Expose more Coq files.

coq/AutosubstExtra.v

@@ -0,0 +1,169 @@
+Require Import Omega.
+Require Import Autosubst.Autosubst.
+
+(* -------------------------------------------------------------------------- *)
+
+(* A more recognizable notation for lifting. *)
+
+Notation lift i t := (t.[ren(+i)]).
+
+(* -------------------------------------------------------------------------- *)
+
+Section Extras.
+
+Context A `{Ids A, Rename A, Subst A, SubstLemmas A}.
+
+Lemma up_ren:
+  forall xi,
+  ren (upren xi) = up (ren xi).
+Proof.
+  intros. autosubst.
+Qed.
+
+Lemma upn_ren:
+  forall i xi,
+  ren (iterate upren i xi) = upn i (ren xi).
+Proof.
+  induction i; intros.
+  { reflexivity. }
+  { rewrite <- fold_up_upn. rewrite <- IHi. asimpl. reflexivity. }
+Qed.
+
+Lemma plus_upn: (* close to [up_liftn] *)
+  forall i sigma,
+  (+i) >>> upn i sigma = sigma >> ren (+i).
+Proof.
+  induction i; intros.
+  { rewrite iterate_0. autosubst. }
+  { rewrite iterate_S. asimpl. rewrite IHi. autosubst. }
+Qed.
+
+Lemma up_sigma_up_ren:
+  forall t i sigma,
+  t.[up sigma].[up (ren (+i))] = t.[up (ren (+i))].[upn (1 + i) sigma].
+Proof.
+  intros. asimpl. rewrite plus_upn. asimpl. reflexivity.
+Qed.
+
+Lemma upn_k_sigma_x:
+  forall k sigma x,
+  x < k ->
+  upn k sigma x = ids x.
+Proof.
+  induction k; intros; asimpl.
+  { omega. }
+  { destruct x; asimpl.
+    { eauto. }
+    { rewrite IHk by omega. autosubst. }
+  }
+Qed.
+
+Lemma push_substitution_last:
+  forall t v i,
+  t.[v .: ren (+i)] = t.[up (ren (+i))].[v/].
+Proof.
+  intros. autosubst.
+Qed.
+
+Lemma push_substitution_last_up_hoist:
+  forall t v i j,
+  t.[up (v .: ren (+i))].[up (ren (+j))] =
+  t.[up (up (ren (+j + i)))].[up (lift j v .: ids)].
+Proof.
+  intros. autosubst.
+Qed.
+
+Lemma lift_lift:
+  forall i j t,
+  lift i (lift j t) = lift (i + j) t.
+Proof.
+  intros. autosubst.
+Qed.
+
+Lemma lift_upn:
+  forall t i sigma,
+  (lift i t).[upn i sigma] = lift i t.[sigma].
+Proof.
+  intros. asimpl.
+  erewrite plus_upn.
+  reflexivity.
+Qed.
+
+Lemma lift_up:
+  forall t sigma,
+  (lift 1 t).[up sigma] = lift 1 t.[sigma].
+Proof.
+  intros. change up with (upn 1). eapply lift_upn.
+Qed.
+
+Lemma up_sigma_f:
+  forall (sigma : var -> A) (f : A -> A),
+  f (ids 0) = ids 0 ->
+  (forall i t, lift i (f t) = f (lift i t)) ->
+  up (sigma >>> f) = up sigma >>> f.
+Proof.
+  intros. f_ext. intros [|x]; asimpl; eauto.
+Qed.
+
+Lemma upn_sigma_f:
+  forall (sigma : var -> A) (f : A -> A),
+  f (ids 0) = ids 0 ->
+  (forall i t, lift i (f t) = f (lift i t)) ->
+  forall i,
+  upn i (sigma >>> f) = upn i sigma >>> f.
+Proof.
+  induction i; intros.
+  { reflexivity. }
+  { do 2 rewrite <- fold_up_upn. rewrite IHi. erewrite up_sigma_f by eauto. reflexivity. }
+Qed.
+
+Lemma upn_theta_sigma_ids:
+  forall theta sigma i,
+  theta >> sigma = ids ->
+  upn i theta >> upn i sigma = ids.
+Proof.
+  intros theta sigma i Hid.
+  rewrite up_comp_n.
+  rewrite Hid.
+  rewrite up_id_n.
+  reflexivity.
+Qed.
+
+Lemma up_theta_sigma_ids:
+  forall theta sigma,
+  theta >> sigma = ids ->
+  up theta >> up sigma = ids.
+Proof.
+  change up with (upn 1). eauto using upn_theta_sigma_ids.
+Qed.
+
+Lemma scons_scomp:
+  forall (T : A) Gamma theta,
+  T.[theta] .: (Gamma >> theta) = (T .: Gamma) >> theta.
+Proof.
+  intros. autosubst.
+Qed.
+
+(* BUG: the two sides of this equation are distinct, yet they are
+   printed identically. *)
+
+Goal
+  forall v f,
+  v .: (ids >>> f) = (v .: ids) >>> f.
+Proof.
+  intros.
+  Fail reflexivity.
+Abort.
+
+End Extras.
+
+(* This incantation means that [eauto with autosubst] can use the tactic
+   [autosubst] to prove an equality. *)
+
+Hint Extern 1 (_ = _) => autosubst : autosubst.
+
+(* This incantation means that [eauto with autosubst] can use the lemmas
+   whose names are listed here. This is useful when an equality involves
+   metavariables, so the tactic [autosubst] fails. *)
+
+Hint Resolve scons_scomp : autosubst.

coq/Autosubst_IsRen.v

@@ -0,0 +1,87 @@
+Require Import Coq.Logic.ClassicalUniqueChoice.
+Require Import Autosubst.Autosubst.
+Require Import AutosubstExtra.
+
+Section Lemmas.
+
+Context {A} `{Ids A, Rename A, Subst A, SubstLemmas A}.
+
+(* The predicate [is_ren sigma] means that the substitution [sigma] is in fact
+   a renaming [ren xi]. *)
+
+(* When stating a lemma that involves a renaming, it is preferable to use a
+   substitution [sigma], together with a hypothesis [is_ren sigma], rather
+   than request that [sigma] be of the form [ren xi]. This allows us to use
+   [obvious] to check that [sigma] is a renaming, whereas we would otherwise
+   have to manually rewrite [sigma] to the form [ren xi]. *)
+
+Definition is_ren sigma :=
+  exists xi, sigma = ren xi.
+
+(* One way of proving that [sigma] is a renaming is to prove that [sigma] maps
+   every variable [x] to a variable [y]. *)
+
+Lemma prove_is_ren:
+  forall sigma,
+  (forall x y, ids x = ids y -> x = y) ->
+  (forall x, exists y, sigma x = ids y) ->
+  is_ren sigma.
+Proof.
+  (* This proof uses the axiom of unique choice. If one is willing to use
+     the stronger axiom of choice, then one can remove the hypothesis that
+     [ids] is injective. *)
+  intros ? Hinj Hxy.
+  assert (Hxi: exists xi : var -> var, forall x, sigma x = ids (xi x)).
+  { eapply unique_choice with (R := fun x y => sigma x = ids y).
+    intros x. destruct (Hxy x) as [ y Heqy ]. exists y.
+    split.
+    { assumption. }
+    { intros x' Heqx'. eapply Hinj. congruence. }
+  }
+  destruct Hxi as [ xi ? ].
+  exists xi.
+  f_ext; intros x. eauto.
+Qed.
+
+(* Applying [up] or [upn i] to a renaming produces a renaming. *)
+
+Lemma up_is_ren:
+  forall sigma,
+  is_ren sigma ->
+  is_ren (up sigma).
+Proof.
+  intros ? [ xi ? ]. subst. exists (upren xi).
+  erewrite <- up_ren by eauto with typeclass_instances. reflexivity.
+Qed.
+
+Lemma upn_is_ren:
+  forall sigma i,
+  is_ren sigma ->
+  is_ren (upn i sigma).
+Proof.
+  intros ? ? [ xi ? ]. subst. exists (iterate upren i xi).
+  erewrite <- upn_ren by eauto with typeclass_instances. reflexivity.
+Qed.
+
+(* Composing two renamings yields a renaming. *)
+
+Lemma comp_is_ren:
+  forall sigma1 sigma2,
+  is_ren sigma1 ->
+  is_ren sigma2 ->
+  is_ren (sigma1 >> sigma2).
+Proof.
+  intros ? ? [ xi1 ? ] [ xi2 ? ]. subst. exists (xi1 >>> xi2). autosubst.
+Qed.
+
+Lemma is_ren_ids:
+  is_ren ids.
+Proof.
+  exists id. autosubst.
+Qed.
+
+End Lemmas.
+
+Hint Unfold is_ren : is_ren obvious.
+
+Hint Resolve up_is_ren upn_is_ren comp_is_ren is_ren_ids : is_ren obvious.

coq/LambdaCalculusBigStep.v

@@ -0,0 +1,534 @@
+Require Import List.
+Require Import MyTactics.
+Require Import Sequences.
+Require Import LambdaCalculusSyntax.
+Require Import LambdaCalculusFreeVars.
+Require Import LambdaCalculusValues.
+Require Import LambdaCalculusReduction.
+
+(* -------------------------------------------------------------------------- *)
+(* -------------------------------------------------------------------------- *)
+
+(* A big-step call-by-value semantics. *)
+
+Inductive bigcbv : term -> term -> Prop :=
+| BigcbvValue:
+    forall v,
+    is_value v ->
+    bigcbv v v
+| BigcbvApp:
+    forall t1 t2 u1 v2 v,
+    bigcbv t1 (Lam u1) ->
+    bigcbv t2 v2 ->
+    bigcbv u1.[v2/] v ->
+    bigcbv (App t1 t2) v
+| BigcbvLet:
+    forall t1 t2 v1 v,
+    bigcbv t1 v1 ->
+    bigcbv t2.[v1/] v ->
+    bigcbv (Let t1 t2) v
+.
+
+Hint Constructors bigcbv : bigcbv.
+
+(* The tactic [invert_bigcbv] looks for a hypothesis of the form [bigcbv t v]
+   and inverts it. *)
+
+Ltac invert_bigcbv :=
+  pick bigcbv invert;
+  try solve [ false; eauto 3 with obvious ].
+
+(* -------------------------------------------------------------------------- *)
+
+(* If [bigcbv t v] holds, then [v] must be a value. *)
+
+Lemma bigcbv_is_value:
+  forall t v,
+  bigcbv t v ->
+  is_value v.
+Proof.
+  induction 1; eauto.
+Qed.
+
+Hint Resolve bigcbv_is_value : is_value obvious.
+
+(* -------------------------------------------------------------------------- *)
+
+(* If [t] evaluates to [v] according to the big-step semantics,
+   then [t] reduces to [v] according to the small-step semantics. *)
+
+Lemma bigcbv_star_cbv:
+  forall t v,
+  bigcbv t v ->
+  star cbv t v.
+Proof.
+  (* A detailed proof: *)
+  induction 1.
+  (* BigcbvValue *)
+  { eapply star_refl. }
+  (* BigcbvApp *)
+  { eapply star_trans. obvious.
+    eapply star_trans. obvious.
+    eapply star_step. obvious.
+    eauto. }
+  (* BigcbvLet *)
+  { eapply star_trans. obvious.
+    eapply star_step. obvious.
+    eauto. }
+Restart.
+  (* A much shorter proof: *)
+  induction 1; eauto 6 with sequences obvious.
+Qed.
+
+(* Conversely, if [t] reduces to [v] in the small-step semantics,
+   then [t] evaluates to [v] in the big-step semantics. *)
+
+Lemma cbv_bigcbv_bigcbv:
+  forall t1 t2,
+  cbv t1 t2 ->
+  forall v,
+  bigcbv t2 v ->
+  bigcbv t1 v.
+Proof.
+  (* A detailed proof: *)
+  induction 1; intros; subst; try solve [ false; tauto ].
+  (* BetaV *)
+  { econstructor; eauto with bigcbv. }
+  (* LetV *)
+  { econstructor; eauto with bigcbv. }
+  (* AppL *)
+  { invert_bigcbv. eauto with bigcbv. }
+  (* AppR *)
+  { invert_bigcbv. eauto with bigcbv. }
+  (* LetL *)
+  { invert_bigcbv. eauto with bigcbv. }
+Restart.
+  (* A shorter proof: *)
+  induction 1; intros; subst; try solve [ false; tauto
+  | econstructor; eauto with bigcbv
+  | invert_bigcbv; eauto with bigcbv
+  ].
+Qed.
+
+Lemma star_cbv_bigcbv:
+  forall t v,
+  star cbv t v ->
+  is_value v ->
+  bigcbv t v.
+Proof.
+  induction 1; eauto using cbv_bigcbv_bigcbv with bigcbv.
+Qed.
+
+(* In conclusion, we have the following equivalence: *)
+
+Theorem star_cbv_bigcbv_eq:
+  forall t v,
+  (star cbv t v /\ is_value v) <-> bigcbv t v.
+Proof.
+  split; intros; unpack;
+  eauto using star_cbv_bigcbv, bigcbv_star_cbv with is_value.
+Qed.
+
+(* -------------------------------------------------------------------------- *)
+(* -------------------------------------------------------------------------- *)
+
+(* A big-step call-by-value semantics with explicit environments. *)
+
+(* A closure is a pair of a term and an environment. A cvalue [cv] must be a
+   closure, as we have no other forms of values. An environment [e] is a list
+   of cvalues. *)
+
+(* We break the mutual induction between [cvalue] and [cenv] by inlining the
+   definition of [cenv] into the definition of [cvalue]. *)
+
+(* CVALUE *)
+Inductive cvalue :=
+| Clo: {bind term} -> list cvalue -> cvalue.
+
+Definition cenv :=
+  list cvalue.
+(* CVALUE *)
+
+(* This dummy cvalue is passed below as an argument to [nth], but is really
+   irrelevant, as the condition [x < length e] ensures that the dummy cvalue
+   is never used. *)
+
+Definition dummy_cvalue : cvalue :=
+  Clo (Var 0) nil.
+
+(* The judgement [ebigcbv e t cv] means that, under the environment [e], the
+   term [t] evaluates to [cv]. *)
+
+Inductive ebigcbv : cenv -> term -> cvalue -> Prop :=
+| EBigcbvVar:
+    forall e x cv,
+    (* The variable [x] must be in the domain of [e]. *)
+    x < length e ->
+    (* This allows us to safely look up [e] at [x]. *)
+    cv = nth x e dummy_cvalue ->
+    ebigcbv e (Var x) cv
+| EBigcbvLam:
+    forall e t,
+    (* The free variables of [t] must be less than or equal to [length e]. *)
+    (forall cv, fv (length (cv :: e)) t) ->
+    (* This allows us to build a closure that is indeed closed. *)
+    ebigcbv e (Lam t) (Clo t e)
+| EBigcbvApp:
+    forall e e' t1 t2 u1 cv2 cv,
+    (* Evaluate [t1] to a closure, *)
+    ebigcbv e t1 (Clo u1 e') ->
+    (* evaluate [t2] to a value, *)
+    ebigcbv e t2 cv2 ->
+    (* and evaluate the function body, in a suitable environment. *)
+    ebigcbv (cv2 :: e') u1 cv ->
+    ebigcbv e (App t1 t2) cv
+| EBigcbvLet:
+    forall e t1 t2 cv1 cv,
+    (* Evaluate [t1] to a value, *)
+    ebigcbv e t1 cv1 ->
+    (* and evaluate [t2] under a suitable environment. *)
+    ebigcbv (cv1 :: e) t2 cv ->
+    ebigcbv e (Let t1 t2) cv
+.
+
+Hint Constructors ebigcbv : ebigcbv.
+
+(* -------------------------------------------------------------------------- *)
+
+(* To explain what the above semantics means, and to prove that it is
+   equivalent to the big-step semantics, we first define a function that
+   decodes a cvalue into a value. *)
+
+(* Ideally, the function [decode] should be defined by the equation:
+
+     decode (Clo t e) = (Lam t).[decode_cenv e]
+
+   where the auxiliary function [decode_cenv] maps [decode] over the
+   environment [e], and converts the result to a substitution, that
+   is, a function of type [term -> term]:
+
+     decode_cenv e = fun x => nth x (map decode e) (decode dummy_cvalue)
+
+   The definitions below are a bit more awkward (as Coq does not support
+   mutual induction very well), but mean the same thing. *)
+
+Definition dummy_value : term :=
+  Lam (Var 0).
+
+Fixpoint decode (cv : cvalue) : term :=
+  match cv with
+  | Clo t e =>
+      (Lam t).[fun x => nth x (map decode e) dummy_value]
+  end.
+  (* I am not even sure why this definition is accepted by Coq? *)
+
+Definition decode_cenv e :=
+  fun x => nth x (map decode e) (decode dummy_cvalue).
+
+(* The first equation in the above comment is satisfied, as shown by
+   the following lemma. The second equation in the above comment is
+   satisfied too, by definition. *)
+
+Lemma decode_eq:
+  forall t e,
+  decode (Clo t e) = (Lam t).[decode_cenv e].
+Proof.
+  reflexivity.
+Qed.
+
+(* This equation is useful, too. *)
+
+Lemma decode_cenv_Var_eq:
+  forall x e,
+  (Var x).[decode_cenv e] = decode (nth x e dummy_cvalue).
+Proof.
+  intros. asimpl. unfold decode_cenv. rewrite map_nth. eauto.
+Qed.
+
+(* The tactic [decode] rewrites using the above two equations. *)
+
+Hint Rewrite decode_eq decode_cenv_Var_eq : decode.
+Ltac decode := autorewrite with decode in *.
+
+(* We make [decode] opaque, so its definition is not unfolded by Coq. *)
+
+Opaque decode.
+
+(* [decode cv] is always a value. *)
+
+Lemma is_value_decode:
+  forall cv,
+  is_value (decode cv).
+Proof.
+  intros. destruct cv. decode. asimpl. tauto.
+Qed.
+
+Lemma is_value_decode_cenv:
+  forall x e,
+  is_value (Var x).[decode_cenv e].
+Proof.
+  intros. decode. eauto using is_value_decode.
+Qed.
+
+Local Hint Resolve is_value_decode is_value_decode_cenv : is_value obvious.
+
+(* A composition of two substitutions is the same thing as one substitution. *)
+
+Lemma decode_cenv_cons:
+  forall t e cv,
+  t.[up (decode_cenv e)].[decode cv/] = t.[decode_cenv (cv :: e)].
+Proof.
+  intros. autosubst. (* wonderful *)
+Qed.
+
+(* The tactic [nonvalue_eq_decode] closes a subgoal when there is a hypothesis
+   of the form [_ = decode_cenv e x], where the left-hand side of the equation
+   clearly is not a value. This is a contradiction. *)
+
+Ltac nonvalue_eq_decode :=
+  match goal with
+  | heq: _ = decode_cenv ?e ?x |- _ =>
+      assert (hv: is_value (decode_cenv e x)); [
+        solve [ obvious ]
+      | rewrite <- heq in hv; false; is_value ]
+  end.
+
+(* -------------------------------------------------------------------------- *)
+
+(* If [t] evaluates to [cv] under environment [e],
+   then, in the big-step semantics,
+   the term [t.[decode_cenv e]] evaluates to the value [decode cv]. *)
+
+Lemma ebigcbv_bigcbv:
+  forall e t cv,
+  ebigcbv e t cv ->
+  bigcbv t.[decode_cenv e] (decode cv).
+Proof.
+  induction 1; intros; subst.
+  (* EBigcbvVar *)
+  { decode. econstructor. obvious. }
+  (* EBigcbvLam *)
+  { econstructor. obvious. }
+  (* EBigcbvApp *)
+  { decode.
+    asimpl. econstructor; eauto.
+    asimpl. eauto. }
+  (* EBigcbvLet *)
+  { asimpl. econstructor; eauto.
+    asimpl. eauto. }
+Qed.
+
+(* A simplified corollary, where [t] is closed and is therefore evaluated
+   under the empty environment. *)
+
+Lemma ebigcbv_bigcbv_nil:
+  forall t cv,
+  ebigcbv nil t cv ->
+  closed t ->
+  bigcbv t (decode cv).
+Proof.
+  intros.
+  replace t with t.[decode_cenv nil] by eauto using closed_unaffected.
+  eauto using ebigcbv_bigcbv.
+Qed.
+
+(* -------------------------------------------------------------------------- *)
+
+(* The converse statement: if in the big-step semantics, the term
+   [t.[decode_cenv e]] evaluates to the value [decode cv], then [t] evaluates
+   to [cv] under environment [e]. *)
+
+(* This proof does not work (and, in fact, the statement is wrong). A failed
+   proof attempt reveals two problems... *)
+
+Lemma bigcbv_ebigcbv_failed:
+  forall e t cv,
+  bigcbv t.[decode_cenv e] (decode cv) ->
+  ebigcbv e t cv.
+Proof.
+  inversion 1; intros; subst.
+  (* BigcbvValue *)
+  { (* [t] must be a variable or a lambda-abstraction. *)
+    destruct t; [ | | false; is_value | false; is_value ].
+    (* Case: [t] is a variable. *)
+    { econstructor.
+      (* Here, we have two subgoals, neither of which can be proved. *)
+      { (* Problem 1: we are unable to prove [x < length e]. In order
+           to establish such a property, we would have to express the
+           hypothesis that the free variables of [t] are in the domain
+           of the environment [e]. And, for this hypothesis to be
+           inductive, we have to further require every closure in
+           the environment [e] to satisfy a similar condition. *)
+        admit. }
+      { (* Problem 2: we have [decode cv1 = decode cv2], and the goal
+           is [cv1 = cv2]. This goal cannot be proved, as the function
+           [decode] is not injective: multiple closures represent the
+           same lambda-abstraction. *)
+        decode.
+        admit. }
+Abort.
+
+(* -------------------------------------------------------------------------- *)
+
+(* In order to fix the above failed statement, we need to express the
+   following well-formedness invariant: whenever a closure [Clo t e] is
+   constructed, the free variables of the term [t] are in the domain of the
+   environment [env], and, recursively, every value in [e] is well-formed. *)
+
+Inductive wf_cvalue : cvalue -> Prop :=
+| WfCvalue:
+    forall t e,
+    (forall cv, fv (length (cv :: e)) t) ->
+    wf_cenv e ->
+    wf_cvalue (Clo t e)
+
+with wf_cenv : cenv -> Prop :=
+| WfCenv:
+    forall e,
+    Forall wf_cvalue e ->
+    wf_cenv e.
+
+(* The following trivial lemmas (which repeat the definition) are provided as
+   hints for [eauto with wf_cvalue]. *)
+
+Lemma use_wf_cvalue_1:
+  forall t e cv,
+  wf_cvalue (Clo t e) ->
+  fv (length (cv :: e)) t.
+Proof.
+  inversion 1; eauto.
+Qed.
+
+Lemma use_wf_cvalue_2:
+  forall t e,
+  wf_cvalue (Clo t e) ->
+  wf_cenv e.
+Proof.
+  inversion 1; eauto.
+Qed.
+
+Lemma prove_wf_cenv_nil:
+  wf_cenv nil.
+Proof.
+  econstructor. eauto.
+Qed.
+
+Lemma prove_wf_cenv_cons:
+  forall cv e,
+  wf_cvalue cv ->
+  wf_cenv e ->
+  wf_cenv (cv :: e).
+Proof.
+  inversion 2; intros; subst.
+  econstructor.
+  econstructor; eauto.
+Qed.
+
+Hint Resolve
+  use_wf_cvalue_1 use_wf_cvalue_2 prove_wf_cenv_nil prove_wf_cenv_cons
+: wf_cvalue.
+
+(* The following lemma states that the invariant is preserved by [ebigcbv].
+   That is, if the term [t] is successfully evaluated in the well-formed
+   environment [e] to a cvalue [cv], then [cv] is well-formed. *)
+
+Lemma ebigcbv_wf_cvalue:
+  forall e t cv,
+  ebigcbv e t cv ->
+  wf_cenv e ->
+  wf_cvalue cv.
+Proof.
+  induction 1; intros; subst.
+  (* EBigcbvVar *)
+  { pick wf_cenv invert. rewrite Forall_forall in *. eauto using nth_In. }
+  (* EBigcbvLam *)
+  { econstructor; eauto. }
+  (* EBigcbvApp *)
+  { eauto 6 with wf_cvalue. }
+  (* EBigcbvLet *)
+  { eauto 6 with wf_cvalue. }
+Qed.
+
+Hint Resolve ebigcbv_wf_cvalue : wf_cvalue.
+
+(* -------------------------------------------------------------------------- *)
+
+(* We can now make an amended statement: if in the big-step semantics, the
+   term [t.[decode_cenv e]] evaluates to a value [v], if the environment [e]
+   is well-formed, and if the free variables of [t] are in the domain of [e],
+   then under environment [e] the term [t] evaluates to some cvalue [cv] such
+   that [decode cv] is [v]. *)
+
+Lemma bigcbv_ebigcbv:
+  forall te v,
+  bigcbv te v ->
+  forall t e,
+  te = t.[decode_cenv e] ->
+  fv (length e) t ->
+  wf_cenv e ->
+  exists cv,
+  ebigcbv e t cv /\ decode cv = v.
+Proof.
+  induction 1; intros; subst.
+  (* BigcbvValue *)
+  { (* [t] must be a variable or a lambda-abstraction. *)
+    destruct t; [ | | false; is_value | false; is_value ]; fv.
+    (* Case: [t] is a variable. *)
+    { eexists; split. econstructor; eauto. decode. eauto. }
+    (* Case: [t] is a lambda-abstraction. *)
+    { eexists; split. econstructor; eauto. reflexivity. }
+  }
+  (* BigcbvApp *)
+  { (* [t] must be an application. *)
+    destruct t;
+    match goal with h: _ = _ |- _ => asimpl in h end;
+    [ nonvalue_eq_decode | false; congruence | | false; congruence ].
+    fv. unpack.
+    (* The equality [App _ _ = App _ _] can be simplified. *)
+    injections. subst.
+    (* Exploit two of the induction hypotheses (forward). *)
+    edestruct IHbigcbv1; eauto. unpack. clear IHbigcbv1.
+    edestruct IHbigcbv2; eauto. unpack. clear IHbigcbv2.
+    (* If [decode cv] is [Lam _], then [cv] must be a closure. This should
+       be a lemma. Because (here) every cvalue is a closure, it is trivial. *)
+    match goal with h: decode ?cv = Lam _ |- _ =>
+      destruct cv as [ t' e' ];
+      rewrite decode_eq in h;
+      asimpl in h;
+      injections; subst
+    end.
+    (* Now, exploit the third induction hypothesis (forward). *)
+    edestruct IHbigcbv3; eauto using decode_cenv_cons with wf_cvalue.
+    unpack. clear IHbigcbv3.
+    (* The result follows. *)
+    eauto with ebigcbv.
+  }
+  (* BigcbvLet *)
+  { (* [t] must be a [Let] construct. *)
+    destruct t;
+    match goal with h: _ = _ |- _ => asimpl in h end;
+    [ nonvalue_eq_decode | false; congruence | false; congruence | ].
+    fv. unpack.
+    injections. subst.
+    (* Exploit the induction hypotheses (forward). *)
+    edestruct IHbigcbv1; eauto. unpack. clear IHbigcbv1.
+    edestruct IHbigcbv2; eauto using decode_cenv_cons with wf_cvalue.
+    unpack. clear IHbigcbv2.
+    (* The result follows. *)
+    eauto with ebigcbv.
+  }
+Qed.
+
+(* A simplified corollary, where [t] is closed and is therefore evaluated
+   under the empty environment. *)
+
+Lemma bigcbv_ebigcbv_nil:
+  forall t v,
+  bigcbv t v ->
+  closed t ->
+  exists cv,
+  ebigcbv nil t cv /\ decode cv = v.
+Proof.
+  intros. eapply bigcbv_ebigcbv; eauto with wf_cvalue.
+  rewrite closed_unaffected by eauto. reflexivity.
+Qed.

coq/LambdaCalculusFreeVars.v

@@ -0,0 +1,152 @@
+Require Import MyTactics.
+Require Import LambdaCalculusSyntax.
+
+(* This technical lemma states that the renaming [lift 1] is injective. *)
+
+Lemma lift_inj_Var:
+  forall t x,
+  lift 1 t = Var (S x) <-> t = Var x.
+Proof.
+  split; intros.
+  { eauto using lift_inj. }
+  { subst. eauto. }
+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:
+  forall k x,
+  fv k (Var x) <-> x < k.
+Proof.
+  unfold fv. asimpl. induction k; intros.
+  (* Base case. *)
+  { asimpl. split; intros; false.
+    { unfold ids, Ids_term in *. injections. omega. }
+    { omega. }
+  }
+  (* Step. *)
+  { destruct x; asimpl.
+    { split; intros. { omega. } { reflexivity. } }
+    rewrite lift_inj_Var. rewrite IHk. omega. }
+Qed.
+
+Lemma fv_Lam_eq:
+  forall k t,
+  fv k (Lam t) <-> fv (S k) t.
+Proof.
+  unfold fv. intros. asimpl. split; intros.
+  { injections. eauto. }
+  { unpack. congruence. }
+Qed.
+
+Lemma fv_App_eq:
+  forall k t1 t2,
+  fv k (App t1 t2) <-> fv k t1 /\ fv k t2.
+Proof.
+  unfold fv. intros. asimpl. split; intros.
+  { injections. eauto. }
+  { unpack. congruence. }
+Qed.
+
+Lemma fv_Let_eq:
+  forall k t1 t2,
+  fv k (Let t1 t2) <-> fv k t1 /\ fv (S k) t2.
+Proof.
+  unfold fv. intros. asimpl. split; intros.
+  { injections. eauto. }
+  { unpack. congruence. }
+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]. *)
+
+Lemma closed_Var:
+  forall x,
+  ~ closed (Var x).
+Proof.
+  unfold closed; intros; fv. omega.
+Qed.
+
+Lemma closed_AppL:
+  forall t1 t2,
+  closed (App t1 t2) ->
+  closed t1.
+Proof.
+  unfold closed; intros; fv. tauto.
+Qed.
+
+Lemma closed_AppR:
+  forall t1 t2,
+  closed (App t1 t2) ->
+  closed t2.
+Proof.
+  unfold closed; intros; fv. tauto.
+Qed.
+
+Lemma closed_LetL:
+  forall t1 t2,
+  closed (Let t1 t2) ->
+  closed t1.
+Proof.
+  unfold closed; intros; fv. tauto.
+Qed.
+
+Hint Resolve closed_Var closed_AppL closed_AppR closed_LetL : closed.
+
+(* -------------------------------------------------------------------------- *)
+
+(* If the free variables of the term [t] are below [k], then [t] is unaffected
+   by a substitution of the form [upn k sigma]. *)
+
+Lemma fv_unaffected:
+  forall t k sigma,
+  fv k t ->
+  t.[upn k sigma] = t.
+Proof.
+  induction t; intros; fv; unpack; asimpl;
+  try solve [ eauto using upn_k_sigma_x with typeclass_instances
+            | f_equal; eauto ].
+Qed.
+
+(* If the term [t] is closed, then [t] is unaffected by any substitution. *)
+
+Lemma closed_unaffected:
+  forall t sigma,
+  closed t ->
+  t.[sigma] = t.
+Proof.
+  intros. eapply fv_unaffected with (k := 0). eauto.
+Qed.

coq/LambdaCalculusInterpreter.v

@@ -0,0 +1,226 @@
+Require Import Option.
+Require Import List.
+Require Import MyTactics.
+Require Import LambdaCalculusSyntax.
+Require Import LambdaCalculusFreeVars.
+Require Import LambdaCalculusBigStep.
+
+(* We now wish to define an interpreter for the lambda-calculus. In other
+   words, whereas [ebigcbv] is a relation, we now wish to define a function
+   [interpret] whose graph is the relation [ebigcbv]. *)
+
+(* At the moment, our lambda-calculus is pure (every value is a function)
+   so the interpreter cannot encounter a runtime error. *)
+
+(* -------------------------------------------------------------------------- *)
+
+(* We might naively wish to write the following code, which Coq rejects,
+   because this function is not obviously terminating. (Exercise: which
+   recursive call is the culprit?) Indeed, an interpreter for the untyped
+   lambda-calculus does not always terminate: there are lambda-terms whose
+   evaluation diverges. (Exercise: exhibit a term that reduces to itself
+   in one or more reduction steps. Prove in Coq that this is the case.) *)
+
+(* FAILINTERPRET *)
+Fail Fixpoint interpret (e : cenv) (t : term) : cvalue :=
+  match t with
+  | Var x =>
+      nth x e dummy_cvalue
+        (* dummy is used when x is out of range *)
+  | Lam t =>
+      Clo t e
+  | App t1 t2 =>
+      let cv1 := interpret e t1 in
+      let cv2 := interpret e t2 in
+      match cv1 with Clo u1 e' =>
+        interpret (cv2 :: e') u1
+      end
+(* FAILINTERPRET *)
+  | Let t1 t2 =>
+      let cv1 := interpret e t1 in
+      interpret (cv1 :: e) t2
+(* FAILINTERPRET *)
+  end.
+(* FAILINTERPRET *)
+
+(* -------------------------------------------------------------------------- *)
+
+(* There are several potential solutions to the above problem. One solution
+   would be to write code in (some implementation of) the partiality monad.
+   (See Dagand's lectures.) The solution proposed here is to parameterize
+   the function [interpret] with a natural integer [n], which serves as an
+   amount of "fuel" (or "effort") that we are willing to invest before we
+   give up. Thus, termination becomes obvious. The downside is that the
+   interpreter can now fail (which means "not enough fuel"). Fortunately,
+   given enough fuel, every terminating term can be evaluated. *)
+
+(* For Coq to accept the following definition, the fuel [n] must decrease at
+   every recursive call. We might wish to be more precise and somehow explain
+   that [n] needs to decrease only at the third recursive call in the case of
+   [App]lications. That would require defining a lexicographic ordering on the
+   pair [n, t], arguing that this ordering is well-founded, and defining
+   [interpret] by well-founded recursion. This can be done in Coq but is more
+   complicated, so (here) not worth the trouble. *)
+
+(* FIXINTERPRET *)
+Fixpoint interpret (n : nat) e t : option cvalue :=
+  match n with
+  | 0   => None (* not enough fuel *)
+  | S n =>
+      match t with
+      | Var x     => Some (nth x e dummy_cvalue)
+      | Lam t     => Some (Clo t e)
+      | App t1 t2 =>
+          interpret n e t1 >>= fun cv1 =>
+          interpret n e t2 >>= fun cv2 =>
+          match cv1 with Clo u1 e' =>
+            interpret n (cv2 :: e') u1
+          end
+(* FIXINTERPRET *)
+      | Let t1 t2 =>
+          interpret n e t1 >>= fun cv1 =>
+          interpret n (cv1 :: e) t2
+(* FIXINTERPRET *)
+  end end.
+(* FIXINTERPRET *)
+
+(* -------------------------------------------------------------------------- *)
+
+(* The interpreter is correct with respect to the big-step semantics. *)
+
+Lemma interpret_ebigcbv:
+  forall n e t cv,
+  interpret n e t = Some cv ->
+  fv (length e) t ->
+  wf_cenv e ->
+  ebigcbv e t cv.
+Proof.
+  (* The definition of [interpret] is by induction on [n], so this proof
+     must be by induction on [n] as well. *)
+  induction n; destruct t; simpl; intros;
+  fv; unpack; injections; subst;
+  try solve [ congruence ].
+  (* Var *)
+  { econstructor; eauto. }
+  (* Lam *)
+  { econstructor; eauto. }
+  (* App *)
+  { repeat invert_bind_Some.
+    (* Every cvalue is a closure. Name the components of the closure
+       obtained by interpreting [t1]. *)
+    match goal with h: interpret _ _ t1 = Some ?cv |- _ =>
+      destruct cv as [ t' e' ]
+    end.
+    (* The goal follows. *)
+    econstructor; eauto 11 with wf_cvalue. }
+  (* Let *)
+  { invert_bind_Some.
+    econstructor; eauto with wf_cvalue. }
+Qed.
+
+(* A simplified corollary, where [t] is closed and is therefore evaluated
+   under the empty environment, and where we conclude with a [bigcbv]
+   judgement. *)
+
+Lemma interpret_bigcbv_nil:
+  forall n t cv,
+  interpret n nil t = Some cv ->
+  closed t ->
+  bigcbv t (decode cv).
+Proof.
+  eauto using ebigcbv_bigcbv_nil, interpret_ebigcbv with wf_cvalue.
+Qed.
+
+(* -------------------------------------------------------------------------- *)
+
+(* The interpreter is monotonic with respect to the amount of fuel that is
+   provided: the more fuel, the better (that is, the more defined the result). *)
+
+Lemma interpret_monotonic:
+  forall n1 n2 e t,
+  n1 <= n2 ->
+  less_defined (interpret n1 e t) (interpret n2 e t).
+Proof.
+  (* This series of tactics get rid of the easy cases: *)
+  induction n1; destruct t; simpl; intros;
+  (* [less_defined None _] is always true. *)
+  eauto with less_defined;
+  (* If [S n1 <= n2], then [n2] must be a successor. *)
+  (destruct n2; [ omega |]); simpl;
+  (* [less_defined] is reflexive. *)
+  eauto with less_defined.
+
+  (* Two more complex cases remain, namely [App] and [Let]. Probably
+     the proof could be further automated, but I did not try. *)
+  (* App *)
+  { eapply prove_less_defined_bind.
+    { eauto using le_S_n. }
+    { intros _ [ t' e' ]. (* destruct the closure produced by [t1] *)
+      eapply prove_less_defined_bind; eauto using le_S_n. }
+  }
+  (* Let *)
+  { eauto 6 using le_S_n with less_defined. }
+Qed.
+
+(* A reformulation. *)
+
+Lemma interpret_monotonic_corollary:
+  forall n1 n2 e t cv,
+  interpret n1 e t = Some cv ->
+  n1 <= n2 ->
+  interpret n2 e t = Some cv.
+Proof.
+  generalize interpret_monotonic. unfold less_defined. eauto.
+Qed.
+
+(* -------------------------------------------------------------------------- *)
+
+(* The interpreter is complete with respect to the big-step semantics
+   [ebigcbv]. That is, given enough fuel, and given a term whose value is
+   [cv], it will compute [cv]. *)
+
+Lemma ebigcbv_interpret:
+  forall e t cv,
+  ebigcbv e t cv ->
+  exists n,
+  interpret n e t = Some cv.
+Proof.
+  (* We can see, in the proof, that the necessary amount of fuel, [n], is
+     the height of the derivation of the judgement [ebigcbv e t cv].
+     Indeed, at every [App] or [Let] node, we count 1 plus the maximum
+     amount of fuel required by our children. *)
+  induction 1; intros; subst.
+  (* EBigcbvVar *)
+  { exists 1. eauto. }
+  (* EBigcbvLam *)
+  { exists 1. eauto. }
+  (* EBigcbvApp *)
+  { destruct IHebigcbv1 as [ n1 ? ].
+    destruct IHebigcbv2 as [ n2 ? ].
+    destruct IHebigcbv3 as [ n3 ? ].
+    eexists (S (max (max n1 n2) n3)). simpl.
+    eauto 6 using prove_bind_Some, interpret_monotonic_corollary with omega. }
+  (* EBigcbvLet *)
+  { destruct IHebigcbv1 as [ n1 ? ].
+    destruct IHebigcbv2 as [ n2 ? ].
+    eexists (S (max n1 n2)). simpl.
+    eauto using prove_bind_Some, interpret_monotonic_corollary with omega. }
+Qed.
+
+(* The interpreter is complete with respect to the big-step semantics
+   [bigcbv]. That is, given enough fuel, and given a term [t] whose value is
+   [v], it will compute a cvalue [cv] which decodes to [v]. We state this in
+   the case where [t] is closed and is therefore evaluated under the empty
+   environment. *)
+
+Lemma bigcbv_interpret_nil:
+  forall t v,
+  bigcbv t v ->
+  closed t ->
+  exists n cv,
+  interpret n nil t = Some cv /\ decode cv = v.
+Proof.
+  intros.
+  edestruct bigcbv_ebigcbv_nil; eauto. unpack.
+  edestruct ebigcbv_interpret; eauto.
+Qed.

coq/LambdaCalculusReduction.v

@@ -0,0 +1,619 @@
+Require Import MyTactics.
+Require Import Sequences.
+Require Import LambdaCalculusSyntax.
+Require Import LambdaCalculusValues.
+Require Import LambdaCalculusFreeVars.
+
+(* We give a symbolic name to each reduction rule. *)
+
+Inductive rule :=
+| RuleBetaV    (* reduction of a beta-v redex: (\x.t) v                   *)
+| RuleLetV     (* reduction of a let-v redex:  let x = v in t             *)
+| RuleBeta     (* reduction of a beta   redex: (\x.t) u                   *)
+| RuleLet      (* reduction of a let redex:    let x = u in t             *)
+| RuleParBetaV (* reduction of a beta-v redex and reduction in both sides *)
+| RuleParLetV  (* reduction of a let redex and reduction in both sides    *)
+| RuleVar      (* no reduction                                            *)
+| RuleLam      (* reduction in [Lam _]                                    *)
+| RuleAppL     (* reduction in [App _ u]                                  *)
+| RuleAppVR    (* reduction in [App v _], if [v] is a value               *)
+| RuleAppLR    (* reduction in both sides of [App _ _]                    *)
+| RuleLetL     (* reduction in [Let _ u]                                  *)
+| RuleLetR     (* reduction in [Let t _]                                  *)
+| RuleLetLR    (* reduction in both sides of [Let _ _]                    *).
+
+(* A mask is a set of rules. *)
+
+Definition mask :=
+  rule -> Prop.
+
+(* A generic small-step reduction semantics, parameterized with a mask. *)
+
+Inductive red (mask : mask) : term -> term -> Prop :=
+| RedBetaV:
+    forall t v u,
+    mask RuleBetaV ->
+    is_value v ->
+    t.[v/] = u ->
+    red mask (App (Lam t) v) u
+| RedLetV:
+    forall t v u,
+    mask RuleLetV ->
+    is_value v ->
+    t.[v/] = u ->
+    red mask (Let v t) u
+| RedBeta:
+    forall t1 t2 u,
+    mask RuleBeta ->
+    t1.[t2/] = u ->
+    red mask (App (Lam t1) t2) u
+| RedLet:
+    forall t1 t2 u,
+    mask RuleLet ->
+    t2.[t1/] = u ->
+    red mask (Let t1 t2) u
+| RedParBetaV:
+    forall t1 v1 t2 v2 u,
+    mask RuleParBetaV ->
+    is_value v1 ->
+    red mask t1 t2 ->
+    red mask v1 v2 ->
+    t2.[v2/] = u ->
+    red mask (App (Lam t1) v1) u
+| RedParLetV:
+    forall t1 t2 v1 v2 u,
+    mask RuleParLetV ->
+    is_value v1 ->
+    red mask t1 t2 ->
+    red mask v1 v2 ->
+    t2.[v2/] = u ->
+    red mask (Let v1 t1) u
+| RedVar:
+    forall x,
+    mask RuleVar ->
+    red mask (Var x) (Var x)
+| RedLam:
+    forall t1 t2,
+    mask RuleLam ->
+    red mask t1 t2 ->
+    red mask (Lam t1) (Lam t2)
+| RedAppL:
+    forall t1 t2 u,
+    mask RuleAppL ->
+    red mask t1 t2 ->
+    red mask (App t1 u) (App t2 u)
+| RedAppVR:
+    forall v u1 u2,
+    mask RuleAppVR ->
+    is_value v ->
+    red mask u1 u2 ->
+    red mask (App v u1) (App v u2)
+| RedAppLR:
+    forall t1 t2 u1 u2,
+    mask RuleAppLR ->
+    red mask t1 t2 ->
+    red mask u1 u2 ->
+    red mask (App t1 u1) (App t2 u2)
+| RedLetL:
+    forall t1 t2 u,
+    mask RuleLetL ->
+    red mask t1 t2 ->
+    red mask (Let t1 u) (Let t2 u)
+| RedLetR:
+    forall t u1 u2,
+    mask RuleLetR ->
+    red mask u1 u2 ->
+    red mask (Let t u1) (Let t u2)
+| RedLetLR:
+    forall t1 t2 u1 u2,
+    mask RuleLetLR ->
+    red mask t1 t2 ->
+    red mask u1 u2 ->
+    red mask (Let t1 u1) (Let t2 u2)
+.
+
+Hint Constructors red : red obvious.
+
+(* The following mask defines the call-by-value reduction semantics. *)
+
+Definition cbv_mask rule :=
+  match rule with
+  | RuleBetaV    (* reduction of a beta-v redex: (\x.t) v                 *)
+  | RuleLetV     (* reduction of a let-v redex:  let x = v in t           *)
+  | RuleAppL     (* reduction in [App _ u]                                *)
+  | RuleAppVR    (* reduction in [App v _], if [v] is a value             *)
+  | RuleLetL     (* reduction in [Let _ u]                                *)
+      => True
+  | _ => False
+  end.
+
+Notation cbv := (red cbv_mask).
+
+(* The following mask defines the call-by-name reduction semantics. *)
+
+Definition cbn_mask rule :=
+  match rule with
+  | RuleBeta     (* reduction of a beta   redex: (\x.t) v                 *)
+  | RuleLet      (* reduction of a let redex:    let x = v in t           *)
+  | RuleAppL     (* reduction in [App _ u]                                *)
+      => True
+  | _ => False
+  end.
+
+Notation cbn := (red cbn_mask).
+
+(* The parallel by-value reduction semantics allows beta-v reductions under
+   arbitrary contexts, including under lambda-abstractions. Furthermore, it
+   allows parallel reductions (and allows no reduction at all). *)
+
+Definition pcbv_mask rule :=
+  match rule with
+  | RuleParBetaV (* reduction of a beta redex and reduction in both sides *)
+  | RuleParLetV  (* reduction of a let redex and reduction in both sides  *)
+  | RuleVar      (* no reduction                                          *)
+  | RuleLam      (* reduction in [Lam _]                                  *)
+  | RuleAppLR    (* reduction in both sides of [App _ _]                  *)
+  | RuleLetLR    (* reduction in both sides of [Let _ _]                  *)
+      => True
+  | _ => False
+  end.
+
+Notation pcbv := (red pcbv_mask).
+
+(* The tactic [obvious] should be able to prove goals of the form
+   [red mask t1 t2], where [mask] is a known mask. *)
+
+Hint Extern 1 (cbv_mask _)  => (simpl; tauto) : red obvious.
+Hint Extern 1 (cbn_mask _)  => (simpl; tauto) : red obvious.
+Hint Extern 1 (pcbv_mask _) => (simpl; tauto) : red obvious.
+
+Goal cbv (Let (App (Lam (Var 0)) (Var 0)) (Var 0)) (Let (Var 0) (Var 0)).
+Proof. obvious. Qed.
+
+Goal cbv (Let (Var 0) (Var 0)) (Var 0).
+Proof. obvious. Qed.
+
+Goal cbn (Let (Var 0) (Var 0)) (Var 0).
+Proof. obvious. Qed.
+
+Goal
+  let id := Lam (Var 0) in
+  let t := (Let (Lam (Var 0)) (Var 0)) in
+  cbn (App id t) t.
+Proof. simpl. obvious. Qed.
+
+Goal pcbv (App (App (Lam (Var 0)) (Var 0)) (App (Lam (Var 0)) (Var 0)))
+          (App (Var 0) (Var 0)).
+Proof.
+  eauto 8 with obvious.
+Qed.
+
+(* The tactic [step] applies to a goal of the form [star (red mask) t1 t2]. It
+   causes the term [t1] to take one step of reduction towards [t1'], turning
+   the goal into [star (red mask) t1' t2]. *)
+
+Ltac step :=
+  eapply star_step; [ obvious |].
+
+(* The tactic [finished] applies to a goal of the form [star (red mask) t1 t2].
+   It turns the goal into [t1 = t2]. *)
+
+Ltac finished :=
+  eapply star_refl_eq.
+
+(* The tactic [invert_cbv] inverts a hypothesis of the form [cbv t1 t2]. *)
+
+Ltac invert_cbv :=
+  pick (red cbv_mask) invert;
+  try solve [ false; eauto 3 with obvious ].
+
+Ltac invert_star_cbv :=
+  pick (star cbv) invert.
+
+Ltac invert_cbn :=
+  pick (red cbn_mask) invert;
+  try solve [ false; eauto 3 with obvious ].
+
+(* If the following four rules are enabled, then reduction is reflexive. *)
+
+Lemma red_refl:
+  forall mask : mask,
+  mask RuleVar ->
+  mask RuleLam ->
+  mask RuleAppLR ->
+  mask RuleLetLR ->
+  forall t,
+  red mask t t.
+Proof.
+  induction t; eauto with red.
+Qed.
+
+(* [RuleBetaV] and [RuleLetV] are special cases of [RuleParBetaV] and
+   [RuleParLetV], hence are admissible in parallel call-by-value reduction. *)
+
+Lemma pcbv_RedBetaV:
+  forall t v u,
+  is_value v ->
+  t.[v/] = u ->
+  pcbv (App (Lam t) v) u.
+Proof.
+  eauto using red_refl with obvious.
+Qed.
+
+Lemma pcbv_RedLetV:
+  forall t v u,
+  is_value v ->
+  t.[v/] = u ->
+  pcbv (Let v t) u.
+Proof.
+  eauto using red_refl with obvious.
+Qed.
+
+(* Sequences of reduction, [star cbv], can be carried out under a context. *)
+
+Lemma star_cbv_AppL:
+  forall t1 t2 u,
+  star cbv t1 t2 ->
+  star cbv (App t1 u) (App t2 u).
+Proof.
+  induction 1; eauto with sequences obvious.
+Qed.
+
+Lemma star_pcbv_AppL:
+  forall t1 t2 u,
+  star pcbv t1 t2 ->
+  star pcbv (App t1 u) (App t2 u).
+Proof.
+  induction 1; eauto using red_refl with sequences obvious.
+Qed.
+
+Lemma plus_pcbv_AppL:
+  forall t1 t2 u,
+  plus pcbv t1 t2 ->
+  plus pcbv (App t1 u) (App t2 u).
+Proof.
+  induction 1.
+  econstructor; [ | eauto using star_pcbv_AppL ].
+  eapply RedAppLR; eauto using red_refl with obvious.
+Qed.
+
+Lemma star_cbv_AppR:
+  forall t u1 u2,
+  is_value t ->
+  star cbv u1 u2 ->
+  star cbv (App t u1) (App t u2).
+Proof.
+  induction 2; eauto with sequences obvious.
+Qed.
+
+Hint Resolve star_cbv_AppL star_pcbv_AppL plus_pcbv_AppL star_cbv_AppR : red obvious.
+
+Lemma star_cbv_AppLR:
+  forall t1 t2 u1 u2,
+  star cbv t1 t2 ->
+  star cbv u1 u2 ->
+  is_value t2 ->
+  star cbv (App t1 u1) (App t2 u2).
+Proof.
+  eauto with sequences obvious.
+Qed.
+
+Lemma star_cbv_LetL:
+  forall t1 t2 u,
+  star cbv t1 t2 ->
+  star cbv (Let t1 u) (Let t2 u).
+Proof.
+  induction 1; eauto with sequences obvious.
+Qed.
+
+Hint Resolve star_cbv_AppLR star_cbv_LetL : red obvious.
+
+(* Reduction commutes with substitutions of values for variables. (This
+   includes renamings.) This is true of every reduction strategy, with
+   the proviso that if [RuleVar] is enabled, then [RuleLam], [RuleAppLR]
+   and [RuleLetLR] must be enabled as well, so that reduction is reflexive. *)
+
+Lemma red_subst:
+  forall mask : mask,
+  (mask RuleVar -> mask RuleLam) ->
+  (mask RuleVar -> mask RuleAppLR) ->
+  (mask RuleVar -> mask RuleLetLR) ->
+  forall t1 t2,
+  red mask t1 t2 ->
+  forall sigma,
+  is_value_subst sigma ->
+  red mask t1.[sigma] t2.[sigma].
+Proof.
+  induction 4; simpl; intros; subst;
+  try solve [ econstructor; solve [ eauto with is_value | autosubst ]].
+  (* Case: [Var] *)
+  { eauto using red_refl. }
+Qed.
+
+Lemma star_red_subst:
+  forall mask : mask,
+  (mask RuleVar -> mask RuleLam) ->
+  (mask RuleVar -> mask RuleAppLR) ->
+  (mask RuleVar -> mask RuleLetLR) ->
+  forall t1 t2 sigma,
+  star (red mask) t1 t2 ->
+  is_value_subst sigma ->
+  star (red mask) t1.[sigma] t2.[sigma].
+Proof.
+  induction 4; eauto using red_subst with sequences.
+Qed.
+
+(* Call-by-value reduction is contained in parallel call-by-value. *)
+
+Lemma cbv_subset_pcbv:
+  forall t1 t2,
+  cbv t1 t2 ->
+  pcbv t1 t2.
+Proof.
+  induction 1; try solve [ tauto ]; eauto using red_refl with red.
+Qed.
+
+(* Under call-by-value, values do not reduce. *)
+
+Lemma values_do_not_reduce:
+  forall t1 t2,
+  cbv t1 t2 ->
+  ~ is_value t1.
+Proof.
+  inversion 1; is_value.
+Qed.
+
+Hint Resolve values_do_not_reduce : is_value obvious.
+
+Hint Extern 1 (False) => (eapply values_do_not_reduce) : is_value obvious.
+
+Lemma is_value_irred:
+  forall v,
+  is_value v ->
+  irred cbv v.
+Proof.
+  intros. intro. obvious.
+Qed.
+
+Hint Resolve is_value_irred : irred obvious.
+
+(* Under every strategy, the property of being a value is preserved by
+   reduction. *)
+
+Lemma values_are_stable:
+  forall mask v1 v2,
+  red mask v1 v2 ->
+  is_value v1 ->
+  is_value v2.
+Proof.
+  induction 1; is_value.
+Qed.
+
+Lemma nonvalues_are_stable:
+  forall mask v1 v2,
+  red mask v1 v2 ->
+  ~ is_value v2 ->
+  ~ is_value v1.
+Proof.
+  induction 1; is_value.
+Qed.
+
+Hint Resolve values_are_stable nonvalues_are_stable : is_value obvious.
+
+(* [cbv] is deterministic. *)
+
+Lemma cbv_deterministic:
+  forall t t1,
+  cbv t t1 ->
+  forall t2,
+  cbv t t2 ->
+  t1 = t2.
+Proof.
+  (* Induction over [cbv t t1]. *)
+  induction 1; try solve [ tauto ]; intros; subst;
+  (* Invert the second hypothesis, [cbv t t2]. The fact that values do not
+     reduce is used to eliminate some cases. *)
+  invert_cbv;
+  (* The result follows. *)
+  f_equal; eauto.
+Qed.
+
+(* Inversion lemmas for [irred]. *)
+
+Lemma invert_irred_cbv_App_1:
+  forall t u,
+  irred cbv (App t u) ->
+  irred cbv t.
+Proof.
+  intros. eapply irred_irred; obvious.
+Qed.
+
+Lemma invert_irred_cbv_App_2:
+  forall t u,
+  irred cbv (App t u) ->
+  is_value t ->
+  irred cbv u.
+Proof.
+  intros. eapply irred_irred; obvious.
+Qed.
+
+Lemma invert_irred_cbv_App_3:
+  forall t u,
+  irred cbv (App t u) ->
+  is_value t ->
+  is_value u ->
+  forall t', t <> Lam t'.
+Proof.
+  intros ? ? Hirred. repeat intro. subst.
+  eapply Hirred. obvious.
+Qed.
+
+Lemma invert_irred_cbv_Let_1:
+  forall t u,
+  irred cbv (Let t u) ->
+  irred cbv t.
+Proof.
+  intros. eapply irred_irred; obvious.
+Qed.
+
+Lemma invert_irred_cbv_Let_2:
+  forall t u,
+  irred cbv (Let t u) ->
+  ~ is_value t.
+Proof.
+  intros ? ? Hirred ?. eapply Hirred. obvious.
+Qed.
+
+Hint Resolve
+  invert_irred_cbv_App_1
+  invert_irred_cbv_App_2
+  invert_irred_cbv_Let_1
+  invert_irred_cbv_Let_2
+: irred.
+
+(* An analysis of irreducible terms for call-by-value reduction. A stuck
+   term is either an application [v1 v2] where [v1] is not a function or
+   a stuck term in an evaluation context. *)
+
+Inductive stuck : term -> Prop :=
+| StuckApp:
+    forall v1 v2,
+    is_value v1 ->
+    is_value v2 ->
+    (forall t, v1 <> Lam t) ->
+    stuck (App v1 v2)
+| StuckAppL:
+    forall t u,
+    stuck t ->
+    stuck (App t u)
+| StuckAppR:
+    forall v u,
+    is_value v ->
+    stuck u ->
+    stuck (App v u)
+| StuckLetL:
+    forall t u,
+    stuck t ->
+    stuck (Let t u).
+
+Hint Constructors stuck : stuck.
+
+(* To go wrong is to reduce to a stuck term. *)
+
+Definition goes_wrong t :=
+  exists t', star cbv t t' /\ stuck t'.
+
+(* A stuck term cannot be a value. *)
+
+Lemma stuck_nonvalue:
+  forall t,
+  stuck t ->
+  ~ is_value t.
+Proof.
+  induction 1; is_value.
+Qed.
+
+(* Every stuck term is irreducible. *)
+
+Ltac prove_irred_cbv :=
+  do 2 intro; invert_cbv.
+
+Lemma stuck_irred:
+  forall t,
+  stuck t ->
+  irred cbv t.
+Proof.
+  induction 1; prove_irred_cbv; try solve [
+    eauto using irreducible_terms_do_not_reduce
+  | eapply stuck_nonvalue; obvious
+  ].
+  (* StuckApp *)
+  { congruence. }
+Qed.
+
+Hint Resolve stuck_irred : irred obvious.
+
+(* Every irreducible term either is a value or is stuck. *)
+
+Lemma irred_cbv_is_value_or_stuck:
+  forall t,
+  irred cbv t ->
+  is_value t \/ stuck t.
+Proof.
+  induction t; intro Hirred;
+  try solve [ is_value ]; right.
+  (* App *)
+  { assert (H1: irred cbv t1). { eauto with irred. }
+    destruct (IHt1 H1); [| eauto with stuck ].
+    assert (H2: irred cbv t2). { eauto with irred. }
+    destruct (IHt2 H2); [| eauto with stuck ].
+    eapply StuckApp; eauto using invert_irred_cbv_App_3. }
+  (* Let *)
+  { assert (H: irred cbv t). { eauto with irred. }
+    destruct (IHt H); [| eauto with stuck ].
+    assert (~ is_value t). { eauto with irred. }
+    tauto. }
+Qed.
+
+(* The converse is true as well. *)
+
+Lemma irred_cbv_characterization:
+  forall t,
+  irred cbv t <->
+  is_value t \/ stuck t.
+Proof.
+  split.
+  { eauto using irred_cbv_is_value_or_stuck. }
+  { intuition eauto with irred. }
+Qed.
+
+(* A closed value must be a lambda-abstraction. *)
+
+Lemma closed_value:
+  forall v,
+  is_value v ->
+  closed v ->
+  exists t, v = Lam t.
+Proof.
+  intros. destruct v as [| t | | ]; try solve [ false; is_value ].
+  { false. eapply closed_Var. eauto. }
+  { exists t. eauto. }
+Qed.
+
+(* A stuck term cannot be closed. *)
+
+Lemma stuck_closed:
+  forall t,
+  stuck t ->
+  closed t ->
+  False.
+Proof.
+  induction 1; intros; eauto with closed.
+  (* StuckApp *)
+  { assert (ht1: exists t1, v1 = Lam t1).
+    { eauto using closed_value with closed. }
+    destruct ht1 as (?&?). subst v1. congruence. }
+Qed.
+
+(* Under call-by-value, every closed term either reduces or is a value. *)
+
+Lemma cbv_progress:
+  forall t,
+  closed t ->
+  is_value t \/ exists u, cbv t u.
+Local Ltac ih IH :=
+  destruct IH as [| [ ? ? ]]; [ eauto with closed | | obvious ].
+Proof.
+  (* We give a direct proof, but the result also follows from
+     [irred_cbv_is_value_or_stuck] and [stuck_closed]. *)
+  induction t as [| | t1 IHt1 t2 IHt2 | t1 IHt1 t2 IHt2 ];
+  try solve [ left; obvious ]; right.
+  (* App *)
+  { ih IHt1.
+    ih IHt2.
+    destruct (closed_value t1) as [ u1 ? ]; eauto with closed; subst t1.
+    obvious.
+  }
+  (* Let *)
+  { ih IHt1. obvious. }
+Qed.

coq/LambdaCalculusSyntax.v

@@ -0,0 +1,192 @@
+Require Import Coq.Wellfounded.Inverse_Image.
+Require Import MyTactics.
+Require Export Autosubst.Autosubst.
+Require Export AutosubstExtra.
+Require Export Autosubst_IsRen.
+
+(* The syntax of the lambda-calculus. *)
+
+Inductive term :=
+| Var (x : var)
+| Lam (t : {bind term})
+| App (t1 t2 : term)
+| Let (t1 : term) (t2 : {bind term})
+.
+
+Instance Ids_term : Ids term. derive. Defined.
+Instance Rename_term : Rename term. derive. Defined.
+Instance Subst_term : Subst term. derive. Defined.
+Instance SubstLemmas_term : SubstLemmas term. derive. Qed.
+
+(* If the image of [t] through a substitution is a variable, then [t] must
+   itself be a variable. *)
+
+Lemma subst_is_var:
+  forall t sigma x,
+  t.[sigma] = ids x ->
+  exists y,
+  t = ids y.
+Proof.
+  intros ? ? ? Heq. destruct t; compute in Heq; solve [ eauto | congruence ].
+Qed.
+
+(* The identity substitution [ids] is injective. *)
+
+Lemma inj_ids:
+  forall x y,
+  ids x = ids y ->
+  x = y.
+Proof.
+  intros ? ? Heq. compute in Heq. congruence.
+Qed.
+
+(* If the composition of two substitutions [sigma1] and [sigma2] is the
+   identity substitution, then [sigma1] must be a renaming. *)
+
+Lemma ids_implies_is_ren:
+  forall sigma1 sigma2,
+  sigma1 >> sigma2 = ids ->
+  is_ren sigma1.
+Proof.
+  intros ? ? Hid.
+  eapply prove_is_ren; [ eapply inj_ids | intros x ].
+  eapply subst_is_var with (sigma := sigma2) (x := x).
+  rewrite <- Hid. reflexivity.
+Qed.
+
+Hint Resolve ids_implies_is_ren : is_ren obvious.
+
+(* The size of a term. *)
+
+Fixpoint size (t : term) : nat :=
+  match t with
+  | Var _ => 0
+  | Lam t => 1 + size t
+  | App t1 t2
+  | Let t1 t2 => 1 + size t1 + size t2
+  end.
+
+(* The size of a term is preserved by renaming. *)
+
+Lemma size_renaming:
+  forall t sigma,
+  is_ren sigma ->
+  size t.[sigma] = size t.
+Proof.
+  induction t; intros sigma Hsigma; asimpl;
+  repeat (match goal with h: forall sigma, _ |- _ => rewrite h by obvious; clear h end);
+  try reflexivity.
+  (* [Var] *)
+  { destruct Hsigma as [ xi ? ]. subst. reflexivity. }
+Qed.
+
+(* The [size] function imposes a well-founded ordering on terms. *)
+
+Lemma smaller_wf:
+  well_founded (fun t1 t2 => size t1 < size t2).
+Proof.
+  eauto using wf_inverse_image, lt_wf.
+Qed.
+
+(* The tactic [size_induction] facilitates proofs by induction on the
+   size of a term. The following lemmas are used in the construction
+   of this tactic. *)
+
+Lemma size_induction_intro:
+  forall (P : term -> Prop),
+  (forall n t, size t < n -> P t) ->
+  (forall t, P t).
+Proof.
+  eauto. (* just instantiate [n] with [size t + 1] *)
+Defined.
+
+Lemma size_induction_induction:
+  forall (P : term -> Prop),
+  (forall n, (forall t, size t < n -> P t) -> (forall t, size t < S n -> P t)) ->
+  (forall n t, size t < n -> P t).
+Proof.
+  intros P IH. induction n; intros.
+  { false. eapply Nat.nlt_0_r. eauto. }
+  { eauto. }
+Defined.
+
+Lemma size_induction:
+  forall (P : term -> Prop),
+  (forall n, (forall t, size t < n -> P t) -> (forall t, size t < S n -> P t)) ->
+  (forall t, P t).
+Proof.
+  intros P IH.
+  eapply size_induction_intro.
+  eapply size_induction_induction.
+  eauto.
+Defined.
+
+Ltac size_induction :=
+  (* We assume the goal is of the form [forall t, P t]. *)
+  intro t; pattern t;
+  match goal with |- ?P t =>
+    simpl; eapply (@size_induction P); clear
+  end;
+  intros n IH t Htn.
+  (* The goal should now be of the form [P t]
+     with a hypothesis [IH: (forall t, size t < n -> P t]
+     and a hypothesis [Htn: size t < S n]. *)
+
+(* The tactic [size] proves goals of the form [size t < n]. The tactic
+   [obvious] is also extended to prove such goals. *)
+
+Hint Extern 1 (size ?t.[?sigma] < ?n) =>
+  rewrite size_renaming by obvious
+  : size obvious.
+
+Hint Extern 1 (size ?t < ?n) =>
+  simpl in *; omega
+  : size obvious.
+
+Ltac size :=
+  eauto with size.
+
+(* The following is a direct proof of [smaller_wf]. We do not use any
+   preexisting lemmas, and end the proof with [Defined] instead of [Qed],
+   so as to make the proof term transparent. Also, we avoid the tactic
+   [omega], which produces huge proof terms. This allows Coq to compute
+   with functions that are defined by well-founded recursion. *)
+
+Lemma smaller_wf_transparent:
+  well_founded (fun t1 t2 => size t1 < size t2).
+Proof.
+  unfold well_founded. size_induction.
+  constructor; intros u Hu.
+  eapply IH. eapply lt_S_n. eapply le_lt_trans; eauto.
+Defined.
+
+(* The following lemmas can be useful in situations where the tactic
+   [asimpl] performs too much simplification. *)
+
+Lemma subst_var:
+  forall x sigma,
+  (Var x).[sigma] = sigma x.
+Proof.
+  autosubst.
+Qed.
+
+Lemma subst_lam:
+  forall t sigma,
+  (Lam t).[sigma] = Lam (t.[up sigma]).
+Proof.
+  autosubst.
+Qed.
+
+Lemma subst_app:
+  forall t1 t2 sigma,
+  (App t1 t2).[sigma] = App t1.[sigma] t2.[sigma].
+Proof.
+  autosubst.
+Qed.
+
+Lemma subst_let:
+  forall t1 t2 sigma,
+  (Let t1 t2).[sigma] = Let t1.[sigma] t2.[up sigma].
+Proof.
+  autosubst.
+Qed.

coq/LambdaCalculusValues.v

@@ -0,0 +1,179 @@
+Require Import MyTactics.
+Require Import LambdaCalculusSyntax.
+
+(* The syntactic subcategory of values is decidable. *)
+
+Definition if_value {A} (t : term) (a1 a2 : A) : A :=
+  match t with
+  | Var _ | Lam _ => a1
+  | _ => a2
+  end.
+
+Definition is_value (t : term) :=
+  if_value t True False.
+
+Hint Extern 1 (is_value _) => (simpl; tauto) : is_value obvious.
+
+(* A term either is or is not a value. *)
+
+Lemma value_or_nonvalue:
+  forall t,
+  is_value t \/ ~ is_value t.
+Proof.
+  destruct t; simpl; eauto.
+Qed.
+
+(* Simplification rules for [if_value]. *)
+
+Lemma if_value_value:
+  forall A v (a1 a2 : A),
+  is_value v ->
+  if_value v a1 a2 = a1.
+Proof.
+  destruct v; simpl; tauto.
+Qed.
+
+Lemma if_value_nonvalue:
+  forall A t (a1 a2 : A),
+  ~ is_value t ->
+  if_value t a1 a2 = a2.
+Proof.
+  destruct t; simpl; tauto.
+Qed.
+
+(* The syntactic subcategory of values is preserved by renamings. *)
+
+Lemma is_value_renaming:
+  forall v xi,
+  is_value v ->
+  is_value v.[ren xi].
+Proof.
+  destruct v; simpl; eauto.
+Qed.
+
+Lemma is_nonvalue_renaming:
+  forall v xi,
+  ~ is_value v ->
+  ~ is_value v.[ren xi].
+Proof.
+  destruct v; simpl; eauto.
+Qed.
+
+Hint Resolve is_value_renaming is_nonvalue_renaming : is_value obvious.
+
+Ltac is_value :=
+  eauto with is_value.
+
+(* The tactic [not_a_value] can be used to prove that the current case
+   is impossible, because we have a hypothesis of the form [~ is_value v],
+   where [v] clearly is a value. *)
+
+Ltac not_a_value :=
+  solve [ false; is_value ].
+
+Ltac if_value :=
+  repeat first [ rewrite if_value_value by is_value |
+                 rewrite if_value_nonvalue by is_value ].
+
+(* The tactic [value_or_nonvalue t] creates two cases: either [t] is a value,
+   or it isn't. *)
+
+Ltac value_or_nonvalue t :=
+  destruct (value_or_nonvalue t);
+  if_value.
+
+(* The tactic [value_or_app_or_let] creates three cases: either [t] is a value,
+   or it is an application, or it is a [let] construct. *)
+
+Ltac value_or_app_or_let t :=
+  value_or_nonvalue t; [|
+    destruct t as [ ? | ? | t1 t2 | t1 t2 ]; [ not_a_value | not_a_value | |]
+      (* In principle, we should not fix the names [t1] and [t2] here,
+         as it might cause name clashes. *)
+  ].
+
+(* The predicate [is_value_subst sigma] holds if every term in the
+   codomain of the substitution [sigma] is a value. *)
+
+Definition is_value_subst (sigma : var -> term) :=
+  forall x, is_value (sigma x).
+
+Lemma is_value_subst_ids:
+  is_value_subst ids.
+Proof.
+  intros x. is_value.
+Qed.
+
+Lemma is_value_subst_cons:
+  forall v sigma,
+  is_value v ->
+  is_value_subst sigma ->
+  is_value_subst (v .: sigma).
+Proof.
+  intros. intros [|x]; is_value.
+Qed.
+
+Definition is_value_subst_up:
+  forall sigma,
+  is_value_subst sigma ->
+  is_value_subst (up sigma).
+Proof.
+  intros sigma h. intros [|x]; asimpl.
+  { simpl. eauto. }
+  { is_value. }
+Qed.
+
+Definition is_value_subst_upn:
+  forall sigma i,
+  is_value_subst sigma ->
+  is_value_subst (upn i sigma).
+Proof.
+  induction i; intros; asimpl.
+  { eauto. }
+  { rewrite <- fold_up_upn. eauto using is_value_subst_up. }
+Qed.
+
+Lemma is_value_subst_renaming:
+  forall sigma i,
+  is_value_subst sigma ->
+  is_value_subst (sigma >> ren (+i)).
+Proof.
+  intros. intro x. asimpl. is_value.
+Qed.
+
+Hint Resolve is_value_subst_up is_value_subst_upn is_value_subst_renaming
+  : is_value obvious.
+
+Lemma values_are_preserved_by_value_substitutions:
+  forall v sigma,
+  is_value v ->
+  is_value_subst sigma ->
+  is_value v.[sigma].
+Proof.
+  destruct v; simpl; intros; eauto with is_value.
+Qed.
+
+Lemma nonvalues_are_preserved_by_substitutions:
+  forall t sigma,
+  ~ is_value t ->
+  ~ is_value t.[sigma].
+Proof.
+  destruct t; simpl; tauto.
+Qed.
+
+Hint Resolve
+  is_value_subst_ids
+  is_value_subst_cons
+  values_are_preserved_by_value_substitutions
+  nonvalues_are_preserved_by_substitutions
+: is_value obvious.
+
+Lemma is_ren_is_value_subst:
+  forall sigma,
+  is_ren sigma ->
+  is_value_subst sigma.
+Proof.
+  intros ? [ xi ? ]. subst. eauto with is_value.
+Qed.
+
+Hint Resolve is_ren_is_value_subst : is_value obvious.

coq/Option.v

@@ -0,0 +1,120 @@
+(* -------------------------------------------------------------------------- *)
+
+(* The [bind] combinator of the option monad. *)
+
+Definition bind {A B} (f : option A) (k : A -> option B) : option B :=
+  match f with
+  | None =>
+      None
+  | Some a =>
+      k a
+  end.
+
+(* The standard syntactic sugar for [bind]. [f >>= k] can be read as ``first
+   do [f]; then, if successful, with the result of [f], do [k]''. *)
+
+Notation "f >>= k" := (bind f k) (at level 55).
+
+(* -------------------------------------------------------------------------- *)
+
+(* These lemmas help prove an equation of the form [f >>= k = b]. *)
+
+Lemma prove_bind_None:
+  forall {A B} {f} {k : A -> option B},
+  f = None ->
+  f >>= k = None.
+Proof.
+  intros. subst. eauto.
+Qed.
+
+Lemma prove_bind_Some:
+  forall {A B} {f} {k : A -> option B} {a b},
+  f = Some a ->
+  k a = b ->
+  f >>= k = b.
+Proof.
+  intros. subst. eauto.
+Qed.
+
+(* This lemma helps exploit an equation of the form [f >>= k = Some b]. *)
+
+Lemma invert_bind_Some:
+  forall {A B} {f} {k : A -> option B} {b},
+  f >>= k = Some b ->
+  exists a, f = Some a /\ k a = Some b.
+Proof.
+  destruct f; simpl; intros.
+  { eauto. }
+  { congruence. }
+Qed.
+
+Ltac invert_bind_Some :=
+  match goal with
+  h: ?f >>= _ = Some _ |- _ =>
+    let heq := fresh in
+    generalize (invert_bind_Some h); clear h; intros (?&?&h)
+  end.
+
+(* -------------------------------------------------------------------------- *)
+
+(* The standard ordering on options, where [None] is less defined then
+   everything, and every element of the form [Some a] is less defined
+   than itself only. *)
+
+Definition less_defined {A} (o1 o2 : option A) :=
+  forall a, o1 = Some a -> o2 = Some a.
+
+(* -------------------------------------------------------------------------- *)
+
+(* This lemma exploits an assertion of the form [less_defined (Some _) _]. *)
+
+Lemma invert_less_defined_Some:
+  forall {A} {a : A} {o : option A},
+  less_defined (Some a) o ->
+  Some a = o.
+Proof.
+  unfold less_defined. intros. symmetry. eauto.
+Qed.
+
+Ltac invert_less_defined :=
+  match goal with
+  | h: less_defined (Some _) _ |- _ =>
+      generalize (invert_less_defined_Some h); clear h; intro h
+  end.
+
+(* -------------------------------------------------------------------------- *)
+
+(* These lemmas help prove assertions of the form [less_defined _ _]. *)
+
+Lemma prove_less_defined_None:
+  forall {A} {o : option A},
+  less_defined None o.
+Proof.
+  unfold less_defined. intros. congruence.
+Qed.
+
+Lemma reflexive_less_defined:
+  forall {A} {o : option A},
+  less_defined o o.
+Proof.
+  unfold less_defined. eauto.
+Qed.
+
+Local Hint Extern 1 (_ <> _) => congruence : congruence.
+
+Lemma prove_less_defined_bind:
+  forall {A B} {f1 f2 : option A} {k1 k2 : A -> option B},
+  less_defined f1 f2 ->
+  (f1 <> None -> forall a, less_defined (k1 a) (k2 a)) ->
+  less_defined (f1 >>= k1) (f2 >>= k2).
+Proof.
+  intros. destruct f1; simpl in *.
+  (* Case: [f1] is [Some _]. *)
+  { invert_less_defined. subst. simpl. eauto with congruence. }
+  (* Case: [f1] is [None]. *)
+  { eauto using prove_less_defined_None. }
+Qed.
+
+Hint Resolve
+  prove_less_defined_None reflexive_less_defined prove_less_defined_bind
+: less_defined.

coq/Sequences.v

@@ -0,0 +1,321 @@
+(** A library of relation operators defining sequences of transitions
+    and useful properties about them. Originally by Xavier Leroy, with
+    some improvements and additions by François Pottier. *)
+
+Set Implicit Arguments.
+
+Section SEQUENCES.
+
+Variable A: Type.
+
+Implicit Types R S : A -> A -> Prop.
+Implicit Types P   : A -> Prop.
+
+(** Zero, one or several transitions: reflexive, transitive closure of [R]. *)
+
+Inductive star R : A -> A -> Prop :=
+| star_refl:
+    forall a,
+    star R a a
+| star_step:
+    forall a b c,
+    R a b -> star R b c -> star R a c.
+
+Hint Constructors star.
+
+Lemma star_refl_eq:
+  forall R a b, a = b -> star R a b.
+Proof.
+  intros. subst. eauto.
+Qed.
+
+Lemma star_one:
+  forall R a b, R a b -> star R a b.
+Proof.
+  eauto.
+Qed.
+
+Lemma star_trans:
+  forall R a b, star R a b ->
+  forall c, star R b c -> star R a c.
+Proof.
+  induction 1; eauto.
+Qed.
+
+Lemma star_covariant:
+  forall R S,
+  (forall a b, R a b -> S a b) ->
+  (forall a b, star R a b -> star S a b).
+Proof.
+  induction 2; eauto.
+Qed.
+
+(* If [R] preserves some property [P], then [star R] preserves [P]. *)
+
+Lemma star_implication:
+  forall P R,
+  (forall a1 a2, R a1 a2 -> P a1 -> P a2) ->
+  (forall a1 a2, star R a1 a2 -> P a1 -> P a2).
+Proof.
+  induction 2; eauto.
+Qed.
+
+(* The same implication holds in the reverse direction (right to left). *)
+
+Lemma star_implication_reversed:
+  forall P R,
+  (forall a1 a2, R a1 a2 -> P a2 -> P a1) ->
+  (forall a1 a2, star R a1 a2 -> P a2 -> P a1).
+Proof.
+  induction 2; eauto.
+Qed.
+
+(** One or several transitions: transitive closure of [R]. *)
+
+Inductive plus R: A -> A -> Prop :=
+| plus_left:
+    forall a b c,
+    R a b -> star R b c -> plus R a c.
+
+Hint Constructors plus.
+
+Lemma plus_one:
+  forall R a b, R a b -> plus R a b.
+Proof.
+  eauto.
+Qed.
+
+Lemma plus_star:
+  forall R a b, plus R a b -> star R a b.
+Proof.
+  inversion 1; eauto.
+Qed.
+
+Lemma plus_covariant:
+  forall R S,
+  (forall a b, R a b -> S a b) ->
+  (forall a b, plus R a b -> plus S a b).
+Proof.
+  induction 2; eauto using star_covariant.
+Qed.
+
+(* A direct induction principle for [plus]: when [plus R a b] holds,
+   either there is just one step, or there is one, followed with more. *)
+
+Lemma plus_ind_direct:
+  forall R P : A -> A -> Prop,
+  (forall a b, R a b -> P a b) ->
+  (forall a b c, R a b -> plus R b c -> P b c -> P a c) ->
+  forall a b, plus R a b -> P a b.
+Proof.
+  intros ? ? Hone Hmore a c Hplus. destruct Hplus as [ ? b ? hR hRStar ].
+  generalize b c hRStar a hR.
+  clear b c hRStar a hR.
+  induction 1; eauto.
+Qed.
+
+Lemma plus_star_trans:
+  forall R a b c, plus R a b -> star R b c -> plus R a c.
+Proof.
+  inversion 1; eauto using star_trans.
+Qed.
+
+Lemma star_plus_trans:
+  forall R a b c, star R a b -> plus R b c -> plus R a c.
+Proof.
+  inversion 1; inversion 1; eauto using star_trans.
+Qed.
+
+Lemma plus_trans:
+  forall R a b c, plus R a b -> plus R b c -> plus R a c.
+Proof.
+  eauto using plus_star_trans, plus_star.
+Qed.
+
+Lemma plus_right:
+  forall R a b c, star R a b -> R b c -> plus R a c.
+Proof.
+  eauto using star_plus_trans.
+Qed.
+
+(** Absence of transitions. *)
+
+Definition irred R a :=
+  forall b, ~ R a b.
+
+Definition halts R a :=
+  exists b, star R a b /\ irred R b.
+
+(** Infinitely many transitions. *)
+
+CoInductive infseq R : A -> Prop :=
+| infseq_step:
+    forall a b,
+    R a b -> infseq R b -> infseq R a.
+
+(** Properties of [irred]. *)
+
+Lemma irred_irred:
+  forall R t1 u1,
+  irred R t1 ->
+  (forall u2, R u1 u2 -> exists t2, R t1 t2) ->
+  irred R u1.
+Proof.
+  unfold irred. intros ? ? ? Hirred Himpl u2 Hu2.
+  destruct (Himpl _ Hu2) as [ t2 Ht2 ].
+  eapply Hirred. eauto.
+Qed.
+
+Lemma irreducible_terms_do_not_reduce:
+  forall R a b, irred R a -> R a b -> False.
+Proof.
+  unfold irred, not. eauto.
+Qed.
+
+(** Coinduction principles to show the existence of infinite sequences. *)
+
+Lemma infseq_coinduction_principle:
+  forall R P,
+  (forall a, P a -> exists b, R a b /\ P b) ->
+  forall a, P a -> infseq R a.
+Proof.
+  intros ? ? Hstep. cofix COINDHYP; intros a hPa.
+  destruct (Hstep a hPa) as (?&?&?).
+  econstructor; eauto.
+Qed.
+
+Lemma infseq_coinduction_principle_2:
+  forall R P a,
+  P a ->
+  (forall a, P a -> exists b, plus R a b /\ P b) ->
+  infseq R a.
+Proof.
+  intros ? ? ? ? Hinv.
+  apply infseq_coinduction_principle with
+    (P := fun a => exists b, star R a b /\ P b).
+  (* Proof that the invariant is preserved. *)
+  { clear dependent a.
+    intros a (b&hStar&hPb).
+    inversion hStar; subst.
+    { destruct (Hinv b hPb) as [c [hPlus ?]].
+      inversion hPlus; subst. eauto. }
+    { eauto. }
+  }
+  (* Proof that the invariant initially holds. *)
+  { eauto. }
+Qed.
+
+Lemma infseq_plus:
+  forall R a,
+  infseq (plus R) a ->
+  infseq R a.
+Proof.
+  intros. eapply infseq_coinduction_principle_2
+    with (P := fun a => infseq (plus R) a).
+  { eauto. }
+  clear dependent a. intros a hInfSeq.
+  destruct hInfSeq. eauto.
+Qed.
+
+(** An example of use of [infseq_coinduction_principle]. *)
+
+Lemma infseq_alternate_characterization:
+  forall R a,
+  (forall b, star R a b -> exists c, R b c) ->
+  infseq R a.
+Proof.
+  intros R. apply infseq_coinduction_principle.
+  intros a Hinv. destruct (Hinv a); eauto.
+Qed.
+
+Lemma infseq_covariant:
+  forall R S,
+  (forall a b, R a b -> S a b) ->
+  forall a, infseq R a -> infseq S a.
+Proof.
+  intros. eapply infseq_coinduction_principle
+  with (P := fun a => infseq R a); [| eauto ].
+  clear dependent a. intros a hInfSeq.
+  destruct hInfSeq. eauto.
+Qed.
+
+(** A sequence either is infinite or stops on an irreducible term.
+    This property needs excluded middle from classical logic. *)
+
+Require Import Classical.
+
+Lemma infseq_or_finseq:
+  forall R a,
+  infseq R a \/ halts R a.
+Proof.
+  intros.
+  destruct (classic (forall b, star R a b -> exists c, R b c)).
+  { left. eauto using infseq_alternate_characterization. }
+  { right.
+    destruct (not_all_ex_not _ _ H) as [b Hb].
+    destruct (imply_to_and _ _ Hb).
+    unfold halts, irred, not. eauto. }
+Qed.
+
+(** Additional properties for deterministic transition relations. *)
+
+Section DETERMINISM.
+
+Variable R : A -> A -> Prop.
+
+Hypothesis R_determ: forall a b c, R a b -> R a c -> b = c.
+
+Ltac R_determ :=
+  match goal with h1: R ?a ?b1, h2: R ?a ?b2 |- _ =>
+    assert (b1 = b2); [ eauto | subst ]
+  end.
+
+(** Uniqueness of transition sequences. *)
+
+Lemma star_star_inv:
+  forall a b, star R a b -> forall c, star R a c -> star R b c \/ star R c b.
+Proof.
+  induction 1; inversion 1; intros; subst; try R_determ; eauto.
+Qed.
+
+Lemma finseq_unique:
+  forall a b b',
+  star R a b -> irred R b ->
+  star R a b' -> irred R b' ->
+  b = b'.
+Proof.
+  unfold irred, not.
+  intros ? ? ? Hab Hirred Hab' Hirred'.
+  destruct (star_star_inv Hab Hab') as [ Hbb' | Hbb' ];
+  inversion Hbb'; subst;
+  solve [ eauto | elimtype False; eauto ].
+Qed.
+
+Lemma infseq_star_inv:
+  forall a b, star R a b -> infseq R a -> infseq R b.
+Proof.
+  induction 1; inversion 1; intros; try R_determ; eauto.
+Qed.
+
+Lemma infseq_finseq_excl:
+  forall a b,
+  star R a b -> irred R b -> infseq R a -> False.
+Proof.
+  unfold irred, not. intros.
+  assert (h: infseq R b). { eauto using infseq_star_inv. }
+  inversion h. eauto.
+Qed.
+
+Lemma infseq_halts_excl:
+  forall a,
+  halts R a -> infseq R a -> False.
+Proof.
+  intros ? (?&?&?). eauto using infseq_finseq_excl.
+Qed.
+
+End DETERMINISM.
+
+End SEQUENCES.
+
+Hint Resolve star_refl star_step star_one star_trans plus_left plus_one
+             plus_star plus_star_trans star_plus_trans plus_right: sequences.