QRC1.QRC1
From mathcomp Require Import all_ssreflect finmap.
From QRC1 Require Import Preamble Language.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Section 2: Quantified Reflection Calculus with one modality *)
Section Formulas.
Local Open Scope qsp_scope.
Variable sig : signature.
Notation term := (term sig).
Notation formula := (formula sig).
Notation Var := (Var sig).
Notation ConstName := (ConstName sig).
(* Definition 2.1 *)
(* Note: this is the updated definition without Diam_All *)
Reserved Notation "|- A ~> B" (at level 85, format "|- A ~> B").
Inductive QRC1Proof : formula -> formula -> Prop :=
| Top : forall A, |- A ~> T _
| Same : forall A, |- A ~> A
| ConjEl : forall A B, |- A /\ B ~> A
| ConjEr : forall A B, |- A /\ B ~> B
| ConjI : forall A B C, |- A ~> B -> |- A ~> C -> |- A ~> B /\ C
| Cut : forall A B C, |- A ~> B -> |- B ~> C -> |- A ~> C
| Nec : forall A B, |- A ~> B -> |- <> A ~> <> B
| Trans : forall A, |- <> <> A ~> <> A
| AllIr : forall x A B, x \notin fv A ->
|- A ~> B -> |- A ~> All x B
| AllIl : forall x t A B, freefor A x t ->
|- A`[Var x <- t] ~> B -> |- All x A ~> B
| TermI : forall x t A B, freefor A x t -> freefor B x t ->
|- A ~> B -> |- A`[Var x <- t] ~> B`[Var x <- t]
| ConstE : forall x c A B, c \notin constants A -> c \notin constants B ->
|- A`[Var x <- Const c] ~> B`[Var x <- Const c] -> |- A ~> B
where "|- A ~> B" := (QRC1Proof A B) : qsp_scope.
Hint Resolve Top Same ConjEl ConjEr ConjI Nec Trans AllIr TermI : core.
Derive Inversion_clear QRC1Proof_inv with (forall A B, QRC1Proof A B).
Lemma Diam_All (x : VarName) (A : formula) :
|- <> All x A ~> All x (<> A).
Proof.
apply: AllIr; first by rewrite fv_Allself.
apply: Nec.
by apply: (AllIl (freeforxx _ _)); rewrite subtt.
Qed.
Lemma AllC (x y : VarName) (A : formula) :
|- All x (All y A) ~> All y (All x A).
Proof.
have [/eqP -> // | /eqP neqxy] := boolP (y == x).
apply: AllIr; first by rewrite fv_Allother // fv_Allself.
apply: AllIr; first by rewrite fv_Allself.
apply: (AllIl (freeforxx _ _)); rewrite subtt.
by apply: (AllIl (freeforxx _ _)); rewrite subtt.
Qed.
Lemma All_sub (x : VarName) (t : term) (A : formula) :
freefor A x t -> |- All x A ~> A`[Var x <- t].
Proof.
by move=> freeforA; apply: (AllIl freeforA).
Qed.
Lemma alphaconversion (x y : VarName) (A : formula) :
y \notin fv A ->
freefor A x (Var y) ->
|- All x A ~> All y A`[Var x <- Var y].
Proof.
move=> ynotinA yfreeforA.
apply: AllIr.
by rewrite /= in_fsetD1 negb_and ynotinA orbT.
by apply: All_sub.
Qed.
Lemma TermIr (x : VarName) (t : term) (A B : formula) :
x \notin fv A ->
freefor B x t ->
|- A ~> B -> |- A ~> B`[Var x <- t].
Proof.
move=> xnotinA xfreefortB.
rewrite -{2}(sub_notfree t xnotinA).
apply: TermI => //.
by rewrite notfv_freefor.
Qed.
Lemma Const_AllIr (x : VarName) (c : ConstName) (A B : formula) :
x \notin fv A ->
c \notin constants A ->
c \notin constants B ->
|- A ~> B`[Var x <- Const c] -> |- A ~> All x B.
Proof.
move=> xnotinA cnotinA cnotinB.
rewrite -{1}(sub_notfree (Const c) xnotinA) => pAcBc.
apply: AllIr => //.
by apply: (ConstE _ _ pAcBc).
Qed.
Lemma QRC1Proof_modaldepth (A B : formula) :
|- A ~> B -> modaldepth B <= modaldepth A.
Proof.
elim => //=.
- by move=> ? ?; rewrite leq_maxl.
- by move=> ? ?; rewrite leq_maxr.
- by move=> C D E _ leqDC _ leqEC; rewrite geq_max; apply /andP.
- by move=> C D E _ leqDC _ leqED; rewrite (leq_trans leqED).
- by move=> ? ? ?; rewrite modaldepth_sub.
- by move=> ? ? ? ?; rewrite 2!modaldepth_sub.
- by move=> ? ? ? ?; rewrite 2!modaldepth_sub.
Qed.
Corollary Diam_irreflexive (A : formula) :
~ |- A ~> <> A.
Proof. by move=> /QRC1Proof_modaldepth /=; rewrite ltnn. Qed.
Lemma spuriousAllr (x : VarName) (A : formula) :
x \notin fv A ->
|- A ~> All x A.
Proof. by move=> xnotinA; apply: AllIr. Qed.
Lemma spuriousAlll (x : VarName) (A : formula) :
x \notin fv A ->
|- All x A ~> A.
Proof.
move=> xnotinA.
rewrite -{2}(sub_notfree (Var x) xnotinA).
apply: All_sub.
by rewrite freeforxx.
Qed.
Lemma TermI_iter (xs : seq VarName) (ts : seq term) (A B : formula) :
{in [seq Var i | i <- xs], forall t1 : term, t1 \notin ts} ->
uniq xs ->
(forall i, i < size xs ->
freefor A (nth 0 xs i) (nth (Var (nth 0 xs i)) ts i)
) ->
(forall i, i < size xs ->
freefor B (nth 0 xs i) (nth (Var (nth 0 xs i)) ts i)
) ->
|- A ~> B -> |- A`[map Var xs <-- ts] ~> B`[map Var xs <-- ts].
Proof.
move: ts A B; elim: xs.
by move=> ts A B _ _ _ _ pAB /=; rewrite 2!simsub0ts.
move=> x xs IHxs; case.
by move=> A B _ _ _ _ pAB /=; rewrite 2!simsubts0.
move=> t ts A B xxsnotintts uniqxxs ffA ffB pAB /=.
have uniqVar : uniq (Var x :: [seq Var i | i <- xs]).
rewrite -[_ :: _]/(map _ (_ :: _)) map_inj_uniq //.
by move=> a b [].
have tnotinxs : t \notin [seq Var i | i <- xs].
apply/negP => tinxs.
have tinxxs : t \in [seq Var i | i <- x :: xs] by rewrite /= inE tinxs orbT.
move: (xxsnotintts _ tinxxs).
by rewrite inE eqxx.
have neqxsit : forall i, i < size xs -> Var (nth 0 (x :: xs) i.+1) <> t.
move=> i ltixs /= eqxsit.
suff tinxxs : t \in [seq Var i | i <- x :: xs].
by move: (xxsnotintts _ tinxxs); rewrite inE eqxx.
rewrite -eqxsit.
apply/mapP; exists (nth 0 (x :: xs) i.+1) => //.
apply: mem_nth => /=.
by rewrite /= -[i.+1]addn1 -[(size _).+1]addn1 ltn_add2r.
do 2!(rewrite simsub_cons //).
apply: IHxs.
- move=> y yinxs.
have yinxxs : y \in [seq Var i | i <- x :: xs] by rewrite /= inE yinxs orbT.
move: (xxsnotintts _ yinxxs).
apply: contra.
by rewrite inE => ->; rewrite orbT.
- by move: uniqxxs; rewrite cons_uniq => /andP[_ ->].
- move=> i ltixs.
rewrite -[nth _ xs i]/(nth _ (x :: xs) i.+1).
rewrite -[nth _ ts i]/(nth _ (t :: ts) i.+1).
apply: freefor_sub_neq.
+ by apply: neqxsit.
+ rewrite freefort_freefor.
by apply: (ffA 0).
apply: ffA.
by rewrite /= -[i.+1]addn1 -[(size _).+1]addn1 ltn_add2r.
- move=> i ltixs.
rewrite -[nth _ xs i]/(nth _ (x :: xs) i.+1).
rewrite -[nth _ ts i]/(nth _ (t :: ts) i.+1).
apply: freefor_sub_neq.
+ by apply: neqxsit.
+ rewrite freefort_freefor.
by apply: (ffB 0).
apply: ffB.
by rewrite /= -[i.+1]addn1 -[(size _).+1]addn1 ltn_add2r.
apply: TermI => //.
by apply: (ffA 0).
by apply: (ffB 0).
Qed.
End Formulas.
Notation "|- A ~> B" := (QRC1Proof A B)
(at level 85, format "|- A ~> B") : qsp_scope.
#[export]
Hint Resolve Top Same ConjEl ConjEr ConjI Nec Trans AllIr TermI : core.
Section Extend.
Open Scope qsp_scope.
Variable sig : signature.
Lemma unlift_monotone (n m1 m2 : nat) (A B : formula (extend sig n)) :
fresh m1 A ->
fresh m1 B ->
m1 + n <= m2 ->
|- A$m1 ~> B$m1 -> |- A$m2 ~> B$m2.
Proof.
move=> freshA freshB lem1nm2 pABm1.
rewrite (unlift_freshvars _ freshA) (unlift_freshvars _ freshB).
rewrite freshvarsE.
apply: TermI_iter => //.
- move=> /= t /mapP /= [x /mapP /= [k1]].
rewrite mem_iota add0n => /andP [_ ltk1n] -> ->.
apply/negP => /mapP /= [k2 _ [eqmk1mk2]].
move: lem1nm2; apply/negP; rewrite -ltnNge.
apply: (@leq_ltn_trans (m1 + k1)).
by rewrite eqmk1mk2 leq_addr.
by rewrite ltn_add2l.
- rewrite map_inj_uniq.
by rewrite iota_uniq.
by apply: addnI.
- move=> k; rewrite size_map => /[dup] ltkiotan; rewrite size_iota => ltkn.
rewrite /freshvars.
do 2!(rewrite (nth_map 0) // nth_iota // add0n).
apply: notvars_freefor; apply/negP =>m2kinAm1.
move: (vars_unlift m1 A) => /fsubsetP /(_ _) /(_ m2kinAm1).
move=> /fsetUP [m2kinA|/imfsetP/=[[i ltin] _ /=]].
move: (leq_bigmax_list id m2kinA).
apply/negP; rewrite -ltnNge.
apply: (leq_trans freshA); apply: (leq_trans (leq_addr n _)).
by apply: (leq_trans lem1nm2); rewrite leq_addr.
move=> eqm2km1i; move: lem1nm2.
have -> : n = i + (n - i) by rewrite subnKC // ltnW.
rewrite addnA -eqm2km1i.
apply/negP; rewrite -ltnNge.
move: ltin; rewrite -subn_gt0.
case: (n - i) => [//|l _].
apply: (@leq_trans (m2 + l.+1)).
by rewrite -addSnnS leq_addr.
by rewrite -addnA [k + _]addnC addnA leq_addr.
- (* TODO this proof is the same as the previous bullet *)
move=> k; rewrite size_map => /[dup] ltkiotan; rewrite size_iota => ltkn.
rewrite /freshvars.
do 2!(rewrite (nth_map 0) // nth_iota // add0n).
apply: notvars_freefor; apply/negP =>m2kinAm1.
move: (vars_unlift m1 B) => /fsubsetP /(_ _) /(_ m2kinAm1).
move=> /fsetUP [m2kinA|/imfsetP/=[[i ltin] _ /=]].
move: (leq_bigmax_list id m2kinA).
apply/negP; rewrite -ltnNge.
apply: (leq_trans freshB); apply: (leq_trans (leq_addr n _)).
by apply: (leq_trans lem1nm2); rewrite leq_addr.
move=> eqm2km1i; move: lem1nm2.
have -> : n = i + (n - i) by rewrite subnKC // ltnW.
rewrite addnA -eqm2km1i.
apply/negP; rewrite -ltnNge.
move: ltin; rewrite -subn_gt0.
case: (n - i) => [//|l _].
apply: (@leq_trans (m2 + l.+1)).
by rewrite -addSnnS leq_addr.
by rewrite -addnA [k + _]addnC addnA leq_addr.
Qed.
Lemma QRC1Proof_unlift (n : nat) (A B : formula (extend sig n)) :
|- A ~> B ->
exists2 m : nat,
fresh m A && fresh m B & |- A$m ~> B$m.
Proof.
have ltx : forall (x m n : nat), x < (maxn x m + n).+1.
move=> x' m' n'; rewrite ltnS.
by apply: leq_trans (leq_addr _ _); rewrite leq_maxl.
have lem : forall (x m n : nat), m <= (maxn x m + n).+1.
move=> x' m' n'; apply: leq_trans (leqnSn _).
by apply: (leq_trans (leq_maxr x' _)); rewrite leq_addr.
have lemn : forall (x m n : nat), m + n <= (maxn x m + n).+1.
move=> x' m' n'.
apply: (@leq_trans (maxn x' m' + n')); last by rewrite leqnSn.
by rewrite leq_add2r leq_maxr.
elim=> {A B}.
- move=> A /=.
exists (\max_(x <- vars A) x).+1 => //=.
by rewrite /fresh ltnSn big_nil.
- move=> A.
exists (\max_(x <- vars A) x).+1 => //=.
by rewrite /fresh ltnSn.
- move=> A B.
exists (\max_(x <- vars (A /\ B)) x).+1 => //=.
rewrite /fresh ltnSn /= ltnS.
rewrite big_fsetU /=; last by apply: maxnn.
by apply: leq_maxl.
- move=> A B.
exists (\max_(x <- vars (A /\ B)) x).+1 => //=.
rewrite /fresh ltnSn /= ltnS.
rewrite big_fsetU /=; last by apply: maxnn.
by apply: leq_maxr.
- move=> A B C pAB [mAB /andP[ltAmAB ltBmAB] IHpAB].
move=> pAC [mAC /andP[ltAmAC ltCmAC] IHpAC].
exists (maxn mAB mAC + n) => /=.
apply/andP; split.
apply: (leq_trans ltAmAB).
apply: (leq_trans (leq_maxl _ mAC)).
by apply: leq_addr.
rewrite freshE (fresh_monotone _ ltBmAB) /=; last first.
by apply: (leq_trans (leq_maxl _ mAC)); rewrite leq_addr.
apply: fresh_monotone ltCmAC.
by apply: (leq_trans (leq_maxr mAB _)); rewrite leq_addr.
apply: ConjI.
apply: (unlift_monotone _ _ _ IHpAB) => //.
by rewrite leq_add2r leq_maxl.
apply: (unlift_monotone _ _ _ IHpAC) => //.
by rewrite leq_add2r leq_maxr.
- move=> A B C pAB [mAB /andP[ltAmAB ltBmAB] IHpAB].
move=> pBC [mBC /andP[ltBmBC ltCmBC] IHpBC].
exists (maxn mAB mBC + n).
rewrite (fresh_monotone _ ltAmAB) /=; last first.
by apply: (leq_trans (leq_maxl _ mBC)); rewrite leq_addr.
apply: fresh_monotone ltCmBC.
by apply: (leq_trans (leq_maxr mAB _)); rewrite leq_addr.
apply: (@Cut _ _ (B$(maxn mAB mBC + n))).
apply: (unlift_monotone _ _ _ IHpAB) => //.
by rewrite leq_add2r leq_maxl.
apply: (unlift_monotone _ _ _ IHpBC) => //.
by rewrite leq_add2r leq_maxr.
- move=> A B pAB [m /andP[ltAm ltBm] IHpAB].
exists m => /=.
by rewrite !freshE ltAm ltBm.
by apply: Nec.
- move=> A.
exists (\max_(x <- vars A) x).+1 => //=.
by rewrite !freshE /fresh ltnSn.
- move=> /= x A B xnotinA pAB [m /andP[ltAm ltBm] IHpAB].
exists (maxn x m + n).+1 => /=.
rewrite freshE ltx /=.
rewrite (fresh_monotone _ ltAm) /=; last by rewrite lem.
by rewrite (fresh_monotone _ ltBm) /=; last by rewrite lem.
apply: AllIr.
by rewrite in_fv_unlift_fv // ltx.
by apply: (unlift_monotone _ _ _ IHpAB).
- move=> x t A B ffAxt pAtB [m /andP[ltAtm ltBm] IHpAtB] /=.
have freshA : fresh (maxn x m + n).+1 A.
apply: (sub_fresh (t1:=Var _ x) (t2:=t)).
by rewrite freshE.
by apply: (fresh_monotone (lem _ m _)).
exists (maxn x m + n).+1.
rewrite freshE ltx freshA /=.
by apply: fresh_monotone ltBm.
apply: (@AllIl _ _ t`$(maxn x m + n).+1).
by rewrite freefor_unlift.
rewrite -[Var sig x]/((Var (extend _ n) x)`$(maxn x m + n).+1).
rewrite -unlift_sub //.
by apply: (unlift_monotone _ _ _ IHpAtB) => //.
by rewrite freshE.
- move=> x [y|c] A B + + pAB.
move=> ffAxy ffBxy [m /andP[freshA freshB] IHpAB].
have freshA' : fresh (maxn (maxn x y) m + n).+1 A.
by apply: fresh_monotone freshA.
have freshB' : fresh (maxn (maxn x y) m + n).+1 B.
by apply: fresh_monotone freshB.
have ltx' : x < (maxn (maxn x y) m + n).+1.
by apply: leq_ltn_trans (ltx _ _ _); rewrite leq_maxl.
have lty : y < (maxn (maxn x y) m + n).+1.
by apply: leq_ltn_trans (ltx _ _ _); rewrite leq_maxr.
exists (maxn (maxn x y) m + n).+1.
by rewrite !fresh_sub ?freshE.
rewrite !unlift_sub ?freshE //.
apply: TermI; try by rewrite freefor_unlift.
by apply: (unlift_monotone _ _ _ IHpAB).
move=> _ _ [[/[!fresh0] //|m /andP[freshA freshB] IHpAB]].
have freshA' : fresh (maxn x m.+1 + n).+1 A.
by apply: fresh_monotone freshA.
have freshB' : fresh (maxn x m.+1 + n).+1 B.
by apply: fresh_monotone freshB.
exists (maxn x m.+1 + n).+1.
rewrite fresh_sub ?freshE //=.
by apply: fresh_sub; rewrite ?freshE.
rewrite !unlift_sub ?freshE //.
apply: TermI; try by rewrite freefor_unlift // freefor_Const.
by apply: (unlift_monotone _ _ _ IHpAB).
- move=> x c A B cnotinA cnotinB pAB [m /andP[freshAsub freshBsub]].
move=> /(unlift_monotone freshAsub freshBsub (lemn x m n)).
move: freshAsub => /(fresh_monotone (lem x m n)) freshAsub.
move: freshBsub => /(fresh_monotone (lem x m n)) freshBsub.
set m' := _.+1; rewrite -/m' in freshAsub freshBsub.
have freshx : termfresh m' (Var (extend sig n) x) by rewrite /m' freshE.
have freshA : fresh m' A by apply: sub_fresh freshAsub.
have freshB : fresh m' B by apply: sub_fresh freshBsub.
rewrite !unlift_sub // [(Var _ _)`$_]/= => IHpABm'.
exists m'.
by rewrite freshA freshB.
case: c cnotinA cnotinB IHpABm' {pAB freshAsub freshBsub} => [c|k] /=.
move=> cnotinA cnotinB IH.
apply: ConstE IH.
by apply: contra cnotinA; apply: constants_unlift.
by apply: contra cnotinB; apply: constants_unlift.
move=> /negPf knotinA /negPf knotinB IH.
have ffAm'xk : freefor A$m' x (Var sig (m' + k)).
rewrite -[Var _ _]/((@Const (extend _ _) (inr k))`$m') freefor_unlift //.
by apply: freefor_Const.
by rewrite /m'.
have ffBm'xk : freefor B$m' x (Var sig (m' + k)).
rewrite -[Var _ _]/((@Const (extend _ _) (inr k))`$m') freefor_unlift //.
by apply: freefor_Const.
by rewrite /m'.
have m'knotinAm' : m' + k \notin fv A$m'.
by apply/negPf; rewrite in_fv_unlift_constants.
have m'knotinBm' : m' + k \notin fv B$m'.
by apply/negPf; rewrite in_fv_unlift_constants.
rewrite -(subxyyx ffAm'xk) // -(subxyyx ffBm'xk) //.
apply: TermI => //.
apply: freefor_sub_eq; rewrite ?freefort_freefor //.
by apply: notfv_freefor.
apply: freefor_sub_eq; rewrite ?freefort_freefor //.
by apply: notfv_freefor.
Qed.
Lemma QRC1Proof_lift (n : nat) (A B : formula sig) :
|- A!!n ~> B!!n -> |- A ~> B.
Proof.
move=> /QRC1Proof_unlift [m _].
by rewrite 2!liftK.
Qed.
End Extend.
From QRC1 Require Import Preamble Language.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Section 2: Quantified Reflection Calculus with one modality *)
Section Formulas.
Local Open Scope qsp_scope.
Variable sig : signature.
Notation term := (term sig).
Notation formula := (formula sig).
Notation Var := (Var sig).
Notation ConstName := (ConstName sig).
(* Definition 2.1 *)
(* Note: this is the updated definition without Diam_All *)
Reserved Notation "|- A ~> B" (at level 85, format "|- A ~> B").
Inductive QRC1Proof : formula -> formula -> Prop :=
| Top : forall A, |- A ~> T _
| Same : forall A, |- A ~> A
| ConjEl : forall A B, |- A /\ B ~> A
| ConjEr : forall A B, |- A /\ B ~> B
| ConjI : forall A B C, |- A ~> B -> |- A ~> C -> |- A ~> B /\ C
| Cut : forall A B C, |- A ~> B -> |- B ~> C -> |- A ~> C
| Nec : forall A B, |- A ~> B -> |- <> A ~> <> B
| Trans : forall A, |- <> <> A ~> <> A
| AllIr : forall x A B, x \notin fv A ->
|- A ~> B -> |- A ~> All x B
| AllIl : forall x t A B, freefor A x t ->
|- A`[Var x <- t] ~> B -> |- All x A ~> B
| TermI : forall x t A B, freefor A x t -> freefor B x t ->
|- A ~> B -> |- A`[Var x <- t] ~> B`[Var x <- t]
| ConstE : forall x c A B, c \notin constants A -> c \notin constants B ->
|- A`[Var x <- Const c] ~> B`[Var x <- Const c] -> |- A ~> B
where "|- A ~> B" := (QRC1Proof A B) : qsp_scope.
Hint Resolve Top Same ConjEl ConjEr ConjI Nec Trans AllIr TermI : core.
Derive Inversion_clear QRC1Proof_inv with (forall A B, QRC1Proof A B).
Lemma Diam_All (x : VarName) (A : formula) :
|- <> All x A ~> All x (<> A).
Proof.
apply: AllIr; first by rewrite fv_Allself.
apply: Nec.
by apply: (AllIl (freeforxx _ _)); rewrite subtt.
Qed.
Lemma AllC (x y : VarName) (A : formula) :
|- All x (All y A) ~> All y (All x A).
Proof.
have [/eqP -> // | /eqP neqxy] := boolP (y == x).
apply: AllIr; first by rewrite fv_Allother // fv_Allself.
apply: AllIr; first by rewrite fv_Allself.
apply: (AllIl (freeforxx _ _)); rewrite subtt.
by apply: (AllIl (freeforxx _ _)); rewrite subtt.
Qed.
Lemma All_sub (x : VarName) (t : term) (A : formula) :
freefor A x t -> |- All x A ~> A`[Var x <- t].
Proof.
by move=> freeforA; apply: (AllIl freeforA).
Qed.
Lemma alphaconversion (x y : VarName) (A : formula) :
y \notin fv A ->
freefor A x (Var y) ->
|- All x A ~> All y A`[Var x <- Var y].
Proof.
move=> ynotinA yfreeforA.
apply: AllIr.
by rewrite /= in_fsetD1 negb_and ynotinA orbT.
by apply: All_sub.
Qed.
Lemma TermIr (x : VarName) (t : term) (A B : formula) :
x \notin fv A ->
freefor B x t ->
|- A ~> B -> |- A ~> B`[Var x <- t].
Proof.
move=> xnotinA xfreefortB.
rewrite -{2}(sub_notfree t xnotinA).
apply: TermI => //.
by rewrite notfv_freefor.
Qed.
Lemma Const_AllIr (x : VarName) (c : ConstName) (A B : formula) :
x \notin fv A ->
c \notin constants A ->
c \notin constants B ->
|- A ~> B`[Var x <- Const c] -> |- A ~> All x B.
Proof.
move=> xnotinA cnotinA cnotinB.
rewrite -{1}(sub_notfree (Const c) xnotinA) => pAcBc.
apply: AllIr => //.
by apply: (ConstE _ _ pAcBc).
Qed.
Lemma QRC1Proof_modaldepth (A B : formula) :
|- A ~> B -> modaldepth B <= modaldepth A.
Proof.
elim => //=.
- by move=> ? ?; rewrite leq_maxl.
- by move=> ? ?; rewrite leq_maxr.
- by move=> C D E _ leqDC _ leqEC; rewrite geq_max; apply /andP.
- by move=> C D E _ leqDC _ leqED; rewrite (leq_trans leqED).
- by move=> ? ? ?; rewrite modaldepth_sub.
- by move=> ? ? ? ?; rewrite 2!modaldepth_sub.
- by move=> ? ? ? ?; rewrite 2!modaldepth_sub.
Qed.
Corollary Diam_irreflexive (A : formula) :
~ |- A ~> <> A.
Proof. by move=> /QRC1Proof_modaldepth /=; rewrite ltnn. Qed.
Lemma spuriousAllr (x : VarName) (A : formula) :
x \notin fv A ->
|- A ~> All x A.
Proof. by move=> xnotinA; apply: AllIr. Qed.
Lemma spuriousAlll (x : VarName) (A : formula) :
x \notin fv A ->
|- All x A ~> A.
Proof.
move=> xnotinA.
rewrite -{2}(sub_notfree (Var x) xnotinA).
apply: All_sub.
by rewrite freeforxx.
Qed.
Lemma TermI_iter (xs : seq VarName) (ts : seq term) (A B : formula) :
{in [seq Var i | i <- xs], forall t1 : term, t1 \notin ts} ->
uniq xs ->
(forall i, i < size xs ->
freefor A (nth 0 xs i) (nth (Var (nth 0 xs i)) ts i)
) ->
(forall i, i < size xs ->
freefor B (nth 0 xs i) (nth (Var (nth 0 xs i)) ts i)
) ->
|- A ~> B -> |- A`[map Var xs <-- ts] ~> B`[map Var xs <-- ts].
Proof.
move: ts A B; elim: xs.
by move=> ts A B _ _ _ _ pAB /=; rewrite 2!simsub0ts.
move=> x xs IHxs; case.
by move=> A B _ _ _ _ pAB /=; rewrite 2!simsubts0.
move=> t ts A B xxsnotintts uniqxxs ffA ffB pAB /=.
have uniqVar : uniq (Var x :: [seq Var i | i <- xs]).
rewrite -[_ :: _]/(map _ (_ :: _)) map_inj_uniq //.
by move=> a b [].
have tnotinxs : t \notin [seq Var i | i <- xs].
apply/negP => tinxs.
have tinxxs : t \in [seq Var i | i <- x :: xs] by rewrite /= inE tinxs orbT.
move: (xxsnotintts _ tinxxs).
by rewrite inE eqxx.
have neqxsit : forall i, i < size xs -> Var (nth 0 (x :: xs) i.+1) <> t.
move=> i ltixs /= eqxsit.
suff tinxxs : t \in [seq Var i | i <- x :: xs].
by move: (xxsnotintts _ tinxxs); rewrite inE eqxx.
rewrite -eqxsit.
apply/mapP; exists (nth 0 (x :: xs) i.+1) => //.
apply: mem_nth => /=.
by rewrite /= -[i.+1]addn1 -[(size _).+1]addn1 ltn_add2r.
do 2!(rewrite simsub_cons //).
apply: IHxs.
- move=> y yinxs.
have yinxxs : y \in [seq Var i | i <- x :: xs] by rewrite /= inE yinxs orbT.
move: (xxsnotintts _ yinxxs).
apply: contra.
by rewrite inE => ->; rewrite orbT.
- by move: uniqxxs; rewrite cons_uniq => /andP[_ ->].
- move=> i ltixs.
rewrite -[nth _ xs i]/(nth _ (x :: xs) i.+1).
rewrite -[nth _ ts i]/(nth _ (t :: ts) i.+1).
apply: freefor_sub_neq.
+ by apply: neqxsit.
+ rewrite freefort_freefor.
by apply: (ffA 0).
apply: ffA.
by rewrite /= -[i.+1]addn1 -[(size _).+1]addn1 ltn_add2r.
- move=> i ltixs.
rewrite -[nth _ xs i]/(nth _ (x :: xs) i.+1).
rewrite -[nth _ ts i]/(nth _ (t :: ts) i.+1).
apply: freefor_sub_neq.
+ by apply: neqxsit.
+ rewrite freefort_freefor.
by apply: (ffB 0).
apply: ffB.
by rewrite /= -[i.+1]addn1 -[(size _).+1]addn1 ltn_add2r.
apply: TermI => //.
by apply: (ffA 0).
by apply: (ffB 0).
Qed.
End Formulas.
Notation "|- A ~> B" := (QRC1Proof A B)
(at level 85, format "|- A ~> B") : qsp_scope.
#[export]
Hint Resolve Top Same ConjEl ConjEr ConjI Nec Trans AllIr TermI : core.
Section Extend.
Open Scope qsp_scope.
Variable sig : signature.
Lemma unlift_monotone (n m1 m2 : nat) (A B : formula (extend sig n)) :
fresh m1 A ->
fresh m1 B ->
m1 + n <= m2 ->
|- A$m1 ~> B$m1 -> |- A$m2 ~> B$m2.
Proof.
move=> freshA freshB lem1nm2 pABm1.
rewrite (unlift_freshvars _ freshA) (unlift_freshvars _ freshB).
rewrite freshvarsE.
apply: TermI_iter => //.
- move=> /= t /mapP /= [x /mapP /= [k1]].
rewrite mem_iota add0n => /andP [_ ltk1n] -> ->.
apply/negP => /mapP /= [k2 _ [eqmk1mk2]].
move: lem1nm2; apply/negP; rewrite -ltnNge.
apply: (@leq_ltn_trans (m1 + k1)).
by rewrite eqmk1mk2 leq_addr.
by rewrite ltn_add2l.
- rewrite map_inj_uniq.
by rewrite iota_uniq.
by apply: addnI.
- move=> k; rewrite size_map => /[dup] ltkiotan; rewrite size_iota => ltkn.
rewrite /freshvars.
do 2!(rewrite (nth_map 0) // nth_iota // add0n).
apply: notvars_freefor; apply/negP =>m2kinAm1.
move: (vars_unlift m1 A) => /fsubsetP /(_ _) /(_ m2kinAm1).
move=> /fsetUP [m2kinA|/imfsetP/=[[i ltin] _ /=]].
move: (leq_bigmax_list id m2kinA).
apply/negP; rewrite -ltnNge.
apply: (leq_trans freshA); apply: (leq_trans (leq_addr n _)).
by apply: (leq_trans lem1nm2); rewrite leq_addr.
move=> eqm2km1i; move: lem1nm2.
have -> : n = i + (n - i) by rewrite subnKC // ltnW.
rewrite addnA -eqm2km1i.
apply/negP; rewrite -ltnNge.
move: ltin; rewrite -subn_gt0.
case: (n - i) => [//|l _].
apply: (@leq_trans (m2 + l.+1)).
by rewrite -addSnnS leq_addr.
by rewrite -addnA [k + _]addnC addnA leq_addr.
- (* TODO this proof is the same as the previous bullet *)
move=> k; rewrite size_map => /[dup] ltkiotan; rewrite size_iota => ltkn.
rewrite /freshvars.
do 2!(rewrite (nth_map 0) // nth_iota // add0n).
apply: notvars_freefor; apply/negP =>m2kinAm1.
move: (vars_unlift m1 B) => /fsubsetP /(_ _) /(_ m2kinAm1).
move=> /fsetUP [m2kinA|/imfsetP/=[[i ltin] _ /=]].
move: (leq_bigmax_list id m2kinA).
apply/negP; rewrite -ltnNge.
apply: (leq_trans freshB); apply: (leq_trans (leq_addr n _)).
by apply: (leq_trans lem1nm2); rewrite leq_addr.
move=> eqm2km1i; move: lem1nm2.
have -> : n = i + (n - i) by rewrite subnKC // ltnW.
rewrite addnA -eqm2km1i.
apply/negP; rewrite -ltnNge.
move: ltin; rewrite -subn_gt0.
case: (n - i) => [//|l _].
apply: (@leq_trans (m2 + l.+1)).
by rewrite -addSnnS leq_addr.
by rewrite -addnA [k + _]addnC addnA leq_addr.
Qed.
Lemma QRC1Proof_unlift (n : nat) (A B : formula (extend sig n)) :
|- A ~> B ->
exists2 m : nat,
fresh m A && fresh m B & |- A$m ~> B$m.
Proof.
have ltx : forall (x m n : nat), x < (maxn x m + n).+1.
move=> x' m' n'; rewrite ltnS.
by apply: leq_trans (leq_addr _ _); rewrite leq_maxl.
have lem : forall (x m n : nat), m <= (maxn x m + n).+1.
move=> x' m' n'; apply: leq_trans (leqnSn _).
by apply: (leq_trans (leq_maxr x' _)); rewrite leq_addr.
have lemn : forall (x m n : nat), m + n <= (maxn x m + n).+1.
move=> x' m' n'.
apply: (@leq_trans (maxn x' m' + n')); last by rewrite leqnSn.
by rewrite leq_add2r leq_maxr.
elim=> {A B}.
- move=> A /=.
exists (\max_(x <- vars A) x).+1 => //=.
by rewrite /fresh ltnSn big_nil.
- move=> A.
exists (\max_(x <- vars A) x).+1 => //=.
by rewrite /fresh ltnSn.
- move=> A B.
exists (\max_(x <- vars (A /\ B)) x).+1 => //=.
rewrite /fresh ltnSn /= ltnS.
rewrite big_fsetU /=; last by apply: maxnn.
by apply: leq_maxl.
- move=> A B.
exists (\max_(x <- vars (A /\ B)) x).+1 => //=.
rewrite /fresh ltnSn /= ltnS.
rewrite big_fsetU /=; last by apply: maxnn.
by apply: leq_maxr.
- move=> A B C pAB [mAB /andP[ltAmAB ltBmAB] IHpAB].
move=> pAC [mAC /andP[ltAmAC ltCmAC] IHpAC].
exists (maxn mAB mAC + n) => /=.
apply/andP; split.
apply: (leq_trans ltAmAB).
apply: (leq_trans (leq_maxl _ mAC)).
by apply: leq_addr.
rewrite freshE (fresh_monotone _ ltBmAB) /=; last first.
by apply: (leq_trans (leq_maxl _ mAC)); rewrite leq_addr.
apply: fresh_monotone ltCmAC.
by apply: (leq_trans (leq_maxr mAB _)); rewrite leq_addr.
apply: ConjI.
apply: (unlift_monotone _ _ _ IHpAB) => //.
by rewrite leq_add2r leq_maxl.
apply: (unlift_monotone _ _ _ IHpAC) => //.
by rewrite leq_add2r leq_maxr.
- move=> A B C pAB [mAB /andP[ltAmAB ltBmAB] IHpAB].
move=> pBC [mBC /andP[ltBmBC ltCmBC] IHpBC].
exists (maxn mAB mBC + n).
rewrite (fresh_monotone _ ltAmAB) /=; last first.
by apply: (leq_trans (leq_maxl _ mBC)); rewrite leq_addr.
apply: fresh_monotone ltCmBC.
by apply: (leq_trans (leq_maxr mAB _)); rewrite leq_addr.
apply: (@Cut _ _ (B$(maxn mAB mBC + n))).
apply: (unlift_monotone _ _ _ IHpAB) => //.
by rewrite leq_add2r leq_maxl.
apply: (unlift_monotone _ _ _ IHpBC) => //.
by rewrite leq_add2r leq_maxr.
- move=> A B pAB [m /andP[ltAm ltBm] IHpAB].
exists m => /=.
by rewrite !freshE ltAm ltBm.
by apply: Nec.
- move=> A.
exists (\max_(x <- vars A) x).+1 => //=.
by rewrite !freshE /fresh ltnSn.
- move=> /= x A B xnotinA pAB [m /andP[ltAm ltBm] IHpAB].
exists (maxn x m + n).+1 => /=.
rewrite freshE ltx /=.
rewrite (fresh_monotone _ ltAm) /=; last by rewrite lem.
by rewrite (fresh_monotone _ ltBm) /=; last by rewrite lem.
apply: AllIr.
by rewrite in_fv_unlift_fv // ltx.
by apply: (unlift_monotone _ _ _ IHpAB).
- move=> x t A B ffAxt pAtB [m /andP[ltAtm ltBm] IHpAtB] /=.
have freshA : fresh (maxn x m + n).+1 A.
apply: (sub_fresh (t1:=Var _ x) (t2:=t)).
by rewrite freshE.
by apply: (fresh_monotone (lem _ m _)).
exists (maxn x m + n).+1.
rewrite freshE ltx freshA /=.
by apply: fresh_monotone ltBm.
apply: (@AllIl _ _ t`$(maxn x m + n).+1).
by rewrite freefor_unlift.
rewrite -[Var sig x]/((Var (extend _ n) x)`$(maxn x m + n).+1).
rewrite -unlift_sub //.
by apply: (unlift_monotone _ _ _ IHpAtB) => //.
by rewrite freshE.
- move=> x [y|c] A B + + pAB.
move=> ffAxy ffBxy [m /andP[freshA freshB] IHpAB].
have freshA' : fresh (maxn (maxn x y) m + n).+1 A.
by apply: fresh_monotone freshA.
have freshB' : fresh (maxn (maxn x y) m + n).+1 B.
by apply: fresh_monotone freshB.
have ltx' : x < (maxn (maxn x y) m + n).+1.
by apply: leq_ltn_trans (ltx _ _ _); rewrite leq_maxl.
have lty : y < (maxn (maxn x y) m + n).+1.
by apply: leq_ltn_trans (ltx _ _ _); rewrite leq_maxr.
exists (maxn (maxn x y) m + n).+1.
by rewrite !fresh_sub ?freshE.
rewrite !unlift_sub ?freshE //.
apply: TermI; try by rewrite freefor_unlift.
by apply: (unlift_monotone _ _ _ IHpAB).
move=> _ _ [[/[!fresh0] //|m /andP[freshA freshB] IHpAB]].
have freshA' : fresh (maxn x m.+1 + n).+1 A.
by apply: fresh_monotone freshA.
have freshB' : fresh (maxn x m.+1 + n).+1 B.
by apply: fresh_monotone freshB.
exists (maxn x m.+1 + n).+1.
rewrite fresh_sub ?freshE //=.
by apply: fresh_sub; rewrite ?freshE.
rewrite !unlift_sub ?freshE //.
apply: TermI; try by rewrite freefor_unlift // freefor_Const.
by apply: (unlift_monotone _ _ _ IHpAB).
- move=> x c A B cnotinA cnotinB pAB [m /andP[freshAsub freshBsub]].
move=> /(unlift_monotone freshAsub freshBsub (lemn x m n)).
move: freshAsub => /(fresh_monotone (lem x m n)) freshAsub.
move: freshBsub => /(fresh_monotone (lem x m n)) freshBsub.
set m' := _.+1; rewrite -/m' in freshAsub freshBsub.
have freshx : termfresh m' (Var (extend sig n) x) by rewrite /m' freshE.
have freshA : fresh m' A by apply: sub_fresh freshAsub.
have freshB : fresh m' B by apply: sub_fresh freshBsub.
rewrite !unlift_sub // [(Var _ _)`$_]/= => IHpABm'.
exists m'.
by rewrite freshA freshB.
case: c cnotinA cnotinB IHpABm' {pAB freshAsub freshBsub} => [c|k] /=.
move=> cnotinA cnotinB IH.
apply: ConstE IH.
by apply: contra cnotinA; apply: constants_unlift.
by apply: contra cnotinB; apply: constants_unlift.
move=> /negPf knotinA /negPf knotinB IH.
have ffAm'xk : freefor A$m' x (Var sig (m' + k)).
rewrite -[Var _ _]/((@Const (extend _ _) (inr k))`$m') freefor_unlift //.
by apply: freefor_Const.
by rewrite /m'.
have ffBm'xk : freefor B$m' x (Var sig (m' + k)).
rewrite -[Var _ _]/((@Const (extend _ _) (inr k))`$m') freefor_unlift //.
by apply: freefor_Const.
by rewrite /m'.
have m'knotinAm' : m' + k \notin fv A$m'.
by apply/negPf; rewrite in_fv_unlift_constants.
have m'knotinBm' : m' + k \notin fv B$m'.
by apply/negPf; rewrite in_fv_unlift_constants.
rewrite -(subxyyx ffAm'xk) // -(subxyyx ffBm'xk) //.
apply: TermI => //.
apply: freefor_sub_eq; rewrite ?freefort_freefor //.
by apply: notfv_freefor.
apply: freefor_sub_eq; rewrite ?freefort_freefor //.
by apply: notfv_freefor.
Qed.
Lemma QRC1Proof_lift (n : nat) (A B : formula sig) :
|- A!!n ~> B!!n -> |- A ~> B.
Proof.
move=> /QRC1Proof_unlift [m _].
by rewrite 2!liftK.
Qed.
End Extend.