Library choice_beh_ref

Require Import base.
Require Import prelim.
Require Import lts_ref.
Require Import branch_ref.
Require Import back_forth_ref.
Require Import logic.

Require Import Wf_nat.
Require Import Omega.

Module CHOICE_BEH_REF.
Section choice_beh_ref. Context {Obs:ObservationSystem}.
Import BF_REF. Import BRANCH_REF.

  Definition enables {X:LTS} (x:lstate X) (o:option O) :=
    exists x', must_step X x o x'.

  Definition stable {X:LTS} (x:lstate X) :=
    ~enables x None.

  Definition well_staged (X:LTS) :=
    forall (x:lstate X) o, enables x (Some o) -> stable x.

  Definition well_stageable (X:LTS) x :=
    exists X', exists x',
      well_staged X' /\ bisimilar branch_ind X X' x x'.

  Definition offer_set {X:LTS} (x:lstate X) (I:O -> Prop) :=
    forall o, I o <-> enables x (Some o).


  Inductive choice_forward (X Y:LTS) (R:lstate X -> lstate Y -> Prop) (y:lstate Y) : lstate X -> Prop :=
    | choice_forward_intro : forall x,
        R x y ->
        (forall o, enables x o ->
          enables y o \/ enables y None \/
          exists x',
            must_step X x None x' /\ choice_forward X Y R y x') ->
        choice_forward X Y R y x.

  Definition choice_forward' X Y R x y := choice_forward X Y R y x.

  Lemma choice_forward_ind
     : forall (X Y : LTS) (R : lstate X -> lstate Y -> Prop)
         (y : lstate Y) (P : lstate X -> Prop),
       (forall x : lstate X,
        R x y ->
        (forall o, enables x o ->
          enables y o \/ enables y None \/
          exists x' : lstate X, must_step X x None x' /\ P x') ->
        P x) -> forall s : lstate X, choice_forward X Y R y s -> P s.

  Definition choice (X Y:LTS) (R:lstate X -> lstate Y -> Prop) x y :=
    choice_forward' X Y R x y /\
    branch_backward_ind X Y R x y.

  Definition choice_no_stutter : transition_diagram :=
    td_and choice_forward' branch_backward_ind_no_stutter.

  Definition choice' (X Y:LTS) (R:lstate X -> lstate Y -> Prop) x y :=
      (stable y ->
        exists x',
          path_where _ (fun x x' => may_step X x None x') (fun x => R x y) x x' /\
          R x' y /\ stable x' /\
          (forall o, enables x' (Some o) -> enables y (Some o))) /\
      branch_backward X Y R x y /\
      cond_D1' X Y R x y.

  Lemma choice_refinement_eq1 {Classic:EM} X Y R :
    refinement choice' X Y R -> refinement choice X Y R.

  Lemma choice_refinement_eq2 X Y
    (R:lstate X -> lstate Y -> Prop)
    (Henables_dec : forall x y, R x y ->
      enables x None \/ ~enables x None) :

    refinement choice X Y R -> refinement choice' X Y R.

  Lemma choice_refinement_eq {Classic:EM} X Y R :
    refinement choice' X Y R <-> refinement choice X Y R.

  Lemma choice_refines_eq {Classic:EM} X Y x y :
    refines choice' X Y x y <-> refines choice X Y x y.

  Lemma branch_forward_ind_choice : forall X Y R,
    refinement branch_forward_ind X Y R ->
    refinement choice_forward' X Y R.

  Lemma refinement_branch_ind_choice : forall X Y R,
    refinement branch_ind X Y R ->
    refinement choice X Y R.

  Lemma refines_branch_ind_choice : forall X Y x y,
    refines branch_ind X Y x y ->
    refines choice X Y x y.

  Lemma choice_refinement_comp : forall X Y Z R1 R2,
    refinement choice X Y R1 ->
    refinement choice Y Z R2 ->
    refinement choice X Z (comp R1 R2).

  Lemma refines_choice_refl : forall A x,
    refines choice A A x x.

  Lemma choice_refines_trans : forall X Y Z x y z,
    refines choice X Y x y ->
    refines choice Y Z y z ->
    refines choice X Z x z.

  Lemma choice_refines'_refinement' : forall X Y,
    refinement choice' X Y (refines choice' X Y).

  Lemma choice_refinement'_comp : forall X Y Z R1 R2,
    refinement choice' X Y R1 ->
    refinement choice' Y Z R2 ->
    refinement choice' X Z (comp R1 R2).

  Lemma choice_refines'_trans : forall X Y Z x y z,
      refines choice' X Y x y ->
      refines choice' Y Z y z ->
      refines choice' X Z x z.

  Lemma choice_refinement_steps : forall X,
    refinement choice' X X (must_step_star X).

  Lemma choice_refines_steps : forall X x x',
    must_step_star X x x' ->
    refines choice' X X x x'.

  Lemma stuttering_choice_forward : forall X Y R
    (Hback:refinement branch_backward_no_stutter X Y R),
    refinement choice_forward' X Y R ->
    refinement choice_forward' X Y (stuttering_closure X Y R).

  Lemma stuttering_choice_refinement : forall X Y R,
    refinement choice_forward' X Y R ->
    refinement branch_backward_ind_no_stutter X Y R ->
    refinement choice X Y (stuttering_closure X Y R).

  Lemma stuttering_choice_refines_eq : forall X Y x y,
    refines (td_and choice_forward' branch_backward_ind_no_stutter) X Y x y <->
    refines choice X Y x y.

  Lemma refines_choice_refinement A B :
    refinement choice A B (refines choice A B).

  Lemma refines_choice_no_stutter_refinement A B :
    refinement (td_and choice_forward' branch_backward_ind_no_stutter) A B
      (refines (td_and choice_forward' branch_backward_ind_no_stutter) A B).

  Lemma choice_refines_mho_step_star : forall A B x,
    refines choice A B x (mho _) ->
    must_step_star A x (mho _).

  Definition run_choice_forward (X Y:LTS) (R:run X -> run Y -> Prop) (x:run X) (y:run Y) :=
    stable (curr y) ->
    exists x',
      may_extend_star X x x' /\ R x' y /\ stable (curr x') /\
      (forall o, enables (curr x') (Some o) -> enables (curr y) (Some o)).

  Definition forth_rev X Y (R:run X -> run Y -> Prop) x y :=
      (forall a y', weak_may_extend Y y a y' -> exists x', weak_may_extend X x a x' /\ R x' y').

  Definition forth_rev' X Y (R:run X -> run Y -> Prop) x y :=
      (forall a y', may_extend Y y a y' -> exists x', weak_may_extend X x a x' /\ R x' y').

  Lemma extended_run_push1'_ugh : forall X Y R x y y',
    run_refinement forth_rev' X Y R ->
    R x y ->
    may_extend_star Y y y' ->
    exists x',
      R x' y' /\
      may_extend_star X x x'.

  Lemma forth_rev'_forth_rev : forall X Y R,
    run_refinement forth_rev' X Y R ->
    run_refinement forth_rev X Y R.

  Definition run_choice X Y R x y :=
    (back X Y R x y /\ forth_rev X Y R x y /\
    run_choice_forward X Y R x y /\ div_back X Y R x y).

  Lemma run_choice_eq : forall X,
    run_refinement run_choice X X eq.

  Lemma run_similar_choice_refl : forall X x,
    run_refines run_choice X X x x.

  Lemma may_weak_may : forall X x a x',
    may_extend X x a x' ->
    weak_may_extend X x a x'.

  Lemma must_weak_must : forall X x a x',
    must_extend X x a x' ->
    weak_must_extend X x a x'.

  Lemma run_choice_back : forall X Y R,
    run_refinement run_choice X Y R ->
    run_refinement back X Y R.

  Lemma run_choice_forth : forall X Y R,
    run_refinement run_choice X Y R ->
    run_refinement forth_rev X Y R.

  Lemma run_choice_div : forall X Y R,
    run_refinement run_choice X Y R ->
    run_refinement div_back X Y R.

  Lemma Xclosure_forth_sim : forall X Y R,
    run_refinement forth_rev X Y R ->
    run_refinement forth_rev X Y (Xclosure X Y R).

  Lemma choice_Xclosure : forall X Y R,
    run_refinement run_choice X Y R ->
    run_refinement run_choice X Y (Xclosure X Y R).

  Lemma run_choice_comp : forall X Y Z R1 R2,
    run_refinement run_choice X Y R1 ->
    run_refinement run_choice Y Z R2 ->
    run_refinement run_choice X Z (comp R1 R2).

  Lemma run_choice_trans : forall X Y Z x y z,
    run_refines run_choice X Y x y ->
    run_refines run_choice Y Z y z ->
    run_refines run_choice X Z x z.

  Lemma run_refinement_to_choice_forward {Classic:EM} : forall X Y R,
    run_refinement (rtd_and back_forth back_forth_div) X Y R ->
    run_refinement run_choice_forward X Y R.

  Lemma run_refinement_to_choice {Classic:EM} : forall X Y R,
    run_refinement (rtd_and back_forth back_forth_div) X Y R ->
    run_refinement run_choice X Y R.

  Lemma run_ref_to_choice {Classic:EM} : forall X Y x y,
    run_refines (rtd_and back_forth back_forth_div) X Y x y ->
    run_refines run_choice X Y x y.

  Section branch_to_bf.
    Variables X Y:LTS.
    Variable R : lstate X -> lstate Y -> Prop.
    Hypothesis HR : refinement choice' X Y R.

    Lemma branch_to_forth :
      run_refinement forth_rev X Y (related_runs X Y R).

    Theorem choice_to_bf_choice : run_refinement run_choice_forward X Y (related_runs X Y R).
  End branch_to_bf.

  Section bf_to_branch.
    Variables X Y:LTS.
    Variable R : run X -> run Y -> Prop.

    Hypothesis HR : run_refinement run_choice X Y R.

    Lemma bf_choice_to_choice : refinement choice' X Y (curr_rel X Y (Xclosure X Y R)).
  End bf_to_branch.

  Theorem bf_choice_related_runs : forall X Y x y,
    run_refines run_choice X Y x y <->
    exists R,
      refinement choice' X Y R /\
      related_runs X Y R x y.

  Theorem bf_choice_related_runs2 : forall X Y,
    run_refines run_choice X Y =
    related_runs X Y (refines choice' X Y).

  Inductive cb_mode :=
      | box : option O -> cb_mode
      | circ : cb_mode
      | box_back : option O -> cb_mode
      | dia_back : option O -> cb_mode
      | conv : cb_mode.

  Definition cb_interp_mode (m:cb_mode) (P:history -> Prop) (w:history) : Prop :=
      match m with
      | box o =>
          forall x', weak_may_extend (hsys w) (hrun w) o x' -> P (hst x')
      | circ =>
          forall x', weak_may_extend (hsys w) (hrun w) None x' ->
            stable (curr x') -> P (hst x')
      | box_back o =>
          forall x', weak_may_extend (hsys w) x' o (hrun w) -> P (hst x')
      | dia_back o =>
          exists x', weak_may_extend (hsys w) x' o (hrun w) /\ P (hst x')
      | conv =>
          forall D, may_hdivergence_set (hsys w) D ->
            D (hrun w) ->
            exists x, D x /\ P (hst x)
      end.

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

  Definition cb_interp_atom (a:cb_atom) (w:history) :=
    match a with
      | offers o =>
          forall x', weak_may_extend (hsys w) (hrun w) None x' ->
            stable (curr x') -> enables (curr x') (Some o)
    end.

  Program Instance cb_logic_input : LOGIC_INPUT :=
    { world := history
    ; accessable w1 w2 :=
         run_refines run_choice (hsys w1) (hsys w2) (hrun w1) (hrun w2)
    ; mode := cb_mode
    ; atom := cb_atom
    ; interp_mode := cb_interp_mode
    ; interp_atom := cb_interp_atom
    }.

  Section adequacy.
    Require prop_logic.
    Import prop_logic.PropLogic.

    Context {Classic:EM}.

    Section inner.
      Variables X Y : LTS.
      Let R (x:run X) (y:run Y) := forall f, interp f (hst x) -> interp f (hst y).

      Hypothesis Hfin1 : weak_image_finite X.
      Hypothesis Hfin2 : weak_image_finite Y.

      Lemma adequate1 : run_refinement back X Y R.

      Lemma adequate2 : run_refinement forth_rev X Y R.

      Lemma adequacy_div1 : run_refinement div_back X Y R.

      Lemma adequacy_choice : run_refinement run_choice_forward X Y R.
    End inner.

    Theorem adequacy : forall x y,
      weak_image_finite (hsys x) ->
      weak_image_finite (hsys y) ->
      (forall f, interp f x -> interp f y) ->
      run_refines run_choice (hsys x) (hsys y) (hrun x) (hrun y).
  End adequacy.

  Import MuCalc.

  Section characteristic.
    Variable X:LTS.
    Let E0 := emptyE.
    Let E1 := extend emptyE (arr (run X) o).

    Definition CF_body (h:run X) (ob:option O) : formula E0 E1 o :=
       f_and (modality E0 E1 o circ (disj' (fun x':{ h' | weak_may_extend X h None h' /\ stable (curr h') } =>
                f_and (app (var E0 E1 None) (proj1_sig x'))
                      (conj' (fun i:{i:O | enables (curr (proj1_sig x')) (Some i) } =>
                        atomic E0 E1 (offers (proj1_sig i))))
             )))
      (f_and (conj' (fun x':{ h' | weak_may_extend X h' ob h} => modality E0 E1 o (dia_back ob) (app (var E0 E1 None) (proj1_sig x'))))
      (f_and (modality E0 E1 o (box ob) (disj' (fun x':{ h' | weak_may_extend X h ob h'} => (app (var E0 E1 None) (proj1_sig x')))))
      (f_and (modality E0 E1 o (box_back ob) (disj' (fun x':{ h' | weak_may_extend X h' ob h} => (app (var E0 E1 None) (proj1_sig x')))))
             (modality E0 E1 o conv (
               (disj' (fun x:{ h' | may_extend X h None h' } =>
                 (app (var E0 E1 None) (proj1_sig x))))))
      ))).

    Definition CF_main : formula E0 E0 (arr (run X) o) :=
      nu E0 E0 (arr (run X) o)
        (lam E0 E1 (run X) o (fun h:run X =>
          (conj' (fun ob:option O => CF_body h ob))
        )).

    Lemma characteristic_self : forall s,
      interp_cformula _ CF_main (s,tt) (hst s).

    Lemma characteristic_other : forall s w,
      interp_cformula _ CF_main (s,tt) w ->
      prelim.accessable (hst s) w.
  End characteristic.

  Definition CF (w:prelim.world) : cformula o :=
    app (CF_main (hsys w)) (hrun w).

  Theorem CF_is_characteristic : characteristic_formula CF.

  Theorem completeness : forall w w',
    prelim.accessable w w' <->
    (forall t (f:formula emptyE emptyE t) z,
      interp_cformula t f z w -> interp_cformula t f z w').

  Theorem models_denotable :
    forall t (X:model t), exists f:cformula t,
      interp_cformula t f = X.

End choice_beh_ref.
End CHOICE_BEH_REF.