Library prop_logic

Require Import base.
Require Import prelim.

Require Import bourbaki.

Require Import Wellfounded.
Require Import Wf_nat.
Require Import Omega.

Module PropLogic.
Hint Resolve @accessable_refl @accessable_trans.

Section proplogic. Context {LI:LOGIC_INPUT} {OLI:ORDERED_LOGIC_INPUT LI}.
  Definition kripke_monotone (X:world -> Prop) :=
    forall w w', accessable w w' -> X w -> X w'.

  Inductive formula : Type :=
  | atomic : atom -> formula
  | modality : mode -> formula -> formula
  | impl : formula -> formula -> formula
  | conj : formula -> formula -> formula
  | disj : formula -> formula -> formula
  | TT : formula
  | FF : formula.

  Inductive fsyn : Type :=
  | A : atom -> fsyn
  | M : mode -> fsyn
  | IMPL : fsyn
  | CONJ : fsyn
  | DISJ : fsyn
  | FF_ : fsyn
  | TT_ : fsyn
  .

  Fixpoint fsyn_number (f:fsyn) : nat :=
   match f with
   | A _ => 0
   | M _ => 1
   | FF_ => 3
   | TT_ => 4
   | IMPL => 5
   | CONJ => 6
   | DISJ => 7
   end.

  Inductive fsyn_symbol_lt : fsyn -> fsyn -> Prop :=
    | fsyn_symbol_lt_A : forall a b, order_atom a b -> fsyn_symbol_lt (A a) (A b)
    | fsyn_symbol_lt_M : forall n m, order_mode n m -> fsyn_symbol_lt (M n) (M m).

  Definition fsyn_order (x y:fsyn) :=
    fsyn_number x < fsyn_number y \/
    (fsyn_number x = fsyn_number y /\ fsyn_symbol_lt x y).

  Lemma fsyn_order_trans : forall x y z,
    fsyn_order x y -> fsyn_order y z -> fsyn_order x z.

  Lemma fsyn_order_total : forall x y,
    fsyn_order x y \/ x = y \/ fsyn_order y x.

  Lemma fsyn_order_wf : well_founded fsyn_order.

  Section order_list.
    Variable A:Type.
    Variable R:A->A->Prop.

    Fixpoint order_list_struct (l1 l2:list A) :=
    match l1, l2 with
    | nil, nil => False
    | x::xs, y::ys => (R x y /\ length xs = length ys) \/ (x = y /\ order_list_struct xs ys)
    | _, _ => False
    end.

    Definition order_list l1 l2 :=
      length l1 < length l2 \/ order_list_struct l1 l2.

    Lemma order_list_struct_len : forall x y,
      order_list_struct x y -> length x = length y.

    Lemma order_list_trans :
      (forall x y z, R x y -> R y z -> R x z) ->
      (forall x y z, order_list x y -> order_list y z -> order_list x z).

    Lemma order_list_total :
      (forall x y, R x y \/ x = y \/ R y x) ->
      (forall x y, order_list x y \/ x = y \/ order_list y x).

    Lemma order_list_wf : well_founded R -> well_founded order_list.
  End order_list.

  Fixpoint formula_to_syntax (f:formula) : list fsyn :=
    match f with
    | atomic a => A a ::nil
    | FF => FF_::nil
    | TT => TT_::nil
    | modality m f => M m :: formula_to_syntax f
    | conj f1 f2 => CONJ :: formula_to_syntax f1 ++ formula_to_syntax f2
    | disj f1 f2 => DISJ :: formula_to_syntax f1 ++ formula_to_syntax f2
    | impl f1 f2 => IMPL :: formula_to_syntax f1 ++ formula_to_syntax f2
    end.

  Definition order_formula f1 f2 :=
    order_list _ fsyn_order (formula_to_syntax f1) (formula_to_syntax f2).

  Lemma order_formula_trans :
    forall x y z, order_formula x y -> order_formula y z -> order_formula x z.

  Lemma formula_to_syntax_inj : forall x y a b,
    formula_to_syntax x ++ a = formula_to_syntax y ++ b -> x = y /\ a = b.

  Lemma order_formula_total :
    forall x y,
      order_formula x y \/ x = y \/ order_formula y x.

  Lemma order_formula_wf : well_founded order_formula.



Definition premodel := world -> Prop.
Definition model := { M : world -> Prop | kripke_monotone M }.

Definition model_app (mdl:model) : world -> Prop := proj1_sig mdl.
Coercion model_app : model >-> Funclass.

Lemma model_kripke (mdl:model) :
  forall w w', accessable w w' -> mdl w -> mdl w'.
Hint Resolve model_kripke.

Definition model_le (m1 m2:model) :=
  forall w, m1 w -> m2 w.

Lemma model_eq : forall (m1 m2:model),
  model_le m1 m2 -> model_le m2 m1 -> m1 = m2.

Fixpoint interp
  (f:formula) {struct f}
  : premodel :=

    match f with
    | atomic a => interp_atom a

    | impl f1 f2 => fun w => forall w', accessable w w' ->
                                  interp f1 w' ->
                                  interp f2 w'

    | conj f1 f2 => fun w => interp f1 w /\ interp f2 w

    | disj f1 f2 => fun w => interp f1 w \/ interp f2 w

    | modality m f => interp_mode m (interp f)

    | TT => fun w => True

    | FF => fun w => False
    end.

  Theorem interp_acc : forall f,
    forall w w',
      accessable w w' ->
      interp f w ->
      interp f w'.

  Definition interp' f : model := exist _ (interp f) (interp_acc f).

  Definition valid (f:formula) :=
    forall w, interp f w.

  Inductive IPL : formula -> Prop :=
  | IPL_then1 : forall x y, IPL (impl x (impl y x))
  | IPL_then2 : forall x y z,
      IPL (impl
           (impl x (impl y z))
           (impl (impl x y)
                 (impl x z)))

  | IPL_and1 : forall x y,
      IPL (impl (conj x y) x)
  | IPL_and2 : forall x y,
      IPL (impl (conj x y) y)
  | IPL_and3 : forall x y,
      IPL (impl x (impl y (conj x y)))

  | IPL_or1 : forall x y,
      IPL (impl x (disj x y))
  | IPL_or2 : forall x y,
      IPL (impl y (disj x y))
  | IPL_or3 : forall x y z,
      IPL (impl
           (impl x z)
           (impl
             (impl y z)
             (impl (disj x y) z)))

  | IPL_TT : IPL TT

  | IPL_FF : forall x, IPL (impl FF x).

  Inductive derives (AX:formula -> Prop) : (formula -> Prop) -> formula -> Prop :=
    | derives_logic : forall G f,
         IPL f -> derives AX G f
    | derives_axiom : forall G f,
         AX f -> derives AX G f
    | derives_assume : forall f (G:formula -> Prop),
         G f -> derives AX G f
    | derives_cut : forall G p q,
         derives AX G (impl p q) ->
         derives AX G p ->
         derives AX G q
    | derives_reg : forall m p q,
         (forall G, derives AX G (impl p q)) ->
         (forall G, derives AX G (impl (modality m p) (modality m q))).

  Ltac logic := eapply derives_logic; constructor.

  Lemma derives_weaken : forall AX (G G':formula -> Prop) f,
    (forall x, G x -> G' x) ->
    derives AX G f ->
    derives AX G' f.

  Hint Resolve derives_weaken.

  Lemma derives_collapse : forall AX G x,
    derives AX (derives AX G) x ->
    derives AX G x.

  Hint Resolve interp_acc.

  Lemma IPL_valid : forall f,
    IPL f -> valid f.

  Theorem theorems_valid : forall (AX G:formula -> Prop),
    (forall x, AX x -> valid x) ->
    (forall x, G x -> valid x) ->
    (forall f, derives AX G f -> valid f).

  Definition E0 : formula -> Prop := fun _ => False.
  Definition theorem AX p := derives AX E0 p.

  Lemma theorem_weaken : forall AX f G,
    theorem AX f ->
    derives AX G f.

  Hint Resolve theorem_weaken.

  Theorem derives_truth : forall (AX G:formula -> Prop) w,
    (forall x, AX x -> valid x) ->
    (forall x, G x -> interp x w) ->
    (forall f, derives AX G f -> interp f w).

  Lemma derives_conj : forall AX G p q,
    derives AX G (conj p q) <->
    derives AX G p /\ derives AX G q.

  Lemma derives_disj : forall AX G p q,
    derives AX G p \/ derives AX G q ->
    derives AX G (disj p q).

  Lemma derives_TT : forall AX G,
    derives AX G TT.

  Lemma derives_FF : forall AX G p,
    derives AX G FF ->
    derives AX G p.

  Lemma impl_adjoint1 : forall AX G p q,
    derives AX (fun x => G x \/ x = p) q ->
    derives AX G (impl p q).

  Lemma impl_adjoint2 : forall AX G p q,
    derives AX G (impl p q) ->
    derives AX (fun x => G x \/ x = p) q.

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

  Fixpoint list_conj (l:list formula) : formula :=
    match l with
      | nil => TT
      | x::l' => conj x (list_conj l')
    end.

  Fixpoint list_disj (l:list formula) : formula :=
    match l with
      | nil => FF
      | x::l' => disj x (list_disj l')
    end.

  Lemma disjunctive_elim : forall AX G p q z,
    derives AX G (impl p z) ->
    derives AX G (impl q z) ->
    derives AX G (disj p q) ->
    derives AX G z.

  Lemma disjunctive_combine : forall AX G p q pz qz,
    derives AX G (impl p pz) ->
    derives AX G (impl q qz) ->
    derives AX G (disj p q) ->
    derives AX G (disj pz qz).

  Lemma disjunctive_rearrange : forall AX G xs ys,
    derives AX G (impl (disj (list_disj xs) (list_disj ys))
                    (list_disj (xs++ys))).

  Lemma disjunctive_combine2 : forall AX G p q pz qz,
    derives AX G (impl p (list_disj pz)) ->
    derives AX G (impl q (list_disj qz)) ->
    derives AX G (disj p q) ->
    derives AX G (list_disj (pz++qz)).

  Lemma unwind_derives : forall AX G x,
    derives AX G x ->
    exists gs: list formula,
      (forall g, In g gs -> G g) /\
      derives AX (fun g => In g gs) x.

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

  Section prime_sets.
  Variable AX:formula -> Prop.

  Definition derives_set (X Y:formula -> Prop) :=
    exists ys,
      (forall y, In y ys -> Y y) /\
      derives AX X (list_disj ys).

  Record theory_avoiding (X Y:formula -> Prop) :=
  { tavd_set :> formula -> Prop
  ; tavd_contains : forall x, X x -> impl_free x -> derives AX tavd_set x
  ; tavd_avoids : ~derives_set tavd_set Y
  ; tavd_impl_free : forall p, tavd_set p -> impl_free p
  ; tavd_closed : forall q, impl_free q -> derives AX tavd_set q -> tavd_set q
  }.

  Definition ta_ord X Y (A B:theory_avoiding X Y) :=
    forall x, A x -> B x.

Program Definition theory_avoiding0
  (X Y Z:formula -> Prop)
  (HX: forall x, X x -> derives AX Z x)
  (HY:~derives_set Z Y) :
  theory_avoiding X Y :=
  {| tavd_set f := impl_free f /\ derives AX X f |}.

Program Definition theory_avoiding_incr
  X Y (T:theory_avoiding X Y)
  (p:formula)
  (H:~derives_set (fun x => T x \/ x = p) Y)
  : theory_avoiding X Y :=
  {| tavd_set f := impl_free f /\ derives AX (fun x => T x \/ x = p) f
   |}.

Lemma theory_avoiding_incr_ord : forall X Y T p H,
  ta_ord X Y T (theory_avoiding_incr X Y T p H).

Program Definition ta_chain_sup X Y (T:theory_avoiding X Y -> Prop) t
  (Ht:T t)
  (H:ordered_set _ (ta_ord X Y) T) : theory_avoiding X Y :=
    {| tavd_set f := exists t, T t /\ t f |}.

Lemma ta_chain_complete X Y : forall T t, ordered_set _ (ta_ord X Y) T -> T t ->
  exists bnd, least_upper_bound _ (ta_ord X Y) T bnd.

Lemma maximal_theory_avoiding_disjunctive {Classic:EM} : forall X Y
  (T:theory_avoiding X Y), maximal _ (ta_ord X Y) T ->
  forall p q, T (disj p q) -> T p \/ T q.

Definition admissable_formula X Y (T:theory_avoiding X Y) (f:formula) :=
  impl_free f /\
  ~T f /\
  ~derives_set (fun x => T x \/ x = f) Y.

Definition smallest_admissable_formula X Y (T:theory_avoiding X Y) (f:formula) :=
  admissable_formula X Y T f /\
  forall f', admissable_formula X Y T f' -> f = f' \/ order_formula f f'.

Lemma order_formula_irr : forall f, order_formula f f -> False.

Program Definition inflate_theory {Classic:EM} X Y (T:theory_avoiding X Y)
  : theory_avoiding X Y :=
  {| tavd_set f := impl_free f /\
    derives AX (fun x => T x \/ smallest_admissable_formula X Y T x) f |}.

Lemma inflate_theory_inflationary {Classic:EM} X Y : inflationary _ (ta_ord X Y) (inflate_theory X Y).

Lemma inflate_theory_iso {Classic:EM} X Y :
   forall x y : theory_avoiding X Y,
   ta_ord X Y x y ->
   ta_ord X Y y x -> ta_ord X Y (inflate_theory X Y x) (inflate_theory X Y y).

Lemma minimize_admissable_formula {Classic:EM} : forall X Y T x,
  admissable_formula X Y T x ->
  exists z, smallest_admissable_formula X Y T z.

Lemma inflate_theory_fixpoint_maximal {Classic:EM} : forall X Y T,
  ta_ord X Y (inflate_theory X Y T) T ->
  maximal _ (ta_ord X Y) T.

Record prime_set :=
  { pset :> formula -> Prop
  ; pset_consistent : pset FF -> False
  ; pset_disjunctive : forall p q, pset (disj p q) -> pset p \/ pset q
  ; pset_closed : forall q, impl_free q -> derives AX pset q -> pset q
  ; pset_impl_free : forall p, pset p -> impl_free p
  }.

Program Definition prime_theory_avoiding X Y
  (T:theory_avoiding X Y)
  (H:forall p q, T (disj p q) -> T p \/ T q)
  : prime_set :=
  {| pset := T |}.

Lemma prime_lemma {Classic:EM} : forall X Y,
  ~derives_set X Y ->
  exists G:prime_set,
    ~derives_set G Y /\
    forall x, impl_free x -> X x -> G x.

Lemma alternate_prime_lemma {Classic:EM} : forall X Y
  (Hchoose : ChoiceFacts.FunctionalChoice),

  ~derives_set X Y ->
  exists G:prime_set,
    ~derives_set G Y /\
    forall x, impl_free x -> X x -> G x.
End prime_sets.

End proplogic.

Hint Resolve @model_kripke.
Hint Resolve @derives_weaken.
Hint Resolve @interp_acc.
Hint Resolve @theorem_weaken.

Ltac logic := eapply derives_logic; constructor.

End PropLogic.