QRC1.Pairs
From mathcomp Require Import all_ssreflect finmap.
From Coq Require Import Program.Wf Classical.
From QRC1 Require Import Preamble Language QRC1 QRC1Equiv Closure.
From QRC1 Require Import KripkeSemantics.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Section Pairs.
Variable sig : signature.
Notation term := (term sig).
Notation ConstName := (ConstName sig).
Notation PredName := (PredName sig).
Notation formula := (formula sig).
Notation formulas := (formulas sig).
Notation consts := (consts sig).
Notation Var := (Var sig).
Local Open Scope qsp_scope.
Local Open Scope fset.
Definition pair : Type := formulas * formulas.
Notation "p .+" := (@fst formulas formulas p) (at level 2, format "p .+").
Notation "p .-" := (@snd formulas formulas p) (at level 2, format "p .-").
Coercion formulas_of_pair (p : pair) : {fset formula} := p.+ `|` p.-.
Lemma pair_fsubset (p : pair) (fs : formulas) :
p `<=` fs = (p.+ `<=` fs) && (p.- `<=` fs).
Proof. by case: p => [p1 p2] /=; rewrite fsubUset. Qed.
Lemma p1inp (p : pair) : p.+ `<=` p.
Proof. by apply: fsubsetU; rewrite fsubset_refl. Qed.
Lemma p2inp (p : pair) : p.- `<=` p.
Proof. by apply: fsubsetU; rewrite fsubset_refl orbT. Qed.
Definition subpair (p q : pair) : bool :=
(p.+ `<=` q.+) && (p.- `<=` q.-).
Infix "`p<=`" := subpair (at level 70).
Lemma subpairfs_trans (fs : formulas) (p q : pair) :
p `p<=` q -> q `<=` fs -> p `<=` fs.
Proof.
case: q; case: p => p1 p2 q1 q2 /andP /= [leqpq1 leqpq2].
move=> /fsubUsetP /= [leqq1fs leqq2fs].
apply/fsubUsetP => /=; split.
by rewrite (fsubset_trans leqpq1).
by rewrite (fsubset_trans leqpq2).
Qed.
Lemma subpair_trans (p q r : pair) :
p `p<=` q -> q `p<=` r -> p `p<=` r.
Proof.
case: r; case: q; case: p => p1 p2 q1 q2 r1 r2.
move=> /andP /= [leqpq1 leqpq2] /andP /= [leqqr1 leqqr2].
apply/andP => /=; split.
by rewrite (fsubset_trans leqpq1).
by rewrite (fsubset_trans leqpq2).
Qed.
Lemma pair_closedfs (p : pair) :
closedfs p = (closedfs p.+) && (closedfs p.-).
Proof.
apply/allP/andP => /=.
move=> closedp; split; apply/allP.
by move=> A Ainp1; apply: closedp; rewrite inE Ainp1.
by move=> A Ainp2; apply: closedp; rewrite inE Ainp2 orbT.
move=> /= [/allP closedp1 /allP closedp2] A /fsetUP [Ainp1 | Ainp2].
by apply: closedp1.
by apply: closedp2.
Qed.
Definition consistent (p : pair) : Prop :=
forall B : formula, B \in p.- -> ~ |- //\\ p.+ ~> B.
Definition maximal (fs : formulas) (p : pair) : bool :=
[forall A : fs, (val A \in p.+) || (val A \in p.-)].
Lemma maximalP (fs : formulas) (p : pair) :
reflect
(forall A : formula, A \in fs -> A \in p.+ \/ A \in p.-)
(maximal fs p).
Proof.
apply (iffP 'forall_orP) => /=.
move=> H A Ainfs; apply: (H [` Ainfs]).
by move=> H A; apply: H.
Qed.
Lemma maximalE (fs : formulas) (p : pair) :
maximal fs p = (fs `<=` p).
Proof.
apply/maximalP/fsubsetP.
move=> maxfs /= A Ainfs.
by rewrite in_fsetU; apply/orP; apply: maxfs.
move=> subfsp A Ainfs.
have := subfsp _ Ainfs.
by rewrite in_fsetU => /orP.
Qed.
Definition witnessed (p : pair) : bool :=
[forall B : p.-,
if val B is All x B' then
[exists c : ConstName, B'`[Var x <- Const c] \in p.-]
else true
].
Lemma witnessedP (p : pair) :
reflect
(forall (x : VarName) (A : formula), All x A \in p.- ->
exists c : ConstName, A`[Var x <- Const c] \in p.-
)
(witnessed p).
Proof.
apply: (iffP forallP) => /=.
move=> H x A xAinp2.
by have /= /existsP := H [` xAinp2].
move=> H [/= [] // x A xAinp2].
by apply/existsP; apply: H.
Qed.
Definition wfpair (fs : formulas) (p : pair) : Prop :=
[/\ p `<=` fs, closedfs p, consistent p, maximal fs p & witnessed p].
Lemma wf_subset (fs : formulas) (p : pair) :
wfpair fs p -> p `<=` fs.
Proof. by move=> []. Qed.
Lemma wf_consistent (fs : formulas) (p : pair) :
wfpair fs p -> consistent p.
Proof.
Proof. by move=> []. Qed.
(* Towards Lindenbaum *)
Lemma counting (C1 C2 : consts) :
#|` C1 `&` C2| < #|` C1| -> exists c, c \in C1 `\` C2.
Proof.
move=> lt; apply/fset0Pn; apply/eqP => /eqP.
rewrite -cardfs_eq0 cardfsD.
rewrite subn_eq0 => le.
by move: (leq_ltn_trans le lt); rewrite ltnn.
Qed.
(* We need classical logic for this lemma *)
(* https://coq.zulipchat.com/narrow/stream/237977-Coq-users/topic/LEM.20vs.20decidability *)
Lemma exists_q_seq (fs : seq formula) (P : formula) :
exists q : pair,
((forall A : formula, A \in q.+ <-> A \in fs /\ |- P ~> A)
/\
q.- = [fset p in fs] `\` q.+)%type.
Proof.
elim: fs.
exists (fset0, fset0); split=> /=.
by move=> A; rewrite in_fset0; split=> [|[]].
rewrite fsetD0.
by apply/fsetP => A; apply/idP/imfsetP => [|[] //]; rewrite in_fset0.
move=> A fs [q [q1P q2P]].
case: (classic (|- P ~> A)) => [pPA | npPA].
exists (A |` q.+, q.-); split=> /=.
move=> B; rewrite 3!inE.
by case: eqP => [-> | _ /=].
rewrite fset_cons q2P.
have [Ainfs | Anotinfs] := boolP (A \in fs).
have Ainq1 : A \in q.+by rewrite q1P.
rewrite (mem_fset1U Ainq1) mem_fset1U //.
by apply/imfsetP; exists A.
have Anotinfs_seq : A \notin [fset p | p in fs].
apply/imfsetP => /= -[B Binfs eqAB].
by move: Anotinfs => /negP; rewrite eqAB.
rewrite fsetDUr fsetU1K //.
rewrite fsetDUl fsetIUr fsetIDA.
rewrite disjoint_fsetI0; last by rewrite fdisjointX1.
rewrite fset0D fset0U.
by rewrite fsetIDA fsetIid.
exists (q.+, A |` q.-); split=> /=.
move=> B; rewrite q1P inE.
case: eqP => [-> | //].
by rewrite orTb; split=> -[].
have Anotinq2 : A \notin q.+ by apply/negP; rewrite q1P => -[_ pPA].
rewrite q2P fsetUDl mem_fsetD1 //.
by rewrite fset_cons.
Qed.
Lemma exists_q (fs : formulas) (P : formula) :
exists q : pair,
((forall A : formula, A \in q.+ <-> A \in fs /\ |- P ~> A)
/\
q.- = fs `\` q.+)%type.
Proof.
have [q [q1P q2P]] := exists_q_seq fs P.
exists q; split=> //.
rewrite q2P; congr (_ `\` _).
apply/fsetP => /= A; apply/imfsetP/idP => /=.
by move=> [B Binfs ->].
by move=> Ainfs; exists A.
Qed.
Lemma lindenbaum (C : consts) (fs : formulas) (P : formula) (ns : formulas) :
constantsfs fs `<=` C ->
closedfs fs ->
(constantcountfs fs + quantifierdepthfs fs).*2 < #|` C| ->
P \in closurefs C fs ->
ns `<=` closurefs C fs ->
consistent ([fset P], ns) ->
exists2 q : pair,
(([fset P], ns) `p<=` q)
&& (modaldepthfs q.+ == modaldepth P)
& wfpair (closurefs C fs) q.
Proof.
move=> constsfsC clfs ltnC PinclCfs nsinclCfs consistPns.
have [[q1 q2] /= [q1P q2P]] := exists_q (closurefs C fs) P.
have Pinq1 : P \in q1 by rewrite q1P.
exists (q1, q2).
apply/andP; split.
(* (fset P, ns) `p<=` q *)
apply/andP; split => /=; first by rewrite fsub1set.
rewrite q2P.
apply/fsubsetDP; split=> //.
apply/fdisjointP => /= A /consistPns /=.
rewrite enum_fsetE enum_fset1 /= bigConj1 => npPA.
by apply/negP; rewrite q1P; apply: or_not_and; right.
(* modaldepthfs q.+ == modaldepth P *)
rewrite /= /modaldepthfs eqn_leq.
apply/andP; split; last by apply: leq_bigmax_list.
apply/bigmax_leqP_list => /= A.
rewrite q1P => -[_ pPA].
by apply: QRC1Proof_modaldepth.
split.
- (* q `<=` closurefs C fs *)
rewrite pair_fsubset /=.
rewrite q2P fsubsetDl andbT.
apply/fsubsetP => /= A Ainq1.
by have [/(_ Ainq1) []] := (q1P A).
- (* closedfs q *)
move: (closurefs_closed C clfs) => /allP /= clclfs.
rewrite pair_closedfs /=; apply/andP; split.
apply/allP => /= A; rewrite q1P => -[Aincl _].
by apply: clclfs.
apply/allP => /= A.
by rewrite q2P => /fsetDP [Aincl _]; apply: clclfs.
- (* consistent q *)
move=> A /=; rewrite q2P => /fsetDP [Ainclfs /negP Anotinq1] pq1A.
apply: Anotinq1; rewrite q1P; split=> //.
apply: (Cut _ pq1A).
rewrite QRC1Proof_bigConj => /= B.
by rewrite q1P => -[].
- (* maximal (closurefs C fs q) *)
rewrite maximalE /formulas_of_pair /=.
by rewrite q2P fsetUDl fsetDv fsetD0 fsubsetUr.
- (* witnessed q *)
apply/witnessedP => x A /=.
rewrite q2P => /fsetDP [xAinclfs /negP xAnotinq1].
have ltPxAC : #|` C `&` constants (P /\ All x A)| < #|` C|.
have /fsetIidPr -> : constants (P /\ All x A) `<=` C.
suff BC : forall B, B \in closurefs C fs -> constants B `<=` C.
rewrite -[constants _]/(constants P `|` constants (All x A)).
by rewrite fsubUset BC // BC.
move=> /= B Bincl.
move: constsfsC => /fsetUidPl <-.
apply: (fsubset_trans _ (constantsfs_closurefs C fs)).
by apply: in_constantsfs.
rewrite (leq_ltn_trans _ ltnC) //.
rewrite /= cardfsU -[constants A]/(constants (All x A)).
rewrite (leq_trans (leq_subr _ _)) //.
move: (constantcount_closurefs C fs) => /andP [_ leqccl].
rewrite -![#|` constants _|]/(constantcount _).
by rewrite -addnn leq_add // (leq_trans _ leqccl) // leq_bigmax_list.
move: (counting ltPxAC) => [c /fsetDP [cinC /=]].
rewrite inE negb_or => /andP [cnotinP cnotinxA]; exists c.
apply/fsetDP; split.
by rewrite substitution_closurefs.
apply/negP; rewrite q1P => -[Acincl pPAc].
apply: xAnotinq1; rewrite q1P; split=> //.
apply: (Const_AllIr _ cnotinP) => //.
apply: closed_fv.
by have := closurefs_closed C clfs => /allP /(_ P) /(_ PinclCfs).
Qed.
Definition RR (p q : pair) : bool :=
[forall A in [finType of p.-],
if val A is <> A' then [fset A'; <> A'] `<=` q.- else true
]
&&
[exists A in [finType of p.+ `&` q.-],
if val A is <> A' then true else false
].
Lemma RRP (p q : pair) :
reflect
(
(forall A, <> A \in p.- -> [fset A; <> A] `<=` q.-)
/\
(exists A, <> A \in p.+ `&` q.-)
)
(RR p q).
Proof.
apply: (iffP andP).
move=> [/forallP Hf /existsP [/= [[]] //= A Ainp1q2 _]].
split; last by exists A.
move=> B Binp2.
by have /implyP /(_ isT) := Hf [` Binp2].
move=> [Hf [A dAinp1q2]].
split; first by apply/forallP => [[[]]].
by apply/existsP; exists [` dAinp1q2].
Qed.
Lemma RR_trans : transitive RR.
Proof.
move=> q p r /RRP /= [RRpqf [Apq /fsetIP [Apqinp1 Apqinq2]]].
move=> /RRP /= [RRqrf [Aqr /fsetIP [Arqinq1 Arqinr2]]].
apply/RRP; split=> /=.
move=> A dAinp2; apply: RRqrf.
have /fsubsetP /(_ (<> A)) := RRpqf _ dAinp2.
by apply; rewrite !inE eqxx orbT.
exists Apq; apply/fsetIP; split=> //.
have /fsubsetP := RRqrf _ Apqinq2.
by apply; rewrite !inE eqxx orbT.
Qed.
Lemma RR_irr (p : pair) : consistent p -> ~ RR p p.
Proof.
move=> consP /RRP [_ [A /fsetIP [dAinp1 dAinp2]]].
apply: (consP (<> A)) => //.
by apply: bigConj_QRC1Proof.
Qed.
Lemma RR_subpair (p q r : pair) :
RR p q -> q `p<=` r -> RR p r.
Proof.
move=> /RRP [RRpqf [A /fsetIP [dAinp1 dAinq2]]] /andP [leqr1 leqr2].
apply/RRP; split.
move=> B dBinp2.
apply: (fsubset_trans _ leqr2).
by apply: RRpqf.
exists A; apply/fsetIP; split=> //.
by have /fsubsetP /(_ _) /(_ dAinq2) := leqr2.
Qed.
Definition is_diamond (A : formula) : bool :=
if A is <> B then true else false.
Lemma is_diamondP (A : formula) :
reflect (exists B : formula, A = <> B) (is_diamond A).
Proof.
case: A => /= *; apply: (iffP idP) => //; try by move=> [[]].
by eexists.
Qed.
Definition pre_diamond (A : formula) : formula :=
if A is <> B then B else T _.
Definition diamonds_pre_diamonds (fs : formulas) : formulas :=
[fset A in fs | is_diamond A]
`|` [fset pre_diamond A | A in fs & is_diamond A].
Lemma pair_existence (C : consts) (fs : formulas) (p : pair) (P : formula) :
constantsfs fs `<=` C ->
closedfs fs ->
(constantcountfs fs + quantifierdepthfs fs).*2 < #|` C| ->
wfpair (closurefs C fs) p ->
<> P \in p.+ ->
exists q : pair,
[/\ wfpair (closurefs C fs) q,
RR p q,
P \in q.+ &
modaldepthfs q.+ < modaldepthfs p.+
].
Proof.
move=> constsC clfs bound wfp DiamPinp1.
set r2 : formulas := <> P |` diamonds_pre_diamonds p.-.
(* <> P \in closure C fs *)
have DiamPinfs : <> P \in closurefs C fs.
suff /fsubsetP /(_ (<> P)) : p.+ `<=` closurefs C fs by apply.
apply: (fsubset_trans (p1inp _)).
by apply: wf_subset.
(* r2 <= closure C fs *)
have r2incl : r2 `<=` closurefs C fs.
rewrite fsubUset fsub1set DiamPinfs /=.
have p2incl : p.- `<=` closurefs C fs.
apply: (fsubset_trans (p2inp _)).
by apply: wf_subset.
rewrite fsubUset (fsubset_trans _ p2incl) ?fset_sub //=.
apply/fsubsetP => /= B /imfsetP /= [D].
rewrite inE => /andP[+ /is_diamondP [E eqDDiamE] ->].
rewrite {}eqDDiamE => DiamEinp2 /=.
apply: closurefsDiam.
by move: p2incl => /fsubsetP; apply.
(* r is consistent *)
have consr : consistent ([fset P], r2).
move=> A /=; rewrite fset_seq1 bigConj1.
move=> /fsetUP [/fset1P -> |].
by apply: Diam_irreflexive.
move=> /fsetUP [|].
rewrite in_fset inE => /= /andP[+ /is_diamondP [B eqADiamB]].
rewrite {}eqADiamB => DiamBinp2 pPDiamB.
apply: (wf_consistent wfp DiamBinp2).
have pDiamPDiamB : |- <> P ~> <> B.
apply: (Cut _ (Trans B)).
by apply: Nec.
apply: (Cut _ pDiamPDiamB).
by apply: bigConj_QRC1Proof.
move=> /imfsetP /= [B].
rewrite inE => /andP[+ /is_diamondP [D eqBDiamD]].
rewrite eqBDiamD => /= Dinp2 -> pPD.
apply: (wf_consistent wfp Dinp2).
apply: (Cut _ (Nec pPD)).
by apply: bigConj_QRC1Proof.
have := lindenbaum constsC clfs bound (closurefsDiam DiamPinfs) r2incl consr.
move=> [q /andP[rinq /eqP eqdepthq1P] wfq].
exists q; split=> //.
- (* p RR q *)
apply: (RR_subpair _ rinq).
apply/RRP; split.
move=> A DiamAinp2 /=.
apply/fsubsetP => /= B.
rewrite 3!inE => /orP [/eqP -> | /eqP ->].
apply/fsetUP; right; apply/fsetUP; right.
apply/imfsetP => /=.
exists (<> A) => //.
by rewrite inE; apply/andP.
apply/fsetUP; right; apply/fsetUP; left.
by rewrite in_fset inE; apply/andP.
exists P.
apply/fsetIP; split=> //=.
by apply/fsetUP; left; rewrite inE.
- (* P in q.+ *)
move: rinq => /andP [/fsubsetP /(_ P) /= + _].
by rewrite inE eqxx; apply.
- (* depth q.+ < depth p.+ *)
rewrite eqdepthq1P.
rewrite (@leq_trans (modaldepth (<> P))) //.
by apply: leq_bigmax_list.
Qed.
End Pairs.
Notation "p .+" :=
(@fst (formulas _) (formulas _) p) (at level 2, format "p .+").
Notation "p .-" :=
(@snd (formulas _) (formulas _) p) (at level 2, format "p .-").
Section Completeness.
Open Scope qsp_scope.
Open Scope fset.
Lemma canonical_model (sig : signature) (C : consts sig) (p : pair sig) :
consistent p ->
closedfs p ->
exists (WType MType : choiceType) (M : model sig WType MType),
True.
Proof.
move=> consistp clp.
set P := //\\ p.+.
set fs : formulas sig := P |` p.-.
have sizeC : (constantcountfs fs + quantifierdepthfs fs).*2 < #|` C|.
admit.
have fsC : constantsfs fs `<=` C by admit.
have clfs : closedfs fs by admit.
have Pinclfs : P \in closurefs C fs by admit.
have p2inclfs : p.- `<=` closurefs C fs by admit.
have consPp2 : consistent ([fset P], p.-).
move=> A /= Ainp2.
rewrite fset_seq1 bigConj1 => pPA.
by apply: (consistp _ Ainp2).
(* generate root *)
have := lindenbaum fsC clfs sizeC Pinclfs p2inclfs consPp2.
move=> [root /andP [psubroot /eqP depthrootP] wfroot].
Admitted.
End Completeness.
From Coq Require Import Program.Wf Classical.
From QRC1 Require Import Preamble Language QRC1 QRC1Equiv Closure.
From QRC1 Require Import KripkeSemantics.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Section Pairs.
Variable sig : signature.
Notation term := (term sig).
Notation ConstName := (ConstName sig).
Notation PredName := (PredName sig).
Notation formula := (formula sig).
Notation formulas := (formulas sig).
Notation consts := (consts sig).
Notation Var := (Var sig).
Local Open Scope qsp_scope.
Local Open Scope fset.
Definition pair : Type := formulas * formulas.
Notation "p .+" := (@fst formulas formulas p) (at level 2, format "p .+").
Notation "p .-" := (@snd formulas formulas p) (at level 2, format "p .-").
Coercion formulas_of_pair (p : pair) : {fset formula} := p.+ `|` p.-.
Lemma pair_fsubset (p : pair) (fs : formulas) :
p `<=` fs = (p.+ `<=` fs) && (p.- `<=` fs).
Proof. by case: p => [p1 p2] /=; rewrite fsubUset. Qed.
Lemma p1inp (p : pair) : p.+ `<=` p.
Proof. by apply: fsubsetU; rewrite fsubset_refl. Qed.
Lemma p2inp (p : pair) : p.- `<=` p.
Proof. by apply: fsubsetU; rewrite fsubset_refl orbT. Qed.
Definition subpair (p q : pair) : bool :=
(p.+ `<=` q.+) && (p.- `<=` q.-).
Infix "`p<=`" := subpair (at level 70).
Lemma subpairfs_trans (fs : formulas) (p q : pair) :
p `p<=` q -> q `<=` fs -> p `<=` fs.
Proof.
case: q; case: p => p1 p2 q1 q2 /andP /= [leqpq1 leqpq2].
move=> /fsubUsetP /= [leqq1fs leqq2fs].
apply/fsubUsetP => /=; split.
by rewrite (fsubset_trans leqpq1).
by rewrite (fsubset_trans leqpq2).
Qed.
Lemma subpair_trans (p q r : pair) :
p `p<=` q -> q `p<=` r -> p `p<=` r.
Proof.
case: r; case: q; case: p => p1 p2 q1 q2 r1 r2.
move=> /andP /= [leqpq1 leqpq2] /andP /= [leqqr1 leqqr2].
apply/andP => /=; split.
by rewrite (fsubset_trans leqpq1).
by rewrite (fsubset_trans leqpq2).
Qed.
Lemma pair_closedfs (p : pair) :
closedfs p = (closedfs p.+) && (closedfs p.-).
Proof.
apply/allP/andP => /=.
move=> closedp; split; apply/allP.
by move=> A Ainp1; apply: closedp; rewrite inE Ainp1.
by move=> A Ainp2; apply: closedp; rewrite inE Ainp2 orbT.
move=> /= [/allP closedp1 /allP closedp2] A /fsetUP [Ainp1 | Ainp2].
by apply: closedp1.
by apply: closedp2.
Qed.
Definition consistent (p : pair) : Prop :=
forall B : formula, B \in p.- -> ~ |- //\\ p.+ ~> B.
Definition maximal (fs : formulas) (p : pair) : bool :=
[forall A : fs, (val A \in p.+) || (val A \in p.-)].
Lemma maximalP (fs : formulas) (p : pair) :
reflect
(forall A : formula, A \in fs -> A \in p.+ \/ A \in p.-)
(maximal fs p).
Proof.
apply (iffP 'forall_orP) => /=.
move=> H A Ainfs; apply: (H [` Ainfs]).
by move=> H A; apply: H.
Qed.
Lemma maximalE (fs : formulas) (p : pair) :
maximal fs p = (fs `<=` p).
Proof.
apply/maximalP/fsubsetP.
move=> maxfs /= A Ainfs.
by rewrite in_fsetU; apply/orP; apply: maxfs.
move=> subfsp A Ainfs.
have := subfsp _ Ainfs.
by rewrite in_fsetU => /orP.
Qed.
Definition witnessed (p : pair) : bool :=
[forall B : p.-,
if val B is All x B' then
[exists c : ConstName, B'`[Var x <- Const c] \in p.-]
else true
].
Lemma witnessedP (p : pair) :
reflect
(forall (x : VarName) (A : formula), All x A \in p.- ->
exists c : ConstName, A`[Var x <- Const c] \in p.-
)
(witnessed p).
Proof.
apply: (iffP forallP) => /=.
move=> H x A xAinp2.
by have /= /existsP := H [` xAinp2].
move=> H [/= [] // x A xAinp2].
by apply/existsP; apply: H.
Qed.
Definition wfpair (fs : formulas) (p : pair) : Prop :=
[/\ p `<=` fs, closedfs p, consistent p, maximal fs p & witnessed p].
Lemma wf_subset (fs : formulas) (p : pair) :
wfpair fs p -> p `<=` fs.
Proof. by move=> []. Qed.
Lemma wf_consistent (fs : formulas) (p : pair) :
wfpair fs p -> consistent p.
Proof.
Proof. by move=> []. Qed.
(* Towards Lindenbaum *)
Lemma counting (C1 C2 : consts) :
#|` C1 `&` C2| < #|` C1| -> exists c, c \in C1 `\` C2.
Proof.
move=> lt; apply/fset0Pn; apply/eqP => /eqP.
rewrite -cardfs_eq0 cardfsD.
rewrite subn_eq0 => le.
by move: (leq_ltn_trans le lt); rewrite ltnn.
Qed.
(* We need classical logic for this lemma *)
(* https://coq.zulipchat.com/narrow/stream/237977-Coq-users/topic/LEM.20vs.20decidability *)
Lemma exists_q_seq (fs : seq formula) (P : formula) :
exists q : pair,
((forall A : formula, A \in q.+ <-> A \in fs /\ |- P ~> A)
/\
q.- = [fset p in fs] `\` q.+)%type.
Proof.
elim: fs.
exists (fset0, fset0); split=> /=.
by move=> A; rewrite in_fset0; split=> [|[]].
rewrite fsetD0.
by apply/fsetP => A; apply/idP/imfsetP => [|[] //]; rewrite in_fset0.
move=> A fs [q [q1P q2P]].
case: (classic (|- P ~> A)) => [pPA | npPA].
exists (A |` q.+, q.-); split=> /=.
move=> B; rewrite 3!inE.
by case: eqP => [-> | _ /=].
rewrite fset_cons q2P.
have [Ainfs | Anotinfs] := boolP (A \in fs).
have Ainq1 : A \in q.+by rewrite q1P.
rewrite (mem_fset1U Ainq1) mem_fset1U //.
by apply/imfsetP; exists A.
have Anotinfs_seq : A \notin [fset p | p in fs].
apply/imfsetP => /= -[B Binfs eqAB].
by move: Anotinfs => /negP; rewrite eqAB.
rewrite fsetDUr fsetU1K //.
rewrite fsetDUl fsetIUr fsetIDA.
rewrite disjoint_fsetI0; last by rewrite fdisjointX1.
rewrite fset0D fset0U.
by rewrite fsetIDA fsetIid.
exists (q.+, A |` q.-); split=> /=.
move=> B; rewrite q1P inE.
case: eqP => [-> | //].
by rewrite orTb; split=> -[].
have Anotinq2 : A \notin q.+ by apply/negP; rewrite q1P => -[_ pPA].
rewrite q2P fsetUDl mem_fsetD1 //.
by rewrite fset_cons.
Qed.
Lemma exists_q (fs : formulas) (P : formula) :
exists q : pair,
((forall A : formula, A \in q.+ <-> A \in fs /\ |- P ~> A)
/\
q.- = fs `\` q.+)%type.
Proof.
have [q [q1P q2P]] := exists_q_seq fs P.
exists q; split=> //.
rewrite q2P; congr (_ `\` _).
apply/fsetP => /= A; apply/imfsetP/idP => /=.
by move=> [B Binfs ->].
by move=> Ainfs; exists A.
Qed.
Lemma lindenbaum (C : consts) (fs : formulas) (P : formula) (ns : formulas) :
constantsfs fs `<=` C ->
closedfs fs ->
(constantcountfs fs + quantifierdepthfs fs).*2 < #|` C| ->
P \in closurefs C fs ->
ns `<=` closurefs C fs ->
consistent ([fset P], ns) ->
exists2 q : pair,
(([fset P], ns) `p<=` q)
&& (modaldepthfs q.+ == modaldepth P)
& wfpair (closurefs C fs) q.
Proof.
move=> constsfsC clfs ltnC PinclCfs nsinclCfs consistPns.
have [[q1 q2] /= [q1P q2P]] := exists_q (closurefs C fs) P.
have Pinq1 : P \in q1 by rewrite q1P.
exists (q1, q2).
apply/andP; split.
(* (fset P, ns) `p<=` q *)
apply/andP; split => /=; first by rewrite fsub1set.
rewrite q2P.
apply/fsubsetDP; split=> //.
apply/fdisjointP => /= A /consistPns /=.
rewrite enum_fsetE enum_fset1 /= bigConj1 => npPA.
by apply/negP; rewrite q1P; apply: or_not_and; right.
(* modaldepthfs q.+ == modaldepth P *)
rewrite /= /modaldepthfs eqn_leq.
apply/andP; split; last by apply: leq_bigmax_list.
apply/bigmax_leqP_list => /= A.
rewrite q1P => -[_ pPA].
by apply: QRC1Proof_modaldepth.
split.
- (* q `<=` closurefs C fs *)
rewrite pair_fsubset /=.
rewrite q2P fsubsetDl andbT.
apply/fsubsetP => /= A Ainq1.
by have [/(_ Ainq1) []] := (q1P A).
- (* closedfs q *)
move: (closurefs_closed C clfs) => /allP /= clclfs.
rewrite pair_closedfs /=; apply/andP; split.
apply/allP => /= A; rewrite q1P => -[Aincl _].
by apply: clclfs.
apply/allP => /= A.
by rewrite q2P => /fsetDP [Aincl _]; apply: clclfs.
- (* consistent q *)
move=> A /=; rewrite q2P => /fsetDP [Ainclfs /negP Anotinq1] pq1A.
apply: Anotinq1; rewrite q1P; split=> //.
apply: (Cut _ pq1A).
rewrite QRC1Proof_bigConj => /= B.
by rewrite q1P => -[].
- (* maximal (closurefs C fs q) *)
rewrite maximalE /formulas_of_pair /=.
by rewrite q2P fsetUDl fsetDv fsetD0 fsubsetUr.
- (* witnessed q *)
apply/witnessedP => x A /=.
rewrite q2P => /fsetDP [xAinclfs /negP xAnotinq1].
have ltPxAC : #|` C `&` constants (P /\ All x A)| < #|` C|.
have /fsetIidPr -> : constants (P /\ All x A) `<=` C.
suff BC : forall B, B \in closurefs C fs -> constants B `<=` C.
rewrite -[constants _]/(constants P `|` constants (All x A)).
by rewrite fsubUset BC // BC.
move=> /= B Bincl.
move: constsfsC => /fsetUidPl <-.
apply: (fsubset_trans _ (constantsfs_closurefs C fs)).
by apply: in_constantsfs.
rewrite (leq_ltn_trans _ ltnC) //.
rewrite /= cardfsU -[constants A]/(constants (All x A)).
rewrite (leq_trans (leq_subr _ _)) //.
move: (constantcount_closurefs C fs) => /andP [_ leqccl].
rewrite -![#|` constants _|]/(constantcount _).
by rewrite -addnn leq_add // (leq_trans _ leqccl) // leq_bigmax_list.
move: (counting ltPxAC) => [c /fsetDP [cinC /=]].
rewrite inE negb_or => /andP [cnotinP cnotinxA]; exists c.
apply/fsetDP; split.
by rewrite substitution_closurefs.
apply/negP; rewrite q1P => -[Acincl pPAc].
apply: xAnotinq1; rewrite q1P; split=> //.
apply: (Const_AllIr _ cnotinP) => //.
apply: closed_fv.
by have := closurefs_closed C clfs => /allP /(_ P) /(_ PinclCfs).
Qed.
Definition RR (p q : pair) : bool :=
[forall A in [finType of p.-],
if val A is <> A' then [fset A'; <> A'] `<=` q.- else true
]
&&
[exists A in [finType of p.+ `&` q.-],
if val A is <> A' then true else false
].
Lemma RRP (p q : pair) :
reflect
(
(forall A, <> A \in p.- -> [fset A; <> A] `<=` q.-)
/\
(exists A, <> A \in p.+ `&` q.-)
)
(RR p q).
Proof.
apply: (iffP andP).
move=> [/forallP Hf /existsP [/= [[]] //= A Ainp1q2 _]].
split; last by exists A.
move=> B Binp2.
by have /implyP /(_ isT) := Hf [` Binp2].
move=> [Hf [A dAinp1q2]].
split; first by apply/forallP => [[[]]].
by apply/existsP; exists [` dAinp1q2].
Qed.
Lemma RR_trans : transitive RR.
Proof.
move=> q p r /RRP /= [RRpqf [Apq /fsetIP [Apqinp1 Apqinq2]]].
move=> /RRP /= [RRqrf [Aqr /fsetIP [Arqinq1 Arqinr2]]].
apply/RRP; split=> /=.
move=> A dAinp2; apply: RRqrf.
have /fsubsetP /(_ (<> A)) := RRpqf _ dAinp2.
by apply; rewrite !inE eqxx orbT.
exists Apq; apply/fsetIP; split=> //.
have /fsubsetP := RRqrf _ Apqinq2.
by apply; rewrite !inE eqxx orbT.
Qed.
Lemma RR_irr (p : pair) : consistent p -> ~ RR p p.
Proof.
move=> consP /RRP [_ [A /fsetIP [dAinp1 dAinp2]]].
apply: (consP (<> A)) => //.
by apply: bigConj_QRC1Proof.
Qed.
Lemma RR_subpair (p q r : pair) :
RR p q -> q `p<=` r -> RR p r.
Proof.
move=> /RRP [RRpqf [A /fsetIP [dAinp1 dAinq2]]] /andP [leqr1 leqr2].
apply/RRP; split.
move=> B dBinp2.
apply: (fsubset_trans _ leqr2).
by apply: RRpqf.
exists A; apply/fsetIP; split=> //.
by have /fsubsetP /(_ _) /(_ dAinq2) := leqr2.
Qed.
Definition is_diamond (A : formula) : bool :=
if A is <> B then true else false.
Lemma is_diamondP (A : formula) :
reflect (exists B : formula, A = <> B) (is_diamond A).
Proof.
case: A => /= *; apply: (iffP idP) => //; try by move=> [[]].
by eexists.
Qed.
Definition pre_diamond (A : formula) : formula :=
if A is <> B then B else T _.
Definition diamonds_pre_diamonds (fs : formulas) : formulas :=
[fset A in fs | is_diamond A]
`|` [fset pre_diamond A | A in fs & is_diamond A].
Lemma pair_existence (C : consts) (fs : formulas) (p : pair) (P : formula) :
constantsfs fs `<=` C ->
closedfs fs ->
(constantcountfs fs + quantifierdepthfs fs).*2 < #|` C| ->
wfpair (closurefs C fs) p ->
<> P \in p.+ ->
exists q : pair,
[/\ wfpair (closurefs C fs) q,
RR p q,
P \in q.+ &
modaldepthfs q.+ < modaldepthfs p.+
].
Proof.
move=> constsC clfs bound wfp DiamPinp1.
set r2 : formulas := <> P |` diamonds_pre_diamonds p.-.
(* <> P \in closure C fs *)
have DiamPinfs : <> P \in closurefs C fs.
suff /fsubsetP /(_ (<> P)) : p.+ `<=` closurefs C fs by apply.
apply: (fsubset_trans (p1inp _)).
by apply: wf_subset.
(* r2 <= closure C fs *)
have r2incl : r2 `<=` closurefs C fs.
rewrite fsubUset fsub1set DiamPinfs /=.
have p2incl : p.- `<=` closurefs C fs.
apply: (fsubset_trans (p2inp _)).
by apply: wf_subset.
rewrite fsubUset (fsubset_trans _ p2incl) ?fset_sub //=.
apply/fsubsetP => /= B /imfsetP /= [D].
rewrite inE => /andP[+ /is_diamondP [E eqDDiamE] ->].
rewrite {}eqDDiamE => DiamEinp2 /=.
apply: closurefsDiam.
by move: p2incl => /fsubsetP; apply.
(* r is consistent *)
have consr : consistent ([fset P], r2).
move=> A /=; rewrite fset_seq1 bigConj1.
move=> /fsetUP [/fset1P -> |].
by apply: Diam_irreflexive.
move=> /fsetUP [|].
rewrite in_fset inE => /= /andP[+ /is_diamondP [B eqADiamB]].
rewrite {}eqADiamB => DiamBinp2 pPDiamB.
apply: (wf_consistent wfp DiamBinp2).
have pDiamPDiamB : |- <> P ~> <> B.
apply: (Cut _ (Trans B)).
by apply: Nec.
apply: (Cut _ pDiamPDiamB).
by apply: bigConj_QRC1Proof.
move=> /imfsetP /= [B].
rewrite inE => /andP[+ /is_diamondP [D eqBDiamD]].
rewrite eqBDiamD => /= Dinp2 -> pPD.
apply: (wf_consistent wfp Dinp2).
apply: (Cut _ (Nec pPD)).
by apply: bigConj_QRC1Proof.
have := lindenbaum constsC clfs bound (closurefsDiam DiamPinfs) r2incl consr.
move=> [q /andP[rinq /eqP eqdepthq1P] wfq].
exists q; split=> //.
- (* p RR q *)
apply: (RR_subpair _ rinq).
apply/RRP; split.
move=> A DiamAinp2 /=.
apply/fsubsetP => /= B.
rewrite 3!inE => /orP [/eqP -> | /eqP ->].
apply/fsetUP; right; apply/fsetUP; right.
apply/imfsetP => /=.
exists (<> A) => //.
by rewrite inE; apply/andP.
apply/fsetUP; right; apply/fsetUP; left.
by rewrite in_fset inE; apply/andP.
exists P.
apply/fsetIP; split=> //=.
by apply/fsetUP; left; rewrite inE.
- (* P in q.+ *)
move: rinq => /andP [/fsubsetP /(_ P) /= + _].
by rewrite inE eqxx; apply.
- (* depth q.+ < depth p.+ *)
rewrite eqdepthq1P.
rewrite (@leq_trans (modaldepth (<> P))) //.
by apply: leq_bigmax_list.
Qed.
End Pairs.
Notation "p .+" :=
(@fst (formulas _) (formulas _) p) (at level 2, format "p .+").
Notation "p .-" :=
(@snd (formulas _) (formulas _) p) (at level 2, format "p .-").
Section Completeness.
Open Scope qsp_scope.
Open Scope fset.
Lemma canonical_model (sig : signature) (C : consts sig) (p : pair sig) :
consistent p ->
closedfs p ->
exists (WType MType : choiceType) (M : model sig WType MType),
True.
Proof.
move=> consistp clp.
set P := //\\ p.+.
set fs : formulas sig := P |` p.-.
have sizeC : (constantcountfs fs + quantifierdepthfs fs).*2 < #|` C|.
admit.
have fsC : constantsfs fs `<=` C by admit.
have clfs : closedfs fs by admit.
have Pinclfs : P \in closurefs C fs by admit.
have p2inclfs : p.- `<=` closurefs C fs by admit.
have consPp2 : consistent ([fset P], p.-).
move=> A /= Ainp2.
rewrite fset_seq1 bigConj1 => pPA.
by apply: (consistp _ Ainp2).
(* generate root *)
have := lindenbaum fsC clfs sizeC Pinclfs p2inclfs consPp2.
move=> [root /andP [psubroot /eqP depthrootP] wfroot].
Admitted.
End Completeness.