Library strong_ref

Require Import base.
Require Import prelim.
Require Import prop_logic.

Module STRONG_REF.
Import PropLogic.

Section strong_ref. Context {Obs:ObservationSystem}.
  Record LTS :=
  { lts_state : Type
  ; lts_steps : lts_state -> O -> lts_state -> Prop
  }.

  Record ELTS :=
  { state : Type
  ; steps : state -> O -> lift state -> Prop
  }.

  Definition lts_lift (X:LTS) : ELTS :=
    Build_ELTS (lts_state X) (fun x o x' =>
      match x' with
      | mho => False
      | into x_ => lts_steps X x o x_
      end).

  Definition lts_unlift (X:ELTS) : LTS :=
    Build_LTS (state X)
      (fun x o x' => steps X x o (into x')).

  Definition lstate X := lift (state X).

  Definition must_step (X:ELTS) (x:lstate X) (o:O) (x':lstate X) :=
    match x with
    | mho => False
    | into x_ => steps X x_ o x'
    end.

  Definition may_step (X:ELTS) (x:lstate X) (o:O) (x':lstate X) :=
    must_step X x o x' \/ (x = mho _ /\ x' = mho _).

  Definition bisimulation (X Y:LTS) (R:lts_state X -> lts_state Y -> Prop) :=
    forall x y, R x y ->
      (forall o x', lts_steps X x o x' -> exists y', lts_steps Y y o y' /\ R x' y') /\
      (forall o y', lts_steps Y y o y' -> exists x', lts_steps X x o x' /\ R x' y').

  Definition wrong_bisimulation (X Y:ELTS) (R:lstate X -> lstate Y -> Prop) :=
    forall x y, R x y ->
      (x = mho _ <-> y = mho _) /\
      (forall o x', must_step X x o x' -> exists y', must_step Y y o y' /\ R x' y') /\
      (forall o y', must_step Y y o y' -> exists x', must_step X x o x' /\ R x' y').

  Definition bisimilar (X Y:LTS) x y :=
    exists R, bisimulation X Y R /\ R x y.

  Definition wrong_bisimilar (X Y:ELTS) (x:lstate X) (y:lstate Y) :=
    exists R, wrong_bisimulation X Y R /\ R x y.

  Inductive wrong_rel' X Y (R:state X -> state Y -> Prop) : lstate X -> lstate Y -> Prop :=
    | wrong_rel_mho' : wrong_rel' X Y R (mho _) (mho _)
    | wrong_rel_into' : forall x y, R x y -> wrong_rel' X Y R (into x) (into y).

  Definition unrel X Y (R:lstate X -> lstate Y -> Prop) :=
    fun x y => R (into x) (into y).

  Definition strong_refinement (X Y:ELTS) (R:lstate X -> lstate Y -> Prop) :=
    forall x y, R x y ->
      (forall o x', must_step X x o x' -> exists y', must_step Y y o y' /\ R x' y') /\
      (forall o y', may_step Y y o y' -> exists x', may_step X x o x' /\ R x' y').

  Definition strong_ref (X Y:ELTS) (x:lstate X) (y:lstate Y) :=
    exists R, strong_refinement X Y R /\ R x y.

  Lemma strong_refinement_eq X : strong_refinement X X eq.

  Lemma strong_refinement_comp X Y Z R1 R2 :
    strong_refinement X Y R1 ->
    strong_refinement Y Z R2 ->
    strong_refinement X Z (comp R1 R2).

  Lemma strong_ref_mho X Y y : strong_ref X Y (mho _) y.

  Lemma strong_ref_refl X x : strong_ref X X x x.

  Lemma strong_ref_trans X Y Z x y z:
    strong_ref X Y x y -> strong_ref Y Z y z -> strong_ref X Z x z.

  Inductive ihm_mode :=
    | box : O -> ihm_mode
    | dia : O -> ihm_mode.

  Record proc := { psys : ELTS; pstate : lstate psys }.

  Inductive pmust_step : proc -> O -> proc -> Prop :=
    | pmust : forall X x o x',
         must_step X x o x' ->
         pmust_step (Build_proc X x) o (Build_proc X x').

  Inductive pmay_step : proc -> O -> proc -> Prop :=
    | pmay : forall X x o x',
         may_step X x o x' ->
         pmay_step (Build_proc X x) o (Build_proc X x').

  Inductive proc_acc : proc -> proc -> Prop :=
    | pacc : forall X Y x y, strong_ref X Y x y -> proc_acc (Build_proc X x) (Build_proc Y y).

  Definition interp_ihm_mode (m:ihm_mode) (P:proc -> Prop) (w:proc) :=
    match m with
    | box o => forall w', pmay_step w o w' -> P w'
    | dia o => exists w', pmust_step w o w' /\ P w'
    end.

  Program Instance IHM_INPUT : LOGIC_INPUT :=
  { world := proc
  ; accessable := proc_acc
  ; atom := Empty_set
  ; mode := ihm_mode
  ; interp_mode := interp_ihm_mode
  ; interp_atom x := match x with end
  }.

  Definition image_finite (Y:ELTS) :=
    forall y o, exists l,
      forall y', steps Y y o y' <-> In y' l.

  Ltac nnpp :=
    match goal with [ |- ?P ] => destruct (classic P); [ trivial | elimtype False] end.

  Lemma construct_counter1 X Y ly x o x' y :
    forall f0,
    must_step X x o x' ->
    interp f0 (Build_proc X x') ->
    (forall y' : lstate Y,
       In y' ly ->
       exists f : formula,
         interp f {| psys := X; pstate := x' |} /\
         ~ interp f {| psys := Y; pstate := y' |}) ->
    (forall y', steps Y y o y' -> In y' ly \/ ~interp f0 (Build_proc Y y')) ->
    exists f,
      interp f (Build_proc X x') /\
      (forall y', steps Y y o y' -> ~interp f (Build_proc Y y')).

  Lemma construct_counter2 X Y lx y o y' x :
    forall f0,
    may_step Y y o y' ->
    (forall x', may_step X x o x' -> In x' lx \/ interp f0 (Build_proc X x')) ->
    (forall x' : lstate X,
       In x' lx ->
       exists f : formula,
         interp f {| psys := X; pstate := x' |} /\
         ~ interp f {| psys := Y; pstate := y' |}) ->
    ~interp f0 (Build_proc Y y') ->
    exists f,
      (forall x', may_step X x o x' -> interp f (Build_proc X x')) /\
      ~interp f (Build_proc Y y').

  Lemma mho_valid : forall X f,
    interp f (Build_proc X (mho _)) ->
    forall w, interp f w.

  Lemma strong_ref_mho' X Y R : forall x,
    strong_refinement X Y R -> R x (mho _) -> x = mho _.

  Lemma strong_refinement_inv X Y R :
    (strong_refinement X Y R /\ strong_refinement Y X (inv R)) <->
    wrong_bisimulation X Y R.

  Definition reachable X :=
    clos_refl_trans _ (fun a b => exists o, must_step X a o b).

  Definition safe_state X x :=
    forall x', reachable X x x' -> x' <> mho _.

  Definition safe_proc x := safe_state (psys x) (pstate x).

  Lemma safe_eq1 : forall X x,
    safe_state X x <->
    (exists X0, exists x0, wrong_bisimilar X (lts_lift X0) x (into x0)).

  Definition maximal X x := forall Y y,
    strong_ref X Y x y -> wrong_bisimilar X Y x y.

  Lemma wrong_bisim_sym X Y x y :
    wrong_bisimilar X Y x y -> wrong_bisimilar Y X y x.

  Definition lts_safe (X:ELTS) : ELTS :=
    Build_ELTS (state X)
      (fun x o x' =>
        (steps X x o x' /\ x' <> mho _) \/
        (into x = x' /\ steps X x o (mho _))).

  Lemma lts_safe_is_safe X x :
    x <> mho _ -> safe_state (lts_safe X) x.

  Lemma safe_refine : forall X Y x y,
    strong_ref X Y x y ->
    safe_state X x ->
    safe_state Y y.

  Lemma lts_safe_refines : forall X x,
    strong_ref X (lts_safe X) x x.

  Lemma safe_eq2 : forall X x,
    safe_state X x <-> maximal X x.

  Definition classical_process x :=
    forall f, interp (disj f (impl f FF)) x.

  Lemma safe_eq3_1 {Classic:EM} : forall x, safe_proc x -> classical_process x.

  Lemma classical_step {Classic:EM} : forall X x o x',
    must_step X x o x' ->
    classical_process (Build_proc X x) ->
    classical_process (Build_proc X x').

  Lemma safe_eq3_2 {Classic:EM} : forall x, classical_process x -> safe_proc x.

  Theorem adequacy {Classic:EM} : forall x y
    (HX: image_finite (psys x)) (HY:image_finite (psys y)),

    (forall f:formula, interp f x -> interp f y) ->
    proc_acc x y.

  Require Import logic.

  Section mucalc.
    Import MuCalc.

    Section characteristic.

    Variable X:ELTS.

    Let E1 := extend emptyE (arr (lstate X) o).

    Definition CF_body (x:lstate X) (ob:O) : formula emptyE E1 o :=
      f_and
        (conj' (fun x':{ x' | must_step X x ob x' } =>
          modality _ _ o (dia ob) (app (var emptyE E1 None) (proj1_sig x'))))
        (modality _ _ o (box ob) (disj' (fun x':{ x' | may_step X x ob x'} =>
          app (var emptyE E1 None) (proj1_sig x')))).

    Definition CF_main : formula _ _ (arr (lstate X) o) :=
      nu _ _ (arr (lstate X) o) (lam emptyE E1 (lstate X) o (fun x =>
        conj' (fun ob => CF_body x ob))).

    Lemma characteristic_self : forall x,
      interp_cformula _ CF_main (x,tt) (Build_proc X x).

    Lemma characteristic_other : forall x w,
      interp_cformula _ CF_main (x,tt) w ->
      proc_acc (Build_proc X x) w.

    End characteristic.

    Definition CF (w:world) : cformula o :=
      app (CF_main (psys w)) (pstate w).

    Theorem CF_is_characteristic : characteristic_formula CF.
  End mucalc.

  Definition refinement (X Y:ELTS) (R:state X -> state Y -> Prop) :=
    forall x y, R x y ->
      (forall o x', steps X x o x' -> exists y', steps Y y o y' /\
        (forall z1, contains x' z1 -> exists z2, contains y' z2) /\
        (forall z1 z2, contains x' z1 -> contains y' z2 -> R z1 z2))
      /\
      (forall o y', steps Y y o y' -> exists x', steps X x o x' /\
        (forall z1, contains x' z1 -> exists z2, contains y' z2) /\
        (forall z1 z2, contains x' z1 -> contains y' z2 -> R z1 z2)).

  Definition refines X Y x y :=
    exists R, refinement X Y R /\ R x y.

  Inductive wrong_rel X Y (R:state X -> state Y -> Prop) : lstate X -> lstate Y -> Prop :=
    | wrong_rel_mho : forall y, wrong_rel X Y R (mho _) y
    | wrong_rel_into : forall x y, R x y -> wrong_rel X Y R (into x) (into y).

  Lemma strong_ref_wrong_rel X Y : strong_refinement X Y (wrong_rel X Y (fun _ _ => False)).

  Lemma strong_refines_mho X Y y : strong_ref X Y (mho _) y.

  Lemma strong_refinement_trip : forall X Y R,
    strong_refinement X Y R ->
    strong_refinement X Y (wrong_rel X Y (unrel X Y R)).

  Lemma ref_eq : forall X Y R,
    refinement X Y R <-> strong_refinement X Y (wrong_rel X Y R).

  Lemma ref_eq' : forall X Y R,
    refinement X Y (unrel X Y (wrong_rel X Y R)) <-> strong_refinement X Y (wrong_rel X Y R).

  Lemma strong_refines_equiv X Y x y :
    wrong_rel X Y (refines X Y) x y <-> strong_ref X Y x y.

  Lemma strong_refines_equiv' X Y x y : refines X Y x y <-> unrel X Y (strong_ref X Y) x y.

  Record wrong_expansion (X Y:ELTS) (f:state X -> state Y) :=
  { expand_inj : forall x x', f x = f x' -> x = x'
  ; expand_prf1 : forall x o x',
       steps X x o (into x') ->
       steps Y (f x) o (into (f x'))
  ; expand_prf2 : forall x o,
       steps X x o (mho _) ->
       exists y, steps Y (f x) o y
  ; expand_prf3 : forall x o y,
       steps Y (f x) o y ->
       exists x', steps X x o x' /\
         match x' with
         | mho => True
         | into z => y = into (f z)
         end
  }.

  Definition wrong_expands X Y x y :=
    exists f, wrong_expansion X Y f /\
      wrong_rel _ _ (fun x y => f x = y) x y.

  Definition wrong_expands' X Y x y :=
    exists Q1, exists Q2, exists q1, exists q2,
      wrong_bisimilar X Q1 x q1 /\
      wrong_expands Q1 Q2 q1 q2 /\
      wrong_bisimilar Q2 Y q2 y.

  Lemma expansion_refinement : forall X Y f,
    (wrong_expansion X Y f) ->
    strong_refinement X Y (wrong_rel X Y (fun x y => f x = y)).
End strong_ref.

Module ExpandRef.
Section expandref. Context {Obs:ObservationSystem}.
  Variables X Y:ELTS.
  Variable R:state X -> state Y -> Prop.
  Hypothesis HR:refinement X Y R.

  Record Q1st := mkQ1 { q1x :state X; q1y:state Y; q1H : R q1x q1y }.

  Inductive Q1step : Q1st -> O -> lift Q1st -> Prop :=
  | Q1step1 : forall o x x' y y' (H:R x y) (H':R x' y'),
      steps X x o (into x') ->
      steps Y y o (into y') ->
      Q1step (mkQ1 x y H) o (into (mkQ1 x' y' H'))
  | Q1step2 : forall o x y (H:R x y),
      steps X x o (mho _) ->
      Q1step (mkQ1 x y H) o (mho _).

  Definition Q1 := Build_ELTS Q1st Q1step.

  Lemma XQ1_bisim : wrong_bisimulation X Q1 (wrong_rel' X Q1 (fun x q => q1x q = x)).

  Inductive Q2st :=
  | mkQ2 : forall (x:state X) (y:state Y), R x y -> Q2st
  | mkQ2Y : state Y -> Q2st.

  Definition q2y (q:Q2st) :=
    match q with
    | mkQ2 _ y _ => y
    | mkQ2Y y => y
    end.

  Inductive Q2step : Q2st -> O -> lift Q2st -> Prop :=
  | Q2step1 : forall o x x' y y' (H:R x y) (H':R x' y'),
      steps X x o (into x') ->
      steps Y y o (into y') ->
      Q2step (mkQ2 x y H) o (into (mkQ2 x' y' H'))
  | Q2step2 : forall o x y (H:R x y) y',
      steps X x o (mho _) ->
      steps Y y o (into y') ->
      Q2step (mkQ2 x y H) o (into (mkQ2Y y'))
  | Q2step3 : forall o x y (H:R x y),
      steps X x o (mho _) ->
      steps Y y o (mho _) ->
      Q2step (mkQ2 x y H) o (mho _)
  | Q2step4 : forall y o y',
      steps Y y o (into y') ->
      Q2step (mkQ2Y y) o (into (mkQ2Y y'))
  | Q2step5 : forall y o,
      steps Y y o (mho _) ->
      Q2step (mkQ2Y y) o (mho _).

  Definition Q2 := Build_ELTS Q2st Q2step.

  Lemma Q2_Y_bisim : wrong_bisimulation Q2 Y (wrong_rel' Q2 Y (fun q y => q2y q = y)).

  Definition Q1toQ2 (x:Q1st) :=
    match x with
    | mkQ1 x y H => mkQ2 x y H
    end.

  Lemma Q1toQ2expand : wrong_expansion Q1 Q2 Q1toQ2.
End expandref.

Lemma wrong_bisim_mho (Obs:ObservationSystem) : forall X Y,
  wrong_bisimilar X Y (mho _) (mho _).

Lemma refinement_refines (Obs:ObservationSystem) : forall X Y,
  refinement X Y (refines X Y).

Theorem refines_expands' (Obs:ObservationSystem) (o:O) X Y x y :
  strong_ref X Y x y <-> wrong_expands' X Y x y.
End ExpandRef.

End STRONG_REF.