QRC1.Closure

From mathcomp Require Import all_ssreflect finmap.
Require Import Program.Wf.

From QRC1 Require Import Preamble Language.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Formulas.

Variable sig : signature.
Notation term := (term sig).
Notation formula := (formula sig).
Notation ConstName := (ConstName sig).
Notation PredName := (PredName sig).
Notation Var := (Var sig).

Local Open Scope qsp_scope.
Local Open Scope fset.

Definition consts : Type := {fset ConstName}.
Definition formulas : Type := {fset formula}.

Definition constantcountfs (fs : formulas) : nat :=
  \max_(A <- fs) (constantcount A).

Definition quantifierdepthfs (fs : formulas) : nat :=
  \max_(A <- fs) (quantifierdepth A).

Definition modaldepthfs (fs : formulas) : nat :=
  \max_(A <- fs) (modaldepth A).

Definition depthfs (fs : formulas) : nat :=
  \max_(A <- fs) (depth A).

Definition closedfs (fs : formulas) : bool :=
  all (@closed _) fs.

Definition constantsfs (fs : formulas) : consts :=
  \bigcup_(A <- fs) (constants A).

Lemma in_constantsfs (A : formula) (fs : formulas) :
  A \in fs -> constants A `<=` constantsfs fs.
Proof. by move=> Ainfs; apply: bigfcup_sup. Qed.

Program Fixpoint closure (C : consts) (A : formula) {measure (depth A)}
    : formulas :=
  match A with
  | T => [fset T _]
  | Pred P ts => [fset T _; Pred ts]
  | A1 /\ A2 => (A1 /\ A2) |` closure C A1 `|` closure C A2
  | <> B => (<> B) |` closure C B
  | All x B => (All x B) |` \bigcup_(c <- C) (closure C B`[Var x <- Const c])
  end.
Next Obligation.
  by apply/leP; rewrite /= ltnS leq_maxl.
Defined.
Next Obligation.
  by apply/leP; rewrite /= ltnS leq_maxr.
Defined.
Next Obligation.
  by apply/leP; rewrite depth_sub.
Defined.

(* This lemma relies on the Defined proof obligations *)
Lemma closure_eq (C : consts) (A : formula) : closure C A =
  match A with
  | T => [fset T _]
  | Pred P ts => [fset T _; Pred ts]
  | A1 /\ A2 => (A1 /\ A2) |` closure C A1 `|` closure C A2
  | <> B => (<> B) |` closure C B
  | All x B => (All x B) |` \bigcup_(c <- C) (closure C B`[Var x <- Const c])
  end.
Proof.
  rewrite {1}/closure {1}/closure_func fix_sub_eq -/closure_func.
    by case: A.
  case=> /= C' B; case: B => //=.
  - by move=> A1 A2 f g eq1fg; rewrite !eq1fg.
  - by move=> A1 f g ->.
  - move=> x A1 f g eq1fg.
    congr fsetU; apply/fsetP => /= A'.
    apply/bigfcupP/bigfcupP.
      move=> [c cinC'true] A'inf.
      by exists c => //; rewrite -eq1fg.
    move=> [c cinC'true] A'ing.
    by exists c => //; rewrite eq1fg.
Qed.

Lemma closure_ind (C : consts) (P : formula -> formulas -> Prop) :
  (P (T _) [fset T _]) ->
  (forall Q ts, P (@Pred _ Q ts) [fset T _; Pred ts]) ->
  (forall A B,
      P A (closure C A) ->
      P B (closure C B) ->
    P (A /\ B) ((A /\ B) |` closure C A `|` closure C B)
  ) ->
  (forall A,
      P A (closure C A) ->
    P (<> A) (<> A |` closure C A)
  ) ->
  (forall x A,
      (forall c, c \in C ->
        P A`[Var x <- Const c] (closure C A`[Var x <- Const c])
      ) ->
    P (All x A) ((All x A) |` \bigcup_(c <- C) (closure C A`[Var x <- Const c]))
  ) ->
  forall A, P A (closure C A).
Proof.
  move=> HT HP HConj HDiam HAll A.
  move: (leqnn (depth A)); move: {2}(depth _) => maxdepth.
  elim: maxdepth A.
    case=> //=.
    by move=> *; apply: HP.
  move=> maxdepth IHdepth; case.
  - by move=> _; apply: HT.
  - by move=> *; apply: HP.
  - move=> A B /=; rewrite ltnS geq_max closure_eq => /andP [leqAmax leqBmax].
    by apply: HConj; apply: IHdepth.
  - move=> A /=; rewrite ltnS closure_eq => leqAmax.
    apply: HDiam.
    by apply: IHdepth.
  - move=> x A /=; rewrite ltnS closure_eq => leqAmax.
    apply: HAll => c cinC.
    apply: IHdepth.
    by rewrite depth_sub.
Qed.

Lemma closure_self (C : consts) (A : formula) : A \in closure C A.
Proof. by case: A => *; rewrite closure_eq !inE eqxx. Qed.

Lemma closure_closed_T (C : consts) :
  closedfs (closure C (T _)).
Proof.
  by rewrite closure_eq; apply/allP => A; rewrite inE => /eqP ->.
Qed.

Lemma closure_closed_Pred (C : consts) (P : PredName)
    (ts : (arity P).-tuple term) :
  closed (Pred ts) -> closedfs (closure C (Pred ts)).
Proof.
  move=> closedP; rewrite closure_eq.
  by apply/allP => A; rewrite 3!inE => /orP [|] /eqP ->.
Qed.

Lemma closedfs1 (A : formula) :
  closedfs [fset A] = closed A.
Proof.
  rewrite /closedfs; apply/allP => /=; case: ifP.
    by move=> clA B; rewrite inE => /eqP ->.
  by move=> nclA /(_ A); rewrite nclA inE eqxx => /(_ isT).
Qed.

Lemma closedfs_fsetU (fs1 fs2 : formulas) :
  closedfs (fs1 `|` fs2) = closedfs fs1 && closedfs fs2.
Proof. by rewrite /closedfs all_fsetU. Qed.

Lemma closure_closed (C : consts) (A : formula) :
  closed A -> closedfs (closure C A).
Proof.
  apply closure_ind => {A}.
  - by rewrite closure_closed_T.
  - by move=> P ts clP; apply: closure_closed_Pred.
  - move=> A B IHA IHB /= /[dup] clAB.
    rewrite 2!closedfs_fsetU closedE => /andP [/IHA -> /IHB ->].
    by rewrite closedfs1 2!andbT.
  - move=> A IHA /[dup] clDA.
    rewrite closedE closedfs_fsetU => /IHA ->.
    by rewrite closedfs1 andbT.
  - move=> x A IHA clxA.
    rewrite closedfs_fsetU => /=.
    apply/andP; split; first by rewrite closedfs1.
    apply/allP => /= B /bigfcupP [c /andP [cinC _] BinclAc].
    move: clxA; rewrite (closed_All _ _ c) => /IHA -/(_ cinC).
    by move=> /allP /(_ B) /(_ BinclAc).
Qed.

Definition closurefs (C : consts) (fs : formulas) : formulas :=
  \bigcup_(A <- fs) (closure C A).

Lemma closurefs_self (C : consts) (A : formula) (fs : formulas) :
  A \in fs -> A \in closurefs C fs.
Proof.
  move=> Ainfs; apply/bigfcupP => /=.
  exists A.
    by rewrite Ainfs.
  by rewrite closure_self.
Qed.

Lemma closurefs_closed (C : consts) (fs : formulas) :
  closedfs fs -> closedfs (closurefs C fs).
Proof.
  move=> /allP /= clfs.
  apply/allP => /= A /bigfcupP /= [B /andP [Binfs _] AinclosureB].
  move: (clfs _ Binfs) => /closure_closed => /(_ C) /allP /= clclosureB.
  by apply: clclosureB.
Qed.

Lemma closure_sub (A : formula) (x : VarName) (c : ConstName)
    (C : consts) :
  closure C A`[Var x <- Const c] =
    [fset D`[Var x <- Const c] | D in closure C A].
Proof.
  move: (leqnn (depth A)); move: {2}(depth _) => maxdepth.
  elim: maxdepth A x c.
    case=> //= x c.
      by rewrite closure_eq fsetmap1.
    by move=> P ts _; rewrite 2!closure_eq fsetmap2.
  move=> maxdepth IHdepth; case => /=.
  - by move=> *; rewrite closure_eq fsetmap1.
  - by move=> *; rewrite 2!closure_eq fsetmap2.
  - move=> A B x c /=; rewrite ltnS geq_max => /andP [leqAmax leqBmax].
    rewrite closure_eq [in RHS]closure_eq.
    by rewrite 2!fsetmapU fsetmap1 IHdepth // IHdepth.
  - move=> A x c; rewrite ltnS => leqAmax.
    rewrite closure_eq [in RHS]closure_eq.
    by rewrite fsetmapU fsetmap1 IHdepth.
  - move=> y A x c; rewrite ltnS => leqAmax.
    rewrite [in RHS]closure_eq.
    rewrite fsetmapU fsetmap1 /=.
    rewrite fsetmap_bigfcup.
    case: eqP => [[->] | neqyx]; rewrite closure_eq; congr fsetU.
      apply/fsetP => /= B; apply/bigfcupP/bigfcupP => /=.
        move=> [c' c'inCT] BinclAc'.
        exists c' => //.
        rewrite -IHdepth ?depth_sub //.
        by rewrite sub_notfree ?notfv_sub.
      move=> [c' c'inCT].
      rewrite -IHdepth ?depth_sub //.
      rewrite sub_notfree ?notfv_sub // => BinclAc'.
      by exists c'.
    have neqxy : x <> y by move=> eqxy; move: neqyx; rewrite eqxy.
    apply/fsetP => /= B; apply/bigfcupP/bigfcupP => /=.
      move=> [c' c'inCT].
      rewrite sub_ConstC // IHdepth ?depth_sub // => Bincl.
      by exists c'.
    move=> [c' c'inCT Bin]; exists c' => //.
    by rewrite sub_ConstC // IHdepth ?depth_sub.
Qed.

Lemma constantcount_closure (C : consts) (A : formula) :
  constantcount A <= constantcountfs (closure C A)
    <= constantcount A + quantifierdepth A.
Proof.
  apply/andP; split.
    by apply: leq_bigmax_list; apply: closure_self.
  apply/bigmax_leqP_list => /=.
  elim: A.
  - by rewrite closure_eq /= addn0 => B /fset1P ->.
  - by move=> P ts; rewrite closure_eq /= addn0 => B /fset2P [-> | ->].
  - move=> A IHA B IHB; rewrite closure_eq => D /fsetUP[/fsetUP [/fset1P ->|]|].
    + by rewrite leq_addr.
    + move=> DinclA.
      rewrite (leq_trans (IHA _ DinclA)) //.
      apply: leq_add; last by rewrite leq_maxl.
      by rewrite constantcount_Conjl.
    + move=> DinclB.
      rewrite (leq_trans (IHB _ DinclB)) //.
      apply: leq_add; last by rewrite leq_maxr.
      by rewrite constantcount_Conjr.
  - move=> A IHA; rewrite closure_eq => B /fsetUP [/fset1P -> | BinclA].
      by rewrite leq_addr.
    by rewrite constantcount_Diam /= IHA.
  - move=> y A IHA; rewrite closure_eq => B /fsetUP [/fset1P -> |].
      by rewrite leq_addr.
    move=> /bigfcupP [c /andP [cinC _]].
    rewrite closure_sub => /imfsetP /= [B' B'inclA ->].
    have /andP [_ leq_ccB'c] := constantcount_sub y c B'.
    rewrite (leq_trans leq_ccB'c) // addnS ltnS.
    by rewrite (leq_trans (IHA _ B'inclA)).
Qed.

Lemma constantcount_closurefs (C : consts) (fs : formulas) :
  constantcountfs fs <= constantcountfs (closurefs C fs)
    <= constantcountfs fs + quantifierdepthfs fs.
Proof.
  rewrite /constantcountfs /quantifierdepthfs; apply/andP; split.
    apply /bigmax_leqP_list => A Ainfs.
    by apply: leq_bigmax_list; apply: closurefs_self.
  apply/bigmax_leqP_list => /= A /bigfcupP /= [B /andP [Binfs _] AinclB].
  have /andP [_] := constantcount_closure C B.
  rewrite /constantcountfs => /bigmax_leqP_list /(_ A) /(_ AinclB) leqAB.
  by rewrite (leq_trans leqAB) // leq_add //; apply: leq_bigmax_list.
Qed.

Lemma closureT (C : consts) (A : formula) :
    (exists c, c \in C) ->
  T sig \in closure C A.
Proof.
  move=> [c cinC].
  apply closure_ind => {A}.
  - by rewrite inE.
  - by move=> *; rewrite 2!inE.
  - by move=> A B _ IHB; rewrite inE IHB orbT.
  - by move=> A IHA; rewrite inE IHA orbT.
  - move=> x A IHA; rewrite 2!inE /=.
    apply/bigfcupP; exists c.
      by rewrite cinC.
    by apply: IHA.
Qed.

Lemma closureConjl (C : consts) (A B : formula) :
  A \in closure C (A /\ B).
Proof. by rewrite closure_eq 2!inE closure_self orbT. Qed.

Lemma closureConjr (C : consts) (A B : formula) :
  B \in closure C (A /\ B).
Proof. by rewrite closure_eq 2!inE closure_self orbT. Qed.

Lemma closureConj_in (C : consts) (A B D : formula) :
  (A /\ B) \in closure C D -> A \in closure C D /\ B \in closure C D.
Proof.
  apply closure_ind.
  - by rewrite inE.
  - by move=> P ts; rewrite 3!inE.
  - move=> E F IHE IHF; rewrite 8!inE.
    move=> /orP [| /IHF [-> ->]]; last by rewrite 2!orbT.
    move=> /orP [/eqP [-> ->] | /IHE [-> ->]]; last by rewrite 2!orbT.
    by rewrite 2!closure_self 2!orbT.
  - by move=> E IHE; rewrite 5!inE => /= /IHE [-> ->]; rewrite 2!orbT.
  - move=> x E IHE; rewrite 5!inE => /= /bigfcupP /= [c /andP [+ _]].
    move=> /[dup] cinC /IHE /[apply] -[AinclEc BinclEc].
    by split; apply/orP; right; apply/bigfcupP; exists c; rewrite ?cinC.
Qed.

Lemma closureConj_inl (C : consts) (A B D : formula) :
  (A /\ B) \in closure C D -> A \in closure C D.
Proof. by move=> /closureConj_in []. Qed.

Lemma closureConj_inr (C : consts) (A B D : formula) :
  (A /\ B) \in closure C D -> B \in closure C D.
Proof. by move=> /closureConj_in []. Qed.

Lemma closureDiam (C : consts) (A : formula) :
  A \in closure C (<> A).
Proof. by rewrite closure_eq inE closure_self orbT. Qed.

Lemma substitution_closureAll (C : consts) (c : ConstName) (x : VarName)
    (A : formula) :
  c \in C -> A`[Var x <- Const c] \in closure C (All x A).
Proof.
  move=> cinC; rewrite closure_eq.
  apply/fset1UP; right.
  apply/bigfcupP; exists c; first by rewrite cinC.
  by apply: closure_self.
Qed.

Lemma closurefs_fsetU (C : consts) (fs1 fs2 : formulas) :
  closurefs C (fs1 `|` fs2) = (closurefs C fs1) `|` (closurefs C fs2).
Proof.
  rewrite /closurefs big_fsetU //=.
  by move=> X; rewrite fsetUid.
Qed.

Lemma closure_idempotent (C : consts) (A : formula) :
  closurefs C (closure C A) = closure C A.
Proof.
  apply closure_ind => {A}.
  - by rewrite /closurefs big_seq_fset1 closure_eq.
  - move=> P ts.
    apply/fsetP => /= A; apply/bigfcupP/fset2P => /=.
      move=> [B]; rewrite 3!inE => /orP [/orP [/eqP -> | /eqP ->] | //].
        by rewrite closure_eq inE => /eqP ->; left.
      by rewrite closure_eq => /fset2P.
    move=> [-> | ->].
      exists (T sig).
        by rewrite 2!inE eqxx.
      by rewrite closure_eq inE.
    exists (Pred ts).
      by rewrite 3!inE eqxx orbT.
    by rewrite closure_eq 3!inE eqxx orbT.
  - move=> A B IHA IHB.
    rewrite 2!closurefs_fsetU IHA IHB.
    rewrite /closurefs big_seq_fset1 closure_eq.
    by rewrite -fsetUA -[_ |` _ `|` _]fsetUA -fsetUA fsetUid.
  - move=> A IHA.
    rewrite closurefs_fsetU IHA.
    rewrite /closurefs big_seq_fset1 closure_eq.
    by rewrite -fsetUA fsetUid.
  - move=> x A IHA.
    rewrite closurefs_fsetU.
    rewrite {1}/closurefs big_seq_fset1 closure_eq.
    rewrite -fsetUA.
    suff /fsetUidPl -> :
        closurefs C (\bigcup_(c <- C) closure C A`[Var x <- Const c])
          `<=` \bigcup_(c <- C) closure C A`[Var x <- Const c]
      by [].
    apply/bigfcupsP => /= B /bigfcupP [c /andP [cinC _] BinclAc _].
    apply/fsubsetP => /= E EinclB.
    apply/bigfcupP.
    exists c; first by rewrite cinC.
    rewrite -IHA //.
    apply/bigfcupP => /=.
    by exists B; first by rewrite BinclAc.
Qed.

Lemma closure_closure (C : consts) (A B : formula) :
  A \in closure C B -> closure C A `<=` closure C B.
Proof.
  move=> AinclB.
  rewrite -[closure _ B]closure_idempotent.
  by apply: bigfcup_sup.
Qed.

Lemma closure_closurefs (C : consts) (A : formula) (fs : formulas) :
  A \in closurefs C fs -> closure C A `<=` closurefs C fs.
Proof.
  move=> /bigfcupP /= [B /andP [Binfs _] AinclB].
  apply: (fsubset_trans (closure_closure AinclB)).
  by apply: bigfcup_sup.
Qed.

Lemma closurefsDiam (C : consts) (A : formula) (fs : formulas) :
  <> A \in closurefs C fs -> A \in closurefs C fs.
Proof.
  move=> /closure_closurefs /fsubsetP.
  by apply; apply: closureDiam.
Qed.

Lemma substitution_closurefs (C : consts) (x : VarName) (A : formula)
    (c : ConstName) (fs : formulas) :
    c \in C ->
    All x A \in closurefs C fs ->
  A`[Var x <- Const c] \in closurefs C fs.
Proof.
  move=> cinC xAinclfs.
  have /fsubsetP := closure_closurefs xAinclfs.
  by apply; apply: substitution_closureAll.
Qed.

Lemma constantsfs_closure (C : consts) (A : formula) :
  constantsfs (closure C A) `<=` C `|` constants A.
Proof.
  elim: A.
  - rewrite closure_eq /= fsetU0.
    by rewrite /constantsfs big_seq_fsetE /= big_fset1 /= fsub0set.
  - move=> P ts; rewrite closure_eq.
    rewrite /constantsfs big_fsetU1 /=; last by rewrite inE.
    by rewrite fset0U big_seq_fsetE /= big_fset1 /= fsubsetUr.
  - move=> A /bigfcupsP /= IHA B /bigfcupsP /= IHB; rewrite closure_eq.
    apply/bigfcupsP => /= D.
    rewrite 3!inE => /orP [/orP [/eqP -> /= | DinclA] | DinclB] _.
    + by rewrite fsubsetUr.
    + apply: (fsubset_trans (IHA _ DinclA isT)).
      by rewrite fsetUA fsubsetUl.
    + apply: (fsubset_trans (IHB _ DinclB isT)).
      by rewrite [constants _ `|` _]fsetUC fsetUA fsubsetUl.
  - move=> A /bigfcupsP /= IHA; rewrite closure_eq.
    apply/bigfcupsP => /= B.
    rewrite 2!inE => /orP [/eqP -> /= | BinclA] _.
      by rewrite fsubsetUr.
    by apply: IHA.
  - move=> x A /bigfcupsP /= IHA; rewrite closure_eq.
    apply/bigfcupsP => /= B.
    rewrite 2!inE => /orP [/eqP -> /= | /bigfcupP [c /andP [cinC _] Bincl]] _.
      by rewrite fsubsetUr.
    have [BinclA | BnotinclA] := boolP (B \in closure C A).
      by apply: IHA.
    move: Bincl; rewrite closure_sub => /imfsetP /= [B' B'inclA ->].
    rewrite constants_sub_Const.
    case: ifP => _; last by apply: IHA.
    rewrite fsubUset IHA // andbT.
    by apply: fsubsetU; rewrite fsub1set cinC.
Qed.

Lemma constantsfs_closurefs (C : consts) (fs : formulas) :
  constantsfs (closurefs C fs) `<=` C `|` constantsfs fs.
Proof.
  apply/bigfcupsP =>/=A /bigfcupP/=[B /andP[Binfs _] /in_constantsfs subAclB] _.
  apply: (fsubset_trans subAclB).
  apply: (fsubset_trans (constantsfs_closure _ _)).
  by apply: fsetUS; apply: in_constantsfs.
Qed.

End Formulas.