diff --git a/cosn.v b/cosn.v index 4b75918..e2506a2 100644 --- a/cosn.v +++ b/cosn.v @@ -9,6 +9,7 @@ Require Import Psatz. From stdpp Require Import relations (rtc (..), rtc_once, rtc_r, sn). From Hammer Require Import Tactics. Require Import Autosubst2.core Autosubst2.unscoped Autosubst2.syntax common fp_red. +Require Import Btauto. Fixpoint nostuck (a : PTm) := match a with @@ -20,18 +21,19 @@ Fixpoint nostuck (a : PTm) := | PProj _ a => (ishf a ==> ispair a) && nostuck a | PZero => true | PSuc a => nostuck a - | PInd P a b c => (ishf a ==> iszero a || issuc a) && nostuck b && nostuck c + | PInd P a b c => nostuck P && (ishf a ==> iszero a || issuc a) && nostuck b && nostuck c | PNat => true | PUniv _ => true end. CoInductive safe a : Prop := - safe_intro {safe_ok : nostuck a; safe_red : forall b,RRed.R a b -> safe b}. + safe_intro : + nostuck a -> + (forall b,RRed.R a b -> safe b) -> + safe a. Arguments safe_intro {a}. -Arguments safe_ok {a}. -Arguments safe_red {a}. Lemma safe_coind P : (forall a, P a -> nostuck a /\ (forall b, RRed.R a b -> P b)) -> forall a, P a -> safe a. move => h. @@ -42,3 +44,64 @@ Lemma safe_coind P : (forall a, P a -> nostuck a /\ (forall b, RRed.R a b -> P apply ha0. move => b hb. apply ha1 in hb. apply ih. apply hb. Qed. + +Lemma safe_app_inv0 : forall a b, safe (PApp a b) -> safe a. +Proof. + suff : forall a, (exists b, safe (PApp a b)) -> safe a by firstorder. + apply safe_coind. + sauto lqb:on. +Qed. + +Lemma safe_app_inv1 : forall a b, safe (PApp a b) -> safe b. +Proof. + suff : forall b, (exists a, safe (PApp a b)) -> safe b by firstorder. + apply safe_coind. + sauto lqb:on. +Qed. + +Lemma safe_abs_inv : forall a, safe (PAbs a) -> safe a. +Proof. + apply safe_coind. + sauto lqb:on. +Qed. + +Lemma nostuck_antisubstitution : forall ρ a, nostuck (subst_PTm ρ a) -> nostuck a. +Proof. + suff : forall (ρ : nat -> PTm) (a : PTm), nostuck (subst_PTm ρ a) ==> nostuck a by sauto lqb:on. + move => /[swap]. elim => //=. + - move => *. rewrite !Bool.implb_orb /is_true. btauto. + - move => b ihb a iha ρ. + move /(_ ρ) : ihb. apply /implyP. + move /(_ ρ) : iha. apply /implyP. + case : b => //= *; rewrite /is_true !Bool.implb_orb; btauto. + - move => a iha b ihb ρ. + move /(_ ρ) : ihb. apply /implyP. + move /(_ ρ) : iha. apply /implyP. + rewrite /is_true !Bool.implb_orb; btauto. + - move => p u hu ρ. + move /(_ ρ) : hu. apply /implyP. + case : u => //= *; rewrite /is_true !Bool.implb_orb; btauto. + - move => _ a iha b ihb ρ. + move /(_ (up_PTm_PTm ρ)) : ihb. apply /implyP. + move /(_ ρ) : iha. apply /implyP. + rewrite /is_true !Bool.implb_orb; btauto. + - move => P ihP a iha b ihb c ihc ρ. + move /(_ (up_PTm_PTm ρ)) : ihP. apply /implyP. + move /(_ ρ) : iha. apply /implyP. + move /(_ ρ) : ihb. apply /implyP. + move /(_ (up_PTm_PTm (up_PTm_PTm ρ))) : ihc. apply /implyP. + case : a => //= *; rewrite /is_true !Bool.implb_orb; btauto. +Qed. + +Lemma safe_antisubstitution : forall ρ a, safe (subst_PTm ρ a) -> safe a. +Proof. + suff : forall a, (exists ρ, safe (subst_PTm ρ a)) -> safe a by firstorder. + apply safe_coind. + move => a [ρ ha]. + split. + have {}ha : nostuck (subst_PTm ρ a) by hauto lq:on inv:safe lq:on. + by eauto using nostuck_antisubstitution. + move => b hr. exists ρ. + inversion ha as [ha0 ha1]. + hauto lq:on use:RRed.substing. +Qed. diff --git a/theories/fp_red.v b/theories/fp_red.v index 507eb5a..a3fb270 100644 --- a/theories/fp_red.v +++ b/theories/fp_red.v @@ -1270,7 +1270,7 @@ Module Type NoForbid. Axiom P_PairInv : forall (a b : PTm), P (PPair a b) -> P a /\ P b. Axiom P_ProjInv : forall p (a : PTm), P (PProj p a) -> P a. - Axiom P_renaming : forall (ξ : nat -> nat) a , P (ren_PTm ξ a) <-> P a. + Axiom P_renaming : forall (ξ : nat -> nat) a , P (ren_PTm ξ a) -> P a. End NoForbid. Module Type NoForbid_FactSig (M : NoForbid). @@ -1342,7 +1342,7 @@ Module SN_NoForbid <: NoForbid. induction h; sauto lq:on rew:off. Qed. - Lemma P_renaming : forall (ξ : nat -> nat) a , P (ren_PTm ξ a) <-> P a. + Lemma P_renaming : forall (ξ : nat -> nat) a , P (ren_PTm ξ a) -> P a. Proof. hauto lq:on use:sn_antirenaming, sn_renaming. Qed. Lemma P_ProjBind : forall p p' (A : PTm) B, ~ P (PProj p (PBind p' A B)).