Library ctl_semantics

Require Import base.

Require Import nominal.
Require Import syntax.
Require Import basic_semantics.
Require Import par_semantics.

Module Type SEQ_CTL_INPUT.
  Parameter ctl_st : Type.
  Parameter ctl_transfer : ctl_st -> Z -> ctl_st + Z.
  Parameter ctl_st_init : ctl_st.

  Parameter ctl_st_eq_dec : forall x y:ctl_st, {x=y}+{x<>y}.
End SEQ_CTL_INPUT.

Module SEQ_CTL (SI:SEQ_CTL_INPUT).
  Import SI.

  Inductive st (X:ctl_st -> Type):=
    | RUN : forall (cs:ctl_st) (x:X cs), st X
    | FINISH : st X.

  Lemma RUN_inj1 : forall X x y a b,
    RUN X x a = RUN X y b -> x = y.

  Lemma RUN_inj2 : forall X x a b,
    RUN X x a = RUN X x b -> a = b.

  Section seq_ctl.
    Variable tasks : ctl_st -> prog.

    Let X := (fun x => state (psys (tasks x))).
    Let st := st X.

    Definition init_st (cs:ctl_st) : st :=
      RUN X cs (init (tasks cs)).

    Definition transfer_st (cs:ctl_st) (z:Z) : st :=
        match ctl_transfer cs z with
        | inl cs' => init_st cs'
        | inr z' => FINISH X
        end.

    Definition transfer_obs (cs:ctl_st) (z:Z) : option OBS :=
      match ctl_transfer cs z with
      | inl cs' => None
      | inr z' => Some (obs_val z')
      end.

    Inductive ctl_steps : st -> option OBS -> lift st -> Prop :=
    | ctl_step_inner : forall cs x o x',
         (forall z, o <> Some (obs_val z)) ->
         steps (psys (tasks cs)) x o x' ->
         ctl_steps (RUN X cs x) o (lift_map (RUN X cs) x')

    | ctl_step_transfer : forall cs x z x',
         steps (psys (tasks cs)) x (Some (obs_val z)) x' ->
         ctl_steps (RUN X cs x) (transfer_obs cs z) (into (transfer_st cs z)).

    Definition ctl_lts : LTS := Build_LTS st ctl_steps.
    Program Definition ctl_prog : prog := Build_prog ctl_lts (init_st ctl_st_init).

    Lemma inner_must_step : forall cs a o b,
      (forall z, o <> Some (obs_val z)) ->
      must_step (psys (tasks cs)) a o b ->
      must_step ctl_lts (lift_map (RUN X cs) a) o (lift_map (RUN X cs) b).

    Lemma inner_must_step_star : forall cs a b,
      must_step_star (psys (tasks cs)) a b ->
      must_step_star ctl_lts (lift_map (RUN X cs) a) (lift_map (RUN X cs) b).

    Lemma inner_may_step : forall cs a o b,
      (forall z, o <> Some (obs_val z)) ->
      may_step (psys (tasks cs)) a o b ->
      may_step ctl_lts (lift_map (RUN X cs) a) o (lift_map (RUN X cs) b).

    Lemma inner_may_step_star : forall cs a b,
      may_step_star (psys (tasks cs)) a b ->
      may_step_star ctl_lts (lift_map (RUN X cs) a) (lift_map (RUN X cs) b).

    Lemma ctl_read_receptive :
      (forall cs, read_receptive (psys (tasks cs))) ->
      read_receptive ctl_lts.

    Lemma ctl_mho_obs_crashes :
      (forall cs, mho_obs_crashes (psys (tasks cs))) ->
      mho_obs_crashes ctl_lts.

    Lemma ctl_reachable_same : forall q1 q2,
      reachable' ctl_lts q1 q2 ->
      forall cs s1 s2,
        contains q1 (RUN X cs s1) ->
        contains q2 (RUN X cs s2) ->
        reachable' (psys (tasks cs)) (into s1) (into s2) \/
        reachable' (psys (tasks cs)) (into (init (tasks cs))) (into s2).

    Lemma ctl_reachable_other : forall q1 q2,
      reachable' ctl_lts q1 q2 ->
      forall cs1 s1 cs2 s2, cs1 <> cs2 ->
        contains q1 (RUN X cs1 s1) ->
        contains q2 (RUN X cs2 s2) ->
        reachable' (psys (tasks cs2)) (into (init (tasks cs2))) (into s2).

    Lemma ctl_reachable_init : forall cs s,
      reachable' ctl_lts (into (init_st ctl_st_init)) (into (RUN X cs s)) ->
      reachable' (psys (tasks cs)) (into (init (tasks cs))) (into s).

    Lemma refines_mho_lemma : forall cs a,
      refines branch_ind (psys (tasks cs)) void_lts (into a) (mho Empty_set) ->
      refines branch_ind ctl_lts void_lts
        (into (RUN (fun x0 : ctl_st => state (psys (tasks x0))) cs a))
        (mho Empty_set).
  End seq_ctl.

  Lemma ctl_support : forall tasks v,
    support (ctl_prog tasks) v ->
    exists cs, support (tasks cs) v.

  Section papp_commute.
    Variable p:perm.
    Variable tasks : ctl_st -> prog.

    Let A := papp p (ctl_lts tasks).
    Let B := ctl_lts (fun x => papp p (tasks x)).

    Lemma ctl_papp_steps : forall x o x',
      steps A x o x' <-> steps B x o x'.

    Lemma ctl_papp_commute :
      papp p (ctl_prog tasks) = ctl_prog (fun x => papp p (tasks x)).
  End papp_commute.

  Section ctl_congruence.
    Variable T1 T2 : ctl_st -> prog.

    Let X1 cs := state (psys (T1 cs)).
    Let X2 cs := state (psys (T2 cs)).

    Section mho_rel.

    Variable mho_rel :
      lift (st X1) -> lift (st X2) -> Prop.

    Hypothesis mho_rel_finish :
      mho_rel (into (FINISH _)) (into (FINISH _)).

    Hypothesis mho_rel_mho :
      mho_rel (mho _) (mho _).

    Definition ctl_pacc_rel
      (R:forall cs, lift (X1 cs) -> lift (X2 cs) -> Prop)
      (x:lift (st X1)) (y:lift (st X2)) :=
      mho_rel x y \/
      exists cs, exists s1, exists s2,
        x = lift_map (RUN X1 cs) s1 /\
        y = lift_map (RUN X2 cs) s2 /\
        R cs s1 s2.

    Lemma ctl_branch_forward : forall cs s1 s2 R,
      refinement branch_forward_ind_no_stutter (psys (T1 cs)) (psys (T2 cs)) (R cs) ->
      forall (HR : forall c, R c (into (init (T1 c))) (into (init (T2 c)))),
      R cs s1 s2 ->
      branch_forward_ind_no_stutter (psys (T1 cs)) (psys (T2 cs)) (R cs) s1 s2 ->
      branch_forward_ind_no_stutter (ctl_lts T1) (ctl_lts T2)
      (ctl_pacc_rel R)
      (lift_map (RUN X1 cs) s1) (lift_map (RUN X2 cs) s2).

    Lemma ctl_branch_backward : forall cs s1 s2 R,
      refinement branch_backward_ind_no_stutter (psys (T1 cs)) (psys (T2 cs)) (R cs) ->
      forall (HR : forall c, R c (into (init (T1 c))) (into (init (T2 c)))),
      forall (HR2 : forall c x, R c x (mho _) -> may_step_star _ x (mho _)),
      forall (asdf: (forall x, mho_rel (mho _) x) \/
                    (forall cs x o x', R cs (mho _) x -> must_step _ x (Some o) x' -> False)),
      R cs s1 s2 ->
      branch_backward_ind_no_stutter (psys (T1 cs)) (psys (T2 cs)) (R cs) s1 s2 ->
      branch_backward_ind_no_stutter (ctl_lts T1) (ctl_lts T2)
      (ctl_pacc_rel R)
      (lift_map (RUN X1 cs) s1) (lift_map (RUN X2 cs) s2).

    End mho_rel.

    Lemma ctl_pacc_rel_refinement :
      forall (Hpacc:forall cs, pacc (T1 cs) (T2 cs)),
      let R := (fun cs => refines branch_ind_no_stutter (psys (T1 cs)) (psys (T2 cs))) in
      let mho_rel x y :=
          x = mho _ \/ (x = into (FINISH _) /\ y = into (FINISH _)) in
      refinement branch_ind_no_stutter (ctl_lts T1) (ctl_lts T2) (ctl_pacc_rel mho_rel R).

    Lemma ctl_choice_forward R :
      let mho_rel x y :=
          x = mho _ \/ (x = into (FINISH _) /\ y = into (FINISH _)) in
      (forall cs, refinement choice_forward' _ _ (R cs)) ->
      refinement choice_forward' (ctl_lts T1) (ctl_lts T2) (ctl_pacc_rel mho_rel R).

    Lemma ctl_pacc :
      (forall cs, pacc (T1 cs) (T2 cs)) ->
      pacc (ctl_prog T1) (ctl_prog T2).

    Lemma ctl_choice_pacc :
      (forall cs, choice_pacc (T1 cs) (T2 cs)) ->
      choice_pacc (ctl_prog T1) (ctl_prog T2).
  End ctl_congruence.

  Lemma refinement_bisim_branch_forward : forall X Y,
   refinement branch_forward_ind_no_stutter X Y
     (bisimilar branch_ind_no_stutter X Y).

  Lemma refinement_bisim_branch_backward : forall X Y,
   refinement branch_backward_ind_no_stutter X Y
     (bisimilar branch_ind_no_stutter X Y).

  Lemma bisim_ind_no_stutter_mho : forall X Y,
    bisimilar branch_ind_no_stutter X Y (mho _) (mho _).

  Section ctl_peq.
    Let mho_rel T1 T2 x y :=
      (x = into (FINISH _) /\ y = into (FINISH _)) \/
      (x = mho _ /\ bisimilar branch_ind_no_stutter (ctl_lts T2) (ctl_lts T1) y (mho _)) \/
      (y = mho _ /\ bisimilar branch_ind_no_stutter (ctl_lts T1) (ctl_lts T2) x (mho _)).

    Let R T1 T2 :=
      (ctl_pacc_rel T1 T2 (mho_rel T1 T2)
        (fun cs => bisimilar branch_ind_no_stutter (psys (T1 cs)) (psys (T2 cs)))).

    Lemma ctl_peq_refinement : forall T1 T2,
      (forall cs, peq (T1 cs) (T2 cs)) ->
      refinement branch_ind_no_stutter (psys (ctl_prog T1)) (psys (ctl_prog T2)) (R T1 T2).

    Lemma ctl_peq_R_inv : forall T1 T2 x y,
      R T1 T2 x y -> R T2 T1 y x.

    Lemma ctl_peq_bisim : forall T1 T2,
      (forall cs, peq (T1 cs) (T2 cs)) ->
      bisimulation branch_ind_no_stutter (psys (ctl_prog T1)) (psys (ctl_prog T2)) (R T1 T2).

    Lemma ctl_peq : forall T1 T2,
      (forall cs, peq (T1 cs) (T2 cs)) ->
      peq (ctl_prog T1) (ctl_prog T2).
  End ctl_peq.

  Section ctl_extrusion.
    Variable x : ctl_st.
    Variable TA TB : ctl_st -> prog.
    Variable v : VAR.
    Variable P : prog.

    Let A := ctl_prog TA.
    Let B := par_prog v P (ctl_prog TB).

    Let XA x' := state (psys (TA x')).
    Let XB x' := state (psys (TB x')).

    Hypothesis HsupportT : forall x',
      support (TB x') v -> x = x'.

    Hypothesis HsupportP : forall p o p',
      steps (psys P) p o p' -> support o v.

    Hypothesis Hx'_strong_ref : forall x', x <> x' ->
      strong_refines (psys (TA x')) (psys (TB x'))
        (into (init (TA x'))) (into (init (TB x'))).

    Hypothesis Hx_weak_ref : forall pb,
      refines branch_ind (psys (TA x)) (psys (par_prog v P (TB x)))
        (into (init (TA x))) (into (into pb, into (init (TB x)))).

    Hypothesis HP_cocrashes : forall v oa ob p p' b b',
      obs_complement v oa ob ->
      steps (psys P) p (Some oa) p' ->
      steps (psys (TB x)) b (Some ob) b' ->
      p' = mho _ ->
      refines branch_ind (psys (TB x)) void_lts b' (mho _).

    Definition ctl_extrude_rel (a:state (psys A)) (b:state (psys B)) :=
      match a with
      | FINISH =>
          match b with
          | (into pb, into FINISH) => True
          | _ => False
          end
      | RUN csa a =>
          (x = csa /\

            match b with
            | (pb, into FINISH) => False
            | (pb, mho) =>

              refines branch_ind (psys (TA csa)) void_lts (into a) (mho _)

            | (into pb, into (RUN csb b)) =>

              x = csb /\
              refines branch_ind (psys (TA csa)) (psys (par_prog v P (TB csb)))
                (into a) (into (into pb, into b))

            | (mho, into (RUN csb b)) =>

              x = csb /\
                refines branch_ind _ void_lts (into a) (mho _)

            end
          ) \/
          ( x <> csa /\
            match b with
            | (into pb, into (RUN csb b)) =>
              csa = csb /\
              reachable' (psys (TB csb)) (into (init (TB csb))) (into b) /\
              strong_refines (psys (TA csa)) (psys (TB csb))
                 (into a) (into b)
            | _ => False
            end)
      end.

    Definition ctl_extrude_rel' (a:lstate (psys A)) (b:lstate (psys B)) :=
      match a, b with
      | into a', into b' => ctl_extrude_rel a' b'
      | into a', mho => refines branch_ind _ void_lts a (mho _)
      | mho, _ => True
      end.

    Lemma refines_mho_lemma1 : forall x,
      refines branch_ind (ctl_lts TA) void_lts x (mho Empty_set) ->
      branch_ind (psys A) (psys B) ctl_extrude_rel' x (mho (state (psys B))).

    Lemma refines_mho_lemma2' : forall a pb b,
      refines branch_ind (psys (TA x)) void_lts (into a) (mho Empty_set) ->
      branch_ind (psys A) (psys B) ctl_extrude_rel'
        (into (RUN (fun x0 : ctl_st => state (psys (TA x0))) x a))
        (into (pb, into (RUN _ x b))).

    Lemma refines_mho_lemma2 : forall a pb,
      refines branch_ind (psys (TA x)) void_lts (into a) (mho Empty_set) ->
      branch_ind (psys A) (psys B) ctl_extrude_rel'
        (into (RUN (fun x0 : ctl_st => state (psys (TA x0))) x a))
        (into (pb, mho (state (psys (ctl_prog TB))))).

    Lemma refines_mho_lemma3 : forall z pb,
      refines branch_ind (psys (TB x)) void_lts z (mho _) ->
      refines branch_ind (par_lts (psys P) (psys (TB x)) v) void_lts
      (into (pb, z)) (mho Empty_set).

    Lemma refines_mho_lemma4 : forall pb,
      refines branch_ind (par_lts (psys P) (psys (TB x)) v) void_lts
      (into (pb, mho (state (psys (TB x))))) (mho Empty_set).

    Lemma refines_mho_lemma5 : forall a pb b b0,
      path_where (lstate (par_lts (psys P) (psys (TB x)) v))
      (fun a0 b1 : lstate (par_lts (psys P) (psys (TB x)) v) =>
        must_step (par_lts (psys P) (psys (TB x)) v) a0 None b1)
      (refines branch_ind (psys (TA x)) (par_lts (psys P) (psys (TB x)) v)
        (into a)) (into (into pb, into b))
      (into (mho (state (psys P)), into b0)) ->
      refines branch_ind (psys (TB x)) void_lts (into b0) (mho (state void_lts)).

    Lemma refines_into_lemma : forall a pb b,
      refines branch_ind (psys (TA x)) (par_lts (psys P) (psys (TB x)) v)
      (into a) (into (into pb, into b)) ->
      branch_ind (psys A) (psys B) ctl_extrude_rel'
      (into (RUN (fun x0 : ctl_st => state (psys (TA x0))) x a))
      (into
        (into pb, into (RUN (fun x0 : ctl_st => state (psys (TB x0))) x b))).

    Lemma ctl_extrude_refinement : refinement branch_ind (psys A) (psys B) ctl_extrude_rel'.

    Lemma ctl_extrude_pacc : pacc A B.

  End ctl_extrusion.
End SEQ_CTL.