Library choice_ref

Require Import base.
Require Import prelim.
Require Import lts_tau.
Require Import branch_bisim.
Require Import back_forth_bisim.

Require Import Wf_nat.
Require Import Omega.

Module CHOICE_REF.
Import LTS_TAU. Import BRANCH_BISIM. Import BF_BISIM.
Section choice_ref. Context {Obs:ObservationSystem}.

  Definition well_staged (X:LTS) :=
    forall (x:state 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:state X) (I:O -> Prop) :=
    forall o, I o <-> enables x (Some o).

  Definition possible_stable_offer {X:LTS} (x:state X) (I:O -> Prop) :=
    exists x', steps_star X x x' /\ stable x' /\ offer_set x' I.


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

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

  Definition choice_refinement (X Y:LTS) (R:state X -> state Y -> Prop) :=
    forall x y, R x y ->
      choice_forward X Y R y x /\
      branch_ind Y X (inv R) y x.

  Definition choice_refinement' (X Y:LTS) (R:state X -> state Y -> Prop) :=
    forall x y, R x y ->
      (stable y ->
        exists x',
          path_where _ (steps_tau X) (fun x => R x y) x x' /\
          R x' y /\ stable x' /\
          (forall o, enables x' (Some o) -> enables y (Some o))) /\
      branch Y X (inv R) y x /\
      cond_D1 Y X (inv R) y x.

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

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

  Definition choice_refines' (X Y:LTS) x y :=
    exists R, choice_refinement' X Y R /\ R x y.

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

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

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

  Lemma choice_refines'_refinement' : forall X Y,
    choice_refinement' X Y (choice_refines' X Y).

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

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

  Lemma choice_refinement_steps : forall X,
    choice_refinement' X X (steps_star X).

  Lemma choice_refines_steps : forall X x x',
    steps_star X x x' ->
    choice_refines' X X x x'.

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

  Definition run_choice X Y R x y :=
    (back X Y R x y /\ back Y X (inv R) y x) /\
    (run_choice_forward X Y R x y /\
      forth Y X (inv R) y x /\ back_forth_div Y X (inv R) y x).

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

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

  Lemma run_choice_bisim_back' : forall X Y R,
    run_simulation run_choice X Y R ->
    run_bisimulation back' X Y R.

  Lemma run_choice_sim_forth' : forall X Y R,
    run_simulation run_choice X Y R ->
    run_simulation forth' Y X (inv R).

  Lemma run_choice_div_sim : forall X Y R,
    run_simulation run_choice X Y R ->
    run_simulation back_forth_div' Y X (inv R).

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

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

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

  Section branch_to_bf.
    Variables X Y:LTS.
    Variable R : state X -> state Y -> Prop.
    Hypothesis HR : choice_refinement' X Y R.

    Theorem choice_to_bf_choice : run_simulation run_choice 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_simulation run_choice X Y R.

    Lemma bf_choice_to_choice : choice_refinement' 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_similar run_choice X Y x y <->
    exists R,
      choice_refinement' X Y R /\
      related_runs X Y R x y.

  Theorem bf_choice_related_runs2 : forall X Y,
    run_similar run_choice X Y =
    related_runs X Y (choice_refines' X Y).

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

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

  Require Import logic.

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

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

  Definition interp_choice_mode (m:choice_mode) (P:history -> Prop) (w:history) : Prop :=
      match m with
      | box o =>
          forall x', step_run (hsys w) (hrun w) o x' -> P (hst x')
      | circ =>
          forall x', extended_run_star (hsys w) (hrun w) x' ->
            stable (curr x') -> P (hst x')
      | box_back o =>
          forall x', step_run (hsys w) x' o (hrun w) -> P (hst x')
      | dia_back o =>
          exists x', step_run (hsys w) x' o (hrun w) /\ P (hst x')
      | conv =>
          forall D, hdivergence_set (hsys w) (fun x => True) D ->
            D (hrun w) ->
            exists x, D x /\ P (hst x)
      end.

  Definition interp_choice_atom (a:choice_atom) (w:history) : Prop :=
    match a with
      | offers o =>
          forall x', extended_run_star (hsys w) (hrun w) x' ->
            stable (curr x') -> enables (curr x') (Some o)
    end.

  Program Instance ChoiceLogicInput : LOGIC_INPUT :=
  { world := history
  ; accessable w1 w2 := run_similar run_choice (hsys w1) (hsys w2) (hrun w1) (hrun w2)
  ; mode := choice_mode
  ; atom := choice_atom
  ; interp_mode := interp_choice_mode
  ; interp_atom := interp_choice_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_simulation back' X Y R.

      Lemma adequate3 : run_simulation back' Y X (inv R).

      Lemma adequate4 : run_simulation forth' Y X (inv R).

      Lemma adequacy_div2 : run_simulation back_forth_div Y X (inv R).

      Lemma adequacy_choice : run_simulation 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_similar 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' | extended_run_star X h 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' | step_run 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' | step_run 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' | step_run X h' ob h} => (app (var E0 E1 None) (proj1_sig x')))))
             (modality E0 E1 o conv (
               (disj' (fun x:{ h' | extended_run 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 ->
      accessable (hst s) w.
  End characteristic.

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

  Theorem CF_is_characteristic : characteristic_formula CF.

  Theorem completeness : forall w w',
    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.


  Record global_pruning {X Y:LTS} :=
    { gp_abs : state Y -> state X
    ; gp_inj : forall y y', gp_abs y = gp_abs y' -> y = y'
    ; gp_subgraph : forall y o y', steps Y y o y' -> steps X (gp_abs y) o (gp_abs y')
    ; gp_prune : forall y o,
          enables (gp_abs y) o ->
          enables y o \/ enables y None
    }.
  Global Implicit Arguments global_pruning [].

  Definition bare_pruning_refines (X Y:LTS) (x:state X) (y:state Y) :=
    exists GP:global_pruning X Y, x = gp_abs GP y.

  Definition pruning_refines (X Y:LTS) (x:state X) (y:state Y) :=
    exists Q1, exists Q2, exists q1, exists q2,
      bisimilar branch_ind X Q1 x q1 /\
      bare_pruning_refines Q1 Q2 q1 q2 /\
      bisimilar branch_ind Q2 Y q2 y.

  Lemma bisimulation_choice_refinement X Y R :
    bisimulation branch_ind X Y R ->
    choice_refinement X Y R.

  Lemma prune_choice_refinement X Y (GP:global_pruning X Y) :
    choice_refinement X Y (fun x y => x = gp_abs GP y).
End choice_ref.

  Module prune_choice_ref_converges.
  Section prune_choice_ref_converges.
    Context {Classic:EM} {Obs:ObservationSystem}.
    Variables X Y:LTS.

    Let X' := droploop X.
    Hypothesis Xconverges : forall x, weak_converges X x.

    Inductive Q1 := mkQ1 : forall (x:state X) (y:state Y), Q1.
    Inductive Q1step : Q1 -> option O -> Q1 -> Prop :=
      | Q1action : forall o x x' y y',
            steps X x o x' ->
            Q1step (mkQ1 x y) o (mkQ1 x' y')
      | Q1tauY : forall x y y',
            steps_tau Y y y' ->
            choice_refines' X Y x y ->
            choice_refines' X Y x y' ->
            (forall x', steps_tau X x x' -> choice_refines' X Y x' y' -> False) ->
            Q1step (mkQ1 x y) None (mkQ1 x y').

    Definition Q1LTS : LTS := Build_LTS Q1 Q1step.

    Inductive Q2 := mkQ2 : forall x y, choice_refines' X Y x y -> Q2.
    Inductive Q2step : Q2 -> option O -> Q2 -> Prop :=
      | Q2action : 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')
      | Q2tauX : forall x x' y Hxy Hxy',
             x <> x' ->
             steps_tau X x x' ->
             Q2step (mkQ2 x y Hxy) None (mkQ2 x' y Hxy')
      | Q2tauY : forall x y y' Hxy Hxy',
             steps_tau Y y y' ->
             (forall x', steps_tau X x x' -> choice_refines' X Y x' y' -> False) ->
             Q2step (mkQ2 x y Hxy) None (mkQ2 x y' Hxy').

    Definition Q2LTS := Build_LTS Q2 Q2step.

    Definition q21 (q:Q2) : Q1 :=
      match q with mkQ2 x y _ => mkQ1 x y end.

    Lemma q21_inj : forall q q', q21 q = q21 q' -> q = q'.

    Lemma q21_subgraph : forall q o q',
      steps Q2LTS q o q' -> steps Q1LTS (q21 q) o (q21 q').

    Lemma q21_prune : forall q o,
         @enables Obs Q1LTS (q21 q) o ->
         @enables Obs Q2LTS q o \/ @enables Obs Q2LTS q None.

    Lemma q21_global_pruning : global_pruning Q1LTS Q2LTS.

    Definition q1fst (q:Q1) : state X :=
      match q with mkQ1 x _ => x end.

    Lemma q1fst_branch_bisim :
      bisimulation (td_and branch cond_D1) X Q1LTS (fun x y => x = q1fst y).

    Definition q2snd (q:Q2) : state Y :=
      match q with mkQ2 x y _ => y end.

    Lemma q2snd_branch_bisim :
      bisimulation (td_and branch cond_D1) Q2LTS Y (fun x y => q2snd x = y).
  End prune_choice_ref_converges.
  End prune_choice_ref_converges.

  Module prune_choice_ref_well_staged.
  Section prune_choice_ref_well_staged.
    Context {Classic:EM} {Obs:ObservationSystem}.
    Variables X Y:LTS.

    Inductive Q1 := mkQ1 : forall (x:state X) (y:state Y), Q1.
    Inductive Q1step : Q1 -> option O -> Q1 -> Prop :=
      | Q1action : forall o x x' y y',
            steps X x o x' ->
            Q1step (mkQ1 x y) o (mkQ1 x' y')
      | Q1tauY : forall x y y',
            steps_tau Y y y' ->
            choice_refines' X Y x y ->
            choice_refines' X Y x y' ->
            (forall x', steps_tau X x x' -> choice_refines' X Y x' y' -> False) ->
            Q1step (mkQ1 x y) None (mkQ1 x y').

    Definition Q1LTS : LTS := Build_LTS Q1 Q1step.

    Inductive path_to_shared_stable_offer (y:state Y) : nat -> state X -> Prop :=
      | ptsso_cons : forall n x x',
           choice_refines' X Y x y ->
           steps_tau X x x' ->
           path_to_shared_stable_offer y n x' ->
           path_to_shared_stable_offer y (S n) x
      | ptsso_nil : forall x I,
           choice_refines' X Y x y ->
           stable x -> offer_set x I ->
           stable y -> offer_set y I ->
           path_to_shared_stable_offer y 0 x.

    Definition shortest_path_to_shared_stable_offer y x x' :=
      exists n,
        steps_tau X x x' /\ path_to_shared_stable_offer y n x' /\
        forall m q,
          steps_tau X x q ->
          path_to_shared_stable_offer y m q ->
          n <= m.

    Inductive Q2 := mkQ2 : forall x y, choice_refines' X Y x y -> Q2.
    Inductive Q2step : Q2 -> option O -> Q2 -> Prop :=
      | Q2action : 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')
      | Q2tauX : forall x x' y Hxy Hxy',
             steps_tau X x x' ->
             shortest_path_to_shared_stable_offer y x x' ->
             Q2step (mkQ2 x y Hxy) None (mkQ2 x' y Hxy')
      | Q2tauY : forall x y y' Hxy Hxy',
             steps_tau Y y y' ->
             (forall x', steps_tau X x x' -> choice_refines' X Y x' y' -> False) ->
             Q2step (mkQ2 x y Hxy) None (mkQ2 x y' Hxy').

    Definition Q2LTS := Build_LTS Q2 Q2step.

    Definition q21 (q:Q2) : Q1 :=
      match q with mkQ2 x y _ => mkQ1 x y end.

    Lemma q21_inj : forall q q', q21 q = q21 q' -> q = q'.

    Lemma q21_subgraph : forall q o q',
      steps Q2LTS q o q' -> steps Q1LTS (q21 q) o (q21 q').

    Lemma minimize_path : forall y x,
      (exists n, path_to_shared_stable_offer y n x) ->
      stable x \/ exists x', shortest_path_to_shared_stable_offer y x x'.

    Lemma choice_ref_stable : forall R x y,
      choice_refinement' X Y R -> R x y -> stable y ->
      exists n, path_to_shared_stable_offer y n x.

    Lemma q21_prune : forall q o,
         @enables _ Q1LTS (q21 q) o ->
         @enables _ Q2LTS q o \/ @enables _ Q2LTS q None.

    Lemma q21_global_pruning : global_pruning Q1LTS Q2LTS.

    Definition q1fst (q:Q1) : state X :=
      match q with mkQ1 x _ => x end.

    Lemma q1fst_branch_bisim :
      bisimulation (td_and branch cond_D1) X Q1LTS (fun x y => x = q1fst y).

    Definition q2snd (q:Q2) : state Y :=
      match q with mkQ2 x y _ => y end.

    Hypothesis Y_well_staged : well_staged Y.

    Lemma q2snd_branch_bisim :
      bisimulation (td_and branch cond_D1) Q2LTS Y (fun x y => q2snd x = y).

  End prune_choice_ref_well_staged.
  End prune_choice_ref_well_staged.

  Theorem pruning_to_choice_ref :
    forall (Obs:ObservationSystem) (X Y:LTS) x y,
        pruning_refines X Y x y -> choice_refines X Y x y.

  Theorem choice_ref_to_pruning_converges {Classic:EM} :
    forall (Obs:ObservationSystem) (X Y:LTS) x y,
      (forall x, finite_divergences X x) ->
      choice_refines X Y x y ->
      pruning_refines X Y x y.

  Theorem choice_ref_to_pruning_well_staged {Classic:EM} :
    forall (Obs:ObservationSystem) (X Y:LTS) x y,
      well_stageable Y y ->
      choice_refines X Y x y ->
      pruning_refines X Y x y.

End CHOICE_REF.