Library strong_ref_complete

Require Import base.
Require Import prelim.

Module Type OBSERVATION_SYSTEM.
  Parameter O:Type.

  Parameter O_inh : O.

  Parameter order_O : O -> O -> Prop.

  Axiom order_O_trans : forall m1 m2 m3,
    order_O m1 m2 -> order_O m2 m3 -> order_O m1 m3.
  Axiom order_O_total : forall m1 m2,
    order_O m1 m2 \/ m1 = m2 \/ order_O m2 m1.
  Axiom order_O_wf : well_founded order_O.
End OBSERVATION_SYSTEM.

Module ELTS_Theory (OS:OBSERVATION_SYSTEM).
Import OS.

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

Definition wrong_bisim (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' /\
        ((x' = mho _ /\ y' = mho _) \/
         (exists z1, exists 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' /\
        ((x' = mho _ /\ y' = mho _) \/
         (exists z1, exists z2, contains x' z1 /\ contains y' z2 /\ R z1 z2))).

Definition wrong_bisimilar X Y x y :=
  exists R, wrong_bisim X Y R /\ R x y.

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.

Lemma refinement_refl : forall X,
  refinement X X eq.

Lemma refinement_compose : forall X Y Z R1 R2,
  refinement X Y R1 ->
  refinement Y Z R2 ->
  refinement X Z (fun x z => exists y, R1 x y /\ R2 y z).

Lemma wrong_bisim_refinement : forall X Y R,
  wrong_bisim X Y R -> refinement X Y R.

Lemma refines_refl : forall X x,
  refines X X x x.

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

Record mho_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 expands X Y x y :=
  exists f, mho_expansion X Y f /\ f x = y.

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

Lemma expansion_refinement : forall X Y f,
  (mho_expansion X Y f) ->
  refinement X Y (fun x y => f x = y).

Module ExpandRef.
Section expandref.
  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_bisim 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_bisim 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 : mho_expansion Q1 Q2 Q1toQ2.
End expandref.

Theorem refines_expands' X Y x y :
  refines X Y x y <-> expands' X Y x y.
End ExpandRef.

Record world :=
  { sys : ELTS
  ; root : lift (state sys)
  }.

Implicit Arguments world [].

Program Definition upd_root (w:world) (st:lift (state (sys w))) :=
  {| sys := sys w; root := st |}.

Definition accessable (x y:world) :=
  forall st, contains (root x) st ->
    exists st', contains (root y) st' /\
      refines (sys x) (sys y) st st'.

Lemma accessable_refl : forall (x:world), accessable x x.

Definition accessable_trans : forall x y z,
  accessable x y -> accessable y z -> accessable x z.

Hint Resolve accessable_refl accessable_trans.


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

Definition interp_mode (m:mode) (P:world -> Prop) (w:world) : Prop :=
    match m with
    | box o =>
              forall w', accessable w w' ->
              forall st, contains (root w') st ->
              forall st', steps (sys w') st o st' ->
                P (upd_root w' st')

    | dia o =>
              exists st, contains (root w) st /\
              exists st', steps (sys w) st o st' /\
                P (upd_root w st')
    end.

Definition order_mode (m1 m2:mode) : Prop :=
    match m1, m2 with
    | box o1, box o2 => order_O o1 o2
    | box _, dia _ => True
    | dia o1, dia o2 => order_O o1 o2
    | dia _, box _ => False
    end.

Program Instance strong_ref_logic_input : LOGIC_INPUT :=
{ world := world
; accessable := accessable
; mode := mode
; atom := Empty_set
; interp_mode := interp_mode
; interp_atom a := match a with end
}.

Program Instance strong_ref_ordered_logic_input : ORDERED_LOGIC_INPUT strong_ref_logic_input :=
{ order_mode := order_mode }.

Require Import prop_logic.
Import PropLogic.

Program Definition empty_model : model :=
  fun _ => False.

  Definition void_elts : ELTS:=
  {| state := Empty_set
   ; steps := fun _ _ _ => False
   |}.

  Definition chaos : world :=
  {| sys := void_elts; root := mho Empty_set |}.

  Definition unit_is : ELTS:=
  {| state := unit
   ; steps := fun _ _ x => contains x tt
   |}.

  Definition unit_w : world :=
  {| sys := unit_is; root := into tt |}.

  Definition step_crash_is : ELTS :=
  {| state := unit
   ; steps := fun _ _ x => forall z, contains x z -> False
   |}.

  Definition step_crash_w : world :=
  {| sys := step_crash_is ; root := into tt |}.

  Definition definite o := disj (modality (dia o) TT)
                              (modality (box o) FF).

  Lemma definite_defined : forall o w,
    interp (definite o) w ->
    exists st, contains (root w) st.

  Lemma defined_definite {Classic:EM} : forall o w st,
    contains (root w) st ->
    interp (definite o) w.

  Lemma definitiveness_axiom1 {Classic:EM} : forall o1 o2,
    valid (impl (definite o1) (definite o2)).

  Lemma definitiveness_axiom2 {Classic:EM} : forall o x,
    valid (impl (modality (box o) x) (disj x (definite o))).

  Definition more_specs (X Y:ELTS) (x:state X) (y:state Y) :=
    forall f, impl_free f -> interp f (Build_world X (into x)) -> interp f (Build_world Y (into y)).

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

  Lemma more_specs_refinement {Classic:EM} X Y :
    forall (HX:image_finite X) (HY:image_finite Y),
    refinement X Y (more_specs X Y).
 Opaque definite.
Transparent definite.

  Theorem adequate {Classic:EM} : forall X Y x y,
    image_finite X ->
    image_finite Y ->
    (refines X Y x y <->
     (forall f, impl_free f ->
      interp f (Build_world X (into x)) ->
      interp f (Build_world Y (into y)))).

  Section interpolate_worlds.
    Variables ob:O.
    Variables X Y:ELTS.
    Variable main_x:state X.
    Variable main_x':lift (state X).
    Variable main_y':lift (state Y).

    Hypothesis Hstp : steps X main_x ob main_x'.
    Hypothesis Hacc : accessable (Build_world X main_x') (Build_world Y main_y').

    Inductive interp_st : Type :=
      | start : interp_st
      | stateX : state X -> interp_st
      | stateY : state Y -> interp_st.

    Program Definition injectX (lx:lift (state X)) : lift interp_st :=
      lift_map stateX lx.

    Program Definition injectY (ly:lift (state Y)) : lift interp_st :=
      lift_map stateY ly.

    Inductive interp_step : interp_st -> O -> lift interp_st -> Prop :=

      | stp_startX : forall ob' x',
            steps X main_x ob' x' ->
            interp_step start ob' (injectX x')

      | stp_startY :
            interp_step start ob (injectY main_y')

      | stp_withinX : forall x ob' x',
            steps X x ob' x' ->
            interp_step (stateX x) ob' (injectX x')

      | stp_withinY : forall y ob' y',
            steps Y y ob' y' ->
            interp_step (stateY y) ob' (injectY y').

    Definition interpELTS := {| state := interp_st ; steps := interp_step |}.

    Definition X_interp_refinement (x:state X) (z:interp_st) :=
      (x = main_x /\ z = start) \/
      z = stateX x \/
      exists y, z = stateY y /\
        refines X Y x y.

    Lemma X_interp_refines : refinement X interpELTS X_interp_refinement.

    Definition Y_interp_refinement (y:state Y) (z:interp_st) :=
      z = stateY y.

    Definition Y_interp_refinement_inv (z:interp_st) (y:state Y) :=
      z = stateY y.

    Lemma Y_interp_refines : refinement Y interpELTS Y_interp_refinement.

    Lemma Y_interp_refines_inv : refinement interpELTS Y Y_interp_refinement_inv.

   Theorem interpolate_worlds :
     exists Z, exists z, exists z',
       refines X Z main_x z /\
       steps Z z ob z' /\
       accessable (Build_world Y main_y') (Build_world Z z') /\
       accessable (Build_world Z z') (Build_world Y main_y').
  End interpolate_worlds.

  Lemma axiom_K5 : forall o x y,
    valid (impl (impl (modality (dia o) x)
                     (modality (box o) y))
               (modality (box o) (impl x y))).

  Lemma axiom_K6 {Classic:EM} : forall o x y,
    valid (impl (modality (box o) (disj x y))
      (disj (modality (box o) x)
      (disj (modality (box o) y)
            (conj (modality (dia o) x)
                  (modality (dia o) y))))).

  Inductive AX : formula -> Prop :=
  | AX_K1 : forall o x y,
      AX
       (impl (modality (box o) (impl x y))
             (impl (modality (box o) x)
                   (modality (box o) y)))

  | AX_K2 : forall o x y,
      AX
       (impl (modality (box o) (impl x y))
             (impl (modality (dia o) x)
                   (modality (dia o) y)))

  | AX_K3 : forall o, AX (impl (modality (dia o) FF) FF)
  | AX_K3' : forall o, AX (modality (box o) TT)

  | AX_K4 : forall o x y,
      AX (impl (modality (dia o) (disj x y))
               (disj (modality (dia o) x) (modality (dia o) y)))

  | AX_K5 : forall o x y,
      AX (impl (impl (modality (dia o) x)
                     (modality (box o) y))
               (modality (box o) (impl x y)))

  | AX_K6 : forall o x y,
      AX (impl (modality (box o) (disj x y))
      (disj (modality (box o) x)
      (disj (modality (box o) y)
            (conj (modality (dia o) x)
                  (modality (dia o) y)))))

  | AX_definite1 : forall o1 o2,
      AX (impl (definite o1) (definite o2))

  | AX_definite2 : forall o x,
      AX (impl (modality (box o) x) (disj x (definite o))).

Inductive AX' : formula -> Prop :=
  | AX'_AX : forall f, AX f -> AX' f
  | AX'_em : forall x, AX' (disj x (impl x FF)).

Inductive AXC : formula -> Prop :=
  | AXC_K1 : forall o x y,
      AXC
       (impl (modality (box o) (impl x y))
             (impl (modality (box o) x)
                   (modality (box o) y)))

  | AXC_boxTT : forall o, AXC (modality (box o) TT)

  | AXC_em : forall x, AXC (disj x (impl x FF))

  | AXC_dia1 : forall o x,
     AXC (impl (modality (box o) x) (impl (modality (dia o) (impl x FF)) FF))

  | AXC_dia2 : forall o x,
     AXC (impl (impl (modality (dia o) (impl x FF)) FF) (modality (box o) x)).

Lemma derives_nec : forall o p,
  (forall G, derives AX G p) ->
  (forall G, derives AX G (modality (box o) p)).

Ltac axiom H := eapply derives_axiom; apply H.


Lemma AX'_derives_AXC : forall f G,
  AXC f -> derives AX' G f.

Lemma AXC_nnpp : forall G f,
  derives AXC G (impl (impl f FF) FF) ->
  derives AXC G f.

Lemma AXC_contrapose : forall G p q,
  derives AXC G (impl (impl q FF) (impl p FF)) ->
  derives AXC G (impl p q).

Lemma AXC_box_dia : forall G o f,
  derives AXC G (impl (modality (dia o) f) FF) <->
  derives AXC G (modality (box o) (impl f FF)).

Lemma AXC_definite : forall G o,
  derives AXC G (definite o).

Lemma AXC_derives_AX : forall f G,
  AX f -> derives AXC G f.

Lemma AXC_AX_derives : forall f G,
  derives AX G f -> derives AXC G f.

Lemma AXC_AX_theorem : forall f,
  theorem AX f -> theorem AXC f.

Lemma AX'_AXC_derives : forall f G,
  derives AXC G f <-> derives AX' G f.

Lemma AX'_AXC_theorem : forall f,
  theorem AXC f <-> theorem AX' f.

Lemma derives_box_dia : forall G o p q,
  derives AX G (modality (box o) (impl p q)) ->
  derives AX G (modality (dia o) p) ->
  derives AX G (modality (dia o) q).

Lemma derives_box_dia' : forall G o p q,
  derives AX G (modality (box o) q) ->
  derives AX G (modality (dia o) p) ->
  derives AX G (modality (dia o) q).


Fixpoint bar (f:formula) {struct f} :=
  match f with
  | TT => True
  | FF => False
  | atomic _ => False
  | conj f1 f2 => bar f1 /\ bar f2
  | disj f1 f2 => (bar f1 /\ derives AX E0 f1) \/ (bar f2 /\ derives AX E0 f2)
  | impl f1 f2 => bar f1 -> derives AX E0 f1 -> bar f2
  | modality (box o) f => derives AX E0 f /\ bar f
  | modality (dia o) f => False
  end.

Lemma bar_IPL : forall f,
  IPL f -> bar f.

Lemma bar_AX : forall f,
  AX f -> bar f.

Lemma theorem_bar : forall G f, derives AX G f -> (forall g, G g -> False) -> bar f.


Lemma AX_valid {Classic:EM} : forall f, AX f -> valid f.

Lemma dia_definite : forall (G:formula -> Prop) o f,
  derives AX G (modality (dia o) f) ->
  derives AX G (definite o).

Lemma box_FF_definite : forall (G:formula -> Prop) o,
  derives AX G (modality (box o) FF) ->
  derives AX G (definite o).

Lemma derives_dia_FF : forall G o,
  derives AX G (modality (dia o) FF) ->
  derives AX G FF.

Lemma deduction_impl_free : forall (G:formula -> Prop) p q,
  impl_free p ->
  (forall g, G g -> impl_free g) ->
  (
  derives AX G (impl p q) <->
  (forall G':formula -> Prop,
    (forall g, G' g -> impl_free g) ->
    (forall g, G g -> G' g) ->
    derives AX G' p -> derives AX G' q)).

Let prime_set := prime_set AX.

Definition definite_set (G:formula -> Prop) :=
  forall o, G (modality (dia o) TT) \/
            G (modality (box o) FF).

Definition definite_prime_set := { G:prime_set | definite_set (pset AX G) }.

Definition set_steps (X:formula -> Prop) (o:O) (X':formula -> Prop) :=
  (forall p, impl_free p -> X (modality (box o) p) -> theorem AX p \/ X' p) /\
  (forall p, impl_free p -> theorem AX p \/ X' p -> X (modality (dia o) p)).

Definition unlift (LG:lift definite_prime_set) (f:formula) : Prop :=
  exists G, contains LG G /\ proj1_sig G f.

Definition primeELTS : ELTS :=
  {| state := definite_prime_set
   ; steps G o G' :=
       set_steps (proj1_sig G)
                 o
                 (unlift G')
   |}.

Theorem prime_definite_definite_set : forall (G:prime_set) o,
  G (definite o) -> definite_set G.

Theorem prime_definite_set {Classic:EM} : forall f (G:prime_set),
  ~theorem AX f -> G f -> definite_set G.

Theorem prime_theorems_or_definite {Classic:EM} : forall (G:prime_set),
  (forall f, G f -> theorem AX f) \/ definite_set G.

Definition subset (G G':formula -> Prop) :=
  forall x, impl_free x -> G x -> derives AX G' x.

Definition def_subset (G G':definite_prime_set) :=
  subset (proj1_sig G) (proj1_sig G').

Lemma frame_condition1 {Classic:EM} : forall (x y:prime_set) (x':formula -> Prop) o
  (Hx':forall f, x' f -> impl_free f),
  subset x y ->
  set_steps x o (derives AX x') ->
  exists y',
    subset (derives AX x') (unlift y') /\
    set_steps y o (unlift y').

Lemma frame_condition2 {Classic:EM} : forall (x y:prime_set) (y':prime_set) o,
  definite_set x ->
  subset x y ->
  set_steps y o y' ->
  exists x',
    subset (unlift x') y' /\
    set_steps x o (unlift x').

Lemma box_successor {Classic:EM} : forall
  (G:definite_prime_set) f o
  (Hf:impl_free f)
  (Hdia:proj1_sig G (modality (dia o) TT))
  (HGf:~ (proj1_sig G) (modality (box o) f)),
  let G'X p := proj1_sig G (modality (box o) p) in
  let G'Y p := p = f \/ (impl_free p /\ ~derives AX (proj1_sig G) (modality (dia o) p)) in
    ~derives_set AX G'X G'Y.

Lemma dia_successor {Classic:EM} : forall
  (G:definite_prime_set) f o
  (Hf:impl_free f)
  (Hdia: (proj1_sig G) (modality (dia o) f)),

  let G'X p := p = f \/ proj1_sig G (modality (box o) p) in
  let G'Y p := impl_free p /\ ~derives AX (proj1_sig G) (modality (dia o) p) in
    ~derives_set AX G'X G'Y.

Lemma cannonical_model_impl_free {Classic:EM} : forall (f:formula) (LG:lift definite_prime_set)
  (Hf:impl_free f),
  (unlift LG f -> interp f (Build_world primeELTS LG)) /\
  (interp f (Build_world primeELTS LG) -> theorem AX f \/ unlift LG f).

Theorem soundness {Classic:EM} : forall f, theorem AX f -> valid f.

Theorem impl_free_completeness {Classic:EM} :
  forall f, impl_free f -> valid f -> theorem AX f.

Check @impl_free_completeness.
Print Assumptions impl_free_completeness.

Theorem disjunctive_property_of_impl_free_theorems {Classic:EM} :
  forall p q,
    impl_free p ->
    impl_free q ->
    theorem AX (disj p q) ->
    theorem AX p \/ theorem AX q.

Fixpoint rank1 (f:formula) : Prop :=
  match f with
  | TT => True
  | FF => True
  | atomic _ => True
  | conj f1 f2 => rank1 f1 /\ rank1 f2
  | disj f1 f2 => rank1 f1 /\ rank1 f2
  | impl f1 f2 => impl_free f1 /\ rank1 f2
  | modality _ f => impl_free f
  end.

Lemma impl_free_rank1 : forall f,
  impl_free f -> rank1 f.
Hint Resolve impl_free_rank1.

Program Definition unlift_prime {Classic:EM} (LG:lift definite_prime_set) : prime_set :=
  {| pset := fun f => impl_free f /\ derives AX (unlift LG) f |}.

Lemma subset_refinement {Classic:EM} : refinement primeELTS primeELTS def_subset.

Lemma refinement_subset {Classic:EM} : forall R x y,
  refinement primeELTS primeELTS R -> R x y -> def_subset x y.

Lemma refinement_is_subset {Classic:EM} : forall x y,
  refines primeELTS primeELTS x y <-> def_subset x y.

Lemma cannonical_model_rank1 {Classic:EM} : forall (f:formula) (LG:lift definite_prime_set)
  (Hf:rank1 f),
  (interp f (Build_world primeELTS LG) -> derives AX (unlift LG) f).

Theorem rank1_completeness {Classic:EM} :
  forall f, rank1 f -> valid f -> theorem AX f.

Check @rank1_completeness.
Print Assumptions rank1_completeness.


End ELTS_Theory.