QRC1.KripkeSemantics
From mathcomp Require Import all_ssreflect finmap.
From QRC1 Require Import Language QRC1.
Local Open Scope qsp_scope.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Reserved Notation "g `+" (at level 1, format "g `+").
Reserved Notation "g ` u" (at level 1, format "g ` u").
Reserved Notation "M `| r" (at level 1, format "M `| r").
Reserved Notation "M `[ r , c <- d ]"
(at level 8, format "M `[ r , c <- d ]").
Section KripkeSemantics.
Local Open Scope fset.
Variable sig : signature.
Notation term := (term sig).
Notation formula := (formula sig).
Notation ConstName := (ConstName sig).
Notation PredName := (PredName sig).
Notation Var := (Var sig).
Variables WType MType : choiceType.
(* Note: we only implement finite frames *)
Record rawFrame := RawFrame {
world :> {fset WType};
R : world -> world -> bool;
domain : world -> {fset MType};
eta : forall (w u : world), domain w -> domain u;
(* at the level of rawFrames we require an eta function for every pair w, u *)
}.
Record rawConstFrame := RawConstFrame {
cworld :> {fset WType};
cR : cworld -> cworld -> bool;
cdomain : {fset MType};
}.
(* Any constant domain frame can be seen as a frame *)
Coercion rawFrame_of_rawConstFrame (cF : rawConstFrame) : rawFrame :=
@RawFrame (cworld cF) (@cR cF) (fun w => cdomain cF) (fun w u a => a).
Record rawModel := RawModel {
rawFrame_of_rawModel :> rawFrame;
I : forall w : world rawFrame_of_rawModel, ConstName -> (domain w);
J : forall w : world rawFrame_of_rawModel, forall (P : PredName),
{fset (arity P).-tuple (domain w)}
}.
Definition transitiveF (F : rawFrame) : bool :=
[forall w : F, forall u : F, forall v : F,
(R w u) ==> (R u v) ==> (R w v)
].
Lemma transitiveFP (F : rawFrame) :
reflect (transitive (@R F)) (transitiveF F).
Proof.
by apply: (iffP 'forall_'forall_'forall_implyP) => H ? ? ? ?;
apply/implyP; apply:H.
Qed.
Definition transetaF (F : rawFrame) : bool :=
[forall w : F, forall u : F, forall v : F, forall d : domain w,
(R w u) ==> (R u v) ==>
(eta v d == eta v (eta u d))
].
Lemma transetaFP (F : rawFrame) :
reflect
(forall (w u v : F) (d : domain w),
R w u -> R u v ->
eta v d = eta v (eta u d)
)
(transetaF F).
Proof.
apply: (iffP 'forall_'forall_'forall_'forall_implyP) => /= H ? ? ? ? ?.
by move=> Ruv; apply/eqP; move: Ruv; apply/implyP; apply: H.
by apply/implyP => ?; apply/eqP; apply: H.
Qed.
Definition idetaF (F : rawFrame) : bool :=
[forall w : F, forall d : domain w, eta w d == d].
Lemma idetaFP (F : rawFrame) :
reflect
(forall (w : F) (d : domain w), eta w d = d)
(idetaF F).
Proof. by apply: (iffP 'forall_'forall_eqP). Qed.
Definition concordantM (M : rawModel) : bool :=
[forall w : M, forall u : M, (R w u) ==>
[forall c : ConstName, val (I u c) == val (eta u (I w c))]
].
Lemma concordantMP (M : rawModel) :
reflect
(forall (w u : M), R w u ->
forall c : ConstName, val (I u c) = val (eta u (I w c))
)
(concordantM M).
Proof.
by apply: (iffP 'forall_'forall_implyP)=> H ? ? ?; apply/'forall_eqP; apply:H.
Qed.
Definition adequateF (F : rawFrame) : bool :=
[&& transitiveF F, transetaF F & idetaF F].
Lemma adequateFP (F : rawFrame) :
reflect [/\ transitiveF F, transetaF F & idetaF F] (adequateF F).
Proof. by apply: (iffP and3P). Qed.
Record frame := Frame {
rawFrame_of_frame :> rawFrame;
_ : adequateF rawFrame_of_frame
}.
Canonical frame_subType := [subType for rawFrame_of_frame].
Lemma frame_adequate (F : frame) : adequateF F.
Proof. by case: F. Qed.
Definition adequateM (M : rawModel) : bool :=
(adequateF M) && (concordantM M).
Lemma adequateMP (M : rawModel) :
reflect (adequateF M /\ concordantM M) (adequateM M).
Proof. by apply: (iffP andP). Qed.
Record model := Model {
rawModel_of_model :> rawModel;
_ : adequateM rawModel_of_model
}.
Canonical model_subType := [subType for rawModel_of_model].
Lemma model_adequate (M : model) : adequateM M.
Proof. by case: M. Qed.
Lemma frame_of_model_subproof (M : model) : adequateF M.
Proof.
case: M => F adeqF; rewrite /rawModel_of_model.
by move /adequateMP : adeqF => [].
Qed.
Hint Resolve frame_of_model_subproof : core.
Coercion frame_of_model (M : model) := @Frame M (frame_of_model_subproof M).
(* We define frame_of_model as canonical because the square below commutes *)
(*
model --> rawModel
| |
| o |
v v
frame --> rawFrame
*)
Canonical frame_of_model.
Definition assignment (F : rawFrame) (w : F) : Type := VarName -> domain w.
Definition assignment_of_term (M : rawModel) (w : M) (g : assignment w)
: term -> domain w := fun t =>
match t with
| Language.Var x => g x
| Const c => I w c
end.
Notation "g `+" := (assignment_of_term g).
Definition Xaltern (F : rawFrame) (w : F) (g h : assignment w)
(X : {fset VarName}) : Prop :=
forall x : VarName, x \notin X -> g x = h x.
Definition xaltern (F : rawFrame) (w : F) (g h : assignment w) (x : VarName)
: Prop :=
Xaltern g h [fset x].
Lemma XalternC (F : rawFrame) (w : F) (g h : assignment w)
(X : {fset VarName}) :
Xaltern g h X <-> Xaltern h g X.
Proof.
move: F w g h.
suff : forall g h, Xaltern g h X -> Xaltern h g X.
by move=> Himpl; split; apply: Himpl.
by move=> F w g h; rewrite /Xaltern => alterngh x xnotinX; rewrite alterngh.
Qed.
Lemma XalternU (F : rawFrame) (w : F) (g h : assignment w)
(X Y : {fset VarName}) :
Xaltern g h X -> Xaltern g h (X `|` Y).
Proof.
move=> Xalterngh x.
by rewrite in_fsetE negb_or => /andP [xnotinX _]; apply: Xalterngh.
Qed.
Lemma XalternW (F : rawFrame) (w : F) (g h : assignment w)
(X Y : {fset VarName}) :
X `<=` Y ->
Xaltern g h X -> Xaltern g h Y.
Proof. by move=> /fsetUidPr <- Xalterngh; apply: XalternU. Qed.
Lemma Xaltern_trans (F : rawFrame) (w : F) (g1 g2 g3 : assignment w)
(X : {fset VarName}) :
Xaltern g1 g2 X ->
Xaltern g2 g3 X ->
Xaltern g1 g3 X.
Proof.
move=> Xalterng1g2 Xalterng2g3 x xnotinX.
by rewrite Xalterng1g2 // Xalterng2g3.
Qed.
Lemma xaltern_trans (F : rawFrame) (w : F) (g1 g2 g3 : assignment w)
(x : VarName) :
xaltern g1 g2 x ->
xaltern g2 g3 x ->
xaltern g1 g3 x.
Proof. by apply: Xaltern_trans. Qed.
Lemma Xaltern_assignment_of_term (M : rawModel) (w : M) (g h : assignment w)
(X : {fset VarName}) :
Xaltern g h X -> forall t : term,
match t with
| Language.Var x => x \notin X -> g`+ t = h`+ t
| Const _ => g`+ t = h`+ t
end.
Proof. by move=> Xalterngh; case. Qed.
Notation "g ` u" := (eta u \o g).
Lemma Xaltern_eta (F : rawFrame) (w u : F) (g h : assignment w)
(X : {fset VarName}) :
Xaltern g h X -> Xaltern g`u h`u X.
Proof.
move=> alterngh x xnotinX.
by apply/val_eqP => /=; apply/val_eqP; rewrite alterngh.
Qed.
Definition Xeq (F : rawFrame) (w : F) (g h : assignment w)
(X : {fset VarName}) : Prop :=
forall x : VarName, x \in X -> g x = h x.
Lemma XeqC (F : rawFrame) (w : F) (g h : assignment w) (X : {fset VarName}) :
Xeq g h X <-> Xeq h g X.
Proof.
move: F w g h.
suff : forall g h, Xeq g h X -> Xeq h g X.
by move=> Himpl; split; apply: Himpl.
by move=> F w g h; rewrite /Xeq => eqgh x xinX; rewrite eqgh.
Qed.
Lemma Xeq_trans (F : rawFrame) (w : F) (g1 g2 g3 : assignment w)
(X : {fset VarName}) :
Xeq g1 g2 X ->
Xeq g2 g3 X ->
Xeq g1 g3 X.
Proof.
move=> Xeqg1g2 Xeqg2g3 x xinX.
by rewrite Xeqg1g2 // Xeqg2g3.
Qed.
Lemma XeqW (F : rawFrame) (w : F) (g h : assignment w) (X Y : {fset VarName}) :
X `<=` Y ->
Xeq g h Y -> Xeq g h X.
Proof.
move=> /fsetIidPl <- Yeqgh x xinX; rewrite Yeqgh //.
by move: xinX; rewrite in_fsetE => /andP [].
Qed.
Lemma Xeq_eta (F : rawFrame) (w u : F) (g h : assignment w)
(X : {fset VarName}) :
Xeq g h X -> Xeq g`u h`u X.
Proof.
move=> Xeqgh x xinX.
by apply /val_eqP => /=; apply /val_eqP; rewrite Xeqgh.
Qed.
Fixpoint sat (M : rawModel) (w : M) (g : assignment w) (A : formula) : Prop :=
match A with
| T => True
| Pred P ts => [tuple of map g`+ ts] \in J w P
| B /\ C => sat g B /\ sat g C
| <> B => exists (u : M), (R w u /\ sat g`u B)%type
| All x B => forall h : assignment w, xaltern g h x -> sat h B
end.
Lemma sat_Xeqfv (M : rawModel) (w : M) (g h : assignment w) (X : {fset VarName})
(A : formula) :
Xeq g h (fv A) ->
sat g A <-> sat h A.
Proof.
move: M w g h.
suff: forall g h, Xeq g h (fv A) -> sat g A -> sat h A.
move=> Himpl alterngh; split.
by apply: Himpl.
by apply: Himpl => //; rewrite XeqC.
move=> M; elim: A => //.
- move=> P ts w g h /= Peqgh.
suff -> : [tuple of map g`+ ts] = [tuple of map h`+ ts] by [].
apply: eq_from_tnth => i; rewrite 2!tnth_map.
case eqtnth : (tnth ts i) => [x /= | //].
rewrite Peqgh //; apply /bigfcupP => /=.
exists (Var x) => //=.
by rewrite -eqtnth mem_tnth.
by rewrite fset11.
- move=> A IHA B IHB w g h /= ABeqgh [satgA satgB]; split.
apply: (IHA _ g) => //.
by apply: (XeqW _ ABeqgh); apply: fsubsetUl.
apply: (IHB _ g) => //.
by apply: (XeqW _ ABeqgh); apply: fsubsetUr.
- move=> A IHA w g h /= Aeqgh [u [Rwu satgA]].
exists u; split=> //.
apply: (IHA _ g`u) => //.
by apply: Xeq_eta.
- move=> y A IHA w g h yAeqgh /= satgyA f yalternhf.
pose f' := fun z : VarName => if z == y then f y else g z.
have yalterngf' : xaltern g f' y.
by move=> z; rewrite /f' in_fsetE; case: eqP.
have yAeqf'g : Xeq f' g (fv (All y A)).
move=> x xinfvyA; rewrite /f'; case: eqP => // eqxy.
by exfalso; move: xinfvyA; rewrite eqxy /= !in_fsetE eqxx.
have yAeqhf : Xeq h f (fv (All y A)).
move=> x xinfvyA; rewrite yalternhf //.
by move: xinfvyA; rewrite /= !in_fsetE => /andP [].
have yAeqff' : Xeq f' f (fv (All y A)).
by apply: (Xeq_trans _ yAeqhf); apply: (Xeq_trans yAeqf'g).
move: (satgyA _ yalterngf'); apply: IHA => x xinA.
rewrite /f'; case: eqP => [-> // | /eqP neqxy].
have xinyA : x \in fv (All y A).
by rewrite /= inE xinA in_fsetE neqxy.
by rewrite -yAeqff' // yAeqf'g.
Qed.
Lemma sat_Xalternfv (M : rawModel) (w : M) (g h : assignment w)
(X : {fset VarName}) (A : formula) :
Xaltern g h X ->
fdisjoint X (fv A) ->
sat g A <-> sat h A.
Proof.
move=> Xalterngh /fdisjointP_sym disjXA; apply: (sat_Xeqfv X).
move=> x xinA; rewrite Xalterngh //.
by apply: disjXA.
Qed.
Lemma substitution_formula (M : model) (w : M) (g g' : assignment w)
(x : VarName) (t : term) (A : formula) :
xaltern g g' x ->
g' x = g`+ t ->
freefor A x t ->
sat g' A <-> sat g A`[Var x <- t].
Proof.
have [| xnotinA] := boolP (x \in fv A); last first.
move=> xalterngg' _ _.
rewrite sub_notfree // (sat_Xalternfv xalterngg') //.
by apply /fdisjointP => /= y; rewrite in_fsetE => /eqP ->.
move: w g g'; elim: A => //.
- move=> P ts w g g' /= xinP xalterngg' eqg'xgt _.
set mapg := [tuple of map g`+ _].
suff -> : [tuple of map g'`+ ts] = mapg by [].
apply: eq_from_tnth => i; rewrite 3!tnth_map.
case: eqP => [-> // |].
case: (tnth ts i) => //= y neqyx.
rewrite xalterngg' // in_fsetE.
by apply /eqP => eqyx; move: neqyx; rewrite eqyx.
- move=> A IHA B IHB w g g' /=.
rewrite in_fsetE => /orP [xinA | xinB] xalterngg' eqg'xgt.
move=> /andP [freeforA freeforB].
rewrite (IHA _ g) //.
have [xinB | xnotinB] := boolP (x \in fv B).
by rewrite (IHB _ g).
rewrite (sub_notfree _ xnotinB).
rewrite (@sat_Xalternfv _ _ _ _ _ B xalterngg') //.
by apply /fdisjointP => /= y; rewrite in_fsetE => /eqP ->.
move=> /andP [freeforA freeforB].
rewrite (IHB _ g) //.
have [xinA | xnotinA] := boolP (x \in fv A).
by rewrite (IHA _ g).
rewrite (sub_notfree _ xnotinA).
rewrite (@sat_Xalternfv _ _ _ _ _ A xalterngg') //.
by apply /fdisjointP => /= y; rewrite in_fsetE => /eqP ->.
- move=> A IHA w g g' /= xinA xalterngg' eqg'xgt freeforAxt.
have xalterngRg'R : forall u, xaltern g`u g'`u x.
by move=> u; apply: Xaltern_eta.
have eqg'RxgRt : forall u, R w u -> g'`u x = (g`u)`+ t.
move=> u Rwu; apply /val_eqP => /=; rewrite eqg'xgt.
case: {+}t => //= c.
move: (model_adequate M) => /adequateMP [_ /concordantMP].
by move=> /(_ _) /(_ _) /(_ Rwu) ->.
split; move=> [u [Rwu satuA]]; exists u; split=> //.
by rewrite -(IHA _ _ g'`u) // eqg'RxgRt.
by rewrite (IHA _ g`u) // eqg'RxgRt.
- move=> y A IHA w g g' xinyA xalterngg' eqg'xgt freeforyAxt.
have neqyx : y == x = false.
by apply /eqP => eqxy; move: xinyA => /=; rewrite eqxy 2!inE eqxx.
have neqVaryx : Var y == Var x = false.
by apply/eqP => -[eqyx]; move: neqyx; rewrite eqyx eqxx.
have xinA : x \in fv A.
by move: xinyA => /=; rewrite !in_fsetE => /andP [].
have freeforAxt : freefor A x t.
by move: freeforyAxt => /= /orP [| /andP [] //]; rewrite neqyx.
split.
move=> satg'yA /=; rewrite neqVaryx => /= h yalterngh.
pose h' := fun z : VarName => if z == x then h`+ t else h z.
have xalternhh' : xaltern h h' x.
by move=> z; rewrite in_fsetE /h' => /negPf ->.
rewrite -(IHA _ _ h') //; last by rewrite /h' eqxx.
apply: satg'yA.
have xyalternhh' : Xaltern h h' [fset x; y].
by apply: (XalternW _ xalternhh'); rewrite fsub1set 2!inE eqxx.
have xyalterngh : Xaltern g h [fset x; y].
by apply: (XalternW _ yalterngh); rewrite fsub1set 3!inE eqxx orbT.
have xyalterng'g : Xaltern g' g [fset x; y].
rewrite XalternC.
by apply: (XalternW _ xalterngg'); rewrite fsub1set 2!inE eqxx.
have xyalterng'h' : Xaltern g' h' [fset x; y].
by apply: (Xaltern_trans xyalterng'g); apply: (Xaltern_trans xyalterngh).
move=> z; rewrite in_fsetE => /negPf neqzy.
case: (@eqP _ z x) => [-> | /eqP /negPf neqzx]; last first.
by rewrite xyalterng'h' // !in_fsetE neqzy neqzx.
rewrite /h' eqxx eqg'xgt.
have : t != Var y.
apply /eqP => eqty; move: freeforyAxt.
by rewrite /= neqyx freeforAxt xinA eqty in_fsetE eqxx.
case: {+}t => //= z' neqz'y.
rewrite yalterngh // in_fsetE.
by apply /eqP => eqz'y; move: neqz'y; rewrite eqz'y eqxx.
rewrite /= neqVaryx => /= satgyAt h' yalterng'h'.
pose h := fun z : VarName => if z == x then g x else h' z.
have xalternhh' : xaltern h h' x.
by move=> z; rewrite in_fsetE /h => /negPf ->.
have yalterngh : xaltern g h y.
have xyalternh'h : Xaltern h' h [fset x; y].
rewrite XalternC.
by apply: (XalternW _ xalternhh'); rewrite fsub1set 2!inE eqxx.
have xyalterngg' : Xaltern g g' [fset x; y].
by apply: (XalternW _ xalterngg'); rewrite fsub1set 2!inE eqxx.
have xyalterng'h' : Xaltern g' h' [fset x; y].
apply: (XalternW _ yalterng'h').
by rewrite fsub1set 3!inE eqxx orbT.
have xyalterngh : Xaltern g h [fset x; y].
apply: (Xaltern_trans xyalterngg').
by apply: (Xaltern_trans xyalterng'h').
move=> z; rewrite in_fsetE => /negPf neqzy.
case: (@eqP _ z x) => [-> | /eqP /negPf neqzx]; first by rewrite /h eqxx.
by rewrite xyalterngh // !in_fsetE neqzy neqzx.
rewrite (IHA _ h) //; first by apply: satgyAt.
rewrite -yalterng'h'; last by rewrite in_fsetE eq_sym neqyx.
rewrite eqg'xgt.
have : t <> Var y.
move=> eqty; move: freeforyAxt.
by rewrite /= freeforAxt xinA eqty neqyx in_fsetE eqxx.
case: {+}t => //= z neqzy.
rewrite yalterngh // in_fsetE.
by apply /eqP => eqzy; apply: neqzy; rewrite eqzy.
Qed.
Lemma sat_noconstants (F : rawFrame) Ic Ic' J :
let rM := @RawModel F Ic J in
let rM' := @RawModel F Ic' J in
forall (adeqM : adequateM rM) (adeqM' : adequateM rM') (w : F)
(g : assignment w) (A : formula),
(forall c, c \in constants A -> Ic w c = Ic' w c) ->
sat (M := Model adeqM) g A <-> sat (M := Model adeqM') g A.
Proof.
move=> rM rM' adeqM adeqM' w g A; move: w g; elim: A => //=.
- move=> P ts w g constantfree.
set tup := [tuple of _].
set tup' := [tuple of _].
suff -> : tup = tup' by [].
apply: eq_from_tnth => i; rewrite 2!tnth_map.
case eqtnth : (tnth ts i) => [// | c /=].
apply: constantfree; apply /bigfcupP => /=; exists (Const c).
by rewrite -eqtnth mem_tnth.
by rewrite /= in_fsetE eqxx.
- move=> A IHA B IHB w g constantfreeAB.
rewrite IHA ?IHB //.
move=> c cinB; apply: constantfreeAB.
by rewrite in_fsetU cinB orbT.
move=> c cinA; apply: constantfreeAB.
by rewrite in_fsetU cinA.
- move=> A IHA w g constantfree.
split.
move=> [u [Rwu satgA]]; exists u; split=> //.
rewrite -IHA // => c cinA.
have := adeqM => /adequateMP [_ /concordantMP /(_ _) /(_ _) /(_ Rwu)].
move=> /(_ c) /= eqIwcIuc; apply /val_eqP => /=; rewrite eqIwcIuc.
have := adeqM' => /adequateMP [_ /concordantMP /(_ _) /(_ _) /(_ Rwu)].
move=> /(_ c) /= eqI'wcI'uc; rewrite eqI'wcI'uc.
by rewrite constantfree.
move=> [u [Rwu satgA]]; exists u; split=> //.
rewrite IHA // => c cinA.
have := adeqM => /adequateMP [_ /concordantMP /(_ _) /(_ _) /(_ Rwu)].
move=> /(_ c) /= eqIwcIuc; apply /val_eqP => /=; rewrite eqIwcIuc.
have := adeqM' => /adequateMP [_ /concordantMP /(_ _) /(_ _) /(_ Rwu)].
move=> /(_ c) /= eqI'wcI'uc; rewrite eqI'wcI'uc.
by rewrite constantfree.
- move=> x A IHA w g constantfree; split.
by move=> satgxA h xaltengh; rewrite -IHA //; apply: satgxA.
by move=> satgxA h xaltengh; rewrite IHA //; apply: satgxA.
Qed.
End KripkeSemantics.
Notation "g `+" := (assignment_of_term g).
Notation "g ` u" := (eta u \o g).
Section ReplacedModels.
Variable sig : signature.
Notation term := (term sig).
Notation formula := (formula sig).
Notation ConstName := (ConstName sig).
Notation PredName := (PredName sig).
Variables WType MType : choiceType.
Notation rawFrame := (rawFrame WType MType).
Notation frame := (frame WType MType).
Notation rawModel := (rawModel sig WType MType).
Notation model := (model sig WType MType).
Definition Rs (F : rawFrame) : F -> F -> bool :=
fun w u => (w == u) || R w u.
Lemma RsP (F : rawFrame) (w u : F) :
reflect (w = u \/ R w u) (Rs w u).
Proof.
by apply: (iffP orP) => [[/eqP |] | [/eqP |]]; [left | right | left | right].
Qed.
Lemma Rsww (F : rawFrame) (w : F) : Rs w w.
Proof. by apply/RsP; left. Qed.
Lemma RRs (F : rawFrame) (w u : F) : R w u -> Rs w u.
Proof. by rewrite /Rs => ->; rewrite orbT. Qed.
Local Hint Resolve Rsww RRs : core.
Lemma RsR_trans (F : frame) (r w u : F) : Rs r w -> R w u -> Rs r u.
Proof.
move=> /RsP [-> | Rrw Rwu]; first by apply: RRs.
apply/RsP; right.
move: (frame_adequate F) => /adequateFP [/transitiveFP transF _ _].
by apply: transF Rwu.
Qed.
Definition transitiveFr (F : rawFrame) (r : F) : bool :=
[forall w : F, forall u : F, forall v : F,
[&& Rs r w, R w u & R u v] ==> R w v
].
Lemma transitiveFrP (F : rawFrame) (r : F) :
reflect
(forall (w u v : F),
Rs r w -> R w u -> R u v ->
R w v
)
(transitiveFr r).
Proof.
apply: (iffP 'forall_'forall_'forall_implyP) => /=.
by move=> H w u v Rsw Rwu Ruv; apply: (H w u v); apply /and3P.
by move=> H w u v /and3P []; apply: H.
Qed.
Definition transetaFr (F : rawFrame) (r : F) : bool :=
[forall w : F, forall u : F, forall v : F, forall d : domain w,
[&& Rs r w, R w u & R u v] ==>
(eta v d == eta v (eta u d))
].
Lemma transetaFrP (F : rawFrame) (r : F) :
reflect
(forall (w u v : F) (d : domain w),
Rs r w -> R w u -> R u v ->
eta v d = eta v (eta u d)
)
(transetaFr r).
Proof.
apply: (iffP 'forall_'forall_'forall_'forall_implyP) => /=.
by move=> H w u v d Rsw Rwu Ruv; apply/eqP; apply: H; apply/and3P.
by move=> H w u v d /and3P [? ? ?]; apply/eqP; apply: H.
Qed.
Definition idetaFr (F : rawFrame) (r : F) : bool :=
[forall w : F, forall d : domain w, (Rs r w) ==> (eta w d == d)].
Lemma idetaFrP (F : rawFrame) (r : F) :
reflect
(forall (w : F) (d : domain w), Rs r w -> eta w d = d)
(idetaFr r).
Proof.
by apply: (iffP 'forall_'forall_implyP) => /= H w d Rsw; apply/eqP; apply: H.
Qed.
Definition adequateFr (F : rawFrame) (r : F) : bool :=
[&& transitiveFr r, transetaFr r & idetaFr r].
Lemma adequateFrP (F : rawFrame) (r : F) :
reflect
([/\ transitiveFr r, transetaFr r & idetaFr r])
(adequateFr r).
Proof. by apply: (iffP and3P). Qed.
Lemma frame_adequateFr (F : frame) (r : F) : adequateFr r.
Proof.
move: (frame_adequate F) => /adequateFP [/transitiveFP transF
/transetaFP tretaF
/idetaFP idF].
apply/adequateFrP; split.
- by apply/transitiveFrP => w u v _; apply: transF.
- by apply/transetaFrP => w u v d _; apply: tretaF.
- by apply/idetaFrP => w d _; apply: idF.
Qed.
Definition concordantMr (M : rawModel) (r : M) : bool :=
[forall w : M, forall u : M, forall c : ConstName,
(Rs r w && R w u) ==>
(val (I u c) == val (eta u (I w c)))
].
Lemma concordantMrP (M : rawModel) (r : M) :
reflect
(forall (w u : M) (c : ConstName),
Rs r w -> R w u ->
val (I u c) = val (eta u (I w c))
)
(concordantMr r).
Proof.
apply: (iffP 'forall_'forall_'forall_implyP) => /=.
by move=> H w u c Rsw Rwu; apply/eqP; apply: H; apply/andP.
by move=> H w u c /andP [? ?]; apply/eqP; apply: H.
Qed.
Definition adequateMr (M : rawModel) (r : M) : bool :=
(adequateFr r) && (concordantMr r).
Lemma adequateMrP (M : rawModel) (r : M) :
reflect (adequateFr r /\ concordantMr r) (adequateMr r).
Proof. by apply: (iffP andP). Qed.
Lemma model_adequateMr (M : model) (r : M) : adequateMr r.
Proof.
move: (model_adequate M) => /adequateMP [adeqF /concordantMP concM].
apply/adequateMrP; split; first by apply: frame_adequateFr.
by apply/concordantMrP => w u c _ Rwu; apply: concM.
Qed.
(* This will not lead to an adequate model unless Rs r w *)
Definition replace_I (M : rawModel) (r : M) (c : ConstName) (d : domain r)
: forall w : M, ConstName -> domain w :=
fun w c' =>
if c' == c then
eta w d
else
I w c'.
Definition replace_rawModel (M : rawModel) (r : M) (c : ConstName)
(d : domain r) : rawModel :=
RawModel (replace_I c d) (@J _ _ _ _).
Notation "M `[ r , c <- d ]" := (@replace_rawModel M r c d).
Set Printing Implicit Defensive.
Lemma replace_adequateMr (M : model) (r : M) (c : ConstName) (d : domain r) :
adequateMr (M := replace_rawModel c d) r.
Proof.
apply/adequateMrP; split; first by apply: frame_adequateFr.
apply/concordantMrP => /= w u c' Rsrw Rwu.
rewrite /replace_I; case: eqP => _.
apply/eqP/val_eqP.
move: Rsrw => /RsP [<- | Rrw].
by move: (frame_adequate M) => /adequateFP [_ _ /idetaFP ->].
by have /adequateFP [_ /transetaFP <- //] := frame_adequate M.
move: (model_adequate M) => /adequateMP [_ /concordantMP concM].
by rewrite (concM _ _ Rwu).
Qed.
Lemma sat_replace_noconstants (M : model) (r w : M) (c : ConstName)
(d : domain r) (g : assignment w) (A : formula) :
Rs r w ->
c \notin constants A ->
sat (M := M) g A <-> sat (M := M`[r, c <- d]) g A.
Proof.
move: w g; elim: A => //=.
- move=> P ts w g Rsrw /negP cnotints.
set tup := [tuple of _]; set tup' := [tuple of _].
suff <- : tup = tup' by [].
apply: eq_from_tnth => i; rewrite !tnth_map.
case isith : (tnth ts i) => [// | c' /=].
rewrite /replace_I; case: eqP => [eqc'c | //].
exfalso; apply: cnotints; rewrite -eqc'c.
apply /bigfcupP; exists (Const c').
by rewrite -isith mem_tnth.
by rewrite in_fsetE.
- move=> A IHA B IHB w g Rsrw.
rewrite in_fsetE => /norP [cnotinA cnotinB].
by rewrite IHA // IHB.
- move=> A IHA w g Rsrw cnotinA; split.
move=> [u [Rwu satMuA]].
by exists u; rewrite -IHA //; apply: RsR_trans Rwu.
move=> [u [Rwu satMruA]].
by exists u; rewrite IHA //; apply: RsR_trans Rwu.
- move=> x A IHA w g Rsrw cnotinA; split.
move=> satMxA h xalterngh.
by rewrite -IHA //; apply: satMxA.
move=> satMrxA h xalterngh.
by rewrite IHA //; apply: satMrxA.
Qed.
Lemma sat_replace_root (M : model) (r w u : M) (c : ConstName) (d : domain r)
(g : assignment u) (A : formula) :
Rs r w -> Rs w u ->
sat (M := M`[r, c <- d]) g A <-> sat (M := M`[w, c <- eta w d]) g A.
Proof.
move: M r w u c d g; elim: A => //.
- move=> P ts M r w u c d g Rsrw Rswu /=.
set tup := [tuple of _]; set tup' := [tuple of _].
suff -> : tup = tup' by [].
apply: eq_from_tnth => i; rewrite !tnth_map.
case isith : (tnth ts i) => [// | c' /=].
rewrite /replace_I; case: eqP => [eqc'c | //].
move: (frame_adequate M) => /adequateFP [_ /transetaFP treta /idetaFP ide].
move: Rsrw => /RsP [<- | Rrw]; first by rewrite ide.
move: Rswu => /RsP [<- | Rwu]; first by rewrite ide.
by rewrite (treta _ _ _ _ Rrw Rwu).
- move=> A IHA B IHB M r w u c d g Rsrw Rswu /=.
by rewrite (IHA _ _ w) // (IHB _ _ w).
- move=> A /= IHA M r w u c d g Rsrw Rswu; split=> [] [v [Ruv satvA]].
exists v; split => //.
by rewrite -IHA //; apply: RsR_trans Ruv.
exists v; split=> //.
by move: satvA; rewrite -IHA //; apply: RsR_trans Ruv.
- move=> x A IHA M r w u c d g Rsrw Rswu; split=> /= satA h xalterngh.
by rewrite -IHA //; apply: satA.
by rewrite (IHA _ _ w) //; apply: satA.
Qed.
Lemma sat_replace_root_self (M : model) (r w : M) (c : ConstName) (d : domain r)
(g : assignment w) (A : formula) :
Rs r w ->
sat (M := M`[r, c <- d]) g A <-> sat (M := M`[w, c <- eta w d]) g A.
Proof.
by move=> Rsrw; rewrite (sat_replace_root _ _ _ _ Rsrw) ?Rsww.
Qed.
Lemma sat_replace (M : model) (w : M) (c : ConstName) (x : VarName)
(g : assignment w) (A : formula) :
c \notin constants A ->
sat (M := M) g A <-> sat (M := M`[w, c <- g x]) g A`[Var _ x <- Const c].
Proof.
have [|] := boolP (x \in fv A); last first.
move=> xnotinA cnotinA.
by rewrite sub_notfree // -sat_replace_noconstants // Rsww.
move: M w g; elim: A => //.
- move=> P t M w g xinP /negP cnotinC /=.
set tup := [tuple of _]; set tup' := [tuple of _].
suff -> : tup = tup' by [].
apply: eq_from_tnth => i.
rewrite !tnth_map; case: eqP => [-> /= | _].
rewrite /replace_I eqxx.
by move: (frame_adequate M) => /adequateFP [_ _ /idetaFP ->].
case istnthi : (tnth t i) => [// | c' /=].
rewrite /replace_I; case: eqP => [eqc'c | //].
exfalso; apply: cnotinC; rewrite -eqc'c /=.
apply /bigfcupP => /=; exists (Const c') => //=.
by rewrite -istnthi mem_tnth.
by rewrite in_fsetE.
- move=> A IHA B IHB M w g /= xinAB.
rewrite in_fsetE => /norP [cnotinA cnotinB].
move: xinAB; rewrite in_fsetE => /orP [xinA | xinB].
have [xinB | xnotinB] := boolP (x \in fv B).
by rewrite IHA // IHB.
rewrite IHA // (sub_notfree _ xnotinB).
by rewrite -(sat_replace_noconstants _ _ _ cnotinB) // Rsww.
have [xinA | xnotinA] := boolP (x \in fv A).
by rewrite IHA // IHB.
rewrite IHB // (sub_notfree _ xnotinA).
by rewrite -(sat_replace_noconstants _ _ _ cnotinA) // Rsww.
- move=> A IHA M w g /= xinA cnotinA; split.
move=> [u [Rwu satuA]].
exists u; split=> //.
move: satuA; rewrite IHA //.
by rewrite -sat_replace_root_self //; apply: RRs.
move=> [u [Rwu satuA]].
exists u; split=> //.
by rewrite IHA // -sat_replace_root_self //; apply: RRs.
- move=> y A IHA M w g xinyA cnotinA.
case: (@eqP _ y x) => [eqyx | neqyx].
have-> : (All y A)`[Var _ x <- Const c] = All y A by rewrite /= eqyx eqxx.
by rewrite -sat_replace_noconstants.
have -> : (All y A)`[Var _ x <- Const c] = All y A`[Var _ x <- Const c].
by move=> /=; case: eqP => [[]|//].
have xinA : x \in fv A by move: xinyA; rewrite /= inE => /andP [].
split.
move=> /= satgyA h yalterngh.
rewrite yalterngh; last by rewrite inE; apply/eqP; apply: nesym.
by rewrite -IHA //; apply: satgyA.
move=> /= satM'gyA h yalterngh.
rewrite IHA // -yalterngh; last by rewrite inE; apply/eqP; apply: nesym.
by apply: satM'gyA.
Qed.
End ReplacedModels.
Section RestrictedModels.
Set Printing Implicit Defensive.
Local Open Scope fset.
Variable sig : signature.
Notation term := (term sig).
Notation formula := (formula sig).
Notation ConstName := (ConstName sig).
Notation PredName := (PredName sig).
Variables MType : choiceType.
Notation rawFrame wt := (rawFrame wt MType).
Notation frame wt := (frame wt MType).
Notation rawModel wt := (rawModel sig wt MType).
Notation model wt := (model sig wt MType).
Definition restrict_world {WType : choiceType} (F : rawFrame WType) (r : F)
: {fset F} :=
r |` [fset w in F | R r w].
Lemma in_r_restrictr {WType : choiceType} (F : rawFrame WType) (r : F) :
r \in restrict_world r.
Proof.
by rewrite /restrict_world 2!in_fsetE eqxx.
Qed.
Lemma in_succ_restrictr {WType : choiceType} (F : frame WType) (r w : F) :
R r w -> w \in restrict_world r.
Proof.
move=> Rrw; rewrite in_fsetE; apply /orP; right.
by apply /imfsetP => /=; exists w.
Qed.
Lemma in_R_restrictr {WType : choiceType} (F : frame WType) (r : F)
(w : restrict_world r) (u : F) :
R (val w) u -> u \in restrict_world r.
Proof.
move=> Rwu; rewrite in_fsetE; apply /orP; right.
apply /imfsetP => /=; exists u => //; rewrite inE.
move: (fsvalP w); rewrite in_fsetE => /orP [|].
by rewrite in_fsetE => /eqP <-.
move=> /imfsetP /= [v]; rewrite inE => + eqwv; rewrite -eqwv => Rrw.
move: (frame_adequate F) => /adequateFP [/transitiveFP transM _].
by rewrite (transM (val w)).
Qed.
Lemma in_restrict_world_R {WType : choiceType} (F : rawFrame WType) (r : F)
(w : restrict_world r) :
r <> val w -> R r (val w).
Proof.
move: (fsvalP w); rewrite /restrict_world in_fsetE => /orP [|].
by rewrite inE => /eqP /= ->.
by move=> /imfsetP /= [w']; rewrite inE => Rrw' ->.
Qed.
Definition restrict_R {WType : choiceType} (F : rawFrame WType) (r : F)
: restrict_world r -> restrict_world r -> bool :=
fun w u => R (val w) (val u).
Definition restrict_domain {WType : choiceType} (F : rawFrame WType) (r : F)
: restrict_world r -> {fset MType} :=
fun w => domain (val w).
Definition restrict_eta {WType : choiceType} (F : rawFrame WType) (r : F)
: forall (w u : restrict_world r), restrict_domain w -> restrict_domain u :=
fun w u => eta (val u).
Definition restrict_rawFrame {WType : choiceType} (F : rawFrame WType) (r : F)
: rawFrame [choiceType of F] :=
@RawFrame _ _ (restrict_world r) (@restrict_R _ _ r) (@restrict_domain _ _ r)
(@restrict_eta _ _ r).
Lemma restrict_frame_adequate {WType : choiceType} (F : frame WType) (r : F) :
adequateF (restrict_rawFrame r).
Proof.
move: (frame_adequate F).
move=> /adequateFP [/transitiveFP transF /transetaFP tretaF /idetaFP idetaF].
apply /adequateFP; split.
- by apply /transitiveFP => u w v Rwu Ruv; apply: (transF (val u)).
- by apply /transetaFP => w u v d Rwu Ruv; apply tretaF.
- by apply /idetaFP => w d; apply idetaF.
Qed.
Definition restrict_frame {WType : choiceType} (F : frame WType) (r : F)
: frame [choiceType of F] :=
Frame (restrict_frame_adequate r).
Definition restrict_I {WType : choiceType} (M : rawModel WType) (r : M)
: forall w : restrict_world r, ConstName -> domain (val w) :=
fun w => I (val w).
Definition restrict_J {WType : choiceType} (M : rawModel WType) (r : M)
: forall (w : restrict_world r) (P : PredName),
{fset (arity P).-tuple (domain (val w))} :=
fun w => J (val w).
Definition restrict_rawModel {WType : choiceType} (M : rawModel WType) (r : M)
: rawModel [choiceType of M] :=
@RawModel _ _ _ (restrict_rawFrame r) (@restrict_I _ _ r) (@restrict_J _ _ r).
Lemma restrict_model_adequate {WType : choiceType} (M : model WType) (r : M) :
adequateM (restrict_rawModel r).
Proof.
move: (model_adequate M) => /adequateMP [adeqF /concordantMP concM].
apply /adequateMP; rewrite restrict_frame_adequate; split=> //.
by apply /concordantMP => w u Rwu c; rewrite -(concM _ (val u)).
Qed.
Definition restrict_model {WType : choiceType} (M : model WType) (r : M)
: model [choiceType of M] :=
Model (restrict_model_adequate r).
Notation "M `| r" := (@restrict_model _ M r).
Lemma sat_restrict {WType : choiceType} (M : model WType) (r : M) (w : M`|r)
(g : assignment w) (A : formula) :
sat (M := M) (w := val w) g A <-> sat (M := M`|r) (w := w) g A.
Proof.
move: w g; elim: A => //=.
- by move=> A IHA B IHB w g; rewrite IHA IHB.
- move=> A IHA w g; split=> [] [u [Rwu satA]].
exists [` (in_R_restrictr Rwu)]; split=> //.
by rewrite -IHA; apply: satA.
by exists (val u); rewrite IHA.
- move=> x A IHA w g; split=> satA h xalterngh.
by rewrite -IHA; apply: satA.
by rewrite IHA; apply: satA.
Qed.
Lemma restrict_replace_adequate {WType : choiceType} (M : model WType) (r : M)
(c : ConstName) (d : domain r) :
adequateM (restrict_rawModel (M := replace_rawModel c d) r).
Proof.
apply /adequateMP; rewrite restrict_frame_adequate; split => //.
apply /concordantMP => /= w u Rwu c'.
rewrite /replace_I; case: eqP => _.
apply/eqP/val_eqP; rewrite /restrict_eta /=.
have [<- | neqrw] := @eqP _ r (fsval w).
by move: (frame_adequate M) => /adequateFP [_ _ /idetaFP ->].
have /adequateFP [_ /transetaFP <- //] := frame_adequate M.
by apply: in_restrict_world_R.
move: (model_adequate M) => /adequateMP [_ /concordantMP concM].
by rewrite (concM _ _ Rwu).
Qed.
Definition restrict_replace {WType : choiceType} (M : model WType) (r : M)
(c : ConstName) (d : domain r) : model [choiceType of M] :=
Model (restrict_replace_adequate c d).
Notation "M `[ r , c <- d ]" := (@restrict_replace _ M r c d).
Lemma sat_replace_adequate {WType : choiceType} (M : model WType) (r : M)
(w : M`|r) (c : ConstName) (d : domain r) (g : assignment w) (A : formula) :
sat (M:=replace_rawModel c d) (w:=val w) g A <-> sat (M:=M`[r, c <- d]) g A.
Proof.
move: M r w c d g; elim: A => //.
- move=> A IHA B IHB M r w c d g /=; split=> [] [satA satB].
by rewrite -IHA -IHB.
by rewrite IHA IHB.
- move=> A IHA M r w c d g /=; split=> [] [u [Rwu satuA]].
have Rru : R (val [` in_r_restrictr r]) u.
move: (frame_adequate M) => /adequateFP [/transitiveFP trans _ _].
case: (@eqP _ r (val w)) => [-> // | neqwu].
by apply: trans Rwu; apply: in_restrict_world_R.
by exists [` in_R_restrictr Rru]; rewrite -IHA.
by exists (val u); rewrite IHA.
- move=> x A IHA M r w c d g /=; split=> sathA h xalterngh.
by rewrite -IHA; apply: sathA.
by rewrite IHA; apply: sathA.
Qed.
Lemma sat_restrict_replace {WType : choiceType} (M : model WType) (w : M)
(c : ConstName) (x : VarName) (g : assignment w) (A : formula) :
c \notin constants A ->
sat (M := M) g A <->
sat (M := M`[w, c <- g x]) (w := [`in_r_restrictr w]) g
A`[Var _ x <- Const c].
Proof.
by move=> cnotinA; rewrite (sat_replace x _ cnotinA) -sat_replace_adequate.
Qed.
Unset Printing Implicit Defensive.
End RestrictedModels.
Notation "M `[ r , c <- d ]" := (@replace_rawModel _ _ _ M r c d).
Section Soundness.
Open Scope qsp_scope.
Variable sig : signature.
Notation formula := (formula sig).
Variables MType : choiceType.
Notation model wt := (model sig wt MType).
Theorem soundness {WType : choiceType} (A B : formula) :
|- A ~> B ->
forall (M : model WType) (w : M) (g : assignment w),
sat g A -> sat g B.
Proof.
move=> pAB; move: WType.
elim: pAB => //=.
- by move=> ? ? ? ? ? ? [].
- by move=> ? ? ? ? ? ? [].
- move=> C D E pCD IHpCD pCE IHpCE WType M w g satC; split.
by apply: IHpCD.
by apply: IHpCE.
- move=> C D E pCD IHpCD pDE IHpDE WType M w g satC.
by apply: IHpDE; apply: IHpCD.
- move=> C D pCD IHpCD WType M w g [u [Rwu satuC]].
by exists u; split=> //; apply: IHpCD.
- move=> C WType M w g [u [Rwu [v [Ruv satwuvC]]]].
exists v.
have Rwv : R w v.
move: (frame_adequate M) => /adequateFP [/transitiveFP transR _ _].
by apply: (transR u).
split=> //.
rewrite (@sat_Xalternfv _ _ _ _ _ _ (g`u)`v fset0) //.
by move=> x _ /=; have /adequateFP [_ /transetaFP <-] := frame_adequate M.
by rewrite fdisjoint0X.
- move=> x C D xnotinC pCD IHpCD WType M w g satgC h xalterngh.
apply: IHpCD.
rewrite -(sat_Xalternfv xalterngh) //.
by apply /fdisjointP => /= y; rewrite in_fsetE => /eqP ->.
- move=> x t C D freeforCxt pCtD IHpCtD WType M w g satgxC.
apply: IHpCtD.
pose h := fun z : VarName => if z == x then g`+ t else g z.
have xalterngh : xaltern g h x.
by move=> z; rewrite in_fsetE /h => /negPf ->.
rewrite -(substitution_formula xalterngh) //.
by apply: satgxC.
by rewrite /h eqxx.
- move=> x t C D freeforCxt freeforDxt pCD IHpCD WType M w g satgCt.
pose h := fun z : VarName => if z == x then g`+ t else g z.
have xalterngh : xaltern g h x.
by move=> z; rewrite in_fsetE /h => /negPf ->.
have eqhxgt : h x = g`+ t by rewrite /h eqxx.
rewrite -(substitution_formula xalterngh) //.
by apply: IHpCD; rewrite (substitution_formula xalterngh eqhxgt).
- move=> x c C D cnotinC cnotinD pCcDc IHpCcDc WType M w g satgC.
rewrite (sat_restrict_replace x _ cnotinD).
by apply: IHpCcDc; rewrite -(sat_restrict_replace x _ cnotinC).
Qed.
End Soundness.
From QRC1 Require Import Language QRC1.
Local Open Scope qsp_scope.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Reserved Notation "g `+" (at level 1, format "g `+").
Reserved Notation "g ` u" (at level 1, format "g ` u").
Reserved Notation "M `| r" (at level 1, format "M `| r").
Reserved Notation "M `[ r , c <- d ]"
(at level 8, format "M `[ r , c <- d ]").
Section KripkeSemantics.
Local Open Scope fset.
Variable sig : signature.
Notation term := (term sig).
Notation formula := (formula sig).
Notation ConstName := (ConstName sig).
Notation PredName := (PredName sig).
Notation Var := (Var sig).
Variables WType MType : choiceType.
(* Note: we only implement finite frames *)
Record rawFrame := RawFrame {
world :> {fset WType};
R : world -> world -> bool;
domain : world -> {fset MType};
eta : forall (w u : world), domain w -> domain u;
(* at the level of rawFrames we require an eta function for every pair w, u *)
}.
Record rawConstFrame := RawConstFrame {
cworld :> {fset WType};
cR : cworld -> cworld -> bool;
cdomain : {fset MType};
}.
(* Any constant domain frame can be seen as a frame *)
Coercion rawFrame_of_rawConstFrame (cF : rawConstFrame) : rawFrame :=
@RawFrame (cworld cF) (@cR cF) (fun w => cdomain cF) (fun w u a => a).
Record rawModel := RawModel {
rawFrame_of_rawModel :> rawFrame;
I : forall w : world rawFrame_of_rawModel, ConstName -> (domain w);
J : forall w : world rawFrame_of_rawModel, forall (P : PredName),
{fset (arity P).-tuple (domain w)}
}.
Definition transitiveF (F : rawFrame) : bool :=
[forall w : F, forall u : F, forall v : F,
(R w u) ==> (R u v) ==> (R w v)
].
Lemma transitiveFP (F : rawFrame) :
reflect (transitive (@R F)) (transitiveF F).
Proof.
by apply: (iffP 'forall_'forall_'forall_implyP) => H ? ? ? ?;
apply/implyP; apply:H.
Qed.
Definition transetaF (F : rawFrame) : bool :=
[forall w : F, forall u : F, forall v : F, forall d : domain w,
(R w u) ==> (R u v) ==>
(eta v d == eta v (eta u d))
].
Lemma transetaFP (F : rawFrame) :
reflect
(forall (w u v : F) (d : domain w),
R w u -> R u v ->
eta v d = eta v (eta u d)
)
(transetaF F).
Proof.
apply: (iffP 'forall_'forall_'forall_'forall_implyP) => /= H ? ? ? ? ?.
by move=> Ruv; apply/eqP; move: Ruv; apply/implyP; apply: H.
by apply/implyP => ?; apply/eqP; apply: H.
Qed.
Definition idetaF (F : rawFrame) : bool :=
[forall w : F, forall d : domain w, eta w d == d].
Lemma idetaFP (F : rawFrame) :
reflect
(forall (w : F) (d : domain w), eta w d = d)
(idetaF F).
Proof. by apply: (iffP 'forall_'forall_eqP). Qed.
Definition concordantM (M : rawModel) : bool :=
[forall w : M, forall u : M, (R w u) ==>
[forall c : ConstName, val (I u c) == val (eta u (I w c))]
].
Lemma concordantMP (M : rawModel) :
reflect
(forall (w u : M), R w u ->
forall c : ConstName, val (I u c) = val (eta u (I w c))
)
(concordantM M).
Proof.
by apply: (iffP 'forall_'forall_implyP)=> H ? ? ?; apply/'forall_eqP; apply:H.
Qed.
Definition adequateF (F : rawFrame) : bool :=
[&& transitiveF F, transetaF F & idetaF F].
Lemma adequateFP (F : rawFrame) :
reflect [/\ transitiveF F, transetaF F & idetaF F] (adequateF F).
Proof. by apply: (iffP and3P). Qed.
Record frame := Frame {
rawFrame_of_frame :> rawFrame;
_ : adequateF rawFrame_of_frame
}.
Canonical frame_subType := [subType for rawFrame_of_frame].
Lemma frame_adequate (F : frame) : adequateF F.
Proof. by case: F. Qed.
Definition adequateM (M : rawModel) : bool :=
(adequateF M) && (concordantM M).
Lemma adequateMP (M : rawModel) :
reflect (adequateF M /\ concordantM M) (adequateM M).
Proof. by apply: (iffP andP). Qed.
Record model := Model {
rawModel_of_model :> rawModel;
_ : adequateM rawModel_of_model
}.
Canonical model_subType := [subType for rawModel_of_model].
Lemma model_adequate (M : model) : adequateM M.
Proof. by case: M. Qed.
Lemma frame_of_model_subproof (M : model) : adequateF M.
Proof.
case: M => F adeqF; rewrite /rawModel_of_model.
by move /adequateMP : adeqF => [].
Qed.
Hint Resolve frame_of_model_subproof : core.
Coercion frame_of_model (M : model) := @Frame M (frame_of_model_subproof M).
(* We define frame_of_model as canonical because the square below commutes *)
(*
model --> rawModel
| |
| o |
v v
frame --> rawFrame
*)
Canonical frame_of_model.
Definition assignment (F : rawFrame) (w : F) : Type := VarName -> domain w.
Definition assignment_of_term (M : rawModel) (w : M) (g : assignment w)
: term -> domain w := fun t =>
match t with
| Language.Var x => g x
| Const c => I w c
end.
Notation "g `+" := (assignment_of_term g).
Definition Xaltern (F : rawFrame) (w : F) (g h : assignment w)
(X : {fset VarName}) : Prop :=
forall x : VarName, x \notin X -> g x = h x.
Definition xaltern (F : rawFrame) (w : F) (g h : assignment w) (x : VarName)
: Prop :=
Xaltern g h [fset x].
Lemma XalternC (F : rawFrame) (w : F) (g h : assignment w)
(X : {fset VarName}) :
Xaltern g h X <-> Xaltern h g X.
Proof.
move: F w g h.
suff : forall g h, Xaltern g h X -> Xaltern h g X.
by move=> Himpl; split; apply: Himpl.
by move=> F w g h; rewrite /Xaltern => alterngh x xnotinX; rewrite alterngh.
Qed.
Lemma XalternU (F : rawFrame) (w : F) (g h : assignment w)
(X Y : {fset VarName}) :
Xaltern g h X -> Xaltern g h (X `|` Y).
Proof.
move=> Xalterngh x.
by rewrite in_fsetE negb_or => /andP [xnotinX _]; apply: Xalterngh.
Qed.
Lemma XalternW (F : rawFrame) (w : F) (g h : assignment w)
(X Y : {fset VarName}) :
X `<=` Y ->
Xaltern g h X -> Xaltern g h Y.
Proof. by move=> /fsetUidPr <- Xalterngh; apply: XalternU. Qed.
Lemma Xaltern_trans (F : rawFrame) (w : F) (g1 g2 g3 : assignment w)
(X : {fset VarName}) :
Xaltern g1 g2 X ->
Xaltern g2 g3 X ->
Xaltern g1 g3 X.
Proof.
move=> Xalterng1g2 Xalterng2g3 x xnotinX.
by rewrite Xalterng1g2 // Xalterng2g3.
Qed.
Lemma xaltern_trans (F : rawFrame) (w : F) (g1 g2 g3 : assignment w)
(x : VarName) :
xaltern g1 g2 x ->
xaltern g2 g3 x ->
xaltern g1 g3 x.
Proof. by apply: Xaltern_trans. Qed.
Lemma Xaltern_assignment_of_term (M : rawModel) (w : M) (g h : assignment w)
(X : {fset VarName}) :
Xaltern g h X -> forall t : term,
match t with
| Language.Var x => x \notin X -> g`+ t = h`+ t
| Const _ => g`+ t = h`+ t
end.
Proof. by move=> Xalterngh; case. Qed.
Notation "g ` u" := (eta u \o g).
Lemma Xaltern_eta (F : rawFrame) (w u : F) (g h : assignment w)
(X : {fset VarName}) :
Xaltern g h X -> Xaltern g`u h`u X.
Proof.
move=> alterngh x xnotinX.
by apply/val_eqP => /=; apply/val_eqP; rewrite alterngh.
Qed.
Definition Xeq (F : rawFrame) (w : F) (g h : assignment w)
(X : {fset VarName}) : Prop :=
forall x : VarName, x \in X -> g x = h x.
Lemma XeqC (F : rawFrame) (w : F) (g h : assignment w) (X : {fset VarName}) :
Xeq g h X <-> Xeq h g X.
Proof.
move: F w g h.
suff : forall g h, Xeq g h X -> Xeq h g X.
by move=> Himpl; split; apply: Himpl.
by move=> F w g h; rewrite /Xeq => eqgh x xinX; rewrite eqgh.
Qed.
Lemma Xeq_trans (F : rawFrame) (w : F) (g1 g2 g3 : assignment w)
(X : {fset VarName}) :
Xeq g1 g2 X ->
Xeq g2 g3 X ->
Xeq g1 g3 X.
Proof.
move=> Xeqg1g2 Xeqg2g3 x xinX.
by rewrite Xeqg1g2 // Xeqg2g3.
Qed.
Lemma XeqW (F : rawFrame) (w : F) (g h : assignment w) (X Y : {fset VarName}) :
X `<=` Y ->
Xeq g h Y -> Xeq g h X.
Proof.
move=> /fsetIidPl <- Yeqgh x xinX; rewrite Yeqgh //.
by move: xinX; rewrite in_fsetE => /andP [].
Qed.
Lemma Xeq_eta (F : rawFrame) (w u : F) (g h : assignment w)
(X : {fset VarName}) :
Xeq g h X -> Xeq g`u h`u X.
Proof.
move=> Xeqgh x xinX.
by apply /val_eqP => /=; apply /val_eqP; rewrite Xeqgh.
Qed.
Fixpoint sat (M : rawModel) (w : M) (g : assignment w) (A : formula) : Prop :=
match A with
| T => True
| Pred P ts => [tuple of map g`+ ts] \in J w P
| B /\ C => sat g B /\ sat g C
| <> B => exists (u : M), (R w u /\ sat g`u B)%type
| All x B => forall h : assignment w, xaltern g h x -> sat h B
end.
Lemma sat_Xeqfv (M : rawModel) (w : M) (g h : assignment w) (X : {fset VarName})
(A : formula) :
Xeq g h (fv A) ->
sat g A <-> sat h A.
Proof.
move: M w g h.
suff: forall g h, Xeq g h (fv A) -> sat g A -> sat h A.
move=> Himpl alterngh; split.
by apply: Himpl.
by apply: Himpl => //; rewrite XeqC.
move=> M; elim: A => //.
- move=> P ts w g h /= Peqgh.
suff -> : [tuple of map g`+ ts] = [tuple of map h`+ ts] by [].
apply: eq_from_tnth => i; rewrite 2!tnth_map.
case eqtnth : (tnth ts i) => [x /= | //].
rewrite Peqgh //; apply /bigfcupP => /=.
exists (Var x) => //=.
by rewrite -eqtnth mem_tnth.
by rewrite fset11.
- move=> A IHA B IHB w g h /= ABeqgh [satgA satgB]; split.
apply: (IHA _ g) => //.
by apply: (XeqW _ ABeqgh); apply: fsubsetUl.
apply: (IHB _ g) => //.
by apply: (XeqW _ ABeqgh); apply: fsubsetUr.
- move=> A IHA w g h /= Aeqgh [u [Rwu satgA]].
exists u; split=> //.
apply: (IHA _ g`u) => //.
by apply: Xeq_eta.
- move=> y A IHA w g h yAeqgh /= satgyA f yalternhf.
pose f' := fun z : VarName => if z == y then f y else g z.
have yalterngf' : xaltern g f' y.
by move=> z; rewrite /f' in_fsetE; case: eqP.
have yAeqf'g : Xeq f' g (fv (All y A)).
move=> x xinfvyA; rewrite /f'; case: eqP => // eqxy.
by exfalso; move: xinfvyA; rewrite eqxy /= !in_fsetE eqxx.
have yAeqhf : Xeq h f (fv (All y A)).
move=> x xinfvyA; rewrite yalternhf //.
by move: xinfvyA; rewrite /= !in_fsetE => /andP [].
have yAeqff' : Xeq f' f (fv (All y A)).
by apply: (Xeq_trans _ yAeqhf); apply: (Xeq_trans yAeqf'g).
move: (satgyA _ yalterngf'); apply: IHA => x xinA.
rewrite /f'; case: eqP => [-> // | /eqP neqxy].
have xinyA : x \in fv (All y A).
by rewrite /= inE xinA in_fsetE neqxy.
by rewrite -yAeqff' // yAeqf'g.
Qed.
Lemma sat_Xalternfv (M : rawModel) (w : M) (g h : assignment w)
(X : {fset VarName}) (A : formula) :
Xaltern g h X ->
fdisjoint X (fv A) ->
sat g A <-> sat h A.
Proof.
move=> Xalterngh /fdisjointP_sym disjXA; apply: (sat_Xeqfv X).
move=> x xinA; rewrite Xalterngh //.
by apply: disjXA.
Qed.
Lemma substitution_formula (M : model) (w : M) (g g' : assignment w)
(x : VarName) (t : term) (A : formula) :
xaltern g g' x ->
g' x = g`+ t ->
freefor A x t ->
sat g' A <-> sat g A`[Var x <- t].
Proof.
have [| xnotinA] := boolP (x \in fv A); last first.
move=> xalterngg' _ _.
rewrite sub_notfree // (sat_Xalternfv xalterngg') //.
by apply /fdisjointP => /= y; rewrite in_fsetE => /eqP ->.
move: w g g'; elim: A => //.
- move=> P ts w g g' /= xinP xalterngg' eqg'xgt _.
set mapg := [tuple of map g`+ _].
suff -> : [tuple of map g'`+ ts] = mapg by [].
apply: eq_from_tnth => i; rewrite 3!tnth_map.
case: eqP => [-> // |].
case: (tnth ts i) => //= y neqyx.
rewrite xalterngg' // in_fsetE.
by apply /eqP => eqyx; move: neqyx; rewrite eqyx.
- move=> A IHA B IHB w g g' /=.
rewrite in_fsetE => /orP [xinA | xinB] xalterngg' eqg'xgt.
move=> /andP [freeforA freeforB].
rewrite (IHA _ g) //.
have [xinB | xnotinB] := boolP (x \in fv B).
by rewrite (IHB _ g).
rewrite (sub_notfree _ xnotinB).
rewrite (@sat_Xalternfv _ _ _ _ _ B xalterngg') //.
by apply /fdisjointP => /= y; rewrite in_fsetE => /eqP ->.
move=> /andP [freeforA freeforB].
rewrite (IHB _ g) //.
have [xinA | xnotinA] := boolP (x \in fv A).
by rewrite (IHA _ g).
rewrite (sub_notfree _ xnotinA).
rewrite (@sat_Xalternfv _ _ _ _ _ A xalterngg') //.
by apply /fdisjointP => /= y; rewrite in_fsetE => /eqP ->.
- move=> A IHA w g g' /= xinA xalterngg' eqg'xgt freeforAxt.
have xalterngRg'R : forall u, xaltern g`u g'`u x.
by move=> u; apply: Xaltern_eta.
have eqg'RxgRt : forall u, R w u -> g'`u x = (g`u)`+ t.
move=> u Rwu; apply /val_eqP => /=; rewrite eqg'xgt.
case: {+}t => //= c.
move: (model_adequate M) => /adequateMP [_ /concordantMP].
by move=> /(_ _) /(_ _) /(_ Rwu) ->.
split; move=> [u [Rwu satuA]]; exists u; split=> //.
by rewrite -(IHA _ _ g'`u) // eqg'RxgRt.
by rewrite (IHA _ g`u) // eqg'RxgRt.
- move=> y A IHA w g g' xinyA xalterngg' eqg'xgt freeforyAxt.
have neqyx : y == x = false.
by apply /eqP => eqxy; move: xinyA => /=; rewrite eqxy 2!inE eqxx.
have neqVaryx : Var y == Var x = false.
by apply/eqP => -[eqyx]; move: neqyx; rewrite eqyx eqxx.
have xinA : x \in fv A.
by move: xinyA => /=; rewrite !in_fsetE => /andP [].
have freeforAxt : freefor A x t.
by move: freeforyAxt => /= /orP [| /andP [] //]; rewrite neqyx.
split.
move=> satg'yA /=; rewrite neqVaryx => /= h yalterngh.
pose h' := fun z : VarName => if z == x then h`+ t else h z.
have xalternhh' : xaltern h h' x.
by move=> z; rewrite in_fsetE /h' => /negPf ->.
rewrite -(IHA _ _ h') //; last by rewrite /h' eqxx.
apply: satg'yA.
have xyalternhh' : Xaltern h h' [fset x; y].
by apply: (XalternW _ xalternhh'); rewrite fsub1set 2!inE eqxx.
have xyalterngh : Xaltern g h [fset x; y].
by apply: (XalternW _ yalterngh); rewrite fsub1set 3!inE eqxx orbT.
have xyalterng'g : Xaltern g' g [fset x; y].
rewrite XalternC.
by apply: (XalternW _ xalterngg'); rewrite fsub1set 2!inE eqxx.
have xyalterng'h' : Xaltern g' h' [fset x; y].
by apply: (Xaltern_trans xyalterng'g); apply: (Xaltern_trans xyalterngh).
move=> z; rewrite in_fsetE => /negPf neqzy.
case: (@eqP _ z x) => [-> | /eqP /negPf neqzx]; last first.
by rewrite xyalterng'h' // !in_fsetE neqzy neqzx.
rewrite /h' eqxx eqg'xgt.
have : t != Var y.
apply /eqP => eqty; move: freeforyAxt.
by rewrite /= neqyx freeforAxt xinA eqty in_fsetE eqxx.
case: {+}t => //= z' neqz'y.
rewrite yalterngh // in_fsetE.
by apply /eqP => eqz'y; move: neqz'y; rewrite eqz'y eqxx.
rewrite /= neqVaryx => /= satgyAt h' yalterng'h'.
pose h := fun z : VarName => if z == x then g x else h' z.
have xalternhh' : xaltern h h' x.
by move=> z; rewrite in_fsetE /h => /negPf ->.
have yalterngh : xaltern g h y.
have xyalternh'h : Xaltern h' h [fset x; y].
rewrite XalternC.
by apply: (XalternW _ xalternhh'); rewrite fsub1set 2!inE eqxx.
have xyalterngg' : Xaltern g g' [fset x; y].
by apply: (XalternW _ xalterngg'); rewrite fsub1set 2!inE eqxx.
have xyalterng'h' : Xaltern g' h' [fset x; y].
apply: (XalternW _ yalterng'h').
by rewrite fsub1set 3!inE eqxx orbT.
have xyalterngh : Xaltern g h [fset x; y].
apply: (Xaltern_trans xyalterngg').
by apply: (Xaltern_trans xyalterng'h').
move=> z; rewrite in_fsetE => /negPf neqzy.
case: (@eqP _ z x) => [-> | /eqP /negPf neqzx]; first by rewrite /h eqxx.
by rewrite xyalterngh // !in_fsetE neqzy neqzx.
rewrite (IHA _ h) //; first by apply: satgyAt.
rewrite -yalterng'h'; last by rewrite in_fsetE eq_sym neqyx.
rewrite eqg'xgt.
have : t <> Var y.
move=> eqty; move: freeforyAxt.
by rewrite /= freeforAxt xinA eqty neqyx in_fsetE eqxx.
case: {+}t => //= z neqzy.
rewrite yalterngh // in_fsetE.
by apply /eqP => eqzy; apply: neqzy; rewrite eqzy.
Qed.
Lemma sat_noconstants (F : rawFrame) Ic Ic' J :
let rM := @RawModel F Ic J in
let rM' := @RawModel F Ic' J in
forall (adeqM : adequateM rM) (adeqM' : adequateM rM') (w : F)
(g : assignment w) (A : formula),
(forall c, c \in constants A -> Ic w c = Ic' w c) ->
sat (M := Model adeqM) g A <-> sat (M := Model adeqM') g A.
Proof.
move=> rM rM' adeqM adeqM' w g A; move: w g; elim: A => //=.
- move=> P ts w g constantfree.
set tup := [tuple of _].
set tup' := [tuple of _].
suff -> : tup = tup' by [].
apply: eq_from_tnth => i; rewrite 2!tnth_map.
case eqtnth : (tnth ts i) => [// | c /=].
apply: constantfree; apply /bigfcupP => /=; exists (Const c).
by rewrite -eqtnth mem_tnth.
by rewrite /= in_fsetE eqxx.
- move=> A IHA B IHB w g constantfreeAB.
rewrite IHA ?IHB //.
move=> c cinB; apply: constantfreeAB.
by rewrite in_fsetU cinB orbT.
move=> c cinA; apply: constantfreeAB.
by rewrite in_fsetU cinA.
- move=> A IHA w g constantfree.
split.
move=> [u [Rwu satgA]]; exists u; split=> //.
rewrite -IHA // => c cinA.
have := adeqM => /adequateMP [_ /concordantMP /(_ _) /(_ _) /(_ Rwu)].
move=> /(_ c) /= eqIwcIuc; apply /val_eqP => /=; rewrite eqIwcIuc.
have := adeqM' => /adequateMP [_ /concordantMP /(_ _) /(_ _) /(_ Rwu)].
move=> /(_ c) /= eqI'wcI'uc; rewrite eqI'wcI'uc.
by rewrite constantfree.
move=> [u [Rwu satgA]]; exists u; split=> //.
rewrite IHA // => c cinA.
have := adeqM => /adequateMP [_ /concordantMP /(_ _) /(_ _) /(_ Rwu)].
move=> /(_ c) /= eqIwcIuc; apply /val_eqP => /=; rewrite eqIwcIuc.
have := adeqM' => /adequateMP [_ /concordantMP /(_ _) /(_ _) /(_ Rwu)].
move=> /(_ c) /= eqI'wcI'uc; rewrite eqI'wcI'uc.
by rewrite constantfree.
- move=> x A IHA w g constantfree; split.
by move=> satgxA h xaltengh; rewrite -IHA //; apply: satgxA.
by move=> satgxA h xaltengh; rewrite IHA //; apply: satgxA.
Qed.
End KripkeSemantics.
Notation "g `+" := (assignment_of_term g).
Notation "g ` u" := (eta u \o g).
Section ReplacedModels.
Variable sig : signature.
Notation term := (term sig).
Notation formula := (formula sig).
Notation ConstName := (ConstName sig).
Notation PredName := (PredName sig).
Variables WType MType : choiceType.
Notation rawFrame := (rawFrame WType MType).
Notation frame := (frame WType MType).
Notation rawModel := (rawModel sig WType MType).
Notation model := (model sig WType MType).
Definition Rs (F : rawFrame) : F -> F -> bool :=
fun w u => (w == u) || R w u.
Lemma RsP (F : rawFrame) (w u : F) :
reflect (w = u \/ R w u) (Rs w u).
Proof.
by apply: (iffP orP) => [[/eqP |] | [/eqP |]]; [left | right | left | right].
Qed.
Lemma Rsww (F : rawFrame) (w : F) : Rs w w.
Proof. by apply/RsP; left. Qed.
Lemma RRs (F : rawFrame) (w u : F) : R w u -> Rs w u.
Proof. by rewrite /Rs => ->; rewrite orbT. Qed.
Local Hint Resolve Rsww RRs : core.
Lemma RsR_trans (F : frame) (r w u : F) : Rs r w -> R w u -> Rs r u.
Proof.
move=> /RsP [-> | Rrw Rwu]; first by apply: RRs.
apply/RsP; right.
move: (frame_adequate F) => /adequateFP [/transitiveFP transF _ _].
by apply: transF Rwu.
Qed.
Definition transitiveFr (F : rawFrame) (r : F) : bool :=
[forall w : F, forall u : F, forall v : F,
[&& Rs r w, R w u & R u v] ==> R w v
].
Lemma transitiveFrP (F : rawFrame) (r : F) :
reflect
(forall (w u v : F),
Rs r w -> R w u -> R u v ->
R w v
)
(transitiveFr r).
Proof.
apply: (iffP 'forall_'forall_'forall_implyP) => /=.
by move=> H w u v Rsw Rwu Ruv; apply: (H w u v); apply /and3P.
by move=> H w u v /and3P []; apply: H.
Qed.
Definition transetaFr (F : rawFrame) (r : F) : bool :=
[forall w : F, forall u : F, forall v : F, forall d : domain w,
[&& Rs r w, R w u & R u v] ==>
(eta v d == eta v (eta u d))
].
Lemma transetaFrP (F : rawFrame) (r : F) :
reflect
(forall (w u v : F) (d : domain w),
Rs r w -> R w u -> R u v ->
eta v d = eta v (eta u d)
)
(transetaFr r).
Proof.
apply: (iffP 'forall_'forall_'forall_'forall_implyP) => /=.
by move=> H w u v d Rsw Rwu Ruv; apply/eqP; apply: H; apply/and3P.
by move=> H w u v d /and3P [? ? ?]; apply/eqP; apply: H.
Qed.
Definition idetaFr (F : rawFrame) (r : F) : bool :=
[forall w : F, forall d : domain w, (Rs r w) ==> (eta w d == d)].
Lemma idetaFrP (F : rawFrame) (r : F) :
reflect
(forall (w : F) (d : domain w), Rs r w -> eta w d = d)
(idetaFr r).
Proof.
by apply: (iffP 'forall_'forall_implyP) => /= H w d Rsw; apply/eqP; apply: H.
Qed.
Definition adequateFr (F : rawFrame) (r : F) : bool :=
[&& transitiveFr r, transetaFr r & idetaFr r].
Lemma adequateFrP (F : rawFrame) (r : F) :
reflect
([/\ transitiveFr r, transetaFr r & idetaFr r])
(adequateFr r).
Proof. by apply: (iffP and3P). Qed.
Lemma frame_adequateFr (F : frame) (r : F) : adequateFr r.
Proof.
move: (frame_adequate F) => /adequateFP [/transitiveFP transF
/transetaFP tretaF
/idetaFP idF].
apply/adequateFrP; split.
- by apply/transitiveFrP => w u v _; apply: transF.
- by apply/transetaFrP => w u v d _; apply: tretaF.
- by apply/idetaFrP => w d _; apply: idF.
Qed.
Definition concordantMr (M : rawModel) (r : M) : bool :=
[forall w : M, forall u : M, forall c : ConstName,
(Rs r w && R w u) ==>
(val (I u c) == val (eta u (I w c)))
].
Lemma concordantMrP (M : rawModel) (r : M) :
reflect
(forall (w u : M) (c : ConstName),
Rs r w -> R w u ->
val (I u c) = val (eta u (I w c))
)
(concordantMr r).
Proof.
apply: (iffP 'forall_'forall_'forall_implyP) => /=.
by move=> H w u c Rsw Rwu; apply/eqP; apply: H; apply/andP.
by move=> H w u c /andP [? ?]; apply/eqP; apply: H.
Qed.
Definition adequateMr (M : rawModel) (r : M) : bool :=
(adequateFr r) && (concordantMr r).
Lemma adequateMrP (M : rawModel) (r : M) :
reflect (adequateFr r /\ concordantMr r) (adequateMr r).
Proof. by apply: (iffP andP). Qed.
Lemma model_adequateMr (M : model) (r : M) : adequateMr r.
Proof.
move: (model_adequate M) => /adequateMP [adeqF /concordantMP concM].
apply/adequateMrP; split; first by apply: frame_adequateFr.
by apply/concordantMrP => w u c _ Rwu; apply: concM.
Qed.
(* This will not lead to an adequate model unless Rs r w *)
Definition replace_I (M : rawModel) (r : M) (c : ConstName) (d : domain r)
: forall w : M, ConstName -> domain w :=
fun w c' =>
if c' == c then
eta w d
else
I w c'.
Definition replace_rawModel (M : rawModel) (r : M) (c : ConstName)
(d : domain r) : rawModel :=
RawModel (replace_I c d) (@J _ _ _ _).
Notation "M `[ r , c <- d ]" := (@replace_rawModel M r c d).
Set Printing Implicit Defensive.
Lemma replace_adequateMr (M : model) (r : M) (c : ConstName) (d : domain r) :
adequateMr (M := replace_rawModel c d) r.
Proof.
apply/adequateMrP; split; first by apply: frame_adequateFr.
apply/concordantMrP => /= w u c' Rsrw Rwu.
rewrite /replace_I; case: eqP => _.
apply/eqP/val_eqP.
move: Rsrw => /RsP [<- | Rrw].
by move: (frame_adequate M) => /adequateFP [_ _ /idetaFP ->].
by have /adequateFP [_ /transetaFP <- //] := frame_adequate M.
move: (model_adequate M) => /adequateMP [_ /concordantMP concM].
by rewrite (concM _ _ Rwu).
Qed.
Lemma sat_replace_noconstants (M : model) (r w : M) (c : ConstName)
(d : domain r) (g : assignment w) (A : formula) :
Rs r w ->
c \notin constants A ->
sat (M := M) g A <-> sat (M := M`[r, c <- d]) g A.
Proof.
move: w g; elim: A => //=.
- move=> P ts w g Rsrw /negP cnotints.
set tup := [tuple of _]; set tup' := [tuple of _].
suff <- : tup = tup' by [].
apply: eq_from_tnth => i; rewrite !tnth_map.
case isith : (tnth ts i) => [// | c' /=].
rewrite /replace_I; case: eqP => [eqc'c | //].
exfalso; apply: cnotints; rewrite -eqc'c.
apply /bigfcupP; exists (Const c').
by rewrite -isith mem_tnth.
by rewrite in_fsetE.
- move=> A IHA B IHB w g Rsrw.
rewrite in_fsetE => /norP [cnotinA cnotinB].
by rewrite IHA // IHB.
- move=> A IHA w g Rsrw cnotinA; split.
move=> [u [Rwu satMuA]].
by exists u; rewrite -IHA //; apply: RsR_trans Rwu.
move=> [u [Rwu satMruA]].
by exists u; rewrite IHA //; apply: RsR_trans Rwu.
- move=> x A IHA w g Rsrw cnotinA; split.
move=> satMxA h xalterngh.
by rewrite -IHA //; apply: satMxA.
move=> satMrxA h xalterngh.
by rewrite IHA //; apply: satMrxA.
Qed.
Lemma sat_replace_root (M : model) (r w u : M) (c : ConstName) (d : domain r)
(g : assignment u) (A : formula) :
Rs r w -> Rs w u ->
sat (M := M`[r, c <- d]) g A <-> sat (M := M`[w, c <- eta w d]) g A.
Proof.
move: M r w u c d g; elim: A => //.
- move=> P ts M r w u c d g Rsrw Rswu /=.
set tup := [tuple of _]; set tup' := [tuple of _].
suff -> : tup = tup' by [].
apply: eq_from_tnth => i; rewrite !tnth_map.
case isith : (tnth ts i) => [// | c' /=].
rewrite /replace_I; case: eqP => [eqc'c | //].
move: (frame_adequate M) => /adequateFP [_ /transetaFP treta /idetaFP ide].
move: Rsrw => /RsP [<- | Rrw]; first by rewrite ide.
move: Rswu => /RsP [<- | Rwu]; first by rewrite ide.
by rewrite (treta _ _ _ _ Rrw Rwu).
- move=> A IHA B IHB M r w u c d g Rsrw Rswu /=.
by rewrite (IHA _ _ w) // (IHB _ _ w).
- move=> A /= IHA M r w u c d g Rsrw Rswu; split=> [] [v [Ruv satvA]].
exists v; split => //.
by rewrite -IHA //; apply: RsR_trans Ruv.
exists v; split=> //.
by move: satvA; rewrite -IHA //; apply: RsR_trans Ruv.
- move=> x A IHA M r w u c d g Rsrw Rswu; split=> /= satA h xalterngh.
by rewrite -IHA //; apply: satA.
by rewrite (IHA _ _ w) //; apply: satA.
Qed.
Lemma sat_replace_root_self (M : model) (r w : M) (c : ConstName) (d : domain r)
(g : assignment w) (A : formula) :
Rs r w ->
sat (M := M`[r, c <- d]) g A <-> sat (M := M`[w, c <- eta w d]) g A.
Proof.
by move=> Rsrw; rewrite (sat_replace_root _ _ _ _ Rsrw) ?Rsww.
Qed.
Lemma sat_replace (M : model) (w : M) (c : ConstName) (x : VarName)
(g : assignment w) (A : formula) :
c \notin constants A ->
sat (M := M) g A <-> sat (M := M`[w, c <- g x]) g A`[Var _ x <- Const c].
Proof.
have [|] := boolP (x \in fv A); last first.
move=> xnotinA cnotinA.
by rewrite sub_notfree // -sat_replace_noconstants // Rsww.
move: M w g; elim: A => //.
- move=> P t M w g xinP /negP cnotinC /=.
set tup := [tuple of _]; set tup' := [tuple of _].
suff -> : tup = tup' by [].
apply: eq_from_tnth => i.
rewrite !tnth_map; case: eqP => [-> /= | _].
rewrite /replace_I eqxx.
by move: (frame_adequate M) => /adequateFP [_ _ /idetaFP ->].
case istnthi : (tnth t i) => [// | c' /=].
rewrite /replace_I; case: eqP => [eqc'c | //].
exfalso; apply: cnotinC; rewrite -eqc'c /=.
apply /bigfcupP => /=; exists (Const c') => //=.
by rewrite -istnthi mem_tnth.
by rewrite in_fsetE.
- move=> A IHA B IHB M w g /= xinAB.
rewrite in_fsetE => /norP [cnotinA cnotinB].
move: xinAB; rewrite in_fsetE => /orP [xinA | xinB].
have [xinB | xnotinB] := boolP (x \in fv B).
by rewrite IHA // IHB.
rewrite IHA // (sub_notfree _ xnotinB).
by rewrite -(sat_replace_noconstants _ _ _ cnotinB) // Rsww.
have [xinA | xnotinA] := boolP (x \in fv A).
by rewrite IHA // IHB.
rewrite IHB // (sub_notfree _ xnotinA).
by rewrite -(sat_replace_noconstants _ _ _ cnotinA) // Rsww.
- move=> A IHA M w g /= xinA cnotinA; split.
move=> [u [Rwu satuA]].
exists u; split=> //.
move: satuA; rewrite IHA //.
by rewrite -sat_replace_root_self //; apply: RRs.
move=> [u [Rwu satuA]].
exists u; split=> //.
by rewrite IHA // -sat_replace_root_self //; apply: RRs.
- move=> y A IHA M w g xinyA cnotinA.
case: (@eqP _ y x) => [eqyx | neqyx].
have-> : (All y A)`[Var _ x <- Const c] = All y A by rewrite /= eqyx eqxx.
by rewrite -sat_replace_noconstants.
have -> : (All y A)`[Var _ x <- Const c] = All y A`[Var _ x <- Const c].
by move=> /=; case: eqP => [[]|//].
have xinA : x \in fv A by move: xinyA; rewrite /= inE => /andP [].
split.
move=> /= satgyA h yalterngh.
rewrite yalterngh; last by rewrite inE; apply/eqP; apply: nesym.
by rewrite -IHA //; apply: satgyA.
move=> /= satM'gyA h yalterngh.
rewrite IHA // -yalterngh; last by rewrite inE; apply/eqP; apply: nesym.
by apply: satM'gyA.
Qed.
End ReplacedModels.
Section RestrictedModels.
Set Printing Implicit Defensive.
Local Open Scope fset.
Variable sig : signature.
Notation term := (term sig).
Notation formula := (formula sig).
Notation ConstName := (ConstName sig).
Notation PredName := (PredName sig).
Variables MType : choiceType.
Notation rawFrame wt := (rawFrame wt MType).
Notation frame wt := (frame wt MType).
Notation rawModel wt := (rawModel sig wt MType).
Notation model wt := (model sig wt MType).
Definition restrict_world {WType : choiceType} (F : rawFrame WType) (r : F)
: {fset F} :=
r |` [fset w in F | R r w].
Lemma in_r_restrictr {WType : choiceType} (F : rawFrame WType) (r : F) :
r \in restrict_world r.
Proof.
by rewrite /restrict_world 2!in_fsetE eqxx.
Qed.
Lemma in_succ_restrictr {WType : choiceType} (F : frame WType) (r w : F) :
R r w -> w \in restrict_world r.
Proof.
move=> Rrw; rewrite in_fsetE; apply /orP; right.
by apply /imfsetP => /=; exists w.
Qed.
Lemma in_R_restrictr {WType : choiceType} (F : frame WType) (r : F)
(w : restrict_world r) (u : F) :
R (val w) u -> u \in restrict_world r.
Proof.
move=> Rwu; rewrite in_fsetE; apply /orP; right.
apply /imfsetP => /=; exists u => //; rewrite inE.
move: (fsvalP w); rewrite in_fsetE => /orP [|].
by rewrite in_fsetE => /eqP <-.
move=> /imfsetP /= [v]; rewrite inE => + eqwv; rewrite -eqwv => Rrw.
move: (frame_adequate F) => /adequateFP [/transitiveFP transM _].
by rewrite (transM (val w)).
Qed.
Lemma in_restrict_world_R {WType : choiceType} (F : rawFrame WType) (r : F)
(w : restrict_world r) :
r <> val w -> R r (val w).
Proof.
move: (fsvalP w); rewrite /restrict_world in_fsetE => /orP [|].
by rewrite inE => /eqP /= ->.
by move=> /imfsetP /= [w']; rewrite inE => Rrw' ->.
Qed.
Definition restrict_R {WType : choiceType} (F : rawFrame WType) (r : F)
: restrict_world r -> restrict_world r -> bool :=
fun w u => R (val w) (val u).
Definition restrict_domain {WType : choiceType} (F : rawFrame WType) (r : F)
: restrict_world r -> {fset MType} :=
fun w => domain (val w).
Definition restrict_eta {WType : choiceType} (F : rawFrame WType) (r : F)
: forall (w u : restrict_world r), restrict_domain w -> restrict_domain u :=
fun w u => eta (val u).
Definition restrict_rawFrame {WType : choiceType} (F : rawFrame WType) (r : F)
: rawFrame [choiceType of F] :=
@RawFrame _ _ (restrict_world r) (@restrict_R _ _ r) (@restrict_domain _ _ r)
(@restrict_eta _ _ r).
Lemma restrict_frame_adequate {WType : choiceType} (F : frame WType) (r : F) :
adequateF (restrict_rawFrame r).
Proof.
move: (frame_adequate F).
move=> /adequateFP [/transitiveFP transF /transetaFP tretaF /idetaFP idetaF].
apply /adequateFP; split.
- by apply /transitiveFP => u w v Rwu Ruv; apply: (transF (val u)).
- by apply /transetaFP => w u v d Rwu Ruv; apply tretaF.
- by apply /idetaFP => w d; apply idetaF.
Qed.
Definition restrict_frame {WType : choiceType} (F : frame WType) (r : F)
: frame [choiceType of F] :=
Frame (restrict_frame_adequate r).
Definition restrict_I {WType : choiceType} (M : rawModel WType) (r : M)
: forall w : restrict_world r, ConstName -> domain (val w) :=
fun w => I (val w).
Definition restrict_J {WType : choiceType} (M : rawModel WType) (r : M)
: forall (w : restrict_world r) (P : PredName),
{fset (arity P).-tuple (domain (val w))} :=
fun w => J (val w).
Definition restrict_rawModel {WType : choiceType} (M : rawModel WType) (r : M)
: rawModel [choiceType of M] :=
@RawModel _ _ _ (restrict_rawFrame r) (@restrict_I _ _ r) (@restrict_J _ _ r).
Lemma restrict_model_adequate {WType : choiceType} (M : model WType) (r : M) :
adequateM (restrict_rawModel r).
Proof.
move: (model_adequate M) => /adequateMP [adeqF /concordantMP concM].
apply /adequateMP; rewrite restrict_frame_adequate; split=> //.
by apply /concordantMP => w u Rwu c; rewrite -(concM _ (val u)).
Qed.
Definition restrict_model {WType : choiceType} (M : model WType) (r : M)
: model [choiceType of M] :=
Model (restrict_model_adequate r).
Notation "M `| r" := (@restrict_model _ M r).
Lemma sat_restrict {WType : choiceType} (M : model WType) (r : M) (w : M`|r)
(g : assignment w) (A : formula) :
sat (M := M) (w := val w) g A <-> sat (M := M`|r) (w := w) g A.
Proof.
move: w g; elim: A => //=.
- by move=> A IHA B IHB w g; rewrite IHA IHB.
- move=> A IHA w g; split=> [] [u [Rwu satA]].
exists [` (in_R_restrictr Rwu)]; split=> //.
by rewrite -IHA; apply: satA.
by exists (val u); rewrite IHA.
- move=> x A IHA w g; split=> satA h xalterngh.
by rewrite -IHA; apply: satA.
by rewrite IHA; apply: satA.
Qed.
Lemma restrict_replace_adequate {WType : choiceType} (M : model WType) (r : M)
(c : ConstName) (d : domain r) :
adequateM (restrict_rawModel (M := replace_rawModel c d) r).
Proof.
apply /adequateMP; rewrite restrict_frame_adequate; split => //.
apply /concordantMP => /= w u Rwu c'.
rewrite /replace_I; case: eqP => _.
apply/eqP/val_eqP; rewrite /restrict_eta /=.
have [<- | neqrw] := @eqP _ r (fsval w).
by move: (frame_adequate M) => /adequateFP [_ _ /idetaFP ->].
have /adequateFP [_ /transetaFP <- //] := frame_adequate M.
by apply: in_restrict_world_R.
move: (model_adequate M) => /adequateMP [_ /concordantMP concM].
by rewrite (concM _ _ Rwu).
Qed.
Definition restrict_replace {WType : choiceType} (M : model WType) (r : M)
(c : ConstName) (d : domain r) : model [choiceType of M] :=
Model (restrict_replace_adequate c d).
Notation "M `[ r , c <- d ]" := (@restrict_replace _ M r c d).
Lemma sat_replace_adequate {WType : choiceType} (M : model WType) (r : M)
(w : M`|r) (c : ConstName) (d : domain r) (g : assignment w) (A : formula) :
sat (M:=replace_rawModel c d) (w:=val w) g A <-> sat (M:=M`[r, c <- d]) g A.
Proof.
move: M r w c d g; elim: A => //.
- move=> A IHA B IHB M r w c d g /=; split=> [] [satA satB].
by rewrite -IHA -IHB.
by rewrite IHA IHB.
- move=> A IHA M r w c d g /=; split=> [] [u [Rwu satuA]].
have Rru : R (val [` in_r_restrictr r]) u.
move: (frame_adequate M) => /adequateFP [/transitiveFP trans _ _].
case: (@eqP _ r (val w)) => [-> // | neqwu].
by apply: trans Rwu; apply: in_restrict_world_R.
by exists [` in_R_restrictr Rru]; rewrite -IHA.
by exists (val u); rewrite IHA.
- move=> x A IHA M r w c d g /=; split=> sathA h xalterngh.
by rewrite -IHA; apply: sathA.
by rewrite IHA; apply: sathA.
Qed.
Lemma sat_restrict_replace {WType : choiceType} (M : model WType) (w : M)
(c : ConstName) (x : VarName) (g : assignment w) (A : formula) :
c \notin constants A ->
sat (M := M) g A <->
sat (M := M`[w, c <- g x]) (w := [`in_r_restrictr w]) g
A`[Var _ x <- Const c].
Proof.
by move=> cnotinA; rewrite (sat_replace x _ cnotinA) -sat_replace_adequate.
Qed.
Unset Printing Implicit Defensive.
End RestrictedModels.
Notation "M `[ r , c <- d ]" := (@replace_rawModel _ _ _ M r c d).
Section Soundness.
Open Scope qsp_scope.
Variable sig : signature.
Notation formula := (formula sig).
Variables MType : choiceType.
Notation model wt := (model sig wt MType).
Theorem soundness {WType : choiceType} (A B : formula) :
|- A ~> B ->
forall (M : model WType) (w : M) (g : assignment w),
sat g A -> sat g B.
Proof.
move=> pAB; move: WType.
elim: pAB => //=.
- by move=> ? ? ? ? ? ? [].
- by move=> ? ? ? ? ? ? [].
- move=> C D E pCD IHpCD pCE IHpCE WType M w g satC; split.
by apply: IHpCD.
by apply: IHpCE.
- move=> C D E pCD IHpCD pDE IHpDE WType M w g satC.
by apply: IHpDE; apply: IHpCD.
- move=> C D pCD IHpCD WType M w g [u [Rwu satuC]].
by exists u; split=> //; apply: IHpCD.
- move=> C WType M w g [u [Rwu [v [Ruv satwuvC]]]].
exists v.
have Rwv : R w v.
move: (frame_adequate M) => /adequateFP [/transitiveFP transR _ _].
by apply: (transR u).
split=> //.
rewrite (@sat_Xalternfv _ _ _ _ _ _ (g`u)`v fset0) //.
by move=> x _ /=; have /adequateFP [_ /transetaFP <-] := frame_adequate M.
by rewrite fdisjoint0X.
- move=> x C D xnotinC pCD IHpCD WType M w g satgC h xalterngh.
apply: IHpCD.
rewrite -(sat_Xalternfv xalterngh) //.
by apply /fdisjointP => /= y; rewrite in_fsetE => /eqP ->.
- move=> x t C D freeforCxt pCtD IHpCtD WType M w g satgxC.
apply: IHpCtD.
pose h := fun z : VarName => if z == x then g`+ t else g z.
have xalterngh : xaltern g h x.
by move=> z; rewrite in_fsetE /h => /negPf ->.
rewrite -(substitution_formula xalterngh) //.
by apply: satgxC.
by rewrite /h eqxx.
- move=> x t C D freeforCxt freeforDxt pCD IHpCD WType M w g satgCt.
pose h := fun z : VarName => if z == x then g`+ t else g z.
have xalterngh : xaltern g h x.
by move=> z; rewrite in_fsetE /h => /negPf ->.
have eqhxgt : h x = g`+ t by rewrite /h eqxx.
rewrite -(substitution_formula xalterngh) //.
by apply: IHpCD; rewrite (substitution_formula xalterngh eqhxgt).
- move=> x c C D cnotinC cnotinD pCcDc IHpCcDc WType M w g satgC.
rewrite (sat_restrict_replace x _ cnotinD).
by apply: IHpCcDc; rewrite -(sat_restrict_replace x _ cnotinC).
Qed.
End Soundness.