Commit 083c0c18 authored by POTTIER Francois's avatar POTTIER Francois

Expose new Coq files.

parent 42ddbb4f
Require Import Omega.
Require Import Autosubst.Autosubst.
Require Import MyTactics. (* TEMPORARY *)
(* -------------------------------------------------------------------------- *)
......@@ -167,3 +168,5 @@ Hint Extern 1 (_ = _) => autosubst : autosubst.
metavariables, so the tactic [autosubst] fails. *)
Hint Resolve scons_scomp : autosubst.
(* -------------------------------------------------------------------------- *)
This diff is collapsed.
Require Import List.
Require Import MyTactics. (* TEMPORARY *)
Require Import Autosubst.Autosubst.
Require Import Autosubst_EOS. (* [eos_var] *)
(* Environments are sometimes represented as finite lists. This file
provides a few notions that helps deal with this representation. *)
Section Env.
Context {A} `{Ids A, Rename A, Subst A, SubstLemmas A}.
(* -------------------------------------------------------------------------- *)
(* The function [env2subst default], where [default] is a default value,
converts an environment (a finite list) to a substitution (a total
function). *)
Definition env2subst (default : A) (e : list A) (x : var) : A :=
nth x e default.
(* -------------------------------------------------------------------------- *)
(* [env_ren_comp e xi e'] means (roughly) that the environment [e] is equal to
the composition of the renaming [xi] and the environment [e'], that is,
[e = xi >>> e']. We also explicitly require the environments [e] and [e']
to have matching lengths, up to [xi], as this is *not* a consequence of
the other premise. *)
Inductive env_ren_comp : list A -> (var -> var) -> list A -> Prop :=
| EnvRenComp:
forall e xi e',
(forall x, x < length e -> xi x < length e') ->
(forall x default, nth x e default = nth (xi x) e' default) ->
env_ren_comp e xi e'.
(* A reformulation of the second premise in the above definition. *)
Lemma env_ren_comp_eq:
forall e xi e',
(forall default, env2subst default e = xi >>> env2subst default e') <->
(forall x default, nth x e default = nth (xi x) e' default).
Proof.
unfold env2subst. split; intros h; intros.
{ change (nth x e default) with ((fun x => nth x e default) x).
rewrite h. reflexivity. }
{ f_ext; intro x. eauto. }
Qed.
(* -------------------------------------------------------------------------- *)
(* Initialization: [e = id >>> e]. *)
Lemma env_ren_comp_id:
forall e,
env_ren_comp e (fun x => x) e.
Proof.
econstructor; eauto.
Qed.
(* -------------------------------------------------------------------------- *)
(* The relation [e = xi >>> e'] can be taken under a binder, as follows. *)
Lemma env_ren_comp_up:
forall e xi e' v,
env_ren_comp e xi e' ->
env_ren_comp (v :: e) (upren xi) (v :: e').
Proof.
inversion 1; intros; subst; econstructor;
intros [|x]; intros; simpl in *; eauto with omega.
Qed.
(* -------------------------------------------------------------------------- *)
(* One element can be prepended to [e'], provided [xi] is adjusted. *)
Lemma env_ren_comp_prepend:
forall e xi e' v,
env_ren_comp e xi e' ->
env_ren_comp e (xi >>> (+1)) (v :: e').
Proof.
inversion 1; intros; subst.
econstructor; intros; simpl; eauto with omega.
Qed.
(* -------------------------------------------------------------------------- *)
(* A consequence of [env_ren_comp_id] and [env_ren_comp_prepend]. The renaming
(+1) will eat away the first entry in [v :: e]. *)
Lemma env_ren_comp_plus1:
forall e v,
env_ren_comp e (+1) (v :: e).
Proof.
econstructor; intros; simpl; eauto with omega.
Qed.
(* -------------------------------------------------------------------------- *)
(* More generally, the renaming [eos_var x], which means that [x] goes out of
scope, will eat away the entry at index [x] in [e1 ++ v :: e2]. *)
Lemma env_ren_comp_eos_var:
forall x e1 v e2,
x = length e1 ->
env_ren_comp (e1 ++ e2) (eos_var x) (e1 ++ v :: e2).
Proof.
rewrite eos_var_eq_lift_var. unfold lift_var.
econstructor; intros y; dblib_by_cases.
{ rewrite app_length in *. simpl. omega. }
{ rewrite app_length in *. simpl. omega. }
{ do 2 (rewrite app_nth2 by omega).
replace (1 + y - length e1) with (1 + (y - length e1)) by omega.
reflexivity. }
{ do 2 (rewrite app_nth1 by omega).
reflexivity. }
Qed.
(* -------------------------------------------------------------------------- *)
End Env.
Hint Resolve
env_ren_comp_id
env_ren_comp_up
env_ren_comp_prepend
env_ren_comp_plus1
env_ren_comp_eos_var
: env_ren_comp.
Require Import Omega.
Require Import Autosubst.Autosubst.
Require Import AutosubstExtra.
Require Import Autosubst_EOS.
(* -------------------------------------------------------------------------- *)
Class IdsLemmas (term : Type) {Ids_term : Ids term} := {
(* The identity substitution is injective. *)
ids_inj:
forall x y,
ids x = ids y ->
x = y
}.
(* -------------------------------------------------------------------------- *)
Section FreeVars.
Context
{A : Type}
{Ids_A : Ids A}
{Rename_A : Rename A}
{Subst_A : Subst A}
{IdsLemmas_A : IdsLemmas A}
{SubstLemmas_A : SubstLemmas A}.
(* -------------------------------------------------------------------------- *)
(* A reformulation of [ids_inj]. *)
Lemma ids_inj_False:
forall x y,
ids x = ids y ->
x <> y ->
False.
Proof.
intros.
assert (x = y). { eauto using ids_inj. }
unfold var in *.
omega.
Qed.
(* -------------------------------------------------------------------------- *)
(* The predicate [fv k t] means that the free variables of the term [t] are
contained in the semi-open interval [0..k). *)
Definition fv k t :=
t.[upn k (ren (+1))] = t.
(* -------------------------------------------------------------------------- *)
(* The predicate [closed t] means that the term [t] is closed, that is, [t]
has no free variables. *)
Definition closed :=
fv 0.
(* -------------------------------------------------------------------------- *)
(* This technical lemma states that the renaming [+1] is injective. *)
Lemma lift_inj_ids:
forall t x,
t.[ren (+1)] = ids (S x) <-> t = ids x.
Proof.
split; intros.
{ eapply lift_inj. autosubst. }
{ subst. autosubst. }
Qed.
(* -------------------------------------------------------------------------- *)
(* This lemma characterizes the meaning of [fv k] when applied to a variable. *)
Lemma fv_ids_eq:
forall k x,
fv k (ids x) <-> x < k.
Proof.
unfold fv. induction k; intros.
(* Base case. *)
{ asimpl. split; intros; elimtype False.
{ eauto using ids_inj_False. }
{ omega. }
}
(* Step. *)
{ destruct x; asimpl.
{ split; intros. { omega. } { reflexivity. } }
{ rewrite lift_inj_ids.
rewrite <- id_subst.
rewrite IHk. omega. }
}
Qed.
(* -------------------------------------------------------------------------- *)
(* A simplification lemma. *)
Lemma fv_lift:
forall k i t,
fv (k + i) t.[ren (+i)] <-> fv k t.
Proof.
unfold fv. intros. asimpl.
rewrite Nat.add_comm.
rewrite <- upn_upn.
erewrite plus_upn by eauto.
rewrite <- subst_comp.
split; intros.
{ eauto using lift_injn. }
{ f_equal. eauto. }
Qed.
(* -------------------------------------------------------------------------- *)
(* If [t] has at most [n - 1] free variables,
and if [x] is inserted among them,
then we get [eos x t],
which has at most [n] free variables. *)
Lemma fv_eos:
forall x n t,
x < n ->
fv (n - 1) t ->
fv n (eos x t).
Proof.
unfold fv. intros x n t ? ht.
rewrite eos_eq in ht.
rewrite eos_eq.
rewrite eos_eos_reversed by omega. (* nice! *)
rewrite ht.
reflexivity.
Qed.
Lemma fv_eos_eq:
forall x n t,
x < n ->
fv n (eos x t) <->
fv (n - 1) t.
Proof.
unfold fv. intros x n t ?.
rewrite eos_eq.
rewrite eos_eq.
rewrite eos_eos_reversed by omega. (* nice! *)
split; intros h.
{ eauto using eos_injective. }
{ rewrite h. reflexivity. }
Qed.
(* -------------------------------------------------------------------------- *)
(* A substitution [sigma] is regular if and only if, for some [j], for
sufficiently large [x], [sigma x] is [x + j]. *)
Definition regular (sigma : var -> A) :=
exists i j,
ren (+i) >> sigma = ren (+j).
Lemma regular_ids:
regular ids.
Proof.
exists 0. exists 0. autosubst.
Qed.
Lemma regular_plus:
forall i,
regular (ren (+i)).
Proof.
intros. exists 0. exists i. autosubst.
Qed.
Lemma regular_upn:
forall n sigma,
regular sigma ->
regular (upn n sigma).
Proof.
intros ? ? (i&j&hsigma).
exists (n + i). eexists (n + j).
replace (ren (+(n + i))) with (ren (+i) >> ren (+n)) by autosubst.
rewrite <- scompA.
rewrite up_liftn.
rewrite scompA.
rewrite hsigma.
autosubst.
Qed.
(* -------------------------------------------------------------------------- *)
(* If the free variables of the term [t] are below [k], then [t] is unaffected
by a substitution of the form [upn k sigma]. *)
(* Unfortunately, in this file, where the definition of type [A] is unknown, I
am unable to establish this result for arbitrary substitutions [sigma]. I
am able to establish it for *regular* substitutions, where The proof is somewhat interesting, so it is given here, even
though, once the definition of the type [A] is known, a more direct proof,
without a regularity hypothesis, can usually be given. *)
(* An intermediate result states that, since [upn k (ren (+1))] does not
affect [t], then (by iteration) neither does [upn k (ren (+j))]. *)
Lemma fv_unaffected_lift:
forall j t k,
fv k t ->
t.[upn k (ren (+j))] = t.
Proof.
induction j as [| j ]; intros t k ht.
{ asimpl. rewrite up_id_n. autosubst. }
{ replace (ren (+S j)) with (ren (+1) >> ren (+j)) by autosubst.
rewrite <- up_comp_n.
replace (t.[upn k (ren (+1)) >> upn k (ren (+j))])
with (t.[upn k (ren (+1))].[upn k (ren (+j))]) by autosubst.
rewrite ht.
rewrite IHj by eauto.
eauto. }
Qed.
(* There follows that a substitution of the form [upn k sigma], where [sigma]
is regular, does not affect [t]. The proof is slightly subtle but very
short. The previous lemma is used twice. *)
Lemma fv_unaffected_regular:
forall k t sigma,
fv k t ->
regular sigma ->
t.[upn k sigma] = t.
Proof.
intros k t sigma ? (i&j&hsigma).
rewrite <- (fv_unaffected_lift i t k) at 1 by eauto.
asimpl. rewrite up_comp_n.
rewrite hsigma.
rewrite fv_unaffected_lift by eauto.
reflexivity.
Qed.
(* A corollary. *)
Lemma closed_unaffected_regular:
forall t sigma,
closed t ->
regular sigma ->
t.[sigma] = t.
Proof.
unfold closed. intros.
rewrite <- (upn0 sigma).
eauto using fv_unaffected_regular.
Qed.
(*One might also wish to prove a result along the following lines:
Goal
forall t k sigma1 sigma2,
fv k t ->
(forall x, x < k -> sigma1 x = sigma2 x) ->
t.[sigma1] = t.[sigma2].
I have not yet investigated how this could be proved. *)
(* -------------------------------------------------------------------------- *)
(* If some term [t] has free variables under [j], then it also has free
variables under [k], where [j <= k]. *)
Lemma fv_monotonic:
forall j k t,
fv j t ->
j <= k ->
fv k t.
Proof.
intros. unfold fv.
replace k with (j + (k - j)) by omega.
rewrite <- upn_upn.
eauto using fv_unaffected_regular, regular_upn, regular_plus.
Qed.
(* -------------------------------------------------------------------------- *)
(* These little lemmas may be occasionally useful. *)
Lemma use_fv_length_cons:
forall A (x : A) (xs : list A) n t,
(forall x, fv (length (x :: xs)) t) ->
n = length xs ->
fv (n + 1) t.
Proof.
intros. subst.
replace (length xs + 1) with (length (x :: xs)) by (simpl; omega).
eauto.
Qed.
Lemma prove_fv_length_cons:
forall A (x : A) (xs : list A) n t,
n = length xs ->
fv (n + 1) t ->
fv (length (x :: xs)) t.
Proof.
intros. subst.
replace (length (x :: xs)) with (length xs + 1) by (simpl; omega).
eauto.
Qed.
(* -------------------------------------------------------------------------- *)
(* [closed t] is equivalent to [t.[ren (+1)] = t]. *)
Lemma closed_eq:
forall t,
closed t <-> t.[ren (+1)] = t.
Proof.
unfold closed, fv. asimpl. tauto.
Qed.
(* -------------------------------------------------------------------------- *)
(* A variable is not closed. *)
Lemma closed_ids:
forall x,
~ closed (ids x).
Proof.
unfold closed, fv. intros. asimpl. intro.
eauto using ids_inj_False.
Qed.
End FreeVars.
(* -------------------------------------------------------------------------- *)
(* The tactic [fv] is intended to use a number of lemmas as rewriting rules.
The hint database [fv] can be extended with language-specific lemmas. *)
Hint Rewrite @fv_ids_eq @fv_lift @fv_eos_eq : fv.
Ltac fv :=
autorewrite with fv in *;
eauto with typeclass_instances.
(* -------------------------------------------------------------------------- *)
(* A hint database to prove goals of the form [~ (closed _)] or [closed _]. *)
Hint Resolve closed_ids : closed.
(* -------------------------------------------------------------------------- *)
Hint Resolve regular_ids regular_plus regular_upn : regular.
This diff is collapsed.
......@@ -14,12 +14,6 @@ Qed.
(* -------------------------------------------------------------------------- *)
(* The predicate [fv k t] means that the free variables of the term [t] are
contained in the semi-open interval [0..k). *)
Definition fv k t :=
t.[upn k (ren (+1))] = t.
(* The predicate [fv] is characterized by the following lemmas. *)
Lemma fv_Var_eq:
......@@ -67,28 +61,8 @@ Qed.
Hint Rewrite fv_Var_eq fv_Lam_eq fv_App_eq fv_Let_eq : fv.
(* The tactic [fv] uses the above lemmas as rewriting rules. *)
Ltac fv :=
autorewrite with fv in *.
(* -------------------------------------------------------------------------- *)
(* The predicate [closed t] means that the term [t] is closed, that is, [t]
has no free variables. *)
Definition closed :=
fv 0.
(* [closed t] is equivalent to [lift 1 t = t]. *)
Lemma closed_eq:
forall t,
closed t <-> lift 1 t = t.
Proof.
unfold closed, fv. asimpl. tauto.
Qed.
(* The following lemmas allow decomposing a closedness hypothesis.
Because [closed] is not an inductive notion, there is no lemma
for [Lam] and for the right-hand side of [Let]. *)
......
......@@ -3,6 +3,8 @@ Require Import MyTactics.
Require Export Autosubst.Autosubst.
Require Export AutosubstExtra.
Require Export Autosubst_IsRen.
(* Require Export Autosubst_EOS. *)
Require Export Autosubst_FreeVars.
(* The syntax of the lambda-calculus. *)
......@@ -18,6 +20,9 @@ Instance Rename_term : Rename term. derive. Defined.
Instance Subst_term : Subst term. derive. Defined.
Instance SubstLemmas_term : SubstLemmas term. derive. Qed.
Instance IdsLemmas_term : IdsLemmas term.
Proof. econstructor. intros. injections. eauto. Qed.
(* If the image of [t] through a substitution is a variable, then [t] must
itself be a variable. *)
......
Require Import List.
Require Import MyList.
Require Import MyTactics.
Require Import Sequences.
Require Import MetalSyntax.
Require Import Autosubst_Env.
(* -------------------------------------------------------------------------- *)
(* -------------------------------------------------------------------------- *)
(* A big-step call-by-value semantics with explicit environments. *)
(* Because every lambda-abstraction is closed, no closures are involved:
a lambda-abstraction evaluates to itself. Thus, an mvalue [mv] must be
either a (closed) lambda-abstraction or a pair of mvalues. *)
Inductive mvalue :=
| MVLam : {bind metal} -> mvalue
| MVPair : mvalue -> mvalue -> mvalue.
Definition dummy_mvalue : mvalue :=
MVLam (MVar 0).
(* An environment [e] is a list of mvalues. *)
Definition menv :=
list mvalue.
(* The judgement [mbigcbv e t mv] means that, under the environment [e], the
term [t] evaluates to [mv]. *)
Inductive mbigcbv : menv -> metal -> mvalue -> Prop :=
| MBigcbvVar:
forall e x mv,
(* The variable [x] must be in the domain of [e]. *)
x < length e ->
(* This allows us to safely look up [e] at [x]. *)
mv = nth x e dummy_mvalue ->
mbigcbv e (MVar x) mv
| MBigcbvLam:
forall e t,
(* The lambda-abstraction must have no free variables. *)
closed (MLam t) ->
mbigcbv e (MLam t) (MVLam t)
| MBigcbvApp:
forall e t1 t2 u1 mv2 mv,
(* Evaluate [t1] to a lambda-abstraction, *)
mbigcbv e t1 (MVLam u1) ->
(* evaluate [t2] to a value, *)
mbigcbv e t2 mv2 ->
(* and evaluate the function body in a singleton environment. *)
mbigcbv (mv2 :: nil) u1 mv ->
mbigcbv e (MApp t1 t2) mv
| MBigcbvLet:
forall e t1 t2 mv1 mv,
(* Evaluate [t1] to a value, *)
mbigcbv e t1 mv1 ->
(* and evaluate [t2] under a suitable environment. *)
mbigcbv (mv1 :: e) t2 mv ->
mbigcbv e (MLet t1 t2) mv
| MBigcbvPair:
forall e t1 t2 mv1 mv2,
(* Evaluate each component to a value, *)
mbigcbv e t1 mv1 ->
mbigcbv e t2 mv2 ->
(* and construct a pair. *)
mbigcbv e (MPair t1 t2) (MVPair mv1 mv2)
| MBigcbvPi:
forall e i t mv1 mv2 mv,
(* Evaluate [t] to a pair value, *)
mbigcbv e t (MVPair mv1 mv2) ->
(* and project out the desired component. *)
mv = match i with 0 => mv1 | _ => mv2 end ->
mbigcbv e (MPi i t) mv
.
Hint Constructors mbigcbv : mbigcbv.
(* -------------------------------------------------------------------------- *)
(* A reformulation of the evaluation rule for variables. *)
Lemma MBigcbvVarExact:
forall e1 mv e2 x,
x = length e1 ->
mbigcbv (e1 ++ mv :: e2) (MVar x) mv.
Proof.
intros. econstructor.
{ length. }
{ rewrite app_nth by eauto. reflexivity. }
Qed.
(* -------------------------------------------------------------------------- *)
(* -------------------------------------------------------------------------- *)
(* We now examine how the big-step semantics interacts with renamings.
We prove that if (roughly) the equation [e = xi >>> e'] holds then
evaluating [t.[xi]] under [e'] is the same as evaluating [t] under
[e]. *)
Lemma mbigcbv_ren:
forall e t mv,
mbigcbv e t mv ->
forall e' xi,
env_ren_comp e xi e' ->
mbigcbv e' t.[ren xi] mv.
Proof.
induction 1; intros;
try solve [ asimpl; eauto with env_ren_comp mbigcbv ].
(* MVar *)
{ pick @env_ren_comp invert.
econstructor; eauto. }
(* MLam *)
{ rewrite closed_unaffected by eauto.
eauto with mbigcbv. }
Qed.
(* As a special case, evaluating [eos x t] under an environment of the form
[e1 ++ mv :: e2], where length of [e1] is [x] (so [x] is mapped to [mv])
is the same as evaluating [t] under [e1 ++ e2]. The operational effect
of the end-of-scope mark [eos x _] is to delete the value stored at index
[x] in the evaluation environment. *)
Lemma mbigcbv_eos:
forall e1 e2 x t mv mw,
mbigcbv (e1 ++ e2) t mw ->
x = length e1 ->
mbigcbv (e1 ++ mv :: e2) (eos x t) mw.
Proof.
intros. eapply mbigcbv_ren; eauto with env_ren_comp.
Qed.
(* -------------------------------------------------------------------------- *)
(* -------------------------------------------------------------------------- *)
(* Evaluation rules for (simulated) tuples. *)
Fixpoint MVTuple mvs :=
match mvs with
| nil =>
MVLam (MVar 0)
| mv :: mvs =>
MVPair mv (MVTuple mvs)
end.
Lemma MBigcbvTuple:
forall e ts mvs,
(* Evaluate every component to a value, *)
Forall2 (mbigcbv e) ts mvs ->
(* and construct a tuple. *)
mbigcbv e (MTuple ts) (MVTuple mvs).