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.