Library strong_choice

Require Import base.
Require Import prelim.

Module READY_PRUNE.
Section ready_prune. Context {Obs:ObservationSystem}.

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

Definition enables {X:LTS} (x:state X) (o:O) :=
  exists x', steps X x o x'.

Record global_pruning (X Y:LTS) (abstr : state Y -> state X) : Prop :=
  { prune_inj : forall y y', abstr y = abstr y' -> y = y'
  ; prune_sub : forall y o y', steps Y y o y' -> steps X (abstr y) o (abstr y')
  ; prune_enable : forall y o, enables (abstr y) o -> enables y o
  }.

Definition bisim (X Y:LTS) (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' /\ R x' y') /\
    (forall o y', steps Y y o y' -> exists x', steps X x o x' /\ R x' y').

Definition ready_sim (X Y:LTS) (R:state X -> state Y -> Prop) :=
  forall x y, R x y ->
    (forall o, enables x o -> enables y o) /\
    (forall o y', steps Y y o y' -> exists x', steps X x o x' /\ R x' y').

Lemma bisim_ready_sim X Y R : bisim X Y R -> ready_sim X Y R.

Definition ready_ref X Y x y :=
  exists R, ready_sim X Y R /\ R x y.

Definition bisimilar X Y x y :=
  exists R, bisim X Y R /\ R x y.

Definition global_pruned_ref X Y x y :=
  exists Q1, exists Q2, exists q1, exists q2,
    bisimilar X Q1 x q1 /\
    (exists f, global_pruning Q1 Q2 f /\ q1 = f q2) /\
    bisimilar Q2 Y q2 y.

Lemma global_pruning_bisim (X Y:LTS) abstr :
  global_pruning X Y abstr ->
  ready_sim X Y (fun x y => x = abstr y).

Lemma eq_ready_sim : forall X, ready_sim X X eq.

Lemma comp_ready_sim : forall X Y Z R1 R2,
  ready_sim X Y R1 ->
  ready_sim Y Z R2 ->
  ready_sim X Z (comp R1 R2).

Lemma ready_ref_refl : forall X x, ready_ref X X x x.

Lemma ready_ref_trans : forall X Y Z x y z,
  ready_ref X Y x y ->
  ready_ref Y Z y z ->
  ready_ref X Z x z.

Record world :=
  { sys : LTS
  ; root : state sys
  }.

Definition world_acc (x y:world) :=
  ready_ref (sys x) (sys y) (root x) (root y).

Lemma acc_refl : forall x, world_acc x x.

Lemma acc_trans : forall x y z,
  world_acc x y -> world_acc y z -> world_acc x z.

Inductive mode :=
| box : O -> mode.

Inductive atom :=
| offers : O -> atom.

Definition interp_sc_mode (m:mode) (P:world -> Prop) (w:world) : Prop :=
  match m with
  | box o => forall s, steps (sys w) (root w) o s -> P (Build_world (sys w) s)
  end.

Definition interp_sc_atom (a:atom) (w:world) : Prop :=
  match a with
  | offers o => exists s', steps (sys w) (root w) o s'
  end.

Program Instance strong_choice_logic_input : LOGIC_INPUT :=
  {| world := world
   ; accessable := world_acc
   ; atom := atom
   ; mode := mode
   ; interp_atom := interp_sc_atom
   ; interp_mode := interp_sc_mode
   |}.

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

Require Import prop_logic.

Section adequacy.
  Import PropLogic.

  Context {Classic:EM}.

  Variable X:LTS.
  Variable Y:LTS.

  Hypothesis HfinX : image_finite X.
  Hypothesis HfinY : image_finite Y.

  Let R (x:state X) (y:state Y) :=
      forall f, interp f (Build_world X x) ->
                interp f (Build_world Y y).

  Lemma adequate_ready_sim: ready_sim X Y R.

End adequacy.

Theorem prop_soundness : forall x y,
  world_acc x y ->
  (forall f, PropLogic.interp f x -> PropLogic.interp f y).

Theorem adequacy {Classic:EM} : forall x y,
  image_finite (sys x) ->
  image_finite (sys y) ->
  (forall f, PropLogic.interp f x -> PropLogic.interp f y) ->
  world_acc x y.

Require Import logic.

  Section mucalc.
    Import MuCalc.

    Section characteristic.

    Variable X:LTS.

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

    Definition CF_body (x:state X) (ob:O) : formula emptyE E1 o :=
      f_and
        (conj' (fun x':{ x' | steps X x ob x' } => atomic _ _ (offers ob)))
        (modality _ _ o (box ob) (disj' (fun x':{ x' | steps X x ob x'} =>
          app (var emptyE E1 None) (proj1_sig x')))).

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

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

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

    End characteristic.

    Definition CF (w:world) : cformula o :=
      app (CF_main (sys w)) (root w).

    Theorem CF_is_characteristic : characteristic_formula CF.
  End mucalc.

Section ref_prune.
  Variables X Y:LTS.
  Variable R:state X -> state Y -> Prop.
  Hypothesis Hp:ready_sim X Y R.

  Inductive Q1st := mkQ1 : forall (x:state X) (y:state Y), Q1st.
  Inductive Q1step : Q1st -> O -> Q1st -> Prop :=
    Q1step1 : forall o x x' y y',
        steps X x o x' ->
        Q1step (mkQ1 x y) o (mkQ1 x' y').

  Inductive Q2st := mkQ2 : forall x y, R x y -> Q2st.
  Inductive Q2step : Q2st -> O -> Q2st -> Prop :=
    Q2step1 : forall o x x' y y' Hxy Hxy',
        steps X x o x' ->
        steps Y y o y' ->
        Q2step (mkQ2 x y Hxy) o (mkQ2 x' y' Hxy').

  Definition Q1 := Build_LTS Q1st Q1step.
  Definition Q2 := Build_LTS Q2st Q2step.

  Lemma Q1Q2_prune : global_pruning Q1 Q2 (fun q => match q with mkQ2 x y _ => mkQ1 x y end).

  Lemma XQ1_bisim : bisim X Q1 (fun x q => match q with mkQ1 x' _ => x = x' end).

  Lemma Q2Y_bisim : bisim Q2 Y (fun q y => match q with mkQ2 _ y' _ => y = y' end).
End ref_prune.

Lemma ready_sim_comp : forall X Y Z R1 R2,
  ready_sim X Y R1 ->
  ready_sim Y Z R2 ->
  ready_sim X Z (comp R1 R2).

Theorem ready_ref_prune : forall X Y x y,
  ready_ref X Y x y <-> global_pruned_ref X Y x y.

End ready_prune.
End READY_PRUNE.