### WIP: subject reducion

parent 243b6bfd
Pipeline #131572321 failed with stage
in 7 minutes and 23 seconds
 ... ... @@ -330,3 +330,11 @@ Proof. try exact I; try reflexivity; try discriminate H12; try inversion H12; try (apply IHs1; auto). Qed. Lemma lexico_lt_diff s1 s2 : lexico_lt s1 s2 -> s1 <> s2. Proof. intros Hlt He. subst s2. apply lexico_irrefl in Hlt. assumption. Qed.
 Require Import Coq.Program.Equality. Require Import albert aux label_lexico typer. Require Import List. Require Import Lia. Hint Constructors typing_val. ... ... @@ -92,15 +93,518 @@ Proof. * apply H1; auto. inversion H2; auto. inversion H3; auto. inversion H4; auto. Qed. (** Subject reduction for function *) Theorem sr_f : forall f G E v v' ty ty', Lemma sr_f_empty : forall G f v v' ty ty', typing_f G f ty ty' -> typing_val G v ty -> eval_f E f v v' -> eval_f E_empty f v v' -> typing_val G v' ty'. Proof. intros arg G E v v' ty ty' Hf Hval Heval. induction Heval. intros g f v v' ty ty' Hf Hval Heval. destruct f. inversion Heval; subst. inversion H0. Qed. Lemma Join_singl_left : forall {A} l (v w : String.string * A), Join (v :: nil) l (w :: nil) -> l = nil /\ v = w. Proof. intros A l v w J. inversion J. - split; reflexivity. - inversion H3. - inversion H3. Qed. Lemma In_sorted_split {A} {lt : A -> A -> Prop} l a : Sorted.StronglySorted lt l -> In a l -> exists l1 l2, l = l1 ++ a :: l2 /\ (forall x, In x l1 -> lt x a) /\ (forall x, In x l2 -> lt a x). Proof. induction l as [|b l]. - simpl. intuition. - simpl. intro Hs. apply Sorted.StronglySorted_inv in Hs. destruct Hs as (Hs, Hf). rewrite Forall_forall in Hf. intros [He|Hin]. + subst b. exists nil. exists l. split; [reflexivity|]. split; [intuition|]. auto. + specialize (IHl Hs Hin). destruct IHl as (l1, (l2, (He, (Hlow, Hhigh)))). subst l. exists (b :: l1). exists l2. split; [reflexivity|]. split; intro x. * intros [He | Hinx]. -- subst x. apply Hf; assumption. -- auto. * auto. Qed. Lemma In_map_rev {A B} (f : A -> B) y l : In y (map f l) -> exists x, In x l /\ y = f x. Proof. induction l. - intro H. simpl in H. contradiction. - simpl. intros [He|Hin]. + exists a. intuition congruence. + specialize (IHl Hin). destruct IHl as (x, (Hx, He)). exists x. intuition. Qed. Lemma In_sorted_case {A} L l1 l2 (v1 v2 : A) f : Sorted.StronglySorted lexico_lt (map f L) -> (forall l v, f (l, v) = l) -> In (l1, v1) L -> In (l2, v2) L -> l1 <> l2 \/ (l1 = l2 /\ v1 = v2). Proof. induction L as [|(l, v) L]; simpl. - contradiction. - intros Hs Hf H1 H2. assert (Sorted.StronglySorted lexico_lt (map f L)) as Hs2 by (inversion Hs; assumption). destruct H1; destruct H2. + right; intuition congruence. + left. apply (in_map f) in H0. remember (map f L) as Lfst. rewrite Hf in H0. rewrite Hf in Hs. assert (Forall (lexico_lt l) Lfst) as HF by (inversion Hs; assumption). rewrite Forall_forall in HF. specialize (HF l2 H0). apply lexico_lt_diff in HF. congruence. + left. apply (in_map f) in H. remember (map f L) as Lfst. rewrite Hf in H. rewrite Hf in Hs. assert (Forall (lexico_lt l) Lfst) as HF by (inversion Hs; assumption). rewrite Forall_forall in HF. specialize (HF l1 H). apply lexico_lt_diff in HF. congruence. + apply IHL; assumption. Qed. Lemma map_ext {A B} (f g : A -> B) l : (forall x, f x = g x) -> map f l = map g l. Proof. intro Hext. induction l; simpl. - reflexivity. - rewrite Hext. rewrite IHl. reflexivity. Qed. Lemma Join_nil_right {A} (l l' : list (String.string * A)) : Join l nil l' -> l = l'. Proof. intro H. inversion H; reflexivity. Qed. Lemma Join_nil_left {A} (l l' : list (String.string * A)) : Join nil l l' -> l = l'. Proof. intro H. inversion H; reflexivity. Qed. Lemma Join_length {A} (l l' l'' : list (String.string * A)) : Join l l' l'' -> length l'' = length l + length l'. Proof. intro H; induction H; simpl. - apply plus_n_O. - reflexivity. - simpl in *. f_equal. assumption. - simpl in *. f_equal. rewrite IHJoin. apply plus_n_Sm. Qed. Lemma add_n_m_n n m : n = n + m -> m = 0. Proof. induction n; simpl. - auto. - intro H. injection H. auto. Qed. Lemma typing_record_length : forall (G : g) (lv : list (label * value)) (lt : list (label * ty)), typing_val G (val_rval (rval_record lv)) (ty_rty (rty_record lt)) -> length lv = length lt. Proof. intros G lv lt H. inversion H. rewrite map_length. rewrite map_length. reflexivity. Qed. Lemma Join_cons_inv {A} (L1 L2 L3 : list (String.string * A)) lv : Join L1 L2 (lv :: L3) -> (exists tl, L1 = lv :: tl /\ Join tl L2 L3) \/ (exists tl, L2 = lv :: tl /\ Join L1 tl L3). Proof. intro H; inversion H. - subst. left; exists L3. repeat constructor. - subst. right; exists L3. repeat constructor. - subst. left. exists v1. auto. - subst. right. exists v2. auto. Qed. Lemma Join_cons_cons_inv {A} (L1 L2 L3 : list (String.string * A)) l v1 v2 : Join ((l, v1) :: L1) L2 ((l, v2) :: L3) -> (v1 = v2 /\ Join L1 L2 L3). Proof. intro H. inversion H; subst; split; try reflexivity; try constructor; try assumption. - apply lexico_lt_diff in H8. congruence. - apply lexico_lt_diff in H8. congruence. Qed. Lemma typing_record_join G : forall vs vs' vs'', Join vs vs' vs'' -> forall tys tys' tys'', Join tys tys' tys'' -> typing_val G (val_rval (rval_record vs)) (ty_rty (rty_record tys)) -> typing_val G (val_rval (rval_record vs')) (ty_rty (rty_record tys')) -> typing_val G (val_rval (rval_record vs'')) (ty_rty (rty_record tys'')). Proof. intros vs vs' vs'' HJv; induction HJv; intros tys tys' tys'' HJt Hv Hv'. - apply typing_record_nil_inv_l in Hv'. subst tys'. apply Join_nil_right in HJt. subst tys''. exact Hv. - apply typing_record_nil_inv_l in Hv. subst tys. apply Join_nil_left in HJt. subst tys''. exact Hv'. - generalize (typing_record_cons_ex_l G _ _ _ _ Hv). intros (ty, (tystl, He)); subst tys; rename tystl into tys. generalize (typing_record_cons_ex_l G _ _ _ _ Hv'). intros (ty', (tys'tl, He)); subst tys'; rename tys'tl into tys'. inversion HJt. + subst. apply typing_record_cons_inv in Hv. destruct Hv as (Ht1, Hv). apply typing_record_cons_inv in Hv'. destruct Hv' as (Ht2, Hv'). apply typing_record_cons; try assumption. apply (IHHJv tys ((l2, ty') :: tys')); try assumption. apply typing_record_cons; assumption. + apply lexico_antirefl in H; contradiction. - generalize (typing_record_cons_ex_l G _ _ _ _ Hv). intros (ty, (tystl, He)); subst tys; rename tystl into tys. generalize (typing_record_cons_ex_l G _ _ _ _ Hv'). intros (ty', (tys'tl, He)); subst tys'; rename tys'tl into tys'. inversion HJt. + apply lexico_antirefl in H; contradiction. + subst. apply typing_record_cons_inv in Hv. destruct Hv as (Ht1, Hv). apply typing_record_cons_inv in Hv'. destruct Hv' as (Ht2, Hv'). apply typing_record_cons; try assumption. apply (IHHJv ((l1, ty) :: tys) tys'); try assumption. apply typing_record_cons; assumption. Qed. Lemma typing_record_in G : forall vs tys, (forall l v ty, In (l, v) vs -> In (l, ty) tys -> typing_val G v ty) -> map (fun '(l, _) => l) vs = map (fun '(l, _) => l) tys -> typing_val G (val_rval (rval_record vs)) (ty_rty (rty_record tys)). Proof. induction vs as [|(l, v) vs]. - intros tys Hin Hmap. destruct tys; [|simpl in Hmap; discriminate]. apply typing_record_nil. - intros tys Hin Hmap. destruct tys as [|(l', ty) tys]; [simpl in Hmap; discriminate|]. simpl in Hmap. injection Hmap; clear Hmap; intros Hl Hmap. subst l'. apply typing_record_cons. + apply (Hin l); left; reflexivity. + apply IHvs. * intros l' v' ty' Hv Hty. apply (Hin l'); right; assumption. * assumption. Qed. Lemma typing_record_in_inv G : forall vs tys, typing_val G (val_rval (rval_record vs)) (ty_rty (rty_record tys)) -> Sorted.StronglySorted lexico_lt (map (fun '(l, _) => l) tys) -> (forall l v ty, In (l, v) vs -> In (l, ty) tys -> typing_val G v ty) /\ map (fun '(l, _) => l) vs = map (fun '(l, _) => l) tys. Proof. induction vs as [|(l, v) vs]; intros tys Hval Hwf; split. - intros l v ty Hin. inversion Hin. - apply typing_record_nil_inv_l in Hval. subst tys. reflexivity. - intros l' v' ty' [He|Htl]. + injection He; clear He; intros; subst. generalize (typing_record_cons_ex_l _ _ _ _ _ Hval). intros (ty'', (lts, He)). subst tys; rename lts into tys. apply (Sorted_not_In l' ty' ty') in Hwf. destruct H1; [|contradiction]. injection H; intros; subst. apply typing_record_cons_inv in Hval; destruct Hval; assumption. + intro Hin_ty. generalize (typing_record_cons_ex_l _ _ _ _ _ Hval). intros (ty'', (lts, He)). subst tys; rename lts into tys. specialize (IHvs tys). apply typing_record_cons_inv in Hval. destruct Hval as (Hv, Hval). specialize (IHvs Hval). simpl in Hwf; inversion Hwf. specialize (IHvs H1). destruct IHvs as (IH, Hmap). apply (IH l'). * assumption. * destruct Hin_ty. -- subst. exfalso. apply (in_map (fun '(l, _) => l)) in Htl. rewrite Hmap in Htl. rewrite Forall_forall in H2. specialize (H2 l' Htl). injection H3; intros; subst. apply lexico_lt_diff in H2. auto. -- subst. assumption. - generalize (typing_record_cons_ex_l _ _ _ _ _ Hval). intros (ty'', (lts, He)). subst tys; rename lts into tys. specialize (IHvs tys). apply typing_record_cons_inv in Hval. destruct Hval as (Hv, Hval). specialize (IHvs Hval). simpl in Hwf; inversion Hwf. specialize (IHvs H1). destruct IHvs as (IH, Hmap). subst. simpl. f_equal. assumption. Qed. (* Subject reduction for rhs depends on subject reduction for functions *) Lemma sr_f_rhs : forall G E, (forall f v v' ty ty', typing_f G f ty ty' -> typing_val G v ty -> eval_f E f v v' -> typing_val G v' ty') -> (forall r v v' ty ty', typing_rhs G r ty ty' -> typing_val G v ty -> eval_rhs E r v v' -> typing_val G v' ty'). Proof. intros G E sr_f r v v' ty ty' Hr Hval Heval. destruct r; inversion Hr; inversion Heval; subst. - (* arg *) eapply sr_arg; eassumption. - (* app *) assert (typing_val G val' ty'0). + eapply sr_arg; eassumption. + eapply sr_f; eassumption. - (* record projection r.l --> v : ty when r : tys --> vs, vs.l = v : ty r = l @ r'; vs = l @ vs' *) rename var into r. rename v' into v. rename ty' into ty. rename rval' into vs. rename rty' into tys. rename rty5 into r'. rename rval5 into vs'. clear E sr_f Hr Heval. rename H2 into H_Join_ty. rename H11 into H_Join_val. rename H5 into HWF. destruct r' as [r']. destruct tys as [tys]. destruct vs' as [vs']. destruct vs as [vs]. apply typing_record_cons_inv in Hval. destruct Hval as (Hvs, _). apply Join_In_l_cons in H_Join_val; clear vs'. apply Join_In_l_cons in H_Join_ty; clear r'. inversion HWF; subst. clear HWF H1 H3. rename H0 into Hsorted. inversion Hvs; subst. rename H2 into Hin_ty. apply Hin_ty; clear Hin_ty. induction l__val__ty__list as [|((l', v'), ty') L]; simpl in *. * contradiction. * destruct H_Join_ty as [He|Hin_ty]. -- injection He; intros; subst; clear He. destruct H_Join_val as [He|Hin_val]. ++ left; congruence. ++ exfalso. apply (lexico_lt_diff l l); [|reflexivity]. assert (Forall (lexico_lt l) (map (fun pat_ : label * albert.ty => let (l__, _) := pat_ in l__) (map (fun pat_ : label * value * albert.ty => let (p, ty__) := pat_ in let (l__, _) := p in (l__, ty__)) L))) as Hlt by (inversion Hsorted; assumption). rewrite Forall_forall in Hlt. apply Hlt; clear Hlt. rewrite map_map. apply (in_map (fun '(l, _) => l)) in Hin_val. simpl in Hin_val. rewrite map_map in Hin_val. erewrite map_ext; [apply Hin_val|intros ((l'', v''), ty'); reflexivity]. -- destruct H_Join_val as [He|Hin_val]. ++ exfalso. injection He; intros; subst; clear He. apply (lexico_lt_diff l l); [|reflexivity]. assert (Forall (lexico_lt l) (map (fun pat_ : label * albert.ty => let (l__, _) := pat_ in l__) (map (fun pat_ : label * value * albert.ty => let (p, ty__) := pat_ in let (l__, _) := p in (l__, ty__)) L))) as Hlt by (inversion Hsorted; assumption). rewrite Forall_forall in Hlt. apply Hlt; clear Hlt. rewrite map_map. apply (in_map (fun '(l, _) => l)) in Hin_ty. simpl in Hin_ty. rewrite map_map in Hin_ty. erewrite map_ext; [apply Hin_ty|intros ((l', v'), ty''); reflexivity]. ++ right. apply typing_record_cons_inv in Hvs; destruct Hvs as (Hval, Hrval). inversion Hsorted. apply IHL; assumption. - (* record update { r with ls = xs } r : { ls : bs } @ ({ labs : as } = a) @ = tys r --> { ls = vbs } @ ({ labs = vas } = lvas) = vs xs --> vbs' { r with ls = xs } : tys --> ({ls = vbs'} @ { labs = vas }) = vs' *) rename var into r. rename rty' into tys. destruct rval' as [vs]. destruct rval'' as [vs']. destruct rty5 as [a]. destruct tys as [tys]. destruct rval5 as [lvas]. simpl in *. apply typing_record_cons_inv in Hval. destruct Hval as (Hvs, Hval). do 2 rewrite app_nil_r in *. clear Heval Hr r E sr_f. refine (typing_record_join G _ _ _ H12 _ _ _ H5 _ _). + apply typing_record_in. * intros l v ty. intros Hinv Hinty. apply In_map_rev in Hinv; simpl in Hinv. destruct Hinv as ((((l', var), val), val'), (Hinv, He)). injection He; clear He; intros; subst. apply In_map_rev in Hinty; simpl in Hinty. destruct Hinty as (((l'', var'), ty'), (Hinty, He)). injection He; clear He; intros; subst. assert (var = var'). -- apply (in_map (fun pat_ : label * label * value * value => let (p, _) := pat_ in let (p0, _) := p in let (l__, var__) := p0 in (l__, var__))) in Hinv. rewrite H7 in Hinv. apply (in_map (fun pat_ : label * label * ty => let (p, _) := pat_ in let (l__, var__) := p in (l__, var__))) in Hinty. remember (map (fun pat_ : label * label * ty => let (p, _) := pat_ in let (l__, var__) := p in (l__, var__)) l__var__ty__list) as L. generalize (In_sorted_case L l'' l'' var var' (fun '(l, _) => l)). intro Hcase. refine (match (Hcase _ _ _ _) with or_introl HN => False_rect _ (HN eq_refl) | or_intror (conj _ H) => H end). ++ subst L. rewrite map_map. inversion H2. Admitted. (** Subject reduction for function, right-hand sides, and instructions *) Theorem sr_f_rhs_i : forall G E, (forall f v v' ty ty', typing_f G f ty ty' -> typing_val G v ty -> eval_f E f v v' -> typing_val G v' ty') /\ (forall r v v' ty ty', typing_rhs G r ty ty' -> typing_val G v ty -> eval_rhs E r v v' -> typing_val G v' ty') /\ (forall i v v' ty ty', typing_instr G i ty ty' -> typing_val G v ty -> eval_instr E i v v' -> typing_val G v' ty'). Proof. intro G; induction E. - split; [|split]. + apply sr_f_empty. + apply sr_f_rhs. apply sr_f_empty. + admit. - split; [|split]. Admitted. Lemma wf_record_cons_inv : forall G lt l ty, ... ...
 ... ... @@ -251,7 +251,7 @@ by { l : ty } @ rty = rty' g |- rty' ------------------------------------- :: projection g |- var . l : rty' => ty g |- var . l : { var : rty' } => ty g |- rty' { l_1 : ty_1 ; .. ; l_n : ty_n } @ rty = rty' ... ... @@ -312,7 +312,7 @@ defns { l = val } @ rval = rval' ----------------------------------------- :: projection E |- var.l / rval' -> val E |- var.l / { var = rval' } -> val { l_1 = val'_1 ; .. ; l_n = val'_n } @ rval = rval' { l_1 = val_1 ; .. ; l_n = val_n } @ rval = rval'' ... ...
 ... ... @@ -25,7 +25,8 @@ g :: 'g_' ::= {{tex \Gamma}} {{com Typing context (for inlined definitions)}} | g , tvar = ty :: :: typedef E :: 'E_' ::= {{com Semantic context (for function definitions)}} | E, fvar = instruction :: :: fdef | . :: :: empty | E , fvar = instruction :: :: fdef formula :: 'formula_' ::= | tvar != tvar' :: :: tvardiff {{coq [[tvar]] <> [[tvar']]}} ... ...
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment