Section TechnicalLemmas.

Require Import Syntax.
Require Import Model.
Require Import ProofSystem.
Require Import Setoid.
Require Import Classical.

(**********************************************************************************************************************)
(* Some techinical lemmas that should be true. These have not been proven in Coq yet, but some do have a paper and    *)
(*                                              pencil proof.                                                         *)
(* Some are actually not provable in Coq because we cannnot define mu and models as inductive. This is because they   *)
(*                are mutually recursive, yet one is of sort Set while the other is of sort Prop.                     *)
(**********************************************************************************************************************)

(*
This allows us to treat functions as set-theoretic, as far as equality is concerned. This makes sense, given that we are trying to model a set-theoretic model.
*)
Axiom function_same : forall (A B : Set) (f g : A -> B), (forall a : A, f a = g a) -> f = g.

(*
This says that it shouldn't matter whether we extend v, and then interpret a term, or if we interpret the term, and then extend that.
Should be provable by induction over mu, which is sadly impossible in the current code.
*)
Axiom mu_same : forall (M : focal_model) (w w' : W M) (l : lt M w w') (v : var -> D (s M w)) (tau : term),
  d_Eq (s M w') (extend_d_lt M w w' l (mu M w v tau)) (mu M w' (extend_v M w w' l v) tau).

(*
This tells us that if we have a formula without x free in it, then we can make x map to anything in our valuation function.
Should be provable by induction over derivations of models.
*)
Axiom replacement : forall (M : focal_model) (w : W M) (v : var -> D (s M w)) (x : var) (d : D (s M w)) (phi : formula),
  is_true(notfree_in_formula x phi) -> (models M w v phi <-> models M w (subst_map M w v x d) phi).

(*
This tells us that we can substitute for any non-free variable in the valuation function, and it won't affect mu.
Should be provable by induction over mu.
*)
Axiom replacement_term : forall (M : focal_model) (w : W M) (v : var -> D (s M w)) (x : var) (d : D (s M w)) (tau : term),
                           is_true(notfree_in_term x tau) -> ((mu M w v tau) = (mu M w (subst_map M w v x d) tau)).

(*
Substituting in the valuation function and in the formula does the same thing.
Again, provable by induction over derivations of models.
*)
Axiom pushback_subst : forall (M : focal_model) (w : W M) (v : var -> D (s M w)) (x : var) (tau : term) (phi : formula),
  (models M w (subst_map M w v x (mu M w v tau)) phi) <-> (models M w v (subst x tau phi)).

(*
This tells us that we can either extend v by p, then interpret a term; or we can interpret the term, then extend by p', as long as p' and p are equivalent.
*)
Axiom interpret_extend_A : forall (M : focal_model) (w w' : W M) (p p' : P M) (a : A M p w w') (a' : A M p' w w') (tau : term) (v : var -> D (s M w)),
                             p_Eq M p p' -> d_Eq (s M w') (mu M w' (extend_v_A M w w' p a v) tau) (extend_d_A M w w' p' a' (mu M w v tau)).

(*
This says that we can use two D-equivalent valuation functions and we should get the same results from models.
*)
Axiom models_v_d_Eq : forall (M : focal_model) (w : W M) (v v' : var -> D (s M w)) (phi : formula), (forall (y : var), d_Eq (s M w) (v y) (v' y)) -> (models M w v phi <-> models M w v' phi).

(*
This says that it doesn't matter if we extend a valuation function that has a substitution or if we extend the element that is getting substituted in and the valuation function that it is gettting substituted in.
*)
Axiom extend_v_subst : forall (M : focal_model) (w w' : W M) (l : lt M w w') (v : var -> D (s M w)) (x : var) (d : D (s M w)) (variable : var),
(extend_v M w w' l (subst_map M w v x d) variable) = (subst_map M w' (extend_v M w w' l v) x (extend_d_lt M w w' l d) variable).

(*
The following two axioms are provable on pencil-and-paper by induction over
tau and by using monotonicity.
They allow us to move up in worlds without changing our principal.
*)
Axiom mu_pi_same : forall (M : focal_model) (w w' : W M) (v : var -> D (s M w))
                          (l : lt M w w') (tau : term),
                     p_Eq M
                          (coerce_d_to_p M w (mu M w v tau))
                          (coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau)).

Axiom mu_pi_same_A : forall (M : focal_model) (w w' : W M) (v : var -> D (s M w))
                            (p : P M) (a : A M p w w') (tau : term),
                       p_Eq M
                            (coerce_d_to_p M w (mu M w v tau))
                            (coerce_d_to_p M w' (mu M w' (extend_v_A M w w' p a v) tau)).

(**********************************************************************************************************************)
(* Some Lemmas, defitions, and Ltac related to connected proofs. These are used extensively below, but nowhere else   *)
(*                                                     in the code.                                                   *)
(**********************************************************************************************************************)

(*
Ltac to deal with the common cases in connections.
*)
Ltac connected :=
  repeat match goal with
           | [|- ?W = ?W ] => trivial
           | [|- True] => trivial
           | [H : True |- _] => clear H
           | [H : connected _ _ _ _ |- _ ] => destruct H
           | [H : connection ?M ?P ?W ?U |- connected ?M ?P ?W ?U] => exists H; trivial
           | [H : ?W = ?U |- connected ?M ?P ?W ?U ] => exists (eqw M P W U H); trivial
           | [|- (connected ?M ?P ?W ?W)] => assert (W = W)
           | [H : lt ?M ?W ?U, H0 : connection ?M ?P ?U ?V |- connected ?M ?P ?W ?V ] => exists (lte M P W V U H H0); trivial
           | [H : A ?M ?P ?W ?U, H0 : connection ?M ?P ?U ?V |- connected ?M ?P ?W ?V ] => exists (ltp M P W V U H H0); trivial
           | [H : lt ?M ?U ?W, H0 : connection ?M ?P ?U ?V |- connected ?M ?P ?W ?V ] => exists (gte M P W V U H H0); trivial
           | [H : A ?M ?P ?U ?W, H0 : connection ?M ?P ?U ?V |- connected ?M ?P ?W ?V ] => exists (gtp M P W V U H H0); trivial
           | [H : connection ?M ?P ?W ?U |- connected ?M ?P ?U ?W ] => exists (con_symm M P U W H); trivial
           | [H : connection ?M ?P ?W ?U, H0 : connection ?M ?P ?U ?V |- connected ?M ?P ?W ?V ] => exists (con_trans M P W V U H H0); trivial
           | [H : ?W = ?U |- connected ?M ?P ?V ?U ] => assert (connected M P U U); connected
           | [H : ?W = ?U |- connected ?M ?P ?V ?W ] => assert (connected M P W W); connected
   end.

(*
Connections without the explicit symmetry and transitivity. Used in some proofs where the simplar structure is necessary.
Later, we prove that the this is equivalent to the origifocal connection.
*)
Inductive connection' (M : focal_model) (p : P M) (w w' : W M) : Set :=
  | eqw' : w = w' -> connection' M p w w'
  | lte' : forall w'' : W M, lt M w w'' -> connection' M p w'' w' -> connection' M p w w'
  | ltp' : forall w'' : W M, A M p w w'' -> connection' M p w'' w' -> connection' M p w w'
  | gte' : forall w'' : W M, lt M w'' w -> connection' M p w'' w' -> connection' M p w w'
  | gtp' : forall w'' : W M, A M p w'' w -> connection' M p w'' w' -> connection' M p w w'.

(*
A definiton of connected, with connection's instead of connections.
*)
Definition connected' (M : focal_model) (p : P M) (w w' : W M) : Prop := exists c : connection' M p w w', True.

(*
Ltac for dealing with connected'. Based on the connected Ltac above.
*)
Ltac connected' :=
  repeat match goal with
           | [|- ?W = ?W ] => trivial
           | [|- True] => trivial
           | [H : True |- _] => clear H
           | [H : connected' _ _ _ _ |- _ ] => destruct H
           | [H : connection' ?M ?P ?W ?U |- connected' ?M ?P ?W ?U] => exists H; trivial
           | [H : ?W = ?U |- connected' ?M ?P ?W ?U ] => exists (eqw' M P W U H); trivial
           | [|- (connected' ?M ?P ?W ?W)] => assert (W = W)
           | [H : lt ?M ?W ?U, H0 : connection' ?M ?P ?U ?V |- connected' ?M ?P ?W ?V ] => exists (lte' M P W V U H H0); trivial
           | [H : A ?M ?P ?W ?U, H0 : connection' ?M ?P ?U ?V |- connected' ?M ?P ?W ?V ] => exists (ltp' M P W V U H H0); trivial
           | [H : lt ?M ?U ?W, H0 : connection' ?M ?P ?U ?V |- connected' ?M ?P ?W ?V ] => exists (gte' M P W V U H H0); trivial
           | [H : A ?M ?P ?U ?W, H0 : connection' ?M ?P ?U ?V |- connected' ?M ?P ?W ?V ] => exists (gtp' M P W V U H H0); trivial
           | [H : ?W = ?U |- connected' ?M ?P ?V ?U ] => assert (connected' M P U U); connected'
           | [H : ?W = ?U |- connected' ?M ?P ?V ?W ] => assert (connected' M P W W); connected'
   end.

(*
Reflexivity of connected'.
*)
Lemma connected'_refl : forall (M : focal_model) (p : P M) (w : W M), connected' M p w w.
Proof.
  intros. assert (w = w). trivial. exists (eqw' M p w w H). trivial.
Qed.

(*
Transitivity of connected'. This is used in the proof of symmetry, interestingly enough.
*)
Lemma connected'_trans : forall (M : focal_model) (p : P M) (w w' w'': W M),
                           connected' M p w w' -> connected' M p w' w'' -> connected' M p w w''.
Proof.
  intros.
  connected'.
  induction x0; connected'.
  rewrite e. connected'.
  assert (connected' M p w''0 w''). apply IHx0. exact x. connected'.
  assert (connected' M p w''0 w''). apply IHx0. exact x. connected'.
  assert (connected' M p w''0 w''). apply IHx0. exact x. connected'.
  assert (connected' M p w''0 w''). apply IHx0. exact x. connected'.
Qed.

(*
Symmetry of connected'. Note the use of transitivity.
*)
Lemma connected'_symm : forall (M : focal_model) (p : P M) (w w' : W M),
                          connected' M p w w' -> connected' M p w' w.
Proof.
  intros.
  connected'; induction x.
  assert (w' = w). symmetry; exact e. exists (eqw' M p w' w H). trivial.
  assert (connected' M p w'' w). assert (w = w). trivial. exists (gte' M p w'' w w l (eqw' M p w w H)). trivial.
    apply connected'_trans with (w' := w''). exact IHx. exact H.
  assert (connected' M p w'' w). assert (w = w). trivial. exists (gtp' M p w'' w w a (eqw' M p w w H)). trivial.
    apply connected'_trans with (w' := w''). exact IHx. exact H.
  apply connected'_trans with (w' := w''). exact IHx. assert (w = w). trivial. exists (lte' M p w'' w w l (eqw' M p w w H)). trivial.
  apply connected'_trans with (w' := w''). exact IHx. assert (w =w ). trivial. exists (ltp' M p w'' w w a (eqw' M p w w H)). trivial.
Qed.

(*
Equivalence of connected and connected'.
*)
Theorem connected_connected' : forall (M : focal_model) (p : P M) (w w' : W M),
                                 connected M p w w' <-> connected' M p w w'.
Proof.
  split; intros.
  destruct H; clear H. induction x; connected'.
    apply connected'_symm. exists x0. trivial.
    apply connected'_trans with (w' := w''). exists x0. trivial. exists x. trivial.
  destruct H; clear H. induction x; connected.
Qed.

(**********************************************************************************************************************)
(*               The next three lemmas prove that the connected relation is an equivalence relation.                  *)
(**********************************************************************************************************************)

(*
Reflexivity
*)
Lemma connected_refl : forall (M : focal_model) (p : P M), reflexive _ (connected M p).
Proof.
  unfold reflexive; intros. assert (x = x). trivial. connected.
Qed.

(*
Symmetry
*)
Lemma connected_symm : forall (M : focal_model) (p : P M), symmetric _ (connected M p).
Proof.
  unfold symmetric; intros. connected.
Qed.

(*
Transitivity
*)
Lemma connected_trans : forall (M : focal_model) (p : P M), transitive _ (connected M p).
Proof.
  unfold transitive; intros. connected.
Qed.
(**********************************************************************************************************************)
(*              The next three lemmas prove that the equiv_listD relation is an equivalence relation.                 *)
(**********************************************************************************************************************)

(*
Reflexivity
*)
Theorem equiv_listD_refl : forall (M : fo_model), reflexive _ (equiv_listD M).
Proof.
  unfold reflexive; intros.
  induction x as [| d x'].
  (* x = nil *)
  simpl. trivial.
  (* x = d :: x' *)
  simpl. split.
  (* Part d_Eq M d d *)
  reflexivity.
  (* Part equiv_listD M x' x' *)
  apply IHx'.
Qed.

(*
Symmetry
*)
Theorem equiv_listD_symm : forall (M : fo_model), symmetric _ (equiv_listD M).
Proof.
  unfold symmetric; intros.
  generalize dependent x.
  induction y.
  induction x.
  intros. simpl. trivial.
  intros. simpl. contradiction.
  intros. induction x.
  simpl. contradiction.
  simpl. simpl in H. split.
  apply equiv_symm. apply H. apply IHy. apply H.
Qed.

(*
This allows us to do induction on three lists simultaneously. It is only used in the below proof of transitivity.
*)
Lemma list_triple_ind : forall (A : Set) (P : list A -> list A -> list A -> Prop),
                          P nil nil nil ->
                          (forall (l : list A), P nil nil l) ->
                          (forall (l : list A), P nil l nil) ->
                          (forall (l : list A), P l nil nil) ->
                          (forall (a b : A) (l1 l2 : list A), P nil l1 l2 -> P nil (a :: l1) (b :: l2)) ->
                          (forall (a b : A) (l1 l2 : list A), P l1 nil l2 -> P (a :: l1) nil (b :: l2)) ->
                          (forall (a b : A) (l1 l2 : list A), P l1 l2 nil -> P (a :: l1) (b :: l2) nil) ->
                          (forall (a b c : A) (l1 l2 l3 : list A), P l1 l2 l3 -> P (a :: l1) (b :: l2) (c :: l3)) ->
                          forall (l1 l2 l3: list A), P l1 l2 l3.
Proof.
  induction l1.
  induction l2.
  auto.
  induction l3; auto.
  induction l2; induction l3; auto.
Qed.

(*
Transitivity
*)
Theorem equiv_listD_trans : forall (M : fo_model), transitive _ (equiv_listD M).
Proof.
  unfold transitive; intros.
  apply (list_triple_ind (D M) (fun x y z => equiv_listD M x y -> equiv_listD M y z -> equiv_listD M x z)) with (l1 := x) (l2 := y) (l3 := z); auto.
  intros; simpl; tauto.
  intros. simpl in H3. inversion H3.
  intros. simpl in H1; simpl in H2; simpl in H3; simpl.
  split.
  transitivity b. apply H2. apply H3.
  apply H1. apply H2. apply H3.
Qed.

(**********************************************************************************************************************)
(*                  The next three lemmas prove that the p_Eq relation is an equivalence relation.                    *)
(**********************************************************************************************************************)

(*
Reflexivity
*)
Theorem p_Eq_refl : forall (M : focal_model) (p1 : P M),
                      p_Eq M p1 p1.
Proof.
  intros.
  unfold p_Eq.
  intros. reflexivity.
Qed.

(*
Symmetry
*)
Theorem p_Eq_symm : forall (M : focal_model) (p1 p2 : P M),
                      p_Eq M p1 p2 -> p_Eq M p2 p1.
Proof.
  intros. unfold p_Eq. intros.
  unfold p_Eq in H. apply equiv_symm. apply H.
Qed.

(*
Transitivity
*)
Theorem p_Eq_trans : forall (M : focal_model) (p1 p2 p3 : P M),
                       p_Eq M p1 p2 -> p_Eq M p2 p3 -> p_Eq M p1 p3.
Proof.
  intros; unfold p_Eq; intros.
  transitivity (coerce_p_to_d M w p2).
  unfold p_Eq in H; apply H.
  unfold p_Eq in H0; apply H0.
Qed.

(**********************************************************************************************************************)
(*                   Some technical lemmas that we have proven to be true, at least modulo the above.                 *)
(**********************************************************************************************************************)

Lemma extend_v_self : forall (M : focal_model) (w : W M) (l : lt M w w)
                             (v : var -> D (s M w)) (x : var),
                        v x = extend_v M w w l v x.
Proof.
  intros; unfold extend_v.
  rewrite extend_d_once. trivial.
Qed.

(*
This tells us that, since var_dec x x is always true, if var_dec x x then a else b will always evaluate to a.
Proof due to Adam Chilpala on the Coq-club mailing list.
*)
Lemma var_dec_if : forall (x : var) (A : Set) (a b : A), (if var_dec x x then a else b) = a.
Proof.
  intros.
  destruct (var_dec x x); tauto.
Qed.

(*
This allows us to rebuild a $\Sigma$ type from it's projections.
Proof due to Adam Chilpala on the Coq-club mailing list.
*)
Lemma proj1_proj2_exist : forall (A : Set) (Q : A -> Prop) (b : {a : A | Q a}), b = exist Q (proj1_sig b) (proj2_sig b).
Proof.
  destruct b. reflexivity.
Qed.

(*
This says that two maps are equivalent if they start from the same base, and then substitute equivalent things for the same variable.
*)
Lemma subst_map_d_Eq : forall (M : focal_model) (w : W M) (v : var -> D (s M w)) (d d' : D (s M w)) (x : var),
                           d_Eq (s M w) d d' -> forall (y : var), d_Eq (s M w) (subst_map M w v x d y) (subst_map M w v x d' y).
Proof.
  intros.
  assert ({x = y} + {x <> y}). apply var_dec. destruct H0.
  unfold subst_map. rewrite e. rewrite var_dec_if. rewrite var_dec_if. exact H.
  unfold subst_map. destruct (var_dec y x). exact H.
  reflexivity.
Qed.

(*
This says that two maps are equivalent if they start from equivalent bases, then substitute the same thing for the same variable.
*)
Lemma subst_map_v_Eq : forall (M : focal_model) (w : W M) (v v' : var -> D (s M w)) (d : D (s M w)) (x : var),
                         (forall y : var, d_Eq (s M w) (v y) (v' y)) ->
                         forall (y : var), d_Eq (s M w) (subst_map M w v x d y) (subst_map M w v' x d y).
Proof.
  intros.
  unfold subst_map. destruct (var_dec y x). reflexivity.
  apply H.
Qed.

(*
This says that, if we have two equal evaluation functions, then it doesn't matter which one we use in models.
*)
Lemma model_v_same : forall (M : focal_model) (w : W M) (v v' : var -> D (s M w)),
                       (forall v1 : var, v v1 = v' v1) -> forall phi: formula, (models M w v phi) <-> models M w v' phi.
Proof.
  intros. assert (v = v'). apply function_same; assumption.
  split; intros.  rewrite <- H0. assumption.
  rewrite H0. assumption.
Qed.

(*
This says that, if we have two equal evaluation function, it doesn't matter which one we use in mu.
*)
Lemma mu_v_same : forall (M : focal_model) (w : W M) (v v' : var -> D (s M w)),
                    (forall v1 : var, v v1 = v' v1) -> forall tau : term, mu M w v tau = mu M w v' tau.
Proof.
  intros. assert (v = v'). apply function_same; assumption.
  rewrite H0. trivial.
Qed.

(*
This generalizes replacement to a list of formulas.
*)
Theorem replacement_all :forall (M : focal_model) (w : W M) (v : var -> D (s M w)) (x : var) (d : D (s M w)) (Gamma : list formula),
                           (forall (phi : formula), In phi Gamma -> is_true(notfree_in_formula x phi)) -> (modelsAll M w v Gamma <-> modelsAll M w (subst_map M w v x d) Gamma).
Proof.
  intros. induction Gamma. simpl. split; intros; trivial.
  split; intros. simpl. simpl in H0. decompose [and] H0. split.
  apply replacement. apply H. simpl. left; trivial. exact H1.
  apply IHGamma. intros. apply H. simpl. right; exact H3. exact H2.
  simpl. simpl in H0. decompose [and] H0. split.
  apply <- replacement. exact H1.
  apply H. simpl. left; trivial.
  apply <- IHGamma. exact H2.
  intros; apply H. simpl. right. exact H3.
Qed.

(*
If p and p' are equivalent, it doesn't matter which we use for the connected relation.
*)
Theorem connected_P_Eq : forall (M : focal_model) (p p' : P M) (w w' : W M),
                           p_Eq M p p' -> connected M p w w' -> connected M p' w w'.
Proof.
  intros.
  destruct H0. clear H0.
  induction x; connected.
  assert (A M p' w w''). apply A_P_Eq with (p := p) (p' := p'); assumption.
  connected.
  assert (A M p' w'' w). apply A_P_Eq with (p := p) (p' := p'); assumption.
  connected.
Qed.

(*
If two worlds are connected, then if two worlds are on restricted_A p w, then they are on restricted_A p w'.
*)
Theorem connected_restricted' : forall (M : focal_model) (p : P M) (w w' u u' : W M),
                                  connected M p w w' -> restricted_A M p w u u' -> restricted_A M p w' u u'.
Proof.
  intros. unfold restricted_A. unfold restricted_A in H0. decompose[and] H0.
  split.
  (* connected M p w' u *)
  connected.
  assert (connected M p w' w). connected.
  connected.
  split.
  assert (connected M p w' w). connected.
  connected.
  (* A M p u u' *)
  assumption.
Qed.

(*
Generalizes the above to be <-> instead of ->.
*)
Theorem connected_restricted : forall (M : focal_model) (p : P M) (w w' u u' : W M),
                                 connected M p w w' -> (restricted_A M p w u u' <-> restricted_A M p w' u u').
Proof.
  intros. split.
  intros. apply connected_restricted' with (w := w); assumption.
  apply connected_restricted' with (w := w'). connected.
Qed.

(*
If p and p' are equivalent, then two worlds are on restricted_A of one if they are on the restricted_A of the other.
*)
Theorem restricted_A_P_Eq : forall (M : focal_model) (p p' : P M) (w w' w'' : W M),
                              p_Eq M p p' -> restricted_A M p w w' w'' ->
                              restricted_A M p' w w' w''.
Proof.
  intros.
  unfold restricted_A in H0. decompose [and] H0.
  unfold restricted_A. split.
  apply connected_P_Eq with (p := p); assumption.
  split. apply connected_P_Eq with (p := p); assumption.
  apply A_P_Eq with (p := p); assumption.
Qed.

(*
This generalizes the previous lemma about replacement to sets (lists) of formulas.
*)
Theorem replace_all : forall (M : focal_model) (w : W M) (v : var -> D (s M w)) (x : var) (d : D (s M w)) (Gamma : list formula),
                        is_true(notfree x Gamma) -> (modelsAll M w v Gamma <-> modelsAll M w (subst_map M w v x d) Gamma).
Proof.
  intros.
  split.
  intro.
  induction Gamma as [| phi Gamma'].
  (* Case Gamma = nil *)
  simpl; trivial.
  (* Case Gamma = phi :: Gamma' *)
  simpl; simpl in H0. split.
  apply replacement.
  simpl in H. unfold andb in H. destruct (notfree_in_formula x phi).
  unfold is_true. trivial.
  inversion H. (* We assume something is true, it can't be false. *)
  apply H0.
  apply IHGamma'. (* Apply the inductive hypothesis. *)
  simpl in H. destruct (notfree x Gamma').
  unfold is_true. trivial.
  unfold andb in H. destruct (notfree_in_formula x phi); inversion H. apply H0.
  intro; induction Gamma as [| phi Gamma'].
  (* Case Gamma = nil *)
  simpl; trivial.
  (* Case Gamma = phi :: Gamma' *)
  simpl; simpl in H0. split.
  apply replacement with (d := d) (x := x).
  simpl in H. unfold andb in H. destruct (notfree_in_formula x phi).
  unfold is_true; trivial.
  inversion H.
  apply H0.
  apply IHGamma'.
  simpl in H. unfold andb in H. destruct (notfree_in_formula x phi).
  exact H.
  inversion H.
  apply H0.
Qed.

(*
We can use relativize p Gamma as if it were p says Gamma
*)
Theorem relativize_as_box : forall (M : focal_model) (w : W M) (v : var -> D (s M w)) (Gamma : list formula) (p : term),
                              modelsAll M w v (relativize p Gamma) <->
                              forall (w' w'' : W M) (l : lt M w w') (a : A M (coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) p)) w' w''),
                                modelsAll M w'' (extend_v_A M w' w'' (coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) p)) a (extend_v M w w' l v)) Gamma.
Proof.
  split.
  intros.
  induction Gamma as [| phi Gamma'].
  simpl; trivial.
  simpl. split. simpl in H. apply H.
  apply IHGamma'. simpl in H. apply H.
  intros. induction Gamma as [| phi Gamma'].
  simpl; trivial.
  simpl. split.
  simpl in H. intros; apply H.
  apply IHGamma'. simpl in H. intros; apply H.
Qed.

(*
If a list of formulas are all modeled, then each formula is modeled individually.
*)
Lemma modelsAll_all_modeled : forall (M : focal_model) (w : W M) (v : var -> D (s M w)) (Gamma : list formula),
                                modelsAll M w v Gamma -> forall (phi : formula), In phi Gamma -> models M w v phi.
Proof.
  intros M w v Gamma.
  induction Gamma as [| phi' Gamma'].
  (* Case Gamma = nil *)
  intros. inversion H0.
  (* Case Gamma = phi' :: Gamma' *)
  unfold modelsAll.
  unfold In. intros.
  induction H0.
  (* Case phi = phi' *)
  rewrite <- H0. apply H.
  (* Case phi \in Gamma' *)
  apply IHGamma'. apply H. apply H0.
Qed.

(*
If a world models false, the world models anything.
*)
Lemma false_models_all : forall (M : focal_model) (w : W M) (v : var -> D (s M w)),
                           models M w v FocalFalse -> forall phi : formula, models M w v phi.
Proof.
  intros.
  inversion H.
Qed.

(*
If a world models all of a list Gamma, and the world models phi, then the world models phi::Gamma.
*)
Lemma pushback : forall (M : focal_model) (w : W M) (v : var -> D(s M w))
                        (Gamma : list formula) (phi : formula),
                   modelsAll M w v Gamma -> models M w v phi
                   -> modelsAll M w v (phi :: Gamma).
Proof.
  intros. induction Gamma as [| psi Gamma'].
  (* Case Gamma = nil *)
  simpl. auto.
  (* Case Gamma = psi :: Gamma' *)
  unfold modelsAll. fold modelsAll. split.
  apply H0.
  split.
  unfold modelsAll in H. fold modelsAll in H. apply H.
  unfold modelsAll in H. fold modelsAll in H. apply H.
Qed.

(*
The same list interpreted in a world and extended, or interpreted in the extended world, and it is equivalent.
*)
Lemma equiv_list_ext : forall (M : focal_model) (w w' : W M) (l : list term) (v : var -> D (s M w)) (ltww : lt M w w'),
                         equiv_listD (s M w') (map (extend_d_lt M w w' ltww) (map (mu M w v) l)) (map (mu M w' (extend_v M w w' ltww v)) l).
Proof.
  intros.
  induction l as [| tau l'].
  (* Case nil *)
  simpl. trivial.
  (* Case tau :: l' *)
  simpl. split.
  (* part mu M w v tau  = mu M w' v tau *)
  apply mu_same.
  (* part equiv_list map mu w l map mu w' l *)
  apply IHl'.
Qed.

(*
We can extend v twice, or we can extend once.
*)
Lemma extend_v_idempotent : forall (M : focal_model) (w w' w'' : W M) (v : var -> D (s M w)) (l : lt M w w') (l' : lt M w' w'') (l'' : lt M w w'') (v1 : var), (extend_v M w' w'' l' (extend_v M w w' l v) v1) = (extend_v M w w'' l'' v) v1.
Proof.
  intro; repeat unfold extend_v. intros.
  rewrite extend_d_lt_idempotent with  (l'' := l''). trivial.
Qed.

(*
It doesn't matter which principal we use to get from one world to another, extending a valuation function always gives the same result.
*)
Lemma extend_v_A_same : forall (M : focal_model) (w w' : W M) (v : var -> D (s M w)) (p p' : P M) (a : A M p w w') (a' : A M p' w w') (v1 : var),
                          d_Eq (s M w') (extend_v_A M w w' p a v v1) (extend_v_A M w w' p' a' v v1).
Proof.
  intros. unfold extend_v_A. apply extend_d_A_same.
Qed.

(*
Extends model_v_same to lists of formulas.
*)
Lemma modelsAll_v_same : forall (M : focal_model) (w : W M) (v v' : var -> D (s M w)), (forall v1 : var, v v1 = v' v1) -> forall Gamma : list formula, modelsAll M w v Gamma <-> modelsAll M w v' Gamma.
Proof.
  intros.
  unfold modelsAll.
  split.
  (* -> *)
  induction Gamma.
  (* Gamma = nil *)
  trivial.
  (* Gamma = a :: Gamma *)
  fold modelsAll in IHGamma.
  intros.
  split.
  (* M w v' ||- a *)
  rewrite model_v_same with (v' := v). apply H0. symmetry. apply H.
  (* M w v' ||- Gamma *)
  fold modelsAll; fold modelsAll in H0. apply IHGamma. apply H0.
  (* <- *)
  induction Gamma; fold modelsAll; intros.
  (* Gamma = nil *)
  trivial.
  (* Gamma = a :: Gamma *)
  split.
  (* M w v ||- a *)
  rewrite model_v_same with (v' := v'). apply H0. apply H.
  (* M w v ||- Gamma *)
  fold modelsAll in IHGamma. apply IHGamma. apply H0.
Qed.

(*
Extends models_v_d_Eq to lists of formulas.
*)
Lemma modelsAll_d_Eq : forall (M : focal_model) (w : W M) (v v' : var -> D (s M w)) (Gamma : list formula),
                         (forall (y : var), d_Eq (s M w) (v y) (v' y)) -> (modelsAll M w v Gamma <-> modelsAll M w v' Gamma).
Proof.
  intros; split; intro.
  induction Gamma as [| psi Gamma'].
  simpl. trivial.
  simpl in H0. simpl. decompose [and] H0. split.
  apply models_v_d_Eq with (v := v); assumption.
  apply IHGamma'. assumption.
  induction Gamma as [| psi Gamma'].
  simpl; trivial.
  simpl; simpl in H0; decompose [and] H0. split.
  apply models_v_d_Eq with (v := v'). intro. symmetry. generalize y. exact H. exact H1.
  apply IHGamma'. exact H2.
Qed.

(*
If a principal q has an accessiblity relation that is a subset of the accessiblity relation p, then their connected relations have the same relationship.
*)
Lemma A_subset_connected_subset : forall (M : focal_model) (p q : P M),
                                    (forall w u : W M, A M p w u -> A M q w u) ->
                                    forall w u : W M, connected M p w u -> connected M q w u.
Proof.
  intros; connected.
  induction x; connected.
  assert (A M q w w''). apply H. exact a. connected.
  assert (A M q w'' w). apply H. exact a. connected.
Qed.

(*
If two worlds are connected according to a principal, then they have the same restricted relation.
*)
Lemma connected_connected : forall (M : focal_model) (p : P M) (w w' : W M),
                              connected M p w w' -> forall u u' : W M, restricted_A M p w u u' <-> restricted_A M p w' u u'.
Proof.
  split; intros.
  unfold restricted_A in H0. decompose [and] H0. unfold restricted_A. split.
  assert (connected M p w' w). connected. connected. split.
  assert (connected M p w' w). connected. connected.
  exact H4.
  unfold restricted_A in H0. decompose [and] H0. unfold restricted_A. split; [connected | split; [connected | exact H4]].
Qed.

(*
If one principal has a restricted connection (on a world w) that is a superset of the other, then it judges a superset of worlds to be connected to w.
*)
Lemma restricted_restricts_connected : forall (M : focal_model) (p q : P M) (w : W M),
                                         (forall u u' : W M, restricted_A M p w u u' -> restricted_A M q w u u') ->
                                         forall u : W M, connected M p w u -> connected M q w u.
Proof.
  intros.
  apply <- connected_connected'.
  assert (connected' M p w u). apply connected_connected'. exact H0.
  connected'. induction x; connected'.
  assert (connected' M q w'' w'). apply IHx. intros.
  apply connected_connected with (w := w). assert (w'' = w''). trivial. connected.
  apply H. apply connected_connected with (w := w'').  assert (w = w). trivial. connected. exact H1.
  apply <- connected_connected'. connected'.
  connected'.
  assert (connected' M q w'' w'). apply IHx. intros.
  apply connected_connected with (w := w). assert (A M q w w''). assert (restricted_A M q w w w''). apply H.
  unfold restricted_A. split. connected. split; [connected | exact a]. assert (w'' = w''). trivial. exists (ltp M p w w'' w'' a (eqw M p w'' w'' H0)). trivial.
  unfold restricted_A in H2. apply H2. assert (w'' = w''). trivial. connected.
  apply H. apply connected_connected with (w := w''). assert (w = w). trivial. connected. exact H1.
  connected. assert (A M q w w''). assert (restricted_A M q w w w''). apply H. unfold restricted_A. split; [connected | split]. assert (w'' = w''). trivial. connected. exact a.
  unfold restricted_A in H2. apply H2.
  connected'.
  assert (connected' M q w'' w'). apply IHx. intros.
  apply connected_connected with (w := w). assert (w'' = w''). trivial. connected.
  apply H. apply connected_connected with (w := w''). assert (w = w). trivial. connected. exact H1.
  apply connected_connected'. connected'.
  connected'.
  assert (A M q w'' w). assert (restricted_A M q w w'' w). apply H. unfold restricted_A.
  split; [connected | split]. assert (w'' = w''). trivial. connected. connected. exact a.
  unfold restricted_A in H1. apply H1.
  assert (connected' M q w'' w'). apply IHx. intros.
  apply connected_connected with (w := w). assert (w'' = w''). trivial. connected. apply H.
  apply connected_connected with (w := w''). assert (w = w). trivial. connected. exact H2.
  apply connected_connected'. connected'.
  connected'.
Qed.

Theorem p_Eq_equivalent : forall (M : focal_model) (p p' : P M),
                            p_Eq M p p' <-> exists w : W M, d_Eq (s M w) (coerce_p_to_d M w p) (coerce_p_to_d M w p').
Proof.
  intros. split; intro.
  unfold p_Eq in H. assert (exists w : W M, True). apply non_empty.
  destruct H0 as [w]; clear H0.
  exists w. apply H.
  destruct H as [w].
  assert (p_Eq M (coerce_d_to_p M w (coerce_p_to_d M w p)) (coerce_d_to_p M w (coerce_p_to_d M w p'))). apply coerce_d_respects. exact H.
  apply p_Eq_trans with (p2 := coerce_d_to_p M w (coerce_p_to_d M w p)).
  apply p_Eq_symm. apply coerce_d_inverse.
  apply p_Eq_trans with (p2 := coerce_d_to_p M w (coerce_p_to_d M w p')).
  exact H0. apply coerce_d_inverse.
Qed.

Theorem handoff_iff : forall (M : focal_model) (w : W M) (v : var -> D (s M w))
                             (tau tau' : term),
  models M w v (Speaksfor tau tau') <-> models M w v (Says tau' (Speaksfor tau tau')).
Proof.
intros; split. intro.
simpl. intros. simpl in H.
assert (p_Eq M (coerce_d_to_p M w''
                 (mu M w'' (extend_v_A M w' w''
                             (coerce_d_to_p M w'
                               (mu M w' (extend_v M w w' l v) tau'))
                             a (extend_v M w w' l v))
                 tau))
               (coerce_d_to_p M w
                 (mu M w v tau))).
  apply p_Eq_trans with (p2 := (coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau))).
  apply p_Eq_symm. apply mu_pi_same_A.
  apply p_Eq_symm. apply mu_pi_same.
assert (restricted_A M (coerce_d_to_p M w'' (mu M w''
        (extend_v_A M w' w''
           (coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau')) a
           (extend_v M w w' l v)) tau)) w w'0 w''0).
apply restricted_A_P_Eq with (p := coerce_d_to_p M w (mu M w v tau)).
apply p_Eq_symm. exact H1.
assert (restricted_A M (coerce_d_to_p M w (mu M w v tau')) w w'0 w''0).
apply restricted_A_P_Eq with (p := (coerce_d_to_p M w''
          (mu M w''
             (extend_v_A M w' w''
                (coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau')) a
                (extend_v M w w' l v)) tau'))).
  apply p_Eq_trans with (p2 := (coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau'))).
  apply p_Eq_symm. apply mu_pi_same_A.
  apply p_Eq_symm. apply mu_pi_same.
apply connected_connected with (w' := w'').
assert (A M (coerce_d_to_p M w (mu M w v tau')) w' w'').
  apply A_P_Eq with (p' := coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau')).
  apply mu_pi_same. exact a.
assert (w = w). trivial.
assert (connected M (coerce_d_to_p M w (mu M w v tau')) w w'').
unfold connected.
exists (con_symm M _ w w''
         (gtp M (coerce_d_to_p M w (mu M w v tau')) w'' w w' H2
           (gte M (coerce_d_to_p M w (mu M w v tau')) w' w w l
             (eqw M _ w w H3)))). trivial.
apply connected_P_Eq with (p := coerce_d_to_p M w (mu M w v tau')).
  apply p_Eq_trans with (p2 := (coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau'))).
  apply mu_pi_same. apply mu_pi_same_A.
  exact H4.
exact H0.
apply H. exact H2.
apply connected_connected with (w' := w).
apply connected_P_Eq with (p := coerce_d_to_p M w (mu M w v tau)).
  apply p_Eq_trans with (p2 := (coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau))).
  apply mu_pi_same. apply mu_pi_same_A.
assert (restricted_A M (coerce_d_to_p M w (mu M w v tau)) w w' w'').
apply H. unfold restricted_A. split; [connected | split].
assert (A M (coerce_d_to_p M w (mu M w v tau')) w' w'').
  apply A_P_Eq with (p' := coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau')).
  apply mu_pi_same. exact a.
unfold connected.
assert (w' = w'). trivial.
exists (lte M _ w w' w' l (eqw M _ w' w' H4)). trivial.
unfold connected.
assert (w = w). trivial.
assert (A M (coerce_d_to_p M w (mu M w v tau')) w' w'').
  apply A_P_Eq with (p' := coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau')).
  apply mu_pi_same. exact a.
exists (con_symm M _ w w''
         (gtp M _ w'' w w' H4
           (gte M _ w' w w l
             (eqw M _ w w H3)))). trivial.
apply A_P_Eq with (p' := coerce_d_to_p M w' (mu M w' (extend_v M w w' l v) tau')).
  apply mu_pi_same. exact a.
unfold connected.
unfold restricted_A in H3.
decompose [and] H3.
induction H6.
exists (con_symm M _ w'' w x). trivial.
exact H2.

(* <- *)

   simpl; intros.
    assert ((exists w' : W M, exists w'' : W M, lt M w w' /\ A M (coerce_d_to_p M w (mu M w v tau')) w' w'') \/ ~(exists w' : W M, exists w'' : W M, lt M w w' /\ A M (coerce_d_to_p M w (mu M w v tau')) w' w'')). apply classic.
    destruct H1. destruct H1 as [u]. destruct H1 as [u'].  decompose [and] H1.
    assert (restricted_A M (coerce_d_to_p M w (mu M w v tau)) u' w' w'').
      assert (A M (coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau')) u u').
        apply A_P_Eq with (p := (coerce_d_to_p M w (mu M w v tau'))). apply mu_pi_same. assumption.
      apply restricted_A_P_Eq with (p := (coerce_d_to_p M u'
            (mu M u'
               (extend_v_A M u u'
                  (coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau')) H4
                  (extend_v M w u H2 v)) tau))).
        apply p_Eq_trans with (p2 := (coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau))); apply p_Eq_symm.
        apply mu_pi_same_A. apply mu_pi_same.
        apply H.
        apply connected_restricted with (w := w).
        assert (A M (coerce_d_to_p M u'
        (mu M u'
           (extend_v_A M u u'
              (coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau')) H4
              (extend_v M w u H2 v)) tau')) u u'). apply A_P_Eq with (p := (coerce_d_to_p M w (mu M w v tau'))).
        apply p_Eq_trans with (p2 := coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau')).
        apply mu_pi_same. apply mu_pi_same_A.
        assumption.
        assert (u' = u'). trivial.
        exists (lte M (coerce_d_to_p M u' (mu M u' (extend_v_A M u u' (coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau')) H4 (extend_v M w u H2 v)) tau')) w u' u H2 (ltp M _ u u' u' H5 (eqw M _ u' u' H6))). trivial.
        apply restricted_A_P_Eq with (p := (coerce_d_to_p M w (mu M w v tau'))).
        apply p_Eq_trans with (p2 := coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau')).
        apply mu_pi_same. apply mu_pi_same_A. assumption.
    apply connected_restricted with (w := u').
      assert (A M (coerce_d_to_p M w (mu M w v tau)) u u').
        assert (A M (coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau')) u u'). apply A_P_Eq with (p := (coerce_d_to_p M w (mu M w v tau'))). apply mu_pi_same. assumption.
        assert (restricted_A M (coerce_d_to_p M u' (mu M u' (extend_v_A M u u' (coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau')) H5 (extend_v M w u H2 v)) tau')) u' u u').
          apply restricted_A_P_Eq with (p := (coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau'))).
          apply mu_pi_same_A. unfold restricted_A. split.
          assert (u = u). trivial.
          exists (gtp M _ u' u u H5 (eqw M _ u u H6)). trivial.
          split. assert (u' = u'). trivial. exists (eqw M _ u' u' H6). trivial.
          assumption.
        assert (restricted_A M (coerce_d_to_p M u' (mu M u' (extend_v_A M u u' (coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau')) H5 (extend_v M w u H2 v)) tau)) u' u u').
          apply H. assumption.
        unfold restricted_A in H7. decompose [and] H7. apply A_P_Eq with (p := (coerce_d_to_p M u'
             (mu M u'
                (extend_v_A M u u'
                   (coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau')) H5
                   (extend_v M w u H2 v)) tau))).
        apply p_Eq_symm; apply p_Eq_trans with (p2 := coerce_d_to_p M u (mu M u (extend_v M w u H2 v) tau)).
        apply mu_pi_same. apply mu_pi_same_A. assumption.
        assert (u' = u'). trivial.
        exists (con_symm M _  u' w (lte M _ w u' u H2 (ltp M _ u u' u' H5 (eqw M _ u' u' H6)))). trivial. assumption.
        apply handoff_necc with (p := (coerce_d_to_p M w (mu M w v tau'))); assumption.
Qed.

End TechnicalLemmas.

Hint Resolve modelsAll_all_modeled false_models_all pushback equiv_list_ext extend_v_idempotent : Lemmas.

Hint Rewrite extend_v_idempotent : Lemmas.

Add Parametric Relation (M : fo_model) : (list (D M)) (@equiv_listD M)
    reflexivity proved by (equiv_listD_refl M)
    symmetry proved by (equiv_listD_symm M)
    transitivity proved by (equiv_listD_trans M)
      as LDE_rel.

Add Parametric Relation (M : focal_model) : (P M) (@p_Eq M)
    reflexivity proved by (p_Eq_refl M)
    symmetry proved by (p_Eq_symm M)
    transitivity proved by (p_Eq_trans M)
      as PE_rel.

Add Parametric Relation (M : focal_model) (p : P M) : (W M) (@connected M p)
    reflexivity proved by (connected_refl M p)
    symmetry proved by (connected_symm M p)
    transitivity proved by (connected_trans M p)
      as conn_rel.

Add Parametric Morphism (M : focal_model) (w : W M) : (@coerce_d_to_p M w)
    with signature (@d_Eq (s M w)) ==> (@p_Eq M)
      as coerce_d_morph.
  intros. apply coerce_d_respects with (d := x) (d' := y) (M := M) (w := w). assumption.
Qed.

Add Parametric Morphism (M : focal_model) (w : W M) : (@coerce_p_to_d M w)
    with signature (@p_Eq M) ==> (@d_Eq (s M w))
      as coerce_p_morph.
  intros. apply coerce_p_respects. assumption.
Qed.

Add Parametric Morphism (M : focal_model) (w w' : W M) (l : lt M w w') : (@extend_d_lt M w w' l)
    with signature (@d_Eq (s M w)) ==> (@d_Eq (s M w'))
      as extend_d_lt_morph.
  intros. apply extend_d_lt_respects. assumption.
Qed.

Add Parametric Morphism (M : focal_model) (w w' : W M) (p : P M) (a : A M p w w') : (@extend_d_A M w w' p a)
    with signature (@d_Eq (s M w)) ==> (@d_Eq (s M w'))
      as extend_d_A_morph.
  intros. apply extend_d_A_respects. assumption.
Qed.


Require Import prosa.model.priority.edf.
Require Import prosa.model.task.absolute_deadline.

(** In this section, we prove a few properties about EDF policy. *)
Section PropertiesOfEDF.

  (** Consider any type of tasks with relative deadlines ... *)
  Context {Task : TaskType}.
  Context `{TaskDeadline Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** Consider any arrival sequence. *)
  Variable arr_seq : arrival_sequence Job.

  (** EDF respects sequential tasks hypothesis. *)
  Lemma EDF_respects_sequential_tasks:
    policy_respects_sequential_tasks.
  Proof.
    intros j1 j2 TSK ARR.
    move: TSK => /eqP TSK.
    unfold hep_job, EDF, job_deadline, job_deadline_from_task_deadline; rewrite TSK.
      by rewrite leq_add2r.
  Qed.

End PropertiesOfEDF.

(** We add the above lemma into a "Hint Database" basic_facts, so Coq
    will be able to apply them automatically. *)
Hint Resolve EDF_respects_sequential_tasks : basic_facts.


(**
Coq-Elpi によるタクティクの作成（その1の2）
=====================

@suharahiromichi

2022/12/31

2023/1/28 ProofCafe
*)

(**
定理証明系Coqには、Embeddable Lambda Prolog Interpreter (ELPI [1]) によってタクティク（証明戦略）を
作成するためのパッケージ ``Coq-Elpi``が用意されています([3]から[6])。

``Coq-Elpi``を使う最初のサンプルとして、``P -> Q -> (P /\ Q)``を証明するタクティクを作成してみます。

この記事のソースコードは Coq のソースファイルであり、以下にあります。

https://github.com/suharahiromichi/coq/tree/master/elpi/coq_elpi_tactic_sample_1_2.v

最初に明かすと、これは文献[6]の勉強ノートにすぎません。
正確な記述を要求される方は、参考文献[3]から[6]を参照してください。
*)

(**
# Coqによる証明の復習

最初に、Coqによる証明がどのようなものか、復習してみましょう。
例は、一貫して``P -> Q -> (P /\ Q)``を使います。

Coqによる証明は、通常は、コンテキストにある仮説（注1）をゴールに適用（apply）することに
よっておこなれますが、もう少し下位のレベルで考えると、
ゴールの型（命題）に対する項（証明）をrefine ([2])で与えていくことになります。
カリー・ハワード対応ですね。

（注1） 通常 hypothesis の頭文字``H``を先頭に付けて呼ぶことが多いです。
*)

(**
また、refine で与える項には未定部分（注2）があってもよく、
Holeの部分が次の（サブ）ゴールになります。

（注2） Holeと呼び、``_``で表します。
*)
Lemma test : forall (P Q : Prop), P -> Q -> (P /\ Q).
Proof.
  intros P Q HP HQ.
(* Goal : P /\ Q *)
  refine (conj _ _).
(* Goal : P *)
  refine HP.
(* Goal : Q *)
  refine HQ.
Qed.

(**
# Coq-Elpi による作成例

## 全般の説明

最初に、Coq の elpiライブラリをインポートします。
*)
From elpi Require Import elpi.

(**
Elpiで定義したタクティクは、Elpiの述語``solve G GL``の形式で呼び出されます。

Gには、Elpiのコンストラクタ``goal``で構成されたデータ構造

```
goal Ctx Trigger Type Proof Args
```

が与えられます。通常、

```
solve (goal Ctx Trigger Type Proof Args as G) GL :- なんとか
```

ここで、

- G はElpiとして、入力です。Gは、``as``によって、``goal Ctx Trigger Type Proof Args`` と等しくなります。
``as`` は、Coqの``match``の``as``と似ていますが、Elpi上の``=``の意味になります。

- GL はElpiとして出力です。残った(サブ)ゴールを返します。一般にサブゴールは複数ですから、リストになっています。
通常は、直接扱うことはなく、後述する``refine``から返します。
ゴールに対して処理をしない（次の``show``のような場合）は、``_``としておけばよいです。

- Ctxは、コンテキストの内容のリストで、リストの要素は次のどちらかになります。
  - ``decl <項1> <Coq表示名> <項2>`` このとき、項2は項1の型
  - ``def <項1> <Coq表示名> <項2> <項3>`` このとき、項2は項1の型、項3は定義

  ``def`` は、Coqのsetタクティクを使った場合なので、この記事では使いません。

- Triggerは、制約論理のサスペンドした条件であり、これに値を代入することで、証明が進みます。
前述の通り、そこにHoleがあった場合、そこが次の（サブ）ゴールになります。

- Typeは、ゴールの命題（カリー・ハワード対応の型）です。

- Proofは、ゴールの証明（カリー・ハワード対応の値）です。通常は参照することも代入することもありません。
ここに直接代入すると、「No more subgoals」になるのに、Qedでエラーになるという「不健全」な
ことができます([6])。おまけ参照。

- Argsは、Elpiで定義したタクティクに与えられた引数のリストです。
この記事では、タクティクに引数を与えないので、使いません。``[]``になっています。

このように、Triggerに値を代入する（Elpiのレベルで``=``を使ってユニフィケーションする）ことで
証明が進むことに間違いはないのですが、通常Elpiの組込述語である``refine``述語を使います。

書式を端折って書くと、次にようになります。

```
solve (goal Ctx Trigger Type Proof Args as G) GL :-
  refine <Triggerに代入したい項> G GL.
```

第2引数と第3引数には、solveの第1引数のGと第2引数のGLを渡します。
``refine``の結果として、GLにサブゴールのリストが返されるので、それをそのまま``solve``に返します。
あとは、Coqの証明エンジンがサブゴールの処理をしてくれます。
*)

(**
### elpi id　なにもしないタクティク

なにもしないのであれば、``solve``の引数になにもなくてよいので、
以下のようになります。
*)
Elpi Tactic id.
Elpi Accumulate lp:{{
  solve _ _ :-
    true.         % true は省略してよい。
}}.
Elpi Typecheck.

Goal True.
Proof.
  elpi id.
  exact I.
Qed.

(**
### elpi show

Elpiで書いたタクティクの例として、Ctx、Proof、Typeを表示するだけのタクティクshowを示します。
``elpi show``で呼び出すことができます([6])。

CoqのコマンドにElpiが追加されるので、これを次の例のように使います。

そして、Elpiのコードは``lp:{{}}``で囲んで埋め込みます。
さらにそのなかに``{{}}``で囲んでCoqの項を書くことができます。
さらにそのなかに``lp:{{}}``で囲んで…とネストできます。
また、``lp:{{A}}``のように``lp:{{}}``の中身が変数などの場合は、``lp:A``と略すことができます。

このように、1つのElpiの節（注3）のなかに、Elpiの項とCoqの項を混ぜて書くことができますが、
Elpiの変数は、1つのElpiの節(Clause)をスコープとすることに違いはありません。

(注3) 正確には、Hereditary Harrop Formula [1]　というべき。

*)
Elpi Tactic show.
Elpi Accumulate lp:{{
  solve (goal Ctx Trigger Type Proof Args) _ :-
    coq.say "Goal:" Ctx "|-" Proof ":" Type.
}}.
Elpi Typecheck.
(**
ここでの表示は、Coq-Elpi内部のHOAS表現([4])であり、Coqでの表現と大きく異なります。
そのため、参考程度にしてください。
*)

(**
前節では、test1のまとめてイッキに証明する場合と、test2のHoleを使い
サブゴールにわけて証明する場合を示しました。
そのどちらも重要であるため、ここでもその2通りの方法で説明します。

解り易さから、test2に対応するHole-サブゴールの例から説明します。
*)

(**
## Coq-Elpi のタクティクの例

補題testをみるとrefineは3箇所、2種類使われています。
ひとつは``refine (conj _ _)``であり、
もうひとつは``refine HP``と``refine HQ``です。

### elpi split

前者については、ゴールのTypeが``_ /\ _`` のときに、
Triggerに``conj _ _``を代入すればよいのですが、
これらはCoqの項であるので、``{{}}``で囲む必要があります。

すると、以下のようになります。Coqのsplitタクティクと同じなので、splitと名付けます。
*)
Elpi Tactic split.
Elpi Accumulate lp:{{
  solve (goal Ctx Trigger {{ _ /\ _ }} Proof Args as G) GL :-
    refine {{ conj _ _ }} G GL.
  solve _ _ :-
    coq.ltac.fail _ "not a conjunction".
}}.
Elpi Typecheck.

(**
### elpi assumption

後者(例えば``refine HP``)の場合は、ゴール``P``に対して、コンテキストのリストから
型``P``をもつ仮説``HP``を探し出して、それをrefineする必要があります。

コンテキストから探し出すには、組込述語 stdlib ([7])のstd.memを使います。

ゴールの型はsolveの呼び出しの``goal Ctx Trigger Type Proof Args``
のTypeですから、Ctxの中から``decl H _ Type``である``H``を探すことになります。

declの2番目の``_``は、Coq表示名ですが、これを手がかりにすることはしないので、
無視するようにします。ゴールのHoleとは関係ありません。

実はCoqのassumptionタクティクと同じ動きなので、assumptionと名付けます。
*)
Elpi Tactic assumption.
Elpi Accumulate lp:{{
  solve (goal Ctx Trigger Type Proof Args as G) GL :-
    std.mem Ctx (decl H _ Type), coq.say "decl" H ":" Type,
    refine H G GL.
  solve _ _ :-
    coq.ltac.fail _ "no such hypothesis".
}}.
Elpi Typecheck.

(**
### 実行例

実行例を以下に示します。Qedが成功しているので、うまくできたようです。
*)
Lemma test21 : forall (P Q : Prop), P -> Q -> (P /\ Q).
Proof.
  intros P Q HP HQ.
(* Goal : P /\ Q *)
  elpi split.
(* Goal : P *)
  elpi assumption.
(* Goal : Q *)
  elpi assumption.
Qed.

(**
# 参考文献

[1] "λProlog (Lambda Prolog) の紹介"

<https://qiita.com/suharahiromichi/items/a046859da0c0883e7304>

[2] "Coq Docs - Basic proof writing - Tactics - refine"

<https://coq.inria.fr/refman/proof-engine/tactics.html#coq:tacn.refine>

[3] "Tutorial on the Elpi programming language"

<https://lpcic.github.io/coq-elpi/tutorial_elpi_lang.html>

[4] "Tutorial on the HOAS for Coq terms"

<https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_HOAS.html>

[5] "Tutorial on Coq commands"

<https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_command.html>

[6] "Tutorial on Coq tactics"

<https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_tactic.html>

[7] ELPI の組込述語 (stdlib編)

<https://qiita.com/suharahiromichi/items/1d200a9320e04ca21953>
*)

(**
# おまけ elpi admit (不健全なタクティク)
*)
Elpi Tactic admit.
Elpi Accumulate lp:{{
  solve (goal Ctx Trigger Type Proof Args as G) GL :-
    Proof = {{I}}.
}}.

Goal False.
Proof.
  elpi admit.
Fail Qed.     (* Qed で失敗する。 *)
Admitted.

(* END *)


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Set Implicit Arguments.
Reserved Notation "'dlet' x .. y := v 'in' f"
         (at level 200, x binder, y binder, f at level 200, format "'dlet'  x .. y  :=  v  'in' '//' f").
Reserved Notation "'nllet' x .. y := v 'in' f"
         (at level 200, x binder, y binder, f at level 200, format "'nllet'  x .. y  :=  v  'in' '//' f").
Reserved Notation "'elet' x := v 'in' f"
         (at level 200, f at level 200, format "'elet'  x  :=  v  'in' '//' f").
Definition Let_In {A P} (v : A) (f : forall x : A, P x) : P v
  := let x := v in f x.
Notation "'dlet' x .. y := v 'in' f" := (Let_In v (fun x => .. (fun y => f) .. )).
Definition Let_In_nat : nat -> (nat -> nat) -> nat
  := (@Let_In nat (fun _ => nat)).
Definition key : unit. exact tt. Qed.
Definition lock {A} (v : A) : A := match key with tt => v end.
Lemma unlock {A} (v : A) : lock v = v.
Proof. unfold lock; destruct key; reflexivity. Qed.
Definition LockedLet_In_nat : nat -> (nat -> nat) -> nat
  := lock Let_In_nat.
Definition locked_nat_mul := lock Nat.mul.
Notation "'nllet' x .. y := v 'in' f"
  := (LockedLet_In_nat v (fun x => .. (fun y => f) .. )).
Definition lock_Let_In_nat : @Let_In nat (fun _ => nat) = LockedLet_In_nat
  := eq_sym (unlock _).
Definition lock_Nat_mul : Nat.mul = locked_nat_mul
  := eq_sym (unlock _).

Module Import PHOAS.
  Inductive expr {var : Type} : Type :=
  | NatO : expr
  | NatS : expr -> expr
  | LetIn (v : expr) (f : var -> expr)
  | Var (v : var)
  | NatMul (x y : expr).

  Declare Scope expr_scope.
  Bind Scope expr_scope with expr.
  Delimit Scope expr_scope with expr.

  Infix "*" := NatMul : expr_scope.
  Notation "'elet' x := v 'in' f" := (LetIn v (fun x => f%expr)) : expr_scope.
  Notation "$$ x" := (Var x) (at level 9, format "$$ x") : expr_scope.

  Fixpoint denote (e : @expr nat) : nat
    := match e with
       | NatO => O
       | NatS x => S (denote x)
       | LetIn v f => dlet x := denote v in denote (f x)
       | Var v => v
       | NatMul x y => denote x * denote y
       end.

  Definition Expr := forall var, @expr var.
  Definition Denote (e : Expr) := denote (e _).
End PHOAS.

(* cf COQBUG(https://github.com/coq/coq/issues/5448), COQBUG(https://github.com/coq/coq/issues/6315) *)
Ltac refresh n :=
  let n' := fresh n in
  let n' := fresh n in
  n'.

Ltac Reify_of reify x :=
  constr:(fun var : Type => ltac:(let v := reify var x in exact v)).

Ltac error_cant_elim_deps f :=
  let __ := match goal with
            | _ => idtac "Failed to eliminate functional dependencies in" f
            end in
  constr:(I : I).

Ltac error_bad_function f :=
  let __ := match goal with
            | _ => idtac "Bad let-in function" f
            end in
  constr:(I : I).

Ltac error_bad_term term :=
  let __ := match goal with
            | _ => idtac "Unrecognized term:" term
            end in
  let ret := constr:(term : I) in
  constr:(I : I).

(** Take care of initial locking of mul, letin, etc. *)
Ltac make_pre_Reify_rhs nat_of untag do_lock_letin do_lock_natmul :=
  let RHS := lazymatch goal with |- _ = ?RHS => RHS end in
  let e := fresh "e" in
  let T := fresh in
  evar (T : Type);
  evar (e : T);
  subst T;
  cut (untag (nat_of e) = RHS);
  [ subst e
  | lazymatch do_lock_letin with
    | true => rewrite ?lock_Let_In_nat
    | false => idtac
    end;
    lazymatch do_lock_natmul with
    | true => rewrite ?lock_Nat_mul
    | false => idtac
    end;
    cbv [e]; clear e ].

Fixpoint big (a : nat) (sz : nat) : nat
  := match sz with
     | O => a
     | S sz' => dlet a' := a * a in big a' sz'
     end.

Definition big_flat_op {T} (op : T -> T -> T) (a : T) (sz : nat) : T
  := Eval cbv [Z_of_nat Pos.of_succ_nat Pos.iter_op Pos.succ] in
      match Z_of_nat sz with
      | Z0 => a
      | Zpos p => Pos.iter_op op p a
      | Zneg p => a
      end.
Definition big_flat (a : nat) (sz : nat) : nat
  := big_flat_op Nat.mul a sz.

Module CanonicalStructuresPHOAS.
  (** * Canonical-structure based reification to [@expr nat], with let-binders *)

  Local Notation context := (list nat).

  Structure tagged_nat (ctx : context) := tag { untag :> nat }.

  Structure reified_of (ctx : context) :=
    reify { nat_of : tagged_nat ctx ; reified_nat_of :> forall var, list var -> (forall T, T) -> @expr var }.

  Definition var_tl_tag := tag.
  Definition var_hd_tag := var_tl_tag.
  Definition S_tag := var_hd_tag.
  Definition O_tag := S_tag.
  Definition mul_tag := O_tag.

  (** N.B. [Canonical] structures follow [Import], so they must be
    imported for reification to work. *)
  Module Export Exports.
    Canonical Structure letin_tag ctx n := mul_tag ctx n.

    Canonical Structure reify_O ctx
      := reify (O_tag ctx 0) (fun var _ _ => @NatO var).
    Canonical Structure reify_S ctx x
      := reify (@S_tag ctx (S (@nat_of ctx x))) (fun var vs phantom => @NatS var (x var vs phantom)).
    Canonical Structure reify_mul ctx x y
      := reify (@mul_tag ctx (@nat_of ctx x * @nat_of ctx y))
               (fun var vs phantom => @NatMul var (x var vs phantom) (y var vs phantom)).
    Canonical Structure reify_var_hd n ctx
      := reify (var_hd_tag (n :: ctx) n)
               (fun var vs phantom => @Var var (List.hd (phantom _) vs)).
    Canonical Structure reify_var_tl n ctx x
      := reify (var_tl_tag (n :: ctx) (@nat_of ctx x))
               (fun var vs phantom => reified_nat_of x (List.tl vs) phantom).
    Canonical Structure reify_letin ctx v f
      := reify (letin_tag ctx (nllet x := @nat_of ctx v in @nat_of (x :: ctx) (f x)))
               (fun var vs phantom => elet x := reified_nat_of v vs phantom in reified_nat_of (f (phantom _)) (x :: vs) phantom)%expr.
  End Exports.

  Definition ReifiedNatOf (e : reified_of nil) : (forall T, T) -> Expr
    := fun phantom var => reified_nat_of e nil phantom.

  Ltac pre_Reify_rhs _ := make_pre_Reify_rhs (@nat_of nil) (@untag nil) true false.
End CanonicalStructuresPHOAS.
Export CanonicalStructuresPHOAS.Exports.

Module LtacTacInTermExplicitCtx.
  Module var_context.
    Inductive var_context {var : Type} := nil | cons (n : nat) (v : var) (xs : var_context).
  End var_context.

  Ltac reify_helper var term ctx :=
    let reify_rec term := reify_helper var term ctx in
    lazymatch ctx with
    | context[var_context.cons term ?v _]
      => constr:(@Var var v)
    | _
      =>
      lazymatch term with
      | O => constr:(@NatO var)
      | S ?x
        => let rx := reify_rec x in
           constr:(@NatS var rx)
      | ?x * ?y
        => let rx := reify_rec x in
           let ry := reify_rec y in
           constr:(@NatMul var rx ry)
      | (dlet x := ?v in ?f)
        => let rv := reify_rec v in
           let not_x := refresh x in
           let not_x2 := refresh not_x in
           let not_x3 := refresh not_x2 in
           let rf
               :=
               lazymatch
                 constr:(
                   fun (x : nat) (not_x : var)
                   => match f, @var_context.cons var x not_x ctx return @expr var with (* c.f. COQBUG(https://github.com/coq/coq/issues/6252#issuecomment-347041995) for [return] *)
                      | not_x2, not_x3
                        => ltac:(let fx := (eval cbv delta [not_x2] in not_x2) in
                                 let ctx := (eval cbv delta [not_x3] in not_x3) in
                                 clear not_x2 not_x3;
                                 let rf := reify_helper var fx ctx in
                                 exact rf)
                      end)
               with
               | fun _ => ?f => f
               | ?f => error_cant_elim_deps f
               end in
           constr:(@LetIn var rv rf)
      | ?v
        => error_bad_term v
      end
    end.

  Ltac reify var x :=
    reify_helper var x (@var_context.nil var).
  Ltac Reify x := Reify_of reify x.
End LtacTacInTermExplicitCtx.

(*
Require Ltac2.Ltac2.
Module Import Ltac2Common.
  Import Ltac2.Init.
  Import Ltac2.Notations.

  Module List.
    Ltac2 rec map f ls :=
      match ls with
      | [] => []
      | l :: ls => f l :: map f ls
      end.
  End List.
  Module Ident.
    Ltac2 rec find_error id xs :=
      match xs with
      | [] => None
      | x :: xs
        => let ((id', val)) := x in
           match Ident.equal id id' with
           | true => Some val
           | false => find_error id xs
           end
      end.
    Ltac2 find id xs :=
      match find_error id xs with
      | None => Control.zero Not_found
      | Some val => val
      end.
  End Ident.
  Module Array.
    Ltac2 rec to_list_aux (ls : 'a array) (start : int) :=
      match Int.equal (Int.compare start (Array.length ls)) -1 with
      | true => Array.get ls start :: to_list_aux ls (Int.mul start 1)
      | false => []
      end.
    Ltac2 to_list (ls : 'a array) := to_list_aux ls 0.
  End Array.
  Module Constr.
    Ltac2 rec strip_casts term :=
      match Constr.Unsafe.kind term with
      | Constr.Unsafe.Cast term' _ _ => strip_casts term'
      | _ => term
      end.
    Module Unsafe.
      Ltac2 beta1 (c : constr) :=
        match Constr.Unsafe.kind c with
        | Constr.Unsafe.App f args
          => match Constr.Unsafe.kind f with
             | Constr.Unsafe.Lambda id ty f
               => Constr.Unsafe.substnl (Array.to_list args) 0 f
             | _ => c
             end
        | _ => c
        end.
      Ltac2 zeta1 (c : constr) :=
        match Constr.Unsafe.kind c with
        | Constr.Unsafe.LetIn id v ty f
          => Constr.Unsafe.substnl [v] 0 f
        | _ => c
        end.
    End Unsafe.
  End Constr.
  Module Ltac1.
    Class Ltac1Result {T} (v : T) := {}.
    Class Ltac1Results {T} (v : list T) := {}.
    Class Ltac2Result {T} (v : T) := {}.
    Ltac save_ltac1_result v :=
      match goal with
      | _ => assert (Ltac1Result v) by constructor
      end.
    Ltac clear_ltac1_results _ :=
      match goal with
      | _ => repeat match goal with
                    | [ H : Ltac1Result _ |- _ ] => clear H
                    end
      end.
    Ltac2 get_ltac1_result () :=
      (lazy_match! goal with
      | [ id : Ltac1Result ?v |- _ ]
        => Std.clear [id]; v
       end).

    Ltac save_ltac1_results v :=
      match goal with
      | _ => assert (Ltac1Result v) by constructor
      end.
    Ltac2 save_ltac2_result v :=
      Std.cut '(Ltac2Result $v);
        Control.dispatch
          [(fun ()
            => Std.intros false [Std.IntroNaming (Std.IntroFresh @res)])
           ;
           (fun () => Notations.constructor)].
    Ltac get_ltac2_result _ :=
      lazymatch goal with
      | [ res : Ltac2Result ?v |- _ ]
        => let __ := match goal with
                     | _ => clear res
                     end in
           v
      end.
    Ltac2 from_ltac1 (save_args : constr) (tac : unit -> unit) :=
      let beta_flag :=
          {
            Std.rBeta := true; Std.rMatch := false; Std.rFix := false; Std.rCofix := false;
            Std.rZeta := false; Std.rDelta := false; Std.rConst := [];
          } in
      let c := '(ltac2:(save_ltac2_result save_args;
                          tac ();
                          let v := get_ltac1_result () in
                          Control.refine (fun () => v))) in
      Constr.Unsafe.zeta1 (Constr.Unsafe.zeta1 (Std.eval_cbv beta_flag c)).
  End Ltac1.
End Ltac2Common.

Module Ltac2LowLevel.
  Import Ltac2.Init.
  Import Ltac2.Notations.

  Ltac2 rec unsafe_reify_helper
        (mkVar : constr -> 'a)
        (mkO : 'a)
        (mkS : 'a -> 'a)
        (mkNatMul : 'a -> 'a -> 'a)
        (mkLetIn : 'a -> ident option -> constr -> 'a -> 'a)
        (gO : constr)
        (gS : constr)
        (gNatMul : constr)
        (gLetIn : constr)
        (unrecognized : constr -> 'a)
        (term : constr)
    :=
      let reify_rec term := unsafe_reify_helper mkVar mkO mkS mkNatMul mkLetIn gO gS gNatMul gLetIn unrecognized term in
      let kterm := Constr.Unsafe.kind term in
      match Constr.equal term gO with
      | true
        => mkO
      | false
        =>
        match kterm with
        | Constr.Unsafe.Rel _ => mkVar term
        | Constr.Unsafe.Var _ => mkVar term
        | Constr.Unsafe.Cast term _ _ => reify_rec term
        | Constr.Unsafe.App f args
          =>
          match Constr.equal f gS with
          | true
            => let x := Array.get args 0 in
               let rx := reify_rec x in
               mkS rx
          | false
            =>
            match Constr.equal f gNatMul with
            | true
              => let x := Array.get args 0 in
                 let y := Array.get args 1 in
                 let rx := reify_rec x in
                 let ry := reify_rec y in
                 mkNatMul rx ry
            | false
              =>
              match Constr.equal f gLetIn with
              | true
                => let x := Array.get args 2 (* assume the first two args are type params *) in
                   let f := Array.get args 3 in
                   match Constr.Unsafe.kind f with
                   | Constr.Unsafe.Lambda idx ty body
                     => let rx := reify_rec x in
                        let rf := reify_rec body in
                        mkLetIn rx idx ty rf
                   | _ => unrecognized term
                   end
              | false
                => unrecognized term
              end
            end
          end
        | _
          => unrecognized term
        end
      end.

  Ltac2 unsafe_reify (var : constr) (term : constr) :=
    let cVar := '@Var in
    let cO := '@NatO in
    let cS := '@NatS in
    let cNatMul := '@NatMul in
    let cLetIn := '@LetIn in
    let gO := 'O in
    let gS := 'S in
    let gNatMul := '@Nat.mul in
    let gLetIn := '@Let_In in
    let mk0VarArgs :=
        let args := Array.make 1 var in
        args in
    let mk1VarArgs (x : constr) :=
        let args := Array.make 2 var in
        let () := Array.set args 1 x in
        args in
    let mk2VarArgs (x : constr) (y : constr) :=
        let args := Array.make 3 var in
        let () := Array.set args 1 x in
        let () := Array.set args 2 y in
        args in
    let mkApp0 (f : constr) :=
        Constr.Unsafe.make (Constr.Unsafe.App f mk0VarArgs) in
    let mkApp1 (f : constr) (x : constr) :=
        Constr.Unsafe.make (Constr.Unsafe.App f (mk1VarArgs x)) in
    let mkApp2 (f : constr) (x : constr) (y : constr) :=
        Constr.Unsafe.make (Constr.Unsafe.App f (mk2VarArgs x y)) in
    let mkVar (v : constr) := mkApp1 cVar v in
    let mkO := mkApp0 cO in
    let mkS (v : constr) := mkApp1 cS v in
    let mkNatMul (x : constr) (y : constr) := mkApp2 cNatMul x y in
    let mkcLetIn (x : constr) (y : constr) := mkApp2 cLetIn x y in
    let mkLetIn (x : constr) (idx : ident option) (ty : constr) (fbody : constr)
        := mkcLetIn x (Constr.Unsafe.make (Constr.Unsafe.Lambda idx var fbody)) in
    let ret := unsafe_reify_helper mkVar mkO mkS mkNatMul mkLetIn gO gS gNatMul gLetIn (fun term => term) term in
    ret.
  Ltac2 check_result (ret : constr) :=
    match Constr.Unsafe.check ret with
    | Val rterm => rterm
    | Err exn => Control.zero exn
    end.
  Ltac2 reify (var : constr) (term : constr) :=
    check_result (unsafe_reify var term).

  Ltac2 unsafe_Reify (term : constr) :=
    let fresh_set := Fresh.Free.of_constr term in
    let idvar := Fresh.fresh fresh_set @var in
    let var := Constr.Unsafe.make (Constr.Unsafe.Var idvar) in
    let rterm := unsafe_reify var term in
    let rterm := Constr.Unsafe.closenl [idvar] 1 rterm in
    Constr.Unsafe.make (Constr.Unsafe.Lambda (Some idvar) 'Type rterm).

  Ltac2 do_Reify (term : constr) :=
    check_result (unsafe_Reify term).

  Ltac2 unsafe_mkApp1 (f : constr) (x : constr) :=
    let args := Array.make 1 x in
    Constr.Unsafe.make (Constr.Unsafe.App f args).
  Ltac2 mkApp1 (f : constr) (x : constr) :=
    check_result (unsafe_mkApp1 f x).

  Ltac2 all_flags :=
    {
      Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true;
      Std.rZeta := true; Std.rDelta := true; Std.rConst := [];
    }.
  Ltac2 betaiota_flags :=
    {
      Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true;
      Std.rZeta := false; Std.rDelta := false; Std.rConst := [];
    }.
  Ltac2 in_goal :=
    { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences }.

  Ltac2 do_Reify_rhs_fast () :=
    let g := Control.goal () in
    match Constr.Unsafe.kind g with
    | Constr.Unsafe.App f args (* App eq [ty; lhs; rhs] *)
      => let v := Array.get args 2 in
         let rv := Control.time (Some "actual reif") (fun _ => unsafe_Reify v) in
         let rv := Control.time (Some "eval lazy") (fun _ => Std.eval_lazy all_flags rv) in
         Control.time (Some "lazy beta iota") (fun _ => Std.lazy betaiota_flags in_goal);
           Control.time (Some "transitivity (Denote rv)") (fun _ => Std.transitivity (unsafe_mkApp1 'Denote rv))
    | _
      => Control.zero (Tactic_failure (Some (Message.concat (Message.of_string "Invalid goal in Ltac2Unsafe.do_Reify_rhs_fast: ") (Message.of_constr g))))
    end.

  Ltac2 do_Reify_rhs () :=
    lazy_match! goal with
  | [ |- _ = ?v ]
    => let rv := do_Reify v in
       let rv := Std.eval_lazy all_flags rv in
       Std.transitivity (mkApp1 'Denote rv)
  | [ |- ?g ] => Control.zero (Tactic_failure (Some (Message.concat (Message.of_string "Invalid goal in Ltac2Unsafe.do_Reify_rhs: ") (Message.of_constr g))))
  end.

  Ltac reify var term :=
    let __ := Ltac1.save_ltac1_result (var, term) in
    let ret :=
        constr:(ltac2:(let args := Ltac1.get_ltac1_result () in
                       (lazy_match! args with
                       | (?var, ?term)
                         => let rv := reify var term in
                            Control.refine (fun () => rv)
                       | _ => Control.throw Not_found
                        end))) in
    let __ := Ltac1.clear_ltac1_results () in
    ret.

  Ltac Reify x := Reify_of reify x.
  (*Ltac do_Reify_rhs _ := do_Reify_rhs_of Reify ().*)
  Ltac do_Reify_rhs _ := ltac2:(do_Reify_rhs_fast ()).
End Ltac2LowLevel.
*)

Require Mtac2.Mtac2.

Module Mtac2Mmatch.
  Import Mtac2.Mtac2.
  Import M.notations.

  Module var_context.
    Inductive var_context {var : Type} := nil | cons (n : nat) (v : var) (xs : var_context).
  End var_context.

  Definition find_in_ctx {var : Type} (term : nat) (ctx : @var_context.var_context var) : M (option var)
    := (mfix1 find_in_ctx (ctx : @var_context.var_context var) : M (option var) :=
          (mmatch ctx with
          | [? v xs] (var_context.cons term v xs)
            =n> M.ret (Some v)
          | [? x v xs] (var_context.cons x v xs)
            =n> find_in_ctx xs
          | _ => M.ret None
           end)) ctx.

   Definition reify_helper {var : Type} (term : nat) (ctx : @var_context.var_context var) : M (@expr var)
     := ((mfix2 reify_helper (term : nat) (ctx : @var_context.var_context var) : M (@expr var) :=
            lvar <- find_in_ctx term ctx;
              match lvar with
              | Some v => M.ret (@Var var v)
              | None =>
                 mmatch term with
                 | O
                   =n> M.ret (@NatO var)
                 | [? x] (S x)
                   =n> (rx <- reify_helper x ctx;
                          M.ret (@NatS var rx))
                 | [? x y] (x * y)
                   =n> (rx <- reify_helper x ctx;
                          ry <- reify_helper y ctx;
                          M.ret (@NatMul var rx ry))
                  | [? v f] (@Let_In nat (fun _ => nat) v f)
                    =n> (rv <- reify_helper v ctx;
                        rf <- (M.nu (FreshFrom f) mNone
                                    (fun x : nat
                                     => M.nu (FreshFrom "vx") mNone
                                             (fun vx : var
                                              => let fx := reduce (RedWhd [rl:RedBeta]) (f x) in
                                                 rf <- reify_helper fx (var_context.cons x vx ctx);
                                                   M.abs_fun vx rf)));
                          M.ret (@LetIn var rv rf))
                end
             end) term ctx).

  Definition reify (var : Type) (term : nat) : M (@expr var)
    := reify_helper term var_context.nil.

  Definition Reify (term : nat) : M Expr
    := \nu var:Type, r <- reify var term; M.abs_fun var r.

  Ltac Reify' x := constr:(ltac:(mrun (@Reify x))).
  Ltac Reify x := Reify' x.

End Mtac2Mmatch.

Require Mtac2.DecomposeApp.
Module MTac2.
  Import Mtac2.Mtac2 Mtac2.DecomposeApp.
  Import M.notations.

  Definition mor {A} (t1 t2 : M A) : M A :=
    M.mtry' t1 (fun _ => t2).
  Notation "a '_or_' b" := (mor a b)  (at level 50).

  Module var_context.
    Inductive var_context {var : Type} := nil | cons (n : nat) (v : var) (xs : var_context).
  End var_context.

  Fixpoint find_in_ctx {var : Type} (term : nat) (ctx : @var_context.var_context var) {struct ctx} : M (option var)
    := match ctx with
       | var_context.cons term' v xs =>
         mmatch term' with
         | [#] term | =n> M.ret (Some v)
         | _ => M.ret None
         end
       | _ => M.ret None
       end.
  Definition reify_helper {var : Type} (term : nat) (ctx : @var_context.var_context var) : M (@expr var)
    := ((mfix2 reify_helper (term : nat) (ctx : @var_context.var_context var) : M (@expr var) :=
           lvar <- find_in_ctx term ctx;
             match lvar with
             | Some v => M.ret (@Var var v)
             | None =>
               mmatch term with
               | [#] O | =n> M.ret (@NatO var)
               | [#] S | x =n>
                  rx <- reify_helper x ctx;
                  M.ret (@NatS var rx)
               | [#] Nat.mul | x y =n>
                  rx <- reify_helper x ctx;
                  ry <- reify_helper y ctx;
                  M.ret (@NatMul var rx ry)
               | [#] @Let_In nat (fun _=>nat) | v f =n>
                  rv <- reify_helper v ctx;
                  rf <- (M.nu (FreshFrom f) mNone
                              (fun x : nat
                               => M.nu Generate mNone
                                       (fun vx : var
                                        => let fx := reduce (RedWhd [rl:RedBeta]) (f x) in
                                           rf <- reify_helper fx (var_context.cons x vx ctx);
                                             M.abs_fun vx rf)));
                  M.ret (@LetIn var rv rf)
               end
             end) term ctx).

  Definition reify (var : Type) (term : nat) : M (@expr var)
    := reify_helper term var_context.nil.

  Definition Reify (term : nat) : M Expr
    := \nu var:Type, r <- reify var term; M.abs_fun var r.

  Ltac Reify' x := constr:(ltac:(mrun (@Reify x))).
  Ltac Reify x := Reify' x.
End MTac2.


Require Import Coq.Lists.List.
Require Import PL.Imp3.
Require Import PL.ImpExt4.
Local Open Scope Z.

(* ################################################################# *)
(** * Review *)

(** Last time, we have introduced a programming language with parallel
    composition. *)

Inductive com : Type :=
  | CSkip
  | CAss (X: var) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com)
  | CPar (c1 c2: com) (* <- new *)
  .

Bind Scope imp_scope with com.
Notation "'Skip'" :=
   CSkip : imp_scope.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity) : imp_scope.
Notation "'While' b 'Do' c 'EndWhile'" :=
  (CWhile b c) (at level 80, right associativity) : imp_scope.
Notation "'If' c1 'Then' c2 'Else' c3 'EndIf'" :=
  (CIf c1 c2 c3) (at level 10, right associativity) : imp_scope.
Local Open Scope imp.

(** We introduced its small step semantics. *)

Module SmallStepSemantics.

Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AssStep : forall st X a a',
      astep st a a' ->
      cstep (CAss X a, st) (CAss X a', st)
  | CS_Ass : forall st1 st2 X n,
      st2 X = n ->
      (forall Y, X <> Y -> st1 Y = st2 Y) ->
      cstep (CAss X (ANum n), st1) (Skip, st2)
  | CS_SeqStep : forall st c1 c1' st' c2,
      cstep (c1, st) (c1', st') ->
      cstep (c1 ;; c2 , st) (c1' ;; c2, st')
  | CS_Seq : forall st c2,
      cstep (Skip ;; c2, st) (c2, st)
  | CS_IfStep : forall st b b' c1 c2,
      bstep st b b' ->
      cstep
        (If b  Then c1 Else c2 EndIf, st)
        (If b'  Then c1 Else c2 EndIf, st)
  | CS_IfTrue : forall st c1 c2,
      cstep (If BTrue Then c1 Else c2 EndIf, st) (c1, st)
  | CS_IfFalse : forall st c1 c2,
      cstep (If BFalse Then c1 Else c2 EndIf, st) (c2, st)
  | CS_While : forall st b c,
      cstep
        (While b Do c EndWhile, st)
        (If b Then (c;; While b Do c EndWhile) Else Skip EndIf, st)
  | CS_ParLeft: forall st st' c1 c1' c2,
      cstep (c1, st) (c1', st') ->
      cstep (CPar c1 c2, st) (CPar c1' c2, st')
  | CS_ParRight: forall st st' c1 c2 c2',
      cstep (c2, st) (c2', st') ->
      cstep (CPar c1 c2, st) (CPar c1 c2', st')
  | CS_Par: forall st,
      cstep (CPar Skip Skip, st) (Skip, st).

End SmallStepSemantics.

(* ################################################################# *)
(** * Denotational Semantics *)

(** Obviously, original denotational semantics does not work. If using initial
    state and ending state pairs as denotations, then

    - [X ::= 1]

    - [X ::= 2;; X ::= 1]

    have the same denotations. However, parallelly executing one of them and

    - [Y ::= X]

    may have different results. That means, this ordinary approach is not
    expressive enough. In the following part of this lecture, we will use trace
    sets to describe all intermediate states. *)

Module DenotationalSemantics_Trace.

(** Here, we use a combination of

    - initial state

    - intermediate states

    - ending state

    to represent an execution trace. But we do not only consider the behavior of
    one program itself. We only consider potential behavior of other threads, we
    call that environment's behavior. Specifically, we distinguish thread local
    actions and envirionment actions. *)

Inductive abs_thread :=
| LOCAL
| ENVIR.

Definition trace_set := state -> list (abs_thread * state) -> state -> Prop.

Inductive environ_trace: trace_set :=
| environ_trace_nil: forall st, environ_trace st nil st
| environ_trace_cons: forall st1 st2 st3 tr,
    environ_trace st2 tr st3 ->
    environ_trace st1 ((ENVIR, st2) :: tr) st3.

Definition seq_sem (d1 d2: trace_set): trace_set :=
  fun st1 tr st3 =>
    exists tr1 tr2 st2,
      d1 st1 tr1 st2 /\ d2 st2 tr2 st3 /\ tr = tr1 ++ tr2.

Definition union_sem (d d': trace_set): trace_set :=
  fun st1 tr st2 =>
    d st1 tr st2 \/ d' st1 tr st2.

Definition omega_union_sem (d: nat -> trace_set): trace_set :=
  fun st1 tr st2 => exists n, d n st1 tr st2.

(** The most interesting case is to define parallel compositions' behavior. *)

Inductive interleave_trace:
  list (abs_thread * state) ->
  list (abs_thread * state) ->
  list (abs_thread * state) ->
  Prop :=
| interleave_nil: interleave_trace nil nil nil
| interleave_cons_l: forall tr1 tr2 tr3 st,
    interleave_trace tr1 tr2 tr3 ->
    interleave_trace ((LOCAL, st) :: tr1) ((ENVIR, st) :: tr2) ((LOCAL, st) :: tr3)
| interleave_cons_r: forall tr1 tr2 tr3 st,
    interleave_trace tr1 tr2 tr3 ->
    interleave_trace ((ENVIR, st) :: tr1) ((LOCAL, st) :: tr2) ((LOCAL, st) :: tr3)
| interleave_cons_env: forall tr1 tr2 tr3 st,
    interleave_trace tr1 tr2 tr3 ->
    interleave_trace ((ENVIR, st) :: tr1) ((ENVIR, st) :: tr2) ((ENVIR, st) :: tr3).

Definition par_sem (d1 d2: trace_set): trace_set :=
  fun st1 tr st2 =>
    exists tr1 tr2,
      d1 st1 tr1 st2 /\ d2 st1 tr2 st2 /\ interleave_trace tr1 tr2 tr.

Module DenotationalSemantics_MiddleStepTrace.

Definition skip_sem: state -> list (abs_thread * state) -> state -> Prop :=
  environ_trace.

Definition local_asgn_sem (X: var) (E: aexp): trace_set :=
  fun st1 tr st2 =>
    st2 X = aeval E st1 /\
    (forall Y, X <> Y -> st1 Y = st2 Y) /\
    tr = (LOCAL, st2) :: nil.

Definition asgn_sem (X: var) (E: aexp): trace_set :=
  seq_sem environ_trace (seq_sem (local_asgn_sem X E) environ_trace).

Definition local_test_sem (X: state -> Prop): trace_set :=
  fun st1 tr st2 =>
    st1 = st2 /\ tr = (LOCAL, st1) :: nil /\ X st1.

Definition if_sem (b: bexp) (d1 d2: trace_set): trace_set :=
  union_sem
    (seq_sem environ_trace (seq_sem (local_test_sem (beval b)) d1))
    (seq_sem environ_trace (seq_sem (local_test_sem (beval (! b))) d2)).

Fixpoint iter_loop_body (b: bexp) (loop_body: trace_set) (n: nat): trace_set :=
  match n with
  | O => local_test_sem (beval (! b))
  | S n' => seq_sem
              (local_test_sem (beval b))
              (seq_sem loop_body (iter_loop_body b loop_body n'))
  end.

Definition loop_sem (b: bexp) (loop_body: trace_set): trace_set :=
  seq_sem
    environ_trace
    (seq_sem (omega_union_sem (iter_loop_body b loop_body)) environ_trace).

Fixpoint ceval (c: com): trace_set :=
  match c with
  | CSkip => skip_sem
  | CAss X E => asgn_sem X E
  | CSeq c1 c2 => seq_sem (ceval c1) (ceval c2)
  | CIf b c1 c2 => if_sem b (ceval c1) (ceval c2)
  | CWhile b c => loop_sem b (ceval c)
  | CPar c1 c2 => par_sem (ceval c1) (ceval c2)
  end.

End DenotationalSemantics_MiddleStepTrace.

Module DenotationalSemantics_SmallStepTrace.

(** In the definitions above, we actually assume that an assignment or an
    testing can happen in one instant. However, you may think it is not true
    because evaluating an expression needs to read program variables' values.
    That does not happen instantly. Due to that consideration, we may choose
    an alternative semantics. *)

Local Open Scope Z.

Definition ANum_sem (n: Z): Z -> trace_set :=
  fun res st1 tr st2 =>
    environ_trace st1 tr st2 /\ res = n.

Definition local_AId_sem (X: var): Z -> trace_set :=
  fun res st1 tr st2 =>
    st1 = st2 /\ tr = (LOCAL, st1) :: nil /\ res = st1 X.

Definition AId_sem (X: var): Z -> trace_set :=
  fun res =>
    seq_sem environ_trace (seq_sem (local_AId_sem X res) environ_trace).

Definition APlus_sem (d1 d2: Z -> trace_set): Z -> trace_set :=
  fun res st1 tr st2 =>
    exists res1 res2,
      seq_sem (d1 res1) (d2 res2) st1 tr st2 /\ res = res1 + res2.

Definition AMinus_sem (d1 d2: Z -> trace_set): Z -> trace_set :=
  fun res st1 tr st2 =>
    exists res1 res2,
      seq_sem (d1 res1) (d2 res2) st1 tr st2 /\ res = res1 - res2.

Definition AMult_sem (d1 d2: Z -> trace_set): Z -> trace_set :=
  fun res st1 tr st2 =>
    exists res1 res2,
      seq_sem (d1 res1) (d2 res2) st1 tr st2 /\ res = res1 * res2.

Fixpoint aeval (a: aexp): Z -> trace_set :=
  match a with
  | ANum n => ANum_sem n
  | AId X => AId_sem X
  | APlus a1 a2 => APlus_sem (aeval a1) (aeval a2)
  | AMinus a1 a2 => AMinus_sem (aeval a1) (aeval a2)
  | AMult a1 a2 => AMult_sem (aeval a1) (aeval a2)
  end.

Definition BEq_sem (d1 d2: Z -> trace_set): bool -> trace_set :=
  fun res st1 tr st2 =>
    exists res1 res2,
      seq_sem (d1 res1) (d2 res2) st1 tr st2 /\ (res = true <-> res1 = res2).

Definition BLe_sem (d1 d2: Z -> trace_set): bool -> trace_set :=
  fun res st1 tr st2 =>
    exists res1 res2,
      seq_sem (d1 res1) (d2 res2) st1 tr st2 /\ (res = true <-> res1 <= res2).

Definition BTrue_sem: bool -> trace_set :=
  fun res st1 tr st2 =>
    environ_trace st1 tr st2 /\ res = true.

Definition BFalse_sem: bool -> trace_set :=
  fun res st1 tr st2 =>
    environ_trace st1 tr st2 /\ res = false.

Definition BNot_sem (d: bool -> trace_set) : bool -> trace_set :=
  fun res st1 tr st2 =>
    exists res',
      d res' st1 tr st2 /\ res = negb res'.

Definition BAnd_sem (d1 d2: bool -> trace_set) : bool -> trace_set :=
  fun res st1 tr st2 =>
    (d1 false st1 tr st2 /\ res = false) \/
    (seq_sem (d1 true) (d2 res) st1 tr st2).

Fixpoint beval (b: bexp): bool -> trace_set :=
  match b with
  | BEq a1 a2 => BEq_sem (aeval a1) (aeval a2)
  | BLe a1 a2 => BLe_sem (aeval a1) (aeval a2)
  | BTrue => BTrue_sem
  | BFalse => BFalse_sem
  | BNot b0 => BNot_sem (beval b0)
  | BAnd b1 b2 => BAnd_sem (beval b1) (beval b2)
  end.

Definition skip_sem: state -> list (abs_thread * state) -> state -> Prop :=
  environ_trace.

Definition local_asgn_sem (X: var) (n: Z): trace_set :=
  fun st1 tr st2 =>
    st2 X = n /\
    (forall Y, X <> Y -> st1 Y = st2 Y) /\
    tr = (LOCAL, st2) :: nil.

Definition asgn_sem (X: var) (E: aexp): trace_set :=
  fun st1 tr st2 =>
    exists n,
      seq_sem (aeval E n) (seq_sem (local_asgn_sem X n) environ_trace) st1 tr st2.

Definition if_sem (b: bexp) (d1 d2: trace_set): trace_set :=
  union_sem
    (seq_sem (beval b true) d1)
    (seq_sem (beval b false) d2).

Fixpoint iter_loop_body (b: bexp) (loop_body: trace_set) (n: nat): trace_set :=
  match n with
  | O => beval b false
  | S n' => seq_sem
              (beval b true)
              (seq_sem loop_body (iter_loop_body b loop_body n'))
  end.

Definition loop_sem (b: bexp) (loop_body: trace_set): trace_set :=
  omega_union_sem (iter_loop_body b loop_body).

Fixpoint ceval (c: com): trace_set :=
  match c with
  | CSkip => skip_sem
  | CAss X E => asgn_sem X E
  | CSeq c1 c2 => seq_sem (ceval c1) (ceval c2)
  | CIf b c1 c2 => if_sem b (ceval c1) (ceval c2)
  | CWhile b c => loop_sem b (ceval c)
  | CPar c1 c2 => par_sem (ceval c1) (ceval c2)
  end.

End DenotationalSemantics_SmallStepTrace.
End DenotationalSemantics_Trace.

(* ################################################################# *)
(** * Hoare Logic *)

(** For axiomatic semantics, we introduce an extension of Hoare logic here, the
    logic of _rely-guanrantee_ (依赖保证). Sometimes we write RG for simplicity.
    In short, rely is a set of actions that the environment may take. Guanrantee
    is a promise that the local thread make: "I will only take these actions." *)

Module HoareLogic.

Import Assertion_D.

(** Here,

    - [stable P R] means if a program state statisfies [P] then it will still
      satisfy [P] if an action in [R] is taken;

    - [permit P X E G] means if a program state statisfies [P] then [X ::= E]
      is an action permit by [G].

*)

Class Actions : Type := {
  action_set: Type;
  action_union: action_set -> action_set -> action_set;
  stable: Assertion -> action_set -> Prop;
  permit: Assertion -> var -> aexp -> action_set -> Prop
}.

Inductive hoare_triple {A: Actions}: Type :=
| Build_hoare_triple
    (R: action_set)
    (G: action_set)
    (P: Assertion)
    (c: com)
    (Q: Assertion).

Reserved Notation "R :; G |-- {{ P }}  c  {{ Q }}"
  (at level 90, G at next level, P at next level, c at next level, Q at next level).

Inductive provable {A: Actions} {T: FirstOrderLogic}: hoare_triple -> Prop :=
  | hoare_seq : forall R G (P1 P2 P3: Assertion) (c1 c2: com),
      R :; G |-- {{P1}} c1 {{P2}} ->
      R :; G |-- {{P2}} c2 {{P3}} ->
      R :; G |-- {{P1}} (CSeq c1 c2) {{P3}}
  | hoare_skip : forall R G P,
      stable P R ->
      R :; G |-- {{P}} CSkip {{P}}
  | hoare_if : forall R G P Q (b: bexp) c1 c2,
      R :; G |-- {{ P AND {[b]} }} c1 {{ Q }} ->
      R :; G |-- {{ P AND NOT {[b]} }} c2 {{ Q }} ->
      R :; G |-- {{ P }} CIf b c1 c2 {{ Q }}
  | hoare_while : forall R G P (b: bexp) c,
      stable (P AND NOT {[b]}) R ->
      R :; G |-- {{ P AND {[b]} }} c {{P}} ->
      R :; G |-- {{P}} CWhile b c {{ P AND NOT {[b]} }}
  | hoare_asgn_bwd : forall R G P (X: var) (E: aexp),
      stable (P [ X |-> E ]) R ->
      stable P R ->
      permit (P [ X |-> E ]) X E G ->
      R :; G |-- {{ P [ X |-> E] }} CAss X E {{ P }}
  | hoare_par : forall G1 G2 R P c1 c2 Q,
      G1 :; action_union G2 R |-- {{ P }} c1 {{ Q }} ->
      G2 :; action_union G1 R |-- {{ P }} c2 {{ Q }} ->
      action_union G1 G2 :; R |-- {{ P }} CPar c1 c2 {{ Q }}
  | hoare_consequence : forall R G (P P' Q Q' : Assertion) c,
      stable P R ->
      stable Q R ->
      P |-- P' ->
      R :; G |-- {{P'}} c {{Q'}} ->
      Q' |-- Q ->
      R :; G |-- {{P}} c {{Q}}
where "R :; G |-- {{ P }}  c  {{ Q }}" :=
  (provable (Build_hoare_triple R G P (c%imp) Q)).

End HoareLogic.

(* Wed Jun 10 23:33:23 CST 2020 *)