From 72d486bce38b376524bedb3cfbcfc136b28b33d9 Mon Sep 17 00:00:00 2001 From: Steven Keuchel Date: Thu, 8 May 2014 15:44:47 +0200 Subject: [PATCH] Reformat and reindent source code. --- Arith.v | 1707 +++++++++++++++++++++-------------------- Arith_Lambda.v | 42 +- Bool.v | 1135 +++++++++++++-------------- Bool_Lambda.v | 43 +- Functors.v | 610 ++++++++------- Lambda.v | 2002 ++++++++++++++++++++++++------------------------ MiniML.v | 30 +- Mu.v | 459 +++++------ Names.v | 1074 +++++++++++++------------- NatCase.v | 424 +++++----- PNames.v | 233 +++--- 11 files changed, 3981 insertions(+), 3778 deletions(-) diff --git a/Arith.v b/Arith.v index 4cb6180..5d639c9 100644 --- a/Arith.v +++ b/Arith.v @@ -12,13 +12,14 @@ Section Arith. (* The Arithmetic Type. *) Inductive AType (A : Set) : Set := - | TNat : AType A. + TNat : AType A. - Definition AType_fmap : forall (A B : Set) (f : A -> B), - AType A -> AType B := fun A B _ _ => TNat _. + Definition AType_fmap (A B : Set) (f : A -> B) : + AType A -> AType B := fun _ => TNat _. Global Instance AType_Functor : Functor AType := {| fmap := AType_fmap |}. + Proof. destruct a; reflexivity. (* fmap id *) destruct a; reflexivity. @@ -29,7 +30,7 @@ Section Arith. Definition DType := DType D. Context {Sub_AType_D : AType :<: D}. - (* Constructor + Universal Property. *) + (* Constructor + Universal Property. *) Context {WF_Sub_AType_D : WF_Functor _ _ Sub_AType_D _ _}. Definition tnat' : DType := inject' (TNat _). @@ -46,27 +47,28 @@ Section Arith. | TNat => exist _ _ H end. - Lemma WF_ind_alg_AType (Name : Set) - (P : forall e : Fix D, Universal_Property'_fold e -> Prop) - (H : UP'_P P tnat) - {Sub_AType_D' : AType :<: D} : + Lemma WF_ind_alg_AType (Name : Set) + (P : forall e : Fix D, Universal_Property'_fold e -> Prop) + (H : UP'_P P tnat) + {Sub_AType_D' : AType :<: D} : (forall a, inj (Sub_Functor := Sub_AType_D) a = - inj (A := Fix D) (Sub_Functor := Sub_AType_D') a) -> - WF_Ind (Name := Name) {| p_algebra := fun H0 => ind_alg_AType P H H0|}. - constructor; intros. - simpl; unfold ind_alg_AType; destruct e; simpl. - unfold tnat; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. - Defined. + inj (A := Fix D) (Sub_Functor := Sub_AType_D') a) -> + WF_Ind (Name := Name) {| p_algebra := fun H0 => ind_alg_AType P H H0|}. + Proof. + constructor; intros. + simpl; unfold ind_alg_AType; destruct e; simpl. + unfold tnat; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. + Defined. (* Type Equality Section. *) Definition isTNat : Fix D -> bool := - fun typ => - match project typ with - | Some TNat => true - | None => false - end. + fun typ => + match project typ with + | Some TNat => true + | None => false + end. - Definition AType_eq_DType (R : Set) (rec : R -> eq_DTypeR D) + Definition AType_eq_DType (R : Set) (rec : R -> eq_DTypeR D) (e : AType R) : eq_DTypeR D := match e with | TNat => fun t => isTNat (proj1_sig t) @@ -81,6 +83,7 @@ Section Arith. Sub_AType_D (MAlgebra_eq_DType_Arith T) (eq_DType_DT _)}. Lemma AType_eq_DType_eq_H : UP'_P (eq_DType_eq_P D) tnat. + Proof. unfold UP'_P; econstructor. unfold eq_DType_eq_P; intros. unfold eq_DType, mfold, tnat, tnat', inject' in H; simpl in H; @@ -124,6 +127,7 @@ Section Arith. Global Instance Arith_Functor : Functor Arith := {| fmap := Arith_fmap |}. + Proof. destruct a; reflexivity. (* fmap id *) destruct a; reflexivity. @@ -135,7 +139,7 @@ Section Arith. Context {Sub_Arith_F : Arith :<: F}. (* Constructor + Universal Property. *) - Context {WF_Sub_Arith_F : WF_Functor _ _ Sub_Arith_F _ _}. + Context {WF_Sub_Arith_F : WF_Functor _ _ Sub_Arith_F _ _}. Definition lit' (n : nat) : Exp := inject' (Lit _ n). Definition lit (n : nat) : Fix F := proj1_sig (lit' n). Global Instance UP'_lit {n : nat} : @@ -148,12 +152,12 @@ Section Arith. {UP'_n : Universal_Property'_fold n} : Fix F := proj1_sig (add' (exist _ _ UP'_m) (exist _ _ UP'_n)). - Global Instance UP'_add {m n : Fix F} - {UP'_m : Universal_Property'_fold m} - {UP'_n : Universal_Property'_fold n} - : - Universal_Property'_fold (add m n) := - proj2_sig (add' (exist _ _ UP'_m) (exist _ _ UP'_n)). + Global Instance UP'_add {m n : Fix F} + {UP'_m : Universal_Property'_fold m} + {UP'_n : Universal_Property'_fold n} + : + Universal_Property'_fold (add m n) := + proj2_sig (add' (exist _ _ UP'_m) (exist _ _ UP'_n)). (* Induction Principles for Arith. *) Definition ind_alg_Arith @@ -167,9 +171,10 @@ Section Arith. : sig (UP'_P P) := match e with - | Lit n => exist _ (lit n) (H n) + | Lit n => exist _ (lit n) (H n) | Add m n => exist (UP'_P P) _ - (H0 (proj1_sig m) (proj1_sig n) (proj2_sig m) (proj2_sig n)) + (H0 (proj1_sig m) (proj1_sig n) + (proj2_sig m) (proj2_sig n)) end. Definition ind2_alg_Arith @@ -194,7 +199,8 @@ Section Arith. match e with | Lit n => exist _ _ (H n) | Add m n => exist (UP'_P2 P) _ - (H0 (proj1_sig m) (proj1_sig n) (proj2_sig m) (proj2_sig n)) + (H0 (proj1_sig m) (proj1_sig n) + (proj2_sig m) (proj2_sig n)) end. (* ============================================== *) @@ -205,17 +211,17 @@ Section Arith. Definition Arith_typeof (R : Set) (rec : R -> typeofR D) (e : Arith R) : typeofR D := - match e with - | Lit n => Some (inject' (TNat _)) - | Add m n => match (rec m), (rec n) with - | Some T1, Some T2 => - match isTNat (proj1_sig T1), isTNat (proj1_sig T2) with - | true, true => Some (inject' (TNat _)) - | _, _ => None - end - | _, _ => None - end - end. + match e with + | Lit n => Some (inject' (TNat _)) + | Add m n => match (rec m), (rec n) with + | Some T1, Some T2 => + match isTNat (proj1_sig T1), isTNat (proj1_sig T2) with + | true, true => Some (inject' (TNat _)) + | _, _ => None + end + | _, _ => None + end + end. Global Instance MAlgebra_typeof_Arith T: FAlgebra TypeofName T (typeofR D) Arith := @@ -226,25 +232,26 @@ Section Arith. (* ============================================== *) (* Arithmetic Values. *) - Inductive NatValue (A : Set) : Set := - | VI : nat -> NatValue A. - - Definition VI_fmap : forall (A B : Set) (f : A -> B), - NatValue A -> NatValue B := - fun A B _ e => match e with - | VI n => VI _ n - end. - - Global Instance VI_Functor : Functor NatValue := - {| fmap := VI_fmap |}. - destruct a; reflexivity. - destruct a; reflexivity. - Defined. - - Variable V : Set -> Set. - Context {Fun_V : Functor V}. - Definition Value := Value V. - Context {Sub_NatValue_V : NatValue :<: V}. + Inductive NatValue (A : Set) : Set := + | VI : nat -> NatValue A. + + Definition VI_fmap (A B : Set) (f : A -> B) : + NatValue A -> NatValue B := + fun e => match e with + | VI n => VI _ n + end. + + Global Instance VI_Functor : Functor NatValue := + {| fmap := VI_fmap |}. + Proof. + destruct a; reflexivity. + destruct a; reflexivity. + Defined. + + Variable V : Set -> Set. + Context {Fun_V : Functor V}. + Definition Value := Value V. + Context {Sub_NatValue_V : NatValue :<: V}. (* Constructor + Universal Property. *) Context {WF_Sub_NatValue_F : WF_Functor _ _ Sub_NatValue_V _ _}. @@ -252,21 +259,21 @@ Section Arith. Definition vi' (n : nat) : Value := inject' (VI _ n). Definition vi (n : nat) : Fix V := proj1_sig (vi' n). - Global Instance UP'_vi {n : nat} : - Universal_Property'_fold (vi n) := proj2_sig (vi' n). + Global Instance UP'_vi {n : nat} : + Universal_Property'_fold (vi n) := proj2_sig (vi' n). - (* Constructor Testing for Arithmetic Values. *) + (* Constructor Testing for Arithmetic Values. *) - Definition isVI : Fix V -> option nat := - fun exp => - match project exp with + Definition isVI : Fix V -> option nat := + fun exp => + match project exp with | Some (VI n) => Some n | None => None - end. + end. - Context {Sub_StuckValue_V : StuckValue :<: V}. - Definition stuck' : nat -> Value := stuck' _. - Definition stuck : nat -> Fix V := stuck _. + Context {Sub_StuckValue_V : StuckValue :<: V}. + Definition stuck' : nat -> Value := stuck' _. + Definition stuck : nat -> Fix V := stuck _. (* ============================================== *) (* EVALUATION *) @@ -274,23 +281,26 @@ Section Arith. Context {Sub_BotValue_V : BotValue :<: V}. - (* Evaluation Algebra for Arithemetic Expressions. *) - - Definition Arith_eval (R : Set) (rec : R -> evalR V) - (e : Arith R) : evalR V := - match e with - | Lit n => (fun _ => vi' n) - | Add m n => (fun env => - let m' := (rec m env) in - let n' := (rec n env) in - match isVI (proj1_sig m'), isVI (proj1_sig n') with - | Some m', Some n' => vi' (m' + n') - | _, _ => - if @isBot _ Fun_V Sub_BotValue_V (proj1_sig m') then @bot' _ Fun_V Sub_BotValue_V else - if @isBot _ Fun_V Sub_BotValue_V (proj1_sig n') then @bot' _ Fun_V Sub_BotValue_V else - stuck' 4 - end) - end. + (* Evaluation Algebra for Arithemetic Expressions. *) + + Definition Arith_eval (R : Set) (rec : R -> evalR V) + (e : Arith R) : evalR V := + match e with + | Lit n => fun _ => vi' n + | Add m n => + fun env => + let m' := (rec m env) in + let n' := (rec n env) in + match isVI (proj1_sig m'), isVI (proj1_sig n') with + | Some m', Some n' => vi' (m' + n') + | _, _ => + if @isBot _ Fun_V Sub_BotValue_V (proj1_sig m') + then @bot' _ Fun_V Sub_BotValue_V + else if @isBot _ Fun_V Sub_BotValue_V (proj1_sig n') + then @bot' _ Fun_V Sub_BotValue_V + else stuck' 4 + end + end. Global Instance MAlgebra_eval_Arith T : FAlgebra EvalName T (evalR V) Arith := @@ -312,17 +322,20 @@ Section Arith. Global Instance MAlgebra_ExpPrint_Arith T : FAlgebra ExpPrintName T (ExpPrintR) Arith := - {| f_algebra := fun rec e => match e with - | Lit n => fun i => String (ascii_of_nat (n + 48)) EmptyString - | Add m n => fun i => append "(" ((rec m i) ++ " + " ++ (rec n i) ++ ")") - end |}. + {| f_algebra := + fun rec e => + match e with + | Lit n => fun i => String (ascii_of_nat (n + 48)) EmptyString + | Add m n => fun i => append "(" ((rec m i) ++ " + " ++ (rec n i) ++ ")") + end |}. Global Instance MAlgebra_ValuePrint_AType T : FAlgebra ValuePrintName T ValuePrintR NatValue := - {| f_algebra := fun rec e => - match e with - | VI n => String (ascii_of_nat (n + 48)) EmptyString - end |}. + {| f_algebra := + fun rec e => + match e with + | VI n => String (ascii_of_nat (n + 48)) EmptyString + end |}. (* ============================================== *) (* TYPE SOUNDNESS *) @@ -332,7 +345,7 @@ Section Arith. Context {WF_eval_F : @WF_FAlgebra EvalName _ _ Arith F Sub_Arith_F (MAlgebra_eval_Arith _) eval_F}. - (* Continuity of Evaluation. *) + (* Continuity of Evaluation. *) Context {WF_SubBotValue_V : WF_Functor BotValue V Sub_BotValue_V Bot_Functor Fun_V}. Context {SV : (SubValue_i V -> Prop) -> SubValue_i V -> Prop}. @@ -340,480 +353,493 @@ Section Arith. (* Lit case. *) - Ltac WF_FAlg_rewrite := repeat rewrite wf_functor; simpl; - repeat rewrite out_in_fmap; simpl; - repeat rewrite wf_functor; simpl; - repeat rewrite wf_algebra; simpl. + Ltac WF_FAlg_rewrite := + repeat rewrite wf_functor; simpl; + repeat rewrite out_in_fmap; simpl; + repeat rewrite wf_functor; simpl; + repeat rewrite wf_algebra; simpl. - Lemma eval_continuous_Exp_H : forall n, + Lemma eval_continuous_Exp_H : + forall n, UP'_P (eval_continuous_Exp_P V F SV) (lit n). - unfold eval_continuous_Exp_P; intros; econstructor; intros. - unfold beval, mfold, lit; simpl; unfold inject. - WF_FAlg_rewrite. - apply inject_i. - constructor. - reflexivity. - Qed. - - (* Add case. *) - - Context {Dis_VI_Bot : Distinct_Sub_Functor _ Sub_NatValue_V Sub_BotValue_V}. - - (* Inversion principles for natural number SubValues. *) - Definition SV_invertVI_P (i : SubValue_i V) := - forall n, proj1_sig (sv_a _ i) = vi n -> - proj1_sig (sv_b _ i) = vi n. - - Inductive SV_invertVI_Name := ece_invertvi_name. - Context {SV_invertVI_SV : - iPAlgebra SV_invertVI_Name SV_invertVI_P SV}. - - Global Instance SV_invertVI_refl : - iPAlgebra SV_invertVI_Name SV_invertVI_P (SubValue_refl V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertVI_P. - inversion H; subst; simpl; congruence. - Defined. - - Lemma SV_invertVI_default : forall V' - (Fun_V' : Functor V') - (SV' : (SubValue_i V -> Prop) -> SubValue_i V -> Prop) - (sub_V'_V : V' :<: V) - (WF_V' : WF_Functor V' V sub_V'_V Fun_V' Fun_V), - (forall (i : SubValue_i V) (H : SV' SV_invertVI_P i), - exists v', proj1_sig (sv_a _ i) = inject v') -> - Distinct_Sub_Functor _ Sub_NatValue_V sub_V'_V -> - iPAlgebra SV_invertVI_Name SV_invertVI_P SV'. - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertVI_P. - destruct (H _ H1) as [v' eq_v']. - intros; rewrite eq_v' in H2. - elimtype False. - unfold vi, inject, vi', inject' in H2; simpl in H2. - apply sym_eq in H2. - apply (inject_discriminate H0 _ _ H2). - Defined. - - Global Instance SV_invertVI_Bot : - iPAlgebra SV_invertVI_Name SV_invertVI_P (SubValue_Bot V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertVI_P. - inversion H; subst; simpl; intros. - elimtype False. - rewrite H0 in H1. - unfold vi, inject, vi', inject' in H1; simpl in H1. - repeat rewrite out_in_inverse, wf_functor in H1; simpl in H1. - eapply (inject_discriminate Dis_VI_Bot); unfold inject; simpl; eauto. - Defined. - - Context {iFun_F : iFunctor SV}. - Definition SV_invertVI := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertVI_SV)). - - Definition SV_invertVI'_P (i : SubValue_i V) := - forall n, proj1_sig (sv_b _ i) = vi n -> - proj1_sig (sv_a _ i) = vi n \/ proj1_sig (sv_a _ i) = bot _. - - Inductive SV_invertVI'_Name := ece_invertvi'_name. - Context {SV_invertVI'_SV : - iPAlgebra SV_invertVI'_Name SV_invertVI'_P SV}. - - Global Instance SV_invertVI'_refl : - iPAlgebra SV_invertVI'_Name SV_invertVI'_P (SubValue_refl V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertVI'_P. - inversion H; subst; simpl; eauto. - intros. - left; congruence. - Defined. + Proof. + unfold eval_continuous_Exp_P; intros; econstructor; intros. + unfold beval, mfold, lit; simpl; unfold inject. + WF_FAlg_rewrite. + apply inject_i. + constructor. + reflexivity. + Qed. + + (* Add case. *) + + Context {Dis_VI_Bot : Distinct_Sub_Functor _ Sub_NatValue_V Sub_BotValue_V}. + + (* Inversion principles for natural number SubValues. *) + Definition SV_invertVI_P (i : SubValue_i V) := + forall n, proj1_sig (sv_a _ i) = vi n -> + proj1_sig (sv_b _ i) = vi n. + + Inductive SV_invertVI_Name := ece_invertvi_name. + Context {SV_invertVI_SV : + iPAlgebra SV_invertVI_Name SV_invertVI_P SV}. + + Global Instance SV_invertVI_refl : + iPAlgebra SV_invertVI_Name SV_invertVI_P (SubValue_refl V). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertVI_P. + inversion H; subst; simpl; congruence. + Defined. + + Lemma SV_invertVI_default : forall V' + (Fun_V' : Functor V') + (SV' : (SubValue_i V -> Prop) -> SubValue_i V -> Prop) + (sub_V'_V : V' :<: V) + (WF_V' : WF_Functor V' V sub_V'_V Fun_V' Fun_V), + (forall (i : SubValue_i V) (H : SV' SV_invertVI_P i), + exists v', proj1_sig (sv_a _ i) = inject v') -> + Distinct_Sub_Functor _ Sub_NatValue_V sub_V'_V -> + iPAlgebra SV_invertVI_Name SV_invertVI_P SV'. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertVI_P. + destruct (H _ H1) as [v' eq_v']. + intros; rewrite eq_v' in H2. + elimtype False. + unfold vi, inject, vi', inject' in H2; simpl in H2. + apply sym_eq in H2. + apply (inject_discriminate H0 _ _ H2). + Defined. - Global Instance SV_invertVI'_Bot : - iPAlgebra SV_invertVI'_Name SV_invertVI'_P (SubValue_Bot V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertVI'_P. - inversion H; subst; simpl; eauto. - Defined. + Global Instance SV_invertVI_Bot : + iPAlgebra SV_invertVI_Name SV_invertVI_P (SubValue_Bot V). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertVI_P. + inversion H; subst; simpl; intros. + elimtype False. + rewrite H0 in H1. + unfold vi, inject, vi', inject' in H1; simpl in H1. + repeat rewrite out_in_inverse, wf_functor in H1; simpl in H1. + eapply (inject_discriminate Dis_VI_Bot); unfold inject; simpl; eauto. + Defined. + + Context {iFun_F : iFunctor SV}. + Definition SV_invertVI := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertVI_SV)). + + Definition SV_invertVI'_P (i : SubValue_i V) := + forall n, proj1_sig (sv_b _ i) = vi n -> + proj1_sig (sv_a _ i) = vi n \/ + proj1_sig (sv_a _ i) = bot _. + + Inductive SV_invertVI'_Name := ece_invertvi'_name. + Context {SV_invertVI'_SV : + iPAlgebra SV_invertVI'_Name SV_invertVI'_P SV}. - Definition SV_invertVI' := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertVI'_SV)). + Global Instance SV_invertVI'_refl : + iPAlgebra SV_invertVI'_Name SV_invertVI'_P (SubValue_refl V). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertVI'_P. + inversion H; subst; simpl; eauto. + intros. + left; congruence. + Defined. + + Global Instance SV_invertVI'_Bot : + iPAlgebra SV_invertVI'_Name SV_invertVI'_P (SubValue_Bot V). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertVI'_P. + inversion H; subst; simpl; eauto. + Defined. - (* End Inversion principles for SubValue.*) + Definition SV_invertVI' := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertVI'_SV)). - Context {SV_invertBot_SV : - iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SV}. + (* End Inversion principles for SubValue.*) - Context {Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV}. + Context {SV_invertBot_SV : + iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SV}. - Lemma project_bot_vi : forall n, + Context {Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV}. + + Lemma project_bot_vi : + forall n, project (F := V) (G := BotValue) (vi n) = None. - Proof. - intros; unfold project, vi; simpl; rewrite out_in_fmap. - repeat rewrite wf_functor; simpl; unfold VI_fmap. - caseEq (prj (sub_F := BotValue) (inj (sub_G := V) (VI (sig (@Universal_Property'_fold V _)) n))). - apply inj_prj in H; elimtype False; eapply (inject_discriminate Dis_VI_Bot); - unfold inject; repeat apply f_equal; apply H. - auto. - Qed. - - Lemma project_vi_bot : project (F := V) (G := NatValue) (bot _) = None. - Proof. - intros; unfold project, bot; simpl; rewrite out_in_fmap. - repeat rewrite wf_functor; simpl; unfold Bot_fmap. - caseEq (prj (sub_F := NatValue) (inj (sub_G := V) (Bot (sig (@Universal_Property'_fold V _))))). - apply inj_prj in H; elimtype False; eapply (inject_discriminate Dis_VI_Bot); - unfold inject; repeat apply f_equal; apply sym_eq in H; apply H. - auto. - Qed. - - Lemma project_vi_vi : forall n, + Proof. + intros; unfold project, vi; simpl; rewrite out_in_fmap. + repeat rewrite wf_functor; simpl; unfold VI_fmap. + caseEq (prj (sub_F := BotValue) (inj (sub_G := V) (VI (sig (@Universal_Property'_fold V _)) n))). + apply inj_prj in H; elimtype False; eapply (inject_discriminate Dis_VI_Bot); + unfold inject; repeat apply f_equal; apply H. + auto. + Qed. + + Lemma project_vi_bot : project (F := V) (G := NatValue) (bot _) = None. + Proof. + intros; unfold project, bot; simpl; rewrite out_in_fmap. + repeat rewrite wf_functor; simpl; unfold Bot_fmap. + caseEq (prj (sub_F := NatValue) (inj (sub_G := V) (Bot (sig (@Universal_Property'_fold V _))))). + apply inj_prj in H; elimtype False; eapply (inject_discriminate Dis_VI_Bot); + unfold inject; repeat apply f_equal; apply sym_eq in H; apply H. + auto. + Qed. + + Lemma project_vi_vi : + forall n, project (F := V) (G := NatValue) (vi n) = Some (VI _ n). - Proof. - intros; unfold project, vi, inject; simpl; rewrite out_in_fmap. - repeat rewrite wf_functor; simpl; unfold VI_fmap. - rewrite prj_inj; reflexivity. - Qed. + Proof. + intros; unfold project, vi, inject; simpl; rewrite out_in_fmap. + repeat rewrite wf_functor; simpl; unfold VI_fmap. + rewrite prj_inj; reflexivity. + Qed. - Lemma eval_continuous_Exp_H0 : forall + Lemma eval_continuous_Exp_H0 : + forall (m n : Fix F) (IHm : UP'_P (eval_continuous_Exp_P V F SV) m) (IHn : UP'_P (eval_continuous_Exp_P V F SV) n), UP'_P (eval_continuous_Exp_P V F SV) (@add m n (proj1_sig IHm) (proj1_sig IHn)). - unfold eval_continuous_Exp_P; intros. - destruct IHm as [m_UP' IHm]. - destruct IHn as [n_UP' IHn]. - econstructor; intros; eauto with typeclass_instances. - unfold beval, mfold, add; simpl. - unfold inject; simpl; repeat rewrite out_in_fmap; simpl; - repeat rewrite wf_functor; simpl. - repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. - repeat erewrite bF_UP_in_out. - caseEq (project (G := NatValue) - (proj1_sig (boundedFix_UP m0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma))). - unfold isVI at 1, evalR, Names.Exp; rewrite H2. - destruct n1. - generalize (H (exist _ m m_UP') _ _ _ H0 H1); simpl; intros. - generalize (inj_prj _ _ H2); rename H2 into H2'; intros. - assert (proj1_sig + Proof. + unfold eval_continuous_Exp_P; intros. + destruct IHm as [m_UP' IHm]. + destruct IHn as [n_UP' IHn]. + econstructor; intros; eauto with typeclass_instances. + unfold beval, mfold, add; simpl. + unfold inject; simpl; repeat rewrite out_in_fmap; simpl; + repeat rewrite wf_functor; simpl. + repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. + repeat erewrite bF_UP_in_out. + caseEq (project (G := NatValue) + (proj1_sig (boundedFix_UP m0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold m m_UP') gamma))). + unfold isVI at 1, evalR, Names.Exp; rewrite H2. + destruct n1. + generalize (H (exist _ m m_UP') _ _ _ H0 H1); simpl; intros. + generalize (inj_prj _ _ H2); rename H2 into H2'; intros. + assert (proj1_sig + (boundedFix_UP m0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold m m_UP') gamma) = vi n1) as Eval_m. + unfold vi, vi', inject'; rewrite <- H2; rewrite in_out_UP'_inverse; eauto. + exact (proj2_sig _). + clear H2; rename H3 into SubV_m. + unfold isVI; unfold eval, mfold in SubV_m. + caseEq (project (G := NatValue) (proj1_sig (boundedFix_UP m0 f_algebra (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma) = vi n1) as Eval_m. - unfold vi, vi', inject'; rewrite <- H2; rewrite in_out_UP'_inverse; eauto. - exact (proj2_sig _). - clear H2; rename H3 into SubV_m. - unfold isVI; unfold eval, mfold in SubV_m. - caseEq (project (G := NatValue) (proj1_sig + (exist Universal_Property'_fold n n_UP') gamma))). + destruct n2. + generalize (H (exist _ n n_UP') _ _ _ H0 H1); simpl; intros. + generalize (inj_prj _ _ H2); rename H2 into H3'; intros. + assert (proj1_sig + (boundedFix_UP m0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold n n_UP') gamma) = vi n2) as Eval_n. + unfold vi, vi', inject'; rewrite <- H2; rewrite in_out_UP'_inverse; eauto. + exact (proj2_sig _). + clear H2; rename H3 into SubV_n. + unfold isVI; unfold eval, mfold in SubV_n. + generalize (SV_invertVI _ SubV_m _ Eval_m). + generalize (SV_invertVI _ SubV_n _ Eval_n). + simpl; unfold beval at 1; unfold beval at 1; unfold evalR, Names.Exp; intros. + rewrite H3, H2. + unfold project, vi, vi'; simpl; repeat rewrite out_in_fmap; + repeat rewrite wf_functor; repeat rewrite prj_inj; + repeat rewrite wf_functor; simpl. + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. + unfold isBot; rewrite Eval_m. + caseEq (project (G := BotValue) (vi n1)). + destruct b; generalize (inj_prj _ _ H3); intro. + assert (vi n1 = bot _) by + (unfold vi, vi', bot, bot', inject' at -1; rewrite <- H4; + rewrite in_out_UP'_inverse; eauto with typeclass_instances). + unfold vi, bot in H5. + elimtype False; eapply (inject_discriminate Dis_VI_Bot _ _ H5). + caseEq (project (G := BotValue) + (proj1_sig (boundedFix_UP m0 f_algebra (fun _ : Env (Names.Value V) => bot' V) (exist Universal_Property'_fold n n_UP') gamma))). - destruct n2. - generalize (H (exist _ n n_UP') _ _ _ H0 H1); simpl; intros. - generalize (inj_prj _ _ H2); rename H2 into H3'; intros. - assert (proj1_sig - (boundedFix_UP m0 f_algebra + destruct b. + apply inject_i; constructor; reflexivity. + generalize (H (exist _ n n_UP') _ _ _ H0 H1) as SubV_n; simpl; intros. + caseEq (project (G := NatValue) + (proj1_sig + (boundedFix_UP n0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold m m_UP') gamma'))). + destruct n2. + caseEq (project (G := NatValue) + (proj1_sig + (boundedFix_UP n0 f_algebra (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma) = vi n2) as Eval_n. - unfold vi, vi', inject'; rewrite <- H2; rewrite in_out_UP'_inverse; eauto. - exact (proj2_sig _). - clear H2; rename H3 into SubV_n. - unfold isVI; unfold eval, mfold in SubV_n. - generalize (SV_invertVI _ SubV_m _ Eval_m). - generalize (SV_invertVI _ SubV_n _ Eval_n). - simpl; unfold beval at 1; unfold beval at 1; unfold evalR, Names.Exp; intros. - rewrite H3, H2. - unfold project, vi, vi'; simpl; repeat rewrite out_in_fmap; - repeat rewrite wf_functor; repeat rewrite prj_inj; - repeat rewrite wf_functor; simpl. - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. - unfold isBot; rewrite Eval_m. - caseEq (project (G := BotValue) (vi n1)). - destruct b; generalize (inj_prj _ _ H3); intro. - assert (vi n1 = bot _) by - (unfold vi, vi', bot, bot', inject' at -1; rewrite <- H4; - rewrite in_out_UP'_inverse; eauto with typeclass_instances). - unfold vi, bot in H5. - elimtype False; eapply (inject_discriminate Dis_VI_Bot _ _ H5). - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP m0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma))). - destruct b. - apply inject_i; constructor; reflexivity. - generalize (H (exist _ n n_UP') _ _ _ H0 H1) as SubV_n; simpl; intros. - caseEq (project (G := NatValue) + (exist Universal_Property'_fold n n_UP') gamma'))). + destruct n3. + generalize (inj_prj _ _ H5); rename H5 into H5'; intros. + assert (proj1_sig + (boundedFix_UP n0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold m m_UP') gamma') = vi n2) as Eval_m' by + (unfold vi, vi', inject'; rewrite <- H5; + rewrite in_out_UP'_inverse; unfold eval, mfold; eauto; + exact (proj2_sig _)). + unfold beval in SubV_m. + generalize (inj_prj _ _ H6); rename H6 into H6'; intros. + assert (proj1_sig + (boundedFix_UP n0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold n n_UP') gamma') = vi n3) as Eval_n'. + unfold vi, vi', inject'. + (unfold vi, vi', inject'; rewrite <- H6; + rewrite in_out_UP'_inverse; unfold eval, mfold; eauto; + exact (proj2_sig _)). + destruct (SV_invertVI' _ SubV_n _ Eval_n') as [n_eq_vi | n_eq_bot]; + simpl in *|-. + unfold beval, mfold, evalR, Names.Exp in n_eq_vi; rewrite n_eq_vi in H2. + unfold vi, project, inject in H2; simpl in H2; rewrite + out_in_fmap in H2. + rewrite fmap_fusion in H2; rewrite wf_functor in H2; simpl in H2. + rewrite (prj_inj _ ) in H2; discriminate. + unfold beval, mfold, evalR, Names.Exp in n_eq_bot; rewrite n_eq_bot in H4. + unfold bot, project, inject in H4; simpl in H4; rewrite out_in_fmap in H4. + rewrite fmap_fusion, wf_functor in H4; simpl in H4. + rewrite (prj_inj _ ) in H4; discriminate. + caseEq (project (G := BotValue) + (proj1_sig + (boundedFix_UP n0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold m m_UP') gamma'))). + destruct b. + generalize (inj_prj _ _ H7); rename H7 into H7'; intros. + assert (proj1_sig + (beval _ _ n0 (exist Universal_Property'_fold m m_UP') gamma') = bot _ ) as Eval_m' by + (apply (f_equal (in_t_UP' _ _)) in H7; apply (f_equal (@proj1_sig _ _)) in H7; + rewrite in_out_UP'_inverse in H7; [apply H7 | exact (proj2_sig _)]). + generalize (SV_invertBot _ SV _ _ SubV_m Eval_m'); simpl; intro H8; + unfold beval, mfold, evalR, Names.Exp in H8; rewrite H8 in Eval_m. + elimtype False; eapply (inject_discriminate Dis_VI_Bot (VI _ n1)); eauto. + caseEq (project (G := BotValue) (proj1_sig (boundedFix_UP n0 f_algebra (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma'))). - destruct n2. - caseEq (project (G := NatValue) + (exist Universal_Property'_fold n n_UP') gamma'))). + destruct b. + generalize (inj_prj _ _ H8); rename H8 into H8'; intros. + assert (proj1_sig + (beval _ _ n0 (exist Universal_Property'_fold n n_UP') gamma') = bot _ ) as Eval_n' by + (apply (f_equal (in_t_UP' _ _)) in H8; apply (f_equal (@proj1_sig _ _)) in H8; + rewrite in_out_UP'_inverse in H8; [apply H8 | exact (proj2_sig _)]). + generalize (SV_invertBot _ SV _ _ SubV_n Eval_n'); simpl; intro H9; + unfold beval, mfold, evalR, Names.Exp in H9. rewrite H9 in H4. + unfold project, bot, bot' in H4; simpl in H4; rewrite out_in_fmap in H4; + simpl in H4; repeat rewrite wf_functor in H4; simpl in H4; + rewrite prj_inj in H4; discriminate. + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. + caseEq (project (G := BotValue) + (proj1_sig + (boundedFix_UP n0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold m m_UP') gamma'))). + destruct b. + unfold project in H6. + apply inj_prj in H6; apply (f_equal (in_t_UP' _ _)) in H6; + apply (f_equal (@proj1_sig _ _)) in H6. + rewrite in_out_UP'_inverse in H6; simpl. + generalize (SV_invertBot _ SV _ _ SubV_m H6); simpl; intro. + unfold beval, evalR, Names.Exp in H7; rewrite H7 in Eval_m. + elimtype False; eapply (inject_discriminate Dis_VI_Bot (VI _ n1)); eauto. + exact (proj2_sig _). + caseEq (project (G := BotValue) + (proj1_sig + (boundedFix_UP n0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold n n_UP') gamma'))). + destruct b. + unfold project in H7. + apply inj_prj in H7; apply (f_equal (in_t_UP' _ _)) in H7; + apply (f_equal (@proj1_sig _ _)) in H7. + rewrite in_out_UP'_inverse in H7; simpl. + generalize (SV_invertBot _ SV _ _ SubV_n H7); simpl; intro. + unfold beval, evalR, Names.Exp in H8; rewrite H8 in H4. + unfold project, bot, bot' in H4; simpl in H4; rewrite out_in_fmap in H4; + simpl in H4; repeat rewrite wf_functor in H4; simpl in H4; + rewrite prj_inj in H4; discriminate. + exact (proj2_sig _). + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. + unfold isVI, evalR, Names.Exp; rewrite H2. + unfold isBot. + caseEq (project (G := BotValue) + (proj1_sig + (boundedFix_UP m0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold m m_UP') gamma))). + destruct b. + apply inj_prj in H3; apply (f_equal (in_t_UP' _ _)) in H3; + apply (f_equal (@proj1_sig _ _)) in H3. + assert (proj1_sig + (boundedFix_UP m0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold m m_UP') gamma) = bot _) as Eval_m. + unfold bot, bot', inject'; rewrite <- H3; rewrite in_out_UP'_inverse; eauto. + exact (proj2_sig _). + apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; eauto. + caseEq (project (G := BotValue) + (proj1_sig + (boundedFix_UP m0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold n n_UP') gamma))). + destruct b. + apply inj_prj in H4; apply (f_equal (in_t_UP' _ _)) in H4; + apply (f_equal (@proj1_sig _ _)) in H4. + assert (proj1_sig + (boundedFix_UP m0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold n n_UP') gamma) = bot _) as Eval_n. + unfold bot, bot', inject'; rewrite <- H4; rewrite in_out_UP'_inverse; eauto. + exact (proj2_sig _). + apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; eauto. + caseEq (project (G := BotValue) (proj1_sig (boundedFix_UP n0 f_algebra (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma'))). - destruct n3. - generalize (inj_prj _ _ H5); rename H5 into H5'; intros. - assert (proj1_sig - (boundedFix_UP n0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma') = vi n2) as Eval_m' by - (unfold vi, vi', inject'; rewrite <- H5; - rewrite in_out_UP'_inverse; unfold eval, mfold; eauto; - exact (proj2_sig _)). - unfold beval in SubV_m. - generalize (inj_prj _ _ H6); rename H6 into H6'; intros. - assert (proj1_sig + (exist Universal_Property'_fold n n_UP') gamma))). + rename H5 into Eval_n. + unfold isVI; unfold eval, mfold in Eval_n. + apply inj_prj in Eval_n; apply (f_equal (in_t_UP' _ _)) in Eval_n; + apply (f_equal (@proj1_sig _ _)) in Eval_n. + rewrite in_out_UP'_inverse in Eval_n. + caseEq (project (G := NatValue) + (proj1_sig (boundedFix_UP n0 f_algebra (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma') = vi n3) as Eval_n'. - unfold vi, vi', inject'. - (unfold vi, vi', inject'; rewrite <- H6; - rewrite in_out_UP'_inverse; unfold eval, mfold; eauto; - exact (proj2_sig _)). - destruct (SV_invertVI' _ SubV_n _ Eval_n') as [n_eq_vi | n_eq_bot]; - simpl in *|-. - unfold beval, mfold, evalR, Names.Exp in n_eq_vi; rewrite n_eq_vi in H2. - unfold vi, project, inject in H2; simpl in H2; rewrite - out_in_fmap in H2. - rewrite fmap_fusion in H2; rewrite wf_functor in H2; simpl in H2. - rewrite (prj_inj _ ) in H2; discriminate. - unfold beval, mfold, evalR, Names.Exp in n_eq_bot; rewrite n_eq_bot in H4. - unfold bot, project, inject in H4; simpl in H4; rewrite out_in_fmap in H4. - rewrite fmap_fusion, wf_functor in H4; simpl in H4. - rewrite (prj_inj _ ) in H4; discriminate. - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP n0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma'))). - destruct b. - generalize (inj_prj _ _ H7); rename H7 into H7'; intros. - assert (proj1_sig - (beval _ _ n0 (exist Universal_Property'_fold m m_UP') gamma') = bot _ ) as Eval_m' by - (apply (f_equal (in_t_UP' _ _)) in H7; apply (f_equal (@proj1_sig _ _)) in H7; - rewrite in_out_UP'_inverse in H7; [apply H7 | exact (proj2_sig _)]). - generalize (SV_invertBot _ SV _ _ SubV_m Eval_m'); simpl; intro H8; - unfold beval, mfold, evalR, Names.Exp in H8; rewrite H8 in Eval_m. - elimtype False; eapply (inject_discriminate Dis_VI_Bot (VI _ n1)); eauto. - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP n0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma'))). - destruct b. - generalize (inj_prj _ _ H8); rename H8 into H8'; intros. - assert (proj1_sig - (beval _ _ n0 (exist Universal_Property'_fold n n_UP') gamma') = bot _ ) as Eval_n' by - (apply (f_equal (in_t_UP' _ _)) in H8; apply (f_equal (@proj1_sig _ _)) in H8; - rewrite in_out_UP'_inverse in H8; [apply H8 | exact (proj2_sig _)]). - generalize (SV_invertBot _ SV _ _ SubV_n Eval_n'); simpl; intro H9; - unfold beval, mfold, evalR, Names.Exp in H9. rewrite H9 in H4. - unfold project, bot, bot' in H4; simpl in H4; rewrite out_in_fmap in H4; - simpl in H4; repeat rewrite wf_functor in H4; simpl in H4; - rewrite prj_inj in H4; discriminate. - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP n0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma'))). - destruct b. - unfold project in H6. - apply inj_prj in H6; apply (f_equal (in_t_UP' _ _)) in H6; - apply (f_equal (@proj1_sig _ _)) in H6. - rewrite in_out_UP'_inverse in H6; simpl. - generalize (SV_invertBot _ SV _ _ SubV_m H6); simpl; intro. - unfold beval, evalR, Names.Exp in H7; rewrite H7 in Eval_m. - elimtype False; eapply (inject_discriminate Dis_VI_Bot (VI _ n1)); eauto. - exact (proj2_sig _). - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP n0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma'))). - destruct b. - unfold project in H7. - apply inj_prj in H7; apply (f_equal (in_t_UP' _ _)) in H7; - apply (f_equal (@proj1_sig _ _)) in H7. - rewrite in_out_UP'_inverse in H7; simpl. - generalize (SV_invertBot _ SV _ _ SubV_n H7); simpl; intro. - unfold beval, evalR, Names.Exp in H8; rewrite H8 in H4. - unfold project, bot, bot' in H4; simpl in H4; rewrite out_in_fmap in H4; - simpl in H4; repeat rewrite wf_functor in H4; simpl in H4; - rewrite prj_inj in H4; discriminate. - exact (proj2_sig _). - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. - unfold isVI, evalR, Names.Exp; rewrite H2. - unfold isBot. - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP m0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma))). - destruct b. - apply inj_prj in H3; apply (f_equal (in_t_UP' _ _)) in H3; - apply (f_equal (@proj1_sig _ _)) in H3. - assert (proj1_sig - (boundedFix_UP m0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma) = bot _) as Eval_m. - unfold bot, bot', inject'; rewrite <- H3; rewrite in_out_UP'_inverse; eauto. - exact (proj2_sig _). - apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; eauto. - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP m0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma))). - destruct b. - apply inj_prj in H4; apply (f_equal (in_t_UP' _ _)) in H4; - apply (f_equal (@proj1_sig _ _)) in H4. - assert (proj1_sig - (boundedFix_UP m0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma) = bot _) as Eval_n. - unfold bot, bot', inject'; rewrite <- H4; rewrite in_out_UP'_inverse; eauto. - exact (proj2_sig _). - apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; eauto. - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP n0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma))). - rename H5 into Eval_n. - unfold isVI; unfold eval, mfold in Eval_n. - apply inj_prj in Eval_n; apply (f_equal (in_t_UP' _ _)) in Eval_n; - apply (f_equal (@proj1_sig _ _)) in Eval_n. - rewrite in_out_UP'_inverse in Eval_n. - caseEq (project (G := NatValue) + (exist Universal_Property'_fold m m_UP') gamma'))). + generalize (H (exist _ m m_UP') _ _ _ H0 H1) as SubV_m; intros. + destruct n1. + apply inj_prj in H5; apply (f_equal (in_t_UP' _ _)) in H5; + apply (f_equal (@proj1_sig _ _)) in H5; + rewrite in_out_UP'_inverse in H5; + unfold beval, evalR, Names.Exp in SubV_m, H5. + destruct (SV_invertVI' _ SubV_m _ H5); simpl in H6. + rewrite H6 in H2; unfold project, vi, vi' in H2; simpl in H2. + rewrite out_in_fmap in H2; repeat rewrite wf_functor in H2. + rewrite prj_inj in H2; discriminate. + rewrite H6 in H3; unfold project, bot, bot' in H3; simpl in H3. + rewrite out_in_fmap in H3; repeat rewrite wf_functor in H3. + rewrite prj_inj in H3; discriminate. + exact (proj2_sig _). + caseEq (project (G := BotValue) (proj1_sig (boundedFix_UP n0 f_algebra (fun _ : Env (Names.Value V) => bot' V) (exist Universal_Property'_fold m m_UP') gamma'))). - generalize (H (exist _ m m_UP') _ _ _ H0 H1) as SubV_m; intros. - destruct n1. - apply inj_prj in H5; apply (f_equal (in_t_UP' _ _)) in H5; - apply (f_equal (@proj1_sig _ _)) in H5; - rewrite in_out_UP'_inverse in H5; - unfold beval, evalR, Names.Exp in SubV_m, H5. - destruct (SV_invertVI' _ SubV_m _ H5); simpl in H6. - rewrite H6 in H2; unfold project, vi, vi' in H2; simpl in H2. - rewrite out_in_fmap in H2; repeat rewrite wf_functor in H2. - rewrite prj_inj in H2; discriminate. - rewrite H6 in H3; unfold project, bot, bot' in H3; simpl in H3. - rewrite out_in_fmap in H3; repeat rewrite wf_functor in H3. - rewrite prj_inj in H3; discriminate. - exact (proj2_sig _). - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP n0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma'))). - unfold evalR, Names.Exp in Eval_n. - destruct b0. - apply inj_prj in H6; apply (f_equal (in_t_UP' _ _)) in H6; - apply (f_equal (@proj1_sig _ _)) in H6; - rewrite in_out_UP'_inverse in H6. - generalize (H (exist _ m m_UP') _ _ _ H0 H1) as SubV_m; intros. - unfold beval, evalR, Names.Exp in SubV_m, H6. - generalize (SV_invertBot _ _ _ _ SubV_m H6); simpl; - intros; rewrite H7 in H3. - unfold project, bot, bot' in H3; simpl in H3. - rewrite out_in_fmap in H3; repeat rewrite wf_functor in H3. - rewrite prj_inj in H3; discriminate. - exact (proj2_sig _). - caseEq (project (G := BotValue) (proj1_sig - (boundedFix_UP n0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma'))). - destruct b0. - apply inj_prj in H7; apply (f_equal (in_t_UP' _ _)) in H7; - apply (f_equal (@proj1_sig _ _)) in H7; - rewrite in_out_UP'_inverse in H7. - generalize (H (exist _ n n_UP') _ _ _ H0 H1) as SubV_n; intros. - unfold beval, evalR, Names.Exp in SubV_n, H7. - generalize (SV_invertBot _ _ _ _ SubV_n H7); simpl; - intros; rewrite H8 in H4. - unfold project, bot, bot' in H4; simpl in H4. - rewrite out_in_fmap in H4; repeat rewrite wf_functor in H4. - rewrite prj_inj in H4; discriminate. - exact (proj2_sig _). - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. - exact (proj2_sig _). - caseEq (project (G := NatValue) - (proj1_sig + unfold evalR, Names.Exp in Eval_n. + destruct b0. + apply inj_prj in H6; apply (f_equal (in_t_UP' _ _)) in H6; + apply (f_equal (@proj1_sig _ _)) in H6; + rewrite in_out_UP'_inverse in H6. + generalize (H (exist _ m m_UP') _ _ _ H0 H1) as SubV_m; intros. + unfold beval, evalR, Names.Exp in SubV_m, H6. + generalize (SV_invertBot _ _ _ _ SubV_m H6); simpl; + intros; rewrite H7 in H3. + unfold project, bot, bot' in H3; simpl in H3. + rewrite out_in_fmap in H3; repeat rewrite wf_functor in H3. + rewrite prj_inj in H3; discriminate. + exact (proj2_sig _). + caseEq (project (G := BotValue) (proj1_sig (boundedFix_UP n0 f_algebra (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma'))). - destruct n1. - generalize (H (exist _ m m_UP') _ _ _ H0 H1) as SubV_m; intros. - apply inj_prj in H6; apply (f_equal (in_t_UP' _ _)) in H6; - apply (f_equal (@proj1_sig _ _)) in H6; - rewrite in_out_UP'_inverse in H6; - unfold beval, evalR, Names.Exp in SubV_m, H6. - destruct (SV_invertVI' _ SubV_m _ H6); simpl in H7. - rewrite H7 in H2; unfold project, vi, vi' in H2; simpl in H2. - rewrite out_in_fmap in H2; repeat rewrite wf_functor in H2. - rewrite prj_inj in H2; discriminate. - rewrite H7 in H3; unfold project, bot, bot' in H3; simpl in H3. - rewrite out_in_fmap in H3; repeat rewrite wf_functor in H3. - rewrite prj_inj in H3; discriminate. - exact (proj2_sig _). - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP n0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold m m_UP') gamma'))). - destruct b. - generalize (H (exist _ m m_UP') _ _ _ H0 H1) as SubV_m; intros. - apply inj_prj in H7; apply (f_equal (in_t_UP' _ _)) in H7; - apply (f_equal (@proj1_sig _ _)) in H7; - rewrite in_out_UP'_inverse in H7; - unfold beval, evalR, Names.Exp in SubV_m, H7. - generalize (SV_invertBot _ _ _ _ SubV_m H7); simpl; - intros. - rewrite H8 in H3; unfold project, bot, bot' in H3; simpl in H3. - rewrite out_in_fmap in H3; repeat rewrite wf_functor in H3. - rewrite prj_inj in H3; discriminate. - exact (proj2_sig _). - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP n0 f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold n n_UP') gamma'))). - destruct b. - generalize (H (exist _ n n_UP') _ _ _ H0 H1) as SubV_n; intros. - apply inj_prj in H8; apply (f_equal (in_t_UP' _ _)) in H8; - apply (f_equal (@proj1_sig _ _)) in H8; - rewrite in_out_UP'_inverse in H8; - unfold beval, evalR, Names.Exp in SubV_n, H8. - generalize (SV_invertBot _ _ _ _ SubV_n H8); simpl; - intros. - rewrite H9 in H4; unfold project, bot, bot' in H4; simpl in H4. - rewrite out_in_fmap in H4; repeat rewrite wf_functor in H4. - rewrite prj_inj in H4; discriminate. - exact (proj2_sig _). - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. - Qed. - - Lemma project_bot_bot : project (F := V) (G := BotValue) (bot _) = Some (Bot _). - Proof. - intros; unfold project, bot; simpl; rewrite out_in_fmap. - repeat rewrite wf_functor; simpl; unfold Bot_fmap. - rewrite prj_inj; reflexivity. - Qed. - - Global Instance Arith_eval_continuous_Exp : - PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V F SV))) Arith. - Proof. - constructor; unfold Algebra; intros. - eapply ind_alg_Arith. - apply eval_continuous_Exp_H. - apply eval_continuous_Exp_H0. - assumption. - Defined. - - Lemma WF_ind_alg_Arith (Name : Set) + (exist Universal_Property'_fold n n_UP') gamma'))). + destruct b0. + apply inj_prj in H7; apply (f_equal (in_t_UP' _ _)) in H7; + apply (f_equal (@proj1_sig _ _)) in H7; + rewrite in_out_UP'_inverse in H7. + generalize (H (exist _ n n_UP') _ _ _ H0 H1) as SubV_n; intros. + unfold beval, evalR, Names.Exp in SubV_n, H7. + generalize (SV_invertBot _ _ _ _ SubV_n H7); simpl; + intros; rewrite H8 in H4. + unfold project, bot, bot' in H4; simpl in H4. + rewrite out_in_fmap in H4; repeat rewrite wf_functor in H4. + rewrite prj_inj in H4; discriminate. + exact (proj2_sig _). + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. + exact (proj2_sig _). + caseEq (project (G := NatValue) + (proj1_sig + (boundedFix_UP n0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold m m_UP') gamma'))). + destruct n1. + generalize (H (exist _ m m_UP') _ _ _ H0 H1) as SubV_m; intros. + apply inj_prj in H6; apply (f_equal (in_t_UP' _ _)) in H6; + apply (f_equal (@proj1_sig _ _)) in H6; + rewrite in_out_UP'_inverse in H6; + unfold beval, evalR, Names.Exp in SubV_m, H6. + destruct (SV_invertVI' _ SubV_m _ H6); simpl in H7. + rewrite H7 in H2; unfold project, vi, vi' in H2; simpl in H2. + rewrite out_in_fmap in H2; repeat rewrite wf_functor in H2. + rewrite prj_inj in H2; discriminate. + rewrite H7 in H3; unfold project, bot, bot' in H3; simpl in H3. + rewrite out_in_fmap in H3; repeat rewrite wf_functor in H3. + rewrite prj_inj in H3; discriminate. + exact (proj2_sig _). + caseEq (project (G := BotValue) + (proj1_sig + (boundedFix_UP n0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold m m_UP') gamma'))). + destruct b. + generalize (H (exist _ m m_UP') _ _ _ H0 H1) as SubV_m; intros. + apply inj_prj in H7; apply (f_equal (in_t_UP' _ _)) in H7; + apply (f_equal (@proj1_sig _ _)) in H7; + rewrite in_out_UP'_inverse in H7; + unfold beval, evalR, Names.Exp in SubV_m, H7. + generalize (SV_invertBot _ _ _ _ SubV_m H7); simpl; + intros. + rewrite H8 in H3; unfold project, bot, bot' in H3; simpl in H3. + rewrite out_in_fmap in H3; repeat rewrite wf_functor in H3. + rewrite prj_inj in H3; discriminate. + exact (proj2_sig _). + caseEq (project (G := BotValue) + (proj1_sig + (boundedFix_UP n0 f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold n n_UP') gamma'))). + destruct b. + generalize (H (exist _ n n_UP') _ _ _ H0 H1) as SubV_n; intros. + apply inj_prj in H8; apply (f_equal (in_t_UP' _ _)) in H8; + apply (f_equal (@proj1_sig _ _)) in H8; + rewrite in_out_UP'_inverse in H8; + unfold beval, evalR, Names.Exp in SubV_n, H8. + generalize (SV_invertBot _ _ _ _ SubV_n H8); simpl; + intros. + rewrite H9 in H4; unfold project, bot, bot' in H4; simpl in H4. + rewrite out_in_fmap in H4; repeat rewrite wf_functor in H4. + rewrite prj_inj in H4; discriminate. + exact (proj2_sig _). + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. + Qed. + + Lemma project_bot_bot : project (F := V) (G := BotValue) (bot _) = Some (Bot _). + Proof. + intros; unfold project, bot; simpl; rewrite out_in_fmap. + repeat rewrite wf_functor; simpl; unfold Bot_fmap. + rewrite prj_inj; reflexivity. + Qed. + + Global Instance Arith_eval_continuous_Exp : + PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V F SV))) Arith. + Proof. + constructor; unfold Algebra; intros. + eapply ind_alg_Arith. + apply eval_continuous_Exp_H. + apply eval_continuous_Exp_H0. + assumption. + Defined. + + Lemma WF_ind_alg_Arith (Name : Set) (P : forall e : Fix F, Universal_Property'_fold e -> Prop) (H : forall n, UP'_P P (lit n)) (H0 : forall m n @@ -824,321 +850,329 @@ Section Arith. (forall a, inj (Sub_Functor := Sub_Arith_F) a = inj (A := (Fix F)) (Sub_Functor := Sub_Arith_F') a) -> WF_Ind (Name := Name) {| p_algebra := ind_alg_Arith P H H0|}. - constructor; intros. - simpl; unfold ind_alg_Arith; destruct e; simpl. - unfold lit; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. - unfold add; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. - Defined. + Proof. + constructor; intros. + simpl; unfold ind_alg_Arith; destruct e; simpl. + unfold lit; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. + unfold add; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. + Defined. - Context {eval_continuous_Exp_E : PAlgebra EC_ExpName - (sig (UP'_P (eval_continuous_Exp_P V F SV))) F}. - Context {WF_Ind_EC_Exp : WF_Ind eval_continuous_Exp_E}. + Context {eval_continuous_Exp_E : PAlgebra EC_ExpName + (sig (UP'_P (eval_continuous_Exp_P V F SV))) F}. + Context {WF_Ind_EC_Exp : WF_Ind eval_continuous_Exp_E}. (* ============================================== *) (* WELL-FORMED NAT VALUES *) (* ============================================== *) - Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. - Variable funWFV : iFunctor WFV. + Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. + Variable funWFV : iFunctor WFV. - (** Natrual Numbers are well-formed **) + (** Natrual Numbers are well-formed **) - Inductive WFValue_VI (WFV : WFValue_i D V -> Prop) : WFValue_i D V -> Prop := - | WFV_VI : forall n v T, - proj1_sig v = vi n -> - proj1_sig T = tnat -> - WFValue_VI WFV (mk_WFValue_i D V v T). + Inductive WFValue_VI (WFV : WFValue_i D V -> Prop) : WFValue_i D V -> Prop := + | WFV_VI : forall n v T, + proj1_sig v = vi n -> + proj1_sig T = tnat -> + WFValue_VI WFV (mk_WFValue_i D V v T). - Definition ind_alg_WFV_VI (P : WFValue_i D V -> Prop) - (H : forall n v T veq Teq, P (mk_WFValue_i _ _ v T)) - i (e : WFValue_VI P i) : P i := - match e in WFValue_VI _ i return P i with - | WFV_VI n v T veq Teq => H n v T veq Teq - end. + Definition ind_alg_WFV_VI (P : WFValue_i D V -> Prop) + (H : forall n v T veq Teq, P (mk_WFValue_i _ _ v T)) + i (e : WFValue_VI P i) : P i := + match e in WFValue_VI _ i return P i with + | WFV_VI n v T veq Teq => H n v T veq Teq + end. - Definition WFV_VI_ifmap (A B : WFValue_i D V -> Prop) i (f : forall i, A i -> B i) - (WFV_a : WFValue_VI A i) : WFValue_VI B i := - match WFV_a in (WFValue_VI _ s) return (WFValue_VI B s) - with - | WFV_VI n v T veq Teq => WFV_VI B n v T veq Teq - end. + Definition WFV_VI_ifmap (A B : WFValue_i D V -> Prop) i (f : forall i, A i -> B i) + (WFV_a : WFValue_VI A i) : WFValue_VI B i := + match WFV_a in (WFValue_VI _ s) return (WFValue_VI B s) + with + | WFV_VI n v T veq Teq => WFV_VI B n v T veq Teq + end. - Global Instance iFun_WFV_VI : iFunctor WFValue_VI. - constructor 1 with (ifmap := WFV_VI_ifmap). - destruct a; simpl; intros; reflexivity. - destruct a; simpl; intros; reflexivity. - Defined. - - Variable Sub_WFV_VI_WFV : Sub_iFunctor WFValue_VI WFV. - - Global Instance WFV_proj1_a_VI : - iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFValue_VI. - econstructor; intros. - unfold iAlgebra; intros; unfold WFV_proj1_a_P. - inversion H; subst; simpl; intros. - apply (inject_i (subGF := Sub_WFV_VI_WFV)); econstructor; simpl; eauto. - rewrite H3; eauto. - Defined. - - Global Instance WFV_proj1_b_VI : - iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFValue_VI. - econstructor; intros. - unfold iAlgebra; intros; unfold WFV_proj1_b_P. - inversion H; subst; simpl; intros. - apply (inject_i (subGF := Sub_WFV_VI_WFV)); econstructor; simpl; eauto. - rewrite H3; eauto. - Defined. - - (* Inversion principles for Well-formed natural numbers. *) - Definition WF_invertVI_P (i : WFValue_i D V) := - proj1_sig (wfv_b _ _ i) = tnat -> - WFValue_VI (iFix WFV) i \/ (proj1_sig (wfv_a D V i) = bot V). - - Inductive WF_invertVI_Name := wfv_invertvi_name. - Context {WF_invertVI_WFV : - iPAlgebra WF_invertVI_Name WF_invertVI_P WFV}. - - Global Instance WF_invertVI_VI : - iPAlgebra WF_invertVI_Name WF_invertVI_P WFValue_VI. - econstructor; intros. - unfold iAlgebra; intros; unfold WF_invertVI_P. - inversion H; subst; simpl; intros. - left; econstructor; eassumption. - Defined. - - Global Instance WF_invertVI_Bot : - iPAlgebra WF_invertVI_Name WF_invertVI_P (WFValue_Bot _ _). - econstructor; intros. - unfold iAlgebra; intros; unfold WF_invertVI_P. - inversion H; subst; simpl; intros. - inversion H; subst; rewrite H3; right; reflexivity. - Defined. - - Definition WF_invertVI := ifold_ WFV _ (ip_algebra (iPAlgebra := WF_invertVI_WFV)). - - Context {WFV_proj1_a_WFV : - iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFV}. - Context {WFV_proj1_b_WFV : - iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFV}. - - Lemma Arith_eval_Soundness_H - (typeof_R eval_R : Set) typeof_rec eval_rec - {eval_F' : FAlgebra EvalName eval_R (evalR V) F} - {WF_eval_F' : @WF_FAlgebra EvalName _ _ Arith F - Sub_Arith_F (MAlgebra_eval_Arith _) (eval_F')} : - forall n : nat, - forall gamma'' : Env (Names.Value V), - forall T : Names.DType D, - Arith_typeof typeof_R typeof_rec (Lit _ n) = Some T -> - WFValueC D V WFV (Arith_eval eval_R eval_rec (Lit _ n) gamma'') T. - intros n gamma'' T H4; intros. - apply (inject_i (subGF := Sub_WFV_VI_WFV)); econstructor; eauto. - simpl. - unfold vi, vi', inject; simpl; eauto. - unfold typeof, mfold, lit in H4; simpl in H4. - injection H4; intros; subst. - reflexivity. - Defined. - - Lemma Arith_eval_Soundness_H0 - (typeof_R eval_R : Set) typeof_rec eval_rec - {eval_F' : FAlgebra EvalName eval_R (evalR V) F} - {WF_eval_F' : @WF_FAlgebra EvalName _ _ Arith F - Sub_Arith_F (MAlgebra_eval_Arith _) (eval_F')} : - forall (a b : typeof_R) (a' b' : eval_R), - forall gamma'' : Env (Names.Value V), - (forall T : Names.DType D, - typeof_rec a = Some T -> - WFValueC D V WFV (eval_rec a' gamma'') T) -> - (forall T : Names.DType D, - typeof_rec b = Some T -> - WFValueC D V WFV (eval_rec b' gamma'') T) -> - forall T : Names.DType D, - Arith_typeof typeof_R typeof_rec (Add _ a b) = Some T -> - WFValueC D V WFV (Arith_eval eval_R eval_rec (Add _ a' b') gamma'') T. - simpl; intros a b a' b' gamma'' IH_a IH_b T H4. - caseEq (typeof_rec a); intros; rename H into typeof_a; - unfold typeofR in typeof_a, H4; rewrite typeof_a in H4; - try discriminate. - caseEq (typeof_rec b); intros; rename H into typeof_b; - unfold typeofR in typeof_b, H4; rewrite typeof_b in H4; - try discriminate. - caseEq (isTNat (proj1_sig d)); intros; rename H into d_eq; rewrite - d_eq in H4; try discriminate. - caseEq (isTNat (proj1_sig d0)); intros; rename H into d0_eq; rewrite - d0_eq in H4; try discriminate. - injection H4; intros; subst; clear H4. - unfold isTNat in d_eq, d0_eq. - caseEq (project (proj1_sig d)); intros; rewrite H in d_eq; - try discriminate; clear d_eq; rename H into d_eq; destruct a0. - caseEq (project (proj1_sig d0)); intros; rewrite H in d0_eq; - try discriminate; clear d0_eq; rename H into d0_eq; destruct a0. - apply project_inject in d_eq; apply project_inject in d0_eq; - eauto with typeclass_instances. - generalize (IH_a _ typeof_a) as WF_a; - generalize (IH_b _ typeof_b) as WF_b; intros. - unfold WFValueC in *|-*. - destruct (WF_invertVI _ WF_a d_eq) as [beval_a' | beval_a']; - inversion beval_a'; subst. - rewrite H1; unfold isVI, project, vi, vi', inject'; simpl; - rewrite out_in_fmap; repeat rewrite wf_functor; simpl; rewrite prj_inj. - destruct (WF_invertVI _ WF_b d0_eq) as [beval_b' | beval_b']; - inversion beval_b'; subst. - rewrite H3; unfold isVI, project, vi, vi', inject'; simpl; - rewrite out_in_fmap; repeat rewrite wf_functor; simpl; rewrite prj_inj. - apply (inject_i (subGF := Sub_WFV_VI_WFV)); econstructor; eauto. - simpl; rewrite wf_functor; simpl; eauto. - unfold vi, vi', inject'; simpl; eauto; - rewrite wf_functor; simpl; reflexivity. - rewrite H0; unfold bot, isVI, project, inject, inject'; simpl; - rewrite out_in_fmap; repeat rewrite wf_functor; simpl; unfold Bot_fmap. - caseEq (prj (Sub_Functor := Sub_NatValue_V) (A:= (sig (@Universal_Property'_fold V _))) - (inj (Bot (sig Universal_Property'_fold)))). - elimtype False; eapply (inject_discriminate Dis_VI_Bot n0). - unfold inject; simpl; apply inj_prj in H; erewrite <- H; reflexivity. - caseEq (isBot V (in_t (inj (VI (Fix V) n)))). - simpl in beval_b'. - apply sym_eq in H0; apply sym_eq in d0_eq. - generalize (WFV_proj1_a D V WFV _ _ WF_b _ _ H0). - simpl; intros WF_b'; generalize (WFV_proj1_b D V WFV _ _ WF_b' _ _ d0_eq); simpl. - assert (exist Universal_Property'_fold (bot V) (UP'_bot V) = bot' V) by - (unfold bot, UP'_bot; destruct bot'; reflexivity). - assert (exist Universal_Property'_fold tnat UP'_tnat = tnat') by - (unfold tnat, UP'_tnat; destruct tnat'; reflexivity). - unfold tnat, tnat', inject' at 1 in H5. - unfold inject. - rewrite H5, H4; auto. - unfold isBot, project; simpl; rewrite out_in_fmap; - repeat rewrite wf_functor; simpl; unfold Bot_fmap; - rewrite prj_inj. - simpl in beval_b'. - apply sym_eq in H0; apply sym_eq in d0_eq. - unfold eval in WF_b; generalize (WFV_proj1_a D V WFV _ _ WF_b _ _ H0). - simpl; intros WF_b'; generalize (WFV_proj1_b D V WFV _ _ WF_b' _ _ d0_eq); simpl. - assert (exist Universal_Property'_fold (bot V) (UP'_bot V) = bot' V) by - (unfold bot, UP'_bot; destruct bot'; reflexivity). - assert (exist Universal_Property'_fold tnat UP'_tnat = tnat') by - (unfold tnat, UP'_tnat; destruct tnat'; reflexivity). - unfold tnat, tnat', inject' at 1 in H5. - unfold inject. - rewrite H5, H4; auto. - caseEq (isVI (proj1_sig (eval_rec a' gamma''))). - unfold isVI in H; rewrite H0 in H. - unfold bot, isVI, project, inject, inject' in H; simpl in H; - rewrite out_in_fmap in H; repeat rewrite wf_functor in H; simpl in H; - unfold Bot_fmap in H. - caseEq (prj (Sub_Functor := Sub_NatValue_V) (A:= (sig (@Universal_Property'_fold V _))) - (inj (Bot (sig Universal_Property'_fold)))). - elimtype False; eapply (inject_discriminate Dis_VI_Bot n0); - apply inj_prj in H1; unfold inject; rewrite <- H1; reflexivity. - rewrite H1 in H; discriminate. - rewrite H0. - unfold bot, isBot, project, inject; simpl; rewrite out_in_fmap; - repeat rewrite wf_functor; simpl; unfold Bot_fmap; simpl. - simpl in beval_a'. - apply sym_eq in H0; apply sym_eq in d_eq. - generalize (WFV_proj1_a D V WFV _ _ WF_a _ _ H0). - simpl; intros WF_a'; generalize (WFV_proj1_b D V WFV _ _ WF_a' _ _ d_eq); simpl. - assert (exist Universal_Property'_fold (bot V) (UP'_bot V) = bot' V) by - (unfold bot, UP'_bot; destruct bot'; reflexivity). - assert (exist Universal_Property'_fold tnat UP'_tnat = tnat') by - (unfold tnat, UP'_tnat; destruct tnat'; reflexivity). - unfold tnat, tnat', inject' at 1 in H2. - unfold inject. - rewrite H2, H1, prj_inj; auto. - exact (proj2_sig d0). - exact (proj2_sig d0). - exact (proj2_sig d). - exact (proj2_sig d0). - Defined. - - Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) F}. - Context {WF_typeof_F : forall T, @WF_FAlgebra TypeofName T _ _ _ - Sub_Arith_F (MAlgebra_typeof_Arith T) (Typeof_F _)}. - Context {WF_Value_continous_alg : - iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SV}. - - Global Instance Arith_eval_Soundness_alg - (P_bind : Set) - (P : P_bind -> Env Value -> Prop) - (E' : Set -> Set) - {Fun_E' : Functor E'} - {Sub_Arith_E' : Arith :<: E'} - {WF_Fun_E' : WF_Functor _ _ Sub_Arith_E' _ _} - {Typeof_E' : forall T, FAlgebra TypeofName T (typeofR D) E'} - {WF_typeof_E' : forall T, @WF_FAlgebra TypeofName T _ _ _ - Sub_Arith_E' (MAlgebra_typeof_Arith T) (Typeof_E' _)} - (pb : P_bind) - (eval_rec : Exp -> evalR V) - (typeof_rec : UP'_F E' -> typeofR D) - : - PAlgebra eval_Soundness_alg_Name (sig (UP'_P2 (@eval_alg_Soundness_P D _ V _ _ _ WFV _ P - _ _ pb typeof_rec eval_rec (f_algebra (FAlgebra := Typeof_E' _ )) - (f_algebra (FAlgebra := eval_F))))) Arith. - Proof. - econstructor; unfold Algebra; intros. - eapply (ind2_alg_Arith (@eval_alg_Soundness_P D _ V _ F _ WFV _ P - _ _ pb typeof_rec eval_rec (f_algebra (FAlgebra := Typeof_E' _)) - (f_algebra (FAlgebra := eval_F)))); try eassumption; - unfold eval_alg_Soundness_P, UP'_P2; intros. - constructor. - exact (conj (proj2_sig (inject' (Lit _ n))) (proj2_sig (lit' n))). - unfold lit, lit', inject; simpl. - repeat rewrite out_in_fmap. - repeat rewrite wf_functor. - intros gamma'' WF_gamma'' IHa. - rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); - rewrite (wf_algebra (WF_FAlgebra := WF_typeof_E' _)); - simpl fmap; simpl f_algebra; unfold Arith_fmap. - intros. - eapply Arith_eval_Soundness_H. - apply WF_eval_F. - apply H0. - (* Add Case *) - destruct m as [m1 m2]; destruct n as [n1 n2]; - destruct IHm as [[UP'_m1 UP'_m2] IHm]; - destruct IHn as [[UP'_n1 UP'_n2] IHn]; simpl in *|-*. - constructor. - split; unfold inject; exact (proj2_sig _). - unfold inject; simpl; - repeat rewrite out_in_fmap; repeat rewrite wf_functor; simpl. - intros eval_rec_proj typeof_rec_proj gamma'' WF_gamma'' IHa. - rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); - rewrite (wf_algebra (WF_FAlgebra := WF_typeof_E' _)); - simpl fmap; simpl f_algebra; unfold Arith_fmap. - intros T; eapply Arith_eval_Soundness_H0. - apply WF_eval_F. - apply (IHa _ _ WF_gamma'' (_, exist _ _ UP'_m2)); simpl; - intros; apply (IHm eval_rec_proj typeof_rec_proj _ WF_gamma'' IHa); - intros; auto; rewrite <- (in_out_UP'_inverse _ _ m1); auto. - apply (IHa _ _ WF_gamma'' (_, exist _ _ UP'_n2)); simpl; - intros; apply (IHn eval_rec_proj typeof_rec_proj _ WF_gamma'' IHa); - intros; auto; rewrite <- (in_out_UP'_inverse _ _ n1); auto. - Defined. + Global Instance iFun_WFV_VI : iFunctor WFValue_VI. + Proof. + constructor 1 with (ifmap := WFV_VI_ifmap). + destruct a; simpl; intros; reflexivity. + destruct a; simpl; intros; reflexivity. + Defined. + + Variable Sub_WFV_VI_WFV : Sub_iFunctor WFValue_VI WFV. + + Global Instance WFV_proj1_a_VI : + iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFValue_VI. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WFV_proj1_a_P. + inversion H; subst; simpl; intros. + apply (inject_i (subGF := Sub_WFV_VI_WFV)); econstructor; simpl; eauto. + rewrite H3; eauto. + Defined. + + Global Instance WFV_proj1_b_VI : + iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFValue_VI. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WFV_proj1_b_P. + inversion H; subst; simpl; intros. + apply (inject_i (subGF := Sub_WFV_VI_WFV)); econstructor; simpl; eauto. + rewrite H3; eauto. + Defined. + + (* Inversion principles for Well-formed natural numbers. *) + Definition WF_invertVI_P (i : WFValue_i D V) := + proj1_sig (wfv_b _ _ i) = tnat -> + WFValue_VI (iFix WFV) i \/ (proj1_sig (wfv_a D V i) = bot V). + + Inductive WF_invertVI_Name := wfv_invertvi_name. + Context {WF_invertVI_WFV : + iPAlgebra WF_invertVI_Name WF_invertVI_P WFV}. + + Global Instance WF_invertVI_VI : + iPAlgebra WF_invertVI_Name WF_invertVI_P WFValue_VI. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WF_invertVI_P. + inversion H; subst; simpl; intros. + left; econstructor; eassumption. + Defined. + + Global Instance WF_invertVI_Bot : + iPAlgebra WF_invertVI_Name WF_invertVI_P (WFValue_Bot _ _). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WF_invertVI_P. + inversion H; subst; simpl; intros. + inversion H; subst; rewrite H3; right; reflexivity. + Defined. + + Definition WF_invertVI := ifold_ WFV _ (ip_algebra (iPAlgebra := WF_invertVI_WFV)). + + Context {WFV_proj1_a_WFV : + iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFV}. + Context {WFV_proj1_b_WFV : + iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFV}. + + Lemma Arith_eval_Soundness_H + (typeof_R eval_R : Set) typeof_rec eval_rec + {eval_F' : FAlgebra EvalName eval_R (evalR V) F} + {WF_eval_F' : @WF_FAlgebra EvalName _ _ Arith F + Sub_Arith_F (MAlgebra_eval_Arith _) (eval_F')} : + forall n : nat, + forall gamma'' : Env (Names.Value V), + forall T : Names.DType D, + Arith_typeof typeof_R typeof_rec (Lit _ n) = Some T -> + WFValueC D V WFV (Arith_eval eval_R eval_rec (Lit _ n) gamma'') T. + Proof. + intros n gamma'' T H4; intros. + apply (inject_i (subGF := Sub_WFV_VI_WFV)); econstructor; eauto. + simpl. + unfold vi, vi', inject; simpl; eauto. + unfold typeof, mfold, lit in H4; simpl in H4. + injection H4; intros; subst. + reflexivity. + Defined. + + Lemma Arith_eval_Soundness_H0 + (typeof_R eval_R : Set) typeof_rec eval_rec + {eval_F' : FAlgebra EvalName eval_R (evalR V) F} + {WF_eval_F' : @WF_FAlgebra EvalName _ _ Arith F + Sub_Arith_F (MAlgebra_eval_Arith _) (eval_F')} : + forall (a b : typeof_R) (a' b' : eval_R), + forall gamma'' : Env (Names.Value V), + (forall T : Names.DType D, + typeof_rec a = Some T -> + WFValueC D V WFV (eval_rec a' gamma'') T) -> + (forall T : Names.DType D, + typeof_rec b = Some T -> + WFValueC D V WFV (eval_rec b' gamma'') T) -> + forall T : Names.DType D, + Arith_typeof typeof_R typeof_rec (Add _ a b) = Some T -> + WFValueC D V WFV (Arith_eval eval_R eval_rec (Add _ a' b') gamma'') T. + Proof. + simpl; intros a b a' b' gamma'' IH_a IH_b T H4. + caseEq (typeof_rec a); intros; rename H into typeof_a; + unfold typeofR in typeof_a, H4; rewrite typeof_a in H4; + try discriminate. + caseEq (typeof_rec b); intros; rename H into typeof_b; + unfold typeofR in typeof_b, H4; rewrite typeof_b in H4; + try discriminate. + caseEq (isTNat (proj1_sig d)); intros; rename H into d_eq; rewrite + d_eq in H4; try discriminate. + caseEq (isTNat (proj1_sig d0)); intros; rename H into d0_eq; rewrite + d0_eq in H4; try discriminate. + injection H4; intros; subst; clear H4. + unfold isTNat in d_eq, d0_eq. + caseEq (project (proj1_sig d)); intros; rewrite H in d_eq; + try discriminate; clear d_eq; rename H into d_eq; destruct a0. + caseEq (project (proj1_sig d0)); intros; rewrite H in d0_eq; + try discriminate; clear d0_eq; rename H into d0_eq; destruct a0. + apply project_inject in d_eq; apply project_inject in d0_eq; + eauto with typeclass_instances. + generalize (IH_a _ typeof_a) as WF_a; + generalize (IH_b _ typeof_b) as WF_b; intros. + unfold WFValueC in *|-*. + destruct (WF_invertVI _ WF_a d_eq) as [beval_a' | beval_a']; + inversion beval_a'; subst. + rewrite H1; unfold isVI, project, vi, vi', inject'; simpl; + rewrite out_in_fmap; repeat rewrite wf_functor; simpl; rewrite prj_inj. + destruct (WF_invertVI _ WF_b d0_eq) as [beval_b' | beval_b']; + inversion beval_b'; subst. + rewrite H3; unfold isVI, project, vi, vi', inject'; simpl; + rewrite out_in_fmap; repeat rewrite wf_functor; simpl; rewrite prj_inj. + apply (inject_i (subGF := Sub_WFV_VI_WFV)); econstructor; eauto. + simpl; rewrite wf_functor; simpl; eauto. + unfold vi, vi', inject'; simpl; eauto; + rewrite wf_functor; simpl; reflexivity. + rewrite H0; unfold bot, isVI, project, inject, inject'; simpl; + rewrite out_in_fmap; repeat rewrite wf_functor; simpl; unfold Bot_fmap. + caseEq (prj (Sub_Functor := Sub_NatValue_V) (A:= (sig (@Universal_Property'_fold V _))) + (inj (Bot (sig Universal_Property'_fold)))). + elimtype False; eapply (inject_discriminate Dis_VI_Bot n0). + unfold inject; simpl; apply inj_prj in H; erewrite <- H; reflexivity. + caseEq (isBot V (in_t (inj (VI (Fix V) n)))). + simpl in beval_b'. + apply sym_eq in H0; apply sym_eq in d0_eq. + generalize (WFV_proj1_a D V WFV _ _ WF_b _ _ H0). + simpl; intros WF_b'; generalize (WFV_proj1_b D V WFV _ _ WF_b' _ _ d0_eq); simpl. + assert (exist Universal_Property'_fold (bot V) (UP'_bot V) = bot' V) by + (unfold bot, UP'_bot; destruct bot'; reflexivity). + assert (exist Universal_Property'_fold tnat UP'_tnat = tnat') by + (unfold tnat, UP'_tnat; destruct tnat'; reflexivity). + unfold tnat, tnat', inject' at 1 in H5. + unfold inject. + rewrite H5, H4; auto. + unfold isBot, project; simpl; rewrite out_in_fmap; + repeat rewrite wf_functor; simpl; unfold Bot_fmap; + rewrite prj_inj. + simpl in beval_b'. + apply sym_eq in H0; apply sym_eq in d0_eq. + unfold eval in WF_b; generalize (WFV_proj1_a D V WFV _ _ WF_b _ _ H0). + simpl; intros WF_b'; generalize (WFV_proj1_b D V WFV _ _ WF_b' _ _ d0_eq); simpl. + assert (exist Universal_Property'_fold (bot V) (UP'_bot V) = bot' V) by + (unfold bot, UP'_bot; destruct bot'; reflexivity). + assert (exist Universal_Property'_fold tnat UP'_tnat = tnat') by + (unfold tnat, UP'_tnat; destruct tnat'; reflexivity). + unfold tnat, tnat', inject' at 1 in H5. + unfold inject. + rewrite H5, H4; auto. + caseEq (isVI (proj1_sig (eval_rec a' gamma''))). + unfold isVI in H; rewrite H0 in H. + unfold bot, isVI, project, inject, inject' in H; simpl in H; + rewrite out_in_fmap in H; repeat rewrite wf_functor in H; simpl in H; + unfold Bot_fmap in H. + caseEq (prj (Sub_Functor := Sub_NatValue_V) (A:= (sig (@Universal_Property'_fold V _))) + (inj (Bot (sig Universal_Property'_fold)))). + elimtype False; eapply (inject_discriminate Dis_VI_Bot n0); + apply inj_prj in H1; unfold inject; rewrite <- H1; reflexivity. + rewrite H1 in H; discriminate. + rewrite H0. + unfold bot, isBot, project, inject; simpl; rewrite out_in_fmap; + repeat rewrite wf_functor; simpl; unfold Bot_fmap; simpl. + simpl in beval_a'. + apply sym_eq in H0; apply sym_eq in d_eq. + generalize (WFV_proj1_a D V WFV _ _ WF_a _ _ H0). + simpl; intros WF_a'; generalize (WFV_proj1_b D V WFV _ _ WF_a' _ _ d_eq); simpl. + assert (exist Universal_Property'_fold (bot V) (UP'_bot V) = bot' V) by + (unfold bot, UP'_bot; destruct bot'; reflexivity). + assert (exist Universal_Property'_fold tnat UP'_tnat = tnat') by + (unfold tnat, UP'_tnat; destruct tnat'; reflexivity). + unfold tnat, tnat', inject' at 1 in H2. + unfold inject. + rewrite H2, H1, prj_inj; auto. + exact (proj2_sig d0). + exact (proj2_sig d0). + exact (proj2_sig d). + exact (proj2_sig d0). + Defined. + + Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) F}. + Context {WF_typeof_F : forall T, @WF_FAlgebra TypeofName T _ _ _ + Sub_Arith_F (MAlgebra_typeof_Arith T) (Typeof_F _)}. + Context {WF_Value_continous_alg : + iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SV}. + + Global Instance Arith_eval_Soundness_alg + (P_bind : Set) + (P : P_bind -> Env Value -> Prop) + (E' : Set -> Set) + {Fun_E' : Functor E'} + {Sub_Arith_E' : Arith :<: E'} + {WF_Fun_E' : WF_Functor _ _ Sub_Arith_E' _ _} + {Typeof_E' : forall T, FAlgebra TypeofName T (typeofR D) E'} + {WF_typeof_E' : forall T, @WF_FAlgebra TypeofName T _ _ _ + Sub_Arith_E' (MAlgebra_typeof_Arith T) (Typeof_E' _)} + (pb : P_bind) + (eval_rec : Exp -> evalR V) + (typeof_rec : UP'_F E' -> typeofR D) + : + PAlgebra eval_Soundness_alg_Name (sig (UP'_P2 (@eval_alg_Soundness_P D _ V _ _ _ WFV _ P + _ _ pb typeof_rec eval_rec (f_algebra (FAlgebra := Typeof_E' _ )) + (f_algebra (FAlgebra := eval_F))))) Arith. + Proof. + econstructor; unfold Algebra; intros. + eapply (ind2_alg_Arith (@eval_alg_Soundness_P D _ V _ F _ WFV _ P + _ _ pb typeof_rec eval_rec (f_algebra (FAlgebra := Typeof_E' _)) + (f_algebra (FAlgebra := eval_F)))); try eassumption; + unfold eval_alg_Soundness_P, UP'_P2; intros. + constructor. + exact (conj (proj2_sig (inject' (Lit _ n))) (proj2_sig (lit' n))). + unfold lit, lit', inject; simpl. + repeat rewrite out_in_fmap. + repeat rewrite wf_functor. + intros gamma'' WF_gamma'' IHa. + rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); + rewrite (wf_algebra (WF_FAlgebra := WF_typeof_E' _)); + simpl fmap; simpl f_algebra; unfold Arith_fmap. + intros. + eapply Arith_eval_Soundness_H. + apply WF_eval_F. + apply H0. + (* Add Case *) + destruct m as [m1 m2]; destruct n as [n1 n2]; + destruct IHm as [[UP'_m1 UP'_m2] IHm]; + destruct IHn as [[UP'_n1 UP'_n2] IHn]; simpl in *|-*. + constructor. + split; unfold inject; exact (proj2_sig _). + unfold inject; simpl; + repeat rewrite out_in_fmap; repeat rewrite wf_functor; simpl. + intros eval_rec_proj typeof_rec_proj gamma'' WF_gamma'' IHa. + rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); + rewrite (wf_algebra (WF_FAlgebra := WF_typeof_E' _)); + simpl fmap; simpl f_algebra; unfold Arith_fmap. + intros T; eapply Arith_eval_Soundness_H0. + apply WF_eval_F. + apply (IHa _ _ WF_gamma'' (_, exist _ _ UP'_m2)); simpl; + intros; apply (IHm eval_rec_proj typeof_rec_proj _ WF_gamma'' IHa); + intros; auto; rewrite <- (in_out_UP'_inverse _ _ m1); auto. + apply (IHa _ _ WF_gamma'' (_, exist _ _ UP'_n2)); simpl; + intros; apply (IHn eval_rec_proj typeof_rec_proj _ WF_gamma'' IHa); + intros; auto; rewrite <- (in_out_UP'_inverse _ _ n1); auto. + Defined. End Arith. - Hint Extern 1 (iPAlgebra SV_invertVI_Name (SV_invertVI_P _) _) => - constructor; unfold iAlgebra; unfold SV_invertVI_P; intros i H n H0; - inversion H; subst; simpl in H0; revert H0; - match goal with H : proj1_sig ?v = _ |- proj1_sig ?v = _ -> _ => rewrite H end; intros; - elimtype False; apply (inject_discriminate _ _ _ H0). - - Hint Extern 1 (iPAlgebra SV_invertVI'_Name (SV_invertVI'_P _) _) => - constructor; unfold iAlgebra; unfold SV_invertVI'_P; intros i H n H0; - inversion H; subst; simpl in H0; revert H0; - match goal with H : proj1_sig ?v = _ |- proj1_sig ?v = _ -> _ => rewrite H end; intros; - elimtype False; apply (inject_discriminate _ _ _ H0). - - Hint Extern 5 (iPAlgebra WF_invertVI_Name (WF_invertVI_P _ _ _) _) => - constructor; unfold iAlgebra; intros i H; unfold WF_invertVI_P; - inversion H; simpl; - match goal with - eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ => - intro eq_H; rewrite eq_H in eq_H0; - elimtype False; first [apply (inject_discriminate _ _ _ eq_H0) | - apply sym_eq in eq_H0; apply (inject_discriminate _ _ _ eq_H0)] - end : typeclass_instances. +Hint Extern 1 (iPAlgebra SV_invertVI_Name (SV_invertVI_P _) _) => + constructor; unfold iAlgebra; unfold SV_invertVI_P; intros i H n H0; + inversion H; subst; simpl in H0; revert H0; + match goal with H : proj1_sig ?v = _ |- proj1_sig ?v = _ -> _ => rewrite H end; intros; + elimtype False; apply (inject_discriminate _ _ _ H0). + +Hint Extern 1 (iPAlgebra SV_invertVI'_Name (SV_invertVI'_P _) _) => + constructor; unfold iAlgebra; unfold SV_invertVI'_P; intros i H n H0; + inversion H; subst; simpl in H0; revert H0; + match goal with H : proj1_sig ?v = _ |- proj1_sig ?v = _ -> _ => rewrite H end; intros; + elimtype False; apply (inject_discriminate _ _ _ H0). + +Hint Extern 5 (iPAlgebra WF_invertVI_Name (WF_invertVI_P _ _ _) _) => + constructor; unfold iAlgebra; intros i H; unfold WF_invertVI_P; + inversion H; simpl; + match goal with + eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ => + intro eq_H; rewrite eq_H in eq_H0; + elimtype False; first [apply (inject_discriminate _ _ _ eq_H0) | + apply sym_eq in eq_H0; apply (inject_discriminate _ _ _ eq_H0)] + end : typeclass_instances. Hint Extern 0 => intros; match goal with @@ -1147,7 +1181,6 @@ Hint Extern 0 => eapply Arith_eval_Soundness_alg; eauto with typeclass_instances end : typeclass_instances. - (* *** Local Variables: *** *** coq-prog-args: ("-emacs-U" "-impredicative-set") *** diff --git a/Arith_Lambda.v b/Arith_Lambda.v index dd63720..4317ffc 100644 --- a/Arith_Lambda.v +++ b/Arith_Lambda.v @@ -106,27 +106,27 @@ Section Lambda_Arith. (* EQUIVALENCE OF ARITHMETIC EXPRESSIONS *) (* ============================================== *) - Inductive Arith_eqv (A B : Set) (C : eqv_i E A B -> Prop) : eqv_i E A B -> Prop := - | Lit_eqv : forall (gamma : Env _) gamma' n e e', - proj1_sig e = lit (E A) n -> - proj1_sig e' = lit (E B) n -> - Arith_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e') - | Add_eqv : forall (gamma : Env _) gamma' a b a' b' e e', - C (mk_eqv_i _ _ _ gamma gamma' a a') -> - C (mk_eqv_i _ _ _ gamma gamma' b b') -> - proj1_sig e = proj1_sig (add' (E _) a b) -> - proj1_sig e' = proj1_sig (add' (E _) a' b') -> - Arith_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e'). - - Lemma Arith_eqv_impl_NP_eqv : forall A B C i, - Arith_eqv A B C i -> NP_Functor_eqv E Arith A B C i. - intros; destruct H. - unfold lit in *; simpl in *. - constructor 1 with (np := fun D => Lit D n); auto. - econstructor 3 with (np := fun D => Add D); eauto. - simpl; congruence. - Defined. - + Inductive Arith_eqv (A B : Set) (C : eqv_i E A B -> Prop) : eqv_i E A B -> Prop := + | Lit_eqv : forall (gamma : Env _) gamma' n e e', + proj1_sig e = lit (E A) n -> + proj1_sig e' = lit (E B) n -> + Arith_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e') + | Add_eqv : forall (gamma : Env _) gamma' a b a' b' e e', + C (mk_eqv_i _ _ _ gamma gamma' a a') -> + C (mk_eqv_i _ _ _ gamma gamma' b b') -> + proj1_sig e = proj1_sig (add' (E _) a b) -> + proj1_sig e' = proj1_sig (add' (E _) a' b') -> + Arith_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e'). + + Lemma Arith_eqv_impl_NP_eqv : forall A B C i, + Arith_eqv A B C i -> NP_Functor_eqv E Arith A B C i. + Proof. + intros; destruct H. + unfold lit in *; simpl in *. + constructor 1 with (np := fun D => Lit D n); auto. + econstructor 3 with (np := fun D => Add D); eauto. + simpl; congruence. + Defined. End Lambda_Arith. diff --git a/Bool.v b/Bool.v index 48c85b4..f796e9a 100644 --- a/Bool.v +++ b/Bool.v @@ -12,13 +12,14 @@ Section Bool. (* The Boolean Type. *) Inductive BType (A : Set) : Set := - | TBool : BType A. + TBool : BType A. - Definition BType_fmap : forall (A B : Set) (f : A -> B), - BType A -> BType B := fun A B _ _ => TBool _. + Definition BType_fmap (A B : Set) (f : A -> B) : + BType A -> BType B := fun _ => TBool _. Global Instance BType_Functor : Functor BType := {| fmap := BType_fmap |}. + Proof. destruct a; reflexivity. (* fmap id *) destruct a; reflexivity. @@ -46,25 +47,26 @@ Section Bool. | TBot => exist _ _ H end. - Lemma WF_ind_alg_BType (Name : Set) + Lemma WF_ind_alg_BType (Name : Set) (P : forall e : Fix D, Universal_Property'_fold e -> Prop) (H : UP'_P P tbool) {Sub_BType_D' : BType :<: D} : (forall a, inj (Sub_Functor := Sub_BType_D) a = inj (A := Fix D) (Sub_Functor := Sub_BType_D') a) -> WF_Ind (Name := Name) {| p_algebra := ind_alg_BType P H|}. - constructor; intros. - simpl; unfold ind_alg_BType; destruct e; simpl. - unfold tbool; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. - Defined. + Proof. + constructor; intros. + simpl; unfold ind_alg_BType; destruct e; simpl. + unfold tbool; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. + Defined. (* Type Equality Section. *) Definition isTBool : Fix D -> bool := - fun typ => - match project typ with - | Some TBool => true - | None => false - end. + fun typ => + match project typ with + | Some TBool => true + | None => false + end. Definition BType_eq_DType (R : Set) (rec : R -> eq_DTypeR D) (e : BType R) : eq_DTypeR D := @@ -82,6 +84,7 @@ Section Bool. Global Instance PAlgebra_eq_DType_eq_BType : PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) BType. + Proof. constructor; unfold Algebra; intros. econstructor; unfold UP'_P; econstructor. unfold eq_DType_eq_P; intros. @@ -206,25 +209,25 @@ Section Bool. (* Typing Boolmetic Expressions. *) Definition Bool_typeof (R : Set) (rec : R -> typeofR D) - (e : Bool R) : typeofR D := - match e with - | BLit n => Some (inject' (TBool _)) - | If i t e => match (rec i) with - | Some TI => - match isTBool (proj1_sig TI) with - | true => match (rec t), (rec e) with - | Some TT, Some TE => - match eq_DType D (proj1_sig TT) TE with - | true => Some TT - | false => None - end - | _, _ => None - end - | false => None - end - | _ => None - end - end. + (e : Bool R) : typeofR D := + match e with + | BLit n => Some (inject' (TBool _)) + | If i t e => match (rec i) with + | Some TI => + match isTBool (proj1_sig TI) with + | true => match (rec t), (rec e) with + | Some TT, Some TE => + match eq_DType D (proj1_sig TT) TE with + | true => Some TT + | false => None + end + | _, _ => None + end + | false => None + end + | _ => None + end + end. Global Instance MAlgebra_typeof_Bool T: FAlgebra TypeofName T (typeofR D) Bool := @@ -235,25 +238,26 @@ Section Bool. (* ============================================== *) (* Boolmetic Values. *) - Inductive BoolValue (A : Set) : Set := - | VB : bool -> BoolValue A. - - Definition VB_fmap : forall (A B : Set) (f : A -> B), - BoolValue A -> BoolValue B := - fun A B _ e => match e with - | VB n => VB _ n - end. - - Global Instance VB_Functor : Functor BoolValue := - {| fmap := VB_fmap |}. - destruct a; reflexivity. - destruct a; reflexivity. - Defined. - - Variable V : Set -> Set. - Context {Fun_V : Functor V}. - Definition Value := Value V. - Context {Sub_BoolValue_V : BoolValue :<: V}. + Inductive BoolValue (A : Set) : Set := + | VB : bool -> BoolValue A. + + Definition VB_fmap : forall (A B : Set) (f : A -> B), + BoolValue A -> BoolValue B := + fun A B _ e => match e with + | VB n => VB _ n + end. + + Global Instance VB_Functor : Functor BoolValue := + {| fmap := VB_fmap |}. + Proof. + destruct a; reflexivity. + destruct a; reflexivity. + Defined. + + Variable V : Set -> Set. + Context {Fun_V : Functor V}. + Definition Value := Value V. + Context {Sub_BoolValue_V : BoolValue :<: V}. (* Constructor + Universal Property. *) Context {WF_Sub_BoolValue_F : WF_Functor _ _ Sub_BoolValue_V _ _}. @@ -261,21 +265,21 @@ Section Bool. Definition vb' (b : bool) : Value := inject' (VB _ b). Definition vb (b : bool) : Fix V := proj1_sig (vb' b). - Global Instance UP'_vb {b : bool} : - Universal_Property'_fold (vb b) := proj2_sig (vb' b). + Global Instance UP'_vb {b : bool} : + Universal_Property'_fold (vb b) := proj2_sig (vb' b). - (* Constructor Testing for Boolmetic Values. *) + (* Constructor Testing for Boolmetic Values. *) - Definition isVB : Fix V -> option bool := - fun exp => - match project exp with + Definition isVB : Fix V -> option bool := + fun exp => + match project exp with | Some (VB b) => Some b | None => None - end. + end. - Context {Sub_StuckValue_V : StuckValue :<: V}. - Definition stuck' : nat -> Value := stuck' _. - Definition stuck : nat -> Fix V := stuck _. + Context {Sub_StuckValue_V : StuckValue :<: V}. + Definition stuck' : nat -> Value := stuck' _. + Definition stuck : nat -> Fix V := stuck _. (* ============================================== *) (* EVALUATION *) @@ -283,22 +287,22 @@ Section Bool. Context {Sub_BotValue_V : BotValue :<: V}. - (* Evaluation Algebra for Boolemetic Expressions. *) - - Definition Bool_eval (R : Set) (rec : R -> evalR V) - (e : Bool R) : evalR V := - match e with - | BLit b => (fun _ => vb' b) - | If i t e => (fun env => - let i' := (rec i env) in - match (isVB (proj1_sig i')) with - | Some true => rec t env - | Some false => rec e env - | None => if (@isBot _ Fun_V Sub_BotValue_V (proj1_sig i')) - then bot' V - else stuck' 5 - end) - end. + (* Evaluation Algebra for Boolemetic Expressions. *) + + Definition Bool_eval (R : Set) (rec : R -> evalR V) + (e : Bool R) : evalR V := + match e with + | BLit b => fun _ => vb' b + | If i t e => fun env => + let i' := (rec i env) in + match (isVB (proj1_sig i')) with + | Some true => rec t env + | Some false => rec e env + | None => if (@isBot _ Fun_V Sub_BotValue_V (proj1_sig i')) + then bot' V + else stuck' 5 + end + end. Global Instance MAlgebra_eval_Bool T : FAlgebra EvalName T (evalR V) Bool := @@ -320,20 +324,24 @@ Section Bool. Global Instance MAlgebra_ExpPrint_Bool T : FAlgebra ExpPrintName T (ExpPrintR) Bool := - {| f_algebra := fun rec e => - match e with - | BLit true => fun i => append "true" "" - | BLit false => fun i => append "false" "" - | If i t e => fun i' => append "(if (" ((rec i i') ++ ") then (" ++ (rec t i') ++ ") else ("++ (rec e i')++"))") - end |}. + {| f_algebra := + fun rec e => + match e with + | BLit true => fun i => append "true" "" + | BLit false => fun i => append "false" "" + | If i t e => fun i' => + append "(if (" ((rec i i') ++ ") then (" ++ (rec t i') ++ ") else (" ++ (rec e i') ++"))") + end + |}. Global Instance MAlgebra_ValuePrint_BType T : FAlgebra ValuePrintName T ValuePrintR BoolValue := {| f_algebra := fun rec e => - match e with - | VB true => append "true" "" - | VB false => append "false" "" - end |}. + match e with + | VB true => append "true" "" + | VB false => append "false" "" + end + |}. (* ============================================== *) (* TYPE SOUNDNESS *) @@ -349,89 +357,94 @@ Section Bool. Context {Dis_VB_Bot : Distinct_Sub_Functor _ Sub_BoolValue_V Sub_BotValue_V}. - (* Inversion principles for natural number SubValues. *) + (* Inversion principles for natural number SubValues. *) Definition SV_invertVB_P (i : SubValue_i V) := forall b, proj1_sig (sv_a _ i) = vb b -> - proj1_sig (sv_b _ i) = vb b. - - Inductive SV_invertVB_Name := ece_invertvb_name. - Context {SV_invertVB_SV : - iPAlgebra SV_invertVB_Name SV_invertVB_P SV}. - - Global Instance SV_invertVB_refl : - iPAlgebra SV_invertVB_Name SV_invertVB_P (SubValue_refl V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertVB_P. - inversion H; subst; simpl; congruence. - Defined. - - Lemma SV_invertVB_default : forall V' - (Fun_V' : Functor V') - (SV' : (SubValue_i V -> Prop) -> SubValue_i V -> Prop) - (sub_V'_V : V' :<: V) - (WF_V' : WF_Functor V' V sub_V'_V Fun_V' Fun_V), - (forall (i : SubValue_i V) (H : SV' SV_invertVB_P i), - exists v', proj1_sig (sv_a _ i) = inject v') -> - Distinct_Sub_Functor _ Sub_BoolValue_V sub_V'_V -> - iPAlgebra SV_invertVB_Name SV_invertVB_P SV'. - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertVB_P. - destruct (H _ H1) as [v' eq_v']. - intros; rewrite eq_v' in H2. - elimtype False. - unfold vb, inject, vb', inject' in H2; simpl in H2. - apply sym_eq in H2. - apply (inject_discriminate H0 _ _ H2). - Defined. - - Global Instance SV_invertVB_Bot : - iPAlgebra SV_invertVB_Name SV_invertVB_P (SubValue_Bot V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertVB_P. - inversion H; subst; simpl; intros. - elimtype False. - rewrite H0 in H1. - unfold vb, inject, vb', inject' in H1; simpl in H1. - repeat rewrite out_in_inverse, wf_functor in H1; simpl in H1. - eapply (inject_discriminate Dis_VB_Bot); unfold inject; simpl; eauto. - Defined. - - Context {iFun_F : iFunctor SV}. - Definition SV_invertVB := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertVB_SV)). - - Definition SV_invertVB'_P (i : SubValue_i V) := - forall n, proj1_sig (sv_b _ i) = vb n -> - proj1_sig (sv_a _ i) = vb n \/ proj1_sig (sv_a _ i) = bot _. - - Inductive SV_invertVB'_Name := ece_invertvb'_name. - Context {SV_invertVB'_SV : - iPAlgebra SV_invertVB'_Name SV_invertVB'_P SV}. - - Global Instance SV_invertVB'_refl : - iPAlgebra SV_invertVB'_Name SV_invertVB'_P (SubValue_refl V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertVB'_P. - inversion H; subst; simpl; eauto. - intros. - left; congruence. - Defined. - - Global Instance SV_invertVB'_Bot : - iPAlgebra SV_invertVB'_Name SV_invertVB'_P (SubValue_Bot V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertVB'_P. - inversion H; subst; simpl; eauto. - Defined. - - Definition SV_invertVB' := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertVB'_SV)). - - (* End Inversion principles for SubValue.*) - - Context {SV_invertBot_SV : - iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SV}. - Context {Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV}. - - Lemma WF_ind_alg_Bool (Name : Set) + proj1_sig (sv_b _ i) = vb b. + + Inductive SV_invertVB_Name := ece_invertvb_name. + Context {SV_invertVB_SV : + iPAlgebra SV_invertVB_Name SV_invertVB_P SV}. + + Global Instance SV_invertVB_refl : + iPAlgebra SV_invertVB_Name SV_invertVB_P (SubValue_refl V). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertVB_P. + inversion H; subst; simpl; congruence. + Defined. + + Lemma SV_invertVB_default : forall V' + (Fun_V' : Functor V') + (SV' : (SubValue_i V -> Prop) -> SubValue_i V -> Prop) + (sub_V'_V : V' :<: V) + (WF_V' : WF_Functor V' V sub_V'_V Fun_V' Fun_V), + (forall (i : SubValue_i V) (H : SV' SV_invertVB_P i), + exists v', proj1_sig (sv_a _ i) = inject v') -> + Distinct_Sub_Functor _ Sub_BoolValue_V sub_V'_V -> + iPAlgebra SV_invertVB_Name SV_invertVB_P SV'. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertVB_P. + destruct (H _ H1) as [v' eq_v']. + intros; rewrite eq_v' in H2. + elimtype False. + unfold vb, inject, vb', inject' in H2; simpl in H2. + apply sym_eq in H2. + apply (inject_discriminate H0 _ _ H2). + Defined. + + Global Instance SV_invertVB_Bot : + iPAlgebra SV_invertVB_Name SV_invertVB_P (SubValue_Bot V). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertVB_P. + inversion H; subst; simpl; intros. + elimtype False. + rewrite H0 in H1. + unfold vb, inject, vb', inject' in H1; simpl in H1. + repeat rewrite out_in_inverse, wf_functor in H1; simpl in H1. + eapply (inject_discriminate Dis_VB_Bot); unfold inject; simpl; eauto. + Defined. + + Context {iFun_F : iFunctor SV}. + Definition SV_invertVB := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertVB_SV)). + + Definition SV_invertVB'_P (i : SubValue_i V) := + forall n, proj1_sig (sv_b _ i) = vb n -> + proj1_sig (sv_a _ i) = vb n \/ proj1_sig (sv_a _ i) = bot _. + + Inductive SV_invertVB'_Name := ece_invertvb'_name. + Context {SV_invertVB'_SV : + iPAlgebra SV_invertVB'_Name SV_invertVB'_P SV}. + + Global Instance SV_invertVB'_refl : + iPAlgebra SV_invertVB'_Name SV_invertVB'_P (SubValue_refl V). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertVB'_P. + inversion H; subst; simpl; eauto. + intros. + left; congruence. + Defined. + + Global Instance SV_invertVB'_Bot : + iPAlgebra SV_invertVB'_Name SV_invertVB'_P (SubValue_Bot V). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertVB'_P. + inversion H; subst; simpl; eauto. + Defined. + + Definition SV_invertVB' := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertVB'_SV)). + + (* End Inversion principles for SubValue.*) + + Context {SV_invertBot_SV : + iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SV}. + Context {Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV}. + + Lemma WF_ind_alg_Bool (Name : Set) (P : forall e : Fix F, Universal_Property'_fold e -> Prop) (H : forall b, UP'_P P (blit b)) (H0 : forall i t e @@ -443,418 +456,426 @@ Section Bool. (forall a, inj (Sub_Functor := Sub_Bool_F) a = inj (A := (Fix (F))) (Sub_Functor := Sub_Bool_F') a) -> WF_Ind (Name := Name) {| p_algebra := ind_alg_Bool P H H0|}. - constructor; intros. - simpl; unfold ind_alg_Bool; destruct e; simpl. - unfold blit; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. - unfold cond; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. - Defined. + Proof. + constructor; intros. + simpl; unfold ind_alg_Bool; destruct e; simpl. + unfold blit; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. + unfold cond; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. + Defined. (* ============================================== *) (* WELL-FORMED BOOLEAN VALUES *) (* ============================================== *) - Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. - Variable funWFV : iFunctor WFV. + Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. + Variable funWFV : iFunctor WFV. - (** Natrual Numbers are well-formed **) + (** Natrual Numbers are well-formed **) - Inductive WFValue_VB (WFV : WFValue_i D V -> Prop) : WFValue_i D V -> Prop := - | WFV_VB : forall n v T, - proj1_sig v = vb n -> - proj1_sig T = tbool -> - WFValue_VB WFV (mk_WFValue_i D V v T). + Inductive WFValue_VB (WFV : WFValue_i D V -> Prop) : WFValue_i D V -> Prop := + | WFV_VB : forall n v T, + proj1_sig v = vb n -> + proj1_sig T = tbool -> + WFValue_VB WFV (mk_WFValue_i D V v T). - Definition ind_alg_WFV_VB (P : WFValue_i D V -> Prop) - (H : forall n v T veq Teq, P (mk_WFValue_i _ _ v T)) - i (e : WFValue_VB P i) : P i := - match e in WFValue_VB _ i return P i with - | WFV_VB n v T veq Teq => H n v T veq Teq - end. + Definition ind_alg_WFV_VB (P : WFValue_i D V -> Prop) + (H : forall n v T veq Teq, P (mk_WFValue_i _ _ v T)) + i (e : WFValue_VB P i) : P i := + match e in WFValue_VB _ i return P i with + | WFV_VB n v T veq Teq => H n v T veq Teq + end. - Definition WFV_VB_ifmap (A B : WFValue_i D V -> Prop) i (f : forall i, A i -> B i) - (WFV_a : WFValue_VB A i) : WFValue_VB B i := - match WFV_a in (WFValue_VB _ s) return (WFValue_VB B s) - with - | WFV_VB n v T veq Teq => WFV_VB B n v T veq Teq - end. + Definition WFV_VB_ifmap (A B : WFValue_i D V -> Prop) i (f : forall i, A i -> B i) + (WFV_a : WFValue_VB A i) : WFValue_VB B i := + match WFV_a in (WFValue_VB _ s) return (WFValue_VB B s) + with + | WFV_VB n v T veq Teq => WFV_VB B n v T veq Teq + end. - Global Instance iFun_WFV_VB : iFunctor WFValue_VB. - constructor 1 with (ifmap := WFV_VB_ifmap). - destruct a; simpl; intros; reflexivity. - destruct a; simpl; intros; reflexivity. - Defined. - - Variable Sub_WFV_VB_WFV : Sub_iFunctor WFValue_VB WFV. - - Global Instance WFV_proj1_a_VB : - iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFValue_VB. - econstructor; intros. - unfold iAlgebra; intros; unfold WFV_proj1_a_P. - inversion H; subst; simpl; intros. - apply (inject_i (subGF := Sub_WFV_VB_WFV)); econstructor; simpl; eauto. - rewrite H3; eauto. - Defined. - - Global Instance WFV_proj1_b_VB : - iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFValue_VB. - econstructor; intros. - unfold iAlgebra; intros; unfold WFV_proj1_b_P. - inversion H; subst; simpl; intros. - apply (inject_i (subGF := Sub_WFV_VB_WFV)); econstructor; simpl; eauto. - rewrite H3; eauto. - Defined. - - (* Inversion principles for Well-formed Booleans. *) - Definition WF_invertVB_P (i : WFValue_i D V) := - proj1_sig (wfv_b _ _ i) = tbool -> - WFValue_VB (iFix WFV) i \/ (proj1_sig (wfv_a D V i) = bot V). - - Inductive WF_invertVB_Name := wfv_invertvb_name. - Context {WF_invertVB_WFV : - iPAlgebra WF_invertVB_Name WF_invertVB_P WFV}. - - Global Instance WF_invertVB_VB : - iPAlgebra WF_invertVB_Name WF_invertVB_P WFValue_VB. - econstructor; intros. - unfold iAlgebra; intros; unfold WF_invertVB_P. - inversion H; subst; simpl; intros. - left; econstructor; eassumption. - Defined. - - Ltac WF_invertVB_default := - constructor; unfold iAlgebra; intros i H; unfold WF_invertVB_P; - inversion H; simpl; - match goal with - eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ => - intro eq_H; rewrite eq_H in eq_H0; - elimtype False; eapply (inject_discriminate _ _ _ eq_H0) - end. - - Global Instance WF_invertVB_Bot : - iPAlgebra WF_invertVB_Name WF_invertVB_P (WFValue_Bot _ _). - Proof. - econstructor; intros. - unfold iAlgebra; intros; unfold WF_invertVB_P. - inversion H; subst; simpl; intros. - inversion H; subst; rewrite H3; right; reflexivity. - Defined. - - Definition WF_invertVB := ifold_ WFV _ (ip_algebra (iPAlgebra := WF_invertVB_WFV)). - - Context {WFV_proj1_a_WFV : - iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFV}. - Context {WFV_proj1_b_WFV : - iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFV}. - Context {eq_DType_eq_DT : PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) D}. - Variable WF_Ind_DType_eq_D : WF_Ind eq_DType_eq_DT. - Variable Sub_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot _ _) WFV. - - Lemma Bool_eval_Soundness_H - (typeof_R eval_R : Set) typeof_rec eval_rec - {eval_F' : FAlgebra EvalName eval_R (evalR V) F} - {WF_eval_F' : @WF_FAlgebra EvalName _ _ Bool F - Sub_Bool_F (MAlgebra_eval_Bool _) (eval_F')} : - forall b : bool, - forall gamma'' : Env (Names.Value V), - forall T : Names.DType D, - Bool_typeof typeof_R typeof_rec (BLit _ b) = Some T -> - WFValueC D V WFV (Bool_eval eval_R eval_rec (BLit _ b) gamma'') T. - intros n gamma'' T H4; intros. - apply (inject_i (subGF := Sub_WFV_VB_WFV)); econstructor; eauto. - simpl. - unfold vb, vb', inject; simpl; eauto. - unfold typeof, mfold, blit in H4; simpl in H4. - injection H4; intros; subst. - reflexivity. - Defined. - - Lemma Bool_eval_Soundness_H0 - (typeof_R eval_R : Set) typeof_rec eval_rec - {eval_F' : FAlgebra EvalName eval_R (evalR V) F} - {WF_eval_F' : @WF_FAlgebra EvalName _ _ Bool F - Sub_Bool_F (MAlgebra_eval_Bool _) (eval_F')} : - forall (i t el : typeof_R) (i' t' el' : eval_R), - forall gamma'' : Env (Names.Value V), - (forall T : Names.DType D, - typeof_rec i = Some T -> - WFValueC D V WFV (eval_rec i' gamma'') T) -> - (forall T : Names.DType D, - typeof_rec t = Some T -> - WFValueC D V WFV (eval_rec t' gamma'') T) -> - (forall T : Names.DType D, - typeof_rec el = Some T -> - WFValueC D V WFV (eval_rec el' gamma'') T) -> - forall T : Names.DType D, - Bool_typeof typeof_R typeof_rec (If _ i t el) = Some T -> - WFValueC D V WFV (Bool_eval eval_R eval_rec (If _ i' t' el') gamma'') T. - simpl; intros i t el i' t' el' gamma'' IH_i IH_t IH_el T H4. - caseEq (typeof_rec i); intros; rename H into typeof_i; - unfold typeof, typeofR in typeof_i, H4; rewrite typeof_i in H4; - try discriminate. - caseEq (isTBool (proj1_sig d)); intros; rename H into d_eq; rewrite - d_eq in H4; try discriminate. - caseEq (typeof_rec t); rewrite H in H4; rename H into typeof_t. - caseEq (typeof_rec el); rewrite H in H4; rename H into typeof_el. - caseEq (eq_DType _ (proj1_sig d0) d1); rewrite H in H4; rename H into eq_d0_d1. - injection H4; intros; subst; clear H4. - unfold isTBool in d_eq. - caseEq (project (proj1_sig d)); intros; rewrite H in d_eq; - try discriminate; clear d_eq; rename H into d_eq; destruct b. - apply project_inject in d_eq; eauto with typeclass_instances. - unfold WFValueC in *|-*. - generalize (IH_i _ typeof_i) as WF_i; - generalize (IH_t _ typeof_t) as WF_t; - generalize (IH_el _ typeof_el) as WF_el; intros. - destruct (WF_invertVB _ WF_i d_eq) as [eval_i' | eval_i']; - inversion eval_i'; subst. - rewrite H1; unfold isVB, project, vb, vb', inject'; simpl; - rewrite out_in_fmap; repeat rewrite wf_functor; simpl; rewrite prj_inj. - destruct n. - unfold eval in WF_t; eapply WF_t. - unfold eval in WF_el; destruct T as [x u]; - apply (WFV_proj1_b _ _ WFV funWFV _ WF_el x u - (eq_DType_eq D WF_Ind_DType_eq_D _ _ eq_d0_d1)). - rewrite H0; unfold bot, isVB, project, inject, inject'; simpl; - rewrite out_in_fmap; repeat rewrite wf_functor; simpl; unfold Bot_fmap. - caseEq (prj (Sub_Functor := Sub_BoolValue_V) (A:= (sig (@Universal_Property'_fold V _))) - (inj (Bot (sig Universal_Property'_fold)))). - elimtype False; eapply (inject_discriminate Dis_VB_Bot b). - unfold inject; simpl; apply inj_prj in H; erewrite <- H; reflexivity. - unfold isBot, project; rewrite out_in_fmap; rewrite wf_functor; - unfold Bot_fmap; rewrite prj_inj; simpl. - apply (inject_i (subGF := Sub_WFV_Bot_WFV)); constructor; reflexivity. - exact (proj2_sig d). - discriminate. - discriminate. - discriminate. - Defined. - - Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) F}. - Context {WF_typeof_F : forall T, @WF_FAlgebra TypeofName T _ _ _ - Sub_Bool_F (MAlgebra_typeof_Bool T) (Typeof_F _)}. - Context {WF_Value_continous_alg : - iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SV}. - - Global Instance Bool_eval_Soundness_alg - (P_bind : Set) - (P : P_bind -> Env Value -> Prop) - (E' : Set -> Set) - {Fun_E' : Functor E'} - {Sub_Bool_E' : Bool :<: E'} - {WF_Fun_E' : WF_Functor _ _ Sub_Bool_E' _ _} - {Typeof_E' : forall T, FAlgebra TypeofName T (typeofR D) E'} - {WF_typeof_E' : forall T, @WF_FAlgebra TypeofName T _ _ _ - Sub_Bool_E' (MAlgebra_typeof_Bool T) (Typeof_E' _)} - (pb : P_bind) - (eval_rec : Exp -> evalR V) - (typeof_rec : UP'_F E' -> typeofR D) - : - PAlgebra eval_Soundness_alg_Name (sig (UP'_P2 (@eval_alg_Soundness_P D _ V _ _ _ WFV _ P - _ _ pb typeof_rec eval_rec (f_algebra (FAlgebra := Typeof_E' _ )) - (f_algebra (FAlgebra := eval_F))))) Bool. - Proof. - econstructor; unfold Algebra; intros. - eapply (ind2_alg_Bool (@eval_alg_Soundness_P D _ V _ _ _ WFV _ P - _ _ pb typeof_rec eval_rec (f_algebra (FAlgebra := Typeof_E' _ )) - (f_algebra (FAlgebra := eval_F)))); try eassumption; - unfold eval_alg_Soundness_P, UP'_P2; intros. - constructor. - exact (conj (proj2_sig (inject' (BLit _ b))) (proj2_sig (blit' b))). - unfold blit, blit', inject; simpl. - repeat rewrite out_in_fmap. - repeat rewrite wf_functor. - intros gamma'' WF_gamma'' IHa. - rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); - rewrite (wf_algebra (WF_FAlgebra := WF_typeof_E' _)); - simpl fmap; simpl f_algebra; unfold Bool_fmap. - intros. - eapply Bool_eval_Soundness_H. - apply WF_eval_F. - apply H0. - (* If Case *) - destruct i as [i1 i2]; destruct t as [t1 t2]; destruct el as [el1 el2]; - destruct IHi as [[UP'_i1 UP'_i2] IHi]; - destruct IHt as [[UP'_t1 UP'_t2] IHt]; - destruct IHel as [[UP'_el1 UP'_el2] IHel]; - simpl in *|-*. - constructor. - split; unfold inject; exact (proj2_sig _). - unfold inject; simpl; - repeat rewrite out_in_fmap; repeat rewrite wf_functor; simpl. - intros eval_rec_proj typeof_rec_proj gamma'' WF_gamma'' IHa. - rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); - rewrite (wf_algebra (WF_FAlgebra := WF_typeof_E' _)); - simpl fmap; simpl f_algebra; unfold Bool_fmap. - intros T; eapply Bool_eval_Soundness_H0. - apply WF_eval_F. - apply (IHa _ _ WF_gamma'' (_, exist _ _ UP'_i2)); simpl; - intros; apply (IHi eval_rec_proj typeof_rec_proj _ WF_gamma'' IHa); - intros; auto; rewrite <- (in_out_UP'_inverse _ _ i1); auto. - apply (IHa _ _ WF_gamma'' (_, exist _ _ UP'_t2)); simpl; - intros; apply (IHt eval_rec_proj typeof_rec_proj _ WF_gamma'' IHa); - intros; auto; rewrite <- (in_out_UP'_inverse _ _ t1); auto. - apply (IHa _ _ WF_gamma'' (_, exist _ _ UP'_el2)); simpl; - intros; apply (IHel eval_rec_proj typeof_rec_proj _ WF_gamma'' IHa); - intros; auto; rewrite <- (in_out_UP'_inverse _ _ el1); auto. - Defined. + Global Instance iFun_WFV_VB : iFunctor WFValue_VB. + Proof. + constructor 1 with (ifmap := WFV_VB_ifmap). + destruct a; simpl; intros; reflexivity. + destruct a; simpl; intros; reflexivity. + Defined. + + Variable Sub_WFV_VB_WFV : Sub_iFunctor WFValue_VB WFV. + + Global Instance WFV_proj1_a_VB : + iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFValue_VB. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WFV_proj1_a_P. + inversion H; subst; simpl; intros. + apply (inject_i (subGF := Sub_WFV_VB_WFV)); econstructor; simpl; eauto. + rewrite H3; eauto. + Defined. + + Global Instance WFV_proj1_b_VB : + iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFValue_VB. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WFV_proj1_b_P. + inversion H; subst; simpl; intros. + apply (inject_i (subGF := Sub_WFV_VB_WFV)); econstructor; simpl; eauto. + rewrite H3; eauto. + Defined. + + (* Inversion principles for Well-formed Booleans. *) + Definition WF_invertVB_P (i : WFValue_i D V) := + proj1_sig (wfv_b _ _ i) = tbool -> + WFValue_VB (iFix WFV) i \/ (proj1_sig (wfv_a D V i) = bot V). + + Inductive WF_invertVB_Name := wfv_invertvb_name. + Context {WF_invertVB_WFV : + iPAlgebra WF_invertVB_Name WF_invertVB_P WFV}. + + Global Instance WF_invertVB_VB : + iPAlgebra WF_invertVB_Name WF_invertVB_P WFValue_VB. + econstructor; intros. + unfold iAlgebra; intros; unfold WF_invertVB_P. + inversion H; subst; simpl; intros. + left; econstructor; eassumption. + Defined. + + Ltac WF_invertVB_default := + constructor; unfold iAlgebra; intros i H; unfold WF_invertVB_P; + inversion H; simpl; + match goal with + eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ => + intro eq_H; rewrite eq_H in eq_H0; + elimtype False; eapply (inject_discriminate _ _ _ eq_H0) + end. + + Global Instance WF_invertVB_Bot : + iPAlgebra WF_invertVB_Name WF_invertVB_P (WFValue_Bot _ _). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WF_invertVB_P. + inversion H; subst; simpl; intros. + inversion H; subst; rewrite H3; right; reflexivity. + Defined. + + Definition WF_invertVB := ifold_ WFV _ (ip_algebra (iPAlgebra := WF_invertVB_WFV)). + + Context {WFV_proj1_a_WFV : + iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFV}. + Context {WFV_proj1_b_WFV : + iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFV}. + Context {eq_DType_eq_DT : PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) D}. + Variable WF_Ind_DType_eq_D : WF_Ind eq_DType_eq_DT. + Variable Sub_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot _ _) WFV. + + Lemma Bool_eval_Soundness_H + (typeof_R eval_R : Set) typeof_rec eval_rec + {eval_F' : FAlgebra EvalName eval_R (evalR V) F} + {WF_eval_F' : @WF_FAlgebra EvalName _ _ Bool F + Sub_Bool_F (MAlgebra_eval_Bool _) (eval_F')} : + forall b : bool, + forall gamma'' : Env (Names.Value V), + forall T : Names.DType D, + Bool_typeof typeof_R typeof_rec (BLit _ b) = Some T -> + WFValueC D V WFV (Bool_eval eval_R eval_rec (BLit _ b) gamma'') T. + Proof. + intros n gamma'' T H4; intros. + apply (inject_i (subGF := Sub_WFV_VB_WFV)); econstructor; eauto. + simpl. + unfold vb, vb', inject; simpl; eauto. + unfold typeof, mfold, blit in H4; simpl in H4. + injection H4; intros; subst. + reflexivity. + Defined. + + Lemma Bool_eval_Soundness_H0 + (typeof_R eval_R : Set) typeof_rec eval_rec + {eval_F' : FAlgebra EvalName eval_R (evalR V) F} + {WF_eval_F' : @WF_FAlgebra EvalName _ _ Bool F + Sub_Bool_F (MAlgebra_eval_Bool _) (eval_F')} : + forall (i t el : typeof_R) (i' t' el' : eval_R), + forall gamma'' : Env (Names.Value V), + (forall T : Names.DType D, + typeof_rec i = Some T -> + WFValueC D V WFV (eval_rec i' gamma'') T) -> + (forall T : Names.DType D, + typeof_rec t = Some T -> + WFValueC D V WFV (eval_rec t' gamma'') T) -> + (forall T : Names.DType D, + typeof_rec el = Some T -> + WFValueC D V WFV (eval_rec el' gamma'') T) -> + forall T : Names.DType D, + Bool_typeof typeof_R typeof_rec (If _ i t el) = Some T -> + WFValueC D V WFV (Bool_eval eval_R eval_rec (If _ i' t' el') gamma'') T. + simpl; intros i t el i' t' el' gamma'' IH_i IH_t IH_el T H4. + caseEq (typeof_rec i); intros; rename H into typeof_i; + unfold typeof, typeofR in typeof_i, H4; rewrite typeof_i in H4; + try discriminate. + caseEq (isTBool (proj1_sig d)); intros; rename H into d_eq; rewrite + d_eq in H4; try discriminate. + caseEq (typeof_rec t); rewrite H in H4; rename H into typeof_t. + caseEq (typeof_rec el); rewrite H in H4; rename H into typeof_el. + caseEq (eq_DType _ (proj1_sig d0) d1); rewrite H in H4; rename H into eq_d0_d1. + injection H4; intros; subst; clear H4. + unfold isTBool in d_eq. + caseEq (project (proj1_sig d)); intros; rewrite H in d_eq; + try discriminate; clear d_eq; rename H into d_eq; destruct b. + apply project_inject in d_eq; eauto with typeclass_instances. + unfold WFValueC in *|-*. + generalize (IH_i _ typeof_i) as WF_i; + generalize (IH_t _ typeof_t) as WF_t; + generalize (IH_el _ typeof_el) as WF_el; intros. + destruct (WF_invertVB _ WF_i d_eq) as [eval_i' | eval_i']; + inversion eval_i'; subst. + rewrite H1; unfold isVB, project, vb, vb', inject'; simpl; + rewrite out_in_fmap; repeat rewrite wf_functor; simpl; rewrite prj_inj. + destruct n. + unfold eval in WF_t; eapply WF_t. + unfold eval in WF_el; destruct T as [x u]; + apply (WFV_proj1_b _ _ WFV funWFV _ WF_el x u + (eq_DType_eq D WF_Ind_DType_eq_D _ _ eq_d0_d1)). + rewrite H0; unfold bot, isVB, project, inject, inject'; simpl; + rewrite out_in_fmap; repeat rewrite wf_functor; simpl; unfold Bot_fmap. + caseEq (prj (Sub_Functor := Sub_BoolValue_V) (A:= (sig (@Universal_Property'_fold V _))) + (inj (Bot (sig Universal_Property'_fold)))). + elimtype False; eapply (inject_discriminate Dis_VB_Bot b). + unfold inject; simpl; apply inj_prj in H; erewrite <- H; reflexivity. + unfold isBot, project; rewrite out_in_fmap; rewrite wf_functor; + unfold Bot_fmap; rewrite prj_inj; simpl. + apply (inject_i (subGF := Sub_WFV_Bot_WFV)); constructor; reflexivity. + exact (proj2_sig d). + discriminate. + discriminate. + discriminate. + Defined. + + Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) F}. + Context {WF_typeof_F : forall T, @WF_FAlgebra TypeofName T _ _ _ + Sub_Bool_F (MAlgebra_typeof_Bool T) (Typeof_F _)}. + Context {WF_Value_continous_alg : + iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SV}. + + Global Instance Bool_eval_Soundness_alg + (P_bind : Set) + (P : P_bind -> Env Value -> Prop) + (E' : Set -> Set) + {Fun_E' : Functor E'} + {Sub_Bool_E' : Bool :<: E'} + {WF_Fun_E' : WF_Functor _ _ Sub_Bool_E' _ _} + {Typeof_E' : forall T, FAlgebra TypeofName T (typeofR D) E'} + {WF_typeof_E' : forall T, @WF_FAlgebra TypeofName T _ _ _ + Sub_Bool_E' (MAlgebra_typeof_Bool T) (Typeof_E' _)} + (pb : P_bind) + (eval_rec : Exp -> evalR V) + (typeof_rec : UP'_F E' -> typeofR D) + : + PAlgebra eval_Soundness_alg_Name (sig (UP'_P2 (@eval_alg_Soundness_P D _ V _ _ _ WFV _ P + _ _ pb typeof_rec eval_rec (f_algebra (FAlgebra := Typeof_E' _ )) + (f_algebra (FAlgebra := eval_F))))) Bool. + Proof. + econstructor; unfold Algebra; intros. + eapply (ind2_alg_Bool (@eval_alg_Soundness_P D _ V _ _ _ WFV _ P + _ _ pb typeof_rec eval_rec (f_algebra (FAlgebra := Typeof_E' _ )) + (f_algebra (FAlgebra := eval_F)))); try eassumption; + unfold eval_alg_Soundness_P, UP'_P2; intros. + constructor. + exact (conj (proj2_sig (inject' (BLit _ b))) (proj2_sig (blit' b))). + unfold blit, blit', inject; simpl. + repeat rewrite out_in_fmap. + repeat rewrite wf_functor. + intros gamma'' WF_gamma'' IHa. + rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); + rewrite (wf_algebra (WF_FAlgebra := WF_typeof_E' _)); + simpl fmap; simpl f_algebra; unfold Bool_fmap. + intros. + eapply Bool_eval_Soundness_H. + apply WF_eval_F. + apply H0. + (* If Case *) + destruct i as [i1 i2]; destruct t as [t1 t2]; destruct el as [el1 el2]; + destruct IHi as [[UP'_i1 UP'_i2] IHi]; + destruct IHt as [[UP'_t1 UP'_t2] IHt]; + destruct IHel as [[UP'_el1 UP'_el2] IHel]; + simpl in *|-*. + constructor. + split; unfold inject; exact (proj2_sig _). + unfold inject; simpl; + repeat rewrite out_in_fmap; repeat rewrite wf_functor; simpl. + intros eval_rec_proj typeof_rec_proj gamma'' WF_gamma'' IHa. + rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); + rewrite (wf_algebra (WF_FAlgebra := WF_typeof_E' _)); + simpl fmap; simpl f_algebra; unfold Bool_fmap. + intros T; eapply Bool_eval_Soundness_H0. + apply WF_eval_F. + apply (IHa _ _ WF_gamma'' (_, exist _ _ UP'_i2)); simpl; + intros; apply (IHi eval_rec_proj typeof_rec_proj _ WF_gamma'' IHa); + intros; auto; rewrite <- (in_out_UP'_inverse _ _ i1); auto. + apply (IHa _ _ WF_gamma'' (_, exist _ _ UP'_t2)); simpl; + intros; apply (IHt eval_rec_proj typeof_rec_proj _ WF_gamma'' IHa); + intros; auto; rewrite <- (in_out_UP'_inverse _ _ t1); auto. + apply (IHa _ _ WF_gamma'' (_, exist _ _ UP'_el2)); simpl; + intros; apply (IHel eval_rec_proj typeof_rec_proj _ WF_gamma'' IHa); + intros; auto; rewrite <- (in_out_UP'_inverse _ _ el1); auto. + Defined. (* BLit case. *) - Lemma eval_continuous_Exp_H : forall b, + Lemma eval_continuous_Exp_H : + forall b, UP'_P (eval_continuous_Exp_P V F SV) (blit b). - unfold eval_continuous_Exp_P; intros; econstructor; intros. - unfold beval, mfold, blit; simpl; unfold inject. - repeat rewrite out_in_fmap; simpl; - repeat rewrite wf_functor; simpl. - repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. - apply (inject_i (subGF := Sub_SV_refl_SV)). - constructor. - reflexivity. - Qed. - - (* If case. *) - - Lemma eval_continuous_Exp_H0 : forall - (i t e : Fix (F)) - (IHi : UP'_P (eval_continuous_Exp_P V F SV) i) - (IHt : UP'_P (eval_continuous_Exp_P V F SV) t) - (IHe : UP'_P (eval_continuous_Exp_P V F SV) e), - UP'_P (eval_continuous_Exp_P V F SV) - (@cond i t e (proj1_sig IHi) (proj1_sig IHt) (proj1_sig IHe)). - unfold eval_continuous_Exp_P; intros. - destruct IHi as [i_UP' IHi]. - destruct IHt as [t_UP' IHt]. - destruct IHe as [e_UP' IHe]. - econstructor; intros; eauto with typeclass_instances. - unfold beval, mfold, cond; simpl. - unfold inject; simpl; repeat rewrite out_in_fmap; simpl; + Proof. + unfold eval_continuous_Exp_P; intros; econstructor; intros. + unfold beval, mfold, blit; simpl; unfold inject. + repeat rewrite out_in_fmap; simpl; + repeat rewrite wf_functor; simpl. + repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. + apply (inject_i (subGF := Sub_SV_refl_SV)). + constructor. + reflexivity. + Qed. + + (* If case. *) + + Lemma eval_continuous_Exp_H0 : forall + (i t e : Fix (F)) + (IHi : UP'_P (eval_continuous_Exp_P V F SV) i) + (IHt : UP'_P (eval_continuous_Exp_P V F SV) t) + (IHe : UP'_P (eval_continuous_Exp_P V F SV) e), + UP'_P (eval_continuous_Exp_P V F SV) + (@cond i t e (proj1_sig IHi) (proj1_sig IHt) (proj1_sig IHe)). + Proof. + unfold eval_continuous_Exp_P; intros. + destruct IHi as [i_UP' IHi]. + destruct IHt as [t_UP' IHt]. + destruct IHe as [e_UP' IHe]. + econstructor; intros; eauto with typeclass_instances. + unfold beval, mfold, cond; simpl. + unfold inject; simpl; repeat rewrite out_in_fmap; simpl; + repeat rewrite wf_functor; simpl. + repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. + repeat erewrite bF_UP_in_out. + caseEq (project (G := BoolValue) + (proj1_sig (boundedFix_UP m f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold i i_UP') gamma))). + unfold isVB at 1, evalR, Names.Exp; rewrite H2. + destruct b. + generalize (H (exist _ i i_UP') _ _ _ H0 H1); simpl; intros. + generalize (inj_prj _ _ H2); rename H2 into H2'; intros. + assert (proj1_sig + (boundedFix_UP m f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold i i_UP') gamma) = vb b) as Eval_i. + unfold vb, vb', inject'; rewrite <- H2; rewrite in_out_UP'_inverse; eauto. + exact (proj2_sig _). + clear H2; rename H3 into SubV_i. + unfold isVB; unfold eval, mfold in SubV_i. + generalize (SV_invertVB _ SubV_i _ Eval_i). + simpl; unfold beval, evalR, Names.Exp. + intros Eval_i'; rewrite Eval_i'. + unfold project, vb, vb'; simpl; repeat rewrite out_in_fmap; + repeat rewrite wf_functor; repeat rewrite prj_inj; repeat rewrite wf_functor; simpl. - repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. - repeat erewrite bF_UP_in_out. - caseEq (project (G := BoolValue) - (proj1_sig (boundedFix_UP m f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold i i_UP') gamma))). - unfold isVB at 1, evalR, Names.Exp; rewrite H2. - destruct b. - generalize (H (exist _ i i_UP') _ _ _ H0 H1); simpl; intros. - generalize (inj_prj _ _ H2); rename H2 into H2'; intros. - assert (proj1_sig - (boundedFix_UP m f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold i i_UP') gamma) = vb b) as Eval_i. - unfold vb, vb', inject'; rewrite <- H2; rewrite in_out_UP'_inverse; eauto. - exact (proj2_sig _). - clear H2; rename H3 into SubV_i. - unfold isVB; unfold eval, mfold in SubV_i. - generalize (SV_invertVB _ SubV_i _ Eval_i). - simpl; unfold beval, evalR, Names.Exp. - intros Eval_i'; rewrite Eval_i'. - unfold project, vb, vb'; simpl; repeat rewrite out_in_fmap; - repeat rewrite wf_functor; repeat rewrite prj_inj; - repeat rewrite wf_functor; simpl. - destruct b; eapply H; eauto. - unfold isVB; unfold evalR, Names.Exp in *|-*; rewrite H2. - caseEq (project (G := BotValue) - (proj1_sig - (boundedFix_UP m f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold i i_UP') gamma))); - unfold isBot; unfold evalR, Names.Exp in *|-*; rewrite H3. - destruct b; apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; eauto. - caseEq (project (G := BoolValue) + destruct b; eapply H; eauto. + unfold isVB; unfold evalR, Names.Exp in *|-*; rewrite H2. + caseEq (project (G := BotValue) (proj1_sig - (boundedFix_UP n f_algebra + (boundedFix_UP m f_algebra (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold i i_UP') gamma'))). - destruct b. - generalize (inj_prj _ _ H4); rename H4 into H4'; intros. - assert (proj1_sig + (exist Universal_Property'_fold i i_UP') gamma))); + unfold isBot; unfold evalR, Names.Exp in *|-*; rewrite H3. + destruct b; apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; eauto. + caseEq (project (G := BoolValue) + (proj1_sig (boundedFix_UP n f_algebra (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold i i_UP') gamma') = vb b) as Eval_i' by - (unfold vb, vb', inject'; rewrite <- H4; - rewrite in_out_UP'_inverse; unfold eval, mfold; eauto; - exact (proj2_sig _)). - generalize (H (exist _ i i_UP') _ _ _ H0 H1); simpl; intros SubV_i. - unfold beval, evalR, Names.Exp in *|-*. - destruct (SV_invertVB' _ SubV_i _ Eval_i') as [i_eq_vb | i_eq_bot]; - simpl in *|-. - rewrite i_eq_vb in H2. - unfold vb, project, inject in H2; simpl in H2; rewrite - out_in_fmap in H2. - rewrite fmap_fusion in H2; rewrite wf_functor in H2; simpl in H2; - rewrite (prj_inj _ ) in H2; discriminate. - rewrite i_eq_bot in H3. - unfold bot, project, inject in H3; simpl in H3; rewrite - out_in_fmap in H3. - rewrite fmap_fusion in H3; rewrite wf_functor in H3; simpl in H3; - rewrite (prj_inj _ ) in H3; discriminate. - caseEq (project (G := BotValue) - (proj1_sig + (exist Universal_Property'_fold i i_UP') gamma'))). + destruct b. + generalize (inj_prj _ _ H4); rename H4 into H4'; intros. + assert (proj1_sig (boundedFix_UP n f_algebra - (fun _ : Env (Names.Value V) => bot' V) - (exist Universal_Property'_fold i i_UP') gamma'))). - generalize (inj_prj _ _ H5); rename H5 into H5'; intros. - destruct b. - assert (proj1_sig - (beval _ _ n (exist Universal_Property'_fold i i_UP') gamma') = bot _ ) as Eval_i' by - (apply (f_equal (in_t_UP' _ _)) in H5; apply (f_equal (@proj1_sig _ _)) in H5; - rewrite in_out_UP'_inverse in H5; [apply H5 | exact (proj2_sig _)]). - generalize (H (exist _ i i_UP') _ _ _ H0 H1); simpl; intros SubV_i. - unfold beval, evalR, Names.Exp in *|-*. - generalize (SV_invertBot _ SV _ _ SubV_i Eval_i'); simpl; intro H8; - unfold beval, evalR, Names.Exp in *|-*; rewrite H8 in H3. - unfold bot, project, inject in H3; simpl in H3; rewrite - out_in_fmap in H3. - rewrite fmap_fusion in H3; rewrite wf_functor in H3; simpl in H3; - rewrite (prj_inj _ ) in H3; discriminate. - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. - Qed. - - Global Instance Bool_eval_continuous_Exp : - PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V F SV))) (Bool). - Proof. - constructor; unfold Algebra; intros. - eapply ind_alg_Bool. - apply eval_continuous_Exp_H. - apply eval_continuous_Exp_H0. - assumption. - Defined. + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold i i_UP') gamma') = vb b) as Eval_i' by + (unfold vb, vb', inject'; rewrite <- H4; + rewrite in_out_UP'_inverse; unfold eval, mfold; eauto; + exact (proj2_sig _)). + generalize (H (exist _ i i_UP') _ _ _ H0 H1); simpl; intros SubV_i. + unfold beval, evalR, Names.Exp in *|-*. + destruct (SV_invertVB' _ SubV_i _ Eval_i') as [i_eq_vb | i_eq_bot]; + simpl in *|-. + rewrite i_eq_vb in H2. + unfold vb, project, inject in H2; simpl in H2; rewrite + out_in_fmap in H2. + rewrite fmap_fusion in H2; rewrite wf_functor in H2; simpl in H2; + rewrite (prj_inj _ ) in H2; discriminate. + rewrite i_eq_bot in H3. + unfold bot, project, inject in H3; simpl in H3; rewrite + out_in_fmap in H3. + rewrite fmap_fusion in H3; rewrite wf_functor in H3; simpl in H3; + rewrite (prj_inj _ ) in H3; discriminate. + caseEq (project (G := BotValue) + (proj1_sig + (boundedFix_UP n f_algebra + (fun _ : Env (Names.Value V) => bot' V) + (exist Universal_Property'_fold i i_UP') gamma'))). + generalize (inj_prj _ _ H5); rename H5 into H5'; intros. + destruct b. + assert (proj1_sig + (beval _ _ n (exist Universal_Property'_fold i i_UP') gamma') = bot _ ) as Eval_i' by + (apply (f_equal (in_t_UP' _ _)) in H5; apply (f_equal (@proj1_sig _ _)) in H5; + rewrite in_out_UP'_inverse in H5; [apply H5 | exact (proj2_sig _)]). + generalize (H (exist _ i i_UP') _ _ _ H0 H1); simpl; intros SubV_i. + unfold beval, evalR, Names.Exp in *|-*. + generalize (SV_invertBot _ SV _ _ SubV_i Eval_i'); simpl; intro H8; + unfold beval, evalR, Names.Exp in *|-*; rewrite H8 in H3. + unfold bot, project, inject in H3; simpl in H3; rewrite + out_in_fmap in H3. + rewrite fmap_fusion in H3; rewrite wf_functor in H3; simpl in H3; + rewrite (prj_inj _ ) in H3; discriminate. + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. + Qed. + + Global Instance Bool_eval_continuous_Exp : + PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V F SV))) (Bool). + Proof. + constructor; unfold Algebra; intros. + eapply ind_alg_Bool. + apply eval_continuous_Exp_H. + apply eval_continuous_Exp_H0. + assumption. + Defined. End Bool. - Hint Extern 1 (iPAlgebra SV_invertVB_Name (SV_invertVB_P _) _) => - constructor; unfold iAlgebra; unfold SV_invertVB_P; intros i H n H0; - inversion H; subst; simpl in H0; revert H0; - match goal with H : proj1_sig ?v = _ |- proj1_sig ?v = _ -> _ => rewrite H end; intros; - elimtype False; apply (inject_discriminate _ _ _ H0). - - Hint Extern 1 (iPAlgebra SV_invertVB'_Name (SV_invertVB'_P _) _) => - constructor; unfold iAlgebra; unfold SV_invertVB'_P; intros i H n H0; - inversion H; subst; simpl in H0; revert H0; - match goal with H : proj1_sig ?v = _ |- proj1_sig ?v = _ -> _ => rewrite H end; intros; - elimtype False; apply (inject_discriminate _ _ _ H0). - - Ltac WF_invertVB_default := - constructor; unfold iAlgebra; intros i H; unfold WF_invertVB_P; - inversion H; simpl; - match goal with - eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ => - intro eq_H; rewrite eq_H in eq_H0; - elimtype False; eapply (inject_discriminate _ _ _ eq_H0) - end. - - Hint Extern 5 (iPAlgebra WF_invertVB_Name (WF_invertVB_P _ _ _) _) => - constructor; unfold iAlgebra; intros i H; unfold WF_invertVB_P; - inversion H; simpl; - match goal with - eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ => - intro eq_H; rewrite eq_H in eq_H0; - elimtype False; first [apply (inject_discriminate _ _ _ eq_H0) | - apply sym_eq in eq_H0; apply (inject_discriminate _ _ _ eq_H0)]; - fail - end : typeclass_instances. +Hint Extern 1 (iPAlgebra SV_invertVB_Name (SV_invertVB_P _) _) => + constructor; unfold iAlgebra; unfold SV_invertVB_P; intros i H n H0; + inversion H; subst; simpl in H0; revert H0; + match goal with H : proj1_sig ?v = _ |- proj1_sig ?v = _ -> _ => rewrite H end; intros; + elimtype False; apply (inject_discriminate _ _ _ H0). + +Hint Extern 1 (iPAlgebra SV_invertVB'_Name (SV_invertVB'_P _) _) => + constructor; unfold iAlgebra; unfold SV_invertVB'_P; intros i H n H0; + inversion H; subst; simpl in H0; revert H0; + match goal with H : proj1_sig ?v = _ |- proj1_sig ?v = _ -> _ => rewrite H end; intros; + elimtype False; apply (inject_discriminate _ _ _ H0). + +Ltac WF_invertVB_default := + constructor; unfold iAlgebra; intros i H; unfold WF_invertVB_P; + inversion H; simpl; + match goal with + eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ => + intro eq_H; rewrite eq_H in eq_H0; + elimtype False; eapply (inject_discriminate _ _ _ eq_H0) + end. + +Hint Extern 5 (iPAlgebra WF_invertVB_Name (WF_invertVB_P _ _ _) _) => + constructor; unfold iAlgebra; intros i H; unfold WF_invertVB_P; + inversion H; simpl; + match goal with + eq_H0 : proj1_sig ?T = _ |- proj1_sig ?T = _ -> _ => + intro eq_H; rewrite eq_H in eq_H0; + elimtype False; first [apply (inject_discriminate _ _ _ eq_H0) | + apply sym_eq in eq_H0; apply (inject_discriminate _ _ _ eq_H0)]; + fail + end : typeclass_instances. Hint Extern 0 => intros; match goal with diff --git a/Bool_Lambda.v b/Bool_Lambda.v index 582233b..5a05cdb 100644 --- a/Bool_Lambda.v +++ b/Bool_Lambda.v @@ -113,27 +113,28 @@ Section PLambda_Arith. (* EQUIVALENCE OF BOOLEAN EXPRESSIONS *) (* ============================================== *) - Inductive Bool_eqv (A B : Set) (C : eqv_i E A B -> Prop) : eqv_i E A B -> Prop := - | BLit_eqv : forall (gamma : Env _) gamma' n e e', - proj1_sig e = blit (E A) n -> - proj1_sig e' = blit (E B) n -> - Bool_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e') - | If_eqv : forall (gamma : Env _) gamma' i t el i' t' el' e e', - C (mk_eqv_i _ _ _ gamma gamma' i i') -> - C (mk_eqv_i _ _ _ gamma gamma' t t') -> - C (mk_eqv_i _ _ _ gamma gamma' el el') -> - proj1_sig e = proj1_sig (cond' _ i t el) -> - proj1_sig e' = proj1_sig (cond' _ i' t' el') -> - Bool_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e'). - - Lemma Bool_eqv_impl_NP_eqv : forall A B C i, - Bool_eqv A B C i -> NP_Functor_eqv E Bool A B C i. - intros; destruct H. - unfold blit, blit in *; simpl in *. - constructor 1 with (np := fun D => BLit D n); auto. - econstructor 4 with (np := fun D => If D); eauto. - simpl; congruence. - Defined. + Inductive Bool_eqv (A B : Set) (C : eqv_i E A B -> Prop) : eqv_i E A B -> Prop := + | BLit_eqv : forall (gamma : Env _) gamma' n e e', + proj1_sig e = blit (E A) n -> + proj1_sig e' = blit (E B) n -> + Bool_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e') + | If_eqv : forall (gamma : Env _) gamma' i t el i' t' el' e e', + C (mk_eqv_i _ _ _ gamma gamma' i i') -> + C (mk_eqv_i _ _ _ gamma gamma' t t') -> + C (mk_eqv_i _ _ _ gamma gamma' el el') -> + proj1_sig e = proj1_sig (cond' _ i t el) -> + proj1_sig e' = proj1_sig (cond' _ i' t' el') -> + Bool_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e'). + + Lemma Bool_eqv_impl_NP_eqv : forall A B C i, + Bool_eqv A B C i -> NP_Functor_eqv E Bool A B C i. + Proof. + intros; destruct H. + unfold blit, blit in *; simpl in *. + constructor 1 with (np := fun D => BLit D n); auto. + econstructor 4 with (np := fun D => If D); eauto. + simpl; congruence. + Defined. End PLambda_Arith. diff --git a/Functors.v b/Functors.v index e381475..d3a17eb 100644 --- a/Functors.v +++ b/Functors.v @@ -20,15 +20,16 @@ Section Folds. Definition MAlgebra (F: Set -> Set) (A : Set) := forall (R : Set), Mixin R F A. - Definition Fix (F : Set -> Set) : Set := + Definition Fix (F : Set -> Set) : Set := forall (A : Set), MAlgebra F A -> A. - Definition mfold {F : Set -> Set} : forall (A : Set) - (f : MAlgebra F A), Fix F -> A:= fun A f e => e A f. + Definition mfold {F : Set -> Set} : + forall (A : Set) (f : MAlgebra F A), + Fix F -> A:= fun A f e => e A f. Class Functor (F : Set -> Set) := - {fmap : - forall {A B : Set} (f : A -> B), F A -> F B; + { fmap : + forall {A B : Set} (f : A -> B), F A -> F B; fmap_fusion : forall (A B C: Set) (f : A -> B) (g : B -> C) (a : F A), fmap g (fmap f a) = fmap (fun e => g (f e)) a; @@ -42,7 +43,7 @@ Section Folds. Definition fold_ {F : Set -> Set} {functor : Functor F} : forall (A : Set) (f : Algebra F A), Fix F -> A := - fun A f e => mfold _ (fun r rec fa => f (fmap rec fa)) e. + fun A f => mfold _ (fun r rec fa => f (fmap rec fa)). Definition out_t {F : Set -> Set} {fun_F : Functor F} : Fix F -> F (Fix F) := @fold_ F fun_F _ (fmap in_t). @@ -59,11 +60,11 @@ Section Folds. | S n => fM (boundedFix n fM default) (out_t e) end. - (* Indexed Algebra *) + (* Indexed Algebra *) Definition iAlgebra {I : Set} (F : (I -> Prop) -> I -> Prop) (A : I -> Prop) := forall i, F A i -> A i. - (* Indexed Mendler Algebra *) + (* Indexed Mendler Algebra *) Definition iMAlgebra {I : Set} (F : (I -> Prop) -> I -> Prop) (A : I -> Prop) := forall i (R : I -> Prop), (forall i, R i -> A i) -> F R i -> A i. @@ -75,8 +76,8 @@ Section Folds. iFix F i -> A i := fun A f i e => e A f. Class iFunctor {I : Set} (F : (I -> Prop) -> I -> Prop) := - {ifmap : - forall {A B : I -> Prop} i (f : forall i, A i -> B i), F A i -> F B i; + { ifmap : + forall {A B : I -> Prop} i (f : forall i, A i -> B i), F A i -> F B i; ifmap_fusion : forall (A B C: I -> Prop) i (f : forall i, A i -> B i) (g : forall i, B i -> C i) (a : F A i), ifmap i g (ifmap i f a) = ifmap i (fun i e => g _ (f i e)) a; @@ -97,20 +98,19 @@ Section Folds. (* Universal Property of Mendler Folds *) - Lemma Universal_Property (F : Set -> Set) (A : Set) - (f : MAlgebra F A) : - forall (h : Fix F -> A), - h = mfold _ f -> forall e, h (in_t e) = f _ h e. + Lemma Universal_Property (F : Set -> Set) (A : Set) (f : MAlgebra F A) : + forall (h : Fix F -> A), + h = mfold _ f -> forall e, h (in_t e) = f _ h e. Proof. intros; rewrite H. unfold in_t. unfold mfold. reflexivity. Qed. Class Universal_Property' {F} {Fun_F : Functor F} (e : Fix F) := - {E_UP' : forall (A : Set) (f : MAlgebra F A) - (h : Fix F -> A), - (forall e, h (in_t e) = f _ h e) -> - h e = mfold _ f e}. + { E_UP' : forall (A : Set) (f : MAlgebra F A) (h : Fix F -> A), + (forall e, h (in_t e) = f _ h e) -> + h e = mfold _ f e + }. Lemma Fix_id F {fun_F : Functor F} e {UP' : Universal_Property' e} : mfold _ (fun _ rec x => in_t (fmap rec x)) e = e. @@ -133,17 +133,19 @@ Section Folds. Lemma Universal_Property_fold (F : Set -> Set) {fun_F : Functor F} (B : Set) (f : Algebra F B) : forall (h : Fix F -> B), h = fold_ _ f -> forall e, h (in_t e) = f (fmap h e). + Proof. intros; rewrite H; reflexivity. Qed. Class Universal_Property'_fold {F} {fun_F : Functor F} (e : Fix F) := - {E_fUP' : forall (B : Set) (f : Algebra F B) (h : Fix F -> B), - (forall e, h (in_t e) = f (fmap h e)) -> - h e = fold_ _ f e + { E_fUP' : forall (B : Set) (f : Algebra F B) (h : Fix F -> B), + (forall e, h (in_t e) = f (fmap h e)) -> + h e = fold_ _ f e }. Lemma Fix_id_fold F {fun_F : Functor F} e {UP' : Universal_Property'_fold e} : fold_ _ (@in_t F) e = e. + Proof. intros; apply sym_eq. fold (id e); unfold id at 2; apply (E_fUP'); intros. rewrite fmap_id. @@ -155,15 +157,17 @@ Section Folds. forall (A B : Set) (h : A -> B) (f : Algebra F A) (g : Algebra F B), (forall a, h (f a) = g (fmap h a)) -> (fun e' => h (fold_ _ f e')) e = fold_ _ g e. + Proof. intros; eapply E_fUP'; try eassumption; intros. rewrite (Universal_Property_fold F _ f _ (refl_equal _)). rewrite H. rewrite fmap_fusion; reflexivity. Qed. - Lemma in_out_inverse : forall (F : Set -> Set) (Fun_F : Functor F) (e : Fix F) - {fUP' : Universal_Property'_fold e}, - in_t (out_t e) = e. + Lemma in_out_inverse (F : Set -> Set) (Fun_F : Functor F) : + forall (e : Fix F) {fUP' : Universal_Property'_fold e}, + in_t (out_t e) = e. + Proof. intros. rewrite <- (@Fix_id_fold _ _ e fUP') at -1. eapply E_fUP' with (h := fun e => in_t (out_t e)). @@ -186,12 +190,12 @@ Section Folds. rewrite fmap_fusion; reflexivity. Qed. - Definition in_t_UP' : forall (F : Set -> Set) - (Fun_F : Functor F), + Definition in_t_UP' (F : Set -> Set) (Fun_F : Functor F) : F (sig (@Universal_Property'_fold F Fun_F)) -> sig (@Universal_Property'_fold F Fun_F). - intros F Fun_F e. - intros; constructor 1 with (x := in_t (fmap (@proj1_sig _ _) e)). + Proof. + intro e; intros. + constructor 1 with (x := in_t (fmap (@proj1_sig _ _) e)). constructor; intros. rewrite H. unfold fold_, mfold. @@ -206,11 +210,10 @@ Section Folds. rewrite H0; reflexivity. Defined. - Definition out_t_UP' : - forall (F : Set -> Set) - (Fun_F : Functor F) - (e : Fix F), + Definition out_t_UP' (F : Set -> Set) (Fun_F : Functor F) : + forall (e : Fix F), F (sig (@Universal_Property'_fold F Fun_F)). + Proof. intros. eapply fold_; try assumption. unfold Algebra; intros. @@ -219,10 +222,10 @@ Section Folds. assumption. Defined. - Lemma out_in_inverse : forall (F : Set -> Set) - (Fun_F : Functor F) - (e : F (sig (@Universal_Property'_fold F Fun_F))), - out_t (in_t (fmap (@proj1_sig _ _) e)) = fmap (@proj1_sig _ _) e. + Lemma out_in_inverse (F : Set -> Set) (Fun_F : Functor F) : + forall (e : F (sig (@Universal_Property'_fold F Fun_F))), + out_t (in_t (fmap (@proj1_sig _ _) e)) = fmap (@proj1_sig _ _) e. + Proof. intros. unfold out_t. erewrite Universal_Property_fold; try reflexivity. @@ -237,20 +240,20 @@ Section Folds. rewrite H; reflexivity. Qed. - Lemma in_t_UP'_inject : forall (F : Set -> Set) - (Fun_F : Functor F) - (e e' : F (sig (@Universal_Property'_fold F Fun_F))), - in_t (fmap (@proj1_sig _ _) e) = in_t (fmap (@proj1_sig _ _) e') -> - fmap (@proj1_sig _ _) e = fmap (@proj1_sig _ _) e'. + Lemma in_t_UP'_inject (F : Set -> Set) (Fun_F : Functor F) : + forall (e e' : F (sig (@Universal_Property'_fold F Fun_F))), + in_t (fmap (@proj1_sig _ _) e) = in_t (fmap (@proj1_sig _ _) e') -> + fmap (@proj1_sig _ _) e = fmap (@proj1_sig _ _) e'. + Proof. intros; apply (f_equal out_t) in H; repeat rewrite out_in_inverse in H; eauto. Qed. - Lemma in_out_UP'_inverse : forall (H : Set -> Set) - (Fun_H : Functor H) - (h : Fix H), - Universal_Property'_fold h -> - proj1_sig (in_t_UP' H Fun_H (out_t_UP' H Fun_H h)) = h. + Lemma in_out_UP'_inverse (H : Set -> Set) (Fun_H : Functor H) : + forall (h : Fix H), + Universal_Property'_fold h -> + proj1_sig (in_t_UP' H Fun_H (out_t_UP' H Fun_H h)) = h. + Proof. intros; simpl. assert ((fmap (@proj1_sig _ _) (out_t_UP' H Fun_H h)) = out_t h). unfold out_t. @@ -258,7 +261,7 @@ Section Folds. intros. rewrite fmap_fusion. assert (out_t_UP' H Fun_H (in_t e) = - fmap (fun e => in_t_UP' _ _ (out_t_UP' _ _ e)) e). + fmap (fun e => in_t_UP' _ _ (out_t_UP' _ _ e)) e). unfold out_t_UP' at 1. erewrite Universal_Property_fold with (f := (fun H2 : H (H (sig Universal_Property'_fold)) => @@ -269,11 +272,11 @@ Section Folds. rewrite in_out_inverse; unfold mfold; eauto. Qed. - Lemma out_in_fmap : forall (F : Set -> Set) - (Fun_F : Functor F) - (e : F (Fix F)), - out_t_UP' F _ (in_t e) = - fmap (fun e => in_t_UP' _ _ (out_t_UP' _ _ e)) e. + Lemma out_in_fmap (F : Set -> Set) (Fun_F : Functor F) : + forall (e : F (Fix F)), + out_t_UP' F _ (in_t e) = + fmap (fun e => in_t_UP' _ _ (out_t_UP' _ _ e)) e. + Proof. intros; unfold out_t_UP' at 1. erewrite Universal_Property_fold with (f := (fun H2 : F (F (sig Universal_Property'_fold)) => @@ -329,13 +332,16 @@ Section Folds. Notation "A :+: B" := (@inj_Functor A B) (at level 80, right associativity). - Global Instance Functor_Plus G H {fun_G : Functor G} {fun_H : Functor H} : Functor (G :+: H). - econstructor 1 with (fmap := - fun (A B : Set) (f : A -> B) (a : (G :+: H) A) => - match a with - | inl G' => inl _ (fmap f G') - | inr H' => inr _ (fmap f H') - end). + Global Instance Functor_Plus G H {fun_G : Functor G} {fun_H : Functor H} : + Functor (G :+: H) := + {| fmap := + fun (A B : Set) (f : A -> B) (a : (G :+: H) A) => + match a with + | inl G' => inl _ (fmap f G') + | inr H' => inr _ (fmap f H') + end + |}. + Proof. (* fmap_fusion *) intros; destruct a; rewrite fmap_fusion; reflexivity. @@ -348,9 +354,9 @@ Section Folds. { inj : forall {A : Set}, sub_F A -> sub_G A; prj : forall {A : Set}, sub_G A -> option (sub_F A); inj_prj : forall {A : Set} (ga : sub_G A) (fa : sub_F A), - prj ga = Some fa -> ga = inj fa; + prj ga = Some fa -> ga = inj fa; prj_inj : forall {A : Set} (fa : sub_F A), - prj (inj fa) = Some fa + prj (inj fa) = Some fa }. Notation "A :<: B" := (Sub_Functor A B) (at level 80, right associativity). @@ -358,13 +364,14 @@ Section Folds. (* Need the 'Global' modifier so that the instance survives the Section.*) Global Instance Sub_Functor_inl (F G H : Set -> Set) (sub_F_G : F :<: G) : F :<: (G :+: H) := - {| inj := (fun (A : Set) (e : F A) => inl _ (@inj F G sub_F_G _ e)); + {| inj := fun (A : Set) (e : F A) => inl _ (@inj F G sub_F_G _ e); prj := fun (A: Set) (e : (G :+: H) A) => - match e with - | inl e' => prj e' - | inr _ => None - end - |}. + match e with + | inl e' => prj e' + | inr _ => None + end + |}. + Proof. intros; destruct ga; [rewrite (inj_prj _ _ H0); reflexivity | discriminate]. intros; simpl; rewrite prj_inj; reflexivity. Defined. @@ -373,18 +380,21 @@ Section Folds. F :<: (G :+: H) := {| inj := fun (A : Set) (e : F A) => inr _ (@inj F H sub_F_H _ e); prj := fun (A : Set) (e : (G :+: H) A) => - match e with - | inl _ => None - | inr e' => prj e' - end - |}. + match e with + | inl _ => None + | inr e' => prj e' + end + |}. + Proof. intros; destruct ga; [discriminate | rewrite (inj_prj _ _ H0); reflexivity ]. intros; simpl; rewrite prj_inj; reflexivity. Defined. Global Instance Sub_Functor_id {F : Set -> Set} : F :<: F := {| inj := fun A => @id (F A); - prj := fun A => @Some (F A) |}. + prj := fun A => @Some (F A) + |}. + Proof. unfold id; congruence. reflexivity. Defined. @@ -398,11 +408,13 @@ Section Folds. (Fun_F: Functor F) (Fun_G: Functor G): Set := { wf_functor : - forall (A B : Set) (f : A -> B) (fa: F A) , - fmap f (inj fa) (F := G) = inj (fmap f fa) }. + forall (A B : Set) (f : A -> B) (fa: F A) , + fmap f (inj fa) (F := G) = inj (fmap f fa) + }. Global Instance WF_Functor_id {F : Set -> Set} {Fun_F : Functor F} : WF_Functor F F Sub_Functor_id _ _. + Proof. econstructor; intros; reflexivity. Defined. @@ -414,6 +426,7 @@ Section Folds. {WF_Fun_F : WF_Functor F _ subfg Fun_F Fun_G} : WF_Functor F (G :+: H) (Sub_Functor_inl F G H _ ) _ (Functor_Plus G H). + Proof. econstructor; intros. simpl; rewrite wf_functor; reflexivity. Defined. @@ -426,6 +439,7 @@ Section Folds. {WF_Fun_F : WF_Functor F _ subfh Fun_F Fun_H} : WF_Functor F (G :+: H) (Sub_Functor_inr F G H _ ) _ (Functor_Plus G H). + Proof. econstructor; intros. simpl; rewrite wf_functor; reflexivity. Defined. @@ -434,7 +448,6 @@ Section Folds. (* INJECTION + PROJECTION *) (* ============================================== *) - Definition inject' {F G: Set -> Set} {Fun_F : Functor F} {subGF: G :<: F} : G (sig (@Universal_Property'_fold F Fun_F)) -> (sig (@Universal_Property'_fold F Fun_F)) := fun gexp => in_t_UP' _ _ (inj gexp). @@ -454,6 +467,7 @@ Section Folds. (h : Fix H) (g : G (sig (@Universal_Property'_fold H Fun_H))), Universal_Property'_fold h -> project h = Some g -> h = inject g. + Proof. intros. apply inj_prj in H1. unfold inject; rewrite <- H1. @@ -467,6 +481,7 @@ Section Folds. (g : G (sig (@Universal_Property'_fold F Fun_F))), fmap (@proj1_sig _ _) (out_t_UP' _ _ (inject g)) = (fmap (@proj1_sig _ _) (inj g)). + Proof. unfold inject; intros; simpl. rewrite out_in_fmap. rewrite fmap_fusion. @@ -484,8 +499,11 @@ Section Folds. (sub_F_H : F :<: H) (sub_G_H : G :<: H) : Set := - {inj_discriminate : forall A f g, - inj (Sub_Functor := sub_F_H) (A := A) f <> inj (Sub_Functor := sub_G_H) (A := A) g}. + { inj_discriminate : + forall A f g, + inj (Sub_Functor := sub_F_H) (A := A) f + <> inj (Sub_Functor := sub_G_H) (A := A) g + }. Global Instance Distinct_Sub_Functor_plus (F G H I : Set -> Set) @@ -495,6 +513,7 @@ Section Folds. (sub_H_I : H :<: I) : @Distinct_Sub_Functor F H (G :+: I) _ _ _. + Proof. econstructor; intros. unfold not; simpl; unfold id; intros. discriminate. @@ -508,6 +527,7 @@ Section Folds. (sub_H_I : H :<: I) : @Distinct_Sub_Functor F H (I :+: G) _ _ _. + Proof. econstructor; intros. unfold not; simpl; unfold id; intros. discriminate. @@ -522,6 +542,7 @@ Section Folds. (Dist_inl : @Distinct_Sub_Functor F H G Fun_G sub_F_G sub_H_G) : @Distinct_Sub_Functor F H (G :+: I) _ _ _. + Proof. econstructor; intros. unfold not; intros. simpl in H0; injection H0; intros. @@ -537,6 +558,7 @@ Section Folds. (Dist_inl : @Distinct_Sub_Functor F H G Fun_G sub_F_G sub_H_G) : @Distinct_Sub_Functor F H (I :+: G) _ _ _. + Proof. econstructor; intros. unfold not; intros. simpl in H0; injection H0; intros. @@ -553,6 +575,7 @@ Section Folds. {WF_G : WF_Functor _ _ sub_G_H Fun_G Fun_H}, Distinct_Sub_Functor Fun_H sub_F_H sub_G_H -> forall f g, inject (subGF := sub_F_H) f <> inject (subGF := sub_G_H) g. + Proof. unfold inject; simpl; intros. unfold not; intros H3; apply in_t_UP'_inject in H3. repeat rewrite wf_functor in H3. @@ -569,13 +592,15 @@ Section Folds. Notation "A ::+:: B" := (@inj_iFunctor _ A B) (at level 80, right associativity). Global Instance iFunctor_Plus {I : Set} (G H : (I -> Prop) -> I -> Prop) - {fun_G : iFunctor G} {fun_H : iFunctor H} : iFunctor (G ::+:: H). - econstructor 1 with (ifmap := - fun (A B : I -> Prop) (i : I) (f : forall i, A i -> B i) (a : (G ::+:: H) A i) => - match a with - | or_introl G' => or_introl _ (ifmap i f G') - | or_intror H' => or_intror _ (ifmap i f H') - end). + {fun_G : iFunctor G} {fun_H : iFunctor H} : iFunctor (G ::+:: H) := + {| ifmap := + fun (A B : I -> Prop) (i : I) (f : forall i, A i -> B i) (a : (G ::+:: H) A i) => + match a with + | or_introl G' => or_introl _ (ifmap i f G') + | or_intror H' => or_intror _ (ifmap i f H') + end + |}. + Proof. (* ifmap_fusion *) intros; destruct a; rewrite ifmap_fusion; reflexivity. @@ -595,29 +620,30 @@ Section Folds. Global Instance Sub_iFunctor_inl {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop) (sub_F_G : F ::<:: G) : F ::<:: (G ::+:: H) := - {| inj_i := (fun (A : I' -> Prop) i (e : F A i) => - or_introl _ (@inj_i _ F G sub_F_G _ _ e)); - prj_i := fun (A: I' -> Prop) i (e : (G ::+:: H) A i) => - match e with - | or_introl e' => prj_i _ e' - | or_intror _ => or_intror _ I - end + {| inj_i := fun (A : I' -> Prop) i (e : F A i) => + or_introl _ (@inj_i _ F G sub_F_G _ _ e); + prj_i := fun (A: I' -> Prop) i (e : (G ::+:: H) A i) => + match e with + | or_introl e' => prj_i _ e' + | or_intror _ => or_intror _ I + end |}. Global Instance Sub_iFunctor_inr {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop) (sub_F_H : F ::<:: H) : F ::<:: (G ::+:: H) := - {| inj_i := (fun (A : I' -> Prop) i (e : F A i) => - or_intror _ (@inj_i _ F H sub_F_H _ _ e)); - prj_i := fun (A: I' -> Prop) i (e : (G ::+:: H) A i) => - match e with - | or_intror e' => prj_i _ e' - | or_introl _ => or_intror _ I - end + {| inj_i := fun (A : I' -> Prop) i (e : F A i) => + or_intror _ (@inj_i _ F H sub_F_H _ _ e); + prj_i := fun (A: I' -> Prop) i (e : (G ::+:: H) A i) => + match e with + | or_intror e' => prj_i _ e' + | or_introl _ => or_intror _ I + end |}. Global Instance Sub_iFunctor_id {I : Set} {F : (I -> Prop) -> I -> Prop} : F ::<:: F := {| inj_i := fun A i e => e; - prj_i := fun A i e => or_introl _ e |}. + prj_i := fun A i e => or_introl _ e + |}. Definition inject_i {I : Set} {F G: (I -> Prop) -> I -> Prop} {subGF: Sub_iFunctor G F} : forall i, G (iFix F) i -> iFix F i:= @@ -660,11 +686,12 @@ Section FAlgebra. Global Instance FAlgebra_Plus (Name: Set) (T: Set) (A : Set) (F G : Set -> Set) {falg: FAlgebra Name T A F} {galg: FAlgebra Name T A G} : FAlgebra Name T A (F :+: G) | 6 := - {| f_algebra := fun f fga=> - (match fga with - | inl fa => f_algebra f fa - | inr ga => f_algebra f ga - end) |}. + {| f_algebra := fun f fga => + match fga with + | inl fa => f_algebra f fa + | inr ga => f_algebra f ga + end + |}. (* The | 6 gives the generated Hint a priority of 6. If this is less than that of other instances for FAlgebra, the @@ -676,16 +703,19 @@ Section FAlgebra. (falg: FAlgebra Name T A F) (galg: FAlgebra Name T A G): Set := { wf_algebra : - forall rec (fa: F T), - @f_algebra Name T A G galg rec (@inj F G subfg T fa) = @f_algebra Name T A F falg rec fa }. + forall rec (fa: F T), + @f_algebra Name T A G galg rec (@inj F G subfg T fa) + = @f_algebra Name T A F falg rec fa + }. Global Instance WF_FAlgebra_id {Name T A : Set} {F} {falg: FAlgebra Name T A F}: WF_FAlgebra Name T A F F Sub_Functor_id falg falg. - econstructor. intros. - unfold inj. - unfold Sub_Functor_id. - unfold id. - reflexivity. + Proof. + econstructor. intros. + unfold inj. + unfold Sub_Functor_id. + unfold id. + reflexivity. Defined. Global Instance WF_FAlgebra_inl @@ -698,11 +728,12 @@ Section FAlgebra. {wf_F_G: WF_FAlgebra Name T A F G sub_F_G falg galg} : WF_FAlgebra Name T A F (G :+: H) (Sub_Functor_inl F G H sub_F_G) falg (@FAlgebra_Plus Name T A G H galg halg). - econstructor. intros. - unfold inj. unfold Sub_Functor_inl. - simpl. - rewrite (wf_algebra rec fa). - reflexivity. + Proof. + econstructor. intros. + unfold inj. unfold Sub_Functor_inl. + simpl. + rewrite (wf_algebra rec fa). + reflexivity. Defined. Global Instance WF_FAlgebra_inr @@ -715,13 +746,14 @@ Section FAlgebra. {wf_G_H: WF_FAlgebra Name T A F H sub_F_H falg halg} : WF_FAlgebra Name T A F (G :+: H) (Sub_Functor_inr F G H sub_F_H) falg (@FAlgebra_Plus Name T A G H galg halg). - econstructor. intros. - unfold inj. - unfold Sub_Functor_inr. - simpl. - rewrite (wf_algebra rec fa). - reflexivity. - Defined. + Proof. + econstructor. intros. + unfold inj. + unfold Sub_Functor_inr. + simpl. + rewrite (wf_algebra rec fa). + reflexivity. + Defined. End FAlgebra. @@ -748,42 +780,48 @@ Section WF_Ind_FAlgebras. {falg: PAlgebra Name A F} {galg: PAlgebra Name A G} : PAlgebra Name A (F :+: G) | 6 := {| p_algebra := fun fga => - (match fga with - | inl fa => p_algebra fa - | inr ga => p_algebra ga - end) |}. + match fga with + | inl fa => p_algebra fa + | inr ga => p_algebra ga + end + |}. Class WF_Ind {E F: Set -> Set} {Name : Set} {Fun_E : Functor E} {Fun_F : Functor F} {P : Fix E -> Prop} {sub_F_E : F :<: E} (F_Alg : PAlgebra Name (sig P) F) := - {proj_eq : forall e, proj1_sig (p_algebra (PAlgebra := F_Alg) e) = - in_t (inj (Sub_Functor := sub_F_E) (fmap (@proj1_sig _ _) e))}. - - Definition Sub_Functor_inl' (F G H : Set -> Set) (sub_F_G : (F :+: G) :<: H) : - F :<: H. - econstructor 1 with - (inj := fun (A : Set) (e : F A) => (@inj _ _ sub_F_G A (inl _ e))) - (prj := fun (A : Set) (ha : H A) => - match @prj _ _ sub_F_G A ha with - | Some (inl f) => Some f - | Some (inr g) => None - | None => None - end). + { proj_eq : + forall e, + proj1_sig (p_algebra (PAlgebra := F_Alg) e) = + in_t (inj (Sub_Functor := sub_F_E) (fmap (@proj1_sig _ _) e)) + }. + + Instance Sub_Functor_inl' (F G H : Set -> Set) (sub_F_G : (F :+: G) :<: H) : + F :<: H := + {| inj := fun (A : Set) (e : F A) => @inj _ _ sub_F_G A (inl _ e); + prj := fun (A : Set) (ha : H A) => + match @prj _ _ sub_F_G A ha with + | Some (inl f) => Some f + | Some (inr g) => None + | None => None + end + |}. + Proof. intros until fa; caseEq (prj ga); [rewrite (inj_prj _ _ H0); destruct i; congruence | discriminate]. intros; rewrite prj_inj; reflexivity. Defined. - Definition Sub_Functor_inr' (F G H : Set -> Set) (sub_F_G : (F :+: G) :<: H) : - G :<: H. - econstructor 1 with - (inj := fun (A : Set) (e : G A) => (@inj _ _ sub_F_G A (inr _ e))) - (prj := fun (A : Set) (H0 : H A) => - match @prj _ _ sub_F_G A H0 with - | Some (inl f) => None - | Some (inr g) => Some g - | None => None - end). + Instance Sub_Functor_inr' (F G H : Set -> Set) (sub_F_G : (F :+: G) :<: H) : + G :<: H := + {| inj := fun (A : Set) (e : G A) => (@inj _ _ sub_F_G A (inr _ e)); + prj := fun (A : Set) (H0 : H A) => + match @prj _ _ sub_F_G A H0 with + | Some (inl f) => None + | Some (inr g) => Some g + | None => None + end + |}. + Proof. intros until fa; caseEq (prj ga); [rewrite (inj_prj _ _ H0); destruct i; congruence | discriminate]. intros; rewrite prj_inj; reflexivity. @@ -804,45 +842,51 @@ Section WF_Ind_FAlgebras. G_Alg) : @WF_Ind H (F :+: G) _ _ _ P _ (PAlgebra_Plus Name _ F G) | 0. - econstructor; intros. - destruct e; simpl. - rewrite (proj_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H)); simpl; - reflexivity. - rewrite (proj_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H)); simpl; - reflexivity. - Defined. - - (* The key reasoning lemma. *) - Lemma Ind {F : Set -> Set} - {Fun_F : Functor F} - {P : Fix F -> Prop} - {N : Set} - {Ind_Alg : PAlgebra N (sig P) F} - {WF_Ind_Alg : WF_Ind Ind_Alg} - : - forall (f : Fix F) - (fUP' : Universal_Property'_fold f), - P f. - intros. - cut (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f) = id f). - unfold id. - intro f_eq; rewrite <- f_eq. - eapply (proj2_sig (fold_ _ (@p_algebra _ _ _ Ind_Alg) f)). - erewrite (@Fusion _ Fun_F f fUP' _ _ (@proj1_sig (Fix F) P) - (@p_algebra _ _ _ Ind_Alg) in_t). - eapply Fix_id_fold; unfold id; assumption. - intros; rewrite (proj_eq (WF_Ind := WF_Ind_Alg)). - simpl; unfold id; reflexivity. - Defined. + Proof. + econstructor; intros. + destruct e; simpl. + rewrite (proj_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H)); simpl; + reflexivity. + rewrite (proj_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H)); simpl; + reflexivity. + Defined. + + (* The key reasoning lemma. *) + Lemma Ind {F : Set -> Set} + {Fun_F : Functor F} + {P : Fix F -> Prop} + {N : Set} + {Ind_Alg : PAlgebra N (sig P) F} + {WF_Ind_Alg : WF_Ind Ind_Alg} + : + forall (f : Fix F) + (fUP' : Universal_Property'_fold f), + P f. + Proof. + intros. + cut (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f) = id f). + unfold id. + intro f_eq; rewrite <- f_eq. + eapply (proj2_sig (fold_ _ (@p_algebra _ _ _ Ind_Alg) f)). + erewrite (@Fusion _ Fun_F f fUP' _ _ (@proj1_sig (Fix F) P) + (@p_algebra _ _ _ Ind_Alg) in_t). + eapply Fix_id_fold; unfold id; assumption. + intros; rewrite (proj_eq (WF_Ind := WF_Ind_Alg)). + simpl; unfold id; reflexivity. + Defined. Class WF_Ind2 {E E' F: Set -> Set} {Name : Set} {Fun_E : Functor E} {Fun_E : Functor E'} {Fun_F : Functor F} {P : (Fix E) * (Fix E') -> Prop} {sub_F_E : F :<: E} {sub_F_E' : F :<: E'} (F_Alg : PAlgebra Name (sig P) F) := - {proj1_eq : forall e, fst (proj1_sig (p_algebra (PAlgebra := F_Alg) e)) = - in_t (inj (Sub_Functor := sub_F_E) (fmap (fun e => fst (proj1_sig e)) e)); - proj2_eq : forall e, snd (proj1_sig (p_algebra (PAlgebra := F_Alg) e)) = - in_t (inj (Sub_Functor := sub_F_E') (fmap (fun e => snd (proj1_sig e)) e)) + { proj1_eq : + forall e, + fst (proj1_sig (p_algebra (PAlgebra := F_Alg) e)) = + in_t (inj (Sub_Functor := sub_F_E) (fmap (fun e => fst (proj1_sig e)) e)); + proj2_eq : + forall e, + snd (proj1_sig (p_algebra (PAlgebra := F_Alg) e)) = + in_t (inj (Sub_Functor := sub_F_E') (fmap (fun e => snd (proj1_sig e)) e)) }. Global Instance WF_Ind2_Plus_split {F G H H'} @@ -864,105 +908,114 @@ Section WF_Ind_FAlgebras. G_Alg) : @WF_Ind2 H H' (F :+: G) _ _ _ _ P _ _ (PAlgebra_Plus Name _ F G) | 0. - econstructor; intros; destruct e; simpl. - rewrite (proj1_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H) - (sub_F_E' := Sub_Functor_inl' _ _ _ sub_F_G_H')); simpl; - reflexivity. - rewrite (proj1_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H) - (sub_F_E' := Sub_Functor_inr' _ _ _ sub_F_G_H')); simpl; - reflexivity. - rewrite (proj2_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H) - (sub_F_E' := Sub_Functor_inl' _ _ _ sub_F_G_H')); simpl; - reflexivity. - rewrite (proj2_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H) - (sub_F_E' := Sub_Functor_inr' _ _ _ sub_F_G_H')); simpl; - reflexivity. - Defined. - - Lemma Ind2 {F : Set -> Set} - {Fun_F : Functor F} - {P : (Fix F) * (Fix F) -> Prop} - {N : Set} - {Ind_Alg : PAlgebra N (sig P) F} - {WF_Ind_Alg : WF_Ind2 Ind_Alg} - : - forall (f : Fix F) - (fUP' : Universal_Property'_fold f), - P (f, f). - intros. - cut (fst (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f)) = f). - cut (snd (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f)) = f). - intros f2_eq f1_eq; rewrite <- f1_eq at 1; rewrite <- f2_eq at -1. - generalize (proj2_sig (fold_ _ (@p_algebra _ _ _ Ind_Alg) f)). - destruct (proj1_sig (fold_ (sig P) p_algebra f)); simpl; auto. - erewrite (@Fusion _ Fun_F f fUP' _ _ (fun e => snd (proj1_sig e)) - (@p_algebra _ _ _ Ind_Alg) in_t). - eapply Fix_id_fold; unfold id; assumption. - intros; rewrite (proj2_eq (WF_Ind2 := WF_Ind_Alg)). - simpl; unfold id; reflexivity. - erewrite (@Fusion _ Fun_F f fUP' _ _ (fun e => fst (proj1_sig e)) - (@p_algebra _ _ _ Ind_Alg) in_t). - eapply Fix_id_fold; unfold id; assumption. - intros; rewrite (proj1_eq (WF_Ind2 := WF_Ind_Alg)). - simpl; unfold id; reflexivity. - Defined. - - Class iPAlgebra (Name : Set) {I : Set} (A : I -> Prop) (F: (I -> Prop) -> I -> Prop) : Prop := + Proof. + econstructor; intros; destruct e; simpl. + rewrite (proj1_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H) + (sub_F_E' := Sub_Functor_inl' _ _ _ sub_F_G_H')); simpl; + reflexivity. + rewrite (proj1_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H) + (sub_F_E' := Sub_Functor_inr' _ _ _ sub_F_G_H')); simpl; + reflexivity. + rewrite (proj2_eq (sub_F_E := Sub_Functor_inl' _ _ _ sub_F_G_H) + (sub_F_E' := Sub_Functor_inl' _ _ _ sub_F_G_H')); simpl; + reflexivity. + rewrite (proj2_eq (sub_F_E := Sub_Functor_inr' _ _ _ sub_F_G_H) + (sub_F_E' := Sub_Functor_inr' _ _ _ sub_F_G_H')); simpl; + reflexivity. + Defined. + + Lemma Ind2 {F : Set -> Set} + {Fun_F : Functor F} + {P : (Fix F) * (Fix F) -> Prop} + {N : Set} + {Ind_Alg : PAlgebra N (sig P) F} + {WF_Ind_Alg : WF_Ind2 Ind_Alg} + : + forall (f : Fix F) + (fUP' : Universal_Property'_fold f), + P (f, f). + Proof. + intros. + cut (fst (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f)) = f). + cut (snd (proj1_sig (fold_ _(@p_algebra _ _ _ Ind_Alg) f)) = f). + intros f2_eq f1_eq; rewrite <- f1_eq at 1; rewrite <- f2_eq at -1. + generalize (proj2_sig (fold_ _ (@p_algebra _ _ _ Ind_Alg) f)). + destruct (proj1_sig (fold_ (sig P) p_algebra f)); simpl; auto. + erewrite (@Fusion _ Fun_F f fUP' _ _ (fun e => snd (proj1_sig e)) + (@p_algebra _ _ _ Ind_Alg) in_t). + eapply Fix_id_fold; unfold id; assumption. + intros; rewrite (proj2_eq (WF_Ind2 := WF_Ind_Alg)). + simpl; unfold id; reflexivity. + erewrite (@Fusion _ Fun_F f fUP' _ _ (fun e => fst (proj1_sig e)) + (@p_algebra _ _ _ Ind_Alg) in_t). + eapply Fix_id_fold; unfold id; assumption. + intros; rewrite (proj1_eq (WF_Ind2 := WF_Ind_Alg)). + simpl; unfold id; reflexivity. + Defined. + + Class iPAlgebra (Name : Set) {I : Set} (A : I -> Prop) (F: (I -> Prop) -> I -> Prop) : Prop := { ip_algebra : iAlgebra F A}. - (* Definition iPAlgebra_Plus (Name: Set) {I : Set} (A : I -> Prop) - (F G : (I -> Prop) -> I -> Prop) - {falg: iPAlgebra Name A F} {galg: iPAlgebra Name A G} : - iPAlgebra Name A (F ::+:: G) := - Build_iPAlgebra Name _ A _ - (fun f fga => - (match fga with - | or_introl fa => ip_algebra f fa - | or_intror ga => ip_algebra f ga - end)). *) - - Global Instance iPAlgebra_Plus (Name: Set) {I : Set} (A : I -> Prop) - (F G : (I -> Prop) -> I -> Prop) - {falg: iPAlgebra Name A F} {galg: iPAlgebra Name A G} : - iPAlgebra Name A (F ::+:: G) | 6 := - {| ip_algebra := fun f fga => - (match fga with - | or_introl fa => ip_algebra f fa - | or_intror ga => ip_algebra f ga - end) |}. + (* Definition iPAlgebra_Plus (Name: Set) {I : Set} (A : I -> Prop) + (F G : (I -> Prop) -> I -> Prop) + {falg: iPAlgebra Name A F} {galg: iPAlgebra Name A G} : + iPAlgebra Name A (F ::+:: G) := + Build_iPAlgebra Name _ A _ + (fun f fga => + (match fga with + | or_introl fa => ip_algebra f fa + | or_intror ga => ip_algebra f ga + end)). *) + + Global Instance iPAlgebra_Plus (Name: Set) {I : Set} (A : I -> Prop) + (F G : (I -> Prop) -> I -> Prop) + {falg: iPAlgebra Name A F} {galg: iPAlgebra Name A G} : + iPAlgebra Name A (F ::+:: G) | 6 := + {| ip_algebra := fun f fga => + match fga with + | or_introl fa => ip_algebra f fa + | or_intror ga => ip_algebra f ga + end + |}. Class iWF_Ind {I : Set} {E F: (I -> Prop) -> I -> Prop} {Name : Set} {Fun_E : iFunctor E} {Fun_F : iFunctor F} {P : forall i, iFix E i -> Prop} {sub_F_E : Sub_iFunctor F E} (F_Alg : iPAlgebra Name (fun i => sig (P i)) F) := - {iproj_eq : forall i e, proj1_sig (ip_algebra (iPAlgebra := F_Alg) i e) = - in_ti i (inj_i (Sub_iFunctor := sub_F_E) i (ifmap i (fun i => proj1_sig (P := P i)) e))}. + { iproj_eq : + forall i e, + proj1_sig (ip_algebra (iPAlgebra := F_Alg) i e) = + in_ti i (inj_i (Sub_iFunctor := sub_F_E) i + (ifmap i (fun i => proj1_sig (P := P i)) e)) + }. Definition Sub_iFunctor_inl' {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop) (isub_F_G : Sub_iFunctor (F ::+:: G) H) : Sub_iFunctor F H := {| inj_i := fun (A : I' -> Prop) (i : I') (fai : F A i) => - @inj_i _ _ _ isub_F_G _ _ (or_introl (G A i) fai); - prj_i := fun (A : I' -> Prop) (i : I') (hai : H A i) => - let o := prj_i i hai in - match o with - | or_introl (or_introl H2) => or_introl True H2 - | or_introl (or_intror _) => or_intror (F A i) I - | or_intror H1 => or_intror (F A i) H1 - end |}. + @inj_i _ _ _ isub_F_G _ _ (or_introl (G A i) fai); + prj_i := fun (A : I' -> Prop) (i : I') (hai : H A i) => + let o := prj_i i hai in + match o with + | or_introl (or_introl H2) => or_introl True H2 + | or_introl (or_intror _) => or_intror (F A i) I + | or_intror H1 => or_intror (F A i) H1 + end + |}. Definition Sub_iFunctor_inr' {I' : Set} (F G H : (I' -> Prop) -> I' -> Prop) (isub_F_G : Sub_iFunctor (F ::+:: G) H) : Sub_iFunctor G H := {| inj_i := fun (A : I' -> Prop) (i : I') (gai : G A i) => - @inj_i _ _ _ isub_F_G _ _ (or_intror _ gai); - prj_i := fun (A : I' -> Prop) (i : I') (hai : H A i) => - let o := prj_i i hai in - match o with - | or_introl (or_intror H2) => or_introl True H2 - | or_introl (or_introl _) => or_intror _ I - | or_intror H1 => or_intror _ H1 - end |}. + @inj_i _ _ _ isub_F_G _ _ (or_intror _ gai); + prj_i := fun (A : I' -> Prop) (i : I') (hai : H A i) => + let o := prj_i i hai in + match o with + | or_introl (or_intror H2) => or_introl True H2 + | or_introl (or_introl _) => or_intror _ I + | or_intror H1 => or_intror _ H1 + end + |}. Global Instance iWF_Ind_Plus_split {I : Set} {F G H : (I -> Prop) -> I -> Prop} @@ -980,13 +1033,14 @@ Section WF_Ind_FAlgebras. G_Alg} : @iWF_Ind _ H (F ::+:: G) _ _ _ P _ (iPAlgebra_Plus Name _ F G) | 0. - econstructor; intros. - destruct e; simpl. - rewrite (iproj_eq (sub_F_E := @Sub_iFunctor_inl' _ _ _ _ sub_F_G_H)); simpl; - reflexivity. - rewrite (iproj_eq (sub_F_E := @Sub_iFunctor_inr' _ _ _ _ sub_F_G_H)); simpl; - reflexivity. - Defined. + Proof. + econstructor; intros. + destruct e; simpl. + rewrite (iproj_eq (sub_F_E := @Sub_iFunctor_inl' _ _ _ _ sub_F_G_H)); simpl; + reflexivity. + rewrite (iproj_eq (sub_F_E := @Sub_iFunctor_inr' _ _ _ _ sub_F_G_H)); simpl; + reflexivity. + Defined. End WF_Ind_FAlgebras. @@ -998,9 +1052,11 @@ Section WF_MAlgebras. Class WF_MAlgebra {Name : Set} {F : Set -> Set} {A : Set} {Fun_F : Functor F}(MAlg : forall R, FAlgebra Name R A F) := - {wf_malgebra : forall (T T' : Set) (f : T' -> T) (rec : T -> A) (ft : F T'), - f_algebra (FAlgebra := MAlg T) rec (fmap f ft) = - f_algebra (FAlgebra := MAlg T') (fun ft' => rec (f ft')) ft}. + { wf_malgebra : + forall (T T' : Set) (f : T' -> T) (rec : T -> A) (ft : F T'), + f_algebra (FAlgebra := MAlg T) rec (fmap f ft) = + f_algebra (FAlgebra := MAlg T') (fun ft' => rec (f ft')) ft + }. Global Instance WF_MAlgebra_Plus {Name : Set} {F G : Set -> Set} {A : Set} {Fun_F : Functor F} diff --git a/Lambda.v b/Lambda.v index 2275594..34b68c6 100644 --- a/Lambda.v +++ b/Lambda.v @@ -17,9 +17,9 @@ Section Lambda. Inductive LType (A : Set) : Set := TArrow : A -> A -> LType A. - Definition LType_fmap : forall (A B : Set) (f : A -> B), + Definition LType_fmap (A B : Set) (f : A -> B) : LType A -> LType B := - fun A B f e => + fun e => match e with | TArrow t1 t2 => TArrow _ (f t1) (f t2) end. @@ -45,11 +45,11 @@ Section Lambda. {UP'_t2 : Universal_Property'_fold t2} : Fix D := proj1_sig (tarrow' (exist _ t1 UP'_t1) (exist _ t2 UP'_t2)). - Global Instance UP'_tarrow (t1 t2 : Fix D) - {UP'_t1 : Universal_Property'_fold t1} - {UP'_t2 : Universal_Property'_fold t2} - : Universal_Property'_fold (tarrow t1 t2) := - proj2_sig (tarrow' (exist _ t1 UP'_t1) (exist _ t2 UP'_t2)). + Global Instance UP'_tarrow (t1 t2 : Fix D) + {UP'_t1 : Universal_Property'_fold t1} + {UP'_t2 : Universal_Property'_fold t2} + : Universal_Property'_fold (tarrow t1 t2) := + proj2_sig (tarrow' (exist _ t1 UP'_t1) (exist _ t2 UP'_t2)). (* Induction Principle for Arrow Types. *) Definition ind_alg_LType @@ -68,8 +68,8 @@ Section Lambda. Definition isTArrow : DType -> option (_ * _) := fun typ => match project (proj1_sig typ) with - | Some (TArrow t1 t2) => Some (t1, t2) - | None => None + | Some (TArrow t1 t2) => Some (t1, t2) + | None => None end. Definition eq_TArrowR := prod ((eq_DTypeR D) -> (eq_DTypeR D) -> bool) (sig (Universal_Property'_fold (F := D))). @@ -108,6 +108,7 @@ Section Lambda. Global Instance PAlgebra_eq_TArrow_eq_LType : PAlgebra eq_TArrow_eqName (sig (UP'_P eq_TArrow_eq_P)) LType. + Proof. constructor; unfold Algebra; intros. apply ind_alg_LType; try assumption; intros. econstructor; unfold eq_TArrow_eq_P; intros; split. @@ -139,7 +140,7 @@ Section Lambda. Definition LType_eq_DType (R : Set) (rec : R -> eq_DTypeR D) (e : LType R) : eq_DTypeR D := match e with - | TArrow t1 t2 => fun t3 => (fst (eq_TArrow (proj1_sig t3))) (rec t1) (rec t2) + | TArrow t1 t2 => fun t3 => fst (eq_TArrow (proj1_sig t3)) (rec t1) (rec t2) end. Global Instance MAlgebra_eq_DType_LType T: @@ -151,6 +152,7 @@ Section Lambda. Global Instance PAlgebra_eq_DType_eq_LType : PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) LType. + Proof. constructor; unfold Algebra; intros. apply ind_alg_LType; try assumption. intros; econstructor; unfold eq_DType_eq_P; intros. @@ -180,25 +182,26 @@ Section Lambda. (** Functor Instance **) - Definition fmapLambda {A} : forall (X Y: Set), (X -> Y) -> (Lambda A X -> Lambda A Y):= - fun _ _ f e => + Definition fmapLambda {A} (X Y: Set) (f : X -> Y) : + Lambda A X -> Lambda A Y := + fun e => match e with - | Var a => Var _ _ a - | App e1 e2 => App _ _ (f e1) (f e2) - | Lam t g => Lam _ _ t (fun a => f (g a)) + | Var a => Var _ _ a + | App e1 e2 => App _ _ (f e1) (f e2) + | Lam t g => Lam _ _ t (fun a => f (g a)) end. Global Instance LambdaFunctor A : Functor (Lambda A) | 5 := - {| fmap := fmapLambda - |}. - (* fmap fusion *) - intros. destruct a; unfold fmapLambda; reflexivity. - (* fmap id *) - intros; destruct a; unfold fmapLambda. - reflexivity. reflexivity. unfold id. unfold id. - assert ((fun x => a x) = a). - apply functional_extensionality; intro. reflexivity. - rewrite H. reflexivity. + {| fmap := fmapLambda |}. + Proof. + (* fmap fusion *) + intros. destruct a; unfold fmapLambda; reflexivity. + (* fmap id *) + intros; destruct a; unfold fmapLambda. + reflexivity. reflexivity. unfold id. unfold id. + assert ((fun x => a x) = a). + apply functional_extensionality; intro. reflexivity. + rewrite H. reflexivity. Defined. Variable F : Set -> Set -> Set. @@ -243,12 +246,12 @@ Section Lambda. : Fix (F A) := proj1_sig (lam' t1 (fun a => exist _ _ (f_UP' a))). - Global Instance UP'_lam {A : Set} - (t1 : DType) - (f : A -> Fix (F A)) - {f_UP' : forall a, Universal_Property'_fold (f a)} - : - Universal_Property'_fold (lam t1 f) := proj2_sig (lam' t1 (fun a => exist _ _ (f_UP' a))). + Global Instance UP'_lam {A : Set} + (t1 : DType) + (f : A -> Fix (F A)) + {f_UP' : forall a, Universal_Property'_fold (f a)} + : + Universal_Property'_fold (lam t1 f) := proj2_sig (lam' t1 (fun a => exist _ _ (f_UP' a))). (* Induction Principle for Lambda. *) Definition ind_alg_Lambda {A : Set} @@ -306,15 +309,16 @@ Section Lambda. | Clos f' env => Clos _ f' (map f env) end. - Global Instance Clos_Functor : Functor ClosValue | 5 := - {| fmap := Clos_fmap |}. - destruct a; simpl. - assert (map g (map f e0) = map (fun e1 : A => g (f e1)) e0) as eq_map by - (clear; induction e0; simpl; eauto; erewrite IHe0; reflexivity). - rewrite eq_map; reflexivity. - (* fmap_id *) - destruct a. unfold Clos_fmap. rewrite map_id. reflexivity. - Defined. + Global Instance Clos_Functor : Functor ClosValue | 5 := + {| fmap := Clos_fmap |}. + Proof. + destruct a; simpl. + assert (map g (map f e0) = map (fun e1 : A => g (f e1)) e0) as eq_map by + (clear; induction e0; simpl; eauto; erewrite IHe0; reflexivity). + rewrite eq_map; reflexivity. + (* fmap_id *) + destruct a. unfold Clos_fmap. rewrite map_id. reflexivity. + Defined. Variable V : Set -> Set. Context {Sub_ClosValue_V : ClosValue :<: V}. @@ -349,27 +353,29 @@ Section Lambda. | None => None end. - Context {Sub_StuckValue_V : StuckValue :<: V}. - Definition stuck' : nat -> Value := stuck' _. - Context {Sub_BotValue_V : BotValue :<: V}. - Definition bot' : Value := bot' _. + Context {Sub_StuckValue_V : StuckValue :<: V}. + Definition stuck' : nat -> Value := stuck' _. + Context {Sub_BotValue_V : BotValue :<: V}. + Definition bot' : Value := bot' _. Definition Lambda_eval : Mixin (Exp nat) (Lambda nat) (evalR V) := fun rec e => - match e with - | Var v => fun env => - match lookup env v with - | Some y => y - | None => stuck' 20 - end - | App e1 e2 => fun env => - let reced := (rec e1 env) in - match isClos (proj1_sig reced) with - | Some (f, env') => rec f (insert _ (rec e2 env) env') - | None => if isBot _ (proj1_sig reced) then bot' else stuck' 5 - end - | Lam t1 f => fun env => closure' (f (length env)) env - end. + match e with + | Var v => + fun env => + match lookup env v with + | Some y => y + | None => stuck' 20 + end + | App e1 e2 => + fun env => + let reced := (rec e1 env) in + match isClos (proj1_sig reced) with + | Some (f, env') => rec f (insert _ (rec e2 env) env') + | None => if isBot _ (proj1_sig reced) then bot' else stuck' 5 + end + | Lam t1 f => fun env => closure' (f (length env)) env + end. Global Instance MAlgebra_eval_Lambda : FAlgebra EvalName (Exp nat) (evalR V) (Lambda nat) := @@ -384,365 +390,377 @@ Section Lambda. Global Instance MAlgebra_DTypePrint_AType T: FAlgebra DTypePrintName T DTypePrintR LType := - {| f_algebra := fun rec e => - match e with - TArrow t1 t2 => append "(" ((rec t1) ++ " -> " ++ (rec t2) ++ ")") - end - |}. + {| f_algebra := + fun rec e => + match e with + | TArrow t1 t2 => append "(" ((rec t1) ++ " -> " ++ (rec t2) ++ ")") + end + |}. Context {DTypePrint_DT : forall T, FAlgebra DTypePrintName T DTypePrintR D}. - Definition Lambda_ExpPrint (R : Set) (rec : R -> ExpPrintR) - (e : Lambda nat R) : ExpPrintR := - match e with - | Var v => fun n => append "x" (String (ascii_of_nat (v)) EmptyString) - | App e1 e2 => fun n => append "(" ((rec e1 n) ++ ") @ (" ++ (rec e2 n) ++ ")") - | Lam t1 f => fun n => append "\x" ((String (ascii_of_nat n) EmptyString) ++ - " : " ++ (DTypePrint _ (proj1_sig t1)) ++ ". " ++ - (rec (f n) (S n)) ++ ")") - end. + Definition Lambda_ExpPrint (R : Set) (rec : R -> ExpPrintR) + (e : Lambda nat R) : ExpPrintR := + match e with + | Var v => fun n => append "x" (String (ascii_of_nat (v)) EmptyString) + | App e1 e2 => fun n => append "(" ((rec e1 n) ++ ") @ (" ++ (rec e2 n) ++ ")") + | Lam t1 f => fun n => append "\x" ((String (ascii_of_nat n) EmptyString) ++ + " : " ++ (DTypePrint _ (proj1_sig t1)) ++ ". " ++ + (rec (f n) (S n)) ++ ")") + end. - Global Instance MAlgebra_Print_Lambda T : - FAlgebra ExpPrintName T ExpPrintR (Lambda nat) := - {| f_algebra := Lambda_ExpPrint T|}. + Global Instance MAlgebra_Print_Lambda T : + FAlgebra ExpPrintName T ExpPrintR (Lambda nat) := + {| f_algebra := Lambda_ExpPrint T|}. - Context {ExpPrint_E : forall T, FAlgebra ExpPrintName T ExpPrintR (F nat)}. + Context {ExpPrint_E : forall T, FAlgebra ExpPrintName T ExpPrintR (F nat)}. - Global Instance MAlgebra_ValuePrint_AType T: - FAlgebra ValuePrintName T ValuePrintR ClosValue := - {| f_algebra := fun rec e => - match e with - | Clos f _ => append "\x0. " (ExpPrint _ (proj1_sig f)) - end |}. + Global Instance MAlgebra_ValuePrint_AType T: + FAlgebra ValuePrintName T ValuePrintR ClosValue := + {| f_algebra := fun rec e => + match e with + | Clos f _ => append "\x0. " (ExpPrint _ (proj1_sig f)) + end + |}. (* ============================================== *) (* SUBVALUE RELATION FOR LAMBDAS *) (* ============================================== *) - Context {SV : (SubValue_i V -> Prop) -> SubValue_i V -> Prop}. - - Inductive SubValue_Clos (A : SubValue_i V -> Prop) : SubValue_i V -> Prop := - SV_Clos : forall f f' env env' v v', - proj1_sig f = proj1_sig f' -> - P2_Env (fun e e' : Value => A (mk_SubValue_i V e e')) env env' -> - proj1_sig v = proj1_sig (closure' f env) -> - proj1_sig v' = proj1_sig (closure' f' env') -> - SubValue_Clos A (mk_SubValue_i _ v v'). - - Definition ind_alg_SV_Clos (P : SubValue_i V -> Prop) - (P' : Env Value -> Env Value -> Prop) - (H : forall f f' env env' v v', - proj1_sig f = proj1_sig f' -> - P' env env' -> - proj1_sig v = proj1_sig (closure' f env) -> - proj1_sig v' = proj1_sig (closure' f' env') -> - P (mk_SubValue_i _ v v')) - (H0 : P' nil nil) - (H1 : forall i env env', P i -> P' env env' -> - P' (sv_a _ i :: env) (sv_b _ i :: env')) - i (e : SubValue_Clos P i) : P i := - match e in SubValue_Clos _ i return P i with - | SV_Clos f f' env env' v v' f_eq Sub_env_env' v_eq v'_eq => - H f f' env env' v v' f_eq - ((fix P_Env_ind' (env : Env _) (env' : Env _) - (P_env_env' : P2_Env (fun e e' => P (mk_SubValue_i _ e e')) env env') := - match P_env_env' in P2_Env _ As Bs return P' As Bs with - | P2_Nil => H0 - | P2_Cons a b As Bs P_a_b P_As_Bs => - H1 (mk_SubValue_i _ a b) As Bs P_a_b (P_Env_ind' _ _ P_As_Bs) - end) _ _ Sub_env_env') v_eq v'_eq - end. + Context {SV : (SubValue_i V -> Prop) -> SubValue_i V -> Prop}. + + Inductive SubValue_Clos (A : SubValue_i V -> Prop) : SubValue_i V -> Prop := + SV_Clos : forall f f' env env' v v', + proj1_sig f = proj1_sig f' -> + P2_Env (fun e e' : Value => A (mk_SubValue_i V e e')) env env' -> + proj1_sig v = proj1_sig (closure' f env) -> + proj1_sig v' = proj1_sig (closure' f' env') -> + SubValue_Clos A (mk_SubValue_i _ v v'). + + Definition ind_alg_SV_Clos (P : SubValue_i V -> Prop) + (P' : Env Value -> Env Value -> Prop) + (H : forall f f' env env' v v', + proj1_sig f = proj1_sig f' -> + P' env env' -> + proj1_sig v = proj1_sig (closure' f env) -> + proj1_sig v' = proj1_sig (closure' f' env') -> + P (mk_SubValue_i _ v v')) + (H0 : P' nil nil) + (H1 : forall i env env', P i -> P' env env' -> + P' (sv_a _ i :: env) (sv_b _ i :: env')) + i (e : SubValue_Clos P i) : P i := + match e in SubValue_Clos _ i return P i with + | SV_Clos f f' env env' v v' f_eq Sub_env_env' v_eq v'_eq => + H f f' env env' v v' f_eq + ((fix P_Env_ind' (env : Env _) (env' : Env _) + (P_env_env' : P2_Env (fun e e' => P (mk_SubValue_i _ e e')) env env') := + match P_env_env' in P2_Env _ As Bs return P' As Bs with + | P2_Nil => H0 + | P2_Cons a b As Bs P_a_b P_As_Bs => + H1 (mk_SubValue_i _ a b) As Bs P_a_b (P_Env_ind' _ _ P_As_Bs) + end) _ _ Sub_env_env') v_eq v'_eq + end. - Definition SV_Clos_ifmap (A B : SubValue_i V -> Prop) i (g : forall i, A i -> B i) - (SV_a : SubValue_Clos A i) : SubValue_Clos B i := - match SV_a in SubValue_Clos _ i return SubValue_Clos B i with - | SV_Clos f f' env env' v v' f_eq Sub_env_env' v_eq v'_eq => - SV_Clos B f f' env env' v v' f_eq - ((fix P_Env_ind' (env : Env _) (env' : Env _) - (P_env_env' : P2_Env (fun e e' => A (mk_SubValue_i _ e e')) env env') := - match P_env_env' in P2_Env _ As Bs return P2_Env (fun e e' => B (mk_SubValue_i _ e e')) As Bs with - | P2_Nil => P2_Nil _ - | P2_Cons a b As Bs P_a_b P_As_Bs => - P2_Cons (fun e e' : Names.Value V => B {| sv_a := e; sv_b := e' |}) - a b As Bs (g (mk_SubValue_i _ a b) P_a_b) (P_Env_ind' _ _ P_As_Bs) - end) _ _ Sub_env_env') v_eq v'_eq - end. + Definition SV_Clos_ifmap (A B : SubValue_i V -> Prop) i (g : forall i, A i -> B i) + (SV_a : SubValue_Clos A i) : SubValue_Clos B i := + match SV_a in SubValue_Clos _ i return SubValue_Clos B i with + | SV_Clos f f' env env' v v' f_eq Sub_env_env' v_eq v'_eq => + SV_Clos B f f' env env' v v' f_eq + ((fix P_Env_ind' (env : Env _) (env' : Env _) + (P_env_env' : P2_Env (fun e e' => A (mk_SubValue_i _ e e')) env env') := + match P_env_env' in P2_Env _ As Bs return P2_Env (fun e e' => B (mk_SubValue_i _ e e')) As Bs with + | P2_Nil => P2_Nil _ + | P2_Cons a b As Bs P_a_b P_As_Bs => + P2_Cons (fun e e' : Names.Value V => B {| sv_a := e; sv_b := e' |}) + a b As Bs (g (mk_SubValue_i _ a b) P_a_b) (P_Env_ind' _ _ P_As_Bs) + end) _ _ Sub_env_env') v_eq v'_eq + end. - Global Instance iFun_SV_Clos : iFunctor SubValue_Clos. - constructor 1 with (ifmap := SV_Clos_ifmap). - destruct a; simpl; intros. - apply (f_equal (fun P_env' => SV_Clos C f0 f' env env' v v' e P_env' e0 e1)). - clear; revert env env' p; eapply P2_Env_ind'; simpl; intros; congruence. - destruct a; simpl; intros. - apply (f_equal (fun P_env' => SV_Clos A f f' env env' v v' e P_env' e0 e1)). - clear; revert env env' p; eapply P2_Env_ind'; simpl; intros. - reflexivity. - unfold id. - rewrite <- H at -1. - apply (f_equal (fun P_env' => - P2_Cons (fun e e' : Names.Value V => A {| sv_a := e; sv_b := e' |}) _ _ _ _ P_a_b P_env')). - reflexivity. - Defined. + Global Instance iFun_SV_Clos : iFunctor SubValue_Clos. + Proof. + constructor 1 with (ifmap := SV_Clos_ifmap). + destruct a; simpl; intros. + apply (f_equal (fun P_env' => SV_Clos C f0 f' env env' v v' e P_env' e0 e1)). + clear; revert env env' p; eapply P2_Env_ind'; simpl; intros; congruence. + destruct a; simpl; intros. + apply (f_equal (fun P_env' => SV_Clos A f f' env env' v v' e P_env' e0 e1)). + clear; revert env env' p; eapply P2_Env_ind'; simpl; intros. + reflexivity. + unfold id. + rewrite <- H at -1. + apply (f_equal (fun P_env' => + P2_Cons (fun e e' : Names.Value V => A {| sv_a := e; sv_b := e' |}) _ _ _ _ P_a_b P_env')). + reflexivity. + Defined. (* ============================================== *) (* TYPE SOUNDNESS *) (* ============================================== *) - Context {eval_F : FAlgebra EvalName (Exp nat) (evalR V) (F nat)}. - Context {WF_eval_F : @WF_FAlgebra EvalName _ _ (Lambda nat) (F nat) - (Sub_Lambda_F nat) (MAlgebra_eval_Lambda) (eval_F)}. + Context {eval_F : FAlgebra EvalName (Exp nat) (evalR V) (F nat)}. + Context {WF_eval_F : @WF_FAlgebra EvalName _ _ (Lambda nat) (F nat) + (Sub_Lambda_F nat) (MAlgebra_eval_Lambda) (eval_F)}. - (* Continuity of Evaluation. *) + (* Continuity of Evaluation. *) - Context {WF_SubBotValue_V : WF_Functor BotValue V Sub_BotValue_V Bot_Functor Fun_V}. - Context {Sub_SV_refl_SV : Sub_iFunctor (SubValue_refl V) SV}. - Context {Sub_SV_Clos_SV : Sub_iFunctor SubValue_Clos SV}. + Context {WF_SubBotValue_V : WF_Functor BotValue V Sub_BotValue_V Bot_Functor Fun_V}. + Context {Sub_SV_refl_SV : Sub_iFunctor (SubValue_refl V) SV}. + Context {Sub_SV_Clos_SV : Sub_iFunctor SubValue_Clos SV}. (* Lit case. *) - Lemma eval_continuous_Exp_H : forall x, - UP'_P (eval_continuous_Exp_P V (F nat) SV) (var x). - unfold eval_continuous_Exp_P; econstructor; simpl; intros; - eauto with typeclass_instances. - unfold beval, mfold, var; simpl; repeat rewrite wf_functor; simpl. - rewrite out_in_fmap; rewrite wf_functor; simpl. - repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. - caseEq (@lookup Value gamma x); unfold Value in *|-*; - rewrite H2. - destruct (P2_Env_lookup _ _ _ _ _ H0 _ _ H2) as [v' [lookup_v' Sub_v_v']]. - unfold Value; rewrite lookup_v'; eauto. - unfold Value; rewrite (P2_Env_Nlookup _ _ _ _ _ H0 _ H2). - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. - Qed. + Lemma eval_continuous_Exp_H : forall x, + UP'_P (eval_continuous_Exp_P V (F nat) SV) (var x). + Proof. + unfold eval_continuous_Exp_P; econstructor; simpl; intros; + eauto with typeclass_instances. + unfold beval, mfold, var; simpl; repeat rewrite wf_functor; simpl. + rewrite out_in_fmap; rewrite wf_functor; simpl. + repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. + caseEq (@lookup Value gamma x); unfold Value in *|-*; + rewrite H2. + destruct (P2_Env_lookup _ _ _ _ _ H0 _ _ H2) as [v' [lookup_v' Sub_v_v']]. + unfold Value; rewrite lookup_v'; eauto. + unfold Value; rewrite (P2_Env_Nlookup _ _ _ _ _ H0 _ H2). + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. + Qed. (* Lambda case. *) - Lemma eval_continuous_Exp_H1 : forall t1 f - (IHf : forall a, UP'_P (eval_continuous_Exp_P V (F nat) SV) (f a)), - UP'_P (eval_continuous_Exp_P V (F nat) SV) - (@lam _ t1 _ (fun a => (proj1_sig (IHf a)))). - unfold eval_continuous_Exp_P; econstructor; simpl; intros. - unfold beval, mfold, lam; simpl; repeat rewrite wf_functor; - simpl; rewrite out_in_fmap; rewrite wf_functor; simpl. - repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F )); simpl. - eapply (inject_i (subGF := Sub_SV_Clos_SV)); econstructor; eauto. - simpl; repeat rewrite wf_functor; simpl. - assert (f (Datatypes.length gamma) = (f (Datatypes.length gamma'))) as f_eq by - (rewrite (P2_Env_length _ _ _ _ _ H0); reflexivity). - rewrite f_eq; eauto. - Qed. + Lemma eval_continuous_Exp_H1 : forall t1 f + (IHf : forall a, UP'_P (eval_continuous_Exp_P V (F nat) SV) (f a)), + UP'_P (eval_continuous_Exp_P V (F nat) SV) + (@lam _ t1 _ (fun a => (proj1_sig (IHf a)))). + Proof. + unfold eval_continuous_Exp_P; econstructor; simpl; intros. + unfold beval, mfold, lam; simpl; repeat rewrite wf_functor; + simpl; rewrite out_in_fmap; rewrite wf_functor; simpl. + repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F )); simpl. + eapply (inject_i (subGF := Sub_SV_Clos_SV)); econstructor; eauto. + simpl; repeat rewrite wf_functor; simpl. + assert (f (Datatypes.length gamma) = (f (Datatypes.length gamma'))) as f_eq by + (rewrite (P2_Env_length _ _ _ _ _ H0); reflexivity). + rewrite f_eq; eauto. + Qed. (* App case. *) - Context {Dis_Clos_Bot : Distinct_Sub_Functor _ Sub_ClosValue_V Sub_BotValue_V}. - Context {iFun_SV : iFunctor SV}. - - Global Instance SV_proj1_b_Clos : - iPAlgebra SV_proj1_b_Name (SV_proj1_b_P _ SV) SubValue_Clos. - econstructor; intros. - unfold iAlgebra; intros. - eapply ind_alg_SV_Clos with (P' := fun env env' => Sub_Environment V SV env env'); - try eassumption; intros. - unfold SV_proj1_b_P; intros; simpl. - apply (inject_i (subGF := Sub_SV_Clos_SV)); - econstructor; eauto. - simpl in *|-*. - congruence. - constructor. - constructor; eauto. - unfold SV_proj1_b_P in H0. - destruct i0; simpl. - destruct sv_b as [sv_b1 sv_b2]. - apply (H0 sv_b1 sv_b2 (refl_equal _)). - Qed. - - Global Instance SV_proj1_a_Clos : - iPAlgebra SV_proj1_a_Name (SV_proj1_a_P _ SV) SubValue_Clos. - econstructor; intros. - unfold iAlgebra; intros. - eapply ind_alg_SV_Clos with (P' := fun env env' => Sub_Environment V SV env env'); - try eassumption; intros. - unfold SV_proj1_a_P; intros; simpl. - apply (inject_i (subGF := Sub_SV_Clos_SV)); - econstructor; eauto. - simpl in *|-*. - congruence. - constructor. - constructor; eauto. - unfold SV_proj1_a_P in H0. - destruct i0; simpl. - destruct sv_a as [sv_a1 sv_a2]. - apply (H0 sv_a1 sv_a2 (refl_equal _)). - Qed. - - Global Instance SV_invertBot_Clos : - iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SubValue_Clos. - Proof. - econstructor; intros. - unfold iAlgebra; intros. - inversion H; subst; simpl. - unfold SV_invertBot_P; intros. - simpl in H4; rewrite H3 in H4. - unfold closure', bot, Names.bot, inject' in H4. - elimtype False; eapply (inject_discriminate Dis_Clos_Bot). - unfold inject; apply H4. - Qed. - - Context {SV_proj1_b_SV : - iPAlgebra SV_proj1_b_Name (SV_proj1_b_P _ SV) SV}. - Context {SV_proj1_a_SV : - iPAlgebra SV_proj1_a_Name (SV_proj1_a_P _ SV) SV}. - Context {SV_invertBot_SV : - iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SV}. + Context {Dis_Clos_Bot : Distinct_Sub_Functor _ Sub_ClosValue_V Sub_BotValue_V}. + Context {iFun_SV : iFunctor SV}. - (* Inversion principles for function SubValues. *) - Definition SV_invertClos_P (i : SubValue_i V) := - SubValue _ SV i /\ - forall f env, proj1_sig (sv_a _ i) = proj1_sig (closure' f env) -> - exists f', exists env', proj1_sig f' = proj1_sig f /\ - proj1_sig (sv_b _ i) = proj1_sig (closure' f' env') - /\ Sub_Environment V SV env env'. - - Inductive SV_invertClos_Name := ece_invertclosure_name. - Context {SV_invertClos_SV : - iPAlgebra SV_invertClos_Name SV_invertClos_P SV}. - - Global Instance SV_invertClos_refl : - iPAlgebra SV_invertClos_Name SV_invertClos_P (SubValue_refl V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertClos_P. - inversion H; subst; simpl; intros. - split; intros. - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; simpl; eauto. - repeat eexists _; repeat split; eauto. - rewrite <- H0; eauto. - eapply Sub_Environment_refl; eauto. - Defined. - - Global Instance SV_invertClos_Clos : - iPAlgebra SV_invertClos_Name SV_invertClos_P (SubValue_Clos). - econstructor; intros. - unfold iAlgebra; intros. - eapply ind_alg_SV_Clos with (P' := fun env env' => - forall env'', - map (@proj1_sig _ _) env'' = map (@proj1_sig _ _) env -> Sub_Environment V SV env'' env' ); + Global Instance SV_proj1_b_Clos : + iPAlgebra SV_proj1_b_Name (SV_proj1_b_P _ SV) SubValue_Clos. + Proof. + econstructor; intros. + unfold iAlgebra; intros. + eapply ind_alg_SV_Clos with (P' := fun env env' => Sub_Environment V SV env env'); try eassumption; intros. - unfold SV_invertClos_P; intros. - simpl in *|-*. - apply (f_equal out_t) in H2. - repeat rewrite out_in_inverse in H2. - repeat rewrite wf_functor in H2; simpl in H2. - apply (f_equal (prj (Sub_Functor := Sub_ClosValue_V))) in H2. - repeat rewrite prj_inj in H2. - split; intros. - apply (inject_i (subGF := Sub_SV_Clos_SV)); econstructor; eauto. - eapply H1; reflexivity. - generalize (inj_prj _ _ H2); intros H5; apply (f_equal in_t) in H5. - rewrite in_out_inverse in H5; simpl. - rewrite wf_functor; simpl; assumption. - exact (proj2_sig v). - simpl; eauto. - exists f'; exists env'; repeat split; eauto. - rewrite H4 in H2; rewrite out_in_inverse, wf_functor, prj_inj in H2; - simpl in H4; injection H2; intros; congruence. - rewrite H4 in H2; rewrite out_in_inverse, wf_functor, prj_inj in H2; - simpl in H4; injection H2; intros; subst; eauto. - destruct env''; try discriminate; constructor. - unfold SV_invertClos_P in H0. - destruct env''; try discriminate; injection H2; intros; subst; - constructor; eauto. - destruct H0 as [i' H0]; destruct s; eapply (SV_proj1_a _ _ _ i0); eauto. - eapply H1; eauto. - Qed. - - Variable Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV. - - Global Instance SV_invertClos_Bot : - iPAlgebra SV_invertClos_Name SV_invertClos_P (SubValue_Bot V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertClos_P. - inversion H; subst; simpl; intros. - split; intros. - apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; eauto. - elimtype False. - rewrite H0 in H1. - eapply (inject_discriminate Dis_Clos_Bot); unfold inject in *|-*; simpl in *|-*; eauto. - Defined. - - Definition SV_invertClos := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertClos_SV)). - - Definition SV_invertClos'_P (i : SubValue_i V) := - SubValue _ SV i /\ - forall f env, proj1_sig (sv_b _ i) = proj1_sig (closure' f env) -> - proj1_sig (sv_a _ i) = bot _ \/ - (exists f, - exists env', proj1_sig (sv_a _ i) = proj1_sig (closure' f env') /\ - Sub_Environment V SV env' env). - - Inductive SV_invertClos'_Name := ece_invertclosure'_name. - Variable SV_invertClos'_SV : iPAlgebra SV_invertClos'_Name SV_invertClos'_P SV. - - Global Instance SV_invertClos'_refl : - iPAlgebra SV_invertClos'_Name SV_invertClos'_P (SubValue_refl V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertClos'_P. - inversion H; subst; simpl; split; intros. - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; auto. - right; eexists; eexists; split; eauto. - rewrite H0; eauto. - eapply Sub_Environment_refl; eauto. - Defined. - - Global Instance SV_invertClos'_Bot : - iPAlgebra SV_invertClos'_Name SV_invertClos'_P (SubValue_Bot V). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertClos'_P. - inversion H; subst; simpl; split; intros; eauto. - apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; assumption. - Defined. - - Global Instance SV_invertClos'_Clos : - iPAlgebra SV_invertClos'_Name SV_invertClos'_P (SubValue_Clos). - econstructor; intros. - unfold iAlgebra; intros. - eapply ind_alg_SV_Clos with (P' := fun env env' => - forall env'', - map (@proj1_sig _ _) env'' = map (@proj1_sig _ _) env' -> - Sub_Environment V SV env env''); + unfold SV_proj1_b_P; intros; simpl. + apply (inject_i (subGF := Sub_SV_Clos_SV)); + econstructor; eauto. + simpl in *|-*. + congruence. + constructor. + constructor; eauto. + unfold SV_proj1_b_P in H0. + destruct i0; simpl. + destruct sv_b as [sv_b1 sv_b2]. + apply (H0 sv_b1 sv_b2 (refl_equal _)). + Qed. + + Global Instance SV_proj1_a_Clos : + iPAlgebra SV_proj1_a_Name (SV_proj1_a_P _ SV) SubValue_Clos. + Proof. + econstructor; intros. + unfold iAlgebra; intros. + eapply ind_alg_SV_Clos with (P' := fun env env' => Sub_Environment V SV env env'); try eassumption; intros. - unfold SV_invertClos'_P; intros; simpl; split; intros. - apply (inject_i (subGF := Sub_SV_Clos_SV)); econstructor; eauto. - eapply H1. - reflexivity. - right; exists f; exists env; split. - rewrite H2; reflexivity. - rewrite H3 in H4; simpl in H4. - apply (f_equal out_t) in H4; repeat rewrite out_in_inverse, wf_functor in H4; - simpl in H4; apply (f_equal (prj (sub_F := ClosValue))) in H4; - repeat rewrite prj_inj in H4; injection H4; intros; subst. - eauto. - destruct env''; try discriminate; constructor. - unfold SV_invertClos_P in H0. - destruct env''; try discriminate; injection H2; intros; subst; - constructor; eauto. - destruct H0 as [i' H0]; destruct s; eapply (SV_proj1_b _ _ _ i0); eauto. - eapply H1; eauto. - Qed. - - Definition SV_invertClos' := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertClos'_SV)). - - Lemma eval_continuous_Exp_H0 : forall e1 e2 - (IHe1 : UP'_P (eval_continuous_Exp_P V (F nat) SV) e1) - (IHe2 : UP'_P (eval_continuous_Exp_P V (F nat) SV) e2), - UP'_P (eval_continuous_Exp_P V (F nat) SV) (@app _ _ _ (proj1_sig IHe1) (proj1_sig IHe2)). - Proof. - intros; destruct IHe1 as [UP'_e1 IHe1]; - destruct IHe2 as [UP'_e2 IHe2]. - unfold eval_continuous_Exp_P; econstructor; simpl; intros; - eauto with typeclass_instances. - unfold beval, mfold, app; simpl; repeat rewrite wf_functor; - simpl; rewrite out_in_fmap; rewrite wf_functor; simpl. - repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F )); simpl. + unfold SV_proj1_a_P; intros; simpl. + apply (inject_i (subGF := Sub_SV_Clos_SV)); + econstructor; eauto. + simpl in *|-*. + congruence. + constructor. + constructor; eauto. + unfold SV_proj1_a_P in H0. + destruct i0; simpl. + destruct sv_a as [sv_a1 sv_a2]. + apply (H0 sv_a1 sv_a2 (refl_equal _)). + Qed. + + Global Instance SV_invertBot_Clos : + iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SubValue_Clos. + Proof. + econstructor; intros. + unfold iAlgebra; intros. + inversion H; subst; simpl. + unfold SV_invertBot_P; intros. + simpl in H4; rewrite H3 in H4. + unfold closure', bot, Names.bot, inject' in H4. + elimtype False; eapply (inject_discriminate Dis_Clos_Bot). + unfold inject; apply H4. + Qed. + + Context {SV_proj1_b_SV : + iPAlgebra SV_proj1_b_Name (SV_proj1_b_P _ SV) SV}. + Context {SV_proj1_a_SV : + iPAlgebra SV_proj1_a_Name (SV_proj1_a_P _ SV) SV}. + Context {SV_invertBot_SV : + iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SV}. + + (* Inversion principles for function SubValues. *) + + Definition SV_invertClos_P (i : SubValue_i V) := + SubValue _ SV i /\ + forall f env, proj1_sig (sv_a _ i) = proj1_sig (closure' f env) -> + exists f', exists env', proj1_sig f' = proj1_sig f /\ + proj1_sig (sv_b _ i) = proj1_sig (closure' f' env') + /\ Sub_Environment V SV env env'. + + Inductive SV_invertClos_Name := ece_invertclosure_name. + Context {SV_invertClos_SV : + iPAlgebra SV_invertClos_Name SV_invertClos_P SV}. + + Global Instance SV_invertClos_refl : + iPAlgebra SV_invertClos_Name SV_invertClos_P (SubValue_refl V). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertClos_P. + inversion H; subst; simpl; intros. + split; intros. + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; simpl; eauto. + repeat eexists _; repeat split; eauto. + rewrite <- H0; eauto. + eapply Sub_Environment_refl; eauto. + Defined. + + Global Instance SV_invertClos_Clos : + iPAlgebra SV_invertClos_Name SV_invertClos_P (SubValue_Clos). + Proof. + econstructor; intros. + unfold iAlgebra; intros. + eapply ind_alg_SV_Clos with (P' := fun env env' => + forall env'', + map (@proj1_sig _ _) env'' = map (@proj1_sig _ _) env -> Sub_Environment V SV env'' env' ); + try eassumption; intros. + unfold SV_invertClos_P; intros. + simpl in *|-*. + apply (f_equal out_t) in H2. + repeat rewrite out_in_inverse in H2. + repeat rewrite wf_functor in H2; simpl in H2. + apply (f_equal (prj (Sub_Functor := Sub_ClosValue_V))) in H2. + repeat rewrite prj_inj in H2. + split; intros. + apply (inject_i (subGF := Sub_SV_Clos_SV)); econstructor; eauto. + eapply H1; reflexivity. + generalize (inj_prj _ _ H2); intros H5; apply (f_equal in_t) in H5. + rewrite in_out_inverse in H5; simpl. + rewrite wf_functor; simpl; assumption. + exact (proj2_sig v). + simpl; eauto. + exists f'; exists env'; repeat split; eauto. + rewrite H4 in H2; rewrite out_in_inverse, wf_functor, prj_inj in H2; + simpl in H4; injection H2; intros; congruence. + rewrite H4 in H2; rewrite out_in_inverse, wf_functor, prj_inj in H2; + simpl in H4; injection H2; intros; subst; eauto. + destruct env''; try discriminate; constructor. + unfold SV_invertClos_P in H0. + destruct env''; try discriminate; injection H2; intros; subst; + constructor; eauto. + destruct H0 as [i' H0]; destruct s; eapply (SV_proj1_a _ _ _ i0); eauto. + eapply H1; eauto. + Qed. + + Variable Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV. + + Global Instance SV_invertClos_Bot : + iPAlgebra SV_invertClos_Name SV_invertClos_P (SubValue_Bot V). + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertClos_P. + inversion H; subst; simpl; intros. + split; intros. + apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; eauto. + elimtype False. + rewrite H0 in H1. + eapply (inject_discriminate Dis_Clos_Bot); unfold inject in *|-*; simpl in *|-*; eauto. + Defined. + + Definition SV_invertClos := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertClos_SV)). + + Definition SV_invertClos'_P (i : SubValue_i V) := + SubValue _ SV i /\ + forall f env, proj1_sig (sv_b _ i) = proj1_sig (closure' f env) -> + proj1_sig (sv_a _ i) = bot _ \/ + (exists f, + exists env', proj1_sig (sv_a _ i) = proj1_sig (closure' f env') /\ + Sub_Environment V SV env' env). + + Inductive SV_invertClos'_Name := ece_invertclosure'_name. + Variable SV_invertClos'_SV : iPAlgebra SV_invertClos'_Name SV_invertClos'_P SV. + + Global Instance SV_invertClos'_refl : + iPAlgebra SV_invertClos'_Name SV_invertClos'_P (SubValue_refl V). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertClos'_P. + inversion H; subst; simpl; split; intros. + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; auto. + right; eexists; eexists; split; eauto. + rewrite H0; eauto. + eapply Sub_Environment_refl; eauto. + Defined. + + Global Instance SV_invertClos'_Bot : + iPAlgebra SV_invertClos'_Name SV_invertClos'_P (SubValue_Bot V). + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertClos'_P. + inversion H; subst; simpl; split; intros; eauto. + apply (inject_i (subGF := Sub_SV_Bot_SV)); constructor; assumption. + Defined. + + Global Instance SV_invertClos'_Clos : + iPAlgebra SV_invertClos'_Name SV_invertClos'_P (SubValue_Clos). + Proof. + econstructor; intros. + unfold iAlgebra; intros. + eapply ind_alg_SV_Clos with (P' := fun env env' => + forall env'', + map (@proj1_sig _ _) env'' = map (@proj1_sig _ _) env' -> + Sub_Environment V SV env env''); + try eassumption; intros. + unfold SV_invertClos'_P; intros; simpl; split; intros. + apply (inject_i (subGF := Sub_SV_Clos_SV)); econstructor; eauto. + eapply H1. + reflexivity. + right; exists f; exists env; split. + rewrite H2; reflexivity. + rewrite H3 in H4; simpl in H4. + apply (f_equal out_t) in H4; repeat rewrite out_in_inverse, wf_functor in H4; + simpl in H4; apply (f_equal (prj (sub_F := ClosValue))) in H4; + repeat rewrite prj_inj in H4; injection H4; intros; subst. + eauto. + destruct env''; try discriminate; constructor. + unfold SV_invertClos_P in H0. + destruct env''; try discriminate; injection H2; intros; subst; + constructor; eauto. + destruct H0 as [i' H0]; destruct s; eapply (SV_proj1_b _ _ _ i0); eauto. + eapply H1; eauto. + Qed. + + Definition SV_invertClos' := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertClos'_SV)). + + Lemma eval_continuous_Exp_H0 : forall e1 e2 + (IHe1 : UP'_P (eval_continuous_Exp_P V (F nat) SV) e1) + (IHe2 : UP'_P (eval_continuous_Exp_P V (F nat) SV) e2), + UP'_P (eval_continuous_Exp_P V (F nat) SV) (@app _ _ _ (proj1_sig IHe1) (proj1_sig IHe2)). + Proof. + intros; destruct IHe1 as [UP'_e1 IHe1]; + destruct IHe2 as [UP'_e2 IHe2]. + unfold eval_continuous_Exp_P; econstructor; simpl; intros; + eauto with typeclass_instances. + unfold beval, mfold, app; simpl; repeat rewrite wf_functor; + simpl; rewrite out_in_fmap; rewrite wf_functor; simpl. + repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F )); simpl. unfold isClos. repeat erewrite bF_UP_in_out. caseEq (project (G := ClosValue) @@ -844,134 +862,136 @@ Section Lambda. reflexivity. Qed. - Global Instance Lambda_eval_continuous_Exp : + Global Instance Lambda_eval_continuous_Exp : PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V (F nat) SV))) (Lambda nat). - constructor; unfold Algebra; intros. - eapply ind_alg_Lambda. - apply eval_continuous_Exp_H. - apply eval_continuous_Exp_H0. - apply eval_continuous_Exp_H1. - assumption. - Defined. + Proof. + constructor; unfold Algebra; intros. + eapply ind_alg_Lambda. + apply eval_continuous_Exp_H. + apply eval_continuous_Exp_H0. + apply eval_continuous_Exp_H1. + assumption. + Defined. (* ============================================== *) (* EQUIVALENCE OF EXPRESSIONS *) (* ============================================== *) - (** SuperFunctor for Equivalence Relation. **) - - Variable EQV_E : forall A B, (eqv_i F A B -> Prop) -> eqv_i F A B -> Prop. - Definition E_eqv A B := iFix (EQV_E A B). - Definition E_eqvC {A B : Set} gamma gamma' e e' := - E_eqv _ _ (mk_eqv_i _ A B gamma gamma' e e'). - Variable funEQV_E : forall A B, iFunctor (EQV_E A B). - - (* Projection doesn't affect Equivalence Relation.*) - - Inductive Lambda_eqv (A B : Set) (E : eqv_i F A B -> Prop) : eqv_i F A B -> Prop := - | Var_eqv : forall (gamma : Env _) gamma' n a b e e', - lookup gamma n = Some a -> lookup gamma' n = Some b -> - proj1_sig e = var a -> - proj1_sig e' = var b -> - Lambda_eqv A B E (mk_eqv_i _ _ _ gamma gamma' e e') - | App_eqv : forall (gamma : Env _) gamma' a b a' b' e e', - E (mk_eqv_i _ _ _ gamma gamma' a a') -> - E (mk_eqv_i _ _ _ gamma gamma' b b') -> - proj1_sig e = proj1_sig (app' a b) -> - proj1_sig e' = proj1_sig (app' a' b') -> - Lambda_eqv A B E (mk_eqv_i _ _ _ gamma gamma' e e') - | Lam_eqv : forall (gamma : Env _) gamma' f g t1 t2 e e', - (forall (a : A) (b : B), E (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b))) -> - proj1_sig t1 = proj1_sig t2 -> - proj1_sig e = proj1_sig (lam' t1 f) -> - proj1_sig e' = proj1_sig (lam' t2 g) -> - Lambda_eqv _ _ E (mk_eqv_i _ _ _ gamma gamma' e e'). - - Definition ind_alg_Lambda_eqv - (A B : Set) - (P : eqv_i F A B -> Prop) - (H : forall gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq, - P (mk_eqv_i _ _ _ gamma gamma' e e')) - (H0 : forall gamma gamma' a b a' b' e e' - (IHa : P (mk_eqv_i _ _ _ gamma gamma' a a')) - (IHb : P (mk_eqv_i _ _ _ gamma gamma' b b')) - e_eq e'_eq, - P (mk_eqv_i _ _ _ gamma gamma' e e')) - (H1 : forall gamma gamma' f g t1 t2 e e' - (IHf : forall a b, P (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b))) - t1_eq e_eq e'_eq, - P (mk_eqv_i _ _ _ gamma gamma' e e')) - i (e : Lambda_eqv A B P i) : P i := - match e in Lambda_eqv _ _ _ i return P i with - | Var_eqv gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq => - H gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq - | App_eqv gamma gamma' a b a' b' e e' - eqv_a_a' eqv_b_b' e_eq e'_eq => - H0 gamma gamma' a b a' b' e e' - eqv_a_a' eqv_b_b' e_eq e'_eq - | Lam_eqv gamma gamma' f g t1 t2 e e' - eqv_f_g t1_eq e_eq e'_eq => - H1 gamma gamma' f g t1 t2 e e' - eqv_f_g t1_eq e_eq e'_eq - end. + (** SuperFunctor for Equivalence Relation. **) + + Variable EQV_E : forall A B, (eqv_i F A B -> Prop) -> eqv_i F A B -> Prop. + Definition E_eqv A B := iFix (EQV_E A B). + Definition E_eqvC {A B : Set} gamma gamma' e e' := + E_eqv _ _ (mk_eqv_i _ A B gamma gamma' e e'). + Variable funEQV_E : forall A B, iFunctor (EQV_E A B). + + (* Projection doesn't affect Equivalence Relation.*) + + Inductive Lambda_eqv (A B : Set) (E : eqv_i F A B -> Prop) : eqv_i F A B -> Prop := + | Var_eqv : forall (gamma : Env _) gamma' n a b e e', + lookup gamma n = Some a -> lookup gamma' n = Some b -> + proj1_sig e = var a -> + proj1_sig e' = var b -> + Lambda_eqv A B E (mk_eqv_i _ _ _ gamma gamma' e e') + | App_eqv : forall (gamma : Env _) gamma' a b a' b' e e', + E (mk_eqv_i _ _ _ gamma gamma' a a') -> + E (mk_eqv_i _ _ _ gamma gamma' b b') -> + proj1_sig e = proj1_sig (app' a b) -> + proj1_sig e' = proj1_sig (app' a' b') -> + Lambda_eqv A B E (mk_eqv_i _ _ _ gamma gamma' e e') + | Lam_eqv : forall (gamma : Env _) gamma' f g t1 t2 e e', + (forall (a : A) (b : B), E (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b))) -> + proj1_sig t1 = proj1_sig t2 -> + proj1_sig e = proj1_sig (lam' t1 f) -> + proj1_sig e' = proj1_sig (lam' t2 g) -> + Lambda_eqv _ _ E (mk_eqv_i _ _ _ gamma gamma' e e'). + + Definition ind_alg_Lambda_eqv + (A B : Set) + (P : eqv_i F A B -> Prop) + (H : forall gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq, + P (mk_eqv_i _ _ _ gamma gamma' e e')) + (H0 : forall gamma gamma' a b a' b' e e' + (IHa : P (mk_eqv_i _ _ _ gamma gamma' a a')) + (IHb : P (mk_eqv_i _ _ _ gamma gamma' b b')) + e_eq e'_eq, + P (mk_eqv_i _ _ _ gamma gamma' e e')) + (H1 : forall gamma gamma' f g t1 t2 e e' + (IHf : forall a b, P (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b))) + t1_eq e_eq e'_eq, + P (mk_eqv_i _ _ _ gamma gamma' e e')) + i (e : Lambda_eqv A B P i) : P i := + match e in Lambda_eqv _ _ _ i return P i with + | Var_eqv gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq => + H gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq + | App_eqv gamma gamma' a b a' b' e e' + eqv_a_a' eqv_b_b' e_eq e'_eq => + H0 gamma gamma' a b a' b' e e' + eqv_a_a' eqv_b_b' e_eq e'_eq + | Lam_eqv gamma gamma' f g t1 t2 e e' + eqv_f_g t1_eq e_eq e'_eq => + H1 gamma gamma' f g t1 t2 e e' + eqv_f_g t1_eq e_eq e'_eq + end. - Definition Lambda_eqv_ifmap (A B : Set) - (A' B' : eqv_i F A B -> Prop) i (f : forall i, A' i -> B' i) - (eqv_a : Lambda_eqv A B A' i) : Lambda_eqv A B B' i := - match eqv_a in Lambda_eqv _ _ _ i return Lambda_eqv _ _ _ i with - | Var_eqv gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq => - Var_eqv _ _ _ gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq - | App_eqv gamma gamma' a b a' b' e e' - eqv_a_a' eqv_b_b' e_eq e'_eq => - App_eqv _ _ _ gamma gamma' a b a' b' e e' - (f _ eqv_a_a') (f _ eqv_b_b') e_eq e'_eq - | Lam_eqv gamma gamma' f' g t1 t2 e e' - eqv_f_g t1_eq e_eq e'_eq => - Lam_eqv _ _ _ gamma gamma' f' g t1 t2 e e' - (fun a b => f _ (eqv_f_g a b)) t1_eq e_eq e'_eq - end. + Definition Lambda_eqv_ifmap (A B : Set) + (A' B' : eqv_i F A B -> Prop) i (f : forall i, A' i -> B' i) + (eqv_a : Lambda_eqv A B A' i) : Lambda_eqv A B B' i := + match eqv_a in Lambda_eqv _ _ _ i return Lambda_eqv _ _ _ i with + | Var_eqv gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq => + Var_eqv _ _ _ gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq + | App_eqv gamma gamma' a b a' b' e e' + eqv_a_a' eqv_b_b' e_eq e'_eq => + App_eqv _ _ _ gamma gamma' a b a' b' e e' + (f _ eqv_a_a') (f _ eqv_b_b') e_eq e'_eq + | Lam_eqv gamma gamma' f' g t1 t2 e e' + eqv_f_g t1_eq e_eq e'_eq => + Lam_eqv _ _ _ gamma gamma' f' g t1 t2 e e' + (fun a b => f _ (eqv_f_g a b)) t1_eq e_eq e'_eq + end. - Global Instance iFun_Lambda_eqv A B : iFunctor (Lambda_eqv A B). - constructor 1 with (ifmap := Lambda_eqv_ifmap A B). - destruct a; simpl; intros; reflexivity. - destruct a; simpl; intros; unfold id; eauto; - rewrite (functional_extensionality_dep _ a); eauto; - intros; apply functional_extensionality_dep; eauto. - Defined. - - Variable Sub_Lambda_eqv_EQV_E : forall A B, - Sub_iFunctor (Lambda_eqv A B) (EQV_E A B). - - Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) (F (typeofR D))}. - - Global Instance EQV_proj1_Lambda_eqv : - forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P F EQV_E A B) (Lambda_eqv _ _). - econstructor; intros. - unfold iAlgebra; intros; apply ind_alg_Lambda_eqv; - unfold EQV_proj1_P; simpl; intros; subst. - apply (inject_i (subGF := Sub_Lambda_eqv_EQV_E A B)); econstructor; simpl; eauto. - apply (inject_i (subGF := Sub_Lambda_eqv_EQV_E A B)); econstructor 2; simpl; eauto. - destruct a; destruct a'; eapply IHa; eauto. - destruct b; destruct b'; eapply IHb; eauto. - apply (inject_i (subGF := Sub_Lambda_eqv_EQV_E A B)); econstructor 3; simpl; eauto. - intros; caseEq (f a); caseEq (g b); apply IHf; eauto. - rewrite H2; simpl; eauto. - rewrite H3; simpl; eauto. - apply H. - Qed. + Global Instance iFun_Lambda_eqv A B : iFunctor (Lambda_eqv A B). + Proof. + constructor 1 with (ifmap := Lambda_eqv_ifmap A B). + destruct a; simpl; intros; reflexivity. + destruct a; simpl; intros; unfold id; eauto; + rewrite (functional_extensionality_dep _ a); eauto; + intros; apply functional_extensionality_dep; eauto. + Defined. + + Variable Sub_Lambda_eqv_EQV_E : forall A B, + Sub_iFunctor (Lambda_eqv A B) (EQV_E A B). + + Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) (F (typeofR D))}. + + Global Instance EQV_proj1_Lambda_eqv : + forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P F EQV_E A B) (Lambda_eqv _ _). + Proof. + econstructor; intros. + unfold iAlgebra; intros; apply ind_alg_Lambda_eqv; + unfold EQV_proj1_P; simpl; intros; subst. + apply (inject_i (subGF := Sub_Lambda_eqv_EQV_E A B)); econstructor; simpl; eauto. + apply (inject_i (subGF := Sub_Lambda_eqv_EQV_E A B)); econstructor 2; simpl; eauto. + destruct a; destruct a'; eapply IHa; eauto. + destruct b; destruct b'; eapply IHb; eauto. + apply (inject_i (subGF := Sub_Lambda_eqv_EQV_E A B)); econstructor 3; simpl; eauto. + intros; caseEq (f a); caseEq (g b); apply IHf; eauto. + rewrite H2; simpl; eauto. + rewrite H3; simpl; eauto. + apply H. + Qed. (* ============================================== *) (* WELL-FORMED FUNCTION VALUES *) (* ============================================== *) - Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. - Variable funWFV : iFunctor WFV. - Variable typeof_rec : Exp (typeofR D) -> typeofR D. - (** Functions are well-formed **) + Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. + Variable funWFV : iFunctor WFV. + Variable typeof_rec : Exp (typeofR D) -> typeofR D. + (** Functions are well-formed **) - Inductive WFValue_Clos - (WFV : WFValue_i D V -> Prop) : WFValue_i D V -> Prop := - | WFV_Clos : forall (f : option DType -> Names.Exp _) f' env gamma gamma' f'_UP + Inductive WFValue_Clos (WFV : WFValue_i D V -> Prop) : WFValue_i D V -> Prop := + WFV_Clos : forall (f : option DType -> Names.Exp _) f' env gamma gamma' f'_UP (t1 t2 t3 t4 : DType) v T, proj1_sig v = proj1_sig (closure' (exist _ (proj1_sig (f' (List.length gamma))) f'_UP) env) -> proj1_sig T = proj1_sig (tarrow' t1 t2) -> @@ -989,496 +1009,510 @@ Section Lambda. proj1_sig t4 = proj1_sig t1 -> WFValue_Clos WFV (mk_WFValue_i D V v T). - Context {WF_typeof_F : forall T, @WF_FAlgebra TypeofName T _ _ _ - (Sub_Lambda_F _) (MAlgebra_typeof_Lambda T) (Typeof_F _)}. - - Context {WF_Value_continous_alg : - iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SV}. - - Definition ind_alg_WFV_Clos - (P : WFValue_i D V -> Prop) - (P' : Env Value -> Env (option DType) -> Prop) - (H : forall f f' env gamma gamma' f'_UP t1 t2 t3 t4 v T - v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma' - P2_env lookup_gamma'' type_of_f t3_eq t4_eq, - P' env gamma -> - P (mk_WFValue_i _ _ v T)) - (H0 : P' nil nil) - (H1 : forall a b env env', - match b with - | Some T => P {| wfv_a := a; wfv_b := T |} - | None => False - end -> P' env env' -> - P' (a :: env) (b :: env')) - i (e : WFValue_Clos P i) : P i := - match e in WFValue_Clos _ i return P i with - | WFV_Clos f f' env gamma gamma' f'_UP t1 t2 t3 t4 v T - v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma' - P2_env lookup_gamma'' type_of_f t3_eq t4_eq => - H f f' env gamma gamma' f'_UP t1 t2 t3 t4 v T - v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma' - P2_env lookup_gamma'' type_of_f t3_eq t4_eq - ((fix P_Env_ind' (env : Env Value) (env' : Env (option DType)) - (P_env_env' : P2_Env (fun v T => match T with - | Some T => P (mk_WFValue_i _ _ v T) - | _ => False - end) env env') := - match P_env_env' in P2_Env _ As Bs return P' As Bs with - | P2_Nil => H0 - | P2_Cons a b As Bs P_a_b P_As_Bs => - H1 a b As Bs P_a_b (P_Env_ind' _ _ P_As_Bs) - end) env gamma P2_env) - end. + Context {WF_typeof_F : forall T, @WF_FAlgebra TypeofName T _ _ _ + (Sub_Lambda_F _) (MAlgebra_typeof_Lambda T) (Typeof_F _)}. + + Context {WF_Value_continous_alg : + iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SV}. + + Definition ind_alg_WFV_Clos + (P : WFValue_i D V -> Prop) + (P' : Env Value -> Env (option DType) -> Prop) + (H : forall f f' env gamma gamma' f'_UP t1 t2 t3 t4 v T + v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma' + P2_env lookup_gamma'' type_of_f t3_eq t4_eq, + P' env gamma -> + P (mk_WFValue_i _ _ v T)) + (H0 : P' nil nil) + (H1 : forall a b env env', + match b with + | Some T => P {| wfv_a := a; wfv_b := T |} + | None => False + end -> P' env env' -> + P' (a :: env) (b :: env')) + i (e : WFValue_Clos P i) : P i := + match e in WFValue_Clos _ i return P i with + | WFV_Clos f f' env gamma gamma' f'_UP t1 t2 t3 t4 v T + v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma' + P2_env lookup_gamma'' type_of_f t3_eq t4_eq => + H f f' env gamma gamma' f'_UP t1 t2 t3 t4 v T + v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma' + P2_env lookup_gamma'' type_of_f t3_eq t4_eq + ((fix P_Env_ind' (env : Env Value) (env' : Env (option DType)) + (P_env_env' : P2_Env (fun v T => match T with + | Some T => P (mk_WFValue_i _ _ v T) + | _ => False + end) env env') := + match P_env_env' in P2_Env _ As Bs return P' As Bs with + | P2_Nil => H0 + | P2_Cons a b As Bs P_a_b P_As_Bs => + H1 a b As Bs P_a_b (P_Env_ind' _ _ P_As_Bs) + end) env gamma P2_env) + end. - Definition WFV_Clos_ifmap - (A B : WFValue_i D V -> Prop) i - (g : forall i, A i -> B i) - (WFV_a : WFValue_Clos A i) : WFValue_Clos B i := - match WFV_a in (WFValue_Clos _ s) return (WFValue_Clos B s) - with - | WFV_Clos f f' env gamma gamma' f'_UP t1 t2 t3 t4 v T - v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma' - P2_env lookup_gamma'' type_of_f t3_eq t4_eq => - WFV_Clos _ f f' env gamma gamma' f'_UP t1 t2 t3 t4 v T - v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma' - ((fix P_Env_ind' (env : Env _) (env' : Env _) - (P_env_env' : P2_Env (fun v T => match T with - | Some T => A (mk_WFValue_i _ _ v T) - | _ => False - end) env env') := - match P_env_env' in P2_Env _ As Bs return - P2_Env (fun v T => match T with - | Some T => B (mk_WFValue_i _ _ v T) - | _ => False - end) As Bs with - | P2_Nil => P2_Nil _ - | P2_Cons a b As Bs P_a_b P_As_Bs => - P2_Cons (fun v T => match T with - | Some T => B (mk_WFValue_i _ _ v T) - | _ => False - end) - a b As Bs ((match b as b' return - (match b' with - | Some T => A (mk_WFValue_i _ _ a T) + Definition WFV_Clos_ifmap + (A B : WFValue_i D V -> Prop) i + (g : forall i, A i -> B i) + (WFV_a : WFValue_Clos A i) : WFValue_Clos B i := + match WFV_a in (WFValue_Clos _ s) return (WFValue_Clos B s) + with + | WFV_Clos f f' env gamma gamma' f'_UP t1 t2 t3 t4 v T + v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma' + P2_env lookup_gamma'' type_of_f t3_eq t4_eq => + WFV_Clos _ f f' env gamma gamma' f'_UP t1 t2 t3 t4 v T + v_eq T_e1 eqv_f_f' lookup_gamma' len_gamma_gamma' + ((fix P_Env_ind' (env : Env _) (env' : Env _) + (P_env_env' : P2_Env (fun v T => match T with + | Some T => A (mk_WFValue_i _ _ v T) + | _ => False + end) env env') := + match P_env_env' in P2_Env _ As Bs return + P2_Env (fun v T => match T with + | Some T => B (mk_WFValue_i _ _ v T) | _ => False - end) -> - (match b' with - | Some T => B (mk_WFValue_i _ _ a T) - | _ => False - end) with - | Some T => fun P_a_b' => g (mk_WFValue_i _ _ a T) P_a_b' - | None => fun P_a_b' => P_a_b' - end) P_a_b) (P_Env_ind' _ _ P_As_Bs) - end) _ _ P2_env) - lookup_gamma'' type_of_f t3_eq t4_eq - end. - - Global Instance iFun_WFV_Clos - : iFunctor (WFValue_Clos ). - constructor 1 with (ifmap := WFV_Clos_ifmap ). - destruct a; simpl; intros; - apply (f_equal (fun G => WFV_Clos C f0 f' env gamma gamma' f'_UP - t1 t2 t3 t4 v T e e0 e1 e2 e3 G e4 e5 e6 e7)). - generalize gamma p; clear; induction env; dependent inversion p; subst. - reflexivity. - rewrite IHenv. - apply (f_equal (fun G => P2_Cons - (fun (v : Names.Value V) (T : option (Names.DType D)) => - match T with - | Some T0 => C {| wfv_a := v; wfv_b := T0 |} - | None => False - end) a b env Bs G (((fix P_Env_ind' (env0 : Env (Names.Value V)) - (env' : Env (option (Names.DType D))) - (P_env_env' : P2_Env - (fun (v : Names.Value V) - (T : option (Names.DType D)) => - match T with - | Some T0 => - A {| wfv_a := v; wfv_b := T0 |} - | None => False - end) env0 env') {struct P_env_env'} : - P2_Env - (fun (v : Names.Value V) (T : option (Names.DType D)) => - match T with - | Some T0 => C {| wfv_a := v; wfv_b := T0 |} - | None => False - end) env0 env' := - match - P_env_env' in (P2_Env _ As Bs0) - return - (P2_Env - (fun (v : Names.Value V) (T : option (Names.DType D)) => - match T with - | Some T0 => C {| wfv_a := v; wfv_b := T0 |} - | None => False - end) As Bs0) - with - | P2_Nil => - P2_Nil - (fun (v : Names.Value V) (T : option (Names.DType D)) => - match T with - | Some T0 => C {| wfv_a := v; wfv_b := T0 |} - | None => False - end) - | P2_Cons a0 b0 As Bs0 P_a_b P_As_Bs => - P2_Cons - (fun (v : Names.Value V) (T : option (Names.DType D)) => - match T with - | Some T0 => C {| wfv_a := v; wfv_b := T0 |} - | None => False - end) a0 b0 As Bs0 - (match - b0 as b' - return - (match b' with - | Some T => A {| wfv_a := a0; wfv_b := T |} - | None => False - end -> - match b' with - | Some T => C {| wfv_a := a0; wfv_b := T |} - | None => False - end) - with - | Some T => - fun P_a_b' : A {| wfv_a := a0; wfv_b := T |} => - g {| wfv_a := a0; wfv_b := T |} - (f {| wfv_a := a0; wfv_b := T |} P_a_b') - | None => fun P_a_b' : False => P_a_b' - end P_a_b) (P_Env_ind' As Bs0 P_As_Bs) - end) env Bs p0)))). - destruct b; auto. - destruct a; simpl; intros; - apply (f_equal (fun G => WFV_Clos _ f f' env gamma gamma' f'_UP - t1 t2 t3 t4 v T e e0 e1 e2 e3 G e4 e5 e6 e7)). - generalize gamma p; clear; induction env; dependent inversion p; subst. - reflexivity. - rewrite IHenv. - apply (f_equal (fun y => P2_Cons - (fun (v : Names.Value V) (T : option (Names.DType D)) => - match T with - | Some T0 => A {| wfv_a := v; wfv_b := T0 |} - | None => False - end) a b env Bs y p0)). - destruct b; reflexivity. - Defined. - - Variable Sub_WFV_Clos_WFV : Sub_iFunctor WFValue_Clos WFV. - Variable Sub_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot _ _) WFV. - - Global Instance WFV_proj1_a_Clos : - iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) (WFValue_Clos ). - econstructor; intros. - unfold iAlgebra; intros; unfold WFV_proj1_a_P. - inversion H; subst; simpl; intros. - apply (inject_i (subGF := Sub_WFV_Clos_WFV )); econstructor; simpl; eauto. - rewrite H11; rewrite H0; simpl; reflexivity. - rewrite H1; simpl; reflexivity. - generalize gamma H5; clear; induction env; intros; inversion H5; - subst; constructor. - destruct b. - unfold WFV_proj1_a_P in H1; unfold WFValueC, WFValue in H1; - destruct a; eapply H1; eauto. - eauto. - eauto. - Defined. - - Global Instance WFV_proj1_b_Clos : - iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) (WFValue_Clos ). - econstructor; intros. - unfold iAlgebra; intros; unfold WFV_proj1_b_P. - inversion H; subst; simpl; intros. - apply (inject_i (subGF := Sub_WFV_Clos_WFV )); econstructor; simpl; eauto. - rewrite H11; rewrite H0; simpl; reflexivity. - rewrite H11; rewrite H1; reflexivity. - generalize gamma H5; clear; induction env; intros; inversion H5; - subst; constructor. - destruct b. - unfold WFV_proj1_b_P in H1; unfold WFValueC, WFValue in H1. - destruct d; eapply H1; eauto. - eauto. - eauto. - Defined. - - (* Inversion principles for Well-formed natural numbers. *) - Definition WF_invertClos_P (i : WFValue_i D V) := - WFValue _ _ WFV i /\ - forall t1 t2, proj1_sig (wfv_b _ _ i) = proj1_sig (tarrow' t1 t2) -> - WFValue_Clos (iFix WFV) i \/ WFValue_Bot _ _ (iFix WFV) i. - - Inductive WF_invertClos_Name := wfv_invertclosure_name. - Context {WF_invertClos_WFV : - iPAlgebra WF_invertClos_Name (WF_invertClos_P ) WFV}. - - Global Instance WF_invertClos_Clos : - iPAlgebra WF_invertClos_Name (WF_invertClos_P ) (WFValue_Clos ). - econstructor; intros. - unfold iAlgebra; intros; apply (ind_alg_WFV_Clos ) with (P' := - P2_Env (fun v T => match T with - | Some T => WFValueC _ _ WFV v T + end) As Bs with + | P2_Nil => P2_Nil _ + | P2_Cons a b As Bs P_a_b P_As_Bs => + P2_Cons (fun v T => match T with + | Some T => B (mk_WFValue_i _ _ v T) + | _ => False + end) + a b As Bs ((match b as b' return + (match b' with + | Some T => A (mk_WFValue_i _ _ a T) | _ => False - end)). - inversion H; subst; simpl; intros; split. - eapply (inject_i (subGF := Sub_WFV_Clos_WFV )); - econstructor 1 with (f'_UP := f'_UP0); simpl in *|-*; eauto. - left; econstructor 1 with (f'_UP := f'_UP0); simpl in *|-*; eauto; try congruence. - rewrite T_e1 in H11; apply (f_equal out_t) in H11; - repeat rewrite out_in_inverse in H11. - repeat rewrite wf_functor in H11; simpl in H11; - apply (f_equal prj) in H11; repeat rewrite prj_inj in H11; - injection H11; intros. - congruence. - rewrite T_e1 in H11; apply (f_equal out_t) in H11; - repeat rewrite out_in_inverse in H11. - repeat rewrite wf_functor in H11; simpl in H11; - apply (f_equal prj) in H11; repeat rewrite prj_inj in H11; - injection H11; intros. - congruence. - constructor. - constructor. - destruct b; destruct H0; eauto. - eassumption. - exact H. - Defined. - - Global Instance WF_invertClos_Bot : - iPAlgebra WF_invertClos_Name (WF_invertClos_P ) (WFValue_Bot _ _). - econstructor; intros. - unfold iAlgebra; intros; unfold WF_invertClos_P. - inversion H; subst; simpl; intros. - split. - apply (inject_i (subGF := Sub_WFV_Bot_WFV)); constructor; auto. - right; econstructor; eassumption. - Defined. - - Definition WF_invertClos := ifold_ WFV _ (ip_algebra (iPAlgebra := WF_invertClos_WFV )). - - Definition WF_invertClos'_P (i : WFValue_i D V) := - WFValue _ _ WFV i /\ - forall v : ClosValue _, proj1_sig (wfv_a _ _ i) = inject v -> - WFValue_Clos (iFix WFV) i. - - Inductive WF_invertClos'_Name := wfv_invertclosure'_name. - Context {WF_invertClos'_WFV : - iPAlgebra WF_invertClos'_Name (WF_invertClos'_P ) WFV}. - - Global Instance WF_invertClos'_Clos : - iPAlgebra WF_invertClos'_Name (WF_invertClos'_P ) (WFValue_Clos ). - econstructor; intros. - unfold iAlgebra; intros; apply (ind_alg_WFV_Clos ) with (P' := - P2_Env (fun v T => match T with - | Some T => WFValueC _ _ WFV v T + end) -> + (match b' with + | Some T => B (mk_WFValue_i _ _ a T) | _ => False - end)). - inversion H; subst; simpl; intros; split. - eapply (inject_i (subGF := Sub_WFV_Clos_WFV )); - econstructor 1 with (f'_UP := f'_UP0); - simpl in *|-*; eauto. - intros; econstructor 1 with (f'_UP := f'_UP0); simpl in *|-*; eauto. - left; econstructor; simpl in *|-*; eauto; try congruence. - intros; constructor; auto. - destruct b; destruct H0; auto. - assumption. - Defined. - - Global Instance WF_invertClos'_Bot : - iPAlgebra WF_invertClos'_Name (WF_invertClos'_P ) (WFValue_Bot _ _). - econstructor; intros. - unfold iAlgebra; intros; unfold WF_invertClos'_P. - inversion H; subst; simpl; intros. - split. - apply (inject_i (subGF := Sub_WFV_Bot_WFV)); constructor; auto. - rewrite H0; intros. - elimtype False. - eapply (inject_discriminate Dis_Clos_Bot); unfold inject in *|-*; simpl in *|-*; eauto; - apply f_equal; apply f_equal; apply sym_eq; eapply H10. - Defined. - - Definition WF_invertClos' := - ifold_ WFV _ (ip_algebra (iPAlgebra := WF_invertClos'_WFV )). - - Context {WFV_proj1_a_WFV : - iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFV}. - Context {WFV_proj1_b_WFV : - iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFV}. - - Global Instance WFV_Value_continuous_Clos : - iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SubValue_Clos. - Proof. - constructor; unfold iAlgebra; intros. - eapply ind_alg_SV_Clos with (P' := fun env env' => forall env0 gamma, - P2_Env (fun (v0 : Names.Value V) (T0 : option (Names.DType D)) => - match T0 with - | Some T1 => iFix WFV {| wfv_a := v0; wfv_b := T1 |} - | None => False - end) env0 gamma -> - map (@proj1_sig _ _) env0 = map (@proj1_sig _ _) env' -> - P2_Env (fun (v0 : Names.Value V) (T0 : option (Names.DType D)) => - match T0 with - | Some T1 => iFix WFV {| wfv_a := v0; wfv_b := T1 |} - | None => False - end) env gamma); try eassumption. - unfold WF_Value_continuous_P; intros. - destruct (WF_invertClos' _ H4) as [_ H5]; simpl in H5; generalize (H5 _ H3); clear H5. - intros H3'; inversion H3'; subst. - rewrite H3 in H7; simpl in H7. - apply in_t_UP'_inject in H7; repeat rewrite wf_functor in H7; - simpl in H7. - apply (f_equal (prj (sub_F := ClosValue))) in H7. - repeat rewrite prj_inj in H7; injection H7; intros; subst; - clear H7. - destruct f as [f f_UP]. - simpl in H0. - revert f_UP H2; rewrite H0; intros. - apply (inject_i (subGF := (Sub_WFV_Clos_WFV ))). - econstructor 1 with (f' := f'0) (env := env) (gamma := gamma) - (f'_UP := f_UP); eauto. - intros; destruct env0; simpl in H1; try discriminate; auto. - intros; destruct env0; simpl in H1; try discriminate; auto. - inversion H2; subst. - econstructor. - destruct b; try destruct H6. - simpl in H3; injection H3; intros; subst. - apply H0. - destruct (v) as [v v_UP']; destruct (sv_b V i0) as [b b_UP']. - eapply WFV_proj1_a with (i := {| wfv_a := exist _ _ v_UP'; wfv_b := d |}); - auto. - eapply H1; eauto. - injection H3; intros; auto. - Defined. - - Lemma isClos_closure : forall t1 f, isClos (proj1_sig (closure' t1 f)) = - Some (t1, map (fun e => in_t_UP' _ _ (out_t_UP' _ _ e)) (map (@proj1_sig _ _) f)). - intros; unfold isClos, project; simpl; rewrite out_in_fmap; - repeat rewrite wf_functor; simpl; rewrite prj_inj; auto. - Qed. - - Lemma isClos_bot : isClos (proj1_sig (bot')) = None. - intros; unfold isClos, project; simpl; rewrite out_in_fmap; - repeat rewrite wf_functor; simpl; unfold Bot_fmap. - caseEq (prj (sub_F := ClosValue) (inj (Bot (sig (Universal_Property'_fold (F := V)))))). - elimtype False; apply inj_prj in H. - eapply (inject_discriminate Dis_Clos_Bot); unfold inject in *|-*; simpl in *|-*; - apply f_equal; apply f_equal; apply sym_eq; eapply H. + end) with + | Some T => fun P_a_b' => g (mk_WFValue_i _ _ a T) P_a_b' + | None => fun P_a_b' => P_a_b' + end) P_a_b) (P_Env_ind' _ _ P_As_Bs) + end) _ _ P2_env) + lookup_gamma'' type_of_f t3_eq t4_eq + end. + + Global Instance iFun_WFV_Clos : iFunctor (WFValue_Clos ) := + {| ifmap := WFV_Clos_ifmap + |}. + Proof. + destruct a; simpl; intros; + apply (f_equal (fun G => WFV_Clos C f0 f' env gamma gamma' f'_UP + t1 t2 t3 t4 v T e e0 e1 e2 e3 G e4 e5 e6 e7)). + generalize gamma p; clear; induction env; dependent inversion p; subst. + reflexivity. + rewrite IHenv. + apply (f_equal (fun G => P2_Cons + (fun (v : Names.Value V) (T : option (Names.DType D)) => + match T with + | Some T0 => C {| wfv_a := v; wfv_b := T0 |} + | None => False + end) a b env Bs G (((fix P_Env_ind' (env0 : Env (Names.Value V)) + (env' : Env (option (Names.DType D))) + (P_env_env' : P2_Env + (fun (v : Names.Value V) + (T : option (Names.DType D)) => + match T with + | Some T0 => + A {| wfv_a := v; wfv_b := T0 |} + | None => False + end) env0 env') {struct P_env_env'} : + P2_Env + (fun (v : Names.Value V) (T : option (Names.DType D)) => + match T with + | Some T0 => C {| wfv_a := v; wfv_b := T0 |} + | None => False + end) env0 env' := + match + P_env_env' in (P2_Env _ As Bs0) + return + (P2_Env + (fun (v : Names.Value V) (T : option (Names.DType D)) => + match T with + | Some T0 => C {| wfv_a := v; wfv_b := T0 |} + | None => False + end) As Bs0) + with + | P2_Nil => + P2_Nil + (fun (v : Names.Value V) (T : option (Names.DType D)) => + match T with + | Some T0 => C {| wfv_a := v; wfv_b := T0 |} + | None => False + end) + | P2_Cons a0 b0 As Bs0 P_a_b P_As_Bs => + P2_Cons + (fun (v : Names.Value V) (T : option (Names.DType D)) => + match T with + | Some T0 => C {| wfv_a := v; wfv_b := T0 |} + | None => False + end) a0 b0 As Bs0 + (match + b0 as b' + return + (match b' with + | Some T => A {| wfv_a := a0; wfv_b := T |} + | None => False + end -> + match b' with + | Some T => C {| wfv_a := a0; wfv_b := T |} + | None => False + end) + with + | Some T => + fun P_a_b' : A {| wfv_a := a0; wfv_b := T |} => + g {| wfv_a := a0; wfv_b := T |} + (f {| wfv_a := a0; wfv_b := T |} P_a_b') + | None => fun P_a_b' : False => P_a_b' + end P_a_b) (P_Env_ind' As Bs0 P_As_Bs) + end) env Bs p0)))). + destruct b; auto. + destruct a; simpl; intros; + apply (f_equal (fun G => WFV_Clos _ f f' env gamma gamma' f'_UP + t1 t2 t3 t4 v T e e0 e1 e2 e3 G e4 e5 e6 e7)). + generalize gamma p; clear; induction env; dependent inversion p; subst. + reflexivity. + rewrite IHenv. + apply (f_equal (fun y => P2_Cons + (fun (v : Names.Value V) (T : option (Names.DType D)) => + match T with + | Some T0 => A {| wfv_a := v; wfv_b := T0 |} + | None => False + end) a b env Bs y p0)). + destruct b; reflexivity. + Defined. + + Variable Sub_WFV_Clos_WFV : Sub_iFunctor WFValue_Clos WFV. + Variable Sub_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot _ _) WFV. + + Global Instance WFV_proj1_a_Clos : + iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) (WFValue_Clos ). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WFV_proj1_a_P. + inversion H; subst; simpl; intros. + apply (inject_i (subGF := Sub_WFV_Clos_WFV )); econstructor; simpl; eauto. + rewrite H11; rewrite H0; simpl; reflexivity. + rewrite H1; simpl; reflexivity. + generalize gamma H5; clear; induction env; intros; inversion H5; + subst; constructor. + destruct b. + unfold WFV_proj1_a_P in H1; unfold WFValueC, WFValue in H1; + destruct a; eapply H1; eauto. + eauto. + eauto. + Defined. + + Global Instance WFV_proj1_b_Clos : + iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) (WFValue_Clos ). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WFV_proj1_b_P. + inversion H; subst; simpl; intros. + apply (inject_i (subGF := Sub_WFV_Clos_WFV )); econstructor; simpl; eauto. + rewrite H11; rewrite H0; simpl; reflexivity. + rewrite H11; rewrite H1; reflexivity. + generalize gamma H5; clear; induction env; intros; inversion H5; + subst; constructor. + destruct b. + unfold WFV_proj1_b_P in H1; unfold WFValueC, WFValue in H1. + destruct d; eapply H1; eauto. + eauto. + eauto. + Defined. + + (* Inversion principles for Well-formed natural numbers. *) + Definition WF_invertClos_P (i : WFValue_i D V) := + WFValue _ _ WFV i /\ + forall t1 t2, proj1_sig (wfv_b _ _ i) = proj1_sig (tarrow' t1 t2) -> + WFValue_Clos (iFix WFV) i \/ WFValue_Bot _ _ (iFix WFV) i. + + Inductive WF_invertClos_Name := wfv_invertclosure_name. + Context {WF_invertClos_WFV : + iPAlgebra WF_invertClos_Name (WF_invertClos_P ) WFV}. + + Global Instance WF_invertClos_Clos : + iPAlgebra WF_invertClos_Name (WF_invertClos_P ) (WFValue_Clos ). + Proof. + econstructor; intros. + unfold iAlgebra; intros; apply (ind_alg_WFV_Clos ) with (P' := + P2_Env (fun v T => match T with + | Some T => WFValueC _ _ WFV v T + | _ => False + end)). + inversion H; subst; simpl; intros; split. + eapply (inject_i (subGF := Sub_WFV_Clos_WFV )); + econstructor 1 with (f'_UP := f'_UP0); simpl in *|-*; eauto. + left; econstructor 1 with (f'_UP := f'_UP0); simpl in *|-*; eauto; try congruence. + rewrite T_e1 in H11; apply (f_equal out_t) in H11; + repeat rewrite out_in_inverse in H11. + repeat rewrite wf_functor in H11; simpl in H11; + apply (f_equal prj) in H11; repeat rewrite prj_inj in H11; + injection H11; intros. + congruence. + rewrite T_e1 in H11; apply (f_equal out_t) in H11; + repeat rewrite out_in_inverse in H11. + repeat rewrite wf_functor in H11; simpl in H11; + apply (f_equal prj) in H11; repeat rewrite prj_inj in H11; + injection H11; intros. + congruence. + constructor. + constructor. + destruct b; destruct H0; eauto. + eassumption. + exact H. + Defined. + + Global Instance WF_invertClos_Bot : + iPAlgebra WF_invertClos_Name (WF_invertClos_P ) (WFValue_Bot _ _). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WF_invertClos_P. + inversion H; subst; simpl; intros. + split. + apply (inject_i (subGF := Sub_WFV_Bot_WFV)); constructor; auto. + right; econstructor; eassumption. + Defined. + + Definition WF_invertClos := ifold_ WFV _ (ip_algebra (iPAlgebra := WF_invertClos_WFV )). + + Definition WF_invertClos'_P (i : WFValue_i D V) := + WFValue _ _ WFV i /\ + forall v : ClosValue _, proj1_sig (wfv_a _ _ i) = inject v -> + WFValue_Clos (iFix WFV) i. + + Inductive WF_invertClos'_Name := wfv_invertclosure'_name. + Context {WF_invertClos'_WFV : + iPAlgebra WF_invertClos'_Name (WF_invertClos'_P ) WFV}. + + Global Instance WF_invertClos'_Clos : + iPAlgebra WF_invertClos'_Name (WF_invertClos'_P ) (WFValue_Clos ). + Proof. + econstructor; intros. + unfold iAlgebra; intros; apply (ind_alg_WFV_Clos ) with (P' := + P2_Env (fun v T => match T with + | Some T => WFValueC _ _ WFV v T + | _ => False + end)). + inversion H; subst; simpl; intros; split. + eapply (inject_i (subGF := Sub_WFV_Clos_WFV )); + econstructor 1 with (f'_UP := f'_UP0); + simpl in *|-*; eauto. + intros; econstructor 1 with (f'_UP := f'_UP0); simpl in *|-*; eauto. + left; econstructor; simpl in *|-*; eauto; try congruence. + intros; constructor; auto. + destruct b; destruct H0; auto. + assumption. + Defined. + + Global Instance WF_invertClos'_Bot : + iPAlgebra WF_invertClos'_Name (WF_invertClos'_P ) (WFValue_Bot _ _). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WF_invertClos'_P. + inversion H; subst; simpl; intros. + split. + apply (inject_i (subGF := Sub_WFV_Bot_WFV)); constructor; auto. + rewrite H0; intros. + elimtype False. + eapply (inject_discriminate Dis_Clos_Bot); unfold inject in *|-*; simpl in *|-*; eauto; + apply f_equal; apply f_equal; apply sym_eq; eapply H10. + Defined. + + Definition WF_invertClos' := + ifold_ WFV _ (ip_algebra (iPAlgebra := WF_invertClos'_WFV )). + + Context {WFV_proj1_a_WFV : + iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFV}. + Context {WFV_proj1_b_WFV : + iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFV}. + + Global Instance WFV_Value_continuous_Clos : + iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SubValue_Clos. + Proof. + constructor; unfold iAlgebra; intros. + eapply ind_alg_SV_Clos with (P' := fun env env' => forall env0 gamma, + P2_Env (fun (v0 : Names.Value V) (T0 : option (Names.DType D)) => + match T0 with + | Some T1 => iFix WFV {| wfv_a := v0; wfv_b := T1 |} + | None => False + end) env0 gamma -> + map (@proj1_sig _ _) env0 = map (@proj1_sig _ _) env' -> + P2_Env (fun (v0 : Names.Value V) (T0 : option (Names.DType D)) => + match T0 with + | Some T1 => iFix WFV {| wfv_a := v0; wfv_b := T1 |} + | None => False + end) env gamma); try eassumption. + unfold WF_Value_continuous_P; intros. + destruct (WF_invertClos' _ H4) as [_ H5]; simpl in H5; generalize (H5 _ H3); clear H5. + intros H3'; inversion H3'; subst. + rewrite H3 in H7; simpl in H7. + apply in_t_UP'_inject in H7; repeat rewrite wf_functor in H7; + simpl in H7. + apply (f_equal (prj (sub_F := ClosValue))) in H7. + repeat rewrite prj_inj in H7; injection H7; intros; subst; + clear H7. + destruct f as [f f_UP]. + simpl in H0. + revert f_UP H2; rewrite H0; intros. + apply (inject_i (subGF := (Sub_WFV_Clos_WFV ))). + econstructor 1 with (f' := f'0) (env := env) (gamma := gamma) + (f'_UP := f_UP); eauto. + intros; destruct env0; simpl in H1; try discriminate; auto. + intros; destruct env0; simpl in H1; try discriminate; auto. + inversion H2; subst. + econstructor. + destruct b; try destruct H6. + simpl in H3; injection H3; intros; subst. + apply H0. + destruct (v) as [v v_UP']; destruct (sv_b V i0) as [b b_UP']. + eapply WFV_proj1_a with (i := {| wfv_a := exist _ _ v_UP'; wfv_b := d |}); auto. - Qed. - - Lemma isBot_closure : forall t1 f, isBot _ (proj1_sig (closure' t1 f)) = false. - intros; unfold isBot, project; simpl; rewrite out_in_fmap; - repeat rewrite wf_functor; simpl. - caseEq (prj (sub_F := BotValue) (inj (Clos _ t1 - (map (fun e : Fix V => in_t_UP' V Fun_V (out_t_UP' V Fun_V e)) - (map (@proj1_sig _ _) f))))). - elimtype False; apply inj_prj in H. - eapply (inject_discriminate Dis_Clos_Bot); unfold inject in *|-*; simpl in *|-*; - apply f_equal; apply f_equal; eapply H. + eapply H1; eauto. + injection H3; intros; auto. + Defined. + + Lemma isClos_closure : forall t1 f, isClos (proj1_sig (closure' t1 f)) = + Some (t1, map (fun e => in_t_UP' _ _ (out_t_UP' _ _ e)) (map (@proj1_sig _ _) f)). + Proof. + intros; unfold isClos, project; simpl; rewrite out_in_fmap; + repeat rewrite wf_functor; simpl; rewrite prj_inj; auto. + Qed. + + Lemma isClos_bot : + isClos (proj1_sig (bot')) = None. + Proof. + intros; unfold isClos, project; simpl; rewrite out_in_fmap; + repeat rewrite wf_functor; simpl; unfold Bot_fmap. + caseEq (prj (sub_F := ClosValue) (inj (Bot (sig (Universal_Property'_fold (F := V)))))). + elimtype False; apply inj_prj in H. + eapply (inject_discriminate Dis_Clos_Bot); unfold inject in *|-*; simpl in *|-*; + apply f_equal; apply f_equal; apply sym_eq; eapply H. + auto. + Qed. + + Lemma isBot_closure : + forall t1 f, isBot _ (proj1_sig (closure' t1 f)) = false. + Proof. + intros; unfold isBot, project; simpl; rewrite out_in_fmap; + repeat rewrite wf_functor; simpl. + caseEq (prj (sub_F := BotValue) (inj (Clos _ t1 + (map (fun e : Fix V => in_t_UP' V Fun_V (out_t_UP' V Fun_V e)) + (map (@proj1_sig _ _) f))))). + elimtype False; apply inj_prj in H. + eapply (inject_discriminate Dis_Clos_Bot); unfold inject in *|-*; simpl in *|-*; + apply f_equal; apply f_equal; eapply H. + auto. + Qed. + + Lemma isBot_bot : + isBot _ (proj1_sig (bot')) = true. + Proof. + intros; unfold isBot, project; simpl; rewrite out_in_fmap; + repeat rewrite wf_functor; simpl. + rewrite prj_inj; unfold Bot_fmap; auto. + Qed. + + Context {EQV_proj1_EQV : forall A B, + iPAlgebra EQV_proj1_Name (@EQV_proj1_P _ _ (EQV_E) A B) (EQV_E A B)}. + + Global Instance Lambda_eqv_eval_soundness_alg : forall eval_rec, + iPAlgebra soundness_XName + (soundness_X'_P D V F EQV_E WFV + typeof_rec eval_rec + (f_algebra (FAlgebra := Typeof_F _)) + (f_algebra (FAlgebra := eval_F))) (Lambda_eqv _ _). + Proof. + econstructor; unfold iAlgebra; intros. + eapply ind_alg_Lambda_eqv; try eassumption; + unfold soundness_X'_P, eval_alg_Soundness_P; simpl; intros. + (* Var Case *) + rewrite e'_eq; split. + apply inject_i; econstructor; eauto. + intros; unfold var, var'; simpl; erewrite out_in_fmap; + repeat rewrite wf_functor; simpl. + rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. + destruct WF_gamma'' as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]]; + simpl in *|-*. + rewrite (WF_gamma' _ _ lookup_b) in *|-*. + destruct (P2_Env_lookup' _ _ _ _ _ WF_gamma'' _ _ lookup_a) as [v [lookup_v WF_v]]; + unfold Value; rewrite lookup_v. + destruct a; eauto. + rename H0 into typeof_d. + rewrite e_eq in typeof_d; unfold typeof, mfold, var in typeof_d; + simpl in typeof_d; rewrite wf_functor in typeof_d; simpl in typeof_d; + rewrite out_in_fmap in typeof_d; rewrite wf_functor in typeof_d; + simpl in typeof_d; + rewrite (wf_algebra (WF_FAlgebra := WF_typeof_F _)) in typeof_d; + simpl in typeof_d; injection typeof_d; intros; subst; auto. + destruct WF_v. + (* app case *) + destruct (IHa IH) as [eqv_a _]; destruct (IHb IH) as [eqv_b _]. + rewrite e'_eq; split. + apply inject_i; econstructor 2; simpl; try apply e_eq; try apply e'_eq; eauto. + intros; simpl; erewrite out_in_fmap; + repeat rewrite wf_functor; simpl. + rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. + destruct a' as [a' UP_a']. + rename H0 into typeof_e. + rewrite e_eq in typeof_e; unfold typeof, mfold, var in typeof_e; + simpl in typeof_e; rewrite wf_functor in typeof_e; simpl in typeof_e; + rewrite out_in_fmap in typeof_e; rewrite wf_functor in typeof_e; + simpl in typeof_e; + rewrite (wf_algebra (WF_FAlgebra := WF_typeof_F _)) in typeof_e; + simpl in typeof_e. + caseEq (typeof_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig a)))); rename H0 into typeof_a; + rewrite typeof_a in typeof_e; try discriminate. + caseEq (typeof_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig b)))); rename H0 into typeof_b; + rewrite typeof_b in typeof_e; try discriminate. + caseEq (isTArrow d); rewrite H0 in typeof_e; try discriminate. + destruct p as [t1 t2]. + caseEq (eq_DType D (proj1_sig t1) d0); rename H1 into eq_t1; + rewrite eq_t1 in typeof_e; try discriminate; injection typeof_e; intros; subst; clear typeof_e. + assert (E_eqv (typeofR D) nat + {| + env_A := gamma; + env_B := gamma'; + eqv_a := (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig a))); + eqv_b := exist Universal_Property'_fold a' UP_a'|}) as eqv_a' by + (apply (EQV_proj1 _ EQV_E _ _ _ eqv_a); simpl; auto; + rewrite <- (in_out_UP'_inverse _ _ (proj1_sig a)) at -1; + simpl; auto; exact (proj2_sig _)). + generalize (IH (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig a))) _ _ _ + WF_gamma'' d eqv_a' typeof_a); + intros WF_a'. + unfold isTArrow in H0. + caseEq (project (proj1_sig d)); rename H1 into typeof_d; + rewrite typeof_d in H0; try discriminate; destruct l. + unfold project in typeof_d; apply inj_prj in typeof_d. + apply (f_equal (fun g => proj1_sig (in_t_UP' D Fun_D g))) in typeof_d; + rewrite in_out_UP'_inverse in typeof_d; [simpl in typeof_d | exact (proj2_sig d)]. + destruct (WF_invertClos _ WF_a') as [_ VWF_a']; clear WF_a'; + destruct (VWF_a' s s0 typeof_d) as [WF_a' | WF_a']; inversion WF_a'; subst. + simpl; rewrite H3. + rewrite isClos_closure; simpl. + rewrite (eval_rec_proj). + assert (WF_eqv_environment_P D V WFV (insert _ (Some t4) gamma0, + insert _ (Datatypes.length gamma'0) gamma'0) + (insert _ (eval_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig b'))) gamma'') + (map (fun e0 : Fix V => in_t_UP' _ _ (out_t_UP' _ _ e0)) + (map (@proj1_sig _ _) env)))). + eapply WF_eqv_environment_P_insert; repeat split; eauto. + simpl; revert WFV_proj1_a_WFV funWFV H8; clear; + intros; induction H8; simpl; constructor; auto. + destruct b; auto. + eapply WFV_proj1_a with (i := {| wfv_a := a; wfv_b := d |}); auto. - Qed. - - Lemma isBot_bot : isBot _ (proj1_sig (bot')) = true. - intros; unfold isBot, project; simpl; rewrite out_in_fmap; - repeat rewrite wf_functor; simpl. - rewrite prj_inj; unfold Bot_fmap; auto. - Qed. - - Context {EQV_proj1_EQV : forall A B, - iPAlgebra EQV_proj1_Name (@EQV_proj1_P _ _ (EQV_E) A B) (EQV_E A B)}. - - Global Instance Lambda_eqv_eval_soundness_alg : forall eval_rec, - iPAlgebra soundness_XName - (soundness_X'_P D V F EQV_E WFV - typeof_rec eval_rec - (f_algebra (FAlgebra := Typeof_F _)) - (f_algebra (FAlgebra := eval_F))) (Lambda_eqv _ _). - Proof. - econstructor; unfold iAlgebra; intros. - eapply ind_alg_Lambda_eqv; try eassumption; - unfold soundness_X'_P, eval_alg_Soundness_P; simpl; intros. - (* Var Case *) - rewrite e'_eq; split. - apply inject_i; econstructor; eauto. - intros; unfold var, var'; simpl; erewrite out_in_fmap; - repeat rewrite wf_functor; simpl. - rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. - destruct WF_gamma'' as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]]; - simpl in *|-*. - rewrite (WF_gamma' _ _ lookup_b) in *|-*. - destruct (P2_Env_lookup' _ _ _ _ _ WF_gamma'' _ _ lookup_a) as [v [lookup_v WF_v]]; - unfold Value; rewrite lookup_v. - destruct a; eauto. - rename H0 into typeof_d. - rewrite e_eq in typeof_d; unfold typeof, mfold, var in typeof_d; - simpl in typeof_d; rewrite wf_functor in typeof_d; simpl in typeof_d; - rewrite out_in_fmap in typeof_d; rewrite wf_functor in typeof_d; - simpl in typeof_d; - rewrite (wf_algebra (WF_FAlgebra := WF_typeof_F _)) in typeof_d; - simpl in typeof_d; injection typeof_d; intros; subst; auto. - destruct WF_v. - (* app case *) - destruct (IHa IH) as [eqv_a _]; destruct (IHb IH) as [eqv_b _]. - rewrite e'_eq; split. - apply inject_i; econstructor 2; simpl; try apply e_eq; try apply e'_eq; eauto. - intros; simpl; erewrite out_in_fmap; - repeat rewrite wf_functor; simpl. - rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. - destruct a' as [a' UP_a']. - rename H0 into typeof_e. - rewrite e_eq in typeof_e; unfold typeof, mfold, var in typeof_e; - simpl in typeof_e; rewrite wf_functor in typeof_e; simpl in typeof_e; - rewrite out_in_fmap in typeof_e; rewrite wf_functor in typeof_e; - simpl in typeof_e; - rewrite (wf_algebra (WF_FAlgebra := WF_typeof_F _)) in typeof_e; - simpl in typeof_e. - caseEq (typeof_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig a)))); rename H0 into typeof_a; - rewrite typeof_a in typeof_e; try discriminate. - caseEq (typeof_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig b)))); rename H0 into typeof_b; - rewrite typeof_b in typeof_e; try discriminate. - caseEq (isTArrow d); rewrite H0 in typeof_e; try discriminate. - destruct p as [t1 t2]. - caseEq (eq_DType D (proj1_sig t1) d0); rename H1 into eq_t1; - rewrite eq_t1 in typeof_e; try discriminate; injection typeof_e; intros; subst; clear typeof_e. - assert (E_eqv (typeofR D) nat - {| - env_A := gamma; - env_B := gamma'; - eqv_a := (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig a))); - eqv_b := exist Universal_Property'_fold a' UP_a'|}) as eqv_a' by - (apply (EQV_proj1 _ EQV_E _ _ _ eqv_a); simpl; auto; - rewrite <- (in_out_UP'_inverse _ _ (proj1_sig a)) at -1; - simpl; auto; exact (proj2_sig _)). - generalize (IH (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig a))) _ _ _ - WF_gamma'' d eqv_a' typeof_a); - intros WF_a'. - unfold isTArrow in H0. - caseEq (project (proj1_sig d)); rename H1 into typeof_d; - rewrite typeof_d in H0; try discriminate; destruct l. - unfold project in typeof_d; apply inj_prj in typeof_d. - apply (f_equal (fun g => proj1_sig (in_t_UP' D Fun_D g))) in typeof_d; - rewrite in_out_UP'_inverse in typeof_d; [simpl in typeof_d | exact (proj2_sig d)]. - destruct (WF_invertClos _ WF_a') as [_ VWF_a']; clear WF_a'; - destruct (VWF_a' s s0 typeof_d) as [WF_a' | WF_a']; inversion WF_a'; subst. - simpl; rewrite H3. - rewrite isClos_closure; simpl. - rewrite (eval_rec_proj). - assert (WF_eqv_environment_P D V WFV (insert _ (Some t4) gamma0, - insert _ (Datatypes.length gamma'0) gamma'0) - (insert _ (eval_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig b'))) gamma'') - (map (fun e0 : Fix V => in_t_UP' _ _ (out_t_UP' _ _ e0)) - (map (@proj1_sig _ _) env)))). - eapply WF_eqv_environment_P_insert; repeat split; eauto. - simpl; revert WFV_proj1_a_WFV funWFV H8; clear; - intros; induction H8; simpl; constructor; auto. - destruct b; auto. - eapply WFV_proj1_a with (i := {| wfv_a := a; wfv_b := d |}); - auto. - erewrite <- in_out_UP'_inverse; simpl; auto; exact (proj2_sig _). - rewrite eval_rec_proj. - destruct b' as [b' b'_UP']; destruct t4 as [t4 t4_UP']. - eapply WFV_proj1_b with (i := {| wfv_a := _; wfv_b := d0 |}); auto. - eapply IH; eauto. - apply (EQV_proj1 _ EQV_E _ _ _ eqv_b); simpl. - erewrite <- in_out_UP'_inverse; simpl; auto; exact (proj2_sig _). - erewrite <- in_out_UP'_inverse; simpl; auto; exact (proj2_sig _). - simpl. + erewrite <- in_out_UP'_inverse; simpl; auto; exact (proj2_sig _). + rewrite eval_rec_proj. + destruct b' as [b' b'_UP']; destruct t4 as [t4 t4_UP']. + eapply WFV_proj1_b with (i := {| wfv_a := _; wfv_b := d0 |}); auto. + eapply IH; eauto. + apply (EQV_proj1 _ EQV_E _ _ _ eqv_b); simpl. + erewrite <- in_out_UP'_inverse; simpl; auto; exact (proj2_sig _). + erewrite <- in_out_UP'_inverse; simpl; auto; exact (proj2_sig _). + simpl. simpl in H12; rewrite H12; apply sym_eq. rewrite typeof_d in H4; simpl in H4; apply in_t_UP'_inject in H4; repeat rewrite wf_functor in H4. @@ -1543,7 +1577,7 @@ Section Lambda. reflexivity. Defined. - End Lambda. +End Lambda. (* *** Local Variables: *** diff --git a/MiniML.v b/MiniML.v index d04bef7..7006b6a 100644 --- a/MiniML.v +++ b/MiniML.v @@ -12,24 +12,24 @@ Require Import NatCase. Section MiniML. -Open Scope string_scope. + Open Scope string_scope. -Definition D := AType :+: LType :+: BType. + Definition D := AType :+: LType :+: BType. -Definition E (A : Set) := Arith :+: (Lambda D A) :+: Bool :+: (Fix_ D A) :+: (NatCase A). + Definition E (A : Set) := Arith :+: (Lambda D A) :+: Bool :+: (Fix_ D A) :+: (NatCase A). -Definition letrec (A : Set) (t : DType D) (def : A -> Exp E A) (body : A -> Exp E A) : - (Exp E A) := app' D E (lam' _ _ t body) (mu' _ _ t def). + Definition letrec (A : Set) (t : DType D) (def : A -> Exp E A) (body : A -> Exp E A) : + (Exp E A) := app' D E (lam' _ _ t body) (mu' _ _ t def). -Instance D_typeof T : FAlgebra TypeofName T (typeofR D) (E (typeofR D)). - eauto with typeclass_instances. -Defined. + Instance D_typeof T : FAlgebra TypeofName T (typeofR D) (E (typeofR D)). + eauto with typeclass_instances. + Defined. -Global Instance Fun_E : forall (A : Set), - Functor (E A). -Proof. - eauto with typeclass_instances. -Defined. + Global Instance Fun_E : forall (A : Set), + Functor (E A). + Proof. + eauto with typeclass_instances. + Defined. Definition V := StuckValue :+: BotValue :+: NatValue :+: (ClosValue E) :+: (BoolValue). @@ -63,6 +63,7 @@ Defined. forall n (Sub_G_G' : Sub_Environment V SV gamma gamma'), m <= n -> SubValueC _ SV (beval _ _ m e gamma) (beval _ _ n e gamma'). + Proof. eapply beval_continuous with (eval_continuous_Exp_E := EV_Alg); eauto 800 with typeclass_instances. Qed. @@ -74,7 +75,8 @@ Defined. (sig (UP'_P2 (eval_alg_Soundness_P D V (E nat) WFV P_bind P (E (typeofR D)) (Fun_E (typeofR D)) pb typeof_rec eval_rec f_algebra f_algebra))) Bool. - eauto 250 with typeclass_instances. + Proof. + eauto 250 with typeclass_instances. Defined. Theorem soundness : forall n gamma gamma' gamma'' e' e'', diff --git a/Mu.v b/Mu.v index 8fa9280..b7f3068 100644 --- a/Mu.v +++ b/Mu.v @@ -22,19 +22,18 @@ Section Mu. (** Functor Instance **) - Definition fmapFix {A} : forall (X Y: Set), (X -> Y) -> (Fix_ A X -> Fix_ A Y):= - fun _ _ f e => + Definition fmapFix {A} (X Y: Set) (f : X -> Y) : Fix_ A X -> Fix_ A Y := + fun e => match e with - | Mu t g => Mu _ _ t (fun a => f (g a)) + | Mu t g => Mu _ _ t (fun a => f (g a)) end. Global Instance FixFunctor A : Functor (Fix_ A) | 5 := - {| fmap := fmapFix - |}. + {| fmap := fmapFix |}. Proof. - (* fmap fusion *) + (* fmap fusion *) intros. destruct a; unfold fmapFix; reflexivity. - (* fmap id *) + (* fmap id *) intros; destruct a; unfold fmapFix. assert ((fun x => a x) = a) by (apply functional_extensionality; intro; reflexivity). @@ -65,13 +64,13 @@ Section Mu. : Fix (F A) := proj1_sig (mu' t1 (fun a => exist _ _ (f_UP' a))). - Global Instance UP'_mu {A : Set} - (t1 : DType D) - (f : A -> Fix (F A)) - {f_UP' : forall a, Universal_Property'_fold (f a)} - : - Universal_Property'_fold (mu t1 f) := - proj2_sig (mu' t1 (fun a => exist _ _ (f_UP' a))). + Global Instance UP'_mu {A : Set} + (t1 : DType D) + (f : A -> Fix (F A)) + {f_UP' : forall a, Universal_Property'_fold (f a)} + : + Universal_Property'_fold (mu t1 f) := + proj2_sig (mu' t1 (fun a => exist _ _ (f_UP' a))). (* Induction Principle for PLambda. *) Definition ind_alg_Fix {A : Set} @@ -106,10 +105,10 @@ Section Mu. Context {Fun_V : Functor V}. Definition Value := Value V. - Variable Sub_StuckValue_V : StuckValue :<: V. - Definition stuck' : nat -> Value := stuck' _. - Variable Sub_BotValue_V : BotValue :<: V. - Definition bot' : Value := bot' _. + Variable Sub_StuckValue_V : StuckValue :<: V. + Definition stuck' : nat -> Value := stuck' _. + Variable Sub_BotValue_V : BotValue :<: V. + Definition bot' : Value := bot' _. (* ============================================== *) (* EVALUATION *) @@ -137,240 +136,244 @@ Section Mu. Context {DTypePrint_DT : forall T, FAlgebra DTypePrintName T DTypePrintR D}. - Definition PLambda_ExpPrint (R : Set) (rec : R -> ExpPrintR) - (e : Fix_ nat R) : ExpPrintR := - match e with - | Mu t1 f => fun n => append "|\/| x" ((String (ascii_of_nat n) EmptyString) ++ - " : " ++ (DTypePrint _ (proj1_sig t1)) ++ ". " ++ - (rec (f n) (S n)) ++ ")") - end. + Definition PLambda_ExpPrint (R : Set) (rec : R -> ExpPrintR) + (e : Fix_ nat R) : ExpPrintR := + match e with + | Mu t1 f => fun n => append "|\/| x" ((String (ascii_of_nat n) EmptyString) ++ + " : " ++ (DTypePrint _ (proj1_sig t1)) ++ ". " ++ + (rec (f n) (S n)) ++ ")") + end. - Global Instance MAlgebra_Print_Fix T : - FAlgebra ExpPrintName T ExpPrintR (Fix_ nat) := - {| f_algebra := PLambda_ExpPrint T|}. + Global Instance MAlgebra_Print_Fix T : + FAlgebra ExpPrintName T ExpPrintR (Fix_ nat) := + {| f_algebra := PLambda_ExpPrint T|}. - Context {ExpPrint_E : forall T, FAlgebra ExpPrintName T ExpPrintR (F nat)}. + Context {ExpPrint_E : forall T, FAlgebra ExpPrintName T ExpPrintR (F nat)}. (* ============================================== *) (* TYPE SOUNDNESS *) (* ============================================== *) - Context {eval_F : FAlgebra EvalName (Exp nat) (evalR V) (F nat)}. - Context {WF_eval_F : @WF_FAlgebra EvalName _ _ (Fix_ nat) (F nat) - (Sub_Fix_F nat) (MAlgebra_eval_Fix) (eval_F)}. + Context {eval_F : FAlgebra EvalName (Exp nat) (evalR V) (F nat)}. + Context {WF_eval_F : @WF_FAlgebra EvalName _ _ (Fix_ nat) (F nat) + (Sub_Fix_F nat) (MAlgebra_eval_Fix) (eval_F)}. - (* Continuity of Evaluation. *) - Context {SV : (SubValue_i V -> Prop) -> SubValue_i V -> Prop}. - Context {WF_SubBotValue_V : WF_Functor BotValue V Sub_BotValue_V Bot_Functor Fun_V}. - Context {Sub_SV_refl_SV : Sub_iFunctor (SubValue_refl V) SV}. + (* Continuity of Evaluation. *) + Context {SV : (SubValue_i V -> Prop) -> SubValue_i V -> Prop}. + Context {WF_SubBotValue_V : WF_Functor BotValue V Sub_BotValue_V Bot_Functor Fun_V}. + Context {Sub_SV_refl_SV : Sub_iFunctor (SubValue_refl V) SV}. (* Mu case. *) - Lemma eval_continuous_Exp_H : forall t1 f - (IHf : forall a, UP'_P (eval_continuous_Exp_P V (F _) SV) (f a)), - UP'_P (eval_continuous_Exp_P V (F _) SV) - (@mu _ t1 _ (fun a => (proj1_sig (IHf a)))). - unfold eval_continuous_Exp_P; econstructor; simpl; intros. - unfold beval, mfold, mu; simpl; repeat rewrite wf_functor; - simpl; rewrite out_in_fmap; rewrite wf_functor; simpl. - repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F )); simpl. - unfold beval, evalR, Names.Exp in H. - assert (f (Datatypes.length gamma) = (f (Datatypes.length gamma'))) as f_eq by - (rewrite (P2_Env_length _ _ _ _ _ H0); reflexivity). - rewrite f_eq. - eapply H; eauto. - eapply P2_Env_insert; eauto. - Qed. - - Global Instance Fix_eval_continuous_Exp : + Lemma eval_continuous_Exp_H : forall t1 f + (IHf : forall a, UP'_P (eval_continuous_Exp_P V (F _) SV) (f a)), + UP'_P (eval_continuous_Exp_P V (F _) SV) + (@mu _ t1 _ (fun a => (proj1_sig (IHf a)))). + Proof. + unfold eval_continuous_Exp_P; econstructor; simpl; intros. + unfold beval, mfold, mu; simpl; repeat rewrite wf_functor; + simpl; rewrite out_in_fmap; rewrite wf_functor; simpl. + repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F )); simpl. + unfold beval, evalR, Names.Exp in H. + assert (f (Datatypes.length gamma) = (f (Datatypes.length gamma'))) as f_eq by + (rewrite (P2_Env_length _ _ _ _ _ H0); reflexivity). + rewrite f_eq. + eapply H; eauto. + eapply P2_Env_insert; eauto. + Qed. + + Global Instance Fix_eval_continuous_Exp : PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V (F _) SV))) (Fix_ nat). - constructor; unfold Algebra; intros. - eapply ind_alg_Fix. - apply eval_continuous_Exp_H. - assumption. - Defined. - - Global Instance WF_PLambda_eval_continuous_Exp - {Sub_F_E' : Fix_ nat :<: F nat} : - (forall a, inj (Sub_Functor := Sub_Fix_F _) a = - inj (A := (Fix (F nat))) (Sub_Functor := Sub_F_E') a) -> - WF_Ind (sub_F_E := Sub_F_E') Fix_eval_continuous_Exp. - constructor; intros. - simpl; unfold ind_alg_Fix; destruct e; simpl. - unfold mu; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. - Defined. + Proof. + constructor; unfold Algebra; intros. + eapply ind_alg_Fix. + apply eval_continuous_Exp_H. + assumption. + Defined. + + Global Instance WF_PLambda_eval_continuous_Exp + {Sub_F_E' : Fix_ nat :<: F nat} : + (forall a, inj (Sub_Functor := Sub_Fix_F _) a = + inj (A := (Fix (F nat))) (Sub_Functor := Sub_F_E') a) -> + WF_Ind (sub_F_E := Sub_F_E') Fix_eval_continuous_Exp. + Proof. + constructor; intros. + simpl; unfold ind_alg_Fix; destruct e; simpl. + unfold mu; simpl; rewrite wf_functor; simpl; apply f_equal; eauto. + Defined. (* ============================================== *) (* EQUIVALENCE OF EXPRESSIONS *) (* ============================================== *) - Inductive Fix_eqv (A B : Set) (E : eqv_i F A B -> Prop) : eqv_i F A B -> Prop := - | Mu_eqv : forall (gamma : Env _) gamma' f g t1 t2 e e', - (forall (a : A) (b : B), - E (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b))) -> - proj1_sig t1 = proj1_sig t2 -> - proj1_sig e = proj1_sig (mu' t1 f) -> - proj1_sig e' = proj1_sig (mu' t2 g) -> - Fix_eqv _ _ E (mk_eqv_i _ _ _ gamma gamma' e e'). - - Variable EQV_E : forall A B, (eqv_i F A B -> Prop) -> eqv_i F A B -> Prop. - Variable funEQV_E : forall A B, iFunctor (EQV_E A B). - - Definition ind_alg_Fix_eqv - (A B : Set) - (P : eqv_i F A B -> Prop) - (H1 : forall gamma gamma' f g t1 t2 e e' - (IHf : forall a b, - P (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b))) - t1_eq e_eq e'_eq, - P (mk_eqv_i _ _ _ gamma gamma' e e')) - i (e : Fix_eqv A B P i) : P i := - match e in Fix_eqv _ _ _ i return P i with - | Mu_eqv gamma gamma' f g t1 t2 e e' - eqv_f_g t1_eq e_eq e'_eq => - H1 gamma gamma' f g t1 t2 e e' - eqv_f_g t1_eq e_eq e'_eq - end. + Inductive Fix_eqv (A B : Set) (E : eqv_i F A B -> Prop) : eqv_i F A B -> Prop := + | Mu_eqv : forall (gamma : Env _) gamma' f g t1 t2 e e', + (forall (a : A) (b : B), + E (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b))) -> + proj1_sig t1 = proj1_sig t2 -> + proj1_sig e = proj1_sig (mu' t1 f) -> + proj1_sig e' = proj1_sig (mu' t2 g) -> + Fix_eqv _ _ E (mk_eqv_i _ _ _ gamma gamma' e e'). + + Variable EQV_E : forall A B, (eqv_i F A B -> Prop) -> eqv_i F A B -> Prop. + Variable funEQV_E : forall A B, iFunctor (EQV_E A B). + + Definition ind_alg_Fix_eqv + (A B : Set) + (P : eqv_i F A B -> Prop) + (H1 : forall gamma gamma' f g t1 t2 e e' + (IHf : forall a b, + P (mk_eqv_i _ _ _ (insert _ a gamma) (insert _ b gamma') (f a) (g b))) + t1_eq e_eq e'_eq, + P (mk_eqv_i _ _ _ gamma gamma' e e')) + i (e : Fix_eqv A B P i) : P i := + match e in Fix_eqv _ _ _ i return P i with + | Mu_eqv gamma gamma' f g t1 t2 e e' + eqv_f_g t1_eq e_eq e'_eq => + H1 gamma gamma' f g t1 t2 e e' + eqv_f_g t1_eq e_eq e'_eq + end. - Definition Fix_eqv_ifmap (A B : Set) - (A' B' : eqv_i F A B -> Prop) i (f : forall i, A' i -> B' i) - (eqv_a : Fix_eqv A B A' i) : Fix_eqv A B B' i := - match eqv_a in Fix_eqv _ _ _ i return Fix_eqv _ _ _ i with - | Mu_eqv gamma gamma' f' g t1 t2 e e' - eqv_f_g t1_eq e_eq e'_eq => - Mu_eqv _ _ _ gamma gamma' f' g t1 t2 e e' - (fun a b => f _ (eqv_f_g a b)) t1_eq e_eq e'_eq - end. + Definition Fix_eqv_ifmap (A B : Set) + (A' B' : eqv_i F A B -> Prop) i (f : forall i, A' i -> B' i) + (eqv_a : Fix_eqv A B A' i) : Fix_eqv A B B' i := + match eqv_a in Fix_eqv _ _ _ i return Fix_eqv _ _ _ i with + | Mu_eqv gamma gamma' f' g t1 t2 e e' + eqv_f_g t1_eq e_eq e'_eq => + Mu_eqv _ _ _ gamma gamma' f' g t1 t2 e e' + (fun a b => f _ (eqv_f_g a b)) t1_eq e_eq e'_eq + end. + + Global Instance iFun_Fix_eqv A B : iFunctor (Fix_eqv A B). + constructor 1 with (ifmap := Fix_eqv_ifmap A B). + destruct a; simpl; intros; reflexivity. + destruct a; simpl; intros; unfold id; eauto; + rewrite (functional_extensionality_dep _ a); eauto; + intros; apply functional_extensionality_dep; eauto. + Defined. + + Variable Sub_Fix_eqv_EQV_E : forall A B, + Sub_iFunctor (Fix_eqv A B) (EQV_E A B). + + Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) (F (typeofR D))}. - Global Instance iFun_Fix_eqv A B : iFunctor (Fix_eqv A B). - constructor 1 with (ifmap := Fix_eqv_ifmap A B). - destruct a; simpl; intros; reflexivity. - destruct a; simpl; intros; unfold id; eauto; - rewrite (functional_extensionality_dep _ a); eauto; - intros; apply functional_extensionality_dep; eauto. - Defined. - - Variable Sub_Fix_eqv_EQV_E : forall A B, - Sub_iFunctor (Fix_eqv A B) (EQV_E A B). - - Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D) (F (typeofR D))}. - - Global Instance EQV_proj1_Fix_eqv : - forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P F EQV_E A B) (Fix_eqv _ _). - econstructor; intros. - unfold iAlgebra; intros; apply ind_alg_Fix_eqv; - unfold EQV_proj1_P; simpl; intros; subst. - apply (inject_i (subGF := Sub_Fix_eqv_EQV_E A B)); econstructor; simpl; eauto. - intros; caseEq (f a); caseEq (g b); apply IHf; eauto. - rewrite H2; simpl; eauto. - rewrite H3; simpl; eauto. - apply H. - Qed. - - Context {EQV_proj1_EQV : forall A B, - iPAlgebra EQV_proj1_Name (EQV_proj1_P F EQV_E A B) (EQV_E A B)}. + Global Instance EQV_proj1_Fix_eqv : + forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P F EQV_E A B) (Fix_eqv _ _). + Proof. + econstructor; intros. + unfold iAlgebra; intros; apply ind_alg_Fix_eqv; + unfold EQV_proj1_P; simpl; intros; subst. + apply (inject_i (subGF := Sub_Fix_eqv_EQV_E A B)); econstructor; simpl; eauto. + intros; caseEq (f a); caseEq (g b); apply IHf; eauto. + rewrite H2; simpl; eauto. + rewrite H3; simpl; eauto. + apply H. + Qed. + + Context {EQV_proj1_EQV : forall A B, + iPAlgebra EQV_proj1_Name (EQV_proj1_P F EQV_E A B) (EQV_E A B)}. (* ============================================== *) (* WELL-FORMED FUNCTION VALUES *) (* ============================================== *) - Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. - Variable funWFV : iFunctor WFV. - - Context {WF_typeof_F : forall T, @WF_FAlgebra TypeofName T _ _ _ - (Sub_Fix_F _) (MAlgebra_typeof_Fix T) (Typeof_F _)}. - Context {WF_Value_continous_alg : - iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SV}. - - Variable Sub_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot _ _) WFV. - Context {eq_DType_eq_D : PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) D}. - Variable WF_Ind_DType_eq_D : WF_Ind eq_DType_eq_D. - - Context {WFV_proj1_a_WFV : - iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFV}. - Context {WFV_proj1_b_WFV : - iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFV}. - Context {eval_continuous_Exp_E : PAlgebra EC_ExpName - (sig (UP'_P (eval_continuous_Exp_P V (F _) SV))) (F nat)}. - Context {WF_Ind_EC_Exp : WF_Ind eval_continuous_Exp_E}. - - Global Instance Fix_Soundness eval_rec : - iPAlgebra soundness_XName - (soundness_X'_P D V F EQV_E WFV - (fun e => typeof _ _ (proj1_sig e)) eval_rec - (f_algebra (FAlgebra := Typeof_F _)) - (f_algebra (FAlgebra := eval_F))) (Fix_eqv _ _). - Proof. - econstructor; unfold iAlgebra; intros. - eapply ind_alg_Fix_eqv; try eassumption; unfold soundness_X'_P; - simpl; intros. - (* mu case *) - split; intros. - apply (inject_i (subGF := Sub_Fix_eqv_EQV_E _ _)) ; econstructor; eauto. - intros; destruct (IHf a b) as [f_eqv _]; eauto. - rewrite e_eq; reflexivity. - rewrite e'_eq; reflexivity. - unfold eval_alg_Soundness_P. - unfold beval; simpl; repeat rewrite wf_functor; simpl. - rewrite e'_eq. - unfold mu, mu'; simpl; erewrite out_in_fmap; - repeat rewrite wf_functor; simpl. - rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl; intros. - caseEq (g (Datatypes.length gamma'')). - rewrite <- eval_rec_proj. - rename H0 into typeof_e. - rewrite e_eq in typeof_e. - rewrite out_in_fmap, fmap_fusion, wf_functor in typeof_e; - rewrite (wf_algebra (WF_FAlgebra := WF_typeof_F _)) in typeof_e; - simpl in typeof_e. - rewrite <- typeof_rec_proj in typeof_e. - caseEq (typeof _ _ (proj1_sig (f (Some t1)))); unfold typeofR, DType, Names.DType, UP'_F in *|-*; - rename H0 into typeof_f; rewrite typeof_f in typeof_e; try discriminate. - caseEq (eq_DType _ (proj1_sig t1) d); rename H0 into eq_t1_d; - rewrite eq_t1_d in typeof_e; try discriminate. - injection typeof_e; intros; subst; clear typeof_e. - generalize (eq_DType_eq D WF_Ind_DType_eq_D T d eq_t1_d); - intros d_eq. - rewrite eval_rec_proj. - cut (WFValueC D V WFV (eval_rec (exist _ - (proj1_sig (g (Datatypes.length gamma''))) (proj2_sig (g (Datatypes.length gamma'')))) - (insert (Names.Value V) - (eval_rec(mu' t2 - (fun a : nat => - in_t_UP' (F nat) (Fun_F nat) - (out_t_UP' (F nat) (Fun_F nat) (proj1_sig (g a))))) - gamma'') gamma'')) d). - destruct T as [T T_UP']; destruct d as [d d_UP']. - intro wf_mu; rewrite <- eval_rec_proj; rewrite H1 in wf_mu; simpl in *|-*. - apply (WFV_proj1_b _ _ WFV funWFV (mk_WFValue_i _ _ _ _) wf_mu _ _ d_eq). - intros; destruct (IHf (Some T) (Datatypes.length gamma'')) as [g_eqv _]; eauto. - destruct (g (Datatypes.length gamma'')) as [gl gl_UP']. - rewrite eval_rec_proj; eapply IH with - (pb := (insert (option (sig Universal_Property'_fold)) (Some T) gamma, - insert nat (Datatypes.length gamma'') gamma')); eauto. - assert (Datatypes.length gamma'' = Datatypes.length gamma') by - (destruct WF_gamma'' as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]]; - simpl in *|-*; rewrite <- WF_gamma2; eapply P2_Env_length; eauto). - rewrite H0. - eapply WF_eqv_environment_P_insert; eauto. - destruct T as [T T_UP']; destruct d as [d d_UP']. - rewrite eval_rec_proj. - generalize (fun a b => proj1 (IHf a b IH)) as f_eqv; intros. - eapply IH. - eassumption. - apply (inject_i (subGF := Sub_Fix_eqv_EQV_E _ _)) ; econstructor; simpl; - try (apply t1_eq); eauto. - repeat rewrite wf_functor; simpl; repeat apply f_equal; - apply functional_extensionality; intros. - rewrite <- (in_out_UP'_inverse _ _ _ (proj2_sig (g x0))) at -1; reflexivity. - rewrite e_eq. - revert typeof_f; unfold typeof, mfold, in_t. - repeat rewrite wf_functor; simpl; rewrite (wf_algebra (WF_FAlgebra := WF_typeof_F _)); - simpl; unfold mfold; intros. - unfold typeofR, DType, Names.DType, UP'_F in *|-*; rewrite typeof_f. - simpl in eq_t1_d; rewrite eq_t1_d; reflexivity. - Defined. - End Mu. + Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. + Variable funWFV : iFunctor WFV. + + Context {WF_typeof_F : forall T, @WF_FAlgebra TypeofName T _ _ _ + (Sub_Fix_F _) (MAlgebra_typeof_Fix T) (Typeof_F _)}. + Context {WF_Value_continous_alg : + iPAlgebra WFV_ContinuousName (WF_Value_continuous_P D V WFV) SV}. + + Variable Sub_WFV_Bot_WFV : Sub_iFunctor (WFValue_Bot _ _) WFV. + Context {eq_DType_eq_D : PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) D}. + Variable WF_Ind_DType_eq_D : WF_Ind eq_DType_eq_D. + + Context {WFV_proj1_a_WFV : + iPAlgebra WFV_proj1_a_Name (WFV_proj1_a_P D V WFV) WFV}. + Context {WFV_proj1_b_WFV : + iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V WFV) WFV}. + Context {eval_continuous_Exp_E : PAlgebra EC_ExpName + (sig (UP'_P (eval_continuous_Exp_P V (F _) SV))) (F nat)}. + Context {WF_Ind_EC_Exp : WF_Ind eval_continuous_Exp_E}. + + Global Instance Fix_Soundness eval_rec : + iPAlgebra soundness_XName + (soundness_X'_P D V F EQV_E WFV + (fun e => typeof _ _ (proj1_sig e)) eval_rec + (f_algebra (FAlgebra := Typeof_F _)) + (f_algebra (FAlgebra := eval_F))) (Fix_eqv _ _). + Proof. + econstructor; unfold iAlgebra; intros. + eapply ind_alg_Fix_eqv; try eassumption; unfold soundness_X'_P; + simpl; intros. + (* mu case *) + split; intros. + apply (inject_i (subGF := Sub_Fix_eqv_EQV_E _ _)) ; econstructor; eauto. + intros; destruct (IHf a b) as [f_eqv _]; eauto. + rewrite e_eq; reflexivity. + rewrite e'_eq; reflexivity. + unfold eval_alg_Soundness_P. + unfold beval; simpl; repeat rewrite wf_functor; simpl. + rewrite e'_eq. + unfold mu, mu'; simpl; erewrite out_in_fmap; + repeat rewrite wf_functor; simpl. + rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl; intros. + caseEq (g (Datatypes.length gamma'')). + rewrite <- eval_rec_proj. + rename H0 into typeof_e. + rewrite e_eq in typeof_e. + rewrite out_in_fmap, fmap_fusion, wf_functor in typeof_e; + rewrite (wf_algebra (WF_FAlgebra := WF_typeof_F _)) in typeof_e; + simpl in typeof_e. + rewrite <- typeof_rec_proj in typeof_e. + caseEq (typeof _ _ (proj1_sig (f (Some t1)))); unfold typeofR, DType, Names.DType, UP'_F in *|-*; + rename H0 into typeof_f; rewrite typeof_f in typeof_e; try discriminate. + caseEq (eq_DType _ (proj1_sig t1) d); rename H0 into eq_t1_d; + rewrite eq_t1_d in typeof_e; try discriminate. + injection typeof_e; intros; subst; clear typeof_e. + generalize (eq_DType_eq D WF_Ind_DType_eq_D T d eq_t1_d); + intros d_eq. + rewrite eval_rec_proj. + cut (WFValueC D V WFV (eval_rec (exist _ + (proj1_sig (g (Datatypes.length gamma''))) (proj2_sig (g (Datatypes.length gamma'')))) + (insert (Names.Value V) + (eval_rec(mu' t2 + (fun a : nat => + in_t_UP' (F nat) (Fun_F nat) + (out_t_UP' (F nat) (Fun_F nat) (proj1_sig (g a))))) + gamma'') gamma'')) d). + destruct T as [T T_UP']; destruct d as [d d_UP']. + intro wf_mu; rewrite <- eval_rec_proj; rewrite H1 in wf_mu; simpl in *|-*. + apply (WFV_proj1_b _ _ WFV funWFV (mk_WFValue_i _ _ _ _) wf_mu _ _ d_eq). + intros; destruct (IHf (Some T) (Datatypes.length gamma'')) as [g_eqv _]; eauto. + destruct (g (Datatypes.length gamma'')) as [gl gl_UP']. + rewrite eval_rec_proj; eapply IH with + (pb := (insert (option (sig Universal_Property'_fold)) (Some T) gamma, + insert nat (Datatypes.length gamma'') gamma')); eauto. + assert (Datatypes.length gamma'' = Datatypes.length gamma') by + (destruct WF_gamma'' as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]]; + simpl in *|-*; rewrite <- WF_gamma2; eapply P2_Env_length; eauto). + rewrite H0. + eapply WF_eqv_environment_P_insert; eauto. + destruct T as [T T_UP']; destruct d as [d d_UP']. + rewrite eval_rec_proj. + generalize (fun a b => proj1 (IHf a b IH)) as f_eqv; intros. + eapply IH. + eassumption. + apply (inject_i (subGF := Sub_Fix_eqv_EQV_E _ _)) ; econstructor; simpl; + try (apply t1_eq); eauto. + repeat rewrite wf_functor; simpl; repeat apply f_equal; + apply functional_extensionality; intros. + rewrite <- (in_out_UP'_inverse _ _ _ (proj2_sig (g x0))) at -1; reflexivity. + rewrite e_eq. + revert typeof_f; unfold typeof, mfold, in_t. + repeat rewrite wf_functor; simpl; rewrite (wf_algebra (WF_FAlgebra := WF_typeof_F _)); + simpl; unfold mfold; intros. + unfold typeofR, DType, Names.DType, UP'_F in *|-*; rewrite typeof_f. + simpl in eq_t1_d; rewrite eq_t1_d; reflexivity. + Defined. +End Mu. (* *** Local Variables: *** diff --git a/Names.v b/Names.v index a13a9f8..2bf63ab 100644 --- a/Names.v +++ b/Names.v @@ -50,74 +50,74 @@ Section Names. (** ERROR VALUES **) - Inductive StuckValue (A : Set) : Set := - | Stuck : nat -> StuckValue A. + Inductive StuckValue (A : Set) : Set := + | Stuck : nat -> StuckValue A. - Context {Sub_StuckValue_V : StuckValue :<: V}. + Context {Sub_StuckValue_V : StuckValue :<: V}. - Definition Stuck_fmap : forall (A B : Set) (f : A -> B), - StuckValue A -> StuckValue B := fun A B _ e => - match e with - | Stuck n => Stuck _ n - end. + Definition Stuck_fmap (A B : Set) (f : A -> B) : + StuckValue A -> StuckValue B := + fun e => match e with + | Stuck n => Stuck _ n + end. - Global Instance Stuck_Functor : Functor StuckValue := - {| fmap := Stuck_fmap |}. - destruct a; reflexivity. - (* fmap_id *) - destruct a; reflexivity. - Defined. + Global Instance Stuck_Functor : Functor StuckValue := + {| fmap := Stuck_fmap |}. + Proof. + destruct a; reflexivity. + (* fmap_id *) + destruct a; reflexivity. + Defined. - (* Constructor + Universal Property. *) - Context {WF_SubStuckValue_V : WF_Functor _ _ Sub_StuckValue_V _ _}. + (* Constructor + Universal Property. *) + Context {WF_SubStuckValue_V : WF_Functor _ _ Sub_StuckValue_V _ _}. - Definition stuck' (n : nat) : Value := inject' (Stuck _ n). - Definition stuck (n : nat) : Fix V := proj1_sig (stuck' n). + Definition stuck' (n : nat) : Value := inject' (Stuck _ n). + Definition stuck (n : nat) : Fix V := proj1_sig (stuck' n). - Global Instance UP'_stuck {n : nat} : - Universal_Property'_fold (stuck n) := proj2_sig (stuck' n). + Global Instance UP'_stuck {n : nat} : + Universal_Property'_fold (stuck n) := proj2_sig (stuck' n). - (* Induction Principle for Stuckor Values. *) + (* Induction Principle for Stuckor Values. *) Definition ind_alg_Stuck (P : Fix V -> Prop) - (H : forall n, P (stuck n)) - (e : StuckValue (sig P)) : sig P := + (H : forall n, P (stuck n)) (e : StuckValue (sig P)) : sig P := match e with | Stuck n => exist P (stuck n) (H n) end. Definition ind_palg_Stuck (Name : Set) (P : Fix V -> Prop) (H : forall n, P (stuck n)) : PAlgebra Name (sig P) StuckValue := - {| p_algebra := ind_alg_Stuck P H|}. + {| p_algebra := ind_alg_Stuck P H |}. - (** BOTTOM VALUES **) + (** BOTTOM VALUES **) - Inductive BotValue (A : Set) : Set := - | Bot : BotValue A. + Inductive BotValue (A : Set) : Set := + | Bot : BotValue A. - Context {Sub_BotValue_V : BotValue :<: V}. + Context {Sub_BotValue_V : BotValue :<: V}. - Definition Bot_fmap : forall (A B : Set) (f : A -> B), - BotValue A -> BotValue B := fun A B _ _ => Bot _. + Definition Bot_fmap : forall (A B : Set) (f : A -> B), + BotValue A -> BotValue B := fun A B _ _ => Bot _. - Global Instance Bot_Functor : Functor BotValue := - {| fmap := Bot_fmap |}. - destruct a; reflexivity. - (* fmap_id *) - destruct a. reflexivity. - Defined. + Global Instance Bot_Functor : Functor BotValue := + {| fmap := Bot_fmap |}. + Proof. + destruct a; reflexivity. + (* fmap_id *) + destruct a. reflexivity. + Defined. - (* Constructor + Universal Property. *) - Context {WF_SubBotValue_V : WF_Functor _ _ Sub_BotValue_V _ _}. + (* Constructor + Universal Property. *) + Context {WF_SubBotValue_V : WF_Functor _ _ Sub_BotValue_V _ _}. - Definition bot' : Value := inject' (Bot _). - Definition bot : Fix V := proj1_sig bot'. - Global Instance UP'_bot : Universal_Property'_fold bot := - proj2_sig bot'. + Definition bot' : Value := inject' (Bot _). + Definition bot : Fix V := proj1_sig bot'. + Global Instance UP'_bot : Universal_Property'_fold bot := + proj2_sig bot'. Definition ind_alg_Bot (P : Fix V -> Prop) - (H : P bot) - (e : BotValue (sig P)) : sig P := + (H : P bot) (e : BotValue (sig P)) : sig P := match e with | Bot => exist P bot H end. @@ -127,8 +127,8 @@ Section Names. Definition isBot : Fix V -> bool := fun exp => match project exp with - | Some Bot => true - | None => false + | Some Bot => true + | None => false end. @@ -176,8 +176,8 @@ Section Names. Context {eq_DType_DT : forall T, FAlgebra eq_DTypeName T eq_DTypeR DT}. Definition eq_DType := mfold _ (fun _ => @f_algebra _ _ _ _ (eq_DType_DT _)). - Definition eq_DType_eq_P (d : Fix DT) (d_UP' : Universal_Property'_fold d) := forall d2, - eq_DType d d2 = true -> d = proj1_sig d2. + Definition eq_DType_eq_P (d : Fix DT) (d_UP' : Universal_Property'_fold d) := + forall d2, eq_DType d d2 = true -> d = proj1_sig d2. Inductive eq_DType_eqName := eq_dtype_eqname. Context {eq_DType_eq_DT : PAlgebra eq_DType_eqName (sig (UP'_P eq_DType_eq_P)) DT}. Variable WF_Ind_eq_DT : WF_Ind eq_DType_eq_DT. @@ -206,536 +206,574 @@ Section Names. Definition ValuePrint := mfold _ (fun _ => @f_algebra _ _ _ _ (ValuePrint_V _)). (* Printers for Bot and Stuck *) - Global Instance MAlgebra_ValuePrint_BotValue T : FAlgebra ValuePrintName T ValuePrintR BotValue := - {| f_algebra := fun _ _ => append "bot" "" |}. - - Global Instance MAlgebra_ValuePrint_StuckValue T : FAlgebra ValuePrintName T ValuePrintR StuckValue := - {| f_algebra := - fun _ e => match e with - | Stuck n => append "Stuck " (String (ascii_of_nat (n + 48)) EmptyString) - end|}. + Global Instance MAlgebra_ValuePrint_BotValue T : + FAlgebra ValuePrintName T ValuePrintR BotValue := + {| f_algebra := fun _ _ => append "bot" "" |}. + + Global Instance MAlgebra_ValuePrint_StuckValue T : + FAlgebra ValuePrintName T ValuePrintR StuckValue := + {| f_algebra := fun _ e => + match e with + | Stuck n => + append "Stuck " + (String (ascii_of_nat (n + 48)) EmptyString) + end + |}. (* ============================================== *) (* PREDICATE LIFTERS FOR LISTS *) (* ============================================== *) - (* Unary Predicates.*) - Inductive P_Env {A : Set} (P : A -> Prop) : forall (env : Env A), Prop := - | P_Nil : P_Env P nil - | P_Cons : forall a (As : Env _), P a -> P_Env P As -> - P_Env P (cons a As). - - Lemma P_Env_lookup : forall A (env : Env A) P, - P_Env P env -> - forall n v, - lookup env n = Some v -> P v. - intros A env P P_env; induction P_env; - destruct n; simpl; intros; try discriminate. - injection H0; intros; subst; eauto. - eauto. - Qed. - - Lemma P_Env_Lookup : forall A (env : Env A) (P : A -> Prop), - (forall n v, - lookup env n = Some v -> P v) -> - P_Env P env. - intros A env P H; induction env; constructor. - eapply (H 0); eauto. - apply IHenv; intros; eapply (H (S n)); eauto. - Qed. - - Lemma P_Env_insert : forall A (env : Env A) (P : A -> Prop), - P_Env P env -> forall a, P a -> P_Env P (insert _ a env). - induction env; simpl; intros; constructor; eauto. - inversion H; subst; eauto. - eapply IHenv; inversion H; eauto. - Qed. - - (* Binary Predicates.*) - Inductive P2_Env {A B : Set} (P : A -> B -> Prop) : forall (env : Env A) (env : Env B), Prop := - | P2_Nil : P2_Env P nil nil - | P2_Cons : forall a b (As : Env _) (Bs : Env _), P a b -> P2_Env P As Bs -> - P2_Env P (cons a As) (cons b Bs). - - Lemma P2_Env_lookup : forall A B (env : Env A) (env' : Env B) P, - P2_Env P env env' -> - forall n v, - lookup env n = Some v -> exists v', lookup env' n = Some v' /\ - P v v'. - intros A B env env' P P_env_env'; induction P_env_env'; - destruct n; simpl; intros; try discriminate. - exists b; injection H0; intros; subst; split; eauto. - eauto. - Qed. - - Lemma P2_Env_lookup' : forall A B (env : Env A) (env' : Env B) P, - P2_Env P env env' -> - forall n v, - lookup env' n = Some v -> exists v', lookup env n = Some v' /\ - P v' v. - intros A B env env' P P_env_env'; induction P_env_env'; - destruct n; simpl; intros; try discriminate. - eexists; injection H0; intros; subst; split; eauto. - eauto. - Qed. - - Lemma P2_Env_Nlookup : forall A B (env : Env A) (env' : Env B) P, - P2_Env P env env' -> - forall n, - lookup env n = None -> lookup env' n = None. - intros A B env env' P P_env_env'; induction P_env_env'; - destruct n; simpl; intros; try discriminate; auto. - Qed. - - Lemma P2_Env_Nlookup' : forall A B (env : Env A) (env' : Env B) P, - P2_Env P env env' -> - forall n, - lookup env' n = None -> lookup env n = None. - intros A B env env' P P_env_env'; induction P_env_env'; - destruct n; simpl; intros; try discriminate; auto. - Qed. - - Lemma P2_Env_length : forall A B (env : Env A) (env' : Env B) P, - P2_Env P env env' -> List.length env = List.length env'. - intros; induction H; simpl; congruence. - Qed. - - Lemma P2_Env_insert : forall A B (env : Env A) (env' : Env B) (P : A -> B -> Prop), - P2_Env P env env' -> - forall a b, P a b -> P2_Env P (insert _ a env) (insert _ b env'). - intros; induction H; simpl; constructor; eauto. - constructor. - Qed. - - (* Need this better induction principle when we're reasoning about + (* Unary Predicates.*) + Inductive P_Env {A : Set} (P : A -> Prop) : forall (env : Env A), Prop := + | P_Nil : P_Env P nil + | P_Cons : forall a (As : Env _), + P a -> P_Env P As -> + P_Env P (cons a As). + + Lemma P_Env_lookup A (env : Env A) P : + P_Env P env -> + forall n v, + lookup env n = Some v -> P v. + Proof. + intros P_env; induction P_env; + destruct n; simpl; intros; try discriminate. + injection H0; intros; subst; eauto. + eauto. + Qed. + + Lemma P_Env_Lookup A (env : Env A) (P : A -> Prop) : + (forall n v, + lookup env n = Some v -> P v) -> + P_Env P env. + Proof. + intros H; induction env; constructor. + eapply (H 0); eauto. + apply IHenv; intros; eapply (H (S n)); eauto. + Qed. + + Lemma P_Env_insert A (env : Env A) (P : A -> Prop) : + P_Env P env -> forall a, P a -> P_Env P (insert _ a env). + Proof. + induction env; simpl; intros; constructor; eauto. + inversion H; subst; eauto. + eapply IHenv; inversion H; eauto. + Qed. + + (* Binary Predicates.*) + Inductive P2_Env {A B : Set} (P : A -> B -> Prop) : forall (env : Env A) (env : Env B), Prop := + | P2_Nil : P2_Env P nil nil + | P2_Cons : forall a b (As : Env _) (Bs : Env _), + P a b -> P2_Env P As Bs -> + P2_Env P (cons a As) (cons b Bs). + + Lemma P2_Env_lookup A B (env : Env A) (env' : Env B) P : + P2_Env P env env' -> + forall n v, + lookup env n = Some v -> + exists v', lookup env' n = Some v' /\ P v v'. + Proof. + intros P_env_env'; induction P_env_env'; + destruct n; simpl; intros; try discriminate. + exists b; injection H0; intros; subst; split; eauto. + eauto. + Qed. + + Lemma P2_Env_lookup' A B (env : Env A) (env' : Env B) P : + P2_Env P env env' -> + forall n v, + lookup env' n = Some v -> + exists v', lookup env n = Some v' /\ P v' v. + Proof. + intros P_env_env'; induction P_env_env'; + destruct n; simpl; intros; try discriminate. + eexists; injection H0; intros; subst; split; eauto. + eauto. + Qed. + + Lemma P2_Env_Nlookup A B (env : Env A) (env' : Env B) P : + P2_Env P env env' -> + forall n, + lookup env n = None -> lookup env' n = None. + Proof. + intros P_env_env'; induction P_env_env'; + destruct n; simpl; intros; try discriminate; auto. + Qed. + + Lemma P2_Env_Nlookup' A B (env : Env A) (env' : Env B) P : + P2_Env P env env' -> + forall n, + lookup env' n = None -> lookup env n = None. + Proof. + intros P_env_env'; induction P_env_env'; + destruct n; simpl; intros; try discriminate; auto. + Qed. + + Lemma P2_Env_length A B (env : Env A) (env' : Env B) P : + P2_Env P env env' -> List.length env = List.length env'. + Proof. + intros; induction H; simpl; congruence. + Qed. + + Lemma P2_Env_insert A B (env : Env A) (env' : Env B) (P : A -> B -> Prop) : + P2_Env P env env' -> + forall a b, P a b -> P2_Env P (insert _ a env) (insert _ b env'). + Proof. + intros; induction H; simpl; constructor; eauto. + constructor. + Qed. + + (* Need this better induction principle when we're reasoning about Functors that use P2_Envs. *) - Definition P2_Env_ind' := + Definition P2_Env_ind' := fun (A B : Set) (P : A -> B -> Prop) (P0 : forall As Bs, P2_Env P As Bs -> Prop) - (f : P0 _ _ (P2_Nil _)) - (f0 : forall (a : A) (b : B) (As : Env A) (Bs : Env B) (ABs : P2_Env P As Bs) - (P_a_b : P a b), P0 _ _ ABs -> P0 _ _ (P2_Cons P a b As Bs P_a_b ABs)) => - fix F (env : Env A) (env0 : Env B) (p : P2_Env P env env0) {struct p} : + (f : P0 _ _ (P2_Nil _)) + (f0 : forall (a : A) (b : B) (As : Env A) (Bs : Env B) (ABs : P2_Env P As Bs) + (P_a_b : P a b), P0 _ _ ABs -> P0 _ _ (P2_Cons P a b As Bs P_a_b ABs)) => + fix F (env : Env A) (env0 : Env B) (p : P2_Env P env env0) {struct p} : P0 env env0 p := - match p in (P2_Env _ env1 env2) return (P0 env1 env2 p) with - | P2_Nil => f - | P2_Cons a b As Bs y p0 => f0 a b As Bs p0 y (F As Bs p0) - end. + match p in (P2_Env _ env1 env2) return (P0 env1 env2 p) with + | P2_Nil => f + | P2_Cons a b As Bs y p0 => f0 a b As Bs p0 y (F As Bs p0) + end. (* ============================================== *) (* SUBVALUE RELATION *) (* ============================================== *) + Record SubValue_i : Set := + mk_SubValue_i {sv_a : Value; sv_b : Value}. - Record SubValue_i : Set := mk_SubValue_i - {sv_a : Value; - sv_b : Value}. + (** SuperFunctor for SubValue Relation. **) - (** SuperFunctor for SubValue Relation. **) + Variable SV : (SubValue_i -> Prop) -> SubValue_i -> Prop. + Definition SubValue := iFix SV. + Definition SubValueC V1 V2:= SubValue (mk_SubValue_i V1 V2). + Variable funSV : iFunctor SV. - Variable SV : (SubValue_i -> Prop) -> SubValue_i -> Prop. - Definition SubValue := iFix SV. - Definition SubValueC V1 V2:= SubValue (mk_SubValue_i V1 V2). - Variable funSV : iFunctor SV. + (** Subvalue is reflexive **) + Inductive SubValue_refl (A : SubValue_i -> Prop) : SubValue_i -> Prop := + SV_refl : forall v v', + proj1_sig v = proj1_sig v' -> + SubValue_refl A (mk_SubValue_i v v'). - (** Subvalue is reflexive **) - Inductive SubValue_refl (A : SubValue_i -> Prop) : SubValue_i -> Prop := - SV_refl : forall v v', - proj1_sig v = proj1_sig v' -> - SubValue_refl A (mk_SubValue_i v v'). - - Definition ind_alg_SV_refl (P : SubValue_i -> Prop) - (H : forall v v', proj1_sig v = proj1_sig v' -> P (mk_SubValue_i v v')) - i (e : SubValue_refl P i) : P i := - match e in SubValue_refl _ i return P i with - | SV_refl v v' eq_v => H v v' eq_v - end. + Definition ind_alg_SV_refl (P : SubValue_i -> Prop) + (H : forall v v', proj1_sig v = proj1_sig v' -> P (mk_SubValue_i v v')) + i (e : SubValue_refl P i) : P i := + match e in SubValue_refl _ i return P i with + | SV_refl v v' eq_v => H v v' eq_v + end. - Definition SV_refl_ifmap (A B : SubValue_i -> Prop) i (f : forall i, A i -> B i) + Definition SV_refl_ifmap (A B : SubValue_i -> Prop) i (f : forall i, A i -> B i) (SV_a : SubValue_refl A i) : SubValue_refl B i := - match SV_a in (SubValue_refl _ s) return (SubValue_refl B s) - with - | SV_refl v v' H => SV_refl B v v' H - end. + match SV_a in (SubValue_refl _ s) return (SubValue_refl B s) + with + | SV_refl v v' H => SV_refl B v v' H + end. - Global Instance iFun_SV_refl : iFunctor SubValue_refl. - constructor 1 with (ifmap := SV_refl_ifmap). - destruct a; simpl; intros; reflexivity. - destruct a; simpl; intros; reflexivity. - Defined. - - Variable Sub_SV_refl_SV : Sub_iFunctor SubValue_refl SV. - - (** Bot is Bottom element for this relation **) - Inductive SubValue_Bot (A : SubValue_i -> Prop) : SubValue_i -> Prop := - SV_Bot : forall v v', - proj1_sig v = inject (Bot _) -> - SubValue_Bot A (mk_SubValue_i v v'). - - Definition ind_alg_SV_Bot (P : SubValue_i -> Prop) - (H : forall v v' v_eq, P (mk_SubValue_i v v')) - i (e : SubValue_Bot P i) : P i := - match e in SubValue_Bot _ i return P i with - | SV_Bot v v' v_eq => H v v' v_eq - end. + Global Instance iFun_SV_refl : iFunctor SubValue_refl. + Proof. + constructor 1 with (ifmap := SV_refl_ifmap). + destruct a; simpl; intros; reflexivity. + destruct a; simpl; intros; reflexivity. + Defined. + + Variable Sub_SV_refl_SV : Sub_iFunctor SubValue_refl SV. + + (** Bot is Bottom element for this relation **) + Inductive SubValue_Bot (A : SubValue_i -> Prop) : SubValue_i -> Prop := + SV_Bot : forall v v', + proj1_sig v = inject (Bot _) -> + SubValue_Bot A (mk_SubValue_i v v'). + + Definition ind_alg_SV_Bot (P : SubValue_i -> Prop) + (H : forall v v' v_eq, P (mk_SubValue_i v v')) + i (e : SubValue_Bot P i) : P i := + match e in SubValue_Bot _ i return P i with + | SV_Bot v v' v_eq => H v v' v_eq + end. - Definition SV_Bot_ifmap (A B : SubValue_i -> Prop) i (f : forall i, A i -> B i) - (SV_a : SubValue_Bot A i) : SubValue_Bot B i := - match SV_a in (SubValue_Bot _ s) return (SubValue_Bot B s) - with - | SV_Bot v v' H => SV_Bot B v v' H - end. + Definition SV_Bot_ifmap (A B : SubValue_i -> Prop) i (f : forall i, A i -> B i) + (SV_a : SubValue_Bot A i) : SubValue_Bot B i := + match SV_a in (SubValue_Bot _ s) return (SubValue_Bot B s) + with + | SV_Bot v v' H => SV_Bot B v v' H + end. - Global Instance iFun_SV_Bot : iFunctor SubValue_Bot. - constructor 1 with (ifmap := SV_Bot_ifmap). - destruct a; simpl; intros; reflexivity. - destruct a; simpl; intros; reflexivity. - Defined. - - Variable Sub_SV_Bot_SV : Sub_iFunctor SubValue_Bot SV. - - - (* Inversion principle for Bottom SubValues. *) - Definition SV_invertBot_P (i : SubValue_i) := - proj1_sig (sv_b i) = bot -> proj1_sig (sv_a i) = bot. - - Inductive SV_invertBot_Name := ece_invertbot_name. - Context {SV_invertBot_SV : - iPAlgebra SV_invertBot_Name SV_invertBot_P SV}. - - Global Instance SV_invertBot_refl : - iPAlgebra SV_invertBot_Name SV_invertBot_P (SubValue_refl). - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertBot_P. - inversion H; subst; simpl; congruence. - Defined. - - Global Instance SV_invertBot_Bot : - iPAlgebra SV_invertBot_Name SV_invertBot_P SubValue_Bot. - econstructor; intros. - unfold iAlgebra; intros; unfold SV_invertBot_P. - inversion H; subst; simpl; eauto. - Defined. - - Definition SV_invertBot := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertBot_SV)). - (* End Inversion principle for SubValue.*) - - (* Projection doesn't affect SubValue Relation.*) - - Definition SV_proj1_b_P (i :SubValue_i) := - forall b' H, b' = proj1_sig (sv_b i) -> - SubValueC (sv_a i) (exist _ b' H). - - Inductive SV_proj1_b_Name := sv_proj1_b_name. - Context {SV_proj1_b_SV : - iPAlgebra SV_proj1_b_Name SV_proj1_b_P SV}. - - Definition SV_proj1_b := - ifold_ SV _ (ip_algebra (iPAlgebra := SV_proj1_b_SV)). - - Global Instance SV_proj1_b_refl : - iPAlgebra SV_proj1_b_Name SV_proj1_b_P SubValue_refl. - econstructor; intros. - unfold iAlgebra; intros; unfold SV_proj1_b_P. - inversion H; subst; simpl; intros. - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; simpl; congruence. - Defined. - - Global Instance SV_proj1_b_Bot : - iPAlgebra SV_proj1_b_Name SV_proj1_b_P SubValue_Bot. - econstructor; intros. - unfold iAlgebra; intros; unfold SV_proj1_b_P. - inversion H; subst; simpl; eauto. - intros; revert H1; rewrite H2; intros. - apply inject_i. - constructor; assumption. - Defined. - - Definition SV_proj1_a_P (i : SubValue_i) := - forall a' H, proj1_sig (sv_a i) = a' -> - SubValueC (exist _ a' H) (sv_b i). - - Inductive SV_proj1_a_Name := sv_proj1_a_name. - Context {SV_proj1_a_SV : - iPAlgebra SV_proj1_a_Name SV_proj1_a_P SV}. - - Definition SV_proj1_a := - ifold_ SV _ (ip_algebra (iPAlgebra := SV_proj1_a_SV)). - - Global Instance SV_proj1_a_refl : - iPAlgebra SV_proj1_a_Name SV_proj1_a_P SubValue_refl. - econstructor; intros. - unfold iAlgebra; intros; unfold SV_proj1_a_P. - inversion H; subst; simpl; intros. - revert H1; rewrite <- H2; intros. - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; simpl; eauto. - Defined. - - Global Instance SV_proj1_a_Bot : - iPAlgebra SV_proj1_a_Name SV_proj1_a_P SubValue_Bot. - econstructor; intros. - unfold iAlgebra; intros; unfold SV_proj1_a_P. - inversion H; subst; simpl; eauto. - intros; revert H1; rewrite <- H2, H0; intros. - apply inject_i. + Global Instance iFun_SV_Bot : iFunctor SubValue_Bot. + constructor 1 with (ifmap := SV_Bot_ifmap). + Proof. + destruct a; simpl; intros; reflexivity. + destruct a; simpl; intros; reflexivity. + Defined. + + Variable Sub_SV_Bot_SV : Sub_iFunctor SubValue_Bot SV. + + + (* Inversion principle for Bottom SubValues. *) + Definition SV_invertBot_P (i : SubValue_i) := + proj1_sig (sv_b i) = bot -> proj1_sig (sv_a i) = bot. + + Inductive SV_invertBot_Name := ece_invertbot_name. + Context {SV_invertBot_SV : + iPAlgebra SV_invertBot_Name SV_invertBot_P SV}. + + Global Instance SV_invertBot_refl : + iPAlgebra SV_invertBot_Name SV_invertBot_P (SubValue_refl). + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertBot_P. + inversion H; subst; simpl; congruence. + Defined. + + Global Instance SV_invertBot_Bot : + iPAlgebra SV_invertBot_Name SV_invertBot_P SubValue_Bot. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_invertBot_P. + inversion H; subst; simpl; eauto. + Defined. + + Definition SV_invertBot := ifold_ SV _ (ip_algebra (iPAlgebra := SV_invertBot_SV)). + (* End Inversion principle for SubValue.*) + + (* Projection doesn't affect SubValue Relation.*) + + Definition SV_proj1_b_P (i :SubValue_i) := + forall b' H, b' = proj1_sig (sv_b i) -> + SubValueC (sv_a i) (exist _ b' H). + + Inductive SV_proj1_b_Name := sv_proj1_b_name. + Context {SV_proj1_b_SV : + iPAlgebra SV_proj1_b_Name SV_proj1_b_P SV}. + + Definition SV_proj1_b := + ifold_ SV _ (ip_algebra (iPAlgebra := SV_proj1_b_SV)). + + Global Instance SV_proj1_b_refl : + iPAlgebra SV_proj1_b_Name SV_proj1_b_P SubValue_refl. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_proj1_b_P. + inversion H; subst; simpl; intros. + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; simpl; congruence. + Defined. + + Global Instance SV_proj1_b_Bot : + iPAlgebra SV_proj1_b_Name SV_proj1_b_P SubValue_Bot. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_proj1_b_P. + inversion H; subst; simpl; eauto. + intros; revert H1; rewrite H2; intros. + apply inject_i. + constructor; assumption. + Defined. + + Definition SV_proj1_a_P (i : SubValue_i) := + forall a' H, proj1_sig (sv_a i) = a' -> + SubValueC (exist _ a' H) (sv_b i). + + Inductive SV_proj1_a_Name := sv_proj1_a_name. + Context {SV_proj1_a_SV : + iPAlgebra SV_proj1_a_Name SV_proj1_a_P SV}. + + Definition SV_proj1_a := + ifold_ SV _ (ip_algebra (iPAlgebra := SV_proj1_a_SV)). + + Global Instance SV_proj1_a_refl : + iPAlgebra SV_proj1_a_Name SV_proj1_a_P SubValue_refl. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_proj1_a_P. + inversion H; subst; simpl; intros. + revert H1; rewrite <- H2; intros. + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; simpl; eauto. + Defined. + + Global Instance SV_proj1_a_Bot : + iPAlgebra SV_proj1_a_Name SV_proj1_a_P SubValue_Bot. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold SV_proj1_a_P. + inversion H; subst; simpl; eauto. + intros; revert H1; rewrite <- H2, H0; intros. + apply inject_i. + constructor; reflexivity. + Defined. + + (** SubValue lifted to Environments **) + Definition Sub_Environment (env env' : Env _) := + P2_Env SubValueC env env'. + + Lemma Sub_Environment_refl : forall (env : Env _), + Sub_Environment env env. + induction env; econstructor; eauto. + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; reflexivity. - Defined. - - (** SubValue lifted to Environments **) - Definition Sub_Environment (env env' : Env _) := - P2_Env SubValueC env env'. - - Lemma Sub_Environment_refl : forall (env : Env _), - Sub_Environment env env. - induction env; econstructor; eauto. - apply (inject_i (subGF := Sub_SV_refl_SV)); - constructor; reflexivity. - Qed. + Qed. (* ============================================== *) (* EVALUATION IS CONTINUOUS *) (* ============================================== *) - (** Helper property for proof of continuity of evaluation. **) - Definition eval_continuous_Exp_P (e : Fix E) - (e_UP' : Universal_Property'_fold e) := - forall (m : nat), - (forall (e0 : Exp) - (gamma gamma' : Env Value) (n : nat), - Sub_Environment gamma gamma' -> - m <= n -> SubValueC (beval m e0 gamma) (beval n e0 gamma')) -> - forall (gamma gamma' : Env Value) (n : nat), - Sub_Environment gamma gamma' -> - m <= n -> - SubValueC (beval (S m) (exist _ _ e_UP') gamma) (beval (S n) (exist _ _ e_UP') gamma'). - - Inductive EC_ExpName := ec_expname. - - Variable eval_continuous_Exp_E : PAlgebra EC_ExpName (sig (UP'_P eval_continuous_Exp_P)) E. - Variable WF_Ind_EC_Exp : WF_Ind eval_continuous_Exp_E. - - (** Evaluation is continuous. **) - Lemma beval_continuous : forall m, - forall (e : Exp) (gamma gamma' : Env _), - forall n (Sub_G_G' : Sub_Environment gamma gamma'), - m <= n -> - SubValueC (beval m e gamma) (beval n e gamma'). - induction m; simpl. - intros; eapply in_ti; eapply inj_i; econstructor; simpl; eauto. - intros; destruct n; try (inversion H; fail). - assert (m <= n) as le_m_n0 by auto with arith; clear H. - revert m IHm gamma gamma' n Sub_G_G' le_m_n0. - fold (eval_continuous_Exp_P (proj1_sig e)). - apply (proj2_sig (Ind (P := UP'_P eval_continuous_Exp_P) _ (proj2_sig e))). - Qed. + (** Helper property for proof of continuity of evaluation. **) + Definition eval_continuous_Exp_P (e : Fix E) + (e_UP' : Universal_Property'_fold e) := + forall (m : nat), + (forall (e0 : Exp) + (gamma gamma' : Env Value) (n : nat), + Sub_Environment gamma gamma' -> + m <= n -> SubValueC (beval m e0 gamma) (beval n e0 gamma')) -> + forall (gamma gamma' : Env Value) (n : nat), + Sub_Environment gamma gamma' -> + m <= n -> + SubValueC (beval (S m) (exist _ _ e_UP') gamma) (beval (S n) (exist _ _ e_UP') gamma'). + + Inductive EC_ExpName := ec_expname. + + Variable eval_continuous_Exp_E : PAlgebra EC_ExpName (sig (UP'_P eval_continuous_Exp_P)) E. + Variable WF_Ind_EC_Exp : WF_Ind eval_continuous_Exp_E. + + (** Evaluation is continuous. **) + Lemma beval_continuous : + forall m (e : Exp) (gamma gamma' : Env _), + forall n (Sub_G_G' : Sub_Environment gamma gamma'), + m <= n -> + SubValueC (beval m e gamma) (beval n e gamma'). + Proof. + induction m; simpl. + intros; eapply in_ti; eapply inj_i; econstructor; simpl; eauto. + intros; destruct n; try (inversion H; fail). + assert (m <= n) as le_m_n0 by auto with arith; clear H. + revert m IHm gamma gamma' n Sub_G_G' le_m_n0. + fold (eval_continuous_Exp_P (proj1_sig e)). + apply (proj2_sig (Ind (P := UP'_P eval_continuous_Exp_P) _ (proj2_sig e))). + Qed. (* ============================================== *) (* WELL-FORMED VALUES RELATION *) (* ============================================== *) - Record WFValue_i : Set := mk_WFValue_i - {wfv_a : Value; - wfv_b : DType}. + Record WFValue_i : Set := + mk_WFValue_i {wfv_a : Value; wfv_b : DType}. - (** SuperFunctor for Well-Formed Value Relation. **) + (** SuperFunctor for Well-Formed Value Relation. **) - Variable WFV : (WFValue_i -> Prop) -> WFValue_i -> Prop. - Definition WFValue := iFix WFV. - Definition WFValueC V T:= WFValue (mk_WFValue_i V T). - Variable funWFV : iFunctor WFV. + Variable WFV : (WFValue_i -> Prop) -> WFValue_i -> Prop. + Definition WFValue := iFix WFV. + Definition WFValueC V T:= WFValue (mk_WFValue_i V T). + Variable funWFV : iFunctor WFV. - (** Bottom is well-formed **) + (** Bottom is well-formed **) - Inductive WFValue_Bot (A : WFValue_i -> Prop) : WFValue_i -> Prop := - WFV_Bot : forall v T, - proj1_sig v = inject (Bot _) -> - WFValue_Bot A (mk_WFValue_i v T). + Inductive WFValue_Bot (A : WFValue_i -> Prop) : WFValue_i -> Prop := + WFV_Bot : forall v T, + proj1_sig v = inject (Bot _) -> + WFValue_Bot A (mk_WFValue_i v T). - Definition ind_alg_WFV_Bot (P : WFValue_i -> Prop) - (H : forall v T v_eq, P (mk_WFValue_i v T)) - i (e : WFValue_Bot P i) : P i := - match e in WFValue_Bot _ i return P i with - | WFV_Bot v T v_eq => H v T v_eq - end. + Definition ind_alg_WFV_Bot (P : WFValue_i -> Prop) + (H : forall v T v_eq, P (mk_WFValue_i v T)) + i (e : WFValue_Bot P i) : P i := + match e in WFValue_Bot _ i return P i with + | WFV_Bot v T v_eq => H v T v_eq + end. - Definition WFV_Bot_ifmap (A B : WFValue_i -> Prop) i (f : forall i, A i -> B i) - (WFV_a : WFValue_Bot A i) : WFValue_Bot B i := - match WFV_a in (WFValue_Bot _ s) return (WFValue_Bot B s) - with - | WFV_Bot v T H => WFV_Bot B v T H - end. + Definition WFV_Bot_ifmap (A B : WFValue_i -> Prop) i (f : forall i, A i -> B i) + (WFV_a : WFValue_Bot A i) : WFValue_Bot B i := + match WFV_a in (WFValue_Bot _ s) return (WFValue_Bot B s) + with + | WFV_Bot v T H => WFV_Bot B v T H + end. - Global Instance iFun_WFV_Bot : iFunctor WFValue_Bot. - constructor 1 with (ifmap := WFV_Bot_ifmap). - destruct a; simpl; intros; reflexivity. - destruct a; simpl; intros; reflexivity. - Defined. - - Variable WF_WFV_Bot_WFV : Sub_iFunctor WFValue_Bot WFV. - - Definition WF_Environment env env' := - P2_Env (fun v T => - match T with - | Some T => WFValueC v T - | None => False - end) env env'. - - (* Projection doesn't affect WFValue Relation.*) - - Definition WFV_proj1_a_P (i :WFValue_i) := - forall a' H, a' = proj1_sig (wfv_a i) -> - WFValueC (exist _ a' H) (wfv_b i). - - Inductive WFV_proj1_a_Name := wfv_proj1_a_name. - Context {WFV_proj1_a_WFV : - iPAlgebra WFV_proj1_a_Name WFV_proj1_a_P WFV}. - - Definition WFV_proj1_a := - ifold_ WFV _ (ip_algebra (iPAlgebra := WFV_proj1_a_WFV)). - - Global Instance WFV_proj1_a_Bot : - iPAlgebra WFV_proj1_a_Name WFV_proj1_a_P WFValue_Bot. - econstructor; intros. - unfold iAlgebra; intros; unfold WFV_proj1_a_P. - inversion H; subst; simpl; intros. - apply (inject_i (subGF := WF_WFV_Bot_WFV)); constructor; simpl; congruence. - Defined. - - Definition WFV_proj1_b_P (i :WFValue_i) := - forall b' H, b' = proj1_sig (wfv_b i) -> - WFValueC (wfv_a i) (exist _ b' H). - - Inductive WFV_proj1_b_Name := wfv_proj1_b_name. - Context {WFV_proj1_b_WFV : - iPAlgebra WFV_proj1_b_Name WFV_proj1_b_P WFV}. - - Definition WFV_proj1_b := - ifold_ WFV _ (ip_algebra (iPAlgebra := WFV_proj1_b_WFV)). - - Global Instance WFV_proj1_b_Bot : - iPAlgebra WFV_proj1_b_Name WFV_proj1_b_P WFValue_Bot. - econstructor; intros. - unfold iAlgebra; intros; unfold WFV_proj1_b_P. - inversion H; subst; simpl; intros. - apply (inject_i (subGF := WF_WFV_Bot_WFV)); constructor; simpl; congruence. - Defined. + Global Instance iFun_WFV_Bot : iFunctor WFValue_Bot. + Proof. + constructor 1 with (ifmap := WFV_Bot_ifmap). + destruct a; simpl; intros; reflexivity. + destruct a; simpl; intros; reflexivity. + Defined. + + Variable WF_WFV_Bot_WFV : Sub_iFunctor WFValue_Bot WFV. + + Definition WF_Environment env env' := + P2_Env (fun v T => + match T with + | Some T => WFValueC v T + | None => False + end) env env'. + + (* Projection doesn't affect WFValue Relation.*) + + Definition WFV_proj1_a_P (i :WFValue_i) := + forall a' H, + a' = proj1_sig (wfv_a i) -> + WFValueC (exist _ a' H) (wfv_b i). + + Inductive WFV_proj1_a_Name := wfv_proj1_a_name. + Context {WFV_proj1_a_WFV : + iPAlgebra WFV_proj1_a_Name WFV_proj1_a_P WFV}. + + Definition WFV_proj1_a := + ifold_ WFV _ (ip_algebra (iPAlgebra := WFV_proj1_a_WFV)). + + Global Instance WFV_proj1_a_Bot : + iPAlgebra WFV_proj1_a_Name WFV_proj1_a_P WFValue_Bot. + econstructor; intros. + unfold iAlgebra; intros; unfold WFV_proj1_a_P. + inversion H; subst; simpl; intros. + apply (inject_i (subGF := WF_WFV_Bot_WFV)); constructor; simpl; congruence. + Defined. + + Definition WFV_proj1_b_P (i :WFValue_i) := + forall b' H, + b' = proj1_sig (wfv_b i) -> + WFValueC (wfv_a i) (exist _ b' H). + + Inductive WFV_proj1_b_Name := wfv_proj1_b_name. + Context {WFV_proj1_b_WFV : + iPAlgebra WFV_proj1_b_Name WFV_proj1_b_P WFV}. + + Definition WFV_proj1_b := + ifold_ WFV _ (ip_algebra (iPAlgebra := WFV_proj1_b_WFV)). + + Global Instance WFV_proj1_b_Bot : + iPAlgebra WFV_proj1_b_Name WFV_proj1_b_P WFValue_Bot. + Proof. + econstructor; intros. + unfold iAlgebra; intros; unfold WFV_proj1_b_P. + inversion H; subst; simpl; intros. + apply (inject_i (subGF := WF_WFV_Bot_WFV)); constructor; simpl; congruence. + Defined. (* ============================================== *) (* Evaluation preserves Well-Formedness *) (* ============================================== *) - Definition WF_Value_continuous_P i := - forall T, WFValueC (sv_b i) T -> WFValueC (sv_a i) T. + Definition WF_Value_continuous_P i := + forall T, WFValueC (sv_b i) T -> WFValueC (sv_a i) T. - Inductive WFV_ContinuousName : Set := wfv_continuousname. + Inductive WFV_ContinuousName : Set := wfv_continuousname. - Context {WF_Value_continous_alg : iPAlgebra WFV_ContinuousName WF_Value_continuous_P SV}. + Context {WF_Value_continous_alg : iPAlgebra WFV_ContinuousName WF_Value_continuous_P SV}. - Global Instance WFV_Value_continuous_refl : - iPAlgebra WFV_ContinuousName WF_Value_continuous_P SubValue_refl. - constructor; unfold iAlgebra; intros. - inversion H; subst. - unfold WF_Value_continuous_P; simpl; intros. - unfold WFValueC in H1. - destruct v; apply (WFV_proj1_a _ H1); eauto. - Qed. + Global Instance WFV_Value_continuous_refl : + iPAlgebra WFV_ContinuousName WF_Value_continuous_P SubValue_refl. + Proof. + constructor; unfold iAlgebra; intros. + inversion H; subst. + unfold WF_Value_continuous_P; simpl; intros. + unfold WFValueC in H1. + destruct v; apply (WFV_proj1_a _ H1); eauto. + Qed. - Global Instance WFV_Value_continuous_Bot : - iPAlgebra WFV_ContinuousName WF_Value_continuous_P SubValue_Bot. - constructor; unfold iAlgebra; intros. - inversion H; subst. - unfold WF_Value_continuous_P; simpl; intros. - apply inject_i; constructor; auto. - Qed. + Global Instance WFV_Value_continuous_Bot : + iPAlgebra WFV_ContinuousName WF_Value_continuous_P SubValue_Bot. + Proof. + constructor; unfold iAlgebra; intros. + inversion H; subst. + unfold WF_Value_continuous_P; simpl; intros. + apply inject_i; constructor; auto. + Qed. - Lemma WF_Value_continous : forall v v', + Lemma WF_Value_continous : + forall v v', SubValueC v v' -> WF_Value_continuous_P (mk_SubValue_i v v'). - intros; apply (ifold_ SV); try assumption. - apply ip_algebra. - Qed. + Proof. + intros; apply (ifold_ SV); try assumption. + apply ip_algebra. + Qed. - Lemma WF_Value_beval : forall m n, - forall (e : Exp) gamma gamma' T - (Sub_G_G' : Sub_Environment gamma' gamma), - m <= n -> - WFValueC (beval n e gamma) T -> - WFValueC (beval m e gamma') T. - intros; eapply WF_Value_continous. - eapply beval_continuous; try eassumption. - eassumption. - Qed. - - Variable (WF_MAlg_typeof : WF_MAlgebra Typeof_E). - Variable (WF_MAlg_eval : WF_MAlgebra eval_E). - - Definition eval_alg_Soundness_P - (P_bind : Set) - (P : P_bind -> Env Value -> Prop) - (E' : Set -> Set) - (Fun_E' : Functor E') - (pb : P_bind) - (typeof_rec : UP'_F E' -> typeofR) - (eval_rec : Exp -> evalR) - (typeof_F : Mixin (UP'_F E') E' typeofR) - (eval_F : Mixin Exp E evalR) - (e : (Fix E') * (Fix E)) - (e_UP' : Universal_Property'_fold (fst e) /\ Universal_Property'_fold (snd e)) := - forall - (eval_rec_proj : forall e, eval_rec e = eval_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig e)))) - (typeof_rec_proj : forall e, typeof_rec e = typeof_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig e)))) - gamma'' (WF_gamma'' : P pb gamma'') - (IHa : forall pb gamma'' (WF_gamma'' : P pb gamma'') (a : (UP'_F E' * Exp)), - (forall T, - typeof_F typeof_rec (out_t_UP' _ _ (proj1_sig (fst a))) = Some T -> - WFValueC (eval_F eval_rec (out_t_UP' _ _ (proj1_sig (snd a))) gamma'') T) -> - forall T, typeof_rec (fst a) = Some T -> - WFValueC (eval_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig (snd a)))) gamma'') T), - forall T : DType, - typeof_F typeof_rec (out_t_UP' _ _ (fst e)) = Some T -> - WFValueC (eval_F eval_rec (out_t_UP' _ _ (snd e)) gamma'') T. - - Inductive eval_Soundness_alg_Name := eval_soundness_algname. - - Variable eval_Soundness_alg_F : forall typeof_rec eval_rec, + Lemma WF_Value_beval : + forall m n (e : Exp), + forall gamma gamma' T + (Sub_G_G' : Sub_Environment gamma' gamma), + m <= n -> + WFValueC (beval n e gamma) T -> + WFValueC (beval m e gamma') T. + Proof. + intros; eapply WF_Value_continous. + eapply beval_continuous; try eassumption. + eassumption. + Qed. + + Variable (WF_MAlg_typeof : WF_MAlgebra Typeof_E). + Variable (WF_MAlg_eval : WF_MAlgebra eval_E). + + Definition eval_alg_Soundness_P + (P_bind : Set) + (P : P_bind -> Env Value -> Prop) + (E' : Set -> Set) + (Fun_E' : Functor E') + (pb : P_bind) + (typeof_rec : UP'_F E' -> typeofR) + (eval_rec : Exp -> evalR) + (typeof_F : Mixin (UP'_F E') E' typeofR) + (eval_F : Mixin Exp E evalR) + (e : (Fix E') * (Fix E)) + (e_UP' : Universal_Property'_fold (fst e) /\ Universal_Property'_fold (snd e)) := + forall + (eval_rec_proj : forall e, eval_rec e = eval_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig e)))) + (typeof_rec_proj : forall e, typeof_rec e = typeof_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig e)))) + gamma'' (WF_gamma'' : P pb gamma'') + (IHa : forall pb gamma'' (WF_gamma'' : P pb gamma'') (a : (UP'_F E' * Exp)), + (forall T, + typeof_F typeof_rec (out_t_UP' _ _ (proj1_sig (fst a))) = Some T -> + WFValueC (eval_F eval_rec (out_t_UP' _ _ (proj1_sig (snd a))) gamma'') T) -> + forall T, typeof_rec (fst a) = Some T -> + WFValueC (eval_rec (in_t_UP' _ _ (out_t_UP' _ _ (proj1_sig (snd a)))) gamma'') T), + forall T : DType, + typeof_F typeof_rec (out_t_UP' _ _ (fst e)) = Some T -> + WFValueC (eval_F eval_rec (out_t_UP' _ _ (snd e)) gamma'') T. + + Inductive eval_Soundness_alg_Name := eval_soundness_algname. + + Variable eval_Soundness_alg_F : + forall typeof_rec eval_rec, PAlgebra eval_Soundness_alg_Name (sig (UP'_P2 (eval_alg_Soundness_P unit (fun _ _ => True) _ _ tt typeof_rec eval_rec (f_algebra (FAlgebra := Typeof_E _)) (f_algebra (FAlgebra := eval_E _))))) E. - Variable WF_Ind_eval_Soundness_alg : forall typeof_rec eval_rec, + Variable WF_Ind_eval_Soundness_alg : + forall typeof_rec eval_rec, @WF_Ind2 E E E eval_Soundness_alg_Name Fun_E Fun_E Fun_E (UP'_P2 (eval_alg_Soundness_P _ _ _ _ tt typeof_rec eval_rec _ _)) _ _ (eval_Soundness_alg_F _ _). - Definition eval_soundness_P (e : Fix E) (e_UP' : Universal_Property'_fold e) := - forall gamma'' T, typeof e = Some T -> - WFValueC (eval e gamma'') T. - - Lemma eval_Soundness : forall (e : Exp), - forall gamma'' T, typeof (proj1_sig e) = Some T -> - WFValueC (eval (proj1_sig e) gamma'') T. - intros. - rewrite <- (@in_out_UP'_inverse _ _ (proj1_sig e) (proj2_sig e)). - simpl; unfold typeof, eval, fold_, mfold, in_t. - rewrite wf_malgebra; unfold mfold. - destruct (Ind2 (Ind_Alg := eval_Soundness_alg_F - (fun e => typeof (proj1_sig e)) (fun e => eval (proj1_sig e))) - _ (proj2_sig e)) as [e' eval_e']. - unfold eval_alg_Soundness_P in eval_e'. - eapply eval_e'; intros; auto; try constructor. - rewrite (@in_out_UP'_inverse _ _ (proj1_sig _) (proj2_sig _)); auto. - rewrite (@in_out_UP'_inverse _ _ (proj1_sig _) (proj2_sig _)); auto. - unfold eval, mfold; simpl; unfold in_t; rewrite wf_malgebra; unfold mfold; apply H0; auto. - rewrite <- (@in_out_UP'_inverse _ _ (proj1_sig (fst a)) (proj2_sig (fst a))) in H1. - simpl in H1; unfold typeof, mfold, in_t in H1. - rewrite wf_malgebra in H1; apply H1. - rewrite <- (@in_out_inverse _ _ (proj1_sig e) (proj2_sig e)) in H. - simpl in H; unfold typeof, mfold, in_t in H; simpl in H. - rewrite <- wf_malgebra. - simpl; unfold out_t_UP'. - rewrite Fusion with (g := (fmap in_t)). - apply H. - exact (proj2_sig _). - intros; repeat rewrite fmap_fusion; reflexivity. - Qed. + Definition eval_soundness_P (e : Fix E) (e_UP' : Universal_Property'_fold e) := + forall gamma'' T, + typeof e = Some T -> + WFValueC (eval e gamma'') T. + + Lemma eval_Soundness : + forall (e : Exp), + forall gamma'' T, + typeof (proj1_sig e) = Some T -> + WFValueC (eval (proj1_sig e) gamma'') T. + Proof. + intros. + rewrite <- (@in_out_UP'_inverse _ _ (proj1_sig e) (proj2_sig e)). + simpl; unfold typeof, eval, fold_, mfold, in_t. + rewrite wf_malgebra; unfold mfold. + destruct (Ind2 (Ind_Alg := eval_Soundness_alg_F + (fun e => typeof (proj1_sig e)) (fun e => eval (proj1_sig e))) + _ (proj2_sig e)) as [e' eval_e']. + unfold eval_alg_Soundness_P in eval_e'. + eapply eval_e'; intros; auto; try constructor. + rewrite (@in_out_UP'_inverse _ _ (proj1_sig _) (proj2_sig _)); auto. + rewrite (@in_out_UP'_inverse _ _ (proj1_sig _) (proj2_sig _)); auto. + unfold eval, mfold; simpl; unfold in_t; rewrite wf_malgebra; unfold mfold; apply H0; auto. + rewrite <- (@in_out_UP'_inverse _ _ (proj1_sig (fst a)) (proj2_sig (fst a))) in H1. + simpl in H1; unfold typeof, mfold, in_t in H1. + rewrite wf_malgebra in H1; apply H1. + rewrite <- (@in_out_inverse _ _ (proj1_sig e) (proj2_sig e)) in H. + simpl in H; unfold typeof, mfold, in_t in H; simpl in H. + rewrite <- wf_malgebra. + simpl; unfold out_t_UP'. + rewrite Fusion with (g := (fmap in_t)). + apply H. + exact (proj2_sig _). + intros; repeat rewrite fmap_fusion; reflexivity. + Qed. End Names. diff --git a/NatCase.v b/NatCase.v index 0b40b38..26e06f5 100644 --- a/NatCase.v +++ b/NatCase.v @@ -30,8 +30,9 @@ Section NatCase. Global Instance NatCase_Functor A : Functor (NatCase A) | 5 := {| fmap := NatCase_fmap A |}. Proof. + (* fmap fusion *) destruct a; reflexivity. - (* fmap id *) + (* fmap id *) destruct a; unfold id; simpl; auto; rewrite <- eta_expansion_dep; reflexivity. Defined. @@ -77,9 +78,9 @@ Section NatCase. (proj2_sig n) (proj2_sig z) (fun n' => proj2_sig (s n'))) end. -(* ============================================== *) -(* TYPING *) -(* ============================================== *) + (* ============================================== *) + (* TYPING *) + (* ============================================== *) Context {eq_DType_DT : forall T, FAlgebra eq_DTypeName T (eq_DTypeR D) D}. @@ -126,19 +127,21 @@ Section NatCase. Definition NatCase_eval R : Mixin R (NatCase nat) (evalR V) := fun rec e => - match e with - | NVar n => fun env => match (lookup env n) with - | Some v => v - | _ => stuck' 146 - end - | Case n z s => fun env => - let reced := rec n env in - match isVI V (proj1_sig reced) with - | Some 0 => rec z env - | Some (S n') => rec (s (Datatypes.length env)) (insert _ (vi' _ n') env) - | _ => if isBot _ (proj1_sig reced) then bot' else stuck' 145 - end - end. + match e with + | NVar n => + fun env => match (lookup env n) with + | Some v => v + | _ => stuck' 146 + end + | Case n z s => + fun env => + let reced := rec n env in + match isVI V (proj1_sig reced) with + | Some 0 => rec z env + | Some (S n') => rec (s (Datatypes.length env)) (insert _ (vi' _ n') env) + | _ => if isBot _ (proj1_sig reced) then bot' else stuck' 145 + end + end. Global Instance MAlgebra_eval_NatCase T : FAlgebra EvalName T (evalR V) (NatCase _) := @@ -169,195 +172,200 @@ Section NatCase. (* TYPE SOUNDNESS *) (* ============================================== *) - Context {eval_F : FAlgebra EvalName (Exp nat) (evalR V) (F nat)}. - Context {WF_eval_F : @WF_FAlgebra EvalName _ _ (NatCase _) - (F _) (Sub_NatCase_F _) (MAlgebra_eval_NatCase _) (eval_F)}. - - (* Continuity of Evaluation. *) - - Context {SV : (SubValue_i V -> Prop) -> SubValue_i V -> Prop}. - Context {iFun_SV : iFunctor SV}. - Context {Sub_SV_refl_SV : Sub_iFunctor (SubValue_refl V) SV}. - Context {Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV}. - Context {SV_invertVI_SV : - iPAlgebra SV_invertVI_Name (SV_invertVI_P V) SV}. - Context {SV_invertVI'_SV : - iPAlgebra SV_invertVI'_Name (SV_invertVI'_P V) SV}. - Context {Dis_VI_Bot : Distinct_Sub_Functor _ Sub_NatValue_V Sub_BotValue_V}. - Context {SV_invertBot_SV : - iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SV}. - - Context {SV_proj1_b_SV : - iPAlgebra SV_proj1_b_Name (SV_proj1_b_P _ SV) SV}. - Context {SV_proj1_a_SV : - iPAlgebra SV_proj1_a_Name (SV_proj1_a_P _ SV) SV}. - - Global Instance NatCase_eval_continuous_Exp : - PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V (F _) SV))) (NatCase nat). - Proof. - constructor; unfold Algebra; intros. - eapply ind_alg_NatCase; try assumption; intros. + Context {eval_F : FAlgebra EvalName (Exp nat) (evalR V) (F nat)}. + Context {WF_eval_F : @WF_FAlgebra EvalName _ _ (NatCase _) + (F _) (Sub_NatCase_F _) (MAlgebra_eval_NatCase _) (eval_F)}. + + (* Continuity of Evaluation. *) + + Context {SV : (SubValue_i V -> Prop) -> SubValue_i V -> Prop}. + Context {iFun_SV : iFunctor SV}. + Context {Sub_SV_refl_SV : Sub_iFunctor (SubValue_refl V) SV}. + Context {Sub_SV_Bot_SV : Sub_iFunctor (SubValue_Bot V) SV}. + Context {SV_invertVI_SV : + iPAlgebra SV_invertVI_Name (SV_invertVI_P V) SV}. + Context {SV_invertVI'_SV : + iPAlgebra SV_invertVI'_Name (SV_invertVI'_P V) SV}. + Context {Dis_VI_Bot : Distinct_Sub_Functor _ Sub_NatValue_V Sub_BotValue_V}. + Context {SV_invertBot_SV : + iPAlgebra SV_invertBot_Name (SV_invertBot_P V) SV}. + + Context {SV_proj1_b_SV : + iPAlgebra SV_proj1_b_Name (SV_proj1_b_P _ SV) SV}. + Context {SV_proj1_a_SV : + iPAlgebra SV_proj1_a_Name (SV_proj1_a_P _ SV) SV}. + + Global Instance NatCase_eval_continuous_Exp : + PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V (F _) SV))) (NatCase nat). + Proof. + constructor; unfold Algebra; intros. + eapply ind_alg_NatCase; try assumption; intros. (* NVar case. *) - unfold eval_continuous_Exp_P; econstructor; simpl; intros; - eauto with typeclass_instances. - instantiate (1 := nvar_UP' n). - unfold beval, mfold, nvar; simpl; repeat rewrite wf_functor; simpl. - repeat rewrite out_in_fmap; rewrite wf_functor; simpl. - repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. - caseEq (@lookup _ gamma n); unfold Value in *|-*. - destruct (P2_Env_lookup _ _ _ _ _ H1 _ _ H3) as [v' [lookup_v' Sub_v_v']]. - unfold Value; rewrite lookup_v'; eauto. - unfold Value; rewrite (P2_Env_Nlookup _ _ _ _ _ H1 _ H3). - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. + unfold eval_continuous_Exp_P; econstructor; simpl; intros; + eauto with typeclass_instances. + instantiate (1 := nvar_UP' n). + unfold beval, mfold, nvar; simpl; repeat rewrite wf_functor; simpl. + repeat rewrite out_in_fmap; rewrite wf_functor; simpl. + repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. + caseEq (@lookup _ gamma n); unfold Value in *|-*. + destruct (P2_Env_lookup _ _ _ _ _ H1 _ _ H3) as [v' [lookup_v' Sub_v_v']]. + unfold Value; rewrite lookup_v'; eauto. + unfold Value; rewrite (P2_Env_Nlookup _ _ _ _ _ H1 _ H3). + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto. (* Case case. *) - destruct IHn as [n_UP IHn]. - destruct IHz as [z_UP IHz]. - unfold eval_continuous_Exp_P; econstructor; simpl; intros; - eauto with typeclass_instances. - instantiate (1 := Ncase_UP' _ _ _). - destruct (IHs (Datatypes.length gamma)) as [s'_UP IHs']. - generalize (H0 (exist _ _ n_UP) _ _ _ H1 H2); intro SV_n_n. - unfold beval, mfold, Ncase; simpl; repeat rewrite wf_functor; simpl. - repeat rewrite out_in_fmap; rewrite wf_functor; simpl. - repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. - rewrite <- (P2_Env_length _ _ _ _ _ H1). - repeat erewrite bF_UP_in_out. - unfold Names.Exp, evalR. - unfold isVI; caseEq (project (G := NatValue) (proj1_sig (beval V (F _) n0 (exist _ _ n_UP) gamma'))). - unfold beval, Names.Exp, evalR in H3; rewrite H3. - destruct n1. - apply project_inject in H3; auto with typeclass_instances; - unfold inject, evalR, Names.Value in H3; simpl in H3. - destruct (SV_invertVI' V _ SV_n_n _ H3) as [beval_m | beval_m]; - simpl in beval_m; unfold beval, Names.Exp, evalR in *|-*; rewrite beval_m. - rewrite project_vi_vi; eauto; destruct n1; apply H0; auto. - (eapply P2_Env_insert; - [assumption | apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto]). - rewrite project_vi_bot; eauto. - unfold isBot; rewrite project_bot_bot; eauto. - apply inject_i; constructor; reflexivity. - exact (proj2_sig _). - unfold isBot; caseEq (project (G := BotValue) - (proj1_sig (beval V (F _) n0 (exist _ _ n_UP) gamma'))). - unfold beval, Names.Exp, evalR in H4; rewrite H4. - destruct b. - apply project_inject in H4; auto with typeclass_instances; - unfold inject, evalR, Names.Value in H4; simpl in H4. - generalize (SV_invertBot V _ _ _ SV_n_n H4) as beval_m; intro; - simpl in beval_m; unfold beval, Names.Exp, evalR in *|-*; rewrite beval_m. - rewrite project_vi_bot, project_bot_bot; eauto. - apply inject_i; constructor; reflexivity. - exact (proj2_sig _). - unfold isVI; caseEq (project (G := NatValue) (proj1_sig (beval V (F _) m (exist _ _ n_UP) gamma))). - unfold beval, Names.Exp, evalR in H5; rewrite H5. - destruct n1. - apply project_inject in H5; auto with typeclass_instances; - unfold inject, evalR, Names.Value in H5; simpl in H5. - generalize (SV_invertVI V _ SV_n_n _ H5) as beval_m; intro; - simpl in beval_m; unfold Names.Exp, evalR in *|-*; rewrite beval_m in H3. - rewrite project_vi_vi in H3; eauto; discriminate. - exact (proj2_sig _). - unfold beval, Names.Exp, evalR in H5; rewrite H5. - caseEq (project (G := BotValue) - (proj1_sig (beval V (F _) m (exist _ _ n_UP) gamma))). - unfold beval, Names.Exp, evalR in H6; rewrite H6. - destruct b. - apply inject_i; constructor; reflexivity. - unfold beval, Names.Exp, evalR in H6; rewrite H6. - unfold beval, Names.Exp, evalR in H3; rewrite H3. - unfold beval, Names.Exp, evalR in H4; rewrite H4. - apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; reflexivity. - Defined. - - Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. - Variable funWFV : iFunctor WFV. - Variable EQV_E : forall A B, (eqv_i F A B -> Prop) -> eqv_i F A B -> Prop. - Definition E_eqv A B := iFix (EQV_E A B). - Definition E_eqvC {A B : Set} gamma gamma' e e' := - E_eqv _ _ (mk_eqv_i _ A B gamma gamma' e e'). - Variable funEQV_E : forall A B, iFunctor (EQV_E A B). - - (* Projection doesn't affect Equivalence Relation.*) - - Inductive NatCase_eqv (A B : Set) (E : eqv_i F A B -> Prop) : eqv_i F A B -> Prop := - | NVar_eqv : forall (gamma : Env _) gamma' n a b e e', - lookup gamma n = Some a -> lookup gamma' n = Some b -> - proj1_sig e = nvar a -> - proj1_sig e' = nvar b -> - NatCase_eqv A B E (mk_eqv_i _ _ _ gamma gamma' e e') - | Case_eqv : forall (gamma : Env _) gamma' n n' z z' s s' e e', - E (mk_eqv_i _ _ _ gamma gamma' n n') -> - E (mk_eqv_i _ _ _ gamma gamma' z z') -> - (forall (n : A) (n' : B), - E (mk_eqv_i _ _ _ (insert _ n gamma) (insert _ n' gamma') (s n) (s' n'))) -> - proj1_sig e = proj1_sig (case' n z s) -> - proj1_sig e' = proj1_sig (case' n' z' s') -> - NatCase_eqv _ _ E (mk_eqv_i _ _ _ gamma gamma' e e'). - - Definition ind_alg_NatCase_eqv - (A B : Set) - (P : eqv_i F A B -> Prop) - (H : forall gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq, - P (mk_eqv_i _ _ _ gamma gamma' e e')) - (H0 : forall gamma gamma' n n' z z' s s' e e' - (IHn : P (mk_eqv_i _ _ _ gamma gamma' n n')) - (IHz : P (mk_eqv_i _ _ _ gamma gamma' z z')) - (IHs : forall n n', - P (mk_eqv_i _ _ _ (insert _ n gamma) (insert _ n' gamma') (s n) (s' n'))) - e_eq e'_eq, + destruct IHn as [n_UP IHn]. + destruct IHz as [z_UP IHz]. + unfold eval_continuous_Exp_P; econstructor; simpl; intros; + eauto with typeclass_instances. + instantiate (1 := Ncase_UP' _ _ _). + destruct (IHs (Datatypes.length gamma)) as [s'_UP IHs']. + generalize (H0 (exist _ _ n_UP) _ _ _ H1 H2); intro SV_n_n. + unfold beval, mfold, Ncase; simpl; repeat rewrite wf_functor; simpl. + repeat rewrite out_in_fmap; rewrite wf_functor; simpl. + repeat rewrite (wf_algebra (WF_FAlgebra := WF_eval_F)); simpl. + rewrite <- (P2_Env_length _ _ _ _ _ H1). + repeat erewrite bF_UP_in_out. + unfold Names.Exp, evalR. + unfold isVI; caseEq (project (G := NatValue) (proj1_sig (beval V (F _) n0 (exist _ _ n_UP) gamma'))). + unfold beval, Names.Exp, evalR in H3; rewrite H3. + destruct n1. + apply project_inject in H3; auto with typeclass_instances; + unfold inject, evalR, Names.Value in H3; simpl in H3. + destruct (SV_invertVI' V _ SV_n_n _ H3) as [beval_m | beval_m]; + simpl in beval_m; unfold beval, Names.Exp, evalR in *|-*; rewrite beval_m. + rewrite project_vi_vi; eauto; destruct n1; apply H0; auto. + (eapply P2_Env_insert; + [assumption | apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; eauto]). + rewrite project_vi_bot; eauto. + unfold isBot; rewrite project_bot_bot; eauto. + apply inject_i; constructor; reflexivity. + exact (proj2_sig _). + unfold isBot; caseEq (project (G := BotValue) + (proj1_sig (beval V (F _) n0 (exist _ _ n_UP) gamma'))). + unfold beval, Names.Exp, evalR in H4; rewrite H4. + destruct b. + apply project_inject in H4; auto with typeclass_instances; + unfold inject, evalR, Names.Value in H4; simpl in H4. + generalize (SV_invertBot V _ _ _ SV_n_n H4) as beval_m; intro; + simpl in beval_m; unfold beval, Names.Exp, evalR in *|-*; rewrite beval_m. + rewrite project_vi_bot, project_bot_bot; eauto. + apply inject_i; constructor; reflexivity. + exact (proj2_sig _). + unfold isVI; caseEq (project (G := NatValue) (proj1_sig (beval V (F _) m (exist _ _ n_UP) gamma))). + unfold beval, Names.Exp, evalR in H5; rewrite H5. + destruct n1. + apply project_inject in H5; auto with typeclass_instances; + unfold inject, evalR, Names.Value in H5; simpl in H5. + generalize (SV_invertVI V _ SV_n_n _ H5) as beval_m; intro; + simpl in beval_m; unfold Names.Exp, evalR in *|-*; rewrite beval_m in H3. + rewrite project_vi_vi in H3; eauto; discriminate. + exact (proj2_sig _). + unfold beval, Names.Exp, evalR in H5; rewrite H5. + caseEq (project (G := BotValue) + (proj1_sig (beval V (F _) m (exist _ _ n_UP) gamma))). + unfold beval, Names.Exp, evalR in H6; rewrite H6. + destruct b. + apply inject_i; constructor; reflexivity. + unfold beval, Names.Exp, evalR in H6; rewrite H6. + unfold beval, Names.Exp, evalR in H3; rewrite H3. + unfold beval, Names.Exp, evalR in H4; rewrite H4. + apply (inject_i (subGF := Sub_SV_refl_SV)); constructor; reflexivity. + Defined. + + Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. + Variable funWFV : iFunctor WFV. + Variable EQV_E : forall A B, (eqv_i F A B -> Prop) -> eqv_i F A B -> Prop. + Definition E_eqv A B := iFix (EQV_E A B). + Definition E_eqvC {A B : Set} gamma gamma' e e' := + E_eqv _ _ (mk_eqv_i _ A B gamma gamma' e e'). + Variable funEQV_E : forall A B, iFunctor (EQV_E A B). + + (* Projection doesn't affect Equivalence Relation.*) + + Inductive NatCase_eqv (A B : Set) (E : eqv_i F A B -> Prop) : eqv_i F A B -> Prop := + | NVar_eqv : forall (gamma : Env _) gamma' n a b e e', + lookup gamma n = Some a -> lookup gamma' n = Some b -> + proj1_sig e = nvar a -> + proj1_sig e' = nvar b -> + NatCase_eqv A B E (mk_eqv_i _ _ _ gamma gamma' e e') + | Case_eqv : forall (gamma : Env _) gamma' n n' z z' s s' e e', + E (mk_eqv_i _ _ _ gamma gamma' n n') -> + E (mk_eqv_i _ _ _ gamma gamma' z z') -> + (forall (n : A) (n' : B), + E (mk_eqv_i _ _ _ (insert _ n gamma) (insert _ n' gamma') (s n) (s' n'))) -> + proj1_sig e = proj1_sig (case' n z s) -> + proj1_sig e' = proj1_sig (case' n' z' s') -> + NatCase_eqv _ _ E (mk_eqv_i _ _ _ gamma gamma' e e'). + + Definition ind_alg_NatCase_eqv + (A B : Set) + (P : eqv_i F A B -> Prop) + (H : forall gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq, P (mk_eqv_i _ _ _ gamma gamma' e e')) - i (e : NatCase_eqv A B P i) : P i := - match e in NatCase_eqv _ _ _ i return P i with - | NVar_eqv gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq => - H gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq - | Case_eqv gamma gamma' n n' z z' s s' e e' - eqv_n_n' eqv_z_z' eqv_s_s' e_eq e'_eq => - H0 gamma gamma' n n' z z' s s' e e' eqv_n_n' - eqv_z_z' eqv_s_s' e_eq e'_eq - end. + (H0 : forall gamma gamma' n n' z z' s s' e e' + (IHn : P (mk_eqv_i _ _ _ gamma gamma' n n')) + (IHz : P (mk_eqv_i _ _ _ gamma gamma' z z')) + (IHs : forall n n', + P (mk_eqv_i _ _ _ (insert _ n gamma) (insert _ n' gamma') (s n) (s' n'))) + e_eq e'_eq, + P (mk_eqv_i _ _ _ gamma gamma' e e')) + i (e : NatCase_eqv A B P i) : P i := + match e in NatCase_eqv _ _ _ i return P i with + | NVar_eqv gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq => + H gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq + | Case_eqv gamma gamma' n n' z z' s s' e e' + eqv_n_n' eqv_z_z' eqv_s_s' e_eq e'_eq => + H0 gamma gamma' n n' z z' s s' e e' eqv_n_n' + eqv_z_z' eqv_s_s' e_eq e'_eq + end. - Definition NatCase_eqv_ifmap (A B : Set) - (A' B' : eqv_i F A B -> Prop) i (f : forall i, A' i -> B' i) - (eqv_a : NatCase_eqv A B A' i) : NatCase_eqv A B B' i := - match eqv_a in NatCase_eqv _ _ _ i return NatCase_eqv _ _ _ i with - | NVar_eqv gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq => - NVar_eqv _ _ _ gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq - | Case_eqv gamma gamma' n n' z z' s s' e e' - eqv_n_n' eqv_z_z' eqv_s_s' e_eq e'_eq => - Case_eqv _ _ _ gamma gamma' n n' z z' s s' e e' - (f _ eqv_n_n') (f _ eqv_z_z') - (fun a b => f _ (eqv_s_s' a b)) - e_eq e'_eq - end. + Definition NatCase_eqv_ifmap (A B : Set) + (A' B' : eqv_i F A B -> Prop) i (f : forall i, A' i -> B' i) + (eqv_a : NatCase_eqv A B A' i) : NatCase_eqv A B B' i := + match eqv_a in NatCase_eqv _ _ _ i return NatCase_eqv _ _ _ i with + | NVar_eqv gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq => + NVar_eqv _ _ _ gamma gamma' n a b e e' lookup_a lookup_b e_eq e'_eq + | Case_eqv gamma gamma' n n' z z' s s' e e' + eqv_n_n' eqv_z_z' eqv_s_s' e_eq e'_eq => + Case_eqv _ _ _ gamma gamma' n n' z z' s s' e e' + (f _ eqv_n_n') (f _ eqv_z_z') + (fun a b => f _ (eqv_s_s' a b)) + e_eq e'_eq + end. - Global Instance iFun_NatCase_eqv A B : iFunctor (NatCase_eqv A B). - constructor 1 with (ifmap := NatCase_eqv_ifmap A B). - destruct a; simpl; intros; reflexivity. - destruct a; simpl; intros; unfold id; eauto; - rewrite (functional_extensionality_dep _ a1); eauto; - intros; apply functional_extensionality_dep; eauto. - Defined. - - Variable Sub_NatCase_eqv_EQV_E : forall A B, - Sub_iFunctor (NatCase_eqv A B) (EQV_E A B). - - Global Instance EQV_proj1_NatCase_eqv : - forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P F EQV_E A B) (NatCase_eqv _ _). - econstructor; intros. - unfold iAlgebra; intros; apply ind_alg_NatCase_eqv; - unfold EQV_proj1_P; simpl; intros; subst. - apply (inject_i (subGF := Sub_NatCase_eqv_EQV_E A B)); econstructor; simpl; eauto. - apply (inject_i (subGF := Sub_NatCase_eqv_EQV_E A B)); econstructor 2; simpl; eauto. - destruct n; destruct n'; eapply IHn; eauto. - destruct z; destruct z'; eapply IHz; eauto. - intros; caseEq (s n0); caseEq (s' n'0); apply IHs; eauto. - rewrite H2; simpl; eauto. - rewrite H3; simpl; eauto. - apply H. - Qed. - - Lemma isTNat_tnat : forall T : DType, - isTNat _ (proj1_sig T) = true -> proj1_sig T = tnat _. + Global Instance iFun_NatCase_eqv A B : + iFunctor (NatCase_eqv A B). + Proof. + constructor 1 with (ifmap := NatCase_eqv_ifmap A B). + destruct a; simpl; intros; reflexivity. + destruct a; simpl; intros; unfold id; eauto; + rewrite (functional_extensionality_dep _ a1); eauto; + intros; apply functional_extensionality_dep; eauto. + Defined. + + Variable Sub_NatCase_eqv_EQV_E : forall A B, + Sub_iFunctor (NatCase_eqv A B) (EQV_E A B). + + Global Instance EQV_proj1_NatCase_eqv : + forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P F EQV_E A B) (NatCase_eqv _ _). + Proof. + econstructor; intros. + unfold iAlgebra; intros; apply ind_alg_NatCase_eqv; + unfold EQV_proj1_P; simpl; intros; subst. + apply (inject_i (subGF := Sub_NatCase_eqv_EQV_E A B)); econstructor; simpl; eauto. + apply (inject_i (subGF := Sub_NatCase_eqv_EQV_E A B)); econstructor 2; simpl; eauto. + destruct n; destruct n'; eapply IHn; eauto. + destruct z; destruct z'; eapply IHz; eauto. + intros; caseEq (s n0); caseEq (s' n'0); apply IHs; eauto. + rewrite H2; simpl; eauto. + rewrite H3; simpl; eauto. + apply H. + Qed. + + Lemma isTNat_tnat : + forall (T : DType), + isTNat _ (proj1_sig T) = true -> proj1_sig T = tnat _. + Proof. unfold isTNat; intros; caseEq (project (G := AType) (proj1_sig T)); rewrite H0 in H; try discriminate. destruct a; unfold project in H0; apply inj_prj in H0. @@ -368,14 +376,18 @@ Section NatCase. exact (proj2_sig _). Defined. - Lemma isVI_vi : forall n, - isVI _ (vi _ n) = Some n. + Lemma isVI_vi : + forall n, + isVI _ (vi _ n) = Some n. + Proof. intros; unfold isVI, vi, vi', project; simpl; rewrite wf_functor. rewrite out_in_fmap; rewrite wf_functor; simpl. rewrite prj_inj; reflexivity. Qed. - Lemma isVI_bot : isVI _ (bot _) = None. + Lemma isVI_bot : + isVI _ (bot _) = None. + Proof. intros; unfold isVI, bot, bot', project; simpl; rewrite wf_functor. rewrite out_in_fmap; rewrite wf_functor; simpl; unfold Bot_fmap. caseEq (prj (sub_F := NatValue) (inj (Bot (sig (@Universal_Property'_fold V _))))); auto. @@ -385,7 +397,9 @@ Section NatCase. unfold inject; erewrite H; reflexivity. Qed. - Lemma isBot_bot : isBot _ (bot _) = true. + Lemma isBot_bot : + isBot _ (bot _) = true. + Proof. intros; unfold isBot, bot, bot', project; simpl; rewrite wf_functor. rewrite out_in_fmap; rewrite wf_functor; simpl; unfold Bot_fmap. rewrite prj_inj; reflexivity. diff --git a/PNames.v b/PNames.v index 91984ae..30cdb00 100644 --- a/PNames.v +++ b/PNames.v @@ -171,130 +171,130 @@ Section PNames. (* Projection doesn't affect Equivalence Relation.*) - Definition EQV_proj1_P A B (i : eqv_i A B) := - forall a' b' H H0, a' = proj1_sig (eqv_a _ _ i) -> - b' = proj1_sig (eqv_b _ _ i) -> - E_eqvC (env_A _ _ i) (env_B _ _ i) (exist _ a' H) (exist _ b' H0). + Definition EQV_proj1_P A B (i : eqv_i A B) := + forall a' b' H H0, a' = proj1_sig (eqv_a _ _ i) -> + b' = proj1_sig (eqv_b _ _ i) -> + E_eqvC (env_A _ _ i) (env_B _ _ i) (exist _ a' H) (exist _ b' H0). - Inductive EQV_proj1_Name := eqv_proj1_name. - Context {EQV_proj1_EQV : forall A B, - iPAlgebra EQV_proj1_Name (@EQV_proj1_P A B) (EQV_E A B)}. - Context {Fun_EQV_E : forall A B, iFunctor (EQV_E A B)}. + Inductive EQV_proj1_Name := eqv_proj1_name. + Context {EQV_proj1_EQV : forall A B, + iPAlgebra EQV_proj1_Name (@EQV_proj1_P A B) (EQV_E A B)}. + Context {Fun_EQV_E : forall A B, iFunctor (EQV_E A B)}. - Definition EQV_proj1 A B:= - ifold_ (EQV_E A B) _ (ip_algebra (iPAlgebra := EQV_proj1_EQV A B)). + Definition EQV_proj1 A B:= + ifold_ (EQV_E A B) _ (ip_algebra (iPAlgebra := EQV_proj1_EQV A B)). Variable Sub_NP_Functor_eqv_EQV_E : forall A B, Sub_iFunctor (NP_Functor_eqv A B) (EQV_E A B). - Global Instance EQV_proj1_NP_Functor_eqv : - forall A B, - iPAlgebra EQV_proj1_Name (EQV_proj1_P A B) (NP_Functor_eqv _ _). - Proof. - intros; econstructor; unfold iAlgebra; intros. - eapply ind_alg_NP_Functor_eqv; unfold EQV_proj1_P; simpl; intros. - apply inject_i; econstructor; simpl; eauto. - rewrite H2; rewrite e_eq; eauto. - rewrite H3; rewrite e'_eq; eauto. - apply inject_i; econstructor 2; simpl; eauto. - rewrite H2; rewrite e_eq; eauto. - rewrite H3; rewrite e'_eq; eauto. - destruct a; destruct a'; apply IHa; auto. - apply inject_i; econstructor 3; simpl; eauto. - rewrite H2; rewrite e_eq; eauto. - rewrite H3; rewrite e'_eq; eauto. - destruct a; destruct a'; apply IHa; auto. - destruct b; destruct b'; apply IHb; auto. - apply inject_i; econstructor 4; simpl; eauto. - rewrite H2; rewrite e_eq; eauto. - rewrite H3; rewrite e'_eq; eauto. - destruct a; destruct a'; apply IHa; auto. - destruct b; destruct b'; apply IHb; auto. - destruct c; destruct c'; apply IHc; auto. - assumption. - Defined. - - End eqv_Section. - - Variable EQV_E : forall A B, (@eqv_i A B -> Prop) -> eqv_i A B -> Prop. - Context {Fun_EQV_E : forall A B, iFunctor (EQV_E A B)}. - Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. - Context {funWFV : iFunctor WFV}. - - Definition WF_eqv_environment_P (env_A_B : Env (typeofR D) * Env nat) gamma'' := - (forall m b : nat, - lookup (snd env_A_B) m = Some b -> - exists T, lookup (fst env_A_B) b = Some T) /\ - Datatypes.length (fst env_A_B) = Datatypes.length (snd env_A_B) /\ - (forall m b : nat, lookup (snd env_A_B) m = Some b -> b = m) /\ - WF_Environment _ _ WFV gamma'' (fst env_A_B). - - Definition eqv_eval_alg_Soundness'_P - (typeof_rec : Exp (E (typeofR D)) -> typeofR D) - (eval_rec : Exp (E nat) -> evalR V) - (typeof_F : Mixin (Exp (E (typeofR D))) (E (typeofR D)) (typeofR D)) - (eval_F : Mixin (Exp (E nat)) (E nat) (evalR V)) - i := - E_eqv EQV_E _ _ i /\ - eval_alg_Soundness_P D V (E nat) WFV - _ WF_eqv_environment_P - (E (typeofR D)) _ (env_A _ _ i, env_B _ _ i) typeof_rec eval_rec - typeof_F eval_F - (proj1_sig (eqv_a _ _ i), proj1_sig (eqv_b _ _ i)) - (conj (proj2_sig (eqv_a _ _ i)) (proj2_sig (eqv_b _ _ i))). - - Lemma WF_eqv_environment_P_insert : forall gamma gamma' gamma'' v T, - WF_eqv_environment_P (gamma, gamma') gamma'' -> - WFValueC _ _ WFV v T -> - WF_eqv_environment_P (insert _ (Some T) gamma, insert _ (Datatypes.length gamma') gamma') - (insert _ v gamma''). + Global Instance EQV_proj1_NP_Functor_eqv : + forall A B, + iPAlgebra EQV_proj1_Name (EQV_proj1_P A B) (NP_Functor_eqv _ _). Proof. - intros; destruct H as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]]. - unfold WF_eqv_environment_P; simpl in *|-*; repeat split. - rewrite <- WF_gamma2. - revert WF_gamma; clear; simpl; induction gamma'; - destruct m; simpl; intros; try discriminate. - injection H; intros; subst. - clear; induction gamma; simpl; eauto; eexists. - injection H; intros; subst. - generalize b (WF_gamma 0 _ (eq_refl _)); clear; induction gamma; simpl; intros b H; - destruct H as [T' lookup_T']; try discriminate. - destruct b; eauto. - eapply IHgamma'. - intros n0 b0 H0; eapply (WF_gamma (S n0) _ H0). - eassumption. - assert (exists m', Datatypes.length gamma' = m') as m'_eq - by (eexists _; reflexivity); destruct m'_eq as [m' m'_eq]. - rewrite m'_eq; generalize m' gamma' WF_gamma2; clear; induction gamma; - destruct gamma'; intros; simpl; try discriminate; - try injection H7; intros; eauto. - simpl in *|-*. - intro; caseEq (beq_nat m (Datatypes.length gamma')). - assert (exists m', m' = Datatypes.length gamma') as ex_m' by - (eexists _; reflexivity); destruct ex_m' as [m' m'_eq]; - rewrite <- m'_eq in H at 1. - rewrite <- WF_gamma2 in H1. - rewrite (beq_nat_true _ _ H). - rewrite (beq_nat_true _ _ H), m'_eq in H1. - rewrite <- WF_gamma2 in m'_eq; rewrite m'_eq. - generalize m' b H1; clear. - induction gamma'; simpl; intros; try discriminate. - injection H1; auto. - eauto. - eapply WF_gamma'. - rewrite <- WF_gamma2 in H1. - assert (exists m', m' = Datatypes.length gamma') as ex_m' by - (eexists _; reflexivity); destruct ex_m' as [m' m'_eq]. - generalize m' m (beq_nat_false _ _ H) H1; clear; - induction gamma'; simpl; destruct m; intros; - try discriminate; eauto. - elimtype False; eauto. - eapply P2_Env_insert. - eauto. - apply H0. - Qed. + intros; econstructor; unfold iAlgebra; intros. + eapply ind_alg_NP_Functor_eqv; unfold EQV_proj1_P; simpl; intros. + apply inject_i; econstructor; simpl; eauto. + rewrite H2; rewrite e_eq; eauto. + rewrite H3; rewrite e'_eq; eauto. + apply inject_i; econstructor 2; simpl; eauto. + rewrite H2; rewrite e_eq; eauto. + rewrite H3; rewrite e'_eq; eauto. + destruct a; destruct a'; apply IHa; auto. + apply inject_i; econstructor 3; simpl; eauto. + rewrite H2; rewrite e_eq; eauto. + rewrite H3; rewrite e'_eq; eauto. + destruct a; destruct a'; apply IHa; auto. + destruct b; destruct b'; apply IHb; auto. + apply inject_i; econstructor 4; simpl; eauto. + rewrite H2; rewrite e_eq; eauto. + rewrite H3; rewrite e'_eq; eauto. + destruct a; destruct a'; apply IHa; auto. + destruct b; destruct b'; apply IHb; auto. + destruct c; destruct c'; apply IHc; auto. + assumption. + Defined. - Section NP_beval_Soundness. + End eqv_Section. + + Variable EQV_E : forall A B, (@eqv_i A B -> Prop) -> eqv_i A B -> Prop. + Context {Fun_EQV_E : forall A B, iFunctor (EQV_E A B)}. + Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop. + Context {funWFV : iFunctor WFV}. + + Definition WF_eqv_environment_P (env_A_B : Env (typeofR D) * Env nat) gamma'' := + (forall m b : nat, + lookup (snd env_A_B) m = Some b -> + exists T, lookup (fst env_A_B) b = Some T) /\ + Datatypes.length (fst env_A_B) = Datatypes.length (snd env_A_B) /\ + (forall m b : nat, lookup (snd env_A_B) m = Some b -> b = m) /\ + WF_Environment _ _ WFV gamma'' (fst env_A_B). + + Definition eqv_eval_alg_Soundness'_P + (typeof_rec : Exp (E (typeofR D)) -> typeofR D) + (eval_rec : Exp (E nat) -> evalR V) + (typeof_F : Mixin (Exp (E (typeofR D))) (E (typeofR D)) (typeofR D)) + (eval_F : Mixin (Exp (E nat)) (E nat) (evalR V)) + i := + E_eqv EQV_E _ _ i /\ + eval_alg_Soundness_P D V (E nat) WFV + _ WF_eqv_environment_P + (E (typeofR D)) _ (env_A _ _ i, env_B _ _ i) typeof_rec eval_rec + typeof_F eval_F + (proj1_sig (eqv_a _ _ i), proj1_sig (eqv_b _ _ i)) + (conj (proj2_sig (eqv_a _ _ i)) (proj2_sig (eqv_b _ _ i))). + + Lemma WF_eqv_environment_P_insert : forall gamma gamma' gamma'' v T, + WF_eqv_environment_P (gamma, gamma') gamma'' -> + WFValueC _ _ WFV v T -> + WF_eqv_environment_P (insert _ (Some T) gamma, insert _ (Datatypes.length gamma') gamma') + (insert _ v gamma''). + Proof. + intros; destruct H as [WF_gamma [WF_gamma2 [WF_gamma' WF_gamma'']]]. + unfold WF_eqv_environment_P; simpl in *|-*; repeat split. + rewrite <- WF_gamma2. + revert WF_gamma; clear; simpl; induction gamma'; + destruct m; simpl; intros; try discriminate. + injection H; intros; subst. + clear; induction gamma; simpl; eauto; eexists. + injection H; intros; subst. + generalize b (WF_gamma 0 _ (eq_refl _)); clear; induction gamma; simpl; intros b H; + destruct H as [T' lookup_T']; try discriminate. + destruct b; eauto. + eapply IHgamma'. + intros n0 b0 H0; eapply (WF_gamma (S n0) _ H0). + eassumption. + assert (exists m', Datatypes.length gamma' = m') as m'_eq + by (eexists _; reflexivity); destruct m'_eq as [m' m'_eq]. + rewrite m'_eq; generalize m' gamma' WF_gamma2; clear; induction gamma; + destruct gamma'; intros; simpl; try discriminate; + try injection H7; intros; eauto. + simpl in *|-*. + intro; caseEq (beq_nat m (Datatypes.length gamma')). + assert (exists m', m' = Datatypes.length gamma') as ex_m' by + (eexists _; reflexivity); destruct ex_m' as [m' m'_eq]; + rewrite <- m'_eq in H at 1. + rewrite <- WF_gamma2 in H1. + rewrite (beq_nat_true _ _ H). + rewrite (beq_nat_true _ _ H), m'_eq in H1. + rewrite <- WF_gamma2 in m'_eq; rewrite m'_eq. + generalize m' b H1; clear. + induction gamma'; simpl; intros; try discriminate. + injection H1; auto. + eauto. + eapply WF_gamma'. + rewrite <- WF_gamma2 in H1. + assert (exists m', m' = Datatypes.length gamma') as ex_m' by + (eexists _; reflexivity); destruct ex_m' as [m' m'_eq]. + generalize m' m (beq_nat_false _ _ H) H1; clear; + induction gamma'; simpl; destruct m; intros; + try discriminate; eauto. + elimtype False; eauto. + eapply P2_Env_insert. + eauto. + apply H0. + Qed. + + Section NP_beval_Soundness. Variable (NP : Set -> Set). Context {Fun_NP : Functor NP}. @@ -607,6 +607,7 @@ Section PNames. iPAlgebra soundness_XName (soundness_X'_P typeof_rec eval_rec typeof_alg eval_alg) EQV_G. + Proof. intros; econstructor; generalize (ip_algebra); unfold iAlgebra; intros. unfold soundness_X'_P; intros. assert (EQV_G (eqv_eval_alg_Soundness'_P typeof_rec eval_rec typeof_alg eval_alg) i).