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.