(* Proof script adapts a small part of the development underlying: Xavier Leroy and Herve Grall, Coinductive big-step operational semantics, Information and Computation 207(2):284-304, 2009. Extended version of the paper with the same title published in the proceedings of ESOP 2006. Copyright 2005, 2006, 2007 Institut National de la Recherche en Informatique et Automatique. Copyright 2012, Catalin Hritcu (adapted a small part of the development for presentation in CIS670 at Penn). This file is distributed under the terms of the GNU Public License version 2, http://www.gnu.org/licenses/gpl.html *) Require Import Classical. (* some of the proofs use classical axioms *) Require Import CpdtTactics. Set Implicit Arguments. (** * The [coind] tactic again (very slightly improved) *) Lemma exists_forall_impl : forall A (P : A -> Prop) (Q : Prop), ((exists x, P x) -> Q) -> forall x : A, P x -> Q. Proof. firstorder. Qed. Tactic Notation "if" tactic(t) "then" tactic(t1) "else" tactic(t2) := first [ t; first [ t1 | fail 2 ] | t2 ]. Tactic Notation "if_is_not_var" tactic(t) "then" tactic(t1) := if (is_var t) then idtac else t1. Ltac step1_arity2 := match goal with | [|- ?P ?s ?s] => remember s in * |- * at 1 | [|- ?P ?s1 ?s2] => (if_is_not_var s1 then remember s1); (if_is_not_var s2 then remember s2) end. Ltac step1_arity1 := match goal with | [|- ?P ?s] => if_is_not_var s then remember s end. Ltac step2conjn := match goal with | [H : ?P |- ?R] => match type of P with | Prop => match R with | ?Q -> ?R => let J := fresh "J" in intro J; cut (P /\ Q); [clear H J | tauto] | _ => generalize dependent H end | _ => fail end end. Ltac step2exn_arity2 := match goal with | [s1 : _, s2 : _, x : ?T |- ?Q -> ?P ?s1 ?s2] => generalize dependent x; apply exists_forall_impl | [s1 : _, s2 : _, x : ?T |- ?P ?s1 ?s2] => clear x end. Ltac step2exn_arity1 := match goal with | [s : _, x : ?T |- ?Q -> ?P ?s] => generalize dependent x; apply exists_forall_impl | [s : _, x : ?T |- ?P ?s] => clear x end. Ltac step2_arity2 := repeat step2conjn; repeat step2exn_arity2. Ltac step2_arity1 := repeat step2conjn; repeat step2exn_arity1. Ltac step3_arity2 X := match goal with | [|- ?Q -> ?P ?s1 ?s2] => generalize dependent s2; generalize dependent s1; apply X | [|- ?P ?s1 ?s2] => generalize dependent s2; generalize dependent s1; apply X end. Ltac step3_arity1 X := match goal with | [|- ?Q -> ?P ?s] => generalize dependent s; apply X | [|- ?P ?s] => generalize dependent s; apply X end. Ltac destrs := match goal with | [H : exists x, _ |- _] => destruct H | [H : _ /\ _ |- _] => destruct H | [H : True |- _] => destruct H end. Ltac post := intros; repeat destrs; subst; simpl in *. Tactic Notation "coind2" "using" constr(X) := intros; step1_arity2; step2_arity2; step3_arity2 X; post. Tactic Notation "coind1" "using" constr(X) := intros; step1_arity1; step2_arity1; step3_arity1 X; post. (* guess the arity of the co-inductive predicate *) Tactic Notation "coind" "using" constr(X) := intros; match goal with | [|- ?P ?x ?y] => coind2 using X | [|- ?P ?x] => coind1 using X end. (** * Syntax **) (** Call-by-value lambda calculus with nat constants -- the simplest language with stuck terms (e.g. 0 0) *) Definition var := nat. Lemma var_eq : forall (v1 v2: var), {v1=v2} + {v1<>v2}. Proof. decide equality. Defined. Inductive term : Set := | Var : var -> term | Const : nat -> term | Fun : var -> term -> term | App : term -> term -> term. Hint Constructors term. (* Using the same trick as in the SF: this definition of substitution is capture-avoiding only when the substituted term is closed. Since we are in a call-by-value language and we only evaluate closed terms, the substituted terms will always be closed values. *) Fixpoint subst (x : var) (b : term) (a : term) {struct a} : term := match a with | Var y => if var_eq x y then b else Var y | Const n => Const n | Fun y a1 => Fun y (if var_eq x y then a1 else subst x b a1) | App a1 a2 => App (subst x b a1) (subst x b a2) end. Inductive val : term -> Prop := | val_const : forall c, val (Const c) | val_fun : forall x a, val (Fun x a). Hint Constructors val. (** * Small-step semantics **) (** ** The one-step reduction relation *) (* Call-by-value left-to-right evaluation strategy *) Inductive red1 : term -> term -> Prop := | red1_beta : forall x a v, val v -> red1 (App (Fun x a) v) (subst x v a) | red1_app_l : forall a1 a2 b, red1 a1 a2 -> red1 (App a1 b) (App a2 b) | red1_app_r : forall v b1 b2, val v -> red1 b1 b2 -> red1 (App v b1) (App v b2). Hint Constructors red1. (* omega - term that reduces to itself (in one step) *) Definition vx: var := 0. Definition tdelta := Fun vx (App (Var vx) (Var vx)). Definition tomega := App tdelta tdelta. Lemma red1_tomega : red1 tomega tomega. Proof. constructor; constructor. Qed. (* irreducible terms *) Definition irred (a : term) : Prop := forall b, red1 a b -> False. Lemma value_irred : forall a, val a -> irred a. Proof. induction 1; intros b Hc; inversion Hc. Qed. (* stuck terms = irreducible terms that are not values *) Definition stuck (a : term) : Prop := irred a /\ ~val a. (* an example stuck term *) Definition tstuck := App (Const 0) (Const 0). Lemma stuck_tstuck : stuck tstuck. Proof. split. intros b Hc; inversion Hc; match goal with [ H : red1 (Const _) _ |- _] => inversion H end. intro Hc; inversion Hc. Qed. (* determinism of one-step reduction *) Lemma red1_deterministic: forall a b, red1 a b -> forall c, red1 a c -> c = b. Proof. induction 1; intros. inversion H0. reflexivity. inversion H4. destruct (value_irred H H5). inversion H0. subst a1. inversion H. rewrite (IHred1 _ H4). auto. destruct (value_irred H3 H). inversion H1. destruct (value_irred H5 H0). destruct (value_irred H H5). rewrite (IHred1 _ H6). reflexivity. Qed. (* Exercise (optional): automate this proof *) (** ** Finite (multi-step) reductions *) (* Reflexive-transitive closure of redfin *) Inductive redfin : term -> term -> Prop := | redfin_refl : forall a, redfin a a | redfin_step : forall a b c, red1 a b -> redfin b c -> redfin a c. Hint Constructors redfin. Lemma redfin_one : forall a b, red1 a b -> redfin a b. Proof. eauto. Qed. Lemma redfin_trans : forall a b c, redfin a b -> redfin b c -> redfin a c. Proof. induction 1; eauto. Qed. Definition goes_wrong a := exists b, redfin a b /\ stuck b. Definition twrong := App (Fun vx (App (Var vx) (Var vx))) (Const 0). Lemma goes_wrong_twrong : goes_wrong twrong. Proof. exists tstuck. split. eapply redfin_step. eapply red1_beta. trivial. apply redfin_refl. auto using stuck_tstuck. Qed. (** ** Infinite reductions *) CoInductive redinf: term -> Prop := | redinf_intro : forall a b, red1 a b -> redinf b -> redinf a. Hint Constructors redinf. Section redinf_coind. Variable R : term -> Prop. Hypothesis H : forall a, R a -> exists b, red1 a b /\ R b. Definition redinf_coind : forall t, R t -> redinf t. cofix CIH. intros t Ht. destruct (H Ht) as [b [Hab Hb]]. eapply redinf_intro. eassumption. apply CIH. eassumption. Qed. End redinf_coind. (* We can very easily prove that omega loops *) Lemma redinf_tomega : redinf tomega. Proof. coind using redinf_coind; eauto using red1_tomega. Qed. (* If one steps through the previous proof, though, there is something strange going on. It seems that we were very lucky that tomega immediately reduced to itself, but that won't work in general. Here is an example where that's not the case: *) Definition tloops := App (Fun vx tomega) (Const 0). Lemma red1_tloops_tomega : red1 tloops tomega. Proof. apply red1_beta; constructor. Qed. Lemma redinf_tloops : redinf tloops. Proof. coind using redinf_coind. exists tomega. split. apply red1_beta. trivial. (* Left to show that [tomega = tloops], which is nonsense. The syntactically chosen R (fun a => a = tloops) is not good! *) Abort. (* In this case we need to manually chose a better R, one that contains both [tloops], and all terms that can be reached by taking reduction steps starting from [tomega]. Since [tomega] only reduces to itself, in this case R needs to contain only 2 terms: [tloops] and [tomega]. *) Lemma redinf_tloops : redinf tloops. Proof. apply redinf_coind with (R := fun a => a = tloops \/ a = tomega); crush; eauto using red1_tloops_tomega, red1_tomega. Qed. (* Instead of phrasing this in terms of choosing a better R, we can also phrase it in terms of generalizing the co-induction hypothesis, and then letting [coind] choose the R automatically. *) Lemma redinf_tloops_stronger : forall a, a = tloops \/ a = tomega -> redinf a. Proof. coind using redinf_coind; crush; eauto using red1_tloops_tomega, red1_tomega. Qed. (* While in this case it sufficed to add an additional term to R to have the co-inductive non-termination proof go through, things are more complicated in general. We can very easily construct terms that loop forever without ever repeating the same term again (e.g. something for the form f 1 -> f 2 -> ... -> f n -> ...). For instance here is a term that grows forever when reduced: *) Definition vf : var := 1. (* A bit of the Y combinator *) Definition ypart := Fun vx (App (Var vf) (App (Var vx) (Var vx))). (* Self-application function *) Definition dup := Fun vx (App (Var vx) (Var vx)). (* Y combinator instantiated to dup *) Definition ydup := subst vf dup (App ypart ypart). (* A term that grows forever when evaluated *) Definition tgrows := App dup ydup. (* We can show that dup ydup -> dup (dup ydup) -> dup (dup (ydup)) -> ... *) Lemma red1_tgrows : red1 tgrows (App dup tgrows). Proof. repeat econstructor. Qed. (* In order to show [redinf tgrows] we need to generalize the co-induction hypothesis as follows: *) Lemma redinf_tgrows_stronger : forall b, redfin tgrows b -> redinf b. Proof. coind using redinf_coind. Abort. (* However, before we can make further progress on this proof we need to provide a more direct characterization of all the terms that can be reached by finitely reducing [tgrows]. We do this with an inductive definition: *) Inductive from_tgrows : term -> Prop := | ft_base : from_tgrows tgrows | ft_step : forall a, from_tgrows a -> from_tgrows (App dup a). Hint Constructors from_tgrows. (* We relate [from_tgrows] and [redfin tgrows] in a series of lemmas. Since we do lots of inversions we define a specialized tactic for that: *) Ltac invsc H := inversion H; subst; clear H. Lemma from_tgrows_red1 : forall a b, from_tgrows a -> red1 a b -> from_tgrows b. Proof. intros a b H1 H2. induction H2; invsc H1. invsc H. invsc H2; invsc H. invsc H2. invsc H2. invsc H2. simpl. eauto. invsc H4. invsc H5. eauto. Qed. Lemma from_tgrows_redfin : forall a b, from_tgrows a -> redfin a b -> from_tgrows b. Proof. induction 2; eauto using from_tgrows_red1. Qed. Lemma from_tgrows_sound : forall a, redfin tgrows a -> from_tgrows a. Proof. eauto using from_tgrows_redfin. Qed. Lemma red1_App_dup : forall a, from_tgrows a -> red1 (App dup a) (App dup (App dup a)). Proof. induction 1. eapply red1_app_r. constructor. apply red1_tgrows. apply red1_app_r. constructor. assumption. Qed. (* We didn't need this for the proof below, still, here it goes in case your proof needs it. *) Lemma from_grows_complete : forall a, from_tgrows a -> redfin tgrows a. Proof. induction 1. auto. eapply redfin_trans. apply IHfrom_tgrows. inversion H; subst; clear H. apply redfin_one. apply red1_tgrows. eapply redfin_one. apply red1_App_dup. assumption. Qed. (* Exercise (medium): Use the lemmas above to finish the following co-inductive proof. *) Lemma redinf_tgrows_stronger : forall b, redfin tgrows b -> redinf b. Proof. coind using redinf_coind. pose proof (from_tgrows_sound H) as H'. (* finish this proof *) Admitted. Lemma redinf_tgrows : redinf tgrows. Proof. eauto using redinf_tgrows_stronger. Qed. (* You might have noticed that the proof of [redinf tgrows] was not as simple one might expect. *) (** ** Coinductive reductions *) (* We give a co-inductive interpretation of the rules for reflexive transitive closure; it captures both finite and infinite reductions *) CoInductive cored : term -> term -> Prop := | cored_refl : forall a, cored a a | cored_step : forall a b c, red1 a b -> cored b c -> cored a c. Hint Constructors cored. Section cored_coind. Variable R : term -> term -> Prop. Hypothesis H : forall a b, R a b -> a = b \/ exists a', red1 a a' /\ R a' b. Definition cored_coind : forall a b, R a b -> cored a b. cofix CIH. intros a b HR. destruct (H HR) as [Hab | [a' [Haa' Ha'b]]]. subst. constructor. eapply cored_step. eassumption. apply CIH; assumption. Qed. End cored_coind. (** ** cored is the union of redfin and redinf *) Lemma redfin_cored : forall a b, redfin a b -> cored a b. Proof. induction 1; eauto. Qed. Lemma redinf_cored : forall a b, redinf a -> cored a b. Proof. coind using cored_coind; match goal with | [H : redinf _ |- _] => destruct H; eauto end. Qed. Lemma cored_irred_redinf : forall a b, cored a b -> ~(redfin a b) -> redinf a. Proof. coind using redinf_coind; match goal with | [ H : cored ?a ?b, H0 : ~ redfin ?a ?b |- _] => destruct H; [apply False_ind; eauto | eauto 10] end. Qed. Theorem cored_red_or_redinf: forall a b, cored a b <-> redfin a b \/ redinf a. Proof. intros a b. split; intro H. destruct (classic (redfin a b)); eauto using cored_irred_redinf. destruct H; eauto using redfin_cored, redinf_cored. Qed. (** * Big-step semantics **) (** ** The terminating executions (standard) *) Inductive eval : term -> term -> Prop := | eval_const : forall c, eval (Const c) (Const c) | eval_fun : forall x a, eval (Fun x a) (Fun x a) | eval_app : forall a b x c vb v, eval a (Fun x c) -> eval b vb -> eval (subst x vb c) v -> eval (App a b) v. Hint Constructors eval. Lemma eval_val : forall a b, eval a b -> val b. Proof. induction 1; eauto. Qed. Lemma eval_deterministic : forall a v, eval a v -> forall v', eval a v' -> v' = v. Proof. induction 1; intros. inversion H; reflexivity. inversion H; reflexivity. inversion H2. pose proof (IHeval1 _ H5) as J1. inversion J1. pose proof (IHeval2 _ H6). subst. apply IHeval3; assumption. Qed. (* Exercise (optional): automate this *) Lemma not_eval_tomega : forall v, ~(eval tomega v). Proof. assert (forall a v, eval a v -> a <> tomega). induction 1; unfold tomega. congruence. congruence. red; intro. injection H2; intros; subst. clear H2. unfold tdelta in H. inversion H. subst. clear H. unfold tdelta in H0. inversion H0. subst; clear H0. simpl in IHeval3. fold tdelta in IHeval3. fold tomega in IHeval3. congruence. intros; red; intros. apply (H _ _ H0). reflexivity. Qed. (* Exercise (optional): automate this *) (* This alone doesn't tell us whether tomega is stuck or diverging; in fact [eval] alone can't distinguish [tstuck] from [tomega] -- this is an important limitation of inductive big-step semantics. *) Lemma not_eval_tstuck : forall v, ~(eval tstuck v). Proof. intros v Hc. inversion Hc. subst. inversion H1. Qed. (** ** The non-terminating executions *) CoInductive evalinf: term -> Prop := | evalinf_app_l: forall a b, evalinf a -> evalinf (App a b) | evalinf_app_r: forall a b va, eval a va -> evalinf b -> evalinf (App a b) | evalinf_app_f: forall a b x c vb, eval a (Fun x c) -> eval b vb -> evalinf (subst x vb c) -> evalinf (App a b). Hint Constructors evalinf. (* One important thing to note is that [evalinf] does not hold for stuck terms; i.e. helps us distinguish between stuckness and divergence. *) Lemma not_evalinf_stuck : ~evalinf tstuck. Proof. intro Hc. inversion Hc. inversion H0. inversion H2. inversion H1. Qed. (* The co-induction principle for [evalinf] is quite complicated. We need to use disjunction since all the 3 rules have the same conclusion. *) Section evalinf_coind. Variable R : term -> Prop. Hypothesis H : forall a, R a -> exists a', exists a'', a = (App a' a'') /\ (R a' \/ (exists va', eval a' va' /\ R a'') \/ (exists x, exists c, eval a' (Fun x c) /\ exists va'', eval a'' va'' /\ R (subst x va'' c))). Definition evalinf_coind : forall t, R t -> evalinf t. cofix CIH. intros t Ht. destruct (H Ht) as [? [? [? [? | [[? [? ?]] | [? [? [? [? [? ?]]]]]]]]]]; subst. apply evalinf_app_l. apply CIH; assumption. eapply evalinf_app_r. eassumption. apply CIH; assumption. eapply evalinf_app_f. eassumption. eassumption. apply CIH; assumption. Qed. End evalinf_coind. (* Here is an alternative way of writing this co-induction principle: we first define a binary relation [step_evalinf] that captures most of R above. We have that [step_evalinf a b] when [eval_inf a] has a premise of the form [evalinf b]. *) Inductive step_evalinf : term -> term -> Prop := | step_evalinf_app_l : forall a b, step_evalinf (App a b) a | step_evalinf_app_r: forall a b va, eval a va -> step_evalinf (App a b) b | step_evalinf_app_f: forall a b x c vb, eval a (Fun x c) -> eval b vb -> step_evalinf (App a b) (subst x vb c). Hint Constructors step_evalinf. (* Using this we can define an alternative co-inductive principle that looks simpler: *) Section evalinf_coind'. Variable R : term -> Prop. Hypothesis H : forall a, R a -> exists b, step_evalinf a b /\ R b. Definition evalinf_coind' : forall a, R a -> evalinf a. cofix CIH. intros a Ha. destruct (H Ha) as [b [Hstep H']]. (* the rest of the proof is exactly as before *) inversion Hstep; subst. apply evalinf_app_l. apply CIH; assumption. eapply evalinf_app_r. eassumption. apply CIH; assumption. eapply evalinf_app_f. eassumption. eassumption. apply CIH; assumption. Qed. End evalinf_coind'. (* Exercise (medium): Prove that this alternative way to state the co-inductive principle is in fact equivalent with the original one. *) Section evalinf_coind_equiv. Variable R : term -> Prop. Variable a : term. Hypothesis H : R a. Lemma evalinf_coind_equiv : (exists b, step_evalinf a b /\ R b) <-> (exists a', exists a'', a = (App a' a'') /\ (R a' \/ (exists va', eval a' va' /\ R a'') \/ (exists x, exists c, eval a' (Fun x c) /\ exists va'', eval a'' va'' /\ R (subst x va'' c)))). Proof. (* fill this in *) Admitted. End evalinf_coind_equiv. (* Now let's prove that [tomega] is non-terminating using [evalinf]. We do it with each of the induction principles. *) Lemma evalinf_tomega : evalinf tomega. Proof. coind using evalinf_coind. unfold tomega. intros. subst. econstructor. econstructor. split. reflexivity. right. right. unfold tdelta. econstructor. econstructor. split. constructor. econstructor. split. constructor. simpl. split; trivial. Qed. (* Exercise (optional): automate this proof *) (* small trick: when [eapply]ed this adds an existential variable *) Lemma step_evalinf_helper : forall a b b', step_evalinf a b -> b = b' -> step_evalinf a b'. Proof. intros; subst; assumption. Qed. Lemma evalinf_tomega' : evalinf tomega. Proof. coind using evalinf_coind'. exists tomega. split; [| reflexivity]. eapply step_evalinf_helper. apply step_evalinf_app_f; unfold tdelta; trivial. reflexivity. Qed. (* Exercise (medium): Show that [tloops] is in [evalinf]. (Hint: if you're stuck have a look at [redinf_tloops]) *) Lemma evalinf_tloops : evalinf tloops. Proof. (* fill in here *) Admitted. (* Exercise (open challenge, optional): Show that [tgrows] is in [evalinf]. *) Lemma evalinf_tgrows : evalinf tloops. Proof. (* fill in here *) Admitted. (** * Relating the big-step and small-step semantics **) (** ** The finite part (standard, easy) *) Lemma redfin_app_l : forall a1 a2 b, redfin a1 a2 -> redfin (App a1 b) (App a2 b). Proof. induction 1; eauto. Qed. Lemma redfin_app_r : forall v a1 a2, val v -> redfin a1 a2 -> redfin (App v a1) (App v a2). Proof. induction 2; eauto. Qed. Theorem eval_redfin: forall a v, eval a v -> redfin a v. Proof. induction 1; try solve [apply redfin_refl]. apply redfin_trans with (App (Fun x c) b). apply redfin_app_l; assumption. apply redfin_trans with (App (Fun x c) vb). apply redfin_app_r; [constructor | assumption]. apply redfin_trans with (subst x vb c). apply redfin_one. eauto using eval_val. assumption. Qed. Lemma val_eval : forall v, val v -> eval v v. Proof. induction 1; auto. Qed. Lemma red1_eval : forall a b, red1 a b -> forall v, eval b v -> eval a v. Proof. induction 1; intros. eauto using val_eval. inversion H0; eauto. inversion H1; eauto. Qed. Theorem redfin_eval: forall a v, redfin a v -> val v -> eval a v. Proof. induction 1; eauto using val_eval, red1_eval. Qed. (** ** The infinite part (more interesting) *) (** We show that evalinf and redinf are equivalent; first the -> direction. *) Lemma infinite_progress_redinf: forall a, (forall b, redfin a b -> exists c, red1 b c) -> redinf a. Proof. coind using redinf_coind; match goal with | [a : term |- _] => assert (exists b, red1 a b) as [b J] by auto; eauto 10 end. Qed. Lemma redfin_or_redinf: forall a, (exists b, redfin a b /\ irred b) \/ redinf a. Proof. intro. destruct (classic (redinf a)). right; assumption. left. assert (~(forall b, redfin a b -> exists c, red1 b c)) by eauto using infinite_progress_redinf. destruct (not_all_ex_not _ _ H0) as [b A]. destruct (imply_to_and _ _ A). exists b. split. assumption. unfold irred. eauto. Qed. Lemma evalinf_red1: forall a, evalinf a -> exists b, red1 a b /\ evalinf b. Proof. induction a; intros; inversion H. (* function part evaluates infinitely *) elim (IHa1 H1). intros a1' [R E]. exists (App a1' a2). split. constructor; auto. apply evalinf_app_l; auto. (* function part evaluates finitely, argument evaluates infinitely *) elim (IHa2 H3). intros a2' [R E]. generalize (eval_redfin H2). intro. inversion H4. (* function part was already a value *) exists (App va a2'). split. constructor. eapply eval_val; eauto. auto. apply evalinf_app_r with va. apply val_eval. eapply eval_val; eauto. auto. (* function part evaluates *) exists (App b0 a2). split. constructor. auto. apply evalinf_app_r with va. apply redfin_eval; auto. eapply eval_val; eauto. auto. (* function and argument parts evaluate finitely, beta-redex evaluates infinitely *) generalize (eval_redfin H2). intro. inversion H5. (* function part was already a value *) generalize (eval_redfin H3). intro. inversion H8. (* argument part was already a value *) exists (subst x vb c). split. constructor. eapply eval_val; eauto. auto. (* argument part reduces *) exists (App (Fun x c) b0). split. constructor. constructor. auto. apply evalinf_app_f with x c vb. constructor. apply redfin_eval; auto. eapply eval_val; eauto. auto. (* function part reduces *) exists (App b0 a2). split. constructor. auto. apply evalinf_app_f with x c vb. apply redfin_eval; auto. auto. auto. Qed. Theorem evalinf_redinf: forall a, evalinf a -> redinf a. Proof. coind using redinf_coind; eauto using evalinf_red1. Qed. (** second we show that redinf implies evalinf *) Lemma redinf_app_l: forall a a', redfin a a' -> forall b, redinf (App a b) -> redinf (App a' b). Proof. induction 1; intros. assumption. apply IHredfin. inversion H1. replace (App b b0) with b1. assumption. apply red1_deterministic with (App a b0); auto. Qed. Lemma redinf_app_r: forall b b', redfin b b' -> forall a, val a -> redinf (App a b) -> redinf (App a b'). Proof. induction 1; intros. assumption. apply IHredfin. auto. inversion H2. replace (App a0 b) with b0. assumption. apply red1_deterministic with (App a0 a); auto. Qed. Theorem redinf_evalinf: forall a, redinf a -> evalinf a. Proof. coind using evalinf_coind. (* XXX move the intros out of coind? *) destruct a; try (inversion H; inversion H0; fail). eexists. eexists. split. reflexivity. destruct (redfin_or_redinf a1) as [ [n1 [REDM1 IRRED1]] | ? ]; [| eauto]. right. (* a1 evaluates finitely *) assert (REDINF1 : redinf (App n1 a2)) by eauto using redinf_app_l. assert (ISVAL1 : val n1). inversion REDINF1. inversion H0. constructor. destruct (IRRED1 _ H6). (* XXX This we should automate *) assumption. destruct (redfin_or_redinf a2) as [ [n2 [REDM2 IRRED2]] | ?]; [| eauto using redfin_eval]. right. (* a2 evaluates finitely as well *) assert (REDINF2 : redinf (App n1 n2)) by eauto using redinf_app_r. assert (J: exists x, exists c, n1 = Fun x c /\ val n2 /\ redinf (subst x n2 c)). inversion REDINF2. inversion H0. subst. exists x; exists a0. tauto. destruct (IRRED1 _ H6). destruct (IRRED2 _ H7). destruct J as [x [c [A [B C]]]]. subst n1. exists x. exists c. split. eauto using redfin_eval. exists n2. split; eauto using redfin_eval. Qed. (* Exercise (optional): Automate as many proofs in this file as possible and send us the ones you're most proud of. *)