### Major simplification of F_mu logrel.

parent 0f96e059
 ... @@ -5,6 +5,8 @@ From iris.algebra Require Export upred_big_op. ... @@ -5,6 +5,8 @@ From iris.algebra Require Export upred_big_op. Section typed_interp. Section typed_interp. Context {Σ : iFunctor}. Context {Σ : iFunctor}. Notation D := (valC -n> iProp lang Σ). Implicit Types Δ : listC D. Local Tactic Notation "smart_wp_bind" uconstr(ctx) ident(v) constr(Hv) uconstr(Hp) := Local Tactic Notation "smart_wp_bind" uconstr(ctx) ident(v) constr(Hv) uconstr(Hp) := iApply (@wp_bind _ _ _ [ctx]); iApply (@wp_bind _ _ _ [ctx]); ... @@ -14,21 +16,20 @@ Section typed_interp. ... @@ -14,21 +16,20 @@ Section typed_interp. Local Ltac value_case := iApply wp_value; cbn; rewrite ?to_of_val; trivial. Local Ltac value_case := iApply wp_value; cbn; rewrite ?to_of_val; trivial. Lemma typed_interp (Δ : varC -n> valC -n> iProp lang Σ) Γ vs e τ Lemma typed_interp Δ Γ vs e τ (HΔ : ctx_PersistentP Δ) : (HΔ : ∀ x v, PersistentP (Δ x v)) : Γ ⊢ₜ e : τ → Γ ⊢ₜ e : τ → length Γ = length vs → length Γ = length vs → [∧] zip_with (λ τ, interp τ Δ) Γ vs ⊢ WP e.[env_subst vs] {{ interp τ Δ }}. [∧] zip_with (λ τ, interp τ Δ) Γ vs ⊢ WP e.[env_subst vs] {{ interp τ Δ }}. Proof. Proof. intros Htyped. revert Δ HΔ vs. intros Htyped. revert Δ HΔ vs. induction Htyped; iIntros {Δ HΔ vs Hlen} "#HΓ"; cbn. induction Htyped; iIntros {Δ HΔ vs Hlen} "#HΓ"; cbn. - (* var *) - (* var *) destruct (lookup_lt_is_Some_2 vs x) as [v Hv]. destruct (lookup_lt_is_Some_2 vs x) as [v Hv]. { by rewrite -Hlen; apply lookup_lt_Some with τ. } { by rewrite -Hlen; apply lookup_lt_Some with τ. } rewrite /env_subst Hv; value_case. rewrite /env_subst Hv; value_case. iApply (big_and_elem_of with "HΓ"). iApply (big_and_elem_of with "HΓ"). apply elem_of_list_lookup_2 with x. apply elem_of_list_lookup_2 with x. rewrite lookup_zip_with; simplify_option_eq; trivial. rewrite lookup_zip_with; by simplify_option_eq. - (* unit *) value_case. - (* unit *) value_case. - (* pair *) - (* pair *) smart_wp_bind (PairLCtx e2.[env_subst vs]) v "# Hv" IHHtyped1. smart_wp_bind (PairLCtx e2.[env_subst vs]) v "# Hv" IHHtyped1. ... @@ -70,35 +71,29 @@ Section typed_interp. ... @@ -70,35 +71,29 @@ Section typed_interp. iApply wp_mono; [|iApply "Hv"]; auto. iApply wp_mono; [|iApply "Hv"]; auto. - (* TLam *) - (* TLam *) value_case. value_case. iIntros { τi } "! %". iApply wp_TLam; iNext; simpl in *. iAlways; iIntros { τi } "%". iApply wp_TLam; iNext. simpl in *. iApply (IHHtyped (extend_context_interp_fun1 τi Δ)); [rewrite map_length|]; trivial. iApply (IHHtyped (τi :: Δ)). by rewrite fmap_length. by iDestruct (zip_with_context_interp_subst with "HΓ") as "?". rewrite zip_with_fmap_l. by iApply context_interp_ren_S. - (* TApp *) - (* TApp *) smart_wp_bind TAppCtx v "#Hv" IHHtyped; cbn. smart_wp_bind TAppCtx v "#Hv" IHHtyped; cbn. iApply wp_wand_r; iSplitL; [iApply ("Hv" \$! (interp τ' Δ)); iPureIntro; apply _|]. iApply wp_wand_r; iSplitL; [iApply ("Hv" \$! (interp τ' Δ)); iPureIntro; apply _|]. iIntros{w} "?". by rewrite interp_subst. iIntros {w} "?". by rewrite interp_subst. - (* Fold *) - (* Fold *) rewrite map_length in IHHtyped. rewrite map_length in IHHtyped. iApply (@wp_bind _ _ _ [FoldCtx]). iApply (@wp_bind _ _ _ [FoldCtx]). iApply wp_wand_l. iApply wp_wand_l. iSplitL; [|iApply (IHHtyped (extend_context_interp ((interp (TRec τ)) Δ) Δ)); iSplitL; [|iApply (IHHtyped (interp (TRec τ) Δ :: Δ)); trivial]. trivial]. + iIntros {v} "#Hv". value_case. + iIntros {v} "#Hv". value_case. change (fixpoint _) with (interp (TRec τ) Δ) at 1; trivial. change (fixpoint _) with (interp (TRec τ) Δ) at 1; trivial. rewrite fixpoint_unfold; cbn. rewrite fixpoint_unfold /=. iAlways; eauto 10. iAlways; eauto. + rewrite zip_with_fmap_l. by iApply context_interp_ren_S. + by iDestruct (zip_with_context_interp_subst with "HΓ") as "?". - (* Unfold *) - (* Unfold *) iApply (@wp_bind _ _ _ [UnfoldCtx]); iApply (@wp_bind _ _ _ [UnfoldCtx]); iApply wp_wand_l; iSplitL; [|iApply IHHtyped; trivial]. iApply wp_wand_l; iSplitL; [|iApply IHHtyped; trivial]. iIntros {v}. iIntros {v} "#Hv". rewrite /= fixpoint_unfold. cbn [interp interp_rec cofe_mor_car]. change (fixpoint _) with (interp (TRec τ) Δ); simpl. rewrite fixpoint_unfold. iDestruct "Hv" as {w} "#[% Hw]"; subst. iIntros "#Hv"; cbn. change (fixpoint _) with (interp (TRec τ) Δ). iDestruct "Hv" as {w} "[% #Hw]"; rewrite H. iApply wp_Fold; cbn; auto using to_of_val. iApply wp_Fold; cbn; auto using to_of_val. rewrite -interp_subst; trivial. by rewrite -interp_subst. Qed. Qed. End typed_interp. End typed_interp.
This diff is collapsed.
 ... @@ -2,34 +2,22 @@ From iris_logrel.F_mu Require Export fundamental. ... @@ -2,34 +2,22 @@ From iris_logrel.F_mu Require Export fundamental. From iris.proofmode Require Import tactics. From iris.proofmode Require Import tactics. From iris.program_logic Require Import adequacy. From iris.program_logic Require Import adequacy. Section Soundness. Section soundness. Let Σ := #[]. Let Σ := #[]. Lemma empty_env_subst e : e.[env_subst []] = e. Proof. change (env_subst []) with (@ids expr _). by asimpl. Qed. Definition free_type_context : varC -n> valC -n> iProp lang (globalF Σ) := λne x y, True%I. Lemma wp_soundness e τ : Lemma wp_soundness e τ : [] ⊢ₜ e : τ → True ⊢ WP e {{ @interp (globalF Σ) τ free_type_context }}. [] ⊢ₜ e : τ → True ⊢ WP e {{ @interp (globalF Σ) τ [] }}. Proof. Proof. iIntros {H} "". rewrite -(empty_env_subst e). iIntros {H} "". rewrite -(empty_env_subst e). by iApply (@typed_interp _ _ _ []). by iApply (@typed_interp _ _ _ []). Qed. Qed. Theorem Soundness e τ : Theorem soundness e τ e' thp : [] ⊢ₜ e : τ → [] ⊢ₜ e : τ → rtc step ([e], ()) (e' :: thp, ()) → ∀ e' thp, rtc step ([e], tt) (e' :: thp, tt) → is_Some (to_val e') ∨ reducible e' (). ¬ reducible e' tt → is_Some (to_val e'). Proof. Proof. intros H1 e' thp Hstp Hnr. intros ??. eapply wp_adequacy_reducible; eauto using ucmra_unit_valid. eapply wp_soundness in H1; eauto. - iIntros "H". by iApply wp_soundness. edestruct (@wp_adequacy_reducible lang (globalF Σ) ⊤ (interp τ free_type_context) e e' (e' :: thp) tt ∅) as [Ha|Ha]; eauto using ucmra_unit_valid; try tauto. - iIntros "H". iApply H1. - constructor. - constructor. Qed. Qed. End Soundness. End soundness.
 ... @@ -30,25 +30,22 @@ Inductive typed (Γ : list type) : expr → type → Prop := ... @@ -30,25 +30,22 @@ Inductive typed (Γ : list type) : expr → type → Prop := Γ ⊢ₜ Case e0 e1 e2 : ρ Γ ⊢ₜ Case e0 e1 e2 : ρ | Lam_typed e τ1 τ2 : τ1 :: Γ ⊢ₜ e : τ2 → Γ ⊢ₜ Lam e : TArrow τ1 τ2 | Lam_typed e τ1 τ2 : τ1 :: Γ ⊢ₜ e : τ2 → Γ ⊢ₜ Lam e : TArrow τ1 τ2 | App_typed e1 e2 τ1 τ2 : Γ ⊢ₜ e1 : TArrow τ1 τ2 → Γ ⊢ₜ e2 : τ1 → Γ ⊢ₜ App e1 e2 : τ2 | App_typed e1 e2 τ1 τ2 : Γ ⊢ₜ e1 : TArrow τ1 τ2 → Γ ⊢ₜ e2 : τ1 → Γ ⊢ₜ App e1 e2 : τ2 | TLam_typed e τ : map (λ t, t.[ren (+1)]) Γ ⊢ₜ e : τ → Γ ⊢ₜ TLam e : TForall τ | TLam_typed e τ : subst (ren (+1)) <\$> Γ ⊢ₜ e : τ → Γ ⊢ₜ TLam e : TForall τ | TApp_typed e τ τ' : Γ ⊢ₜ e : TForall τ → Γ ⊢ₜ TApp e : τ.[τ'/] | TApp_typed e τ τ' : Γ ⊢ₜ e : TForall τ → Γ ⊢ₜ TApp e : τ.[τ'/] | TFold e τ : map (λ t, t.[ren (+1)]) Γ ⊢ₜ e : τ → Γ ⊢ₜ Fold e : TRec τ | TFold e τ : subst (ren (+1)) <\$> Γ ⊢ₜ e : τ → Γ ⊢ₜ Fold e : TRec τ | TUnfold e τ : Γ ⊢ₜ e : TRec τ → Γ ⊢ₜ Unfold e : τ.[TRec τ/] | TUnfold e τ : Γ ⊢ₜ e : TRec τ → Γ ⊢ₜ Unfold e : τ.[TRec τ/] where "Γ ⊢ₜ e : τ" := (typed Γ e τ). where "Γ ⊢ₜ e : τ" := (typed Γ e τ). Local Hint Extern 1 => match goal with | H : context [length (map _ _)] |- _ => rewrite map_length in H end : typed_subst_invariant. Lemma typed_subst_invariant Γ e τ s1 s2 : Lemma typed_subst_invariant Γ e τ s1 s2 : Γ ⊢ₜ e : τ → (∀ x, x < length Γ → s1 x = s2 x) → e.[s1] = e.[s2]. Γ ⊢ₜ e : τ → (∀ x, x < length Γ → s1 x = s2 x) → e.[s1] = e.[s2]. Proof. Proof. intros Htyped; revert s1 s2. intros Htyped; revert s1 s2. assert (∀ {A} `{Ids A} `{Rename A} assert (∀ x Γ, x < length (subst (ren (+1)) <\$> Γ) → x < length Γ). (s1 s2 : nat → A) x, (x ≠ 0 → s1 (pred x) = s2 (pred x)) → up s1 x = up s2 x). { intros ??. by rewrite fmap_length. } assert (∀ {A} `{Ids A} `{Rename A} (s1 s2 : nat → A) x, (x ≠ 0 → s1 (pred x) = s2 (pred x)) → up s1 x = up s2 x). { intros A H1 H2. rewrite /up=> s1 s2 [|x] //=; auto with f_equal omega. } { intros A H1 H2. rewrite /up=> s1 s2 [|x] //=; auto with f_equal omega. } induction Htyped => s1 s2 Hs; f_equal/=; eauto using lookup_lt_Some with omega typed_subst_invariant. induction Htyped => s1 s2 Hs; f_equal/=; eauto using lookup_lt_Some with omega. Qed. Qed. Definition env_subst (vs : list val) (x : var) : expr := Definition env_subst (vs : list val) (x : var) : expr := ... @@ -58,27 +55,11 @@ Lemma typed_subst_head_simpl Δ τ e w ws : ... @@ -58,27 +55,11 @@ Lemma typed_subst_head_simpl Δ τ e w ws : Δ ⊢ₜ e : τ → length Δ = S (length ws) → Δ ⊢ₜ e : τ → length Δ = S (length ws) → e.[# w .: env_subst ws] = e.[env_subst (w :: ws)]. e.[# w .: env_subst ws] = e.[env_subst (w :: ws)]. Proof. Proof. intros H1 H2. intros H1 H2. rewrite /env_subst. rewrite /env_subst. eapply typed_subst_invariant; eauto=> /= -[|x] ? //=. eapply typed_subst_invariant; eauto=> /= -[|x] ? //=. destruct (lookup_lt_is_Some_2 ws x) as [v' Hv]; first omega; simpl. destruct (lookup_lt_is_Some_2 ws x) as [v' ?]; first omega. by rewrite Hv. by simplify_option_eq. Qed. Qed. Local Opaque eq_nat_dec. Lemma empty_env_subst e : e.[env_subst []] = e. Proof. change (env_subst []) with (@ids expr _). by asimpl. Qed. Lemma iter_up_subst_type (m : nat) (τ : type) (x : var) : iter m up (τ .: ids) x = if lt_dec x m then ids x else if eq_nat_dec x m then τ.[ren (+m)] else ids (x - 1). Proof. revert x τ. induction m; intros x τ; cbn. - destruct x; cbn. + destruct eq_nat_dec; auto with omega. asimpl; trivial. + destruct eq_nat_dec; auto with omega. - destruct x; asimpl; trivial. rewrite IHm. repeat destruct lt_dec; repeat destruct eq_nat_dec; asimpl; auto with omega. Qed.
 ... @@ -167,7 +167,7 @@ Proof. ... @@ -167,7 +167,7 @@ Proof. Qed. Qed. Lemma n_closed_subst_head_simpl n e w ws : Lemma n_closed_subst_head_simpl n e w ws : (∀ f, e.[iter n up f] = e) -> (∀ f, e.[iter n up f] = e) → S (length ws) = n → S (length ws) = n → e.[# w .: env_subst ws] = e.[env_subst (w :: ws)]. e.[# w .: env_subst ws] = e.[env_subst (w :: ws)]. Proof. Proof. ... @@ -188,7 +188,7 @@ Proof. ... @@ -188,7 +188,7 @@ Proof. Qed. Qed. Lemma n_closed_subst_head_simpl_2 n e w w' ws : Lemma n_closed_subst_head_simpl_2 n e w w' ws : (∀ f, e.[iter n up f] = e) -> (S (S (length ws))) = n → (∀ f, e.[iter n up f] = e) → (S (S (length ws))) = n → e.[# w .: # w' .: env_subst ws] = e.[env_subst (w :: w' :: ws)]. e.[# w .: # w' .: env_subst ws] = e.[env_subst (w :: w' :: ws)]. Proof. Proof. intros H1 H2. intros H1 H2. ... ...
 From iris.algebra Require Export base. From iris.algebra Require Export base. From iris.algebra Require Import cofe. From iris.algebra Require Import upred. From iris.program_logic Require Import weakestpre. From Autosubst Require Export Autosubst. From Autosubst Require Export Autosubst. Import uPred. Canonical Structure varC := leibnizC var. Canonical Structure varC := leibnizC var. ... @@ -22,3 +24,19 @@ Section Autosubst_Lemmas. ... @@ -22,3 +24,19 @@ Section Autosubst_Lemmas. repeat (case_match || asimpl || rewrite IH); auto with omega. repeat (case_match || asimpl || rewrite IH); auto with omega. Qed. Qed. End Autosubst_Lemmas. End Autosubst_Lemmas. Ltac properness := repeat match goal with | |- (∃ _: _, _)%I ≡ (∃ _: _, _)%I => apply exist_proper =>? | |- (∀ _: _, _)%I ≡ (∀ _: _, _)%I => apply forall_proper =>? | |- (_ ∧ _)%I ≡ (_ ∧ _)%I => apply and_proper | |- (_ ∨ _)%I ≡ (_ ∨ _)%I => apply or_proper | |- (_ → _)%I ≡ (_ → _)%I => apply impl_proper | |- (WP _ {{ _ }})%I ≡ (WP _ {{ _ }})%I => apply wp_proper =>? | |- (▷ _)%I ≡ (▷ _)%I => apply later_proper | |- (□ _)%I ≡ (□ _)%I => apply always_proper end. Ltac solve_proper_alt := repeat intro; (simpl + idtac); by repeat match goal with H : _ ≡{_}≡ _|- _ => rewrite H end. \ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!