Library strong_beh_choice

Require Import base.
Require Import prelim.

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

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

Definition lstate X := lift (state X).

Definition enables {X:ELTS} (x:state X) (o:O) :=
  exists x', steps X x o 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 must_enable {X:ELTS} (x:lstate X) (o:O) :=
  exists x', must_step X x o x'.

Record global_pruning (X Y:ELTS) (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 (lift_map abstr y')
  ; prune_enable : forall y o, enables (abstr y) o -> enables y o
  }.

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_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 ready_sim (X Y:ELTS) (R:lstate X -> lstate Y -> Prop) :=
  forall x y, R x y ->
    (forall o, must_enable x o -> must_enable y o) /\
    (forall o y', may_step Y y o y' -> exists x', may_step X x o x' /\ 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.

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

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

Lemma global_pruning_bisim (X Y:ELTS) abstr :
  global_pruning X Y abstr ->
  ready_sim X Y (fun x y => x = lift_map abstr 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).

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).

Lemma expansion_refinement : forall X Y f,
  (wrong_expansion X Y f) ->
  ready_sim X Y (wrong_rel X Y (fun x y => f x = 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 : ELTS
  ; root : lstate 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, may_step (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', must_step (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:ELTS) :=
  forall y o, exists l,
    forall y', steps Y y o y' <-> In y' l.

Require Import prop_logic.

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

Section adequacy.
  Import PropLogic.

  Context {Classic:EM}.

  Variable X:ELTS.
  Variable Y:ELTS.

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

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

  Let R (x:lstate X) (y:lstate 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: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' } => atomic _ _ (offers ob)))
        (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_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:ELTS.
  Variable R:lstate X -> lstate Y -> Prop.
  Hypothesis Hp:ready_sim X Y R.

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

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

  Inductive Q3st :=
  | mkQ3 : forall x y, R (into x) (into y) -> Q3st
  | mkQ3_Y : forall y:state Y, Q3st.

  Inductive Q3step : Q3st -> O -> lift Q3st -> Prop :=
  | Q3step1 : forall o x x' y y' Hxy Hxy',
        steps X x o (into x') ->
        steps Y y o (into y') ->
        Q3step (mkQ3 x y Hxy) o (into (mkQ3 x' y' Hxy'))
  | Q3step2 : forall o x y Hxy,
        steps X x o (mho _) ->
        steps Y y o (mho _) ->
        Q3step (mkQ3 x y Hxy) o (mho _)
  | Q3step3 : forall o x y y' Hxy,
        steps X x o (mho _) ->
        steps Y y o (into y') ->
        Q3step (mkQ3 x y Hxy) o (into (mkQ3_Y y'))
  | Q3step4 : forall y o y',
        steps Y y o y' ->
        Q3step (mkQ3_Y y) o (lift_map mkQ3_Y y').

  Definition Q1 := Build_ELTS Q1st Q1step.
  Definition Q2 := Build_ELTS Q2st Q2step.
  Definition Q3 := Build_ELTS Q3st Q3step.

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

  Lemma Q2Q3_expand : wrong_expansion Q2 Q3
    (fun q => match q with mkQ2 x y H => mkQ3 x y H end).

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

  Lemma Q3Y_bisim : wrong_bisimulation Q3 Y
    (wrong_rel' Q3 Y (fun q y => match q with mkQ3 _ y' _ => y = y' | mkQ3_Y 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).

Definition global_pruned X Y x y :=
  exists f, global_pruning X Y f /\
    wrong_rel' _ _ (fun x y => x = f y) x y.

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

Definition expand_prune_extension
  (R:forall X Y, lstate X -> lstate Y -> Prop) : Prop :=

  (forall X Y Z x y z, R X Y x y -> R Y Z y z -> R X Z x z) /\
  (forall X Y x y, wrong_bisimilar X Y x y -> R X Y x y) /\
  (forall X Y x y, global_pruned X Y x y -> R X Y x y) /\
  (forall X Y x y, wrong_expanded X Y x y -> R X Y x y).

Definition smallest_expand_prune_extension R :=
  expand_prune_extension R /\
  (forall R', expand_prune_extension R' ->
    forall X Y x y, R X Y x y -> R' X Y x y).

Theorem ready_ref_smallest :
  smallest_expand_prune_extension ready_ref.

End ready_prune.
End READY_PRUNE.