Require Import List.
Import ListNotations.

Require Import StructTact.StructTactics.
Require Import StructTact.Update.
Require Import StructTact.Update2.
Require Import StructTact.RemoveAll.
Require Import Sumbool.
Require Import Relation_Definitions.
Require Import RelationClasses.

Require Export Verdi.VerdiHints.

Require Import Cheerios.Cheerios.

Set Implicit Arguments.

Class BaseParams :=
  {
    data : Type;
    input : Type;
    output : Type
  }.

Class OneNodeParams (P : BaseParams) :=
  {
    init : data;
    handler : input -> data -> (output * data)
  }.

Class SingleParams (P : BaseParams) :=
  {
    init_handler : data;
    input_handler : input -> data -> (list output * data)
  }.

Class MultiParams (P : BaseParams) :=
  {
    name : Type ;
    msg : Type ;
    msg_eq_dec : forall x y : msg, {x = y} + {x <> y} ;
    name_eq_dec : forall x y : name, {x = y} + {x <> y} ;
    nodes : list name ;
    all_names_nodes : forall n, In n nodes ;
    no_dup_nodes : NoDup nodes ;
    init_handlers : name -> data;
    net_handlers : name -> name -> msg -> data -> (list output) * data * list (name * msg) ;
    input_handlers : name -> input -> data -> (list output) * data * list (name * msg)
  }.

Class FailureParams `(P : MultiParams) :=
  {
    reboot : data -> data
  }.

Definition do_disk file_name :=
  file_name -> option IOStreamWriter.t.

Inductive disk_op file_name :=
| Append :  file_name -> IOStreamWriter.t -> disk_op file_name
| Write : file_name -> IOStreamWriter.t -> disk_op file_name
| Delete : file_name -> disk_op file_name.

Class DiskOpMultiParams (P : BaseParams) :=
  {
    do_name : Type ;
    file_name : Type ;
    do_msg : Type ;
    do_msg_eq_dec : forall x y : do_msg, {x = y} + {x <> y} ;
    do_name_eq_dec : forall x y : do_name, {x = y} + {x <> y} ;
    file_name_eq_dec : forall x y : file_name, {x = y} + {x <> y} ;
    do_nodes : list do_name ;
    do_all_names_nodes : forall n, In n do_nodes ;
    do_no_dup_nodes : NoDup do_nodes ;
    do_net_handlers : do_name -> do_name -> do_msg -> data ->
                      list (disk_op file_name) * (list output) * data * list (do_name * do_msg) ;
    do_input_handlers : do_name -> input -> data ->
                        list (disk_op file_name) * (list output) * data * list (do_name * do_msg);
  }.

Class DiskOpFailureParams `(P : DiskOpMultiParams) :=
  {
    do_reboot : do_name -> (file_name -> option IOStreamWriter.in_channel) ->
                data * list (disk_op file_name)
  }.

Class NameOverlayParams `(P : MultiParams) :=
  {
    adjacent_to : relation name ;
    adjacent_to_dec : forall x y : name, {adjacent_to x y} + {~ adjacent_to x y} ;
    adjacent_to_symmetric : Symmetric adjacent_to ;
    adjacent_to_irreflexive : Irreflexive adjacent_to
  }.

Class FailMsgParams `(P : MultiParams) :=
  {
    msg_fail : msg
  }.

Class NewMsgParams `(P : MultiParams) :=
  {
    msg_new : msg
  }.

Section StepRelations.
  Variable A : Type.
  Variable trace : Type.

  Definition step_relation := A -> A -> list trace -> Prop.

  Inductive refl_trans_1n_trace (step : step_relation) : step_relation :=
  | RT1nTBase : forall x, refl_trans_1n_trace step x x []
  | RT1nTStep : forall x x' x'' cs cs',
                   step x x' cs ->
                   refl_trans_1n_trace step x' x'' cs' ->
                   refl_trans_1n_trace step x x'' (cs ++ cs').

  Theorem refl_trans_1n_trace_trans : forall step (a b c : A) (os os' : list trace),
                                        refl_trans_1n_trace step a b os ->
                                        refl_trans_1n_trace step b c os' ->
                                        refl_trans_1n_trace step a c (os ++ os').
  Proof using.
    intros.
    induction H; simpl; auto.
    concludes.
    rewrite app_ass.
    constructor 2 with x'; auto.
  Qed.

  Definition inductive (step : step_relation) (P : A -> Prop)  :=
    forall (a a': A) (os : list trace),
      P a ->
      step a a' os ->
      P a'.

  Theorem step_star_inductive :
    forall step P,
      inductive step P ->
      forall (a : A) a' os,
        P a ->
        (refl_trans_1n_trace step) a a' os ->
        P a'.
  Proof using.
    unfold inductive. intros.
    induction H1; auto.
    forwards; eauto.
  Qed.

  Definition inductive_invariant (step : step_relation) (init : A) (P : A -> Prop) :=
    P init /\ inductive step P.

  Definition reachable step init a :=
    exists out, refl_trans_1n_trace step init a out.

  Definition true_in_reachable step init (P : A -> Prop) :=
    forall a,
      reachable step init a ->
      P a.

  Theorem true_in_reachable_reqs :
    forall (step : step_relation) init (P : A -> Prop),
      (P init) ->
      (forall a a' out,
         step a a' out ->
         reachable step init a ->
         P a ->
         P a') ->
      true_in_reachable step init P.
  Proof using.
    intros. unfold true_in_reachable, reachable in *.
    intros. break_exists.
    match goal with H : refl_trans_1n_trace _ _ _ _ |- _ => induction H end;
      intuition eauto.
    match goal with H : P _ -> _ |- _ => apply H end;
      intros; break_exists;
      match goal with H : forall _ _ _, step _ _ _ -> _ |- _ => eapply H end;
      eauto; eexists; econstructor; eauto.
  Qed.

  Theorem inductive_invariant_true_in_reachable :
    forall step init P,
      inductive_invariant step init P ->
      true_in_reachable step init P.
  Proof using.
    unfold inductive_invariant, true_in_reachable, reachable, inductive in *. intros.
    break_exists.
    match goal with H : refl_trans_1n_trace _ _ _ _ |- _ => induction H end;
      intuition eauto.
  Qed.

  Inductive refl_trans_n1_trace (step : step_relation) : step_relation :=
  | RTn1TBase : forall x, refl_trans_n1_trace step x x []
  | RTn1TStep : forall x x' x'' cs cs',
                  refl_trans_n1_trace step x x' cs ->
                  step x' x'' cs' ->
                  refl_trans_n1_trace step x x'' (cs ++ cs').

  Lemma RTn1_step :
    forall (step : step_relation) x y z l l',
      step x y l ->
      refl_trans_n1_trace step y z l' ->
      refl_trans_n1_trace step x z (l ++ l').
  Proof using.
    intros.
    induction H0.
    - rewrite app_nil_r. rewrite <- app_nil_l.
      econstructor.
      constructor.
      auto.
    - concludes.
      rewrite <- app_ass.
      econstructor; eauto.
  Qed.

  Lemma refl_trans_1n_n1_trace :
    forall step x y l,
      refl_trans_1n_trace step x y l ->
      refl_trans_n1_trace step x y l.
  Proof using.
    intros.
    induction H.
    - constructor.
    - eapply RTn1_step; eauto.
  Qed.

  Lemma RT1n_step :
    forall (step : step_relation) x y z l l',
      refl_trans_1n_trace step x y l ->
      step y z l' ->
      refl_trans_1n_trace step x z (l ++ l').
  Proof using.
    intros.
    induction H.
    - simpl. rewrite <- app_nil_r. econstructor; eauto. constructor.
    - concludes. rewrite app_ass.
      econstructor; eauto.
  Qed.

  Lemma refl_trans_n1_1n_trace :
    forall step x y l,
      refl_trans_n1_trace step x y l ->
      refl_trans_1n_trace step x y l.
  Proof using.
    intros.
    induction H.
    - constructor.
    - eapply RT1n_step; eauto.
  Qed.

  Lemma refl_trans_1n_trace_n1_ind :
    forall (step : step_relation) (P : A -> A -> list trace -> Prop),
      (forall x, P x x []) ->
      (forall x x' x'' tr1 tr2,
         refl_trans_1n_trace step x x' tr1 ->
         step x' x'' tr2 ->
         P x x' tr1 ->
         refl_trans_1n_trace step x x'' (tr1 ++ tr2) ->
         P x x'' (tr1 ++ tr2)) ->
      forall x y l,
        refl_trans_1n_trace step x y l -> P x y l.
  Proof using.
    intros.
    find_apply_lem_hyp refl_trans_1n_n1_trace.
    eapply refl_trans_n1_trace_ind; eauto.
    intros. eapply H0; eauto using refl_trans_n1_1n_trace, RT1n_step.
  Qed.

  Theorem true_in_reachable_elim :
    forall (step : step_relation) init (P : A -> Prop),
      true_in_reachable step init P ->
      (P init) /\
      (forall a a' out,
         step a a' out ->
         reachable step init a ->
         P a ->
         P a').
  Proof using.
    intros. unfold true_in_reachable, reachable in *.
    intros. intuition.
    - apply H; eexists; econstructor.
    - apply H.
      break_exists.
      eexists. apply refl_trans_n1_1n_trace.
      find_apply_lem_hyp refl_trans_1n_n1_trace.
      econstructor; eauto.
  Qed.
End StepRelations.

Section Step1.
  Context `{params : OneNodeParams}.

  Inductive step_1 : (step_relation data (input * output)) :=
  | S1T_deliver : forall (i : input) s s' (out : output),
                    handler i s = (out, s') ->
                    step_1 s s' [(i, out)].

  Definition step_1_star := refl_trans_1n_trace step_1.
End Step1.

Section StepSingle.
  Context `{params : SingleParams}.

  Inductive step_s : (step_relation data (input + output)) :=
  | SST_deliver : forall i s s' out tr,
                    input_handler i s = (out, s') ->
                    tr = inl i :: map inr out ->
                    step_s s s' tr.

  Definition step_s_star := refl_trans_1n_trace step_s.
End StepSingle.

Section StepAsync.

  Context `{params : MultiParams}.

  Record packet := mkPacket { pSrc  : name ;
                             pDst  : name ;
                             pBody : msg }.

  Definition send_packets src ps := (map (fun m => mkPacket src (fst m) (snd m)) ps).

  Definition packet_eq_dec (p q : packet) : {p = q} + {p <> q}.
    decide equality; auto using name_eq_dec, msg_eq_dec.
  Defined.

  Record network := mkNetwork { nwPackets : list packet ;
                               nwState   : name -> data }.

  Definition step_async_init : network :=
    mkNetwork [] init_handlers.

  Inductive step_async : step_relation network (name * (input + list output)) :=
  | StepAsync_deliver : forall net net' p xs ys out d l,
      nwPackets net = xs ++ p :: ys ->
      net_handlers (pDst p) (pSrc p) (pBody p) (nwState net (pDst p)) = (out, d, l) ->
      net' = mkNetwork (send_packets (pDst p) l ++ xs ++ ys)
                       (update name_eq_dec (nwState net) (pDst p) d) ->
      step_async net net' [(pDst p, inr out)]
  (* inject a message (f inp) into host h. analogous to step_1 *delivery* *)
  | StepAsync_input : forall h net net' out inp d l,
      input_handlers h inp (nwState net h) = (out, d, l) ->
      net' = mkNetwork (send_packets h l ++ nwPackets net)
                       (update name_eq_dec (nwState net) h d) ->
      step_async net net' [(h, inl inp); (h, inr out)].

  Definition step_async_star := refl_trans_1n_trace step_async.
End StepAsync.

Arguments update _ _ _ _ _ _ / _.
Arguments send_packets _ _ _ _ /.

Section ParamsAux.
  Context `{params : MultiParams}.

  Lemma packet_eta :
    forall p : packet,
      {| pSrc := pSrc p; pDst := pDst p; pBody := pBody p |} = p.
  Proof using.
    destruct p; auto.
  Qed.

  Definition trace_non_empty_out (e : name * (input + list output)) :=
    match e with
    | (n, inr []) => None
    | _ => Some e
    end.
End ParamsAux.

Ltac map_id :=
  rewrite map_ext with (g := (fun x => x)); [eauto using map_id|simpl; intros; apply packet_eta].

Section StepDup.

  Context `{params : MultiParams}.

  Inductive step_dup : step_relation network (name * (input + list output)) :=
  (* just like step_async *)
  | StepDup_deliver : forall net net' p xs ys out d l,
      nwPackets net = xs ++ p :: ys ->
      net_handlers (pDst p) (pSrc p) (pBody p) (nwState net (pDst p)) = (out, d, l) ->
      net' = mkNetwork (send_packets (pDst p) l ++ xs ++ ys)
                       (update name_eq_dec (nwState net) (pDst p) d) ->
      step_dup net net' [(pDst p, inr out)]
  (* inject a message (f inp) into host h *)
  | StepDup_input : forall h net net' out inp d l,
      input_handlers h inp (nwState net h) = (out, d, l) ->
      net' = mkNetwork (send_packets h l ++ nwPackets net)
                       (update name_eq_dec (nwState net) h d) ->
      step_dup net net' [(h, inl inp); (h, inr out)]
  | StepDup_dup : forall net net' p xs ys,
      nwPackets net = xs ++ p :: ys ->
      net' = mkNetwork (p :: xs ++ p :: ys) (nwState net) ->
      step_dup net net' [].

  Definition step_dup_star := refl_trans_1n_trace step_dup.
End StepDup.

Section StepDrop.

  Context `{params : MultiParams}.

  Inductive step_drop : step_relation network (name * (input + list output)) :=
  | StepDrop_deliver : forall net net' p xs ys out d l,
      nwPackets net = xs ++ p :: ys ->
      net_handlers (pDst p) (pSrc p) (pBody p) (nwState net (pDst p)) = (out, d, l) ->
      net' = mkNetwork (send_packets (pDst p) l ++ xs ++ ys)
                       (update name_eq_dec (nwState net) (pDst p) d) ->
      step_drop net net' [(pDst p, inr out)]
  | StepDrop_drop : forall net net' p xs ys,
      nwPackets net = xs ++ p :: ys ->
      net' = mkNetwork (xs ++ ys) (nwState net) ->
      step_drop net net' []
  | StepDrop_input : forall h net net' out inp d l,
      input_handlers h inp (nwState net h) = (out, d, l) ->
      net' = mkNetwork (send_packets h l ++ nwPackets net)
                       (update name_eq_dec (nwState net) h d) ->
      step_drop net net' [(h, inl inp); (h, inr out)].

  Definition step_drop_star := refl_trans_1n_trace step_drop.
End StepDrop.

Section StepFailure.
  Context `{params : FailureParams}.

  (* this step relation transforms a list of failed hosts (list name * network), but does not transform handlers (H : hosts) *)
  Inductive step_failure : step_relation (list name * network) (name * (input + list output)) :=
  (* like step_async, but only delivers to hosts that haven't failed yet *)
  | StepFailure_deliver : forall net net' failed p xs ys out d l,
      nwPackets net = xs ++ p :: ys ->
      ~ In (pDst p) failed ->
      net_handlers (pDst p) (pSrc p) (pBody p) (nwState net (pDst p)) = (out, d, l) ->
      net' = mkNetwork (send_packets (pDst p) l ++ xs ++ ys)
                       (update name_eq_dec (nwState net) (pDst p) d) ->
      step_failure (failed, net) (failed, net') [(pDst p, inr out)]
  | StepFailure_input : forall h net net' failed out inp d l,
      ~ In h failed ->
      input_handlers h inp (nwState net h) = (out, d, l) ->
      net' = mkNetwork (send_packets h l ++ nwPackets net)
                       (update name_eq_dec (nwState net) h d) ->
      step_failure (failed, net) (failed, net') [(h, inl inp) ;  (h, inr out)]
  (* drops a packet *)
  | StepFailure_drop : forall net net' failed p xs ys,
      nwPackets net = xs ++ p :: ys ->
      net' = (mkNetwork (xs ++ ys) (nwState net)) ->
      step_failure (failed, net) (failed, net') []
  (* duplicates a packet *)
  | StepFailure_dup : forall net net' failed p xs ys,
      nwPackets net = xs ++ p :: ys ->
      net' = (mkNetwork (p :: xs ++ p :: ys) (nwState net)) ->
      step_failure (failed, net) (failed, net') []
  (* a host fails (potentially again) *)
  | StepFailure_fail :  forall h net failed,
      step_failure (failed, net) (h :: failed, net) []
  (* a host reboots (is not failing anymore). the new state is computed with the reboot function from the old state *)
  | StepFailure_reboot : forall h net net' failed failed',
      In h failed ->
      failed' = remove name_eq_dec h failed ->
      net' = mkNetwork (nwPackets net)
                       (update name_eq_dec (nwState net) h (reboot (nwState net h))) ->
      step_failure (failed, net) (failed', net') [].

  Definition step_failure_star : step_relation (list name * network) (name * (input + list output)) :=
    refl_trans_1n_trace step_failure.

  Definition step_failure_init : list name * network := ([], step_async_init).
End StepFailure.

Section StepFailureDiskOp.
  Context `{disk_op_failure_params : DiskOpFailureParams}.

  Record do_packet := mklPacket { do_pSrc  : do_name ;
                                 do_pDst  : do_name ;
                                 do_pBody : do_msg }.

  Definition do_send_packets src ps := (map (fun m => mklPacket src (fst m) (snd m)) ps).

  Definition do_packet_eq_dec (p q : do_packet) : {p = q} + {p <> q}.
    decide equality; auto using do_name_eq_dec, do_msg_eq_dec.
  Defined.

  Record do_network := mkdoNetwork { nwdoPackets : list do_packet ;
                                     nwdoState   : do_name -> data ;
                                     nwdoDisk    : do_name -> do_disk file_name
                                   }.

  Definition disk_to_channel (dsk : do_disk file_name) :=
    fun file => (match dsk file with
                 | Some s => Some (IOStreamWriter.channel_send (IOStreamWriter.out_channel_wrap s))
                 | None => None
                 end).

  Definition update_disk (dsk : do_disk file_name) (op : disk_op file_name) :
    do_disk file_name :=
    match op with
    | Append file x =>
      update file_name_eq_dec dsk file (match dsk file with
                                        | Some s => Some (s +$+ x)
                                        | None => Some x
                                        end)
    | Write file x => update file_name_eq_dec dsk file (Some x)
    | Delete file =>  update file_name_eq_dec dsk file (Some IOStreamWriter.empty)
    end.

  Definition apply_ops dsk ops :=
    fold_left update_disk ops dsk.

  Inductive step_failure_disk_ops : step_relation (list do_name * do_network) (do_name * (input + list output)) :=
  | StepFailureDiskOp_deliver : forall net net' failed p xs ys ops out d l,
      nwdoPackets net = xs ++ p :: ys ->
      ~ In (do_pDst p) failed ->
      do_net_handlers (do_pDst p) (do_pSrc p) (do_pBody p) (nwdoState net (do_pDst p)) = (ops, out, d, l) ->
      net' = mkdoNetwork (do_send_packets (do_pDst p) l ++ xs ++ ys)
               (update do_name_eq_dec (nwdoState net) (do_pDst p) d)
               (update do_name_eq_dec (nwdoDisk net) (do_pDst p) (apply_ops (nwdoDisk net (do_pDst p)) ops)) ->
      step_failure_disk_ops (failed, net) (failed, net') [(do_pDst p, inr out)]
  | StepFailureDiskOp_input : forall h net net' failed ops out inp d l,
      ~ In h failed ->
      do_input_handlers h inp (nwdoState net h) = (ops, out, d, l) ->
      net' = mkdoNetwork (do_send_packets h l ++ nwdoPackets net)
               (update do_name_eq_dec (nwdoState net) h d)
               (update do_name_eq_dec (nwdoDisk net) h (apply_ops (nwdoDisk net h) ops)) ->
      step_failure_disk_ops (failed, net) (failed, net') [(h, inl inp) ;  (h, inr out)]
  | StepFailureDiskOp_drop : forall net net' failed p xs ys,
      nwdoPackets net = xs ++ p :: ys ->
      net' = (mkdoNetwork (xs ++ ys) (nwdoState net) (nwdoDisk net)) ->
      step_failure_disk_ops (failed, net) (failed, net') []
  | StepFailureDiskOp_dup : forall net net' failed p xs ys,
      nwdoPackets net = xs ++ p :: ys ->
      net' = (mkdoNetwork (p :: xs ++ p :: ys) (nwdoState net) (nwdoDisk net)) ->
      step_failure_disk_ops (failed, net) (failed, net') []
  | StepFailureDiskOp_fail :  forall h net failed,
      step_failure_disk_ops (failed, net) (h :: failed, net) []
  | StepFailureDiskOp_reboot : forall h net net' failed failed' d ops,
      In h failed ->
      failed' = remove do_name_eq_dec h failed ->
      do_reboot h (disk_to_channel (nwdoDisk net h)) = (d, ops) ->
      net' = mkdoNetwork (nwdoPackets net)
               (update do_name_eq_dec (nwdoState net) h d)
               (update do_name_eq_dec (nwdoDisk net) h (apply_ops (nwdoDisk net h) ops)) ->
      step_failure_disk_ops (failed, net) (failed', net') [].

  Definition step_failure_disk_ops_star : step_relation (list do_name * do_network) (do_name * (input + list output)) :=
    refl_trans_1n_trace step_failure_disk_ops.

  Definition null_disk : do_disk file_name :=
    fun _ => None.

  Definition step_failure_disk_ops_init : list do_name * do_network :=
    ([], mkdoNetwork [] (fun h => fst (do_reboot h (disk_to_channel null_disk)))
      (fun h => apply_ops null_disk (snd (do_reboot h (disk_to_channel null_disk))))).
End StepFailureDiskOp.

Section StepOrdered.
  Context `{params : MultiParams}.

  Notation src := name (only parsing).
  Notation dst := name (only parsing).

  Record ordered_network :=
    mkONetwork
       { onwPackets : src -> dst -> list msg;
         onwState   : name -> data
       }.

  Inductive step_ordered : step_relation ordered_network (name * (input + output)) :=
  | StepOrdered_deliver : forall net net' tr m ms out d l from to,
      onwPackets net from to = m :: ms ->
      net_handlers to from m (onwState net to) = (out, d, l) ->
      net' = mkONetwork (collate name_eq_dec to (update2 name_eq_dec (onwPackets net) from to ms) l)
                        (update name_eq_dec (onwState net) to d) ->
      tr = map2fst to (map inr out) ->
      step_ordered net net' tr
  | StepOrdered_input : forall h net net' tr out inp d l,
      input_handlers h inp (onwState net h) = (out, d, l) ->
      net' = mkONetwork (collate name_eq_dec h (onwPackets net) l)
                        (update name_eq_dec (onwState net) h d) ->
      tr = (h, inl inp) :: map2fst h (map inr out) ->
      step_ordered net net' tr.

  Definition step_ordered_star := refl_trans_1n_trace step_ordered.

  Definition step_ordered_init : ordered_network := mkONetwork (fun _ _ => []) init_handlers.
End StepOrdered.

Section StepOrderedFailure.
  Context `{multi_params : MultiParams}.
  Context {overlay_params : NameOverlayParams multi_params}.
  Context {fail_msg_params : FailMsgParams multi_params}.

  Inductive step_ordered_failure : step_relation (list name * ordered_network) (name * (input + output)) :=
  | StepOrderedFailure_deliver : forall net net' failed tr m ms out d l from to,
      onwPackets net from to = m :: ms ->
      ~ In to failed ->
      net_handlers to from m (onwState net to) = (out, d, l) ->
      net' = {| onwPackets := collate name_eq_dec to (update2 name_eq_dec (onwPackets net) from to ms) l;
                onwState := update name_eq_dec (onwState net) to d |} ->
      tr = map2fst to (map inr out) ->
      step_ordered_failure (failed, net) (failed, net') tr
  | StepOrderedFailure_input : forall h net net' failed tr out inp d l,
      ~ In h failed ->
      input_handlers h inp (onwState net h) = (out, d, l) ->
      net' = {| onwPackets := collate name_eq_dec h (onwPackets net) l;
                onwState := update name_eq_dec (onwState net) h d |} ->
      tr = (h, inl inp) :: map2fst h (map inr out) ->
      step_ordered_failure (failed, net) (failed, net') tr
  | StepOrderedFailure_fail :  forall h net net' failed,
      ~ In h failed ->
      net' = {| onwPackets := collate name_eq_dec h (onwPackets net)
                  (map2snd msg_fail (filter_rel adjacent_to_dec h (remove_all name_eq_dec failed nodes))) ;
                onwState := onwState net |} ->
      step_ordered_failure (failed, net) (h :: failed, net') [].

  Definition step_ordered_failure_star := refl_trans_1n_trace step_ordered_failure.

  Definition step_ordered_failure_init : list name * ordered_network := ([], step_ordered_init).
End StepOrderedFailure.

Section StepOrderedDynamic.
  Context `{multi_params : MultiParams}.
  Context {overlay_params : NameOverlayParams multi_params}.
  Context {new_msg_params : NewMsgParams multi_params}.

  Notation src := name (only parsing).
  Notation dst := name (only parsing).

  Record ordered_dynamic_network :=
    mkODNetwork
       {
         odnwNodes : list name ;
         odnwPackets : src -> dst -> list msg ;
         odnwState : name -> option data
       }.

  Inductive step_ordered_dynamic : step_relation ordered_dynamic_network (name * (input + output)) :=
  | StepOrderedDynamic_start : forall net net' h,
      ~ In h (odnwNodes net) ->
      net' = {| odnwNodes := h :: odnwNodes net;
                odnwPackets := collate_ls name_eq_dec (filter_rel adjacent_to_dec h (odnwNodes net))
                               (collate name_eq_dec h (odnwPackets net)
                                 (map2snd msg_new (filter_rel adjacent_to_dec h (odnwNodes net)))) h msg_new;
                odnwState := update name_eq_dec (odnwState net) h (Some (init_handlers h)) |} ->
      step_ordered_dynamic net net' []
  | StepOrderedDynamic_deliver : forall net net' tr m ms out d d' l from to,
      In to (odnwNodes net) ->
      odnwState net to = Some d ->
      odnwPackets net from to = m :: ms ->
      net_handlers to from m d = (out, d', l) ->
      net' = {| odnwNodes := odnwNodes net;
                odnwPackets := collate name_eq_dec to (update2 name_eq_dec (odnwPackets net) from to ms) l;
                odnwState := update name_eq_dec (odnwState net) to (Some d') |} ->
      tr = map2fst to (map inr out) ->
      step_ordered_dynamic net net' tr
  | StepOrderedDynamic_input : forall h net net' tr out inp d d' l,
      In h (odnwNodes net) ->
      odnwState net h = Some d ->
      input_handlers h inp d = (out, d', l) ->
      net' = {| odnwNodes := odnwNodes net;
                odnwPackets := collate name_eq_dec h (odnwPackets net) l;
                odnwState := update name_eq_dec (odnwState net) h (Some d') |} ->
      tr = (h, inl inp) :: map2fst h (map inr out) ->
      step_ordered_dynamic net net' tr.

  Definition step_ordered_dynamic_star := refl_trans_1n_trace step_ordered_dynamic.

  Definition step_ordered_dynamic_init : ordered_dynamic_network := mkODNetwork [] (fun _ _ => []) (fun _ => None).
End StepOrderedDynamic.

Section StepOrderedDynamicFailure.
  Context `{multi_params : MultiParams}.
  Context {overlay_params : NameOverlayParams multi_params}.
  Context {new_msg_params : NewMsgParams multi_params}.
  Context {fail_msg_params : FailMsgParams multi_params}.

  Inductive step_ordered_dynamic_failure : step_relation (list name * ordered_dynamic_network) (name * (input + output)) :=
  | StepOrderedDynamicFailure_start : forall net net' failed h,
      ~ In h (odnwNodes net) ->
      net' = {| odnwNodes := h :: odnwNodes net;
                odnwPackets := collate_ls name_eq_dec (filter_rel adjacent_to_dec h (remove_all name_eq_dec failed (odnwNodes net)))
                                (collate name_eq_dec h (odnwPackets net)
                                  (map2snd msg_new (filter_rel adjacent_to_dec h (remove_all name_eq_dec failed (odnwNodes net))))) h msg_new;
                odnwState := update name_eq_dec (odnwState net) h (Some (init_handlers h)) |} ->
      step_ordered_dynamic_failure (failed, net) (failed, net') []
  | StepOrderedDynamicFailure_deliver : forall net net' failed tr m ms out d d' l from to,
      ~ In to failed ->
      In to (odnwNodes net) ->
      odnwState net to = Some d ->
      odnwPackets net from to = m :: ms ->
      net_handlers to from m d = (out, d', l) ->
      net' = {| odnwNodes := odnwNodes net;
                odnwPackets := collate name_eq_dec to (update2 name_eq_dec (odnwPackets net) from to ms) l;
                odnwState := update name_eq_dec (odnwState net) to (Some d') |} ->
      tr = map2fst to (map inr out) ->
      step_ordered_dynamic_failure (failed, net) (failed, net') tr
  | StepOrderedDynamicFailure_input : forall h net net' failed tr out inp d d' l,
      ~ In h failed ->
      In h (odnwNodes net) ->
      odnwState net h = Some d ->
      input_handlers h inp d = (out, d', l) ->
      net' = {| odnwNodes := odnwNodes net;
                odnwPackets := collate name_eq_dec h (odnwPackets net) l;
                odnwState := update name_eq_dec (odnwState net) h (Some d') |} ->
      tr = (h, inl inp) :: map2fst h (map inr out) ->
      step_ordered_dynamic_failure (failed, net) (failed, net') tr
  | StepOrderedDynamicFailure_fail : forall h net net' failed,
      ~ In h failed ->
      In h (odnwNodes net) ->
      net' = {| odnwNodes := odnwNodes net;
                odnwPackets := collate name_eq_dec h (odnwPackets net)
                                (map2snd msg_fail (filter_rel adjacent_to_dec h (remove_all name_eq_dec failed (odnwNodes net)))) ;
                odnwState := odnwState net |} ->
      step_ordered_dynamic_failure (failed, net) (h :: failed, net') [].

  Definition step_ordered_dynamic_failure_star := refl_trans_1n_trace step_ordered_dynamic_failure.

  Definition step_ordered_dynamic_failure_init : list name * ordered_dynamic_network :=
    ([], step_ordered_dynamic_init).
End StepOrderedDynamicFailure.


From ch2o_compcert Require Export return42_ch2o_safe return42_csyntaxgen ch2o_compcertc_lp64 compcertc_compiler.

Lemma return42_compcertc_safe: compcertc_safe_program (λ z, z = 42) prog.
Proof.
apply soundness with (2:=return42_ch2o_safe).
econstructor.
- apply δ_main.
- apply init_mem_ok.
  reflexivity.
- reflexivity.
- reflexivity.
- constructor.
  constructor.
  constructor; (unfold int_lower || unfold int_upper); simpl; lia.
Qed.

Theorem return42_asm_safe tp:
  transf_c_program prog = OK tp →
  asm_program_satisfies_spec tp (satisfies_postcondition (λ z, z = 42)).
Proof.
intros.
apply transf_c_program_safe with (1:=H).
apply return42_compcertc_safe.
Qed.


Require Import
 List Program Decidable Sumbool.

Set Implicit Arguments.

Section StackSet_defs.

Require Import Aux.

(*******************************************************************
** Variables corresponding to type classes                        **
*******************************************************************)

Variable (i l a sd : Set).

Variable eqi : forall (x y : i), {x = y} + {x <> y}.
Definition beqi (x y : i) : {b : bool | if b then x = y else x <> y}
  := bool_of_sumbool (eqi x y).

Variable eqa : forall (x y : a), {x = y} + {x <> y}.
Definition beqa (x y : a) : {b : bool | if b then x = y else x <> y}
  := bool_of_sumbool (eqa x y).

Definition eqOption : forall (x y : option a), {x = y} + {x <> y}.
  decide equality; apply eqa.
  Defined.

Definition beqOption (x y : option a) : {b : bool | if b then x = y else x <> y}
  := bool_of_sumbool (eqOption x y).

(*******************************************************************
** Axiomatic assumptions about Data.Map                           **
*******************************************************************)

Axiom FMap : Set -> Set -> Set.
Axiom empty : forall k a, FMap k a.
Axiom insert : forall (k a : Set), k -> a -> FMap k a -> FMap k a.
Axiom remove : forall (k a : Set), k -> FMap k a -> FMap k a.
Axiom r : Set.

(*******************************************************************
** Data types for stacksets                                       **
*******************************************************************)

Definition sid : Set := nat.

Definition eqsid (x y : sid) : {x = y} + {x <> y}.
  decide equality.
  Defined.

Definition beqsid (x y : sid) : {b : bool | if b then x = y else x <> y}
  := bool_of_sumbool (eqsid x y).

Record stack : Set :=
  Stack
    { getUp : list a
    ; getFocus :  a
    ; getDown : list a
    }.

Record workspace : Set :=
  Workspace
    { getTag : i
    ; getLayout : l
    ; getStack : option stack
    }.

Inductive rationalRect : Set :=
  RationalRect : r -> r -> r -> r -> rationalRect.

Record screen : Set :=
  Screen
    { getWorkspace : workspace
    ; getScreen : sid
    ; getScreenDetail : sd
    }.

Record stackSet : Set :=
  StackSet
    { getCurrent : screen
    ; getVisible : list screen
    ; getHidden : list workspace
    ; getFloating : FMap a rationalRect
    }.

(******************************************************************* *)
(* ** Functions from StackSet.hs re-implemented in Coq               ** *)
(* *******************************************************************)

Definition workspaces : stackSet -> list workspace :=
  fun s => (getWorkspace (getCurrent s)) ::
    map (fun x => getWorkspace x) (getVisible s) ++ getHidden s.

Definition new
  (m : l)
  (wids : {wids : list i | wids <> nil })
  (sds  : {sds : list sd | length sds <= length (proj1_sig wids) /\ sds <> nil})
  : stackSet.
    refine (
    let seenUnseen := splitAt (length (proj1_sig sds)) (map (fun i => Workspace i m None) (proj1_sig wids))
    in let zippy := zipWith3 Screen
                      (fst seenUnseen)
                      (seq 0 (length (proj1_sig wids)))
                      (proj1_sig sds)
    in match zippy return (zippy = zipWith3 Screen
                      (fst seenUnseen)
                      (seq 0 (length (proj1_sig wids)))
                      (proj1_sig sds) -> stackSet)  with
         | (cur :: visi) => fun _ =>
               StackSet cur visi (snd seenUnseen) (empty a rationalRect)
         | nil => _
       end _).
    intro H.
    destruct wids as ([ | wid wids] & prf).
    contradiction prf; auto.
    destruct sds as ( [ | sid sids] & (H1 & H2)).
    contradiction H2; auto.
    unfold seenUnseen in H.
    simpl in H.
    discriminate H.
    unfold zippy; auto.
    Defined.

Definition currentTag : stackSet -> i :=
  fun s => getTag (getWorkspace (getCurrent s)).

Definition _tagMember (x : i) (stckset : stackSet) :
    let tags := map getTag (workspaces stckset)
    in {In x tags} + {~In x tags} :=
    let tags := map getTag (workspaces stckset)
    in In_dec (A := i) eqi x tags.

Definition _view
  (x : i) (s : stackSet) : stackSet :=
  match eqi x (currentTag s) with
    | left eq => s
    | _ =>
      match find (fun y => proj1_sig (beqi x (getTag (getWorkspace y)))) (getVisible s) with
        | Some x =>
          match s with
            StackSet c vs us f =>
              let p x y := proj1_sig (beqsid (getScreen x) (getScreen y)) in
              StackSet x (deleteBy p x vs) us f
          end
        | _ =>
          match find (fun y => proj1_sig (beqi x (getTag y))) (getHidden s) with
            | Some x =>
              match s with
                | StackSet c vs us f =>
                  let c' := match c with
                              | Screen _ sid sd => Screen x sid sd
                            end
                  in let p x y := proj1_sig (beqi (getTag x) (getTag y)) in
                  StackSet c' vs (getWorkspace c :: deleteBy p x us) f
              end
            | None => s
          end
      end
  end.

Definition _greedyView (w : i) (ws : stackSet) : stackSet :=
  let wTag x := proj1_sig (beqi w (getTag x))
  in if existsb wTag (getHidden ws) then _view w ws
     else match find (fun x => wTag (getWorkspace x)) (getVisible ws) with
            | None => ws
            | Some s => match ws with
                          | StackSet c vs us f =>
                            let c' := c
                            in let vs' :=
                              match s with
                                | Screen w sid sd =>
                                  Screen (getWorkspace (getCurrent ws)) sid sd
                                  :: filter (fun x => negb (wTag (getWorkspace x))) vs
                              end
                            in StackSet c' vs' us f
                        end
            end.

Definition lookupWorkspace (sc : sid) (w : stackSet) : option i :=
  let ws := filter (fun w => proj1_sig (beqsid sc (getScreen w)))
                   (getCurrent w :: getVisible w)
  in match ws with
      | nil => None
      | (Screen y _ _ :: _) => Some (getTag y)
    end.

(* Called "with" in StackSet.hs *)
Definition withStack : forall b,
  b -> (stack -> b) -> stackSet -> b :=
  fun b y f s =>
    maybe y f (getStack (getWorkspace (getCurrent s))).

Definition modify :
  option stack -> (stack -> option stack)
  -> stackSet -> stackSet :=
  fun d f s =>
    match s with
      StackSet (Screen (Workspace i l x) sid sd) v h m =>
        StackSet (Screen (Workspace i l (withStack d f s)) sid sd) v h m end.

Definition modify' :
  (stack -> stack) -> stackSet -> stackSet :=
  fun f => modify None (fun x => Some (f x)).

Definition peek : stackSet -> option a :=
  withStack None (fun x => Some (getFocus x)).

Definition integrate : stack -> list a :=
  fun s => match s with
             Stack u x d => rev u ++ x :: d
           end.

Definition integrate' : option stack -> list a :=
  fun s => maybe nil (fun x => integrate x) s.

Definition differentiate : list a -> option stack :=
  fun xs => match xs with
              | nil => None
              | y :: ys => Some (Stack nil y ys)
            end.

(* Called filter in Xmonad *)
Definition filterStack :
  (a -> bool) -> stack -> option stack :=
    fun p s => match s with
                 | Stack ls c rs =>
                   match filter p (c :: rs) with
                     | c' :: rs' => Some (Stack (filter p ls) c' rs')
                     | nil => match filter p ls with
                                | c' :: ls' => Some (Stack ls' c' nil)
                                | nil => None
                              end
                   end
               end.

Definition index : stackSet -> list a :=
  withStack nil (fun x => integrate x).

Definition focusUp' : stack -> stack :=
  fun s => match s with
             | Stack (l :: ls) c rs => Stack ls l (c :: rs)
             | Stack nil c rs => Stack (tail (rev (c :: rs))) (hd c (rev rs)) nil
           end.

Definition swapUp' : stack -> stack :=
  fun s => match s with
             | Stack (l :: ls) c rs => Stack ls c (l :: rs)
             | Stack nil c rs => Stack (rev rs) c nil
           end.

Definition reverseStack : stack -> stack :=
  fun s => match s with
             | Stack ls c rs => Stack rs c ls
           end.

Definition focusUp : stackSet -> stackSet :=
  fun s => modify' (fun x => focusUp' x) s.

Definition focusDown' : stack -> stack :=
  fun s => reverseStack (focusUp' (reverseStack s)).

Definition focusDown : stackSet -> stackSet :=
  fun s => modify' (fun x => focusDown' x) s.

Definition swapUp : stackSet -> stackSet :=
  fun s => modify' (fun x => swapUp' x) s.

Definition swapDown : stackSet -> stackSet
  := fun s => modify' (fun x => reverseStack (swapUp' (reverseStack x))) s.

Definition screens : stackSet -> list screen :=
  fun s => getCurrent s :: getVisible s.

Definition allWindows : stackSet -> list a :=
  fun s => flat_map (fun x => integrate' (getStack x))  (workspaces s).

Definition mapWorkspace : (workspace -> workspace) -> stackSet -> stackSet :=
  fun f s => let updateScreen scr := match scr with
                                       | Screen w s sd => Screen (f w) s sd
                                     end
    in match s with
         | StackSet c v h fl =>
             StackSet (updateScreen c) (map updateScreen v) (map f h) fl
       end.

Definition _findTag : a -> stackSet -> option i :=
  fun x s =>
    let has := fun x opt =>
      match opt with
        | None => false
        | Some (Stack ls c rs) => match In_dec eqa x (c :: ls ++ rs) with
                                    | left _ => true
                                    | right _ => false
                                  end
      end
    in match
      filter (fun w => has x (getStack w)) (workspaces s) with
        | nil => None
        | x :: _ => Some (getTag x)
       end.

Definition _member : a -> stackSet -> bool :=
  fun x s =>
    match _findTag x s with
      | None => false
      | Some _ => true
    end.

Definition _renameTag (old new : i) : stackSet -> stackSet :=
     let rename := fun w => match eqi (getTag w) old with
                              | left _ => Workspace new (getLayout w) (getStack w)
                              | right _ => w
                            end
     in mapWorkspace rename.

Definition shiftMaster : stackSet -> stackSet :=
  modify' (fun c => match c with
                      | Stack nil _ _ => c
                      | Stack ls t rs => Stack nil t (rev ls ++ rs)
                    end).

Definition focusMaster : stackSet -> stackSet.
  refine (
    modify' (fun c => match c with
                        | Stack [] _ _ => c
                        | Stack (l :: ls) c rs =>
                          let revLs := rev (l :: ls) in
                          match revLs return (rev (l :: ls) = revLs -> stack) with
                            | nil => _
                            | x :: xs => fun _ => Stack nil x (xs ++ c :: rs)
                          end _
                      end)).
  intro H; assert (D : l0 :: ls = nil);
    [apply revNil; auto | discriminate D].
  auto.
  Defined.

Definition rotate : list a -> list a := fun xs =>
  match xs with
    | nil => nil
    | x :: xs => xs ++ [x]
  end.

Definition swapMaster : stackSet -> stackSet :=
  modify' (fun c => match c with
                      | Stack nil _ _ => c
                      | Stack ls c rs =>
                          let rs' := rotate (rev ls) ++ rs in
                          Stack nil c rs'
                    end).

Definition _insertUp : a -> stackSet -> stackSet :=
  fun x s =>
  if _member x s
    then s
    else modify
      (Some (Stack nil x nil))
      (fun s => match s with
                  | Stack l c r => Some (Stack l x (c :: r))
                end) s.

Definition _ensureTags : l -> list i -> stackSet -> stackSet :=
  fun label allt st =>
    let fix et is rn s :=
      match is , rn return stackSet with
        | nil , _ => s
        | i :: is , rn =>
          match _tagMember i s with
            | left _ => et is rn s
            | right _ =>
              match rn , s with
                | nil , StackSet c v h f =>
                  et is nil (StackSet c v (Workspace i label None :: h) f)
                | (r :: rs) , s => et is rs (_renameTag r i s)
              end
          end
      end
    in et allt
          (removeList eqi (map getTag (workspaces st)) allt) st.

Definition sink : a -> stackSet -> stackSet :=
  fun w s => match s with
               | StackSet c v h f => StackSet c v h (remove w f)
             end.

Definition float : a -> rationalRect -> stackSet -> stackSet :=
  fun w r s => match s with
                 | StackSet c v h f => StackSet c v h (insert w r f)
               end.

Definition _delete' : a -> stackSet -> stackSet :=
   fun w s =>
     let removeFromWorkspace ws :=
       match ws with
         | Workspace i l stk => Workspace i l
             (option_bind stk (filterStack (fun x => negb (proj1_sig (beqa x w)))))
       end
     in let removeFromScreen scr :=
       match scr with
         | Screen ws sid sd => Screen (removeFromWorkspace ws) sid sd
       end
     in match s with
       | StackSet c v h f =>
         StackSet (removeFromScreen c)
         (map removeFromScreen v)
         (map removeFromWorkspace h)
         f
     end.

Definition _delete : a -> stackSet -> stackSet :=
  fun w s => sink w (_delete' w s).

Definition _shift : i -> stackSet -> stackSet :=
  fun n s =>
    let curtag := getTag (getWorkspace (getCurrent s))
    in let go w := _view curtag (_insertUp w (_view n (_delete' w s)))
    in  match _tagMember n s , eqi n curtag with
          | left _ , right _ => maybe s go (peek s)
          | _ , _ => s
        end.

Definition findDistance (w : a) (stk: stack) : option nat :=
  match stk with
    | Stack ls t rs => elemIndex eqa w (t :: ls ++ rev rs)
  end.

Definition _focusWindow : a -> stackSet -> stackSet :=
  fun w s =>
    match eqOption (Some w) (peek s) with
      | left p => s
      | right _ =>
        let go := _findTag w s >>= fun n =>
                  withStack None (findDistance w) (_view n s) >>= fun d =>
                  Some (applyN d (_view n s) focusUp)
        in maybe s id go
   end.

Definition onWorkspace (n : i) (f : stackSet -> stackSet) (s : stackSet)
  := _view (currentTag s) (f (_view n s)).

Definition _shiftWin : i -> a -> stackSet -> stackSet :=
  fun n w s =>
  let go from x := onWorkspace n (_insertUp w) (onWorkspace from (_delete' w) x)
  in match _findTag w s with
       | None => s
       | Some from =>
          match _tagMember n s , eqi n from with
            | left p , right q => go from s
            | _ , _ => s
          end
     end.

End StackSet_defs.

Definition mapLayout (a i l l' sd : Set)
  (f : l -> l') (s : stackSet i l a sd) : stackSet i l' a sd
  := match s with
       | StackSet v vs hs m =>
         let fWorkspace := fun w =>
           match w with
             | Workspace t x s => Workspace t (f x) s
           end
           in let fScreen s :=
             match s with
               | Screen ws s sd => Screen (fWorkspace ws) s sd
             end in
             StackSet (fScreen v) (map fScreen vs) (map fWorkspace hs) m
     end.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Floating-point format without underflow *)
Require Import Raux Defs Round_pred Generic_fmt Float_prop.
Require Import FIX Ulp Round_NE.

Section RND_FLX.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable prec : Z.

Class Prec_gt_0 :=
  prec_gt_0 : (0 < prec)%Z.

Context { prec_gt_0_ : Prec_gt_0 }.

Inductive FLX_format (x : R) : Prop :=
  FLX_spec (f : float beta) :
    x = F2R f -> (Zabs (Fnum f) < Zpower beta prec)%Z -> FLX_format x.

Definition FLX_exp (e : Z) := (e - prec)%Z.

(** Properties of the FLX format *)

Global Instance FLX_exp_valid : Valid_exp FLX_exp.
Proof.
intros k.
unfold FLX_exp.
generalize prec_gt_0.
repeat split ; intros ; omega.
Qed.

Theorem FIX_format_FLX :
  forall x e,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  FLX_format x ->
  FIX_format beta (e - prec) x.
Proof.
clear prec_gt_0_.
intros x e Hx [[xm xe] H1 H2].
rewrite H1, (F2R_prec_normalize beta xm xe e prec).
now eexists.
exact H2.
now rewrite <- H1.
Qed.

Theorem FLX_format_generic :
  forall x, generic_format beta FLX_exp x -> FLX_format x.
Proof.
intros x H.
rewrite H.
eexists ; repeat split.
simpl.
apply lt_IZR.
rewrite abs_IZR.
rewrite <- scaled_mantissa_generic with (1 := H).
rewrite <- scaled_mantissa_abs.
apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp (Rabs x))).
apply bpow_gt_0.
rewrite scaled_mantissa_mult_bpow.
rewrite IZR_Zpower, <- bpow_plus.
2: now apply Zlt_le_weak.
unfold cexp, FLX_exp.
ring_simplify (prec + (mag beta (Rabs x) - prec))%Z.
rewrite mag_abs.
destruct (Req_dec x 0) as [Hx|Hx].
rewrite Hx, Rabs_R0.
apply bpow_gt_0.
destruct (mag beta x) as (ex, Ex).
now apply Ex.
Qed.

Theorem generic_format_FLX :
  forall x, FLX_format x -> generic_format beta FLX_exp x.
Proof.
clear prec_gt_0_.
intros x [[mx ex] H1 H2].
simpl in H2.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
unfold cexp, FLX_exp.
rewrite mag_F2R with (1 := Zmx).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
now apply mag_le_Zpower.
Qed.

Theorem FLX_format_satisfies_any :
  satisfies_any FLX_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
intros x.
split.
apply FLX_format_generic.
apply generic_format_FLX.
Qed.

Theorem FLX_format_FIX :
  forall x e,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  FIX_format beta (e - prec) x ->
  FLX_format x.
Proof with auto with typeclass_instances.
intros x e Hx Fx.
apply FLX_format_generic.
apply generic_format_FIX in Fx.
revert Fx.
apply generic_inclusion with (e := e)...
apply Zle_refl.
Qed.

(** unbounded floating-point format with normal mantissas *)
Inductive FLXN_format (x : R) : Prop :=
  FLXN_spec (f : float beta) :
    x = F2R f ->
    (x <> 0%R -> Zpower beta (prec - 1) <= Zabs (Fnum f) < Zpower beta prec)%Z ->
    FLXN_format x.

Theorem generic_format_FLXN :
  forall x, FLXN_format x -> generic_format beta FLX_exp x.
Proof.
intros x [[xm ex] H1 H2].
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx.
apply generic_format_0.
specialize (H2 Zx).
apply generic_format_FLX.
rewrite H1.
eexists ; repeat split.
apply H2.
Qed.

Theorem FLXN_format_generic :
  forall x, generic_format beta FLX_exp x -> FLXN_format x.
Proof.
intros x Hx.
rewrite Hx.
simpl.
eexists. easy.
rewrite <- Hx.
intros Zx.
simpl.
split.
(* *)
apply le_IZR.
rewrite IZR_Zpower.
2: now apply Zlt_0_le_0_pred.
rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx).
apply Rmult_le_reg_r with (bpow (cexp beta FLX_exp x)).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite <- scaled_mantissa_abs.
rewrite <- cexp_abs.
rewrite scaled_mantissa_mult_bpow.
unfold cexp, FLX_exp.
rewrite mag_abs.
ring_simplify (prec - 1 + (mag beta x - prec))%Z.
destruct (mag beta x) as (ex,Ex).
now apply Ex.
(* *)
apply lt_IZR.
rewrite IZR_Zpower.
2: now apply Zlt_le_weak.
rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx).
apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp x)).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite <- scaled_mantissa_abs.
rewrite <- cexp_abs.
rewrite scaled_mantissa_mult_bpow.
unfold cexp, FLX_exp.
rewrite mag_abs.
ring_simplify (prec + (mag beta x - prec))%Z.
destruct (mag beta x) as (ex,Ex).
now apply Ex.
Qed.

Theorem FLXN_format_satisfies_any :
  satisfies_any FLXN_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
split ; intros H.
now apply FLXN_format_generic.
now apply generic_format_FLXN.
Qed.

Lemma negligible_exp_FLX :
   negligible_exp FLX_exp = None.
Proof.
case (negligible_exp_spec FLX_exp).
intros _; reflexivity.
intros n H2; contradict H2.
unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega.
Qed.

Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R.
Proof.
unfold ulp; rewrite Req_bool_true; trivial.
rewrite negligible_exp_FLX; easy.
Qed.

Theorem eq_0_round_0_FLX :
   forall rnd {Vr: Valid_rnd rnd} x,
     round beta FLX_exp rnd x = 0%R -> x = 0%R.
Proof.
intros rnd Hr x.
apply eq_0_round_0_negligible_exp; try assumption.
apply FLX_exp_valid.
apply negligible_exp_FLX.
Qed.

Theorem gt_0_round_gt_0_FLX :
   forall rnd {Vr: Valid_rnd rnd} x,
     (0 < x)%R -> (0 < round beta FLX_exp rnd x)%R.
Proof with auto with typeclass_instances.
intros rnd Hr x Hx.
assert (K: (0 <= round beta FLX_exp rnd x)%R).
rewrite <- (round_0 beta FLX_exp rnd).
apply round_le... now apply Rlt_le.
destruct K; try easy.
absurd (x = 0)%R.
now apply Rgt_not_eq.
apply eq_0_round_0_FLX with rnd...
Qed.

Theorem ulp_FLX_le :
  forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLX_0, Rabs_R0.
right; ring.
rewrite ulp_neq_0; try exact Hx.
unfold cexp, FLX_exp.
replace (mag beta x - prec)%Z with ((mag beta x - 1) + (1-prec))%Z by ring.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply bpow_mag_le.
Qed.

Theorem ulp_FLX_ge :
  forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLX_0, Rabs_R0.
right; ring.
rewrite ulp_neq_0; try exact Hx.
unfold cexp, FLX_exp.
unfold Zminus; rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
left; now apply bpow_mag_gt.
Qed.

(** FLX is a nice format: it has a monotone exponent... *)
Global Instance FLX_exp_monotone : Monotone_exp FLX_exp.
Proof.
intros ex ey Hxy.
now apply Zplus_le_compat_r.
Qed.

(** and it allows a rounding to nearest, ties to even. *)
Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z.

Global Instance exists_NE_FLX : Exists_NE beta FLX_exp.
Proof.
destruct NE_prop as [H|H].
now left.
right.
unfold FLX_exp.
split ; omega.
Qed.

End RND_FLX.


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)

(*| .. coq:: none |*)
Require Import Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Classes.Morphisms.
Require Import Coq.Classes.DecidableClass.
Require Import Coq.Lists.List.
Import ListNotations. (* from List *)

Require Import Coq.Bool.Bool.
Require Import Coq.Classes.SetoidClass.
Open Scope equiv_scope.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Logic.Decidable.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.
Set Implicit Arguments.
Set Strict Implicit.

Require Import Oqarina.CoqExt.all.
Require Import Oqarina.formalisms.Contracts.Specification.
Require Import Oqarina.formalisms.Contracts.MetaTheory.
Require Import Oqarina.formalisms.Contracts.AG_Contracts.
(*| .. coq:: |*)

(*|
Extended A/G Contracts
======================

In this section, we extend A/G contracts to rich specifications.

|*)

(*| .. coq:: none |*)
Section Extended_AG_Contract.
(*| .. coq:: |*)

Import AG_Contract_Notations.
Import Specifications_Notations.

(*| Assume a type M denoting a rich specification (or model) |*)
Variable M : Type.
Context `{spec_m : Rich_Specification M}.

(*| Assume a type V denoting a specification, forming a class of Assume/Guarantee contracts. |*)
Variable V : Type.
Context `{spec_v : Specification V}.

(*| We defined an extended A/G contract as a pair of a function mapping
a model to a variable V and a A/G contract. |*)

Record Extended_AG_Contract := {
    phi : M -> V ;
    ag_contract : AG_Contract V;
}.

Definition Model_Implements_Contract (m : M) (c : Extended_AG_Contract) :=
    let c' := @ (Saturate c.(ag_contract)) in
        c.(phi) m ⊢m c'.

(*| We say that a refinement m of a model m' is *preserving*  a contract c
if both m and m' both implement the contract c. A sufficient conditition is
phi (m) = phi (m'). |*)

Lemma Refinement_Preserving_Contract: forall (m m': M) (c : Extended_AG_Contract),
    m ≼ m' -> c.(phi) m = c.(phi) m'
        -> Model_Implements_Contract m c
        -> Model_Implements_Contract m' c.
Proof.
    unfold Model_Implements_Contract.
    intros.
    rewrite <- H0.
    apply H1.
Qed.

(*| We say that a refinement m of a model m' is *robust* w.r.t. a contract c
if both m and m' both implement the contract c but phi (m) <> phi (m'). |*)

Definition Refinement_Robust (m m': M) (c : Extended_AG_Contract) : Prop :=
    m ≼ m' -> c.(phi) m <> c.(phi) m'
        -> Model_Implements_Contract m c
        -> Model_Implements_Contract m' c.

(*| We say that a refinement m of a model m' is *preserved* by a refined contract c' of contrac c
if both m and m' both implement the contract c. A sufficient conditition is
phi (m) = phi (m'). |*)

Definition Refinement_Refined_Contract (m m': M) (c : Extended_AG_Contract) : Prop :=
    exists c',
        m ≼ m' -> (@ c'.(ag_contract)) ≼ (@ c.(ag_contract))
            -> Model_Implements_Contract m c
            -> Model_Implements_Contract m' c'.

End Extended_AG_Contract.


Require Export Iron.Language.SystemF2Store.ExpBase.
Require Import Iron.Language.SystemF2Store.ExpLift.

(* Substitution of Types in Exps *)
Fixpoint substTX (d: nat) (u: ty) (xx: exp) : exp :=
  match xx with
  | XVar _     => xx
  | XLoc _     => xx

  |  XLAM x
  => XLAM (substTX (S d) (liftTT 1 0 u) x)

  |  XAPP x t
  => XAPP (substTX d u x)  (substTT d u t)

  |  XLam t x
  => XLam (substTT d u t)  (substTX d u x)

  |  XApp x1 x2
  => XApp (substTX d u x1) (substTX d u x2)

  |  XCon dc ts xs
  => XCon dc (map (substTT d u) ts) (map (substTX d u) xs)

  |  XCase xx alts
  => XCase (substTX d u xx) (map (substTA d u) alts)

  |  XUpdate c i ts x1 x2
  => XUpdate c i (map (substTT d u) ts) (substTX d u x1) (substTX d u x2)
 end

with substTA (d: nat) (u: ty) (aa: alt) : alt :=
  match aa with
  |  AAlt dc xx
  => AAlt dc (substTX d u xx)
  end.

(* Substitution of Exps in Exps *)
Fixpoint substXX (d:  nat) (u: exp) (xx: exp) : exp :=
 match xx with
    | XVar ix
    => match nat_compare ix d with
       (* Index matches the one we are substituting for. *)
       | Eq  => u

       (* Index was free in the original expression.
          As we've removed the outermost binder, also decrease this
          index by one. *)
       | Gt  => XVar (ix - 1)

       (* Index was bound in the original expression. *)
       | Lt  => XVar ix
       end

    |  XLoc l
    => XLoc l

    |  XLAM x1
    => XLAM (substXX d (liftTX 0 u) x1)

    |  XAPP x1 t2
    => XAPP (substXX d u x1) t2

    (* Increase the depth as we move across a lambda.
       Also lift free references in the exp being substituted
       across the lambda as we enter it. *)
    |  XLam t1 x2
    => XLam t1 (substXX (S d) (liftXX 1 0 u) x2)

    (* Applications *)
    |  XApp x1 x2
    => XApp (substXX d u x1) (substXX d u x2)

    |  XCon dc ts xs
    => XCon dc ts (map (substXX d u) xs)

    |  XCase x alts
    => XCase (substXX d u x) (map (substXA d u) alts)

    |  XUpdate c i ts x1 x2
    => XUpdate c i ts (substXX d u x1) (substXX d u x2)
    end

with substXA (d: nat) (u: exp) (aa: alt)
 := match aa with
    |  AAlt (DataCon tag arity) x
    => AAlt (DataCon tag arity)
         (substXX (d + arity)
                  (liftXX arity 0 u) x)
    end.

(* Substitute several expressions.
   Note that in the definition, each time we substitute an
   exp (u), we need to lift it by the number of exps remaining
   in the list (us). This is because we're placing the substitued
   exp under the binders corresponding to the remaining ones.
   The added lifting is then gradually "undone" each time we
   substitue one of the remaining expressions. This happens due
   to the free variable/Gt case in the definition of substX.
   Example:
               (A->B), A |- 0 :: A
               (A->B), A |- 1 :: (A->B)
    (A->B), A, A, (A->B) |- (0 1) [1 0] :: B

    Substitute first exp in list.
            (A->B), A, A |- (2 0) [0] :: B
    We get '2' by adding the length of the remaining substitution
    (1) to the index substituted (1). The argument of the function
    is changed from 1 to 0 by the free variable case of substX.
    Substitute remaining exp in list.
               (A->B), A |- (1 0) :: B
    Here, 0 is subst for 0, and 2 changes to 1 due as it's a free
    variable.
*)
Fixpoint substXXs (d: nat) (us: list exp) (xx: exp) :=
 match us with
 | nil      => xx
 | u :: us' => substXXs d us'
                 (substXX d (liftXX (List.length us') 0 u)
                            xx)
 end.

(* The data constructor of an alternative is unchanged
   by exp substitution. *)
Lemma dcOfAlt_substXA
 : forall d u a
 , dcOfAlt (substXA d u a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_substXA : global.

(* The data constructor of an alternative is unchanged
   by type substitution. *)
Lemma dcOfAlt_substTA
 : forall d u a
 , dcOfAlt (substTA d u a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_substTA : global.


From Coq Require Import List.
From PCC Require Import java_basic_defs program_model expressions_assertions.
From PCC Require Import ssrexport.

Section SecurityDefs.

Open Scope type_scope.

Inductive event :=
| bef_event (_: classid) (_: methid) (arg: value)
| aft_event (_: classid) (_: methid) (ret: value)
| exc_event (_: classid) (_: methid).

Definition event_trace := list event.

(*
   The following definition is not distributive under ++ operations.
   That is, trace_of (exec1 ++ exec2) <> (trace_of exec1) ++ (trace_of exec2)
*)
Definition observed_event (p: program) (c: conf) : option event :=
  match c with
  | (gv, h, normal c m pc s ls :: ars) =>
    match (instr_at p c m pc) with
    | invoke c' m' => Some (bef_event c' m' (s[[0]]))
    | ret => Some (aft_event c m (s[[0]]))
    | _ => None
    end
  | (gv, h, exceptional o :: ars) => None (* add exc_event *)
  | (gv, h, nil) => None
  end.

Fixpoint event_trace_of (p: program) (e: execution) : event_trace :=
  match e with
  | nil => nil
  | c :: e' =>
    match observed_event p c with
    | Some evt => evt :: event_trace_of p e'
    | None => event_trace_of p e'
    end
  end.

Lemma event_trace_distr : forall p l l',
  event_trace_of p (l ++ l') = event_trace_of p l ++ event_trace_of p l'.
Proof.
move => p.
elim => [|a l IH l']; first by [].
rewrite -app_comm_cons /=.
by case (observed_event p a); rewrite IH.
Qed.

Inductive event_modifier := before | after  | exception.

Definition contract := (event_modifier * classid * methid) -> ghost_update.

Definition sec_state := ghost_valuation.

Definition sec_state_trace := list sec_state.

Inductive ss_updates_of (contr : contract) : event_trace -> list ghost_update -> Prop :=
| ssu_done : ss_updates_of contr nil nil
| ssu_bef  : forall c m arg t' gus', ss_updates_of contr t' gus' ->
    ss_updates_of contr (bef_event c m arg :: t') (contr (before, c, m) :: gus')
| ssu_aft  : forall c m ret t' gus', ss_updates_of contr t' gus' ->
    ss_updates_of contr (aft_event c m ret :: t') (contr (after, c, m) :: gus').

Inductive sst_tail : list ghost_update -> sec_state_trace -> Prop :=
| sst_done : forall ss, sst_tail nil (ss :: nil)
| sst_step : forall ss ss' gvar exp v sst gus,
    g_eeval exp ss v ->
    ss' = (upd_gv ss gvar v) ->
    sst_tail gus (ss' :: sst) ->
    sst_tail ((gvar, exp) :: gus) (ss :: ss' :: sst).

Definition is_sec_state_trace (ssus : list ghost_update) (sst : sec_state_trace) : Prop :=
  head sst = Some initial_gv /\ sst_tail ssus sst.

(*
   For simplicity: The ghost state is represented by a single fixed ghost variable 'gs'.
   We still have a notion of ghost valuations to be able to handle local ghost variables
   used for storing arguments and return values.
*)
Variable gs : ghostid.

Definition violating_sec_state (gv: ghost_valuation) := gv gs = ghost_errval.

Definition accepted_by contr (event_tr: event_trace) :=
  forall gus sec_tr,
    ss_updates_of contr event_tr gus ->
    is_sec_state_trace gus sec_tr ->
    hd initial_gv sec_tr = initial_gv ->
    (forall ss, In ss sec_tr -> ~ violating_sec_state ss).

Definition adheres_to p contr : Prop :=
  forall e, execution_of p e -> accepted_by contr (event_trace_of p e).

(*
   The original definition of "Ghost Instruction Goes Wrong" is,
   "no guards of the ghost instruction hold".
   If all inserted ghost instructions has the shape

   x := g_1 -> v_1 | g_2 -> v_2 | ... | g_n -> v_n | ghost_errval

   the notion of going wrong is equivalent to "no ghost var equals ghost_errval".
   This is the reason why initial_gv has all vars initialized to 0 instead of ghost_errval.
*)

Definition exec_never_goes_wrong (e: execution) :=
  forall c, In c e -> ~ violating_sec_state (ghost_valuation_of c).

Section GhostInliner.

(* Note that assertions are irrelevant in this section. *)

Variable contr : contract.

(*
   My initial attempt encoded the ghost_inliner as a function. That approach
   ran into the following problem:

   If a ghost instruction is to be inserted, it needs a label. Since method
   bodies are total mappings from lables to instructions, it is impossible
   to dig out a fresh label.

   The obvious fix would be to let method bodies be partial ("option")
   mappings. Unfortunately the option-type spreads like a plague in the defs
   and all proofs needs splitting on Some/None.

   This is why it is currently encoded as a proposition over programs.
*)

Definition ghost_inlined_meth (m gm: method) : Prop :=
  forall l,
    let l'   := label_function_of gm l in
    let l''  := label_function_of gm l' in
    let l''' := label_function_of gm l'' in
      forall (c: classid) (m': methid),
        match minstr_at m l with
        | invoke c m' => minstr_at gm l   = ghost_instr (contr (before, c, m')) /\
            minstr_at gm l'  = invoke c m' /\
            minstr_at gm l'' = ghost_instr (contr (after, c, m')) /\
            label_function_of m l = l'''
        | i => minstr_at gm l = i /\
            label_function_of m l = l
        end.

Definition ghost_inlined_class (c gc: class) : Prop :=
  forall mid, ghost_inlined_meth (c mid) (gc mid).

Definition ghost_inlined (p pg: program) : Prop :=
  forall cid, ghost_inlined_class (classes pg cid) (classes p cid).

End GhostInliner.

(*
Definition ghost_update_of pg (c : conf) : option ghost_update :=
  match c with
    | (_, _, normal c m pc s l :: _) =>
      match instr_at pg c m pc with
        | ghost_instr gu => Some gu
        | otherwise => None
      end
    | otherwise => None
  end.
*)
Definition ghost_update_of pg (c : conf) : option ghost_update :=
  match current_instr pg c with
  | Some (ghost_instr gu) => Some gu
  | _ => None
  end.

(* Returns ghost updates that *have been carried out* (to be compatible with ss_after). *)
Fixpoint ghost_updates_of pg (eg : execution) : list ghost_update :=
  match eg with
  | nil => nil
  | c :: eg' =>
    match eg' with
    | nil => nil
    | c' :: eg'' =>
      match ghost_update_of pg c with
      | Some gu => gu :: ghost_updates_of pg eg'
      | None => ghost_updates_of pg eg'
      end
    end
  end.

Fixpoint seen_ghost_updates_of pg (eg : execution) : list ghost_update :=
  match eg with
  | nil => nil
  | c :: eg' =>
    match ghost_update_of pg c with
    | Some gu => gu :: seen_ghost_updates_of pg eg'
    | None => seen_ghost_updates_of pg eg'
    end
  end.

End SecurityDefs.


From iris.bi Require Export bi plainly.
From iris.proofmode Require Import tactics.
From iris.prelude Require Import options.
Import bi.

(** The "core" of an assertion is its maximal persistent part,
    i.e. the conjunction of all persistent assertions that are weaker
    than P (as in, implied by P). *)
Definition coreP `{!BiPlainly PROP} (P : PROP) : PROP :=
  (* TODO: Looks like we want notation for affinely-plainly; that lets us avoid
  using conjunction/implication here. *)
  (∀ Q : PROP, <affine> ■ (Q -∗ <pers> Q) -∗ <affine> ■ (P -∗ Q) -∗ Q)%I.
Global Instance: Params (@coreP) 1 := {}.
Typeclasses Opaque coreP.

Section core.
  Context `{!BiPlainly PROP}.
  Implicit Types P Q : PROP.

  Lemma coreP_intro P : P -∗ coreP P.
  Proof.
    rewrite /coreP. iIntros "HP" (Q) "_ HPQ".
    (* FIXME: Cannot apply HPQ directly. This works if we move it to the
    persistent context, but why should we? *)
    iDestruct (affinely_plainly_elim with "HPQ") as "HPQ".
    by iApply "HPQ".
  Qed.

  Global Instance coreP_persistent P : Persistent (coreP P).
  Proof.
    rewrite /coreP /Persistent. iIntros "HC" (Q).
    iApply persistently_wand_affinely_plainly. iIntros "#HQ".
    iApply persistently_wand_affinely_plainly. iIntros "#HPQ".
    iApply "HQ". iApply "HC"; auto.
  Qed.
  Global Instance coreP_affine P : Affine P → Affine (coreP P).
  Proof. intros ?. rewrite /coreP /Affine. iIntros "HC". iApply "HC"; eauto. Qed.

  Global Instance coreP_ne : NonExpansive (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.
  Global Instance coreP_proper : Proper ((⊣⊢) ==> (⊣⊢)) (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.

  Global Instance coreP_mono : Proper ((⊢) ==> (⊢)) (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.
  Global Instance coreP_flip_mono :
    Proper (flip (⊢) ==> flip (⊢)) (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.

  Lemma coreP_wand P Q : <affine> ■ (P -∗ Q) -∗ coreP P -∗ coreP Q.
  Proof.
    rewrite /coreP. iIntros "#HPQ HP" (R) "#HR #HQR". iApply ("HP" with "HR").
    iIntros "!> !> HP". iApply "HQR". by iApply "HPQ".
  Qed.

  Lemma coreP_elim P : Persistent P → coreP P -∗ P.
  Proof. rewrite /coreP. iIntros (?) "HCP". iApply "HCP"; auto. Qed.

  (** The [<affine>] modality is needed for general BIs:
  - The right-to-left direction corresponds to elimination of [<pers>], which
    cannot be done without [<affine>].
  - The left-to-right direction corresponds the introduction of [<pers>]. The
    [<affine>] modality makes it stronger since it appears in the LHS of the
    [⊢] in the premise. As a user, you have to prove [<affine> coreP P ⊢ Q],
    which is weaker than [coreP P ⊢ Q]. *)
  Lemma coreP_entails P Q : (<affine> coreP P ⊢ Q) ↔ (P ⊢ <pers> Q).
  Proof.
    split.
    - iIntros (HP) "HP". iDestruct (coreP_intro with "HP") as "#HcP {HP}".
      iIntros "!>". by iApply HP.
    - iIntros (->) "HcQ". by iDestruct (coreP_elim with "HcQ") as "#HQ".
  Qed.
  (** A more convenient variant of the above lemma for affine [P]. *)
  Lemma coreP_entails' P Q `{!Affine P} : (coreP P ⊢ Q) ↔ (P ⊢ □ Q).
  Proof.
    rewrite -(affine_affinely (coreP P)) coreP_entails. split.
    - rewrite -{2}(affine_affinely P). by intros ->.
    - intros ->. apply affinely_elim.
  Qed.
End core.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  List utility proofs.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Lemma cons_is_append_singleton:
 forall (A : Type) (x : A) (l : list A),
   x :: l = [x] ++ l.
Proof.
  intros.
  reflexivity.
Qed.

Lemma append_nil_noop:
 forall (A : Type) (l : list A),
   [] ++ l = l.
Proof.
  intros.
  compute.
  reflexivity.
Qed.

Lemma list_of_length_0_is_nil:
  forall (A : Type) (l : list A),
    length l = 0 ->
    l = nil.
Proof.
  intros A l lengthl.
  induction l.
  reflexivity.
  inversion lengthl.
Qed.

Lemma rev_nil:
  forall (A : Type) (l : list A),
    rev l = [] ->
    l = [].
Proof.
  intros.
Admitted.

Lemma rev_cons_app:
 forall (A : Type) (l p': list A) (p0 : A),
   rev p' = p0 :: l ->
   p' = (rev l) ++ [p0].
Admitted.


Require Import Arith.
Require Import Omega.
Require Import String.
Require Import List.
(*Require Import Monad.*)
(*Require Import Logic.*)

(* bytes *)

(* Use nat as a standin for the data *)
Definition bytes : Type := (nat * nat).

(*************************************************************)
(* file traces (for ghost state) *)

Section filetraces.

Inductive fileop: Type :=
| FileWrite: bytes -> nat -> fileop
| FileTruncate: nat -> fileop
.

Inductive file_trace: nat -> list fileop -> Type :=
| FileTrace: forall j ops, j <= length ops -> file_trace j ops
.

End filetraces.

(*************************************************************)
(* dir traces (for ghost state) *)

Section dirtraces.

Inductive dirop: Set :=
| DirCreate: string -> dirop
| DirUnlink: string -> dirop
.

Inductive dir_trace: nat -> list dirop -> Type :=
| DirTrace: forall j ops, j <= length ops -> dir_trace j ops
.

End dirtraces.

(*************************************************************)
(* vnodes/fses *)

Section vnodes.

(* M : Monad (XXX) *)
Class vnodeclass (M : Type -> Type) (vnode : Type) := {
  VOP_LOOKUP: vnode -> string -> M vnode;
  VOP_CREATE: vnode -> string -> M vnode;
  VOP_UNLINK: vnode -> string -> M unit;
  VOP_READ: vnode -> nat -> nat -> M (bytes * nat)%type;
  VOP_WRITE: vnode -> bytes -> nat -> M unit;
  VOP_TRUNCATE: vnode -> nat -> M unit;
  VOP_FSYNC: vnode -> M unit;
}.

(* M : Monad (XXX) *)
Class fsclass (M : Type -> Type) (vfs : Type) := {
  vnode_: Type;
  VFS_GETROOT: vfs -> M vnode_;
  VFS_SYNC: vfs -> M unit;
  newfs: M unit;
}.

End vnodes.

(*************************************************************)
(* vfs-level executions *)

Section ops.

Definition vnode: Type := nat. (* XXX placeholder *)
Definition vfs: Type := nat.   (* XXX placeholder *)

Inductive vfscmd: Type :=
| lookup: vnode -> string -> vfscmd
| create: vnode -> string -> vfscmd
| unlink: vnode -> string -> vfscmd
| read: vnode -> nat -> nat -> vfscmd
| write: vnode -> bytes -> nat -> vfscmd
| truncate: vnode -> nat -> vfscmd
| fsync: vnode -> vfscmd
| getroot: vfs -> vfscmd
| sync: vfs -> vfscmd
.

Inductive vfsprogram: Type :=
| prog_cmd: vfscmd -> vfsprogram
| prog_seq: vfsprogram -> vfsprogram -> vfsprogram
| prog_par: vfsprogram -> vfsprogram -> vfsprogram
.

(* a program is made of commands and a trace is made of actions *)

Inductive vfsaction: Type :=
| a_lookup: vnode -> string -> vnode -> vfsaction
| a_create: vnode -> string -> vnode -> vfsaction
| a_read: vnode -> nat -> nat -> bytes -> vfsaction
| a_write: vnode -> bytes -> nat -> vfsaction
| a_truncate: vnode -> nat -> vfsaction
| a_fsync: vnode -> vfsaction
| a_getroot: vfs -> vnode -> vfsaction
| a_sync: vfs -> vfsaction
.

Definition vfstrace := list vfsaction.

Function vfsexec (s : vfsstate) (p : vfsprogram): (vfsstate * vfstrace) :=
   match p with
   | prog_op op => match op with
        | lookup vn name =>

Lemma string_eq_dec:
   forall s1 s2 : string,
   {s1 = s2} + {s1 <> s2}.
Proof.
Admitted.

Lemma op_eq_dec:
   forall op1 op2 : op,
   {op1 = op2} + {op1 <> op2}.
Proof.
   intros.
   destruct op1; destruct op2; auto; try (right; discriminate).
   1-3: destruct (string_eq_dec s s0);
        subst; auto;
        right;
        congruence.
   - destruct (Nat.eq_dec n n1); destruct (Nat.eq_dec n0 n2); subst.
     1: left; auto.
     1-3: right; congruence.
   - destruct b. destruct b0.
     destruct (Nat.eq_dec n1 n3);
     destruct (Nat.eq_dec n2 n4);
     destruct (Nat.eq_dec n n0); subst.
     1: left; auto.
     1-7: right; congruence.
   - destruct (Nat.eq_dec n n0); subst.
     1: left; auto.
     1: right; congruence.
Qed.

Inductive serial: execution -> Prop :=
| serial_op: forall op, serial (exec_op op)
| serial_seq: forall x1 x2, serial (exec_seq x1 x2)
.

Inductive op_in: op -> execution -> Prop :=
| op_in_op: forall op, op_in op (exec_op op)
| op_in_seqa: forall op x1 x2, op_in op x1 -> op_in op (exec_seq x1 x2)
| op_in_seqb: forall op x1 x2, op_in op x2 -> op_in op (exec_seq x1 x2)
| op_in_para: forall op x1 x2, op_in op x1 -> op_in op (exec_par x1 x2)
| op_in_parb: forall op x1 x2, op_in op x2 -> op_in op (exec_par x1 x2)
.

Lemma OpInOp:
   forall op1 op2,
   op_in op1 (exec_op op2) -> op1 = op2.
Proof.
   intros.
   inversion H; auto.
Qed.

Lemma NotOpInOp:
   forall op1 op2,
   ~(op_in op1 (exec_op op2)) -> op1 <> op2.
Proof.
   intros.
   contradict H.
   subst.
   apply op_in_op.
Qed.

Lemma OpInSeq:
   forall op x1 x2,
   op_in op (exec_seq x1 x2) -> op_in op x1 \/ op_in op x2.
Proof.
   intros.
   inversion H; subst.
   - left; auto.
   - right; auto.
Qed.

Lemma OpInPar:
   forall op x1 x2,
   op_in op (exec_par x1 x2) -> op_in op x1 \/ op_in op x2.
Proof.
   intros.
   inversion H; subst.
   - left; auto.
   - right; auto.
Qed.

Lemma NotOpInSeq:
   forall op x1 x2,
   ~(op_in op (exec_seq x1 x2)) -> ~(op_in op x1) /\ ~(op_in op x2).
Proof.
   intros.
   split; contradict H.
   - apply op_in_seqa; auto.
   - apply op_in_seqb; auto.
Qed.

Lemma NotOpInPar:
   forall op x1 x2,
   ~(op_in op (exec_par x1 x2)) -> ~(op_in op x1) /\ ~(op_in op x2).
Proof.
   intros.
   split; contradict H.
   - apply op_in_para; auto.
   - apply op_in_parb; auto.
Qed.

Lemma not_op_in_op:
   forall op1 op2,
   op1 <> op2 -> ~(op_in op1 (exec_op op2)).
Proof.
   intros.
   contradict H.
   apply OpInOp in H.
   auto.
Qed.

Lemma not_op_in_seq:
   forall op x1 x2,
   ~(op_in op x1) -> ~(op_in op x2) -> ~(op_in op (exec_seq x1 x2)).
Proof.
   intros.
   contradict H.
   apply OpInSeq in H.
   destruct H.
   - auto.
   - contradiction.
Qed.

Lemma not_op_in_par:
   forall op x1 x2,
   ~(op_in op x1) -> ~(op_in op x2) -> ~(op_in op (exec_par x1 x2)).
Proof.
   intros.
   contradict H.
   apply OpInPar in H.
   destruct H.
   - auto.
   - contradiction.
Qed.

Lemma in_dec:
   forall op x,
   {op_in op x} + {~(op_in op x)}.
Proof.
   intros.
   induction x.
   - destruct (op_eq_dec op0 o); subst.
     * left. apply op_in_op.
     * right. apply not_op_in_op. auto.
   - destruct IHx1; destruct IHx2.
     * left. apply op_in_seqa. auto.
     * left. apply op_in_seqa. auto.
     * left. apply op_in_seqb. auto.
     * right. apply not_op_in_seq; auto.
   - destruct IHx1; destruct IHx2.
     * left. apply op_in_para. auto.
     * left. apply op_in_para. auto.
     * left. apply op_in_parb. auto.
     * right. apply not_op_in_par; auto.
Qed.

Inductive op_occurs: op -> execution -> nat -> Prop :=
| op_occurs_self: forall op,
     op_occurs op (exec_op op) 1
| op_occurs_other: forall op1 op2, op1 <> op2 ->
     op_occurs op1 (exec_op op2) 0
| op_occurs_seq: forall op x1 x2 n1 n2,
       op_occurs op x1 n1 -> op_occurs op x2 n2 ->
     op_occurs op (exec_seq x1 x2) (n1 + n2)
| op_occurs_par: forall op x1 x2 n1 n2,
       op_occurs op x1 n1 -> op_occurs op x2 n2 ->
     op_occurs op (exec_par x1 x2) (n1 + n2)
.

Lemma op_occurs_det:
   forall op x n1 n2,
      op_occurs op x n1 -> op_occurs op x n2 ->
      n1 = n2.
Proof.
   intros.
   revert H0. revert n2.
   induction H; intros.
   - destruct (Nat.eq_dec n2 1); subst; auto.
     inversion H0; [ omega | contradiction ].
   - destruct (Nat.eq_dec n2 0); subst; auto.
     inversion H0; subst; contradiction; auto.
   - inversion H1; subst.
     apply IHop_occurs1 in H5.
     apply IHop_occurs2 in H7.
     subst; auto.
   - inversion H1; subst.
     apply IHop_occurs1 in H5.
     apply IHop_occurs2 in H7.
     subst; auto.
Qed.

Lemma op_occurs_seq_nosum_existential:
   forall op x1 x2 n1 n2,
   op_occurs op x1 n1 -> op_occurs op x2 n2 ->
   exists n,
   n = n1 + n2 /\ op_occurs op (exec_seq x1 x2) n.
Proof.
   intros.
   exists (n1 + n2).
   split; auto.
   apply op_occurs_seq; auto.
Qed.

Lemma op_occurs_seq_nosum:
   forall op x1 x2 n1 n2 n,
   op_occurs op x1 n1 -> op_occurs op x2 n2 -> n = n1 + n2 ->
   op_occurs op (exec_seq x1 x2) n.
Proof.
   intros.
   rewrite H1.
   apply op_occurs_seq; auto.
Qed.

Lemma op_occurs_par_nosum:
   forall op x1 x2 n1 n2 n,
   op_occurs op x1 n1 -> op_occurs op x2 n2 -> n = n1 + n2 ->
   op_occurs op (exec_par x1 x2) n.
Proof.
   intros.
   rewrite H1.
   apply op_occurs_par; auto.
Qed.

Lemma OpOccursSeq:
   forall op x1 x2 n,
   op_occurs op (exec_seq x1 x2) n ->
   exists n1 n2,
   n = n1 + n2 /\
   op_occurs op x1 n1 /\
   op_occurs op x2 n2.
Proof.
   intros.
   inversion H; subst.
   exists n1. exists n2.
   split; auto.
Qed.

Lemma OpOccursPar:
   forall op x1 x2 n,
   op_occurs op (exec_par x1 x2) n ->
   exists n1 n2,
   n = n1 + n2 /\
   op_occurs op x1 n1 /\
   op_occurs op x2 n2.
Proof.
   intros.
   inversion H; subst.
   exists n1. exists n2.
   split; auto.
Qed.

Lemma op_occurs_in:
   forall op x n,
   op_occurs op x n -> n > 0 -> op_in op x.
Proof.
   intros.
   induction H.
   - apply op_in_op.
   - omega.
   - destruct (Nat.eq_dec n1 0); subst.
     * rewrite Nat.add_0_l in H0.
       apply IHop_occurs2 in H0.
       apply op_in_seqb.
       auto.
     * assert (n1 > 0) by omega.
       apply IHop_occurs1 in H2.
       apply op_in_seqa.
       auto.
   - destruct (Nat.eq_dec n1 0); subst.
     * rewrite Nat.add_0_l in H0.
       apply IHop_occurs2 in H0.
       apply op_in_parb.
       auto.
     * assert (n1 > 0) by omega.
       apply IHop_occurs1 in H2.
       apply op_in_para.
       auto.
Qed.

Lemma op_notin_occurs:
   forall op x,
      ~(op_in op x) -> op_occurs op x 0.
Proof.
   intros.
   induction x.
   - apply NotOpInOp in H.
     apply op_occurs_other.
     auto.
   - apply NotOpInSeq in H.
     destruct H as [Ha Hb].
     apply op_occurs_seq_nosum with (n1 := 0) (n2 := 0); auto.
   - apply NotOpInPar in H.
     destruct H as [Ha Hb].
     apply op_occurs_par_nosum with (n1 := 0) (n2 := 0); auto.
Qed.

Lemma op_in_occurs:
   forall op x,
      op_in op x -> exists n, n > 0 /\ op_occurs op x n.
Proof.
   intros.
   revert H.
   induction x; intros.
   - apply OpInOp in H.
     rewrite H.
     exists 1.
     split; auto.
     apply op_occurs_self.
   - apply OpInSeq in H.
     destruct H.
     * apply IHx1 in H.
       destruct H as [n1 [H1a H1b]].
       destruct (in_dec op0 x2) as [Hx2 | Hx2].
       + apply IHx2 in Hx2.
         destruct Hx2 as [n2 [H2a H2b]].
         exists (n1 + n2).
         split; try omega.
         apply op_occurs_seq; auto.
       + apply op_notin_occurs in Hx2.
         exists (n1 + 0).
         split; try omega.
         apply op_occurs_seq; auto.
     * apply IHx2 in H.
       destruct H as [n2 [H2a H2b]].
       destruct (in_dec op0 x1) as [Hx1 | Hx1].
       + apply IHx1 in Hx1.
         destruct Hx1 as [n1 [H1a H1b]].
         exists (n1 + n2).
         split; try omega.
         apply op_occurs_seq; auto.
       + apply op_notin_occurs in Hx1.
         exists (0 + n2).
         split; try omega.
         apply op_occurs_seq; auto.
   - apply OpInPar in H.
     destruct H.
     * apply IHx1 in H.
       destruct H as [n1 [H1a H1b]].
       destruct (in_dec op0 x2) as [Hx2 | Hx2].
       + apply IHx2 in Hx2.
         destruct Hx2 as [n2 [H2a H2b]].
         exists (n1 + n2).
         split; try omega.
         apply op_occurs_par; auto.
       + apply op_notin_occurs in Hx2.
         exists (n1 + 0).
         split; try omega.
         apply op_occurs_par; auto.
     * apply IHx2 in H.
       destruct H as [n2 [H2a H2b]].
       destruct (in_dec op0 x1) as [Hx1 | Hx1].
       + apply IHx1 in Hx1.
         destruct Hx1 as [n1 [H1a H1b]].
         exists (n1 + n2).
         split; try omega.
         apply op_occurs_par; auto.
       + apply op_notin_occurs in Hx1.
         exists (0 + n2).
         split; try omega.
         apply op_occurs_par; auto.
Qed.

Definition sameops (x1 x2 : execution): Prop :=
   forall op n,
   op_occurs op x1 n <-> op_occurs op x2 n.

Lemma sameops_refl:
   forall x,
   sameops x x.
Proof.
   unfold sameops.
   intros.
   split; auto. (* auto can't handle x <-> x... sigh *)
Qed.

Lemma sameops_sym:
   forall x1 x2,
   sameops x1 x2 -> sameops x2 x1.
Proof.
   unfold sameops.
   intros.
   split; intro.
   - rewrite H. auto.
   - rewrite <- H. auto.
Qed.

Lemma sameops_in:
   forall x1 x2,
   sameops x1 x2 ->
   forall op, op_in op x1 -> op_in op x2.
Proof.
   intros.
   unfold sameops in H.
   apply op_in_occurs in H0.
   destruct H0 as [n [H0 H1]].
   rewrite H in H1.
   apply op_occurs_in with (n := n); auto.
Qed.

Lemma sameops_occurs:
   forall x1 x2,
   sameops x1 x2 ->
   forall op n, op_occurs op x1 n -> op_occurs op x2 n.
Proof.
   intros.
   unfold sameops in H.
   rewrite <- H.
   auto.
Qed.

Lemma sameops_seq:
   forall x1 x2 y1 y2,
   sameops x1 x2 -> sameops y1 y2 ->
   sameops (exec_seq x1 y1) (exec_seq x2 y2).
Proof.
   unfold sameops in *.
   intros.
   split; intro;
     apply OpOccursSeq in H1;
     destruct H1 as [n1 [n2 [H1 [H2 H3]]]];
     rewrite H1.
   - rewrite H in H2;
     rewrite H0 in H3;
     apply op_occurs_seq; auto.
   - rewrite <- H in H2.
     rewrite <- H0 in H3.
     apply op_occurs_seq; auto.
Qed.

(* this is actually "before or same as" as that's easier to use *)
(* XXX is this even remotely right? what if an op appears twice? *)
Inductive op_before: op -> op -> execution -> Prop :=
| op_before_self: forall op x,
     op_in op x ->
     op_before op op x
| op_before_seq: forall op1 op2 x1 x2,
     op_in op1 x1 -> op_in op2 x2 ->
     op_before op1 op2 (exec_seq x1 x2)
| op_before_seqappend: forall op1 op2 x1 x2,
     op_before op1 op2 x1 ->
     op_before op1 op2 (exec_seq x1 x2)
| op_before_seqprepend: forall op1 op2 x1 x2,
     op_before op1 op2 x2 ->
     op_before op1 op2 (exec_seq x1 x2)
| op_before_parappend: forall op1 op2 x1 x2,
     op_before op1 op2 x1 ->
     op_before op1 op2 (exec_par x1 x2)
| op_before_parprepend: forall op1 op2 x1 x2,
     op_before op1 op2 x2 ->
     op_before op1 op2 (exec_par x1 x2)
.

Definition sameorder (x1 x2 : execution): Prop :=
   forall op1 op2,
   op_before op1 op2 x1 -> op_before op1 op2 x2.

Lemma sameorder_refl:
   forall x, sameorder x x.
Proof.
   unfold sameorder.
   auto.
Qed.

(* XXX
Definition equivalent (x1 x2 : execution): Prop :=
   forall gt0 gt1 gt2,
   eval gt0 x1 = gt1 ->
   eval gt0 x2 = gt2 ->
   forall f, gt_select f gt1 = gt_select f gt2.
*)

(* x1 serializes x2, not x2 serializes x1 *)
Definition serializes (x1 x2 : execution): Prop :=
   sameops x1 x2 /\ sameorder x2 x1 /\ serial x1.
(* /\ equivalent x1 x2 *) (* XXX *)

Lemma serializes_refl:
   forall x, serial x -> serializes x x.
Proof.
   intros.
   unfold serializes.
   split. 2: split.
   - apply sameops_refl.
   - apply sameorder_refl.
   - auto.
Qed.

(*
 * This should be in the typeclass, but first I have to figure out
 * how to hook "execution" up to it.
 *)

Hypothesis ops_noninterference:
   forall op1 op2,
      serializes (exec_seq op1 op2) (exec_par op1 op2) \/
      serializes (exec_seq op2 op1) (exec_par op1 op2).

Theorem serializability:
   forall x2,
   exists x1,
   serializes x1 x2.
Proof.
   intros.
   induction x2.
   - exists (exec_op o). apply serializes_refl; apply serial_op.
   - destruct IHx2_1 as [x_1 IH1].
     destruct IHx2_2 as [x_2 IH2].
     exists (exec_seq x_1 x_2).
     unfold serializes in *.
     destruct IH1 as [IH1a [IH1b IH1c]].
     destruct IH2 as [IH2a [IH2b IH2c]].
     split. 2: split.
     * unfold sameops.
       split; intros.
       1,2: apply OpOccursSeq in H;
         destruct H as [n1 [n2 [Hn [H1 H2]]]];
         unfold sameops in IH1a;
         unfold sameops in IH2a;
         apply IH1a in H1;
         apply IH2a in H2;
         rewrite Hn;
         apply op_occurs_seq; auto.
     * unfold sameorder in *.
       intros.
       inversion H; subst; try discriminate.
       + apply op_before_self.
         assert (sameops (exec_seq x2_1 x2_2) (exec_seq x_1 x_2)) by
            (apply sameops_sym; apply sameops_seq; auto).
         apply sameops_in with (op := op2) in H1; auto.
       + apply sameops_sym in IH1a.
         apply sameops_sym in IH2a.
         apply op_before_seq.
         apply sameops_in with (op := op1) in IH1a; auto.
         apply sameops_in with (op := op2) in IH2a; auto.
       + apply op_before_seqappend.
         apply IH1b; auto.
       + apply op_before_seqprepend.
         apply IH2b; auto.
     * apply serial_seq.
   - destruct IHx2_1 as [sx1 Ser1].
     destruct IHx2_2 as [sx2 Ser2].
     exists (exec_seq sx1 sx2).
     unfold serializes in *.
     destruct Ser1 as [Ser1a [Ser1b Ser1c]].
     destruct Ser2 as [Ser2a [Ser2b Ser2c]].
     split; split.
     * intro.
       apply OpOccursSeq in H.
       destruct H as [n1 [n2 [H1 [H2 H3]]]].
       rewrite H1.
       apply op_occurs_par.
       + apply sameops_occurs with (x1 := sx1); auto.
       + apply sameops_occurs with (x1 := sx2); auto.
     * intro.
       apply OpOccursPar in H.
       destruct H as [n1 [n2 [H1 [H2 H3]]]].
       rewrite H1.
       apply op_occurs_seq.
       + apply sameops_occurs with (x1 := x2_1); apply sameops_sym in Ser1a; auto.
       + apply sameops_occurs with (x1 := x2_2); apply sameops_sym in Ser2a; auto.
     * unfold sameorder in *.
       intros.
       inversion H; subst; try discriminate.
       + apply op_before_self.
         apply OpInPar in H0.
         destruct H0.
         -- apply sameops_sym in Ser1a.
            apply sameops_in with (op := op2) in Ser1a; auto.
            apply op_in_seqa; auto.
         -- apply sameops_sym in Ser2a.
            apply sameops_in with (op := op2) in Ser2a; auto.
            apply op_in_seqb; auto.
       + apply op_before_seqappend.
         apply Ser1b; auto.
       + apply op_before_seqprepend.
         apply Ser2b; auto.
     * apply serial_seq.
Qed.

End ops.


(* This is a test of how to combine type classes with the old records.
Specifically, how to use the pointfree machinery with the [Complete] monad *)
Require Import CRtrans.
Require Import Qmetric.

Section ODE.
Open Scope uc_scope.
Require Import ProductMetric CompleteProduct.
Require Import Unicode.Utf8.
Require Import metric2.Classified.
Require Import stdlib_rationals.

(*
Check (_:MetricSpaceClass (Q*Q)).
Check (_:MetricSpaceClass (CR*Q)).
*)

Section bind_uc.
(* We use the packed MetricSpace because we do not (yet) want to redefine Complete.
However, here is a first attempt:
Definition CompleteC Y `{MetricSpaceClass Y}:=(Complete (bundle_MetricSpace Y)).
  Context `{MetricSpaceClass X} `{MetricSpaceClass Y}
   {f: X → CompleteC Y} `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}.
*)

Context {X Y : MetricSpace} (f: X → Complete Y) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}.

(* Definition bindf : Complete X -> Complete Y :=
  Cbind_slow  (wrap_uc_fun' f).

Definition test: UCFunction (Complete X) (Complete Y):=
  ucFunction (fun x => bindf x). *)

(* The classified version *)
Definition Cbind_slowC: UCFunction (Complete X) (Complete Y):=
   ucFunction (Cbind_slow  (wrap_uc_fun' f)).

Variable g:X --> Complete Y.
Definition test': UCFunction (Complete X) (Complete Y):=
  ucFunction (fun x => (Cbind_slow g) x).

(* Note that: unwrap_uc_fun automatically unwraps g *)
End bind_uc.
Notation " f >> g ":= (Cbind_slowC f ∘ g) (at level 50).
Notation " x >>= f ":= (Cbind_slowC f x) (at level 50).

Section test.
(* Should Q*Q be bundled ? *)
Context (v: (Q*Q) → CR)
        `{!UniformlyContinuous_mu v}
        `{!UniformlyContinuous v}.

Context (f:Q→CR)
        `{!UniformlyContinuous_mu f}
        `{!UniformlyContinuous f}.

(*
Can be replace by the default (,) ?
Notation "( f , g )":= (together f g).
We would like to define fun x => v (x, f x), more precisely:
*)

Check (Cbind_slowC v).
Definition vxfx : UCFunction Q CR :=
  ucFunction (fun x => (Couple (Cunit x, f x) >>= v)).

Better:
Definition vxfx : UCFunction Q CR :=
  ucFunction (fun x => (Couple (x, f x) >>= v)).

Where Cunit is derived from the Coercion inject_Q.
Coercion inject_Q: QArith_base.Q>-> CR.
But this cannot be a Coercion(?)
*)
End test.