Require Import Verdi.Verdi.
Require Import Verdi.LabeledNet.
Require Import Verdi.TotalMapSimulations.
Require Import Verdi.PartialMapSimulations.
Require Import Verdi.TotalMapExecutionSimulations.

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

Require Import FunctionalExtensionality.

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

Require Import Verdi.Ssrexport.
Require Import ssr.ssrbool.

Set Implicit Arguments.

Class LabeledMultiParamsPartialMapCongruency
  (B0 : BaseParams) (B1 : BaseParams)
  (P0 : LabeledMultiParams B0) (P1 : LabeledMultiParams B1)
  (B : BaseParamsPartialMap B0 B1)
  (N : MultiParamsNameTotalMap (@unlabeled_multi_params _ P0) (@unlabeled_multi_params _ P1))
  (P : MultiParamsMsgPartialMap (@unlabeled_multi_params _ P0) (@unlabeled_multi_params _ P1))
  (L : LabeledMultiParamsLabelTotalMap P0 P1) : Prop :=
  {
    pt_lb_label_silent_fst_snd : tot_map_label label_silent = label_silent ;
    pt_lb_net_handlers_some : forall me src m st m' out st' ps lb,
      pt_map_msg m = Some m' ->
      lb_net_handlers (tot_map_name me) (tot_map_name src) m' (pt_map_data st) = (lb, out, st', ps) ->
      lb <> label_silent /\ tot_mapped_lb_net_handlers_label me src m st = lb ;
    pt_lb_net_handlers_none : forall me src m st,
      pt_map_msg m = None ->
      tot_mapped_lb_net_handlers_label me src m st = label_silent ;
    pt_lb_input_handlers_some : forall me inp st inp' out st' ps lb,
      pt_map_input inp = Some inp' ->
      lb_input_handlers (tot_map_name me) inp' (pt_map_data st) = (lb, out, st', ps) ->
      lb <> label_silent /\ tot_mapped_lb_input_handlers_label me inp st = lb ;
    pt_lb_input_handlers_none : forall me inp st,
      pt_map_input inp = None ->
      tot_mapped_lb_input_handlers_label me inp st = label_silent
  }.

Section PartialMapExecutionSimulations.

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 : BaseParamsPartialMap base_fst base_snd}.
Context {name_map : MultiParamsNameTotalMap (@unlabeled_multi_params _ labeled_multi_fst) (@unlabeled_multi_params _ labeled_multi_snd)}.
Context {msg_map : MultiParamsMsgPartialMap (@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 : MultiParamsPartialMapCongruency base_map name_map msg_map}.
Context {multi_map_lb_congr : LabeledMultiParamsPartialMapCongruency base_map name_map msg_map label_map}.

Hypothesis label_eq_dec : forall x y : label, {x = y} + {x <> y}.

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

Hypothesis label_tot_mapped :
  forall l, exists l', l = tot_map_label l'.

(* lb_step_failure *)

Theorem lb_step_failure_pt_mapped_simulation_1_non_silent :
  forall net net' failed failed' lb tr,
    tot_map_label lb <> label_silent ->
    @lb_step_failure _ labeled_multi_fst (failed, net) lb (failed', net') tr ->
    @lb_step_failure _ labeled_multi_snd (List.map tot_map_name failed, pt_map_net net) (tot_map_label lb) (List.map tot_map_name failed', pt_map_net net') (filterMap pt_map_trace_occ tr).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
move => net net' failed failed' lb tr H_neq H_step.
have H_neq': lb <> label_silent.
  rewrite -pt_lb_label_silent_fst_snd in H_neq.
  move => H_eq.
  by rewrite H_eq in H_neq.
invcs H_step => //=.
- destruct (pt_map_packet p) eqn:?; last first.
    destruct p.
    simpl in *.
    break_match => //.
    have H_q := @pt_lb_net_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr pDst pSrc _ (nwState net pDst) Heqo0.
    rewrite /tot_mapped_lb_net_handlers_label in H_q.
    repeat break_let.
    by tuple_inversion.
  have H_eq_n: tot_map_name (pDst p) = pDst p0.
    destruct p.
    simpl in *.
    break_match => //.
    by find_injection.
  rewrite H_eq_n.
  apply (@LabeledStepFailure_deliver _ _ _ _ _ _ (filterMap pt_map_packet xs) (filterMap pt_map_packet ys) (filterMap pt_map_output out) (pt_map_data d) (filterMap (@pt_map_name_msg _ _ _ _ _ msg_map) l)).
  * rewrite /pt_map_net /=.
    find_rewrite.
    by rewrite filterMap_app /= Heqo.
  * rewrite -H_eq_n.
    exact: not_in_failed_not_in.
  * rewrite /pt_map_net /= -{2}H_eq_n tot_map_name_inv_inverse.
    destruct p, p0.
    simpl in *.
    break_match => //.
    find_injection.
    clean.
    have H_q := @pt_net_handlers_some _ _ _ _ _ _ _ multi_map_congr pDst pSrc pBody (nwState net pDst) _ Heqo0.
    rewrite /pt_mapped_net_handlers /net_handlers /= /unlabeled_net_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_net_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ _ Heqo0 Heqp1.
    rewrite /tot_mapped_lb_net_handlers_label in H_q'.
    repeat break_let.
    break_and.
    by repeat tuple_inversion.
  * rewrite /pt_map_net /= 2!filterMap_app.
    by rewrite (filterMap_pt_map_packet_map_eq_some _ _ Heqo) (pt_map_update_eq_some _ _ _ Heqo).
- case H_i: pt_map_input => [inp'|]; last first.
    have H_q := @pt_lb_input_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr h _ (nwState net h) H_i.
    rewrite /tot_mapped_lb_input_handlers_label /= in H_q.
    repeat break_let.
    by tuple_inversion.
  apply (@LabeledStepFailure_input _ _ _ _ _ _ _ _ (pt_map_data d) (filterMap (@pt_map_name_msg _ _ _ _ _ msg_map) l)).
  * exact: not_in_failed_not_in.
  * have H_q := @pt_input_handlers_some _ _ _ _ _ _ _ multi_map_congr h _ (nwState net h) _ H_i.
    rewrite /pt_mapped_input_handlers /input_handlers /= /unlabeled_input_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_input_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ H_i Heqp1.
    break_and.
    unfold tot_mapped_lb_input_handlers_label in *.
    repeat break_let.
    repeat tuple_inversion.
    by rewrite /pt_map_net /= tot_map_name_inv_inverse.
  * rewrite /pt_map_net /=.
    rewrite filterMap_app filterMap_pt_map_packet_map_eq.
    by rewrite -(@pt_map_update_eq  _ _ _ _ _ _ name_map_bijective).
Qed.

Theorem lb_step_failure_pt_mapped_simulation_1_silent :
  forall net net' failed failed' lb tr,
    tot_map_label lb = label_silent ->
    @lb_step_failure _ labeled_multi_fst (failed, net) lb (failed', net') tr ->
    @lb_step_failure _ labeled_multi_snd (List.map tot_map_name failed, pt_map_net net) label_silent (List.map tot_map_name failed', pt_map_net net') [] /\ filterMap trace_non_empty_out (filterMap pt_map_trace_occ tr) = [].
Proof using multi_map_lb_congr multi_map_congr.
move => net net' failed failed' lb tr H_eq H_step.
invcs H_step => //=.
- destruct (pt_map_packet p) eqn:?.
    destruct p, p0.
    simpl in *.
    break_match_hyp => //.
    find_injection.
    have H_q := @pt_net_handlers_some _ _ _ _ _ _ _ multi_map_congr pDst pSrc pBody (nwState net pDst) _ Heqo0.
    rewrite /pt_mapped_net_handlers /net_handlers /= /unlabeled_net_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_net_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ _ Heqo0 Heqp1.
    break_and.
    unfold tot_mapped_lb_net_handlers_label in *.
    repeat break_let.
    by repeat tuple_inversion.
  destruct p.
  simpl in *.
  break_match_hyp => //.
  have H_q := @pt_net_handlers_none _ _ _ _ _ _ _ multi_map_congr pDst pSrc pBody (nwState net pDst) out d l Heqo0.
  rewrite /net_handlers /= /unlabeled_net_handlers in H_q.
  repeat break_let.
  repeat tuple_inversion.
  concludes.
  break_and.
  have H_q' := @pt_lb_net_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr pDst pSrc _ (nwState net pDst) Heqo0.
  rewrite /tot_mapped_lb_net_handlers_label in H_q'.
  repeat break_let.
  repeat tuple_inversion.
  rewrite /pt_map_net /=.
  rewrite filterMap_app.
  rewrite filterMap_pt_map_name_msg_empty_eq //=.
  rewrite H3.
  rewrite filterMap_app /=.
  repeat break_match => //.
  rewrite -filterMap_app.
  set s1 := fun _ => _.
  set s2 := fun _ => _.
  have H_eq_s: s1 = s2.
    rewrite /s1 /s2.
    apply functional_extensionality => n.
    rewrite /update.
    by break_if; first by rewrite H e.
  rewrite -H_eq_s /s1 {s1 s2 H_eq_s}.
  split => //.
  exact: LabeledStepFailure_stutter.
- case H_i: (pt_map_input inp) => [inp'|].
    have H_q := @pt_input_handlers_some _ _ _ _ _ _ _ multi_map_congr h _ (nwState net h) _ H_i.
    rewrite /pt_mapped_input_handlers /input_handlers /= /unlabeled_input_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_input_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ H_i Heqp1.
    break_and.
    unfold tot_mapped_lb_input_handlers_label in *.
    repeat break_let.
    by tuple_inversion.
  have H_q := @pt_input_handlers_none _ _ _ _ _ _ _ multi_map_congr h _ (nwState net h) out d l H_i.
  rewrite /input_handlers /= /unlabeled_input_handlers in H_q.
  repeat break_let.
  repeat tuple_inversion.
  concludes.
  break_and.
  have H_q' := @pt_lb_input_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr h _ (nwState net h) H_i.
  rewrite /tot_mapped_lb_input_handlers_label in H_q'.
  repeat break_let.
  repeat tuple_inversion.
  rewrite /pt_map_net /=.
  rewrite filterMap_app.
  rewrite filterMap_pt_map_name_msg_empty_eq //=.
  set s1 := fun _ => _.
  set s2 := fun _ => _.
  have H_eq_s: s1 = s2.
    rewrite /s1 /s2.
    apply functional_extensionality => n.
    rewrite /update.
    by break_if; first by rewrite H e.
  rewrite -H_eq_s /s1 {s1 s2 H_eq_s}.
  split; first exact: LabeledStepFailure_stutter.
  by repeat find_rewrite.
- split => //; exact: LabeledStepFailure_stutter.
Qed.

(* lb_step_ordered_failure *)

Theorem lb_step_ordered_failure_pt_mapped_simulation_1_non_silent :
  forall net net' failed failed' lb tr,
    tot_map_label lb <> label_silent ->
    @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, pt_map_onet net) (tot_map_label lb) (List.map tot_map_name failed', pt_map_onet net') (filterMap pt_map_trace_ev tr).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
move => net net' failed failed' lb tr H_neq H_step.
have H_neq': lb <> label_silent.
  rewrite -pt_lb_label_silent_fst_snd in H_neq.
  move => H_eq.
  by rewrite H_eq in H_neq.
invcs H_step => //=.
- rewrite {2}/pt_map_onet /=.
  case H_m: (@pt_map_msg _ _ _ _ msg_map m) => [m'|]; last first.
    have H_q := @pt_lb_net_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr to from _ (onwState net to) H_m.
    rewrite /tot_mapped_lb_net_handlers_label in H_q.
    repeat break_let.
    by tuple_inversion.
  apply (@LabeledStepOrderedFailure_deliver _ _ _ _ _ _ m' (filterMap (@pt_map_msg _ _ _ _ msg_map) ms) (filterMap pt_map_output out) (pt_map_data d) (filterMap (@pt_map_name_msg _ _ _ _ _ msg_map) l) (@tot_map_name _ _ _ _ name_map from) (@tot_map_name _ _ _ _ name_map to)).
  * by rewrite /= 2!tot_map_name_inv_inverse /= H3 /= H_m.
  * exact: not_in_failed_not_in.
  * rewrite /pt_map_onet /= tot_map_name_inv_inverse.
    have H_q := @pt_net_handlers_some _ _ _ _ _ _ _ multi_map_congr to from m (onwState net to) _ H_m.
    rewrite /pt_mapped_net_handlers /net_handlers /= /unlabeled_net_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_net_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ _ H_m Heqp1.
    rewrite /tot_mapped_lb_net_handlers_label in H_q'.
    repeat break_let.
    break_and.
    by repeat tuple_inversion.
  * rewrite (@collate_pt_map_update2_eq _ _ _ _ name_map).
    set f1 := fun _ => pt_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 -filterMap_pt_map_trace_ev_outputs_eq.
- rewrite {2}/pt_map_onet /=.
  case H_i: pt_map_input => [inp'|]; last first.
    have H_q := @pt_lb_input_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr h inp (onwState net h) H_i.
    rewrite /tot_mapped_lb_input_handlers_label in H_q.
    repeat break_let.
    by tuple_inversion.
  apply (@LabeledStepOrderedFailure_input _ _ (@tot_map_name _ _ _ _ name_map h) _ _ _ _ (filterMap pt_map_output out) inp' (pt_map_data d) (filterMap (@pt_map_name_msg _ _ _ _ _ msg_map) l)).
  * exact: not_in_failed_not_in.
  * rewrite /pt_map_onet /= tot_map_name_inv_inverse.
    have H_q := @pt_input_handlers_some _ _ _ _ _ _ _ multi_map_congr h inp (onwState net h) _ H_i.
    rewrite /pt_mapped_input_handlers /input_handlers /= /unlabeled_input_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_input_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ H_i Heqp1.
    rewrite /tot_mapped_lb_input_handlers_label in H_q'.
    repeat break_let.
    break_and.
    by repeat tuple_inversion.
  * rewrite {2}/pt_map_onet /=.
    rewrite (@collate_pt_map_eq _ _ _ _ name_map).
    set f1 := fun _ => pt_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 -(@filterMap_pt_map_trace_ev_outputs_eq _ _ _ _ _ name_map out h).
Qed.

Theorem lb_step_ordered_failure_pt_mapped_simulation_1_silent :
  forall net net' failed failed' lb tr,
    tot_map_label lb = label_silent ->
    @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, pt_map_onet net) label_silent (List.map tot_map_name failed', pt_map_onet net') [] /\ filterMap pt_map_trace_ev tr = [].
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
move => net net' failed failed' lb tr H_eq H_step.
invcs H_step => //=.
- rewrite {2}/pt_map_onet /=.
  case H_m: (@pt_map_msg _ _ _ _ msg_map m) => [m'|].
    have H_q := @pt_net_handlers_some _ _ _ _ _ _ _ multi_map_congr to from m (onwState net to) _ H_m.
    rewrite /pt_mapped_net_handlers /net_handlers /= /unlabeled_net_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_net_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ _ H_m Heqp1.
    break_and.
    unfold tot_mapped_lb_net_handlers_label in *.
    repeat break_let.
    by repeat tuple_inversion.
  have H_q := @pt_net_handlers_none _ _ _ _ _ _ _ multi_map_congr to from m (onwState net to) out d l H_m.
  rewrite /net_handlers /= /unlabeled_net_handlers in H_q.
  repeat break_let.
  repeat tuple_inversion.
  concludes.
  break_and.
  have H_q' := @pt_lb_net_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr to from _ (onwState net to) H_m.
  rewrite /tot_mapped_lb_net_handlers_label in H_q'.
  repeat break_let.
  repeat tuple_inversion.
  rewrite /pt_map_onet /=.
  rewrite (@collate_pt_map_update2_eq _ _ _ _ name_map) /=.
  rewrite H0 /=.
  set p1 := fun _ _ => _.
  set p2 := update2 _ _ _ _ _.
  set s1 := fun _ => _.
  set s2 := fun _ => _.
  have H_eq_p: p1 = p2.
    rewrite /p1 /p2 /update2.
    apply functional_extensionality => src.
    apply functional_extensionality => dst.
    break_if => //.
    break_and.
    by rewrite -H2 -H5 2!tot_map_name_inv_inverse H3 /= H_m.
  have H_eq_s: s1 = s2.
    rewrite /s1 /s2 /update.
    apply functional_extensionality => n.
    break_if => //.
    by rewrite H e.
  rewrite H_eq_p H_eq_s.
  split; first exact: LabeledStepOrderedFailure_stutter.
  rewrite (@filterMap_pt_map_trace_ev_outputs_eq _ _ _ _ _ name_map out to).
  by repeat find_rewrite.
- case H_i: (pt_map_input inp) => [inp'|].
    have H_q := @pt_input_handlers_some _ _ _ _ _ _ _ multi_map_congr h _ (onwState net h) _ H_i.
    rewrite /pt_mapped_input_handlers /input_handlers /= /unlabeled_input_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_input_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ H_i Heqp1.
    break_and.
    unfold tot_mapped_lb_input_handlers_label in *.
    repeat break_let.
    by tuple_inversion.
  have H_q := @pt_input_handlers_none _ _ _ _ _ _ _ multi_map_congr h _ (onwState net h) out d l H_i.
  rewrite /input_handlers /= /unlabeled_input_handlers in H_q.
  repeat break_let.
  repeat tuple_inversion.
  concludes.
  break_and.
  have H_q' := @pt_lb_input_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr h _ (onwState net h) H_i.
  rewrite /tot_mapped_lb_input_handlers_label in H_q'.
  repeat break_let.
  repeat tuple_inversion.
  rewrite /pt_map_onet /=.
  rewrite (@collate_pt_map_eq _ _ _ _ name_map) H0 /=.
  set s1 := fun _ => pt_map_data _.
  set s2 := fun _ => pt_map_data _.
  have H_eq_s: s1 = s2.
    rewrite /s1 /s2.
    apply functional_extensionality => n.
    rewrite /update.
    by break_if; first by rewrite H e.
  rewrite -H_eq_s /s1 {s1 s2 H_eq_s}.
  split; first exact: LabeledStepOrderedFailure_stutter.
  rewrite (@filterMap_pt_map_trace_ev_outputs_eq _ _ _ _ _ name_map).
  by repeat find_rewrite.
- by split => //; exact: LabeledStepOrderedFailure_stutter.
Qed.

Definition pt_map_onet_event e :=
{| evt_a := (List.map tot_map_name (fst e.(evt_a)), pt_map_onet (snd e.(evt_a))) ;
   evt_l := tot_map_label e.(evt_l) ;
   evt_trace := filterMap pt_map_trace_ev e.(evt_trace) |}.

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

Lemma lb_step_execution_lb_step_ordered_failure_pt_map_onet_infseq : forall s,
  lb_step_execution lb_step_ordered_failure s ->
  lb_step_execution lb_step_ordered_failure (map pt_map_onet_event s).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr label_eq_dec.
cofix c.
move => s H_exec.
rewrite -pt_map_onet_event_Map_unfold {1}/pt_map_onet_event /=.
inversion H_exec; subst => /=.
rewrite -pt_map_onet_event_Map_unfold /= /pt_map_onet_event /=.
case (label_eq_dec (tot_map_label (evt_l e)) label_silent) => H_eq.
  apply: Cons_lb_step_exec.
  - rewrite H_eq.
    destruct e, e'.
    destruct evt_a, evt_a0.
    simpl in *.
    by eapply lb_step_ordered_failure_pt_mapped_simulation_1_silent; eauto.
  - destruct e, e'.
    destruct evt_a, evt_a0.
    apply (lb_step_ordered_failure_pt_mapped_simulation_1_silent H_eq) in H.
    break_and.
    simpl in *.
    rewrite H0 filterMap_app.
    by aggressive_rewrite_goal.
  - pose s' := Cons e' s0.
    rewrite (pt_map_onet_event_Map_unfold s').
    exact: c.
apply: Cons_lb_step_exec => /=.
- destruct e, e'.
  destruct evt_a, evt_a0.
  simpl in *.
  by eapply lb_step_ordered_failure_pt_mapped_simulation_1_non_silent; eauto.
- by rewrite H0 filterMap_app.
- pose s' := Cons e' s0.
  rewrite (pt_map_onet_event_Map_unfold s').
  exact: c.
Qed.

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

Lemma pt_map_onet_tot_map_label_event_inf_often_occurred_conv :
  forall l s,
    inf_often (now (occurred (tot_map_label l))) (map pt_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 => //.
- exact: extensional_now.
- exact: extensional_now.
- case => e s.
  rewrite /= /occurred /=.
  move => H_eq.
  exact: tot_map_label_injective.
Qed.

Hypothesis lb_step_ordered_failure_strong_fairness_enabled_pt_map_onet_eventually :
  forall l, tot_map_label l <> label_silent ->
    forall s, lb_step_execution lb_step_ordered_failure s ->
    strong_fairness lb_step_ordered_failure label_silent s ->
    enabled lb_step_ordered_failure (tot_map_label l) (pt_map_onet_event (hd s)) ->
    eventually (now (enabled lb_step_ordered_failure l)) s.

Lemma pt_map_onet_tot_map_labeled_event_inf_often_enabled :
  forall l, tot_map_label l <> label_silent ->
    forall s, lb_step_execution lb_step_ordered_failure s ->
    strong_fairness lb_step_ordered_failure label_silent s ->
    inf_often (now (enabled lb_step_ordered_failure (tot_map_label l))) (map pt_map_onet_event s) ->
    inf_often (now (enabled lb_step_ordered_failure l)) s.
Proof using lb_step_ordered_failure_strong_fairness_enabled_pt_map_onet_eventually.
move => l H_neq s H_exec H_fair.
have H_a: ((lb_step_execution lb_step_ordered_failure) /\_ (strong_fairness lb_step_ordered_failure label_silent)) s by auto.
move: H_a {H_exec H_fair}.
apply: always_map_conv_ext => {s}.
  rewrite /and_tl /=.
  move => x s0 [H_e H_w].
  apply lb_step_execution_invar in H_e.
  by apply strong_fairness_invar in H_w.
apply: eventually_map_conv_ext.
- exact: extensional_now.
- exact: extensional_now.
- apply extensional_and_tl.
  * exact: lb_step_execution_extensional.
  * exact: strong_fairness_extensional.
- rewrite /and_tl /=.
  move => x s [H_e H_w].
  apply lb_step_execution_invar in H_e.
  by apply strong_fairness_invar in H_w.
- rewrite /and_tl.
  case => /= x s [H_a H_w] H_en.
  exact: lb_step_ordered_failure_strong_fairness_enabled_pt_map_onet_eventually.
Qed.

Hypothesis lb_step_ordered_failure_weak_fairness_always_enabled_pt_map_onet_continuously :
  forall l, tot_map_label l <> label_silent ->
    forall s, lb_step_execution lb_step_ordered_failure s ->
    weak_fairness lb_step_ordered_failure label_silent s ->
    always (now (enabled lb_step_ordered_failure (tot_map_label l))) (map pt_map_onet_event s) ->
    continuously (now (enabled lb_step_ordered_failure l)) s.

Lemma pt_map_onet_tot_map_labeled_event_state_continuously_enabled :
  forall l, tot_map_label l <> label_silent ->
    forall s, lb_step_execution lb_step_ordered_failure s ->
    weak_fairness lb_step_ordered_failure label_silent s ->
    continuously (now (enabled lb_step_ordered_failure (tot_map_label l))) (map pt_map_onet_event s) ->
    continuously (now (enabled lb_step_ordered_failure l)) s.
Proof using lb_step_ordered_failure_weak_fairness_always_enabled_pt_map_onet_continuously.
move => l H_neq s H_exec H_fair.
have H_a: ((lb_step_execution lb_step_ordered_failure) /\_ (weak_fairness lb_step_ordered_failure label_silent)) s by auto.
move: H_a {H_exec H_fair}.
apply: eventually_map_conv_ext => {s}.
- apply extensional_always.
  exact: extensional_now.
- apply extensional_always.
  exact: extensional_now.
- apply extensional_and_tl.
  * exact: lb_step_execution_extensional.
  * exact: weak_fairness_extensional.
- rewrite /and_tl /=.
  move => x s [H_e H_w].
  apply lb_step_execution_invar in H_e.
  by apply weak_fairness_invar in H_w.
- case => x s [H_a H_w] H_al.
  simpl in *.
  exact: lb_step_ordered_failure_weak_fairness_always_enabled_pt_map_onet_continuously.
Qed.

Lemma pt_map_onet_tot_map_label_event_strong_fairness :
  forall s, lb_step_execution lb_step_ordered_failure s ->
       strong_fairness lb_step_ordered_failure label_silent s ->
       strong_fairness lb_step_ordered_failure label_silent (map pt_map_onet_event s).
Proof using multi_map_lb_congr lb_step_ordered_failure_strong_fairness_enabled_pt_map_onet_eventually label_tot_mapped.
move => s.
rewrite /strong_fairness => H_exec H_fair l H_neq H_en.
have [l' H_l] := label_tot_mapped l.
rewrite H_l.
apply pt_map_onet_tot_map_label_event_inf_often_occurred.
apply H_fair; first by move => H_eq; rewrite H_eq pt_lb_label_silent_fst_snd in H_l.
rewrite H_l in H_en.
unfold inf_enabled in *.
apply: pt_map_onet_tot_map_labeled_event_inf_often_enabled => //.
move => H_eq.
by rewrite -H_l in H_eq.
Qed.

Lemma pt_map_onet_tot_map_label_event_state_weak_fairness :
  forall s, lb_step_execution lb_step_ordered_failure s ->
       weak_fairness lb_step_ordered_failure label_silent s ->
       weak_fairness lb_step_ordered_failure label_silent (map pt_map_onet_event s).
Proof using multi_map_lb_congr lb_step_ordered_failure_weak_fairness_always_enabled_pt_map_onet_continuously label_tot_mapped.
move => s.
rewrite /weak_fairness => H_exec H_fair l H_neq H_en.
have [l' H_l] := label_tot_mapped l.
rewrite H_l.
apply pt_map_onet_tot_map_label_event_inf_often_occurred.
apply H_fair; first by move => H_eq; rewrite H_eq pt_lb_label_silent_fst_snd in H_l.
rewrite H_l in H_en.
unfold cont_enabled in *.
apply: pt_map_onet_tot_map_labeled_event_state_continuously_enabled => //.
move => H_eq.
by rewrite -H_l in H_eq.
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 : FailMsgParamsPartialMapCongruency fail_msg_fst fail_msg_snd msg_map}.

Lemma pt_map_onet_hd_step_ordered_failure_star :
  forall e, event_step_star step_ordered_failure step_ordered_failure_init e ->
       event_step_star step_ordered_failure step_ordered_failure_init (pt_map_onet_event e).
Proof using overlay_map_congr name_map_bijective multi_map_congr fail_msg_map_congr.
move => e.
rewrite /= /pt_map_onet_event /= /event_step_star /=.
move => H_star.
destruct e, evt_a.
simpl in *.
exact: step_ordered_failure_pt_mapped_simulation_star_1.
Qed.

Lemma pt_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 pt_map_onet_event s).
Proof using overlay_map_congr name_map_bijective multi_map_lb_congr multi_map_congr label_eq_dec fail_msg_map_congr.
case => e s H_star H_exec.
apply: step_ordered_failure_star_lb_step_execution; first exact: pt_map_onet_hd_step_ordered_failure_star.
exact: lb_step_execution_lb_step_ordered_failure_pt_map_onet_infseq.
Qed.

(* lb_step_ordered_dynamic_failure *)

Theorem lb_step_ordered_dynamic_failure_pt_mapped_simulation_1_non_silent :
  forall net net' failed failed' lb tr,
    tot_map_label lb <> label_silent ->
    @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, pt_map_odnet net) (tot_map_label lb) (List.map tot_map_name failed', pt_map_odnet net') (filterMap pt_map_trace_ev tr).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
move => net net' failed failed' lb tr H_neq H_step.
have H_neq': lb <> label_silent.
  rewrite -pt_lb_label_silent_fst_snd in H_neq.
  move => H_eq.
  by rewrite H_eq in H_neq.
invcs H_step => //=.
- rewrite {2}/pt_map_odnet /=.
  case H_m: (@pt_map_msg _ _ _ _ msg_map m) => [m'|]; last first.
    have H_q := @pt_lb_net_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr to from _ d H_m.
    rewrite /tot_mapped_lb_net_handlers_label in H_q.
    repeat break_let.
    by tuple_inversion.
  apply (@LabeledStepOrderedDynamicFailure_deliver _ _ _ _ _ _ m' (filterMap (@pt_map_msg _ _ _ _ msg_map) ms) (filterMap pt_map_output out) (pt_map_data d) (pt_map_data d') (filterMap (@pt_map_name_msg _ _ _ _ _ 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.
  * by rewrite /pt_map_odnet /= tot_map_name_inv_inverse H5.
  * by rewrite /pt_map_odnet /= 2!tot_map_name_inv_inverse H6 /= H_m.
  * have H_q := @pt_net_handlers_some _ _ _ _ _ _ _ multi_map_congr to from m d _ H_m.
    rewrite /pt_mapped_net_handlers /net_handlers /= /unlabeled_net_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_net_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ _ H_m Heqp1.
    rewrite /tot_mapped_lb_net_handlers_label in H_q'.
    repeat break_let.
    break_and.
    by repeat tuple_inversion.
  * rewrite {2}/pt_map_odnet /=.
    rewrite (@collate_pt_map_update2_eq _ _ _ _ name_map).
    set f1 := fun _ => match _ with _ => _ end.
    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 (@filterMap_pt_map_trace_ev_outputs_eq _ _ _ _ _ name_map).
- rewrite {2}/pt_map_odnet /=.
  case H_i: pt_map_input => [inp'|]; last first.
    have H_q := @pt_lb_input_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr h inp d H_i.
    rewrite /tot_mapped_lb_input_handlers_label in H_q.
    repeat break_let.
    by tuple_inversion.
  apply (@LabeledStepOrderedDynamicFailure_input _ _ (@tot_map_name _ _ _ _ name_map h) _ _ _ _ (filterMap pt_map_output out) inp' (pt_map_data d) (pt_map_data d') (filterMap (@pt_map_name_msg _ _ _ _ _ msg_map) l)).
  * exact: not_in_failed_not_in.
  * exact: in_failed_in.
  * by rewrite /pt_map_odnet /= tot_map_name_inv_inverse H5.
  * have H_q := @pt_input_handlers_some _ _ _ _ _ _ _ multi_map_congr h inp d _ H_i.
    rewrite /pt_mapped_input_handlers /input_handlers /= /unlabeled_input_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_input_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ H_i Heqp1.
    rewrite /tot_mapped_lb_input_handlers_label in H_q'.
    repeat break_let.
    break_and.
    by repeat tuple_inversion.
  * rewrite {2}/pt_map_odnet /=.
    rewrite (@collate_pt_map_eq _ _ _ _ name_map).
    set f1 := fun _ => match _ with _ => _ end.
    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 (@filterMap_pt_map_trace_ev_outputs_eq _ _ _ _ _ name_map).
Qed.

Theorem lb_step_ordered_dynamic_failure_pt_mapped_simulation_1_silent :
  forall net net' failed failed' lb tr,
    tot_map_label lb = label_silent ->
    @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, pt_map_odnet net) label_silent (List.map tot_map_name failed', pt_map_odnet net') [] /\ filterMap pt_map_trace_ev tr = [].
Proof using name_map_bijective multi_map_lb_congr multi_map_congr.
move => net net' failed failed' lb tr H_eq H_step.
invcs H_step => //=.
- rewrite {2}/pt_map_odnet /=.
  case H_m: (@pt_map_msg _ _ _ _ msg_map m) => [m'|].
    have H_q := @pt_net_handlers_some _ _ _ _ _ _ _ multi_map_congr to from m d _ H_m.
    rewrite /pt_mapped_net_handlers /net_handlers /= /unlabeled_net_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_net_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ _ H_m Heqp1.
    break_and.
    unfold tot_mapped_lb_net_handlers_label in *.
    repeat break_let.
    by repeat tuple_inversion.
  have H_q := @pt_net_handlers_none _ _ _ _ _ _ _ multi_map_congr to from m d out d' l H_m.
  rewrite /net_handlers /= /unlabeled_net_handlers in H_q.
  repeat break_let.
  repeat tuple_inversion.
  concludes.
  break_and.
  have H_q' := @pt_lb_net_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr to from _ d H_m.
  rewrite /tot_mapped_lb_net_handlers_label in H_q'.
  repeat break_let.
  repeat tuple_inversion.
  rewrite /pt_map_odnet /=.
  rewrite (@collate_pt_map_update2_eq _ _ _ _ name_map) /=.
  rewrite H0 /=.
  set p1 := fun _ _ => _.
  set p2 := update2 _ _ _ _ _.
  set s1 := fun _ => _.
  set s2 := fun _ => _.
  have H_eq_p: p1 = p2.
    rewrite /p1 /p2 /update2.
    apply functional_extensionality => src.
    apply functional_extensionality => dst.
    break_if => //.
    break_and.
    by rewrite -H2 -H7 2!tot_map_name_inv_inverse H6 /= H_m.
  have H_eq_s: s1 = s2.
    rewrite /s1 /s2 /update.
    apply functional_extensionality => n.
    break_if => //.
    by rewrite e H5 H.
  rewrite H_eq_p H_eq_s.
  split; first exact: LabeledStepOrderedDynamicFailure_stutter.
  rewrite (@filterMap_pt_map_trace_ev_outputs_eq _ _ _ _ _ name_map).
  by repeat find_rewrite.
- case H_i: (pt_map_input inp) => [inp'|].
    have H_q := @pt_input_handlers_some _ _ _ _ _ _ _ multi_map_congr h _ d _ H_i.
    rewrite /pt_mapped_input_handlers /input_handlers /= /unlabeled_input_handlers in H_q.
    repeat break_let.
    repeat tuple_inversion.
    have H_q' := @pt_lb_input_handlers_some _ _ _ _ _ _ _ _ multi_map_lb_congr _ _ _ _ _ _ _ _ H_i Heqp1.
    break_and.
    unfold tot_mapped_lb_input_handlers_label in *.
    repeat break_let.
    by tuple_inversion.
  have H_q := @pt_input_handlers_none _ _ _ _ _ _ _ multi_map_congr h _ d out d' l H_i.
  rewrite /input_handlers /= /unlabeled_input_handlers in H_q.
  repeat break_let.
  repeat tuple_inversion.
  concludes.
  break_and.
  have H_q' := @pt_lb_input_handlers_none _ _ _ _ _ _ _ _ multi_map_lb_congr h _ d H_i.
  rewrite /tot_mapped_lb_input_handlers_label in H_q'.
  repeat break_let.
  repeat tuple_inversion.
  rewrite /pt_map_odnet /=.
  rewrite (@collate_pt_map_eq _ _ _ _ name_map) H0 /=.
  set s1 := fun _ => match _ with _ => _ end.
  set s2 := fun _ => match _ with _ => _ end.
  have H_eq_s: s1 = s2.
    rewrite /s1 /s2.
    apply functional_extensionality => n.
    rewrite /update.
    by break_if; first by rewrite e H5 H.
  rewrite -H_eq_s /s1 {s1 s2 H_eq_s}.
  split; first exact: LabeledStepOrderedDynamicFailure_stutter.
  rewrite (@filterMap_pt_map_trace_ev_outputs_eq _ _ _ _ _ name_map).
  by repeat find_rewrite.
- split => //; exact: LabeledStepOrderedDynamicFailure_stutter.
Qed.

Definition pt_map_odnet_event e :=
{| evt_a := (List.map tot_map_name (fst e.(evt_a)), pt_map_odnet (snd e.(evt_a))) ;
   evt_l := tot_map_label e.(evt_l) ;
   evt_trace := filterMap pt_map_trace_ev e.(evt_trace) |}.

Lemma pt_map_odnet_event_Map_unfold : forall s,
 Cons (pt_map_odnet_event (hd s)) (map pt_map_odnet_event (tl s)) = map pt_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_pt_map_odnet_infseq : forall s,
  lb_step_execution lb_step_ordered_dynamic_failure s ->
  lb_step_execution lb_step_ordered_dynamic_failure (map pt_map_odnet_event s).
Proof using name_map_bijective multi_map_lb_congr multi_map_congr label_eq_dec.
cofix c.
move => s H_exec.
rewrite -pt_map_odnet_event_Map_unfold {1}/pt_map_odnet_event /=.
inversion H_exec; subst => /=.
rewrite -pt_map_odnet_event_Map_unfold /= /pt_map_odnet_event /=.
case (label_eq_dec (tot_map_label (evt_l e)) label_silent) => H_eq.
  apply: Cons_lb_step_exec => /=.
  - rewrite H_eq.
    destruct e, e'.
    destruct evt_a, evt_a0.
    simpl in *.
    by eapply lb_step_ordered_dynamic_failure_pt_mapped_simulation_1_silent; eauto.
  - destruct e, e'.
    destruct evt_a, evt_a0.
    simpl in *.
    apply (lb_step_ordered_dynamic_failure_pt_mapped_simulation_1_silent H_eq) in H.
    break_and.
    simpl in *.
    rewrite H0 filterMap_app.
    by aggressive_rewrite_goal.
  - pose s' := Cons e' s0.
    rewrite (pt_map_odnet_event_Map_unfold s').
    exact: c.
apply: Cons_lb_step_exec => /=.
- destruct e, e'.
  destruct evt_a, evt_a0.
  simpl in *.
  by eapply lb_step_ordered_dynamic_failure_pt_mapped_simulation_1_non_silent; eauto.
- by rewrite H0 filterMap_app.
- pose s' := Cons e' s0.
  rewrite (pt_map_odnet_event_Map_unfold s').
  exact: c.
Qed.

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

Lemma pt_map_odnet_tot_map_label_event_inf_often_occurred_conv :
  forall l s,
    inf_often (now (occurred (tot_map_label l))) (map pt_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 => //.
- exact: extensional_now.
- exact: extensional_now.
- case => e s.
  rewrite /= /occurred /=.
  move => H_eq.
  exact: tot_map_label_injective.
Qed.

Hypothesis lb_step_ordered_dynamic_failure_strong_fairness_enabled_pt_map_onet_eventually :
  forall l, tot_map_label l <> label_silent ->
    forall s, lb_step_execution lb_step_ordered_dynamic_failure s ->
    strong_fairness lb_step_ordered_dynamic_failure label_silent s ->
    enabled lb_step_ordered_dynamic_failure (tot_map_label l) (pt_map_odnet_event (hd s)) ->
    eventually (now (enabled lb_step_ordered_dynamic_failure l)) s.

Lemma pt_map_odnet_tot_map_labeled_event_inf_often_enabled :
  forall l, tot_map_label l <> label_silent ->
    forall s, lb_step_execution lb_step_ordered_dynamic_failure s ->
    strong_fairness lb_step_ordered_dynamic_failure label_silent s ->
    inf_often (now (enabled lb_step_ordered_dynamic_failure (tot_map_label l))) (map pt_map_odnet_event s) ->
    inf_often (now (enabled lb_step_ordered_dynamic_failure l)) s.
Proof using lb_step_ordered_dynamic_failure_strong_fairness_enabled_pt_map_onet_eventually.
move => l H_neq s H_exec H_fair.
have H_a: ((lb_step_execution lb_step_ordered_dynamic_failure) /\_ (strong_fairness lb_step_ordered_dynamic_failure label_silent)) s by auto.
move: H_a {H_exec H_fair}.
apply: always_map_conv_ext => {s}.
  rewrite /and_tl /=.
  move => x s0 [H_e H_w].
  apply lb_step_execution_invar in H_e.
  by apply strong_fairness_invar in H_w.
apply: eventually_map_conv_ext.
- exact: extensional_now.
- exact: extensional_now.
- apply extensional_and_tl.
  * exact: lb_step_execution_extensional.
  * exact: strong_fairness_extensional.
- rewrite /and_tl /=.
  move => x s [H_e H_w].
  apply lb_step_execution_invar in H_e.
  by apply strong_fairness_invar in H_w.
- rewrite /and_tl.
  case => /= x s [H_a H_w] H_en.
  exact: lb_step_ordered_dynamic_failure_strong_fairness_enabled_pt_map_onet_eventually.
Qed.

Hypothesis lb_step_ordered_dynamic_failure_weak_fairness_always_enabled_pt_map_onet_continuously :
  forall l, tot_map_label l <> label_silent ->
    forall s, lb_step_execution lb_step_ordered_dynamic_failure s ->
    weak_fairness lb_step_ordered_dynamic_failure label_silent s ->
    always (now (enabled lb_step_ordered_dynamic_failure (tot_map_label l))) (map pt_map_odnet_event s) ->
    continuously (now (enabled lb_step_ordered_dynamic_failure l)) s.

Lemma pt_map_odnet_tot_map_labeled_event_state_continuously_enabled :
  forall l, tot_map_label l <> label_silent ->
    forall s, lb_step_execution lb_step_ordered_dynamic_failure s ->
    weak_fairness lb_step_ordered_dynamic_failure label_silent s ->
    continuously (now (enabled lb_step_ordered_dynamic_failure (tot_map_label l))) (map pt_map_odnet_event s) ->
    continuously (now (enabled lb_step_ordered_dynamic_failure l)) s.
Proof using lb_step_ordered_dynamic_failure_weak_fairness_always_enabled_pt_map_onet_continuously.
move => l H_neq s H_exec H_fair.
have H_a: ((lb_step_execution lb_step_ordered_dynamic_failure) /\_ (weak_fairness lb_step_ordered_dynamic_failure label_silent)) s by auto.
move: H_a {H_exec H_fair}.
apply: eventually_map_conv_ext => {s}.
- apply extensional_always.
  exact: extensional_now.
- apply extensional_always.
  exact: extensional_now.
- apply extensional_and_tl.
  * exact: lb_step_execution_extensional.
  * exact: weak_fairness_extensional.
- rewrite /and_tl /=.
  move => x s [H_e H_w].
  apply lb_step_execution_invar in H_e.
  by apply weak_fairness_invar in H_w.
- case => x s [H_a H_w] H_al.
  simpl in *.
  exact: lb_step_ordered_dynamic_failure_weak_fairness_always_enabled_pt_map_onet_continuously.
Qed.

Lemma pt_map_odnet_tot_map_label_event_strong_fairness :
  forall s, lb_step_execution lb_step_ordered_dynamic_failure s ->
       strong_fairness lb_step_ordered_dynamic_failure label_silent s ->
       strong_fairness lb_step_ordered_dynamic_failure label_silent (map pt_map_odnet_event s).
Proof using multi_map_lb_congr lb_step_ordered_dynamic_failure_strong_fairness_enabled_pt_map_onet_eventually label_tot_mapped.
move => s.
rewrite /strong_fairness => H_exec H_fair l H_neq H_en.
have [l' H_l] := label_tot_mapped l.
rewrite H_l.
apply pt_map_odnet_tot_map_label_event_inf_often_occurred.
apply H_fair; first by move => H_eq; rewrite H_eq pt_lb_label_silent_fst_snd in H_l.
rewrite H_l in H_en.
unfold inf_enabled in *.
apply: pt_map_odnet_tot_map_labeled_event_inf_often_enabled => //.
move => H_eq.
by rewrite -H_l in H_eq.
Qed.

Lemma pt_map_odnet_tot_map_label_event_state_weak_fairness :
  forall s, lb_step_execution lb_step_ordered_dynamic_failure s ->
       weak_fairness lb_step_ordered_dynamic_failure label_silent s ->
       weak_fairness lb_step_ordered_dynamic_failure label_silent (map pt_map_odnet_event s).
Proof using multi_map_lb_congr lb_step_ordered_dynamic_failure_weak_fairness_always_enabled_pt_map_onet_continuously label_tot_mapped.
move => s.
rewrite /weak_fairness => H_exec H_fair l H_neq H_en.
have [l' H_l] := label_tot_mapped l.
rewrite H_l.
apply pt_map_odnet_tot_map_label_event_inf_often_occurred.
apply H_fair; first by move => H_eq; rewrite H_eq pt_lb_label_silent_fst_snd in H_l.
rewrite H_l in H_en.
unfold cont_enabled in *.
apply: pt_map_odnet_tot_map_labeled_event_state_continuously_enabled => //.
move => H_eq.
by rewrite -H_l in H_eq.
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 : NewMsgParamsPartialMapCongruency new_msg_fst new_msg_snd msg_map}.

Lemma pt_map_odnet_hd_step_ordered_dynamic_failure_star :
  forall e, event_step_star step_ordered_dynamic_failure step_ordered_dynamic_failure_init e ->
       event_step_star step_ordered_dynamic_failure step_ordered_dynamic_failure_init (pt_map_odnet_event e).
Proof using overlay_map_congr new_msg_map_congr name_map_bijective multi_map_congr fail_msg_map_congr.
move => e.
rewrite /= /pt_map_odnet_event /= /event_step_star /=.
move => H_star.
break_exists.
destruct e, evt_a.
simpl in *.
exact: step_ordered_dynamic_failure_pt_mapped_simulation_star_1.
Qed.

Lemma pt_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 pt_map_odnet_event s).
Proof using overlay_map_congr new_msg_map_congr name_map_bijective multi_map_lb_congr multi_map_congr label_eq_dec fail_msg_map_congr.
case => e s H_star H_exec.
apply: step_ordered_dynamic_failure_star_lb_step_execution; first exact: pt_map_odnet_hd_step_ordered_dynamic_failure_star.
exact: lb_step_execution_lb_step_ordered_dynamic_failure_pt_map_odnet_infseq.
Qed.

End PartialMapExecutionSimulations.


From Coq Require Import
     ssreflect
.

From ExtensibleCompiler.Syntax.Terms Require Import
     If2
.

From ExtensibleCompiler.Syntax.Types Require Import
     BoolType
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Functor
     IndexedAlgebra
     IndexedFunctor
     IndexedProofAlgebra
     IndexedSubFunctor
     ProgramAlgebra
     SubFunctor
     TypeSoundness
     UniversalProperty
.

Local Open Scope SubFunctor.

Section If2.

  Context

    {T}
    `{Functor T}
    `{! T supports BoolType}

    {E}
    `{Functor E}
    `{E supports If2}

    {V}
    `{Functor V}

  .

  Inductive WellTypedValue__If2
            (WTV : (TypedExpr T V)-indexedProp)
    : (TypedExpr T V)-indexedProp
    :=
    | WellTypedValue__if2 : forall t v,
        WTV {| type := t; expr := v |} ->
        WellTypedValue__If2 WTV {| type := t; expr := v |}
  .

  Global Instance IndexedFunctor_WellTypedValue__If2
    : IndexedFunctor (TypedExpr T V) WellTypedValue__If2.
  Proof.
    constructor.
    move => A B i IH [] [t UP__t] [v UP__v] /= => WTV__V.
    econstructor => //; apply IH => //.
  Qed.

  Definition WellTypedValueInversionClear__If2
             (WellTypedValue__V : (TypedExpr T V)-indexedProp)
             (tv : TypedExpr T V)
             (P : (TypedExpr T V)-indexedPropFunctor)
             (IH : forall tau v,
                 {| type := tau; expr := v |} = tv ->
                 WellTypedValue__V {| type := tau; expr := v |} ->
                 P WellTypedValue__V {| type := tau; expr := v |})
             (WT : WellTypedValue__If2 WellTypedValue__V tv)
    : P WellTypedValue__V tv
    :=
      match WT in (WellTypedValue__If2 _ p) return (p = tv -> P WellTypedValue__V tv) with
      | WellTypedValue__if2 _ tau e wtv =>
        fun EQ =>
          eq_ind _ (fun p => P WellTypedValue__V p) (IH _ _ EQ wtv) tv EQ
      end eq_refl.

  (* Definition WellTypedValueInversionStatement__If2 *)
  (*            (WellTypedValue__V : (TypedExpr T V)-indexedPropFunctor) *)
  (*            (te : TypedExpr T V) *)
  (*   := proj1_sig (type te) = boolType -> *)
  (*      WellTypedValue__If2 (IndexedFix WellTypedValue__V) te. *)

  (* Variant ForWellTypedValueInversion__If2 := . *)

  (* Global Instance WellTypedValueInversion__If2 *)
  (*        (WellTypedValue__V : (TypedExpr T V)-indexedPropFunctor) *)
  (*        `{IndexedFunctor (TypedExpr T V) WellTypedValue__V} *)
  (*        `{S : ! IndexedSubFunctor WellTypedValue__If2 WellTypedValue__V} *)
  (*   : IndexedProofAlgebra ForWellTypedValueInversion__If2 *)
  (*                         WellTypedValue__If2 *)
  (*                         (WellTypedValueInversionStatement__If2 WellTypedValue__V). *)
  (* Proof. *)
  (*   constructor. *)
  (*   move => tv [] t v //. *)
  (* Qed. *)

  (* Definition wellTypedValueInversion__If2 *)
  (*            (WellTypedValue__V : (TypedExpr T V)-indexedPropFunctor) *)
  (*            `{IndexedFunctor (TypedExpr T V) WellTypedValue__V} *)
  (*            `{S : ! IndexedSubFunctor WellTypedValue__If2 WellTypedValue__V} *)
  (*            `{A : ! IndexedProofAlgebra ForWellTypedValueInversion__If2 WellTypedValue__V *)
  (*                    (WellTypedValueInversionStatement__If2 WellTypedValue__V)} *)
  (*   :=  ifold (indexedProofAlgebra' A). *)

  Inductive WellTypedExpr__If2
            (WT : (TypedExpr T E)-indexedProp)
    : (TypedExpr T E)-indexedProp
    :=
    | WellTypedExpr__if2 : forall t e condition thenBranch elseBranch,
        proj1_sig e = if2F' condition thenBranch elseBranch ->
        WT {| type := boolType';  expr := condition;  |} ->
        WT {| type := t;          expr := thenBranch |} ->
        WT {| type := t;          expr := elseBranch |} ->
        WellTypedExpr__If2 WT {| type := t; expr := e |}
  .

  Global Instance IndexedFunctor_WellTypedExpr__If2
    : IndexedFunctor (TypedExpr T E) WellTypedExpr__If2.
  Proof.
    constructor.
    move => A B i IH [] [t UP__t] [e UP__e] /= => cond thenB elseB Eq__e.
    move : Eq__e UP__e => -> => UP__e H__c H__t H__e.
    econstructor => //; apply IH => //.
  Qed.

  Definition WellTypedExprInversionClear__If2
             (WellTypedExpr__E : (TypedExpr T E)-indexedProp)
             (te : TypedExpr T E)
             (P : (TypedExpr T E)-indexedPropFunctor)
             (IH : forall tau e cond thenB elseB,
                 {| type := tau; expr := e |} = te ->
                 proj1_sig e = if2F' cond thenB elseB ->
                 P WellTypedExpr__E {| type := tau; expr := e |})
             (WT : WellTypedExpr__If2 WellTypedExpr__E te)
    : P WellTypedExpr__E te
    :=
      match WT in (WellTypedExpr__If2 _ p) return (p = te -> P WellTypedExpr__E te) with
      | WellTypedExpr__if2 _ tau e cond thenB elseB E WT__c WT__t WT__e =>
        fun EQ =>
          eq_ind _ (fun p => P WellTypedExpr__E p) (IH _ _ _ _ _ EQ E) te EQ
      end eq_refl.

  Definition WellTypedExprInversionStatement__If2
             (WellTypedExpr__E : (TypedExpr T E)-indexedPropFunctor)
             (te : TypedExpr T E)
    := proj1_sig (type te) = boolType ->
       WellTypedExpr__If2 (IndexedFix WellTypedExpr__E) te.

  Variant ForWellTypedExprInversion__If2 := .

  Global Instance WellTypedExprInversion__If2
         (WellTypedExpr__E : (TypedExpr T E)-indexedPropFunctor)
         `{IndexedFunctor (TypedExpr T E) WellTypedExpr__E}
         `{S : ! IndexedSubFunctor WellTypedExpr__If2 WellTypedExpr__E}
    : IndexedProofAlgebra ForWellTypedExprInversion__If2
                          WellTypedExpr__If2
                          (WellTypedExprInversionStatement__If2 WellTypedExpr__E).
  Proof.
    constructor.
    move => te [] t e cond thenB elseB P IH__c IH__t IH__e Q.
    apply : (WellTypedExpr__if2 _ _ _ _ _ _ P).
    apply (iInject (IH__c eq_refl)).
    apply (iInject (IH__t Q)).
    apply (iInject (IH__e Q)).
  Qed.

End If2.


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 TableAux.Specs.invalidate_page.
Require Import TableAux.LowSpecs.invalidate_page.
Require Import TableAux.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
       barrier_spec
       stage2_tlbi_ipa_spec
    .

  Lemma invalidate_page_spec_exists:
    forall habd habd'  labd addr
           (Hspec: invalidate_page_spec addr habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', invalidate_page_spec0 addr labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    intros. destruct Hrel. inv id_rdata.
    unfold invalidate_page_spec, invalidate_page_spec0 in *. repeat autounfold in *.
    repeat simpl_hyp Hspec; inv Hspec.
    eexists. split. reflexivity. constructor.
    replace (4096 / 4096) with 1 by reflexivity.
    match goal with
    | |- _ {share: _ {tlbs: ?f1}} = _ {share: _ {tlbs: ?f2}} => assert(f1 = f2)
    end.
    apply func_eq. intros. repeat destruct_if; try reflexivity; repeat destruct_con; repeat destruct_dis; bool_rel; try omega.
    rewrite H. reflexivity.
  Qed.

End Refine.


Require Import Coq.Logic.Classical.
Require Import Coq.Lists.List.
Require Import Coq.Sets.Ensembles.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.Relation_ext.
Require Import CertiGraph.hip.hip_graphmark.
Require Import CertiGraph.msl_ext.seplog.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.weak_mark_lemmas.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.msl_application.Graph.
Require Import CertiGraph.msl_application.GraphBi.
Require Import CertiGraph.msl_application.Graph_Mark.
Require Import CertiGraph.msl_application.GraphBi_Mark.
Import CertiGraph.msl_ext.seplog.OconNotation.

Context {pSGG_Bi: pPointwiseGraph_Graph_Bi}.
Context {sSGG_Bi: sPointwiseGraph_Graph_Bi bool unit}.
Context {SGSA: PointwiseGraphStrongAssum SGP}.

Tactic Notation "LEM" constr(v) := (destruct (classic v); auto).

Module GraphMark <: Mgraphmark.
  Definition formula : Type := pred.
  Definition node : Type := addr.
  Definition null_node : node := null.
  Definition valid : formula -> Prop := fun f => TT |-- f.
  Definition ptto_node : node -> bool -> node -> node -> formula := fun v d l r => vertex_at v (d, l, r).
  Definition A : Type := (@Graph _ bool unit unit).
  Definition graph : node -> A -> formula := fun x g => (@reachable_vertices_at _ _ _ _ _ _ _ _ _ _ SGP _ x (Graph_LGraph g)).
  Definition star : formula -> formula -> formula := sepcon.
  Definition and : formula -> formula -> formula := andp.
  Definition imp : formula -> formula -> formula := imp.
  Definition ext : (bool -> formula) -> formula := exp.
  Definition not : formula -> formula := fun f => prop (f |-- FF).
  Definition eq : node -> node -> formula := fun a b => prop (a = b).
  Definition mwand : formula -> formula -> formula := ewand.
  Definition union : formula -> formula -> formula := ocon.
  Definition neq : bool -> bool -> formula := fun a b => prop (~ a = b).
  Definition mark : A -> node -> A -> formula := fun g1 n g2 => prop (mark n (Graph_LGraph g1) (Graph_LGraph g2)).

  Definition eq_notreach : A -> node -> A -> formula :=
    fun g1 n g2 => prop ((predicate_partial_labeledgraph (Graph_LGraph g1) (Complement _ (reachable (pg_lg (Graph_LGraph g1)) n))) ~=~ (predicate_partial_labeledgraph (Graph_LGraph g2) (Complement _ (reachable (pg_lg (Graph_LGraph g2)) n)))%LabeledGraph).

  Definition subset_reach : A -> node -> A -> formula := fun g1 n g2 => prop (Included (reachable (pg_lg (Graph_LGraph g1)) n) (reachable (pg_lg (Graph_LGraph g2)) n)).

  Definition lookup : A -> node -> bool -> node -> node -> formula :=
    fun g x d l r => prop (vlabel (Graph_LGraph g) x = d /\ vvalid (pg_lg (Graph_LGraph g)) x /\
                           vvalid (pg_lg (Graph_LGraph g)) l /\ vvalid (pg_lg (Graph_LGraph g)) r /\
                           dst (pg_lg (Graph_LGraph g)) (x, L) = l /\ dst (pg_lg (Graph_LGraph g)) (x, R) = r).

  Definition update : A -> node -> bool -> A -> formula :=
    fun g1 x d g2 => prop (Graph_vgen g1 x d = g2).

  Lemma update_is_mark1: forall (l r: addr) (G G1: A) x,
      vvalid (pg_lg (Graph_LGraph G)) x ->
      dst (pg_lg (Graph_LGraph G)) (x, L) = l ->
      dst (pg_lg (Graph_LGraph G)) (x, R) = r ->
      Graph_vgen G x true = G1 ->
      mark1 x (Graph_LGraph G) (Graph_LGraph G1).
  Proof.
    intros. unfold valid in H1.
    rewrite <- H2. split; [|split]; simpl.
    + split; [|split; [|split]]; simpl; intros; auto.
      - unfold change_vvalid. intuition.
      - unfold change_evalid. intuition.
    + unfold update_vlabel. destruct (equiv_dec x x); intuition.
    + intros. unfold update_vlabel. destruct (equiv_dec x n'); intuition.
  Qed.

  Lemma marked_node_marked: forall (G1: A) (n: addr) (G2: A) (x: addr) (v: bool),
      vlabel (Graph_LGraph G1) x = true ->
      WeakMarkGraph.mark n (Graph_LGraph G1) (Graph_LGraph G2) ->
      vlabel (Graph_LGraph G2) x = true.
  Proof.
    intros. unfold WeakMarkGraph.mark. destruct H0 as [? ?]. specialize (H1 x).
    simpl in H1. symmetry. rewrite H1. left; auto.
  Qed.

(* (*TODO: delete it *)
  Lemma axiom_5 : forall v G1 G2 G G3 x l r,
      valid (imp (and (lookup G x v l r)
                      (and (update G x true G1)
                           (and (neq v true) (and (mark G1 r G2) (mark G2 l G3)))))
                 (and (mark G x G3) (lookup G3 x true l r))).
  Proof.
    intros. unfold valid, imp, and, lookup, neq, mark, update.
    apply imp_andp_adjoint. normalize. destruct H as [? [? [? [? [? ?]]]]].
    assert (mark1 x (Graph_LGraph G) (Graph_LGraph (Graph_vgen G x true))) by (apply (update_is_mark1 l r); auto).
    apply andp_right; normalize.
    + apply mark1_mark_list_mark with (r :: l :: nil); auto.
      - simpl. unfold Complement. unfold In.
        subst v. clear - H0. intuition.
      - apply gamma_step_list' with false; auto. simpl.
        do 2 (f_equal; auto). subst v. apply Bool.not_true_is_false in H0. auto.
      - hnf. apply (compond_intro (compond_relation Logic.eq (mark1 x)) _ _ (Graph_LGraph (Graph_vgen G x true)) _).
        apply (compond_intro Logic.eq (mark1 x) (Graph_LGraph G) (Graph_LGraph G) (Graph_LGraph (Graph_vgen G x true))); auto.
        unfold mark_list. simpl. hnf.
        apply (compond_intro
                 (compond_relation Logic.eq (Graph_Mark.mark r)) _ _ (Graph_LGraph G2) _); auto.
          apply (compond_intro Logic.eq (Graph_Mark.mark r) (Graph_LGraph (Graph_vgen G x true)) (Graph_LGraph (Graph_vgen G x true)) (Graph_LGraph G2)); auto.
    + destruct H1, H2, H8. destruct H11 as [? ?]. split.
      - apply (marked_node_marked G2 l); auto. apply (marked_node_marked (Graph_vgen G x true) r); auto.
      - assert ((pg_lg (Graph_LGraph G)) ~=~ (pg_lg (Graph_LGraph G3))) by
            (transitivity (pg_lg (Graph_LGraph (Graph_vgen G x true))); auto; transitivity (pg_lg (Graph_LGraph G2)); auto).
        destruct H13 as [? [? [? ?]]]. split; [|split; [|split; [|split]]].
        * specialize (H13 x); intuition.
        * specialize (H13 l); intuition.
        * specialize (H13 r); intuition.
        * assert (evalid (pg_lg (Graph_LGraph G)) (x, L)) by
              (apply (@left_valid _ _ _ _ _ _ _ (biGraph G)); auto).
          subst l. symmetry. specialize (H16 (x, L)).
          specialize (H14 (x, L)). intuition.
        * assert (evalid (pg_lg (Graph_LGraph G)) (x, R)) by
              (apply (@right_valid _ _ _ _ _ _ _ (biGraph G)); auto).
          subst r. symmetry. specialize (H16 (x, R)).
          specialize (H14 (x, R)). intuition.
  Qed.
  *)
  Lemma axiom_1 : forall v G1 G2 G G3 x l r,
      valid (imp (and (lookup G x v l r)
                      (and (update G x true G1)
                           (and (neq v true) (and (mark G1 l G2) (mark G2 r G3)))))
                 (and (mark G x G3) (lookup G3 x true l r))).
  Proof.
    intros. unfold valid, imp, and, lookup, neq, mark, update.
    apply imp_andp_adjoint. normalize. destruct H as [? [? [? [? [? ?]]]]].
    assert (mark1 x (Graph_LGraph G) (Graph_LGraph (Graph_vgen G x true))) by (apply (update_is_mark1 l r); auto).
    apply andp_right; normalize.
    + apply mark1_mark_list_mark with (l :: r :: nil); auto.
      - simpl. unfold Complement. unfold In.
        subst v. clear - H0. intuition.
      - apply gamma_step_list with false; auto. simpl.
        do 2 (f_equal; auto). subst v. apply Bool.not_true_is_false in H0. auto.
      - hnf. apply (compond_intro (compond_relation Logic.eq (mark1 x)) _ _ (Graph_LGraph (Graph_vgen G x true)) _).
        apply (compond_intro Logic.eq (mark1 x) (Graph_LGraph G) (Graph_LGraph G) (Graph_LGraph (Graph_vgen G x true))); auto.
        unfold mark_list. simpl. hnf.
        apply (compond_intro
                 (compond_relation Logic.eq (Graph_Mark.mark l)) _ _ (Graph_LGraph G2) _); auto.
          apply (compond_intro Logic.eq (Graph_Mark.mark l) (Graph_LGraph (Graph_vgen G x true)) (Graph_LGraph (Graph_vgen G x true)) (Graph_LGraph G2)); auto.
    + destruct H1, H2, H8. destruct H11 as [? ?]. split.
      - apply (marked_node_marked G2 r); auto. apply (marked_node_marked (Graph_vgen G x true) l); auto.
      - assert ((pg_lg (Graph_LGraph G)) ~=~ (pg_lg (Graph_LGraph G3))) by
            (transitivity (pg_lg (Graph_LGraph (Graph_vgen G x true))); auto; transitivity (pg_lg (Graph_LGraph G2)); auto).
        destruct H13 as [? [? [? ?]]]. split; [|split; [|split; [|split]]].
        * specialize (H13 x); intuition.
        * specialize (H13 l); intuition.
        * specialize (H13 r); intuition.
        * assert (evalid (pg_lg (Graph_LGraph G)) (x, L)) by
              (apply (@left_valid _ _ _ _ _ _ _ (biGraph G)); auto).
          subst l. symmetry. specialize (H16 (x, L)).
          specialize (H14 (x, L)). intuition.
        * assert (evalid (pg_lg (Graph_LGraph G)) (x, R)) by
              (apply (@right_valid _ _ _ _ _ _ _ (biGraph G)); auto).
          subst r. symmetry. specialize (H16 (x, R)).
          specialize (H14 (x, R)). intuition.
  Qed.

  Lemma axiom_2 : forall v G x G1 y l r, valid (imp (and (mark G x G1) (lookup G y v l r)) (and (subset_reach G x G1) (and (eq_notreach G x G1) (ext (fun Anon_15 => (lookup G1 y Anon_15 l r)))))).
  Proof.
    intros. unfold valid, imp, and, mark, lookup, subset_reach, eq_notreach.
    apply imp_andp_adjoint. normalize. destruct H0 as [? [? [? [? [? ?]]]]].
    apply andp_right; [|apply andp_right].
    + apply TT_prop_right. destruct H. apply (reachable_ind.si_reachable _ _ x) in H6.
      destruct H6. auto.
    + apply TT_prop_right. destruct H.
      destruct H.
      split; [| split].
      - simpl. rewrite H6; reflexivity.
      - simpl; intros ? [? ?] [? ?].
        apply vlabel_eq.
        rewrite H7.
        assert (~ (pg_lg (Graph_LGraph G)) |= x ~o~> v0
          satisfying (WeakMarkGraph.unmarked (Graph_LGraph G))); [| tauto].
        intro.
        apply reachable_by_is_reachable in H12.
        apply H9; auto.
      - simpl; intros ? [? ?] [? ?].
        match goal with | |- ?A = ?B => destruct A, B; auto end.
      (* rewrite H6; reflexivity. *)
(*
SearchAbout predicate_partialgraph (_ ~=~ _).
Locate si_stronger_partialgraph.
       reflexivity.
      unfold vertices_identical2.
      split; [apply Ensembles_ext.Intersection_proper |].
      1: rewrite Same_set_spec; intro; hnf; apply (proj1 H6).
      1: rewrite H6; reflexivity.
      rewrite vertices_identical_spec; intros.
      specialize (H7 x0).
      simpl in H7 |- *; unfold node in *.
      rewrite Intersection_spec in H8; destruct H8.
      f_equal; [f_equal |].
      - assert (~ reachable_by (pg_lg (Graph_LGraph G)) x (WeakMarkGraph.unmarked (Graph_LGraph G)) x0).
        1: {
          intro.
          apply reachable_by_is_reachable in H10; auto.
        }
        assert (true <> false) by congruence.
        destruct (vlabel (Graph_LGraph G) x0), (vlabel (Graph_LGraph G1) x0); try tauto.
      - apply (si_dst1 _ _ _ H6).
        apply (@left_valid _ _ _ _ _ _ (pg_lg (Graph_LGraph G)) (biGraph G)); auto.
      - apply (si_dst1 _ _ _ H6).
        apply (@right_valid _ _ _ _ _ _ (pg_lg (Graph_LGraph G)) (biGraph G)); auto.
*)
    + unfold ext. destruct H as [[? ?] ?]. specialize (H6 y). simpl in H6.
      destruct H7 as [? [? [? ?]]].
      LEM ((pg_lg (Graph_LGraph G)) |= x ~o~> y satisfying (WeakMarkGraph.unmarked (Graph_LGraph G))).
      - assert (vlabel (Graph_LGraph G1) y = true) by (symmetry; rewrite H6; right; auto).
        apply (exp_right true). normalize. split; [|split;[|split;[|split; [|split]]]]; auto.
        * specialize (H7 y); intuition.
        * specialize (H7 l); intuition.
        * specialize (H7 r); intuition.
        * assert (evalid (pg_lg (Graph_LGraph G)) (y, L)) by
              (apply (@left_valid _ _ _ _ _ _ _ (biGraph G)); auto).
          subst l. symmetry. specialize (H10 (y, L)).
          specialize (H8 (y, L)). intuition.
        * assert (evalid (pg_lg (Graph_LGraph G)) (y, R)) by
              (apply (@right_valid _ _ _ _ _ _ _ (biGraph G)); auto).
          subst r. symmetry. specialize (H10 (y, R)).
          specialize (H8 (y, R)). intuition.
      - apply (exp_right v). normalize. split; [|split;[|split;[|split; [|split]]]].
        * destruct (Bool.bool_dec v true).
          1: rewrite e in *; symmetry; rewrite H6; left; auto.
          apply Bool.not_true_is_false in n. rewrite n in *. clear n.
          apply Bool.not_true_is_false. intro. symmetry in H12. rewrite H6 in H12.
          destruct H12; [|intuition]. apply Bool.diff_true_false. clear - H0 H12.
          rewrite H12. rewrite <- H0. auto.
        * specialize (H7 y); intuition.
        * specialize (H7 l); intuition.
        * specialize (H7 r); intuition.
        * assert (evalid (pg_lg (Graph_LGraph G)) (y, L)) by
              (apply (@left_valid _ _ _ _ _ _ _ (biGraph G)); auto).
          subst l. symmetry. specialize (H10 (y, L)).
          specialize (H8 (y, L)). intuition.
        * assert (evalid (pg_lg (Graph_LGraph G)) (y, R)) by
              (apply (@right_valid _ _ _ _ _ _ _ (biGraph G)); auto).
          subst r. symmetry. specialize (H10 (y, R)).
          specialize (H8 (y, R)). intuition.
  Qed.

  Lemma axiom_3 : forall l r x G, valid (imp (lookup G x true l r) (mark G x G)).
  Proof.
    intros. unfold valid, imp, lookup, mark. rewrite <- iter_sepcon.prop_impl_imp. normalize.
    destruct H as [? [? [? [? [? ?]]]]]. hnf. split; [|reflexivity].
    split; [|split]; [reflexivity | intros..]; [intuition|destruct H5; auto].
    apply reachable_by_head_prop in H5. simpl in H5. unfold Complement in H5. unfold In in H5.
    exfalso; auto.
  Qed.

  Lemma axiom_4 : forall G, valid (mark G null_node G).
  Proof.
    intros. unfold valid, mark, null_node. normalize. hnf. split; [|reflexivity].
    hnf. split; [|intros; split; intros]; [reflexivity | intuition |]. destruct H; auto.
    exfalso. apply reachable_by_head_valid in H.
    apply (@valid_not_null _ _ _ _ _ _ (maGraph G) _) in H; auto. reflexivity.
  Qed.

  Lemma lookup_graph_unfold: forall (G: A) x v l r,
      vlabel (Graph_LGraph G) x = v -> vvalid (pg_lg (Graph_LGraph G)) x -> vvalid (pg_lg (Graph_LGraph G)) l ->
      vvalid (pg_lg (Graph_LGraph G)) r -> dst (pg_lg (Graph_LGraph G)) (x, L) = l ->
      dst (pg_lg (Graph_LGraph G)) (x, R) = r -> (graph x G = ptto_node x v l r ⊗ graph l G ⊗ graph r G).
  Proof.
    intros. unfold graph. unfold ptto_node. apply bi_graph_unfold; auto.
    simpl. f_equal; [f_equal|]; auto.
  Qed.

  Lemma graph_graphs_eq_l:
    forall (G: A) v x l r, vlabel (Graph_LGraph G) x = v -> vvalid (pg_lg (Graph_LGraph G)) x ->
                           vvalid (pg_lg (Graph_LGraph G)) l -> vvalid (pg_lg (Graph_LGraph G)) r ->
                           dst (pg_lg (Graph_LGraph G)) (x, L) = l -> dst (pg_lg (Graph_LGraph G)) (x, R) = r ->
                           (ptto_node x v l r ⊗ (graph l G ⊗ graph r G)) =
                           graph l G ⊗ graphs (x :: l :: r :: nil) (Graph_LGraph G).
  Proof.
    intros. simpl. rewrite ocon_emp. do 3 rewrite <- ocon_assoc.
    rewrite (ocon_comm (graph l G) (graph x G)).
    rewrite (ocon_assoc (graph x G) (graph l G) (graph l G)).
    rewrite <- log_normalize.precise_ocon_self.
    2: apply (bi_graph_precise_left _ x); auto.
    rewrite (lookup_graph_unfold _ x v l r); auto.
    rewrite (ocon_assoc (ptto_node x v l r) (graph l G) (graph r G)).
    rewrite ocon_assoc.
    rewrite (ocon_assoc (ptto_node x v l r) (graph l G ⊗ graph r G)
                        (graph l G ⊗ graph r G)).
    rewrite <- log_normalize.precise_ocon_self; auto. apply precise_ocon.
    + apply (bi_graph_precise_left _ x); auto.
    + apply (bi_graph_precise_right _ x); auto.
  Qed.

  Lemma lem_subgraphupdate_l : forall G v G1 x v1 l r,
      valid (imp (and (star (graph l G1) (mwand (graph l G) (union (ptto_node x v l r) (union (graph l G) (graph r G)))))
                      (and (subset_reach G l G1) (and (eq_notreach G l G1) (and (lookup G x v l r) (lookup G1 x v1 l r)))))
                 (union (ptto_node x v1 l r) (union (graph l G1) (graph r G1)))).
  Proof.
    intros. unfold valid, imp, and, star, mwand, union, subset_reach, eq_notreach, lookup.
    apply imp_andp_adjoint. normalize. apply precise_wand_ewand.
    + apply precise_graph. apply RGF. left; intuition.
    + destruct H1 as [? [? [? [? [? ?]]]]]. destruct H2 as [? [? [? [? [? ?]]]]].
      rewrite (graph_graphs_eq_l G v x l r); auto. rewrite (graph_graphs_eq_l G1 v1 x l r); auto.
      assert (forall (g: A), graph l g = graphs (l :: nil) (Graph_LGraph g)) by (intros; simpl; rewrite ocon_emp; auto).
      rewrite (H13 G). rewrite (H13 G1). apply subgraph_update; auto.
      - intros. left. simpl in H14. destruct H14 as [? | [? | [? | [? | ?]]]]; [subst x0 ..|exfalso]; auto.
      - intros. left. simpl in H14. destruct H14 as [? | [? | [? | [? | ?]]]]; [subst x0 ..|exfalso]; auto.
      - rewrite !reachable_through_set_single'; auto.
  Qed.

  Lemma graph_graphs_eq_r:
    forall (G: A) v x l r, vlabel (Graph_LGraph G) x = v -> vvalid (pg_lg (Graph_LGraph G)) x ->
                           vvalid (pg_lg (Graph_LGraph G)) l -> vvalid (pg_lg (Graph_LGraph G)) r ->
                           dst (pg_lg (Graph_LGraph G)) (x, L) = l -> dst (pg_lg (Graph_LGraph G)) (x, R) = r ->
                           (ptto_node x v l r ⊗ (graph l G ⊗ graph r G)) =
                           graph r G ⊗ graphs (x :: l :: r :: nil) (Graph_LGraph G).
  Proof.
    intros. simpl. rewrite ocon_emp. do 3 rewrite <- ocon_assoc.
    rewrite (ocon_comm (graph r G) (graph x G)).
    rewrite (ocon_assoc (graph x G) (graph r G) (graph l G)).
    rewrite (ocon_comm (graph r G) (graph l G)).
    rewrite <- (ocon_assoc (graph x G) (graph l G) (graph r G)).
    rewrite (ocon_assoc (graph x G ⊗ graph l G) (graph r G) (graph r G)).
    rewrite <- log_normalize.precise_ocon_self.
    2: apply (bi_graph_precise_right _ x); auto.
    rewrite (lookup_graph_unfold _ x v l r); auto.
    rewrite (ocon_assoc (ptto_node x v l r) (graph l G) (graph r G)).
    rewrite ocon_assoc.
    rewrite (ocon_assoc (ptto_node x v l r) (graph l G ⊗ graph r G)
                        (graph l G ⊗ graph r G)).
    rewrite <- log_normalize.precise_ocon_self; auto. apply precise_ocon.
    + apply (bi_graph_precise_left _ x); auto.
    + apply (bi_graph_precise_right _ x); auto.
  Qed.

  Lemma lem_subgraphupdate_r : forall G v G1 x v1 l r, valid (imp (and (star (graph r G1) (mwand (graph r G) (union (ptto_node x v l r) (union (graph l G) (graph r G))))) (and (subset_reach G r G1) (and (eq_notreach G r G1) (and (lookup G x v l r) (lookup G1 x v1 l r))))) (union (ptto_node x v1 l r) (union (graph l G1) (graph r G1)))).
  Proof.
    intros. unfold valid, imp, and, star, mwand, union, subset_reach, eq_notreach, lookup.
    apply imp_andp_adjoint. normalize. apply precise_wand_ewand.
    + apply precise_graph. apply RGF. left; intuition.
    + destruct H1 as [? [? [? [? [? ?]]]]]. destruct H2 as [? [? [? [? [? ?]]]]].
      rewrite (graph_graphs_eq_r G v x l r); auto. rewrite (graph_graphs_eq_r G1 v1 x l r); auto.
      assert (forall (g: A), graph r g = graphs (r :: nil) (Graph_LGraph g)) by (intros; simpl; rewrite ocon_emp; auto).
      rewrite (H13 G). rewrite (H13 G1). apply subgraph_update; auto.
      - intros. left. simpl in H14. destruct H14 as [? | [? | [? | [? | ?]]]]; [subst x0 ..|exfalso]; auto.
      - intros. left. simpl in H14. destruct H14 as [? | [? | [? | [? | ?]]]]; [subst x0 ..|exfalso]; auto.
      - rewrite !reachable_through_set_single'; auto.
  Qed.

  Lemma lem_pttoupdate : forall v l r G x v1 G1, valid (imp (and (star (ptto_node x v1 l r) (mwand (ptto_node x v l r) (union (ptto_node x v l r) (union (graph l G) (graph r G))))) (and (lookup G x v l r) (update G x v1 G1))) (union (ptto_node x v1 l r) (union (graph l G1) (graph r G1)))).
  Proof.
    intros. unfold valid, imp, and, star, mwand, union, subset_reach, eq_notreach, lookup, update.
    apply imp_andp_adjoint. normalize. apply precise_wand_ewand.
    + unfold ptto_node. apply log_normalize.mapsto_precise.
    + destruct H as [? [? [? [? [? ?]]]]]. rewrite <- ocon_assoc. rewrite <- (lookup_graph_unfold G x v l r); auto.
      rewrite <- ocon_assoc.
      assert (vgamma (LGraph_SGraph (Graph_LGraph G)) x = (v, l, r)). {
        simpl. f_equal; [f_equal |]; auto.
      }
      pose proof (Graph_vgen_vgamma G x v v1 l r H5).
      rewrite <- (lookup_graph_unfold (Graph_vgen G x v1) x v1 l r);
        [| inversion H6 | ..|inversion H6|inversion H6]; auto.
      2: rewrite H8; auto.
      apply va_reachable_root_update_ramify; auto.
  Qed.

End GraphMark.


Declare ML Module "magmide_plugin".
Require Import String.
Open Scope string_scope.

Inductive Value :=
	| Const (n: nat)
	| Ref (r: nat)
.

Inductive Instruction :=
	| Return (v: Value)
	| Add (r: nat) (op1: Value) (op2: Value)
.

Magmide "test_code/something.mg" as four.
Check four.
Print four.

MagmideInspectExpr (true).
MagmideInspectExpr (0).
MagmideInspectExpr ("yo").
MagmideInspectExpr (cons true nil).


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition realm_destroy_ops_spec (g_rtt: Pointer) (g_rec_list: Pointer) (g_rd: Pointer) (adt: RData) : option RData :=
    when adt == query_oracle adt;
    rely (peq (base g_rtt) ginfo_loc);
    rely (peq (base g_rec_list) ginfo_loc);
    rely (peq (base g_rd) ginfo_loc);
    let rtt_gidx := offset g_rtt in
    let rec_list_gidx := offset g_rec_list in
    let rd_gidx := offset g_rd in
    rely is_gidx rtt_gidx; rely is_gidx rec_list_gidx; rely is_gidx rd_gidx;
    let grd := (gs (share adt)) @ rd_gidx in
    let grtt := (gs (share adt)) @ rtt_gidx in
    let grecl := (gs (share adt)) @ rec_list_gidx in
    rely prop_dec (glock grd = Some CPU_ID);
    rely prop_dec (glock grtt = Some CPU_ID);
    rely prop_dec (glock grecl = None);
    rely (gtype grecl =? GRANULE_STATE_REC_LIST);
    rely (gtype grd =? GRANULE_STATE_RD);
    rely (gtype grtt =? GRANULE_STATE_TABLE);
    rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
    rely prop_dec ((buffer (priv adt)) @ SLOT_REC_LIST = None);
    rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
    let grd' := grd {gnorm: zero_granule_data_normal} {grec: zero_granule_data_rec}
                    {ginfo: (ginfo grd) {g_tag: GRANULE_STATE_DELEGATED}} in
    let grecl' := grecl {gnorm: zero_granule_data_normal} {grec: zero_granule_data_rec}
                        {ginfo: (ginfo grecl) {g_tag: GRANULE_STATE_DELEGATED}} in
    let grtt' := grtt {gnorm: zero_granule_data_normal} {grec: zero_granule_data_rec}
                      {ginfo: (ginfo grtt) {g_rd: 0} {g_tag: GRANULE_STATE_DELEGATED}} in
    let e := EVT CPU_ID (ACQ rec_list_gidx) in
    let e1 := EVT CPU_ID (REL rtt_gidx grtt') in
    let e' := EVT CPU_ID (REL rec_list_gidx (grecl' {glock: Some CPU_ID})) in
    Some adt {log: e' :: e1 :: e :: (log adt)}
         {share: (share adt) {gs: (gs (share adt)) # rtt_gidx == (grtt' {gtype: GRANULE_STATE_DELEGATED} {glock: None})
                                                   # rec_list_gidx == (grecl' {gtype: GRANULE_STATE_DELEGATED})
                                                   # rd_gidx == grd'}}.

End Spec.


From Coq Require Import String List ZArith Lia.
From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs.
From compcert Require Import Maps Values ClightBigstep Events.

Require Import Clight.max.

Open Scope Z_scope.

Definition max_fspec := Z.max.

Theorem f_max_correct (ge : genv) (e : env) (m : Memory.Mem.mem) :
  forall (ste : temp_env) (n1 n2 : Z),
    (* starting environment *)
    ste ! _n1 = Some (Vint (Int.repr n1)) ->
    ste ! _n2 = Some (Vint (Int.repr n2)) ->

    (* bounds on coq representation *)
    Int.min_signed <= n1 <= Int.max_signed ->
    Int.min_signed <= n2 <= Int.max_signed ->

    (* correct return *)
    exists (t : trace) (rte : temp_env),
      exec_stmt ge e ste m f_max.(fn_body) t rte m
        (Out_return (Some ((Vint (Int.repr (max_fspec n1 n2)), tint)))).
Proof.
  (* the two branches of this proof are exactly the same,
     but have been left as is for simplicity *)
  intros.
  (* introduce existential variables *)
  destruct (Z_le_dec n1 n2).
  all: repeat eexists.
  - econstructor. (* seq *)
    + (* seq1 - ifthenelse *)
      econstructor. (* if *)
      * (* condition *)
        repeat econstructor.
        eassumption.
        eassumption.
        simpl.
        econstructor.
      * (* condition bool *)
        simpl.
        unfold Int.lt.
        repeat rewrite Int.signed_repr by assumption.
        destruct zlt; try omega.
        econstructor.
      * (* set result *)
        destruct negb eqn:N; inversion_clear N.
        repeat econstructor.
        eassumption.
    + (* seq2 - return *)
      econstructor.
      econstructor.
      rewrite PTree.gss.
      try rewrite Z.max_l by lia.
      try rewrite Z.max_r by lia.
      reflexivity.
  - econstructor. (* seq *)
    + (* seq1 - ifthenelse *)
      econstructor. (* if *)
      * (* condition *)
        repeat econstructor.
        eassumption.
        eassumption.
        simpl.
        econstructor.
      * (* condition bool *)
        simpl.
        unfold Int.lt.
        repeat rewrite Int.signed_repr by assumption.
        destruct zlt; try omega.
        econstructor.
      * (* set result *)
        destruct negb eqn:N; inversion_clear N.
        repeat econstructor.
        eassumption.
    + (* seq2 - return *)
      econstructor.
      econstructor.
      rewrite PTree.gss.
      try rewrite Z.max_l by lia.
      try rewrite Z.max_r by lia.
      reflexivity.
Qed.


(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
From mathcomp Require Import all_ssreflect.
From HB Require Import structures.
Require Import imonae_lib ihierarchy imonad_lib imonad_transformer.

(******************************************************************************)
(*   Uniform Lifting of Sigma-operations Along Functorial Monad Transformers  *)
(*                                                                            *)
(* This file corresponds to the formalization of [Mauro Jaskelioff,           *)
(* Modular Monad Transformers, ESOP 2009] (from Sect. 5, definition 23).      *)
(*                                                                            *)
(*            codensityT == codensity monad transformer                       *)
(*              slifting == definition of a sigma-operation using a           *)
(*                          sigma-operation and a functorial monad            *)
(*                          transformer                                       *)
(* uniform_sigma_lifting == Theorem: given a functorial monad transformer t,  *)
(*                          slifting is a lifting along Lift t                *)
(*       slifting_stateT == lifting of a sigma-operation along stateT         *)
(*      slifting_exceptT == lifting of a sigma-operation along exceptT        *)
(*         slifting_envT == lifting of a sigma-operation along envT           *)
(*      slifting_outputT == lifting of a sigma-operation along outputT        *)
(*   slifting_alifting_* == Lemmas: slifting and alifting of algebraic        *)
(*                          operations coincide                               *)
(*              local_*E == Lemmas: liftings of local                         *)
(*             handle_*E == Lemmas: liftings of handle                        *)
(*              flush_*E == Lemmas: liftings of flush                         *)
(******************************************************************************)

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

Local Open Scope monae_scope.

Definition MK (m : UU0 -> UU0) (A : UU0) := forall (B : UU0), (A -> m B) -> m B.

Section codensity.
Variable (M : monad).

Definition retK : FId ~~> MK M :=
  fun (A : UU0) (a : A) (B : UU0) (k : A -> M B) => k a.

Definition bindK (A B : UU0) (m : MK M A) f : MK M B :=
  fun (C : UU0) (k : B -> M C) => m C (fun a : A => (f a) C k).

Let left_neutral : BindLaws.left_neutral bindK retK.
Proof.
by move=> A B a f; rewrite /bindK /=; apply funext_dep => C; exact: funext.
Qed.

Let right_neutral : BindLaws.right_neutral bindK retK.
Proof.
by move=> A m; rewrite /bindK /retK; apply funext_dep => C; exact: funext.
Qed.

Lemma associative : BindLaws.associative bindK.
Proof. by move=> A B C m f g; rewrite /bindK; exact: funext_dep. Qed.

HB.instance Definition _ :=
  isMonad_ret_bind.Build (MK M) left_neutral right_neutral associative.

Definition liftK : M ~~> MK M :=
  fun (A : UU0) (m : M A) (B : UU0) (k : A -> M B) => m >>= k.

Let retliftK : MonadMLaws.ret liftK.
Proof.
move=> A; rewrite /liftK/= /retK/=; apply funext => a.
by apply funext_dep => B /=; apply: funext => b; rewrite bindretf.
Qed.

Let bindliftK : MonadMLaws.bind liftK.
Proof.
move=> A B m f; rewrite /liftK; apply funext_dep => C /=.
by apply funext => g; rewrite bindA.
Qed.

HB.instance Definition _ := isMonadM_ret_bind.Build
  M [the monad of MK M] liftK retliftK bindliftK.

End codensity.

Definition codensityT := fun M : monad => [the monad of MK M].

HB.instance Definition _ :=
  isMonadT.Build codensityT (fun M => [the monadM _ _ of @liftK M]).

Section kappa.
Variables (M : monad) (E : functor) (op : E.-operation M).

Definition kappa' : E ~~> codensityT M :=
  fun (A : UU0) (s : E A) (B : UU0) (k : A -> M B) =>
    op B ((E # k) s).

Lemma naturality_kappa' : naturality _ _ kappa'.
Proof.
move=> A B h; rewrite /kappa'; apply funext => ea; rewrite [in RHS]/=.
transitivity (fun B0 (k : B -> M B0) => op B0 ((E # (k \o h)) ea)) => //.
by apply funext_dep => C; apply funext => D; rewrite functor_o.
Qed.

HB.instance Definition _ := isNatural.Build
  _ (codensityT M) kappa' naturality_kappa'.

Definition kappa := [the _ ~> _ of kappa'].

Lemma kappaE X : kappa X =
  fun (s : E X) (B : UU0) (k : X -> M B) => op B ((E # k) s).
Proof. by []. Qed.

End kappa.

Definition naturality_MK (M : functor) (A : UU0) (m : MK M A) :=
  naturality [the functor of exponential_F A \o M] M m.

Section from.
Variables (M : monad).

Definition from_component : codensityT M ~~> M :=
  fun (A : UU0) (c : codensityT M A) => c A Ret.

Hypothesis naturality_MK : forall (A : UU0) (m : MK M A),
  naturality_MK m.

Lemma natural_from_component : naturality (codensityT M) M from_component.
Proof.
move=> A B h; apply funext => m /=.
rewrite [RHS](_ : _ = m B (Ret \o h)) //. (* by definition of from *)
rewrite -natural.
rewrite [LHS](_ : _ = (M # h \o m A) Ret) //. (* by definition of from *)
by rewrite naturality_MK.
Qed.

HB.instance Definition _ :=
  isNatural.Build _ M from_component natural_from_component.

Definition from := [the _ ~> _ of from_component].

Lemma from_component_liftK A :
  @from_component A \o Lift [the monadT of codensityT] M A = id.
Proof.
by apply funext => m /=; rewrite /from_component/= /liftK /= bindmret.
Qed.

End from.

Section psi_kappa.
Variables (E : functor) (M : monad) (op : E.-operation M).

Definition psik : E.-aoperation (codensityT M) := psi (kappa op).

Lemma psikE (A : UU0) : op A = (@from_component M A) \o (@psik A) \o
  ((E ## Lift [the monadT of codensityT] M) A).
Proof.
apply funext => m /=.
rewrite /from_component /psik /= /psi' /kappa' /fun_app_nt /=.
rewrite /bindK /=.
rewrite -[in RHS]compE.
rewrite -[in RHS]compE.
rewrite -compA.
rewrite -functor_o.
rewrite from_component_liftK.
rewrite functor_id.
by rewrite compfid.
Qed.

End psi_kappa.

Section uniform_sigma_lifting.
Variables (E : functor) (M : monad) (op : E.-operation M) (t : fmt).
Hypothesis naturality_MK : forall (A : UU0) (m : MK M A), naturality_MK m.

Let op1 : t (codensityT M) ~> t M := hmap t (from naturality_MK).
Let op2 := alifting (psik op) (Lift t _).
Let op3 : [the functor of E \o t M] ~> [the functor of E \o t (codensityT M)] :=
  E ## hmap t (Lift [the monadT of codensityT] M).

Definition slifting : E.-operation (t M) := op1 \v op2 \v op3.

Theorem uniform_sigma_lifting : lifting_monadT op slifting.
Proof.
rewrite /lifting_monadT /slifting => X.
apply/esym.
transitivity ((op1 \v op2) X \o op3 X \o E # Lift t M X).
  by rewrite (vassoc op1) vcompE/= !vcompE.
rewrite -compA.
transitivity ((op1 \v op2) X \o
    ((E # Lift t (codensityT M) X) \o
    (E # Lift [the monadT of codensityT] M X))).
  congr (_ \o _); rewrite /op3.
  by rewrite -functor_o -natural_hmapE functor_app_naturalE -(@functor_o E).
transitivity (op1 X \o
  (op2 X \o E # Lift t (codensityT M) X) \o E # Lift [the monadT of codensityT] M X).
  by rewrite vcompE -compA.
rewrite -uniform_algebraic_lifting.
transitivity (Lift t M X \o from naturality_MK X \o (psik op) X \o
  E # Lift [the monadT of codensityT] M X).
  congr (_ \o _).
  by rewrite compA natural_hmapE.
rewrite -2!compA.
congr (_ \o _).
by rewrite compA -psikE.
Qed.
End uniform_sigma_lifting.

(* example 29 *)
Section slifting_instances.

Variables (E : functor) (M : monad) (op : E.-operation M).
Hypothesis naturality_MK : forall (A : UU0) (m : MK M A), naturality_MK m.

Section slifting_stateT.
Variable S : UU0.

Let tau (X : UU0) s (f : S -> M (X * S)%type) := f s.

Let op' : E \o stateT S M ~~> stateT S M :=
  fun (X : UU0) t s => op (X * S)%type ((E # tau s) t).

Lemma slifting_stateT (X : UU0) :
  (slifting op [the fmt of stateT S] naturality_MK) X = @op' _.
Proof.
apply funext => emx.
rewrite /op'.
apply funext => s.
rewrite /slifting.
rewrite 2!vcompE.
set h := hmap _.
rewrite [in RHS](psikE op).
rewrite 2!functor_app_naturalE.
rewrite /=.
congr (from_component _).
apply funext_dep => A; apply funext => f.
rewrite {1}/psi' /=.
rewrite /bindS /=.
rewrite vcompE/=.
rewrite /liftS /=.
rewrite bindA.
set ret_id := (X in _ >>= X).
have -> : ret_id = fun (x : MS S (codensityT M) X) (C : UU0) => (fun t => x s C t).
  by apply funext.
rewrite /psi' /= /bindK /kappa' /=.
congr (op A).
rewrite -2![in LHS](compE _ _ emx) -2![in RHS](compE _ _ emx).
by rewrite -!functor_o.
Qed.

End slifting_stateT.

Section slifting_exceptT.
Variable Z : UU0.

Let op' : E \o exceptT Z M ~~> exceptT Z M := fun (Y : UU0) => @op _.

Lemma slifting_exceptT (X : UU0) :
  (slifting op [the fmt of exceptT Z] naturality_MK) X = @op' X.
Proof.
apply funext => emx.
rewrite /op'.
rewrite (psikE op (Z + X)%type).
rewrite /slifting.
rewrite 2!vcompE.
set h := hmap _.
rewrite /=.
f_equal.
rewrite /psi' /=.
rewrite /bindX bindE /=.
apply funext_dep => A; apply funext => k.
rewrite vcompE/=.
rewrite /liftX /=.
rewrite bindE /= /bindK /=.
rewrite /psi' /= /bindK /=.
rewrite /kappa' /=.
congr (op _ _).
rewrite -(compE (E # _)).
by rewrite -functor_o.
Qed.

End slifting_exceptT.

Section slifting_envT.
Variable Env : UU0.

Let tau (X : UU0) e (f : Env -> M X) := f e.

Let op' : E \o envT Env M ~~> envT Env M :=
  fun (X : UU0) t => fun e => op X ((E # tau e) t).

Lemma slifting_envT (X : UU0) :
  (slifting op [the fmt of envT Env] naturality_MK) X = @op' _.
Proof.
apply funext => emx.
rewrite /op'.
apply funext => s.
rewrite /slifting.
rewrite 2!vcompE.
set h := hmap _.
rewrite (psikE op).
rewrite 2!functor_app_naturalE.
rewrite /=.
congr (from_component _).
apply funext_dep => A; apply funext => f.
rewrite {1}/psi' /=.
rewrite /bindEnv /=.
rewrite vcompE/=.
rewrite bindE /= /bindK.
rewrite fmapE /bindK.
rewrite /liftEnv /=.
rewrite -(compE _ _ emx) -functor_o.
rewrite -[in RHS](compE _ _ emx) -functor_o.
rewrite /psi' /= /bindK /= /kappa' /=.
congr (op A).
rewrite -(compE _ _ emx) -[in RHS](compE _ _ emx).
by rewrite -2!functor_o.
Qed.

End slifting_envT.

Section slifting_outputT.
Variable R : UU0.

Let op' : E \o outputT R M ~~> outputT R M :=
  fun (X : UU0) => @op (X * seq R)%type.

Lemma slifting_outputT (X : UU0) :
  (slifting op [the fmt of outputT R] naturality_MK) X = @op' _.
Proof.
apply funext => emx.
rewrite /op'.
rewrite /slifting.
rewrite 2!vcompE.
set h := hmap _.
rewrite (psikE op).
rewrite 2!functor_app_naturalE.
rewrite /=.
f_equal.
rewrite /psi' /= /bindK /bindO /= bindE /= /bindK /=.
apply funext_dep => A; apply funext => f.
rewrite fmapE /bindK.
rewrite vcompE/=.
rewrite /liftO /=.
rewrite -(compE _ _ emx) -functor_o.
rewrite bindE /= /bindK /=.
rewrite fmapE.
rewrite /bindK.
rewrite /psi' /= /bindK /= /kappa' /=.
congr (op A).
rewrite -(compE _ _ emx) -[in RHS](compE _ _ emx).
rewrite -2!functor_o.
congr ((E # _) _).
apply funext => rmx /=.
rewrite /retK /= bindE fmapE /= /bindK.
congr (Lift [the monadT of codensityT] M _ _ _ _).
by apply funext => -[].
Qed.

End slifting_outputT.

End slifting_instances.

(* proposition 28 *)
Section slifting_alifting_coincide.

Variables (E : functor) (M : monad) (aop : E.-aoperation M).
Hypothesis naturality_MK : forall (A : UU0) (m : MK M A),
  naturality_MK m.

Lemma slifting_alifting_stateFMT (S : UU0) (t := [the fmt of stateT S]) :
  slifting aop t naturality_MK = alifting aop (Lift t M).
Proof.
apply nattrans_ext => X.
rewrite (slifting_stateT aop naturality_MK S).
apply funext => m; apply funext => s.
rewrite /alifting.
rewrite /=.
rewrite psiE /=.
rewrite /bindS.
rewrite vcompE/=.
rewrite /liftS/=.
rewrite 2!algebraic.
congr (aop _ _).
rewrite -[RHS](compE _ (E # _)).
rewrite -functor_o.
rewrite -[RHS](compE _ (E # _)).
rewrite -functor_o.
congr ((E # _) m).
apply funext => x /=.
by rewrite 2!bindretf.
Qed.

Lemma slifting_alifting_exceptFMT (Z : UU0) (t := [the fmt of exceptT Z]) :
  slifting aop t naturality_MK = alifting aop (Lift t M).
Proof.
apply nattrans_ext => X.
rewrite (slifting_exceptT aop naturality_MK Z).
apply funext => m.
rewrite /alifting.
rewrite /=.
rewrite psiE /= /bindX.
rewrite vcompE/=.
rewrite /liftX.
rewrite 2!algebraic.
congr (aop _ _).
rewrite -[RHS](compE _ (E # _)).
rewrite -functor_o.
rewrite -[RHS](compE _ (E # _)).
rewrite -functor_o.
rewrite (_ : _ \o Ret = id) ?functor_id //.
apply funext => n /=.
by rewrite 2!bindretf.
Qed.

Lemma slifting_alifting_envFMT (Env : UU0) (t := [the fmt of envT Env]) :
  slifting aop t naturality_MK = alifting aop (Lift t M).
Proof.
apply nattrans_ext => X.
rewrite (slifting_envT aop naturality_MK Env).
apply funext => m; apply funext => e.
rewrite /alifting.
rewrite /=.
rewrite psiE /= /bindEnv.
rewrite vcompE/=.
rewrite /liftEnv.
rewrite algebraic.
congr (aop _ _).
rewrite -[RHS](compE _ (E # _)).
rewrite -functor_o.
congr ((E # _) m).
apply funext => x /=.
by rewrite bindretf.
Qed.

Lemma slifting_alifting_outputFMT (R : UU0) (t := [the fmt of outputT R]) :
  slifting aop t naturality_MK = alifting aop (Lift t M).
Proof.
apply nattrans_ext => X.
rewrite (slifting_outputT aop naturality_MK R).
apply funext => m.
rewrite /alifting.
rewrite /=.
rewrite psiE /= /bindO.
rewrite vcompE/=.
rewrite /liftO.
rewrite 2!algebraic.
congr (aop _ _).
rewrite -[RHS](compE _ (E # _)).
rewrite -functor_o.
rewrite -[RHS](compE _ (E # _)).
rewrite -functor_o.
rewrite (_ : _ \o Ret = id) ?functor_id //.
apply funext => n /=.
rewrite 2!bindretf.
Open (X in _ >>= X).
  by case : x => ? ?; rewrite cat0s.
by rewrite bindmret.
Qed.

End slifting_alifting_coincide.

Require Import imonad_model.

(* example 30 *)
Section slifting_local.
Variable Env : UU0.
Let E := [the functor of Local.acto Env].
Let M := [the monad of EnvironmentMonad.acto Env].
Let local : E.-operation M := local_op Env.
Hypothesis naturality_MK : forall (A : UU0) (m : MK M A), naturality_MK m.

Section slifting_local_FMT.
Variable T : fmt.

Definition localKT (f : Env -> Env) : T (codensityT M) ~~> T (codensityT M) :=
  fun (X : UU0) t => Join
    (Lift T (codensityT M) (T (codensityT M) X) (fun Y k => local Y (f, k t))).

Definition localT (f : Env -> Env) : T M ~~> T M :=
  fun X t => let t' := hmap T (Lift [the monadT of codensityT] M) X t in
  hmap T (from naturality_MK) X (localKT f t').

End slifting_local_FMT.

Section slifting_local_stateT.
Variable S : UU0.

Definition local_stateT (f : Env -> Env) : stateT S M ~~> stateT S M :=
  fun X t s e => t s (f e).

Let local_stateT' : (E \o stateT S M) ~~> (stateT S M) :=
  fun X => uncurry (@local_stateT ^~ X).

Lemma local_stateTE (X : UU0) :
  (slifting local [the fmt of stateT S] naturality_MK) X = @local_stateT' X.
Proof. by rewrite slifting_stateT; apply funext => -[]. Qed.
End slifting_local_stateT.

Section slifting_local_exceptT.
Variable Z : UU0.
Definition local_exceptT (f : Env -> Env) : exceptT Z M ~~> exceptT Z M :=
  fun X t e => t (f e).

Let local_exceptT' : (E \o exceptT Z M) ~~> (exceptT Z M) :=
  fun X => uncurry (@local_exceptT ^~ X).

Lemma local_exceptTE (X : UU0) :
  (slifting local [the fmt of exceptT Z] naturality_MK) X = @local_exceptT' X.
Proof. by rewrite slifting_exceptT; apply funext => -[]. Qed.

End slifting_local_exceptT.

Section slifting_local_envT.
Variable Z : UU0.
Definition local_envT (f : Env -> Env) : envT Z M ~~> envT Z M :=
  fun X t e e' => t e (f e').

Let local_envT' : E \o envT Z M ~~> envT Z M :=
  fun X => uncurry (@local_envT ^~ X).

Lemma local_envTE (X : UU0) :
  (slifting local [the fmt of envT Z] naturality_MK) X = @local_envT' X.
Proof.
rewrite slifting_envT.
by apply funext => -[].
Qed.
End slifting_local_envT.

Section slifting_local_outputT.
Variable R : UU0.
Definition local_outputT (f : Env -> Env) : outputT R M ~~> outputT R M :=
  fun (X : UU0) t e => t (f e).

Let local_outputT' : E \o outputT R M ~~> outputT R M :=
  fun (X : UU0) => uncurry (@local_outputT ^~ X).

Lemma local_outputTE (X : UU0) :
  (slifting local [the fmt of outputT R] naturality_MK) X = @local_outputT' X.
Proof. by rewrite slifting_outputT; apply funext => -[]. Qed.
End slifting_local_outputT.

End slifting_local.

(* example 31 *)
Section slifting_handle. (* except monad with Z = unit *)
Let E := [the functor of Handle.acto unit].
Let M := [the monad of ExceptMonad.acto unit].
Let handle : E.-operation M := @handle_op unit.
Hypothesis naturality_MK : forall (A : UU0) (m : MK M A),
  naturality_MK m.

Section slifting_handle_stateT.
Variable S : UU0.
Definition handle_stateT (X : UU0) (t : stateT S M X) (h : unit -> stateT S M X)
  : stateT S M X := fun s => match t s with
    | inl z(*unit*) => h z s
    | inr x => inr x
    end.

Let handle_stateT' : (E \o stateT S M) ~~> (stateT S M) :=
  fun (X : UU0) => uncurry (@handle_stateT X).

Lemma handle_stateTE (X : UU0) :
  (slifting handle [the fmt of stateT S] naturality_MK) X = @handle_stateT' X.
Proof. by rewrite slifting_stateT; apply funext => -[m f]. Qed.
End slifting_handle_stateT.

Section slifting_handle_exceptT.
Variable Z : UU0.
Definition handle_exceptT (X : UU0) (t : exceptT Z M X)
  (h : unit -> exceptT Z M X) : exceptT Z M X := match t with
    | inl z(*unit*) => h z
    | inr x => inr x
    end.

Let handle_exceptT' : E \o exceptT Z M ~~> exceptT Z M :=
  fun (X : UU0) => uncurry (@handle_exceptT X).

Lemma handle_exceptTE (X : UU0) :
  (slifting handle [the fmt of exceptT Z] naturality_MK) X = @handle_exceptT' X.
Proof. by rewrite slifting_exceptT; exact: funext. Qed.
End slifting_handle_exceptT.

Section slifting_handle_envT.
Variable Z : UU0.
Definition handle_envT (X : UU0) (t : envT Z M X) (h : unit -> envT Z M X)
  : envT Z M X := fun e => match t e with
    | inl z(*unit*) => h z e
    | inr x => inr x
    end.

Let handle_envT' : E \o envT Z M ~~> envT Z M :=
  fun (X : UU0) => uncurry (@handle_envT X).

Lemma handle_envTE (X : UU0) :
  (slifting handle [the fmt of envT Z] naturality_MK) X = @handle_envT' X.
Proof.
by rewrite slifting_envT; apply funext => -[m f]; exact: funext.
Qed.
End slifting_handle_envT.

Section slifting_handle_outputT.
Variable R : UU0.
Definition handle_outputT (X : UU0) (t : outputT R M X)
  (h : unit -> outputT R M X) : outputT R M X := match t with
    | inl z(*unit*) => h z
    | inr x => inr x
    end.

Let handle_outputT' : E \o outputT R M ~~> outputT R M :=
  fun (X : UU0) => uncurry (@handle_outputT X).

Lemma handle_outputTE (X : UU0) :
  (slifting handle [the fmt of outputT R] naturality_MK) X = @handle_outputT' X.
Proof. by rewrite slifting_outputT; apply funext => -[]. Qed.
End slifting_handle_outputT.

End slifting_handle.

(* example 32 *)
Section slifting_flush.
Variable R : UU0.
Let E := [the functor of Flush.acto].
Let M := [the monad of OutputMonad.acto R].
Let flush : E.-operation M := flush_op R.
Hypothesis naturality_MK : forall (A : UU0) (m : MK M A),
  naturality_MK m.

Section slifting_flush_stateT.
Variable S : UU0.
Definition flush_stateT : stateT S M ~~> stateT S M :=
  fun (X : UU0) t s => let: (x, _) := t s in (x, [::]).

Lemma flush_stateTE (X : UU0) :
  (slifting flush [the fmt of stateT S] naturality_MK) X = @flush_stateT X.
Proof. by rewrite slifting_stateT. Qed.
End slifting_flush_stateT.

Section slifting_flush_exceptT.
Variable Z : UU0.
Definition flush_exceptT (X : UU0) (t : exceptT Z M X) (h : Z -> exceptT Z M X)
    : exceptT Z M X :=
  let: (c, _) := t in (c, [::]).

Let flush_exceptT' : E \o exceptT Z M ~~> exceptT Z M :=
  fun (X : UU0) c => let : (x, _) := c in (x, [::]).

Lemma flush_exceptTE (X : UU0) :
  (slifting flush [the fmt of exceptT Z] naturality_MK) X = @flush_exceptT' X.
Proof. by rewrite slifting_exceptT. Qed.
End slifting_flush_exceptT.

Section slifting_flush_envT.
Variable Z : UU0.
Definition flush_envT : envT Z M ~~>  envT Z M :=
  fun (X : UU0) t e => let: (x, _) := t e in (x, [::]).

Lemma flush_envTE (X : UU0) :
  (slifting flush [the fmt of envT Z] naturality_MK) X = @flush_envT X.
Proof. by rewrite slifting_envT. Qed.
End slifting_flush_envT.

Section slifting_flush_outputT.
Variable Z : UU0.
Definition flush_outputT (X : UU0) (t : outputT R M X) (h : Z -> outputT R M X)
  : outputT R M X := let: (p, w) := t in (p, [::]).

Let flush_outputT' : E \o outputT R M ~~> outputT R M :=
  fun (X : UU0) e => let: (pw, w') := e in (pw, [::]).

Lemma flush_outputTE (X : UU0) :
  (slifting flush [the fmt of outputT R] naturality_MK) X = @flush_outputT' X.
Proof. by rewrite slifting_outputT; exact: funext. Qed.
End slifting_flush_outputT.

End slifting_flush.


Require Import ExtLib.Tactics.
Require Import MirrorCore.RTac.Core.
Require Import MirrorCore.RTac.CoreK.

Require Import MirrorCore.Util.Forwardy.

Set Implicit Arguments.
Set Strict Implicit.

Section parameterized.
  Context {typ : Set}.
  Context {expr : Set}.

  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Expr_expr : Expr typ expr}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {ExprUVar_expr : ExprUVar expr}.

  Definition THEN (c1 : rtac typ expr)
             (c2 : rtacK typ expr)
  : rtac typ expr :=
    fun ctx sub g =>
      match c1 ctx sub g with
        | More_ sub' g' => c2 _ sub' g'
        | Solved sub => Solved sub
        | Fail => Fail
      end.

  Theorem THEN_sound
  : forall (tac1 : rtac typ expr) (tac2 : rtacK typ expr),
      rtac_sound tac1 ->
      rtacK_sound tac2 ->
      rtac_sound (THEN tac1 tac2).
  Proof.
    unfold THEN.
    intros.
    red. intros. subst.
    specialize (H ctx s g _ eq_refl).
    match goal with
      | |- context [ match ?X with _ => _ end ] =>
        destruct X; auto
    end.
    eapply rtac_spec_trans; eauto.
    eapply H0. reflexivity.
  Qed.

End parameterized.

Typeclasses Opaque THEN.
Hint Opaque THEN : typeclass_instances.

Arguments THEN {typ expr} _%rtac _%rtacK _ _ _ : rename.

Notation "X  ;; Y" := (@THEN _ _ X%rtac Y%rtacK) (at level 70, right associativity) : rtac_scope.