diff --git a/README.md b/README.md index 88d60ecc8..50637fbea 100644 --- a/README.md +++ b/README.md @@ -7,10 +7,6 @@ opam pin add -k git coq-core.dev "https://github.com/coq/coq.git#master" opam pin add -k git coq-stdlib.dev "https://github.com/coq/coq.git#master" opam pin add -k git coqide-server.dev "https://github.com/coq/coq.git#master" opam pin add -k git coq.dev "https://github.com/coq/coq.git#master" -opam pin add -k git coq-equations.dev "https://github.com/mattam82/Coq-Equations.git#main" -opam pin add -k git coq-metacoq-utils.dev "https://github.com/MetaCoq/metacoq.git#main" -opam pin add -k git coq-metacoq-common.dev "https://github.com/MetaCoq/metacoq.git#main" -opam pin add -k git coq-metacoq-template.dev "https://github.com/MetaCoq/metacoq.git#main" ``` # Coq Library of Undecidability Proofs @@ -117,7 +113,7 @@ An equivalence proof that most of the mentioned models of computation compute th ## Manual Installation Instructions -You need the `master` branch of `Coq` built on OCAML `>= 4.09.1`, and the Template-Coq (part of [MetaCoq](https://metacoq.github.io/)) package for Coq. If you are using opam 2 you can use the following commands to install the dependencies on a new switch: +You need the `master` branch of `Coq` built on OCAML `>= 4.09.1`. If you are using opam 2 you can use the following commands to install the dependencies on a new switch: ``` opam switch create coq-library-undecidability --packages=ocaml-variants.4.14.1+options,ocaml-option-flambda @@ -126,10 +122,6 @@ opam pin add -k git coq-core.dev "https://github.com/coq/coq.git#master" opam pin add -k git coq-stdlib.dev "https://github.com/coq/coq.git#master" opam pin add -k git coqide-server.dev "https://github.com/coq/coq.git#master" opam pin add -k git coq.dev "https://github.com/coq/coq.git#master" -opam pin add -k git coq-equations.dev "https://github.com/mattam82/Coq-Equations.git#main" -opam pin add -k git coq-metacoq-utils.dev "https://github.com/MetaCoq/metacoq.git#main" -opam pin add -k git coq-metacoq-common.dev "https://github.com/MetaCoq/metacoq.git#main" -opam pin add -k git coq-metacoq-template.dev "https://github.com/MetaCoq/metacoq.git#main" ``` #### Building the undecidability library @@ -150,7 +142,7 @@ The library is compatible with Coq's compiled interfaces ([`vos`](https://coq.in #### Coq version -Be careful that this branch only compiles under `Coq 8.16`. If you want to use a different Coq version you have to change to a different branch. +Be careful that this branch only compiles under `Coq dev`. If you want to use a different Coq version you have to change to a different branch. Due to compatibility issues, not every branch contains exactly the same problems. We recommend to use the newest branch if possible. diff --git a/opam b/opam index e25b357ea..813773c23 100644 --- a/opam +++ b/opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "dev+8.16" +version: "dev" maintainer: "forster@ps.uni-saarland.de" homepage: "https://github.com/uds-psl/coq-library-undecidability/" dev-repo: "git+https://github.com/uds-psl/coq-library-undecidability/" @@ -28,10 +28,9 @@ install: [ depends: [ "coq" {= "dev"} "ocaml" - "coq-metacoq-template" {= "dev"} ] synopsis: "A Coq Library of Undecidability Proofs" url { - git: "https://github.com/uds-psl/coq-library-undecidability.git#coq-8.16" + git: "https://github.com/uds-psl/coq-library-undecidability.git#master" } diff --git a/theories/L/Computability/Acceptability.v b/theories/L/Computability/Acceptability.v deleted file mode 100644 index a09d8baf0..000000000 --- a/theories/L/Computability/Acceptability.v +++ /dev/null @@ -1,87 +0,0 @@ -From Undecidability.L Require Export LTerm Por Decidability Lbeta_nonrefl. -Import L_Notations. - -(* * Definition of L-acceptability *) - -Definition pi (s t:term) := converges (s (ext t)). - -Definition lacc (P : term -> Prop) := - exists u, proc u /\ forall t, P t <-> pi u t. - -(* * Properties of acceptance *) - -Goal forall s1 s2 t, s1 == s2 -> (pi s1 t <-> pi s2 t). -Proof. - intros s1 s2 t H; (intuition idtac); unfold pi; [now rewrite <- H | now rewrite H]. -Qed. - -(* * L-acceptable predicates are closed under conjunction and disjunction *) - -Definition acc_conj (p q : term) := lam ((lam (q #1)) (p #0) ). -#[export] Hint Unfold acc_conj : cbv. - -Lemma acc_conj_correct p q s : closed p -> closed q -> (pi (acc_conj p q) s <-> pi p s /\ pi q s). -Proof. - intros cls_p cls_q. - split. - - intros [x [Hx lx]]. - assert (H : converges (lam( q (enc s)) (p (enc s)))). { exists x;split;auto. symmetry. symmetry in Hx. unfold acc_conj in Hx. rewrite Hx. redStep. LsimplRed. } - destruct (app_converges H) as [_ [y [Hy ly]]]. split. - + eexists; split;eassumption. - + exists x;split;auto. rewrite <- Hx. symmetry. clear Hx. unfold acc_conj. LsimplRed. rewrite Hy. LsimplRed. - - intros [[x [Hx ?]] [y [Hy ?]]]. exists y. split. unfold acc_conj. LsimplRed. rewrite Hx. LsimplRed. tauto. Lproc. -Qed. - -Lemma lacc_conj P Q : lacc P -> lacc Q -> lacc (conj P Q). -Proof. - intros [u1 [[? ?] Hu1]] [u2 [[? ?] Hu2]]. - exists (acc_conj u1 u2). split. unfold acc_conj. Lproc. - intros; rewrite acc_conj_correct; firstorder. -Qed. - -Lemma lacc_disj M N : lacc M -> lacc N -> lacc (disj M N). -Proof. - intros [u [[lam_u cls_u] Hu]] [v [[lam_v cls_v] Hv]]. - unfold lacc, disj. - exists (lam (Por ((ext app) (enc u) ((ext (enc (X:=term)) #0))) (((ext app) (enc v) ((ext (enc (X:=term))) #0))))). - split. Lproc. intros t. - - rewrite Hu, Hv; unfold pi. - evar (t':term). - (* todo: nicer way?*) - assert (R':(lam( - (Por ((ext app) (ext u) ((ext (enc (X:=term))) 0))) - ((ext app) (ext v) ((ext (enc (X:=term))) 0))) (ext t)) >* t'). subst t'. now Lsimpl. - rewrite R'. subst t'. - split. intros [A|B]. - -destruct (Por_correct_1a (v (enc t)) A) as [s [R ls]]. exists s. split;try Lproc. eassumption. - -destruct (Por_correct_1b (u (enc t)) B) as [s [R ls]]. exists s. split;try Lproc. eassumption. - -intros [s [H ls]]. edestruct Por_correct_2 as []. - { exists s. split;auto. - rewrite !ext_is_enc. - unfold Por. - rewrite <- R'. Lsimpl. eassumption. } - apply Por_correct' in H0. destruct x;auto. -Qed. - -(* * L-ecidable predicates are L-acceptable (and their complement too) *) - -Lemma dec_lacc M : ldec M -> lacc M. -Proof. - intros [u [[cls_u lam_u] dec_u_M]]. - exists (lam (u #0 I (lam Omega) I)); split. Lproc. - + intros t. specialize (dec_u_M t). - split; intros H; destruct dec_u_M; try tauto. - * destruct H0 as [u_true ?]. eexists;split;[|eexists;reflexivity]. redSteps. rewrite u_true. destruct x. now Lsimpl. tauto. - * destruct H0. destruct x. tauto. - assert ((lam ((((u #0) I) (lam Omega)) I)) (enc t) == Omega). clear H. LsimplRed. rewrite H0. Lrewrite. - now Lsimpl. destruct H as [H [? []]]. subst H. rewrite H2 in H3. - destruct (Omega_diverges H3). -Qed. - -Lemma dec_acc : forall M, ldec M -> lacc M /\ lacc (complement M). -Proof. - intros M decM; split. - - eapply (dec_lacc decM). - - eapply ldec_complement in decM. eapply (dec_lacc decM). -Qed. diff --git a/theories/L/Computability/Computability.v b/theories/L/Computability/Computability.v deleted file mode 100644 index e871bc0d5..000000000 --- a/theories/L/Computability/Computability.v +++ /dev/null @@ -1,52 +0,0 @@ -From Undecidability.L Require Export L Datatypes.LNat Datatypes.LBool Functions.Encoding Computability.Seval. -Require Import Coq.Logic.ConstructiveEpsilon. - -Definition cChoice := constructive_indefinite_ground_description_nat_Acc. - -Lemma eq_term_dec (s t : term) : (s = t) + (s <> t). -Proof. - revert t. induction s; intros t; destruct t; try(right; intros H; inv H; fail). - - decide (n = n0). left. congruence. right. congruence. - - destruct (IHs1 t1), (IHs2 t2); try (right; congruence). left. congruence. - - destruct (IHs t). left; congruence. right; congruence. -Qed. - -Lemma enc_extinj {X} {R} {H:@encInj X R} (m n:X) : enc m == enc n -> m = n. -Proof. - intros eq. apply unique_normal_forms in eq; try Lproc. now apply inj_enc. -Qed. - -Lemma lcomp_comp Y {Ry:encodable Y} (u:term) (g: term -> Y): - (forall x (y:Y), enc y = x -> y = g x) -> - (exists y:Y, u == enc y) -> {y:Y| u == enc y}. -Proof. - intros Hg Hu. - assert (exists n (y:Y), eva n u = Some (enc y)). - { - destruct Hu as [y Hy]. apply equiv_lambda in Hy;try Lproc. - assert (eval (u) (enc y)). split. assumption. Lproc. - apply eval_seval in H. destruct H as [n Hn]. exists n. exists y. now apply seval_eva. - } - eapply cChoice in H. destruct H as [n H]. - destruct (eva n u) as [t|] eqn:Heva. - -exists (g t). destruct H as [y H]. rewrite <- Heva in H. apply eva_equiv in H. - assert (lambda t)by now apply eva_lam in Heva. apply eva_equiv in Heva. rewrite Heva in H. erewrite <- Hg. apply equiv_lambda in Heva;try Lproc. rewrite Heva. exact H. apply unique_normal_forms in H;try Lproc. congruence. - -exists (g #0). destruct H as [? H]. inv H. - -intros n. destruct (eva n u) eqn:eq. - +left. destruct H as [n' [y H]]. exists y. apply eva_equiv in H. - assert (lambda t) by now apply eva_lam in eq. apply eva_equiv in eq. rewrite H in eq. apply unique_normal_forms in eq;[|Lproc..]. congruence. - +right. intros [y eq']. congruence. -Qed. - -Definition bool_enc_inv b:= - match b with - | lam (lam (var 1)) => true - | _ => false - end. - -Lemma bool_enc_inv_correct : (forall x (y:bool), enc y = x -> y = bool_enc_inv x). -Proof. - intros x [];intros;subst;reflexivity. - Qed. - -Arguments lcomp_comp _{_} _ {_} _ _. diff --git a/theories/L/Computability/Decidability.v b/theories/L/Computability/Decidability.v deleted file mode 100644 index dff14631f..000000000 --- a/theories/L/Computability/Decidability.v +++ /dev/null @@ -1,72 +0,0 @@ -From Undecidability.L Require Export Tactics.LTactics Functions.Encoding Datatypes.LBool L. -Import HOAS_Notations. - -(* * Definition of L-decidability *) - -Definition decides (u:term) P := forall (s:term), exists b : bool, (app u (ext s) == ext b /\ (if b then P s else ~P s)). - -Definition ldec (P : term -> Prop) := - exists u : term, proc u /\ decides u P. - -(* * Complement, conj and disj of predicates *) - -Definition complement (P : term -> Prop) := fun t => ~ P t. - -Definition conj (P : term -> Prop) (Q : term -> Prop) := fun t => P t /\ Q t. - -Definition disj (P : term -> Prop) (Q : term -> Prop) := fun t => P t \/ Q t. - -(* * Deciders for complement, conj and disj of ldec predicates *) -Definition tcompl (u : term) : term := Eval cbn in convert (λ x, !!(ext negb) (!!u x)). - -Definition tconj (u v : term) : term := Eval cbn in convert (λ x, !!(ext andb) (!!u x) (!!v x)). - -Definition tdisj (u v : term) : term := Eval cbn in convert (λ x, !!(ext orb) (!!u x) (!!v x)). - -#[global] Hint Unfold tcompl tconj tdisj : Lrewrite. -#[global] Hint Opaque tcompl tconj tdisj : Lrewrite. -#[global] Hint Unfold tcompl tconj tdisj : LProc. -#[global] Hint Opaque tcompl tconj tdisj : LProc. - -(* * L-decidable predicates are closed under complement, conj and disj *) - -Lemma ldec_complement P : ldec P -> ldec (complement P). -Proof. - intros [u [[cls_u lam_u] H]]. exists (tcompl u). unfold tcompl. split. Lproc. - intros s. destruct (H s) as [b [A Ps]];exists (negb b). - split. - -Lsimpl. rewrite A. now Lsimpl. - -destruct b;simpl; intuition. -Qed. - -Lemma ldec_conj P Q : ldec P -> ldec Q -> ldec (conj P Q). -Proof. - intros [u [[cls_u lam_u] decP]] [v [[cls_v lam_v] decQ]]. - exists (tconj u v). unfold tconj. split. Lproc. - intros s. destruct (decP s) as [b [Hu Ps]], (decQ s) as [b' [Hv Qs]];exists (andb b b'). - split. - -Lsimpl. rewrite Hu,Hv. now Lsimpl. - -destruct b,b';simpl;unfold conj;intuition. -Qed. - -Lemma ldec_disj P Q : ldec P -> ldec Q -> ldec (disj P Q). -Proof. - intros [u [[cls_u lam_u] decP]] [v [[cls_v lam_v] decQ]]. - exists (tdisj u v). unfold tdisj. split. Lproc. - intros s. destruct (decP s) as [b [Hu Ps]], (decQ s) as [b' [Hv Qs]];exists (orb b b'). - split. - -Lsimpl. rewrite Hu,Hv. now Lsimpl. - -destruct b,b';simpl;unfold disj;intuition. -Qed. - -Lemma dec_ldec (P:term -> Prop) (f: term -> bool) {If : computable f}: (forall x, reflect (P x) (f x)) ->ldec P. -Proof. - intros H. - exists (ext f). split. Lproc. - intros s. eexists. split. - -Lsimpl. reflexivity. - -destruct (H s);assumption. -Qed. - -Arguments dec_ldec {_} f {_} _. - diff --git a/theories/L/Computability/Fixpoints.v b/theories/L/Computability/Fixpoints.v deleted file mode 100644 index c03d1346c..000000000 --- a/theories/L/Computability/Fixpoints.v +++ /dev/null @@ -1,33 +0,0 @@ -From Undecidability.L Require Export LTactics LTerm Functions.Encoding Tactics.Lbeta_nonrefl. -Import L_Notations. - -(* * First Fixed Point Theorem *) - -Theorem FirstFixedPoint (s : term) : closed s -> exists t, closed t /\ s t == t. -Proof. - intros cls_s. - pose (A := lam (s (#0 #0))). - pose (t := A A). - exists t. split;[subst t A;Lproc|]. - symmetry. cbv. now redStep. -Qed. - -(* * Second Fixed Point Theorem *) - -Theorem SecondFixedPoint (s : term) : closed s -> exists t, closed t /\ s (enc t) == t. -Proof. - intros cls_s. - pose (A := lam(s ((ext app) #0 ((ext (enc (X:= term))) #0)))). - pose (t := A (ext A)). - exists t. split;[subst t A;Lproc|]. - symmetry. change (enc t) with (ext t). - unfold t. unfold A at 1. - redSteps. now Lsimpl. -Qed. - -Goal exists t, closed t /\ t == (enc t). -Proof. - destruct (SecondFixedPoint) with ( s := I) as [t [cls_t A]]. Lproc. - exists t. - split. Lproc. rewrite <- A at 1. clear A. unfold I. now Lsimpl. -Qed. diff --git a/theories/L/Computability/MuRec.v b/theories/L/Computability/MuRec.v deleted file mode 100644 index 92953c4c5..000000000 --- a/theories/L/Computability/MuRec.v +++ /dev/null @@ -1,135 +0,0 @@ -From Undecidability.L Require Export Datatypes.LNat Datatypes.LBool Tactics.LTactics Computability.Computability Tactics.Lbeta. - -Section MuRecursor. - -Variable P : term. -Hypothesis P_proc : proc P. -Local Hint Resolve P_proc : LProc. - -Hypothesis dec'_P : forall (n:nat), (exists (b:bool), app P (ext n) == ext b ). - -Lemma dec_P : forall n:nat, {b:bool | app P (ext n) == ext b}. -Proof using dec'_P. - intros. eapply lcomp_comp. - -apply bool_enc_inv_correct. - -apply dec'_P. -Qed. - -Section hoas. - Import HOAS_Notations. - Definition mu' := Eval cbn -[enc] in rho (convert (λ mu P n, (P n) (!!K n) (λ Sn, mu P Sn) (!!(ext S) n))). -End hoas. - -Import L_Notations. - -Lemma mu'_proc : proc mu'. -Proof. - unfold mu'; Lproc. -Qed. - -Local Hint Resolve mu'_proc : LProc. - -Lemma mu'_n_false n: P (ext n) == ext false -> mu' P (ext n) >* mu' P (ext (S n)). -Proof using P_proc. - intros R. apply equiv_lambda in R;[|Lproc]. recStep mu'. unfold K. now Lsimpl. -Qed. - -Lemma mu'_0_false n: (forall n', n' < n -> P (ext n') == ext false) -> mu' P (ext 0) >* mu' P (ext n). -Proof using P_proc. - intros H. induction n. - -reflexivity. - -rewrite IHn. - +apply mu'_n_false. apply H. lia. - +intros. apply H. lia. -Qed. - -Lemma mu'_n_true (n:nat): P (ext n) == ext true -> mu' P (ext n) == ext n. -Proof using P_proc. - intros R. recStep mu'. Lsimpl. rewrite R. unfold K. now Lsimpl. -Qed. - -(* TODO: mu' sound*) -Lemma mu'_sound v n: proc v -> mu' P (ext (n:nat)) == v -> - (forall n', n' < n -> P (ext n') == ext false) -> - exists n0, n0 >= n /\ P (ext n0) == ext true /\ v == ext n0 - /\ forall n', n' < n0 -> P (ext (n':nat)) == ext false. -Proof using P_proc dec'_P. - intros pv. intros R. apply equiv_lambda in R;try Lproc. apply star_pow in R. destruct R as [k R]. revert n R. apply complete_induction with (x:=k);clear k;intros k. intros IH n R H. - specialize (dec_P n). - destruct (dec_P n) as [[] eq]. - -exists n;intuition. apply pow_star in R. apply star_equiv in R. rewrite <- R. now rewrite mu'_n_true. - -assert (R':=mu'_n_false eq). apply star_pow in R'. destruct R' as [k' R']. - destruct (parametrized_confluence uniform_confluence R R') as [x [l [u [le1 [le2 [R1 [R2 eq']]]]]]]. destruct x. - +inv R1. apply IH in R2 as [n0 [ge1 [Rn0 [eq0 H0]]]]. - *exists n0. repeat split;try assumption;lia. - *decide (l=k);[|lia]. subst l. assert (k'=0) by lia. subst k'. inv R'. apply inj_enc in H1. lia. - *intros. decide (n'=n). subst. tauto. apply H. lia. - +destruct R1 as [? [C _]]. destruct pv as [_ [v']]. subst v. inv C. -Qed. - - -Lemma mu'_complete n0 : P (ext n0) == ext true - -> (forall n', n' < n0 -> P (ext n') == ext false) - -> mu' P (ext 0) == ext n0. -Proof using P_proc. - intros. rewrite mu'_0_false with (n:=n0);try tauto. - -recStep mu'. Lsimpl. rewrite H. unfold K. now Lsimpl. -Qed. - -(* the mu combinator:*) - - -Definition mu :term := lam (mu' #0 (ext 0)). - -Lemma mu_proc : proc mu. -Proof. - unfold mu. Lproc. -Qed. - -Local Hint Resolve mu_proc : LProc. - -Lemma mu_sound v : lambda v -> mu P == v -> exists n, v = ext n /\ P (ext n) == ext true /\ (forall n', n' < n -> P (ext n') == ext false). -Proof using P_proc dec'_P. - unfold mu. intros lv R. standardizeHypo 100. apply mu'_sound in R. - -destruct R as [n ?]. exists n. intuition. apply unique_normal_forms;try Lproc. assumption. - -split;[|Lproc]. apply equiv_lambda in R;auto. apply closed_star in R;Lproc. - -intros. lia. -Qed. - -Lemma mu_complete' (n:nat) : P (ext n) == ext true -> exists n0:nat, mu P == ext n0 /\ P (ext n0) == ext true. -Proof using P_proc dec'_P. - remember 0 as n0. - assert (forall n':nat, n'< n-(n-n0) -> P (ext n') == ext false) by (intros;lia). - assert ((n-n0)+n0=n) by lia. remember (n-n0) as k. clear Heqk Heqn0 H0 n0. induction k. - - simpl in *. subst. intros. - eexists. unfold mu. split. - + Lsimpl. apply mu'_complete;eauto. intros. apply H. lia. - + eauto. - - intros. destruct (dec_P (n-S k)) as [y P']. - destruct y. - + eexists. unfold mu. split. - * Lsimpl. apply mu'_complete. exact P'. exact H. - * eauto. - + apply IHk. intros. decide (n' = n - (S k)). - * subst. exact P'. - * apply H. lia. - * assumption. -Qed. - -Lemma mu_complete (n:nat) : P (ext n) == ext true -> exists n0:nat, mu P == ext n0. -Proof using P_proc dec'_P. - intros [? []] % mu_complete'; eauto. -Qed. - -Lemma mu_spec : converges (mu P) <-> exists n : nat, P (ext n) == ext true. -Proof using P_proc dec'_P. - split. - - intros (? & ? & ?). eapply mu_sound in H as (? & ? & ? & ?); eauto. - - intros []. eapply mu_complete in H as []. exists (ext x0). split. eauto. eapply proc_ext. -Qed. - -End MuRecursor. - -#[export] Hint Resolve mu'_proc : LProc. -#[export] Hint Resolve mu_proc : LProc. - diff --git a/theories/L/Computability/Por.v b/theories/L/Computability/Por.v deleted file mode 100644 index 30ec02b0d..000000000 --- a/theories/L/Computability/Por.v +++ /dev/null @@ -1,65 +0,0 @@ -From Undecidability.L.Functions Require Export Eval. - -(* * Definition of parallel or *) - -Section hoas. Import HOAS_Notations. -Definition Por :term := Eval simpl in [L_HOAS λ s t , (λ n0, !!(ext doesHaltIn) s n0 ) (!!mu (λ n ,!!(ext orb) (!!(ext doesHaltIn) s n) (!!(ext doesHaltIn) t n)))] . -End hoas. - -Lemma Por_proc : proc Por. -Proof. - unfold Por; Lproc. -Qed. - -#[export] Hint Resolve Por_proc : LProc. - -Import L_Notations. - -Lemma Por_correct_1a (s t:term) : converges s -> converges (Por (ext s) (ext t)). -Proof. - intros H. apply eval_converges in H as [t' H]. apply eval_seval in H as [n H]. - apply seval_eva in H. edestruct mu_complete with (n:=n) (P:=(lam ((ext orb) ((ext doesHaltIn) (ext s) 0) ((ext doesHaltIn) (ext t) 0)))) as [v R]. - -Lproc. - -eexists;now Lsimpl. - -Lsimpl. edestruct (doesHaltIn s n) eqn:eq;unfold doesHaltIn in eq;rewrite H in eq. 2:congruence. reflexivity. - -eapply Seval.eval_converges. unfold Por. Lsimpl. rewrite R. Lsimpl. Lreflexivity. -Qed. - -Lemma Por_correct_1b (s t:term) : converges t -> converges (Por (ext s) (ext t)). -Proof. - intros H. apply eval_converges in H as [t' H]. apply eval_seval in H as [n H]. - apply seval_eva in H. edestruct mu_complete with (n:=n) (P:=lam ( (ext orb) ((ext doesHaltIn) (ext s) 0) ((ext doesHaltIn) (ext t) 0))) as [v R]. - -Lproc. - -eexists;now Lsimpl. - -Lsimpl. edestruct (doesHaltIn t n) eqn:eq;unfold doesHaltIn in eq;rewrite H in eq. 2:congruence. edestruct doesHaltIn;reflexivity. - -eapply Seval.eval_converges. unfold Por. Lsimpl. rewrite R. Lsimpl. Lreflexivity. -Qed. - -Lemma Por_correct_1 s t : converges s \/ converges t -> converges (Por (ext s) (ext t)). -Proof. - intros [convs | convt]; eauto using Por_correct_1a, Por_correct_1b. -Qed. - -Lemma Por_correct_2 (s t:term) : converges (Por (ext s) (ext t)) -> - exists (b:bool), Por (ext s) (ext t) == ext b. -Proof. - intros [v [R lv]]. unfold Por in R. LsimplHypo. - evar (s':term). assert (C:converges s'). eexists. split. exact R. Lproc. subst s'. - apply app_converges in C as [_ [v' [C lv']]]. - assert (C':=C). - apply mu_sound in C as [n [eq [R' H]]];try Lproc. - -exists (doesHaltIn s n). subst. unfold Por. Lsimpl. rewrite C'. now Lsimpl. - -eexists. now Lsimpl. -Qed. - - -Lemma Por_correct' (s t:term) (b:bool) : Por (ext s) (ext t) == ext b -> if b then converges s else converges t. -Proof. - intros H. unfold Por in H. LsimplHypo. evar (s':term). assert (C:converges s'). eexists. split. exact H. Lproc. subst s'. - apply app_converges in C as [_ [v [C lv]]]. - assert (C':= C). apply mu_sound in C'; try Lproc. - -destruct C' as [n [eq [R C']]]. subst v. rewrite C in H. LsimplHypo. Lrewrite in R. Lrewrite in H. apply enc_extinj in H. rewrite H in R. destruct b. - +unfold doesHaltIn in H. destruct (eva n s) eqn: eq. apply eva_seval in eq. apply seval_eval in eq. eauto. congruence. - +simpl in R. apply enc_extinj in R. unfold doesHaltIn in R. destruct (eva n t) eqn: eq. apply eva_seval in eq. apply seval_eval in eq. eauto. congruence. - -intros. eexists. now Lsimpl. -Qed. diff --git a/theories/L/Computability/Rice.v b/theories/L/Computability/Rice.v deleted file mode 100644 index bb957fa73..000000000 --- a/theories/L/Computability/Rice.v +++ /dev/null @@ -1,197 +0,0 @@ -From Undecidability.L.Computability Require Export Scott Acceptability. -Import Undecidability.L.Prelim.ARS.ARSNotations. -Import L_Notations. - -(* * The self halting problem is not L-acceptable *) - -Definition self_diverging (s : term) := ~ pi s s. - -Definition self_diverging_comb := conj self_diverging proc. - -Lemma self_div : ~ lacc self_diverging. -Proof. - intros H. - destruct H as [u [[cls_u lam_u] H]]. - unfold self_diverging in H. specialize (H u). intuition auto. -Qed. - -Lemma self_div_comb : ~ lacc self_diverging_comb. -Proof. - intros [u [[cls_u lam_u] H]]. - unfold self_diverging_comb in H. unfold conj in H. - specialize (H u). unfold self_diverging in H. - destruct H. unfold proc in *. tauto. -Qed. - -(* * Rice's Theorem *) - -Lemma Rice1 (M : term -> Prop) : (M <=1 proc) -> - (forall (s t : term), proc t -> M s -> (forall u, pi s u <-> pi t u) -> M t) -> - (exists p, proc p /\ ~ M p) -> (exists p, proc p /\ M p) -> - M (lam Omega) -> ~ lacc M. -Proof with eauto; try now intuition. - intros M_proc M_cl_equiv [t2 [cls_t2 nMt2]] [t1 [cls_t1 nMt1]] MLO [u [[cls_u lam_u] Hu]]. - - eapply (self_div_comb). - - destruct (dec_lacc ldec_proc) as [c [[cls_c lam_c] Hc]]. - pose (v := lam ( u ((ext lam) ((ext app) (enc (lam (t2 #1))) ((ext app) #0 ((ext (enc(X:= term))) #0)))))). - pose (v' := acc_conj c v). - assert (proc v). subst v;unfold acc_conj;Lproc. - assert (proc v'). subst v';unfold acc_conj;Lproc. - exists v'; split. Lproc. - intros s. - pose (vs := lam ((lam (t2 #1)) (s (enc s)))). - - symmetry. - transitivity (pi v s /\ proc s). - { - unfold v'. rewrite acc_conj_correct;try Lproc. rewrite <- Hc. tauto. - } - - unfold self_diverging_comb, conj. - - transitivity (pi u vs /\ proc s). - { - split; intros [R cls_s];(split;[|Lproc]). - -revert R. eapply converges_proper. symmetry. subst v. now Lsimpl. - -revert R. eapply converges_proper. subst v. now Lsimpl. - } - - transitivity (M vs /\ proc s). - split; intros [? ?]; intuition auto; try (now apply Hu). - { - split. - - intros [Mvs cls_s]; intuition. - intros [w [Hw lw]]. - assert (forall t, pi vs t <-> pi t2 t). { - intros t. eapply converges_proper. - assert (closed w). eapply (equiv_lambda lw) in Hw. eapply closed_star. exact Hw. Lproc. subst vs. Lsimpl. rewrite Hw. now Lsimpl. - } - eapply nMt2. eapply M_cl_equiv; eassumption. - - intros [npi_s_s cls_s]. split; [|assumption]. - assert (forall t, pi (lam Omega) t <-> pi vs t). { - intros t; split; intros H'. - - exfalso. destruct H' as [w [Hw lw]]. inv lw. eapply Omega_diverges. rewrite <- Hw. symmetry. clear Hw. now redStep. - - exfalso. eapply npi_s_s. - assert (A: converges (lam ( t2 (enc t)) (s (enc s)))). revert H'. eapply converges_proper. symmetry. unfold vs. now Lsimpl. - eapply app_converges in A. easy. - } - subst vs. - eapply M_cl_equiv; try Lproc;try eassumption. - } -Qed. - -Lemma Rice2 (M : term -> Prop) : (M <=1 proc) -> - (forall (s t : term), proc t -> M s -> (forall u, pi s u <-> pi t u) -> M t) -> - (exists p, proc p /\ ~ M p) -> (exists p, proc p /\ M p) -> - ~ M (lam Omega) -> ~ lacc (complement M). -Proof. - intros M_cls M_cl_equiv [t2 [cls_t2 nMt2]] [t1 [cls_t1 nMt1]] nMLO decM. - destruct decM as [u [[cls_u lam_u] Hu]]. unfold complement in Hu. - - eapply (self_div_comb). - - destruct (dec_lacc ldec_proc) as [c [[cls_c lam_c] Hc]]. - pose (v := lam ( u ((ext lam) ((ext app) (enc (lam (t1 #1))) ((ext app) #0 ((ext (enc (X:=term))) #0)))))). - pose (v' := acc_conj c v). - exists v'; split. subst v' v. unfold acc_conj. Lproc. - intros s. - pose (vs := lam ((lam (t1 #1)) (s (enc s)))). - assert (cv:closed v) by (subst v; Lproc). - - symmetry. - transitivity (pi v s /\ proc s). - { - unfold v'. rewrite acc_conj_correct;try Lproc. intuition idtac; now apply Hc. } - - unfold self_diverging_comb, conj. - - transitivity (pi u vs /\ proc s). - { - split; intros [R cls_s];(split;[|Lproc]). - -revert R. eapply converges_proper. symmetry. subst v. now Lsimpl. - -revert R. eapply converges_proper. subst v. now Lsimpl. - } - - transitivity (~ M vs /\ proc s). - { - split; intros [? ?]; try (rewrite Hu); intuition idtac. now apply Hu. - } - - { - split. - - intros [Mvs cls_s]; intuition idtac. - intros [w [Hw lw]]. - assert (forall t, pi t1 t <-> pi vs t). { - intros t. symmetry. assert (closed w). eapply closed_star. eapply equiv_lambda;eauto. Lproc. eapply converges_proper. - transitivity (lam ( t1 (enc t)) (s (enc s))). unfold vs. now Lsimpl. rewrite Hw. now Lsimpl. - } - eapply Mvs. eapply M_cl_equiv;try subst vs; try Lproc; try eassumption. - - intros [npi_s_s cls_s]; intuition idtac. - assert (forall t, pi (lam Omega) t <-> pi vs t). { - intros t; split; intros A. - - exfalso. destruct A as [w [Hw lw]]. inv lw. eapply Omega_diverges. rewrite <- Hw. symmetry. clear Hw. now LsimplRed. - - exfalso. eapply npi_s_s. - assert (B: converges (lam ( t1 (enc t)) (s (enc s)))). revert A. eapply converges_proper. symmetry. unfold vs. now Lsimpl. - eapply app_converges in B. firstorder easy. - } - eapply nMLO. - eapply M_cl_equiv; try (symmetry); eauto. Lproc. - } -Qed. - -(* ** Rice's Theorem, classical *) - -Theorem Rice (M : term -> Prop) : (M <=1 proc) -> - (forall (s t : term), proc t -> M s -> (forall u, pi s u <-> pi t u) -> M t) -> - (exists p, proc p /\ ~ M p) -> (exists p, proc p /\ M p) -> - ~ ldec M. -Proof. - intros. intros A. assert (B : ldec M) by eassumption. destruct A as [u [proc_u Hu]]. - destruct (Hu (lam Omega)) as [[] [eq m]]. - - eapply Rice1; try eassumption. apply dec_lacc. exists u; tauto. - - eapply Rice2; try eassumption. apply dec_lacc. apply ldec_complement. exists u; tauto. -Qed. - -Lemma lamOmega s : ~ pi (lam Omega) s. -Proof. - intros A. destruct A as [? [H l]]. inv l. eapply Omega_diverges. rewrite <- H. clear H. symmetry. now redSteps. -Qed. - -(* * Applications of Rice's Theorem *) - -Goal ~ ldec (fun s => proc s /\ forall t, pi s t). -Proof. - eapply Rice. - - firstorder. - - intuition idtac;now apply H1. - - exists (lam Omega). split. Lproc. intros [_ A]. eapply lamOmega; eauto. - - exists (lam I). repeat split;try Lproc. intros t; eexists; split; [|eexists;reflexivity]. now Lsimpl. -Unshelve. repeat econstructor. -Qed. - -Goal ~ lacc (fun s => proc s /\ exists t, ~ pi s t). -Proof. - eapply Rice1. - - firstorder. - - intros s t cls_t [cls_s [t0 H]] He. split; eauto. - exists t0. rewrite <- He. eassumption. - - exists (lam I). split. Lproc. intros [_ [? H]]. eapply H. eexists;split;[|eexists;reflexivity]. now Lsimpl. - - exists (lam Omega). repeat split;try Lproc. exists I. eapply lamOmega. - - split. Lproc. exists I. eapply lamOmega. -Qed. - -(* * Rice's Theorem, classical, on combinators *) - -Theorem Rice_classical (M : term -> Prop) : (M <=1 closed) -> - (forall (s t : term), closed t -> M s -> (forall u, pi s u <-> pi t u) -> M t) -> - (exists p, closed p /\ ~ M p) -> (exists p, closed p /\ M p) -> - ~ ldec M. -Proof. - intros. eapply Scott. - - firstorder. - - intros. eapply H0; try eassumption. intros. unfold pi. now rewrite H5. - - destruct H2; eauto. - - destruct H2; eauto. -Qed. diff --git a/theories/L/Computability/Scott.v b/theories/L/Computability/Scott.v deleted file mode 100644 index 301fc1fe4..000000000 --- a/theories/L/Computability/Scott.v +++ /dev/null @@ -1,72 +0,0 @@ -From Undecidability.L.Computability Require Export Fixpoints Decidability Seval. -From Undecidability.L.Functions Require Export Proc Encoding. -Import ARS.ARSNotations L_Notations. -(* * Scott's Theorem *) - -Theorem Scott (M : term -> Prop) : M <=1 closed -> - (forall s t, M s -> closed t -> t == s -> M t) -> - (exists t1, closed t1 /\ M t1) -> (exists t2, closed t2 /\ ~ M t2) -> - ~ ldec M. -Proof. - intros M_cl M_equiv [s1 [cls_s1 Ms1]] [s2 [cls_s2 nMs2]] [u [[cls_u lam_u] Hu]]. - pose (x := lam(u #0 (lam s2) (lam s1) I)). - destruct (SecondFixedPoint (s := x)) as [t [cls_t H]]. subst x. Lproc. - eapply eqTrans with (s := u (enc t) (lam s2) (lam s1) I) in H. - destruct (Hu t) as [[] [R C]]. - - eapply nMs2, M_equiv; eauto. - rewrite <- H,R. symmetry. Lrewrite. LsimplRed. - - eapply C, M_equiv; eauto. - rewrite <- H,R. Lrewrite. LsimplRed. - -symmetry. etransitivity. apply eqStep. apply step_Lproc;Lproc. simpl. now rewrite cls_u,cls_s1,cls_s2. -Qed. - -(* * Applications of Scott's Theorem *) - -Goal ~ ldec (fun x => closed x /\ converges x). -Proof. - eapply Scott. - - tauto. - - intros s t [cls_s [x [Hx lx]]] cls_t t_e_s; split. - + eassumption. - + exists x;split;[|Lproc]. now rewrite t_e_s. - - exists I. repeat split. exists I;split. reflexivity. Lproc. - - exists Omega. repeat split. intros [_ [x [Hx lx]]]. inv lx. eapply Omega_diverges. exact Hx. -Qed. - -Lemma I_neq_Omega : ~ I == Omega. -Proof. - intros H. eapply Omega_diverges. rewrite <- H. unfold I. cbv; reflexivity. -Qed. - -Lemma C27 : forall t, closed t -> ~ ldec (fun x => closed x /\ x == t). -Proof. - intros t cls_t H. cut (ldec (fun x : term => closed x /\ x == t)). - eapply Scott. - - tauto. - - intros s t0 [cls_s H0] cls_t0 H1. split. assumption. rewrite H1. assumption. - - exists t. repeat split. assumption. assumption. reflexivity. - - destruct H. destruct H. destruct (H0 I) as [[] [? ?]]. - +destruct H2 as [? ?]. exists Omega. split. intros k r. simpl. reflexivity. intros [_ C]. eapply I_neq_Omega. rewrite C. auto. - +exists I. split. Lproc. auto. - - eassumption. -Qed. - -Lemma C27_proc : forall t, proc t -> ~ ldec (fun x => x == t). -Proof. - intros t proc_t H. eapply C27; eauto using ldec_conj, ldec_closed; Lproc. -Qed. - -Lemma Eq_ldec : ~ ldec (fun x => exists (s t : term), x = enc (s t) /\ s == t). -Proof. - intros [u [[cls_u lam_u] Hu]]. - pose (t := I). - eapply (C27_proc (t := t)). Lproc. - pose (v := (lam(u ((ext (enc (X:=term))) ((ext app) #0 (ext t)))))). - exists v. split. subst v;Lproc. - intros s. destruct (Hu (ext (s t))) as [b [eq C]]. - exists b. split. - +subst v. Lsimpl. eassumption. - +destruct b. - *destruct C as [? [? [eq' ?]]]. apply inj_enc in eq'. congruence. - *intros eq'. apply C. now repeat eexists. -Qed. diff --git a/theories/L/Computability/Synthetic.v b/theories/L/Computability/Synthetic.v deleted file mode 100644 index a2833c1a6..000000000 --- a/theories/L/Computability/Synthetic.v +++ /dev/null @@ -1,269 +0,0 @@ -From Undecidability.L Require Import Computability.MuRec. -From Undecidability.L.Datatypes Require Import LNat LOptions LProd. -From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts. -From Undecidability.L.Datatypes.List Require Import List_basics List_nat. - -Require Import Datatypes. - -Inductive is_computable {A} {t : TT A} (a : A) : Prop := - C : computable a -> is_computable a. - -Notation enumerates f p := (forall x, p x <-> exists n : nat, f n = Some x). - -Definition L_decidable {X} `{encodable X} (P : X -> Prop) := - exists f : X -> bool, is_computable f /\ forall x, P x <-> f x = true. - -Definition L_enumerable {X} `{encodable X} (p : X -> Prop) := - exists f : nat -> option X, is_computable f /\ (enumerates f p). - -Definition L_recognisable {X} `{encodable X} (p : X -> Prop) := - exists f : X -> nat -> bool, is_computable f /\ forall x, p x <-> exists n, f x n = true. - -Definition L_recognisable' {X} `{encodable X} (p : X -> Prop) := - exists s : term, forall x, p x <-> converges (L.app s (enc x)). - -Section L_enum_rec. - - Variable X : Type. - Context `{encodable X}. - Variable (p : X -> Prop). - - Hypotheses (f : nat -> option X) (c_f : computable f) (H_f : enumerates f p). - Hypotheses (d : X -> X -> bool) (c_d : computable d) (H_d : forall x y, reflect (x = y) (d x y)). - - Definition test := (fun x n => match f n with Some y => d x y | None => false end). - - Instance term_test : computable test. - Proof using c_f c_d. - extract. - Qed. - - Import HOAS_Notations. - - Lemma proc_test (x : X) : - proc [L_HOAS λ y, !!(ext test) !!(enc x) y]. - Proof. - cbn. Lproc. - Qed. - - Lemma L_enumerable_recognisable : - L_recognisable' p. - Proof using c_f c_d H_f H_d. - exists [L_HOAS λ x, !!mu (λ y, !!(ext test) x y)]. - intros. split; intros. - - eapply H_f in H0 as [n H0]. - edestruct (mu_complete (proc_test x)) with (n := n). - + intros. exists (test x n0). cbn. now Lsimpl. - + cbn. Lsimpl. unfold test. rewrite H0. destruct (H_d x x); intuition. - + exists (ext x0). split; try Lproc. - cbn. Lsimpl. now rewrite H1. - - destruct H0 as (v & ? & ?). - edestruct (mu_sound (proc_test x)) with (v := v) as (n & ? & ? & _). - + intros. exists (test x n). cbn. now Lsimpl. - + Lproc. - + rewrite <- H0. symmetry. cbn. now Lsimpl. - + subst. eapply H_f. exists n. - assert ([L_HOAS (λ y, !! (ext test) !! (enc x) y) !!(ext n)] == ext (test x n)). - cbn. now Lsimpl. cbn in *. rewrite H2 in *. - eapply unique_normal_forms in H3;[|Lproc..]. - eapply inj_enc in H3. - unfold test in H3. destruct (f n); inv H3. - destruct (H_d x x0); firstorder congruence. - Qed. - -End L_enum_rec. - -Definition opt_to_list n := match nat_enum n with Some x => [x] | None => [] end. - -#[global] -Instance term_opt_to_list : computable opt_to_list. -Proof. - extract. -Qed. - -Definition L_nat := cumul (opt_to_list). - -#[global] -Instance term_L_nat : computable L_nat. -Proof. - unfold L_nat. unfold cumul. - extract. -Qed. - -(* Definition T_nat_nat := Eval cbn in L_T (X := nat * nat). *) - -(* Definition pair' : nat * nat -> nat * nat := fun '(x,y) => (x,y). *) - -(* Instance term_pair' : computable pair'. *) -(* Proof. *) -(* extract. *) -(* Qed. *) - -From Coq Require Cantor. - -(* Instance term_nat_rec {X : Set} `{encodable X} : computable (@nat_rec (fun _ => X)). *) -(* Proof. *) -(* unfold nat_rec, nat_rect. extract. *) -(* Qed. *) - -Definition F' := (fix F (n : nat) : nat := match n with - | 0 => 0 - | S n0 => S n0 + F n0 - end). - -#[global] -Instance term_F' : computable F'. -Proof. - extract. -Qed. - -Definition F'' := (fix F (n0 : nat) : nat * nat := match n0 with - | 0 => (0, 0) - | S n1 => match F n1 with - | (0, y) => (S y, 0) - | (S x0, y) => (x0, S y) - end - end). - -#[global] -Instance term_F'' : computable F''. -Proof. - extract. -Qed. - -#[global] -Instance term_embed_nat : computable Cantor.to_nat. -Proof. - change (computable (fun '(x, y) => y + F' (y + x))). - extract. -Qed. - -#[global] -Instance term_unembed_nat : computable Cantor.of_nat. -Proof. - unfold Cantor.of_nat. - change (computable F''). - exact term_F''. -Qed. - -(* Definition F''' := (prod_enum nat_enum nat_enum). *) - -(* Instance term_prod_enum : computable F'''. *) -(* Proof. *) -(* unfold F'''. *) -(* extract. *) -(* Qed. *) - -(* Instance term_nat_enum : computable nat_enum. *) -(* Proof. *) -(* extract. *) -(* Qed. *) - -(* Instance term_T_nat_nat : computable T_nat_nat. *) -(* Proof. *) -(* change (computable *) -(* (fix f (n : nat) : list (nat * nat) := match n with *) -(* | 0 => [] *) -(* | S n0 => f n0 ++ opt_to_list (F''' n0) *) -(* end)). *) -(* extract. *) -(* Qed. *) - -(* Instance term_R_nat_nat : computable R_nat_nat. *) -(* Proof. *) -(* change (computable (fun n : nat => nthe n (T_nat_nat n))). *) -(* extract. *) -(* Qed. *) - -(* Instance term_ofNat X `{encodable X} : *) -(* computable (@ofNat X). *) -(* Proof. *) -(* extract. *) -(* Qed. *) - -Definition lenumerates {X} L (p : X -> Prop) := - cumulative L /\ (forall x : X, p x <-> (exists m : nat, x el L m)). - -Definition L_enum {X} `{encodable X} (p : X -> Prop) := - exists L, is_computable L /\ lenumerates L p. - -Lemma projection X Y {HX : encodable X} {HY : encodable Y} (p : X * Y -> Prop) : - L_enumerable p -> L_enumerable (fun x => exists y, p (x,y)). -Proof. - intros (f & [cf] & ?). - exists (fun n => match f n with Some (x, y) => Some x | None => None end). - split. - - econstructor. extract. - - intros; split. - + intros [y ?]. eapply H in H0 as [n]. exists n. now rewrite H0. - + intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inv H0. - exists y. eapply H. eauto. -Qed. - -Lemma L_enumerable_ext X `{encodable X} p q : L_enumerable p -> (forall x : X, p x <-> q x) -> L_enumerable q. -Proof. - intros (f & cf & Hf) He. exists f; split; eauto. - intros ?. rewrite <- He. eapply Hf. -Qed. - -Definition F1 {X} (T : nat -> list X) := (fun n => let (n, m) := Cantor.of_nat n in nth_error (T n) m). - -#[global] -Instance term_F1 {X} {H : encodable X} : @computable ((nat -> list X) -> nat -> option X) ((! nat ~> ! list X) ~> ! nat ~> ! option X) (@F1 X). -Proof. - extract. -Qed. - -Lemma L_enumerable_enum {X} `{encodable X} (p : X -> Prop) : - L_enum p -> L_enumerable p. -Proof. - intros (f & [cf] & Hf). - exists (F1 f). split. - - econstructor. extract. - - destruct Hf as [CX HX]. - intros x. unfold F1. - now rewrite list_enumerator_to_enumerator. -Qed. - -Lemma L_enumerable_halt {X} `{encodable X} (p : X -> Prop) : - L_decidable (X := X * X) (fun '(x,y) => x = y) -> - L_enumerable p -> p ⪯ converges. -Proof. - intros (d & [c_d] & H_d) (f & [c_f] & H_f). - edestruct L_enumerable_recognisable with (p := p) (d := fun x y => d (x,y)) (f := f); eauto. - - extract. - - intros. specialize (H_d (x,y)). destruct (d (x,y)); intuition (auto with bool). - - now exists (fun x0 => L.app x (enc x0)). -Qed. - -Import L_Notations. - -Lemma L_recognisable'_recognisable {X} `{encodable X} (p : X -> Prop) : - L_recognisable p -> L_recognisable' p. -Proof. - intros (f & [c_f] & H_f). - exists (lam (mu (lam (ext f 1 0)))). - intros. - assert (((lam (mu (lam ((ext f 1) 0)))) (enc x)) >* mu (lam (ext f (enc x) 0))) by now Lsimpl. - rewrite H0. rewrite mu_spec. - - rewrite H_f. split; intros [n]; exists n. - Lsimpl. now rewrite H1. - eapply enc_extinj. - now assert ((lam (((ext f) (enc x)) 0)) (ext n) == enc (f x n)) as <- by now Lsimpl. - - Lproc. - - intros. exists (f x n). now Lsimpl. -Qed. - -Lemma L_recognisable_halt {X} `{encodable X} (p : X -> Prop) : - L_recognisable p -> p ⪯ converges. -Proof. - intros. eapply L_recognisable'_recognisable in H0 as (f & H_f). now exists (fun x0 => f (enc x0)). -Qed. - -Lemma L_recognisable_HaltL {X} {Hreg : encodable X} (p : X -> Prop) : - L_recognisable p -> p ⪯ HaltL. -Proof. - intros. eapply L_recognisable'_recognisable in H as (f & H_f). exists (fun x0 => f (enc x0)). - intros x. rewrite H_f. unfold converges, HaltL. setoid_rewrite eval_iff. firstorder. - subst. eapply eproc_equiv in H. eauto. -Qed. diff --git a/theories/L/Datatypes/LBool.v b/theories/L/Datatypes/LBool.v deleted file mode 100644 index 5e5f9515c..000000000 --- a/theories/L/Datatypes/LBool.v +++ /dev/null @@ -1,50 +0,0 @@ -From Undecidability.L Require Export Util.L_facts. -From Undecidability.L.Tactics Require Import LTactics GenEncode. -(* ** Encoding of booleans *) - -(* Definition bool_enc (b:bool) : term:= *) -(* Eval simpl in *) -(* if b then .\"t", "f"; "t" else .\"t", "f"; "f". *) - -MetaCoq Run (tmGenEncodeInj "bool_enc" bool). -(* For each encoding, Lrewrite must contain an lemma that solves goals like "encode b s t >* match ...end". The database Lrewrite also calls Lproc to discharge the other assumptions *) -#[export] Hint Resolve bool_enc_correct : Lrewrite. - -#[global] -Instance term_negb : computable negb. -Proof. - extract. -Qed. - -#[global] -Instance term_andb : computable andb. -Proof. - extract. -Qed. - -#[global] -Instance term_orb : computable orb. -Proof. - extract. -Qed. - -Definition OmegaLift := lam Omega. - -Lemma OmegaLift_proc : proc OmegaLift. -Proof. unfold OmegaLift. Lproc. Qed. -#[export] Hint Resolve OmegaLift_proc : LProc. - -Import L_Notations. - -Definition trueOrDiverge := lam (var 0 I OmegaLift I). - -Lemma trueOrDiverge_proc : proc trueOrDiverge. -Proof. unfold trueOrDiverge. Lproc. Qed. -#[export] Hint Resolve trueOrDiverge_proc : LProc. - -Lemma trueOrDiverge_true : trueOrDiverge (enc true) >(4) I. -Proof. - unfold trueOrDiverge. cbv - [pow]. Lsimpl. -Qed. - -#[export] Hint Resolve trueOrDiverge_true : Lrewrite. diff --git a/theories/L/Datatypes/LFinType.v b/theories/L/Datatypes/LFinType.v deleted file mode 100644 index 58cbb8978..000000000 --- a/theories/L/Datatypes/LFinType.v +++ /dev/null @@ -1,43 +0,0 @@ -From Undecidability.L.Tactics Require Import LTactics GenEncode. -From Undecidability.L Require Import Datatypes.LNat Functions.EqBool. - -Import Nat. -Require Export Undecidability.Shared.Libs.PSL.FiniteTypes.FinTypes. - -(* *** Encoding finite types *) -(* This is not an instance because we only want it for very specific types. *) -Definition encodable_finType `{X : finType} : encodable X. -Proof. - eapply (registerAs index). -Defined. (*because registerAs*) - -Definition finType_eqb {X:finType} (x y : X) := - Nat.eqb (index x) (index y). - -Lemma finType_eqb_reflect (X:finType) (x y:X) : reflect (x = y) (finType_eqb x y). -Proof. - unfold finType_eqb. destruct (Nat.eqb_spec (index x) (index y));constructor. - -now apply injective_index. - -congruence. -Qed. - -Section finType_eqb. - Local Existing Instance encodable_finType. - - Global Instance term_index (F:finType): computable (@index F). - Proof. - apply cast_computable. - Qed. - - Local Instance eqbFinType_inst (X:finType): eqbClass finType_eqb (X:=X). - Proof. - intros ? ?. eapply finType_eqb_reflect. - Qed. - - Global Instance eqbFinType (X:finType): eqbComp X. - Proof. - constructor. unfold finType_eqb. - extract. - Qed. - -End finType_eqb. diff --git a/theories/L/Datatypes/LNat.v b/theories/L/Datatypes/LNat.v deleted file mode 100644 index 7b93bde28..000000000 --- a/theories/L/Datatypes/LNat.v +++ /dev/null @@ -1,133 +0,0 @@ -From Undecidability.L Require Export Util.L_facts. -From Undecidability.L.Tactics Require Export LTactics GenEncode. -Require Import Undecidability.Shared.Libs.PSL.Numbers. - -Require Import Nat. -From Undecidability.L Require Import Datatypes.LBool Functions.EqBool Datatypes.LProd. -Import GenEncode. Import Nat. -(* ** Encoding of natural numbers *) - -MetaCoq Run (tmGenEncodeInj "nat_enc" nat). -#[export] Hint Resolve nat_enc_correct : Lrewrite. - -#[global] -Instance termT_S : computable S. -Proof. - extract constructor. -Qed. - -#[global] -Instance termT_pred : computable pred. -Proof. - extract. -Qed. - -#[global] -Instance termT_plus' : computable add. -Proof. - extract. -Qed. - -#[global] -Instance termT_mult : computable mult. -Proof. - extract. -Qed. - -#[global] -Instance term_sub : computable Nat.sub. -Proof. - extract. -Qed. - -#[global] -Instance termT_leb : computable leb. -Proof. - extract. -Qed. - -#[global] -Instance term_ltb : computable Nat.ltb. -Proof. - extract. -Qed. - -#[global] -Instance eqbNat_inst : eqbClass Nat.eqb. -Proof. - exact Nat.eqb_spec. -Qed. - -#[global] -Instance eqbComp_nat : eqbComp nat. -Proof. - constructor. unfold Nat.eqb. - extract. -Qed. - -#[global] -Instance termT_nat_min : computable Nat.min. -Proof. - extract. -Qed. - -#[global] -Instance termT_nat_max : computable Nat.max. -Proof. - extract. -Qed. - -#[global] -Instance termT_pow: - computable Init.Nat.pow. -Proof. - extract. -Qed. - - -#[global] -Instance termT_divmod : - computable divmod. -Proof. - extract. -Qed. - -#[global] -Instance termT_modulo : - computable Init.Nat.modulo. -Proof. - extract. -Qed. - -(* now some more encoding-related properties:*) - -Fixpoint nat_unenc (s : term) := - match s with - | lam (lam #1) => Some 0 - | lam (lam (app #0 s)) => match nat_unenc s with Some n => Some (S n) | x=>x end - | _ => None - end. - -Lemma unenc_correct m : (nat_unenc (nat_enc m)) = Some m. -Proof. - induction m; simpl; now try rewrite IHm. -Qed. - -Lemma unenc_correct2 t n : nat_unenc t = Some n -> nat_enc n = t. -Proof with try solve [Coq.Init.Tactics.easy]. - revert n. eapply (size_induction (f := size) (p := (fun t => forall n, nat_unenc t = Some n -> nat_enc n = t))). clear t. intros t IHt n H. - destruct t as [ | | t]. easy. easy. - destruct t as [ | | t]. easy. easy. - destruct t. 3:easy. - -destruct n0. easy. destruct n0. 2:easy. inv H. easy. - -destruct t1. 2-3:easy. destruct n0. 2:easy. simpl in H. destruct (nat_unenc t2) eqn:A. - +apply IHt in A;simpl;try lia. destruct n. inv H. simpl. congruence. - +congruence. -Qed. - -Lemma dec_enc t : dec (exists n, t = nat_enc n). -Proof. - destruct (nat_unenc t) eqn:H. - - left. exists n. now eapply unenc_correct2 in H. - - right. intros [n A]. rewrite A in H. rewrite unenc_correct in H. inv H. -Qed. diff --git a/theories/L/Datatypes/LOptions.v b/theories/L/Datatypes/LOptions.v deleted file mode 100644 index d0ca23418..000000000 --- a/theories/L/Datatypes/LOptions.v +++ /dev/null @@ -1,86 +0,0 @@ -From Undecidability.L Require Import Tactics.LTactics Datatypes.LBool Tactics.GenEncode. -From Undecidability.L Require Import Functions.EqBool. -Import L_Notations. - -(* ** Encoding of option type *) -Section Fix_X. - Variable X:Type. - Context {intX : encodable X}. - - - MetaCoq Run (tmGenEncode "option_enc" (option X)). - Hint Resolve option_enc_correct : Lrewrite. - - Global Instance encInj_option_enc {H : encInj intX} : encInj (encodable_option_enc). - Proof. register_inj. Qed. - - (* now we must register the non-constant constructors*) - - Global Instance term_Some : computable (@Some X). - Proof. - extract constructor. - Defined. (*because next lemma*) - -End Fix_X. - -#[export] Hint Resolve option_enc_correct : Lrewrite. - -Section option_eqb. - - Variable X : Type. - Variable eqb : X -> X -> bool. - Variable spec : forall x y, reflect (x = y) (eqb x y). - - Definition option_eqb (A B : option X) := - match A,B with - | None,None => true - | Some x, Some y => eqb x y - | _,_ => false - end. - - Lemma option_eqb_spec A B : reflect (A = B) (option_eqb A B). - Proof using spec. - destruct A, B; try now econstructor. cbn. - destruct (spec x x0); econstructor; congruence. - Qed. -End option_eqb. - -Section int. - - Variable X:Type. - Context {HX : encodable X}. - - Global Instance term_option_eqb : computable (@option_eqb X). - Proof. - extract. - Qed. - - Global Instance eqbOption f `{eqbClass (X:=X) f}: - eqbClass (option_eqb f). - Proof. - intros ? ?. eapply option_eqb_spec. all:eauto using eqb_spec. - Qed. - - Global Instance eqbComp_Option `{H:eqbComp X (R:=HX)}: - eqbComp (option X). - Proof. - constructor. unfold option_eqb. - change (eqb0) with (eqb (X:=X)). - extract. - Qed. - -End int. - -Definition isSome {T} (u : option T) := match u with Some _ => true | _ => false end. - -#[global] -Instance term_isSome {T} `{encodable T} : computable (@isSome T). -Proof. - extract. -Qed. - -#[global] -Instance term_option_map {A B} `{encodable A} `{encodable B} : computable (@option_map A B). -Proof. - extract. -Qed. diff --git a/theories/L/Datatypes/LProd.v b/theories/L/Datatypes/LProd.v deleted file mode 100644 index 1aa21f6c5..000000000 --- a/theories/L/Datatypes/LProd.v +++ /dev/null @@ -1,73 +0,0 @@ -From Undecidability.L Require Export L Tactics.LTactics GenEncode. - -From Undecidability.L.Datatypes Require Import LBool. - -From Undecidability.L Require Import Functions.EqBool GenEncode. -(* -From Undecidability.L Require Import LNat.*) - -(* ** Encoding of pairs *) - -Section Fix_XY. - - Variable X Y:Type. - - Context {intX : encodable X}. - Context {intY : encodable Y}. - - MetaCoq Run (tmGenEncode "prod_enc" (X * Y)). - Hint Resolve prod_enc_correct : Lrewrite. - - Global Instance encInj_prod_enc {H : encInj intX} {H' : encInj intY} : encInj (encodable_prod_enc). - Proof. register_inj. Qed. - - (* now we must register the constructors*) - Global Instance term_pair : computable (@pair X Y). - Proof. - extract constructor. - Qed. - - Global Instance term_fst : computable (@fst X Y). - Proof. - extract. - Qed. - - Global Instance term_snd : computable (@snd X Y). - Proof. - extract. - Qed. - - Definition prod_eqb f g (a b: X*Y):= - let (x1,y1):= a in - let (x2,y2):= b in - andb (f x1 x2) (g y1 y2). - - Lemma prod_eqb_spec f g: - (forall (x1 x2 : X) , reflect (x1 = x2) (f x1 x2)) - -> (forall (y1 y2 : Y) , reflect (y1 = y2) (g y1 y2)) - -> forall x y, reflect (x=y) (prod_eqb f g x y). - Proof with try (constructor;congruence). - intros Hf Hg [x1 y1] [x2 y2]. - specialize (Hf x1 x2); specialize (Hg y1 y2);cbn. - inv Hf;inv Hg;cbn... - Qed. - - Global Instance eqbProd f g `{eqbClass (X:=X) f} `{eqbClass (X:=Y) g}: - eqbClass (prod_eqb f g). - Proof. - intros ? ?. eapply prod_eqb_spec. all:eauto using eqb_spec. - Qed. - - - Global Instance eqbComp_Prod `{eqbComp X (R:=intX)} `{eqbComp Y (R:=intY)}: - eqbComp (X*Y). - Proof. - constructor. unfold prod_eqb. - change (eqb0) with (eqb (X:=X)). - change (eqb1) with (eqb (X:=Y)). - extract. - Qed. - -End Fix_XY. - -#[export] Hint Resolve prod_enc_correct : Lrewrite. diff --git a/theories/L/Datatypes/LSum.v b/theories/L/Datatypes/LSum.v deleted file mode 100644 index eb2966377..000000000 --- a/theories/L/Datatypes/LSum.v +++ /dev/null @@ -1,79 +0,0 @@ -From Undecidability.L Require Import Tactics.LTactics Datatypes.LBool. -From Undecidability.L Require Import Tactics.GenEncode. - -(* ** Encoding of sum type *) -Section Fix_XY. - - Variable X Y:Type. - - Variable intX : encodable X. - Variable intY : encodable Y. - - MetaCoq Run (tmGenEncode "sum_enc" (X + Y)). - Hint Resolve sum_enc_correct : Lrewrite. - - Global Instance encInj_sum_enc {H : encInj intX} {H' : encInj intY} : encInj (encodable_sum_enc). - Proof. register_inj. Qed. - - (* now we must register the non-constant constructors*) - - Global Instance term_inl : computable (@inl X Y). - Proof. - extract constructor. - Qed. - - Global Instance term_inr : computable (@inr X Y). - Proof. - extract constructor. - Qed. - -End Fix_XY. - -#[export] Hint Resolve sum_enc_correct : Lrewrite. - -Section sum_eqb. - - Variable X Y : Type. - Variable eqb__X : X -> X -> bool. - Variable spec__X : forall x y, reflect (x = y) (eqb__X x y). - Variable eqb__Y : Y -> Y -> bool. - Variable spec__Y : forall x y, reflect (x = y) (eqb__Y x y). - - Definition sum_eqb (A B : X + Y) := - match A,B with - | inl a,inl b => eqb__X a b - | inr a,inr b => eqb__Y a b - | _,_ => false - end. - - Lemma sum_eqb_spec A B : reflect (A = B) (sum_eqb A B). - Proof using spec__X spec__Y. - destruct A, B; (try now econstructor);cbn. - -destruct (spec__X x x0); econstructor;congruence. - -destruct (spec__Y y y0); constructor;congruence. - Qed. -End sum_eqb. - -From Undecidability Require Import EqBool. - -Section int. - - Variable X Y:Type. - Context {HX : encodable X} {HY : encodable Y}. - - Global Instance eqbSum f g `{eqbClass (X:=X) f} `{eqbClass (X:=Y) g}: - eqbClass (sum_eqb f g). - Proof. - intros ? ?. eapply sum_eqb_spec. all:eauto using eqb_spec. - Qed. - - Global Instance eqbComp_sum `{H:eqbComp X (R:=HX)} `{H':eqbComp Y (R:=HY)}: - eqbComp (sum X Y). - Proof. - constructor. unfold sum_eqb. - change (eqb0) with (eqb (X:=X)). - change (eqb1) with (eqb (X:=Y)). - extract. - Qed. - -End int. diff --git a/theories/L/Datatypes/LTerm.v b/theories/L/Datatypes/LTerm.v deleted file mode 100644 index 3e67a6058..000000000 --- a/theories/L/Datatypes/LTerm.v +++ /dev/null @@ -1,26 +0,0 @@ -From Undecidability.L.Datatypes Require Export LNat. -From Undecidability.L Require Export Util.L_facts. -From Undecidability.L.Tactics Require Import LTactics GenEncode. - -(* ** Encoding for L-terms *) -MetaCoq Run (tmGenEncodeInj "term_enc" term). -#[export] Hint Resolve term_enc_correct : Lrewrite. - -(* register the non-constant constructors *) -#[global] -Instance term_var : computable var. -Proof. - extract constructor. -Qed. - -#[global] -Instance term_app : computable L.app. -Proof. - extract constructor. -Qed. - -#[global] -Instance term_lam : computable lam. -Proof. - extract constructor. -Qed. diff --git a/theories/L/Datatypes/LUnit.v b/theories/L/Datatypes/LUnit.v deleted file mode 100644 index 4dd7a0b1b..000000000 --- a/theories/L/Datatypes/LUnit.v +++ /dev/null @@ -1,7 +0,0 @@ -From Undecidability.L Require Export Util.L_facts. -From Undecidability.L.Tactics Require Import LTactics GenEncode. -(* * Encodings and extracted basic functions *) -(* ** Encoding of unit *) - -MetaCoq Run (tmGenEncodeInj "unit_enc" unit). -#[export] Hint Resolve unit_enc_correct : Lrewrite. diff --git a/theories/L/Datatypes/LVector.v b/theories/L/Datatypes/LVector.v deleted file mode 100644 index f67e69db1..000000000 --- a/theories/L/Datatypes/LVector.v +++ /dev/null @@ -1,101 +0,0 @@ -From Undecidability.L.Tactics Require Import LTactics GenEncode. -From Undecidability.L.Datatypes Require Import LNat List.List_basics List.List_eqb LFinType. - -Require Import Undecidability.Shared.Libs.PSL.Vectors.Vectors. - -(* *** Encoding vectors *) - -#[global] -Instance register_vector X `{encodable X} n : encodable (Vector.t X n). -Proof. - apply (registerAs VectorDef.to_list). (* - intros x. induction x. - - intros y. pattern y. revert y. eapply VectorDef.case0. cbn. reflexivity. - - intros y. clear H. revert h x IHx. pattern n, y. revert n y. - eapply Vector.caseS. intros h n y h0 x IHx [=]. - subst. f_equal. eapply IHx. eassumption. *) -Defined. (*because registerAs*) - - -Lemma enc_vector_eq X `{encodable X} m (x:Vector.t X m): - enc x = enc (Vector.to_list x). -Proof. - reflexivity. -Qed. - -#[global] -Instance term_to_list X `{encodable X} n : computable (Vector.to_list (A:=X) (n:=n)). -Proof. - apply cast_computable. -Qed. - -Import Vector. -#[global] -Instance term_vector_map X Y `{encodable X} `{encodable Y} n (f:X->Y) : - computable f -> - computable (VectorDef.map f (n:=n)). -Proof. - intros ?. - computable_casted_result. - apply computableExt with (x:= fun x => List.map f (Vector.to_list x)). - 2:{ - extract. - } - - cbn. intros x. - clear - x. - induction n. revert x. apply VectorDef.case0. easy. revert IHn. apply Vector.caseS' with (v:=x). - intros. cbn. f_equal. fold (Vector.fold_right (A:=X) (B:=Y)). - setoid_rewrite IHn. reflexivity. -Qed. - -Global -Instance term_map2 n A B C `{encodable A} `{encodable B} `{encodable C} (g:A -> B -> C) : - computable g -> computable (Vector.map2 g (n:=n)). -Proof. - intros ?. - computable_casted_result. - pose (f:=(fix f t a : list C:= - match t,a with - t1::t,a1::a => g t1 a1 :: f t a - | _,_ => [] - end)). - assert (computable f). - {subst f; extract. } - - - apply computableExt with (x:= fun t a => f (Vector.to_list t) (Vector.to_list a)). - 2:{extract. } - induction n;cbn. - -do 2 destruct x using Vector.case0. reflexivity. - -destruct x using Vector.caseS'. destruct x0 using Vector.caseS'. - cbn. f_equal. apply IHn. -Qed. - - -#[global] -Instance term_vector_eqb X `{encodable X} (n' m:nat) (eqb:X->X->bool) : - computable eqb -> - computable (VectorEq.eqb eqb (A:=X) (n:=n') (m:=m)). -Proof. - intros ?. - apply computableExt with (x:=(fun x y => list_eqb eqb (Vector.to_list x) (Vector.to_list y))). - 2:{extract. } - intros v v'. hnf. - induction v in n',v'|-*;cbn;destruct v';cbn;try tauto. rewrite <- IHv. f_equal. -Qed. - -From Undecidability.L Require Import Functions.EqBool. - -Global Instance eqbVector X eqbx `{eqbClass (X:=X) eqbx} n: - eqbClass (VectorEq.eqb eqbx (n:=n) (m:=n)). -Proof. - intros ? ?. apply iff_reflect. symmetry. apply Vector.eqb_eq. symmetry. apply reflect_iff. eauto. -Qed. - -Global Instance eqbComp_List X `{encodable X} `{eqbComp X (R:=_)} n: - eqbComp (Vector.t X n). -Proof. - constructor. apply term_vector_eqb. - apply comp_eqb. -Qed. diff --git a/theories/L/Datatypes/List/List_basics.v b/theories/L/Datatypes/List/List_basics.v deleted file mode 100644 index 306fcb235..000000000 --- a/theories/L/Datatypes/List/List_basics.v +++ /dev/null @@ -1,46 +0,0 @@ -From Undecidability.L.Tactics Require Import LTactics. -From Undecidability.L.Datatypes Require Export List.List_enc LBool LNat. - -#[global] -Instance termT_append X {intX : encodable X} : computable (@List.app X). -Proof. - extract. -Qed. - - -#[global] -Instance term_map (X Y:Type) (Hx : encodable X) (Hy:encodable Y): computable (@map X Y). -Proof. - extract. -Qed. - - -#[global] -Instance termT_rev_append X `{encodable X}: computable (@rev_append X). -Proof. -extract. -Qed. - -#[global] -Instance termT_rev X `{encodable X}: computable (@rev X). -Proof. -eapply computableExt with (x:= fun l => rev_append l []). -{intro. rewrite rev_alt. reflexivity. } -extract. -Qed. - -Section Fix_X. - Variable (X:Type). - Context {intX : encodable X}. - - Global Instance term_filter_notime: computable (@filter X). - Proof using intX. - extract. - Qed. - - Global Instance term_repeat: computable (@repeat X). - Proof using intX. - extract. - Qed. - -End Fix_X. diff --git a/theories/L/Datatypes/List/List_enc.v b/theories/L/Datatypes/List/List_enc.v deleted file mode 100644 index ae8a662f6..000000000 --- a/theories/L/Datatypes/List/List_enc.v +++ /dev/null @@ -1,22 +0,0 @@ -From Undecidability.L.Tactics Require Import LTactics GenEncode. - -(* ** Encoding of lists *) - -Section Fix_X. - Variable (X:Type). - Context {intX : encodable X}. - - MetaCoq Run (tmGenEncode "list_enc" (list X)). - - Global Instance encInj_list_enc {H : encInj intX} : encInj (encodable_list_enc). - Proof. register_inj. Qed. - - (* now we must register the non-constant constructors*) - - Global Instance termT_cons : computable (@cons X). - Proof. - extract constructor. - Qed. -End Fix_X. - -#[export] Hint Resolve list_enc_correct : Lrewrite. diff --git a/theories/L/Datatypes/List/List_eqb.v b/theories/L/Datatypes/List/List_eqb.v deleted file mode 100644 index 75478b8e2..000000000 --- a/theories/L/Datatypes/List/List_eqb.v +++ /dev/null @@ -1,69 +0,0 @@ -From Undecidability.L.Tactics Require Import LTactics. -From Undecidability.L Require Import Functions.EqBool. - -From Undecidability.L.Datatypes Require Export List.List_enc LBool LOptions LNat. - -Section Fix_X. - Variable (X:Type). - Context {intX : encodable X}. - - Fixpoint inb eqb (x:X) (A: list X) := - match A with - nil => false - | a::A' => orb (eqb a x) (inb eqb x A') - end. - - Variable X_eqb : X -> X -> bool. - Hypothesis X_eqb_spec : (forall (x y:X), Bool.reflect (x=y) (X_eqb x y)). - - Global Instance term_inb: computable inb. - Proof. - extract. - Qed. - -End Fix_X. - -Section list_eqb. - - Variable X : Type. - Variable eqb : X -> X -> bool. - Variable spec : forall x y, reflect (x = y) (eqb x y). - - Fixpoint list_eqb A B := - match A,B with - | nil,nil => true - | a::A',b::B' => eqb a b && list_eqb A' B' - | _,_ => false - end. - - Lemma list_eqb_spec A B : reflect (A = B) (list_eqb A B). - Proof using spec. - revert B; induction A; intros; destruct B; cbn in *; try now econstructor. - destruct (spec a x), (IHA B); cbn; econstructor; congruence. - Qed. - -End list_eqb. - -Section int. - - Context {X : Type}. - Context {HX : encodable X}. - - Global Instance term_list_eqb : computable (list_eqb (X:=X)). - Proof. - extract. - Qed. - - Global Instance eqbList f `{eqbClass (X:=X) f}: - eqbClass (list_eqb f). - Proof. - intros ? ?. eapply list_eqb_spec. all:eauto using eqb_spec. - Qed. - Import EqBool. - Global Instance eqbComp_List `{eqbComp X (R:=HX)}: - eqbComp (list X). - Proof. - constructor. unfold list_eqb. - extract. - Qed. -End int. diff --git a/theories/L/Datatypes/List/List_extra.v b/theories/L/Datatypes/List/List_extra.v deleted file mode 100644 index b6cd7be04..000000000 --- a/theories/L/Datatypes/List/List_extra.v +++ /dev/null @@ -1,26 +0,0 @@ -From Undecidability.L.Tactics Require Import LTactics. -From Undecidability.L.Datatypes Require Export List_enc List_in List_basics LBool LNat. - -(* seq *) -#[global] -Instance term_seq : computable seq. -Proof. - extract. -Qed. - -(* prodLists *) -Section fixprodLists. - Variable (X Y : Type). - Context `{Xint : encodable X} `{Yint : encodable Y}. - - Global Instance term_prodLists : computable (@list_prod X Y). - Proof. - apply computableExt with (x := fix rec (A : list X) (B : list Y) : list (X * Y) := - match A with - | [] => [] - | x :: A' => map (@pair X Y x) B ++ rec A' B - end). - 1: { unfold list_prod. change (fun x => ?h x) with h. intros l1 l2. induction l1; easy. } - extract. - Qed. -End fixprodLists. diff --git a/theories/L/Datatypes/List/List_in.v b/theories/L/Datatypes/List/List_in.v deleted file mode 100644 index db6347d5c..000000000 --- a/theories/L/Datatypes/List/List_in.v +++ /dev/null @@ -1,53 +0,0 @@ -From Undecidability.L.Tactics Require Import LTactics. -From Undecidability.L Require Import Functions.EqBool. - -From Undecidability.L.Datatypes Require Export List.List_enc. - -Section list_in. - Variable (X : Type). - Variable (eqb : X -> X -> bool). - Variable eqb_correct : forall a b, a = b <-> eqb a b = true. - - Definition list_in_decb := fix rec (l : list X) (x : X) : bool := - match l with [] => false - | (l :: ls) => eqb l x || rec ls x - end. - - Lemma list_in_decb_iff (l : list X) : forall x, list_in_decb l x = true <-> x el l. - Proof using eqb_correct. - intros x. induction l. - - cbn. firstorder. - - split. - + intros [H1 | H1]%orb_true_elim. left. now apply eqb_correct. - apply IHl in H1. now right. - + intros [H | H]. - cbn. apply orb_true_intro; left; now apply eqb_correct. - cbn. apply orb_true_intro; right; now apply IHl. - Qed. - - Fixpoint list_incl_decb (a b : list X) := - match a with - | [] => true - | (x::a) => list_in_decb b x && list_incl_decb a b - end. - - -End list_in. - -Section list_in_time. - Variable (X : Type). - Context {H : encodable X}. - Context (eqbX : X -> X -> bool). - Context {Xeq : eqbClass eqbX}. - Context {XeqbComp : eqbComp X}. - - Global Instance term_list_in_decb : computable (@list_in_decb X eqbX). - Proof using XeqbComp Xeq. - extract. - Qed. - - Global Instance term_list_incl_decb : computable (@list_incl_decb X eqbX). - Proof using XeqbComp Xeq. - extract. - Qed. -End list_in_time. diff --git a/theories/L/Datatypes/List/List_nat.v b/theories/L/Datatypes/List/List_nat.v deleted file mode 100644 index 2aa8c18ae..000000000 --- a/theories/L/Datatypes/List/List_nat.v +++ /dev/null @@ -1,22 +0,0 @@ -From Undecidability.L.Tactics Require Import LTactics. -From Undecidability.L.Datatypes Require Export List.List_enc LNat LOptions. - -#[global] -Instance termT_nth_error (X:Type) (Hx : encodable X): computable (@nth_error X). -Proof. - extract. -Qed. - -#[global] -Instance termT_length X `{encodable X} : computable (@length X). -Proof. -extract. -Qed. - -#[global] -Instance term_nth X (Hx : encodable X) : computable (@nth X). -Proof. - extract. -Qed. - - diff --git a/theories/L/Datatypes/Lists.v b/theories/L/Datatypes/Lists.v deleted file mode 100644 index e224b71fa..000000000 --- a/theories/L/Datatypes/Lists.v +++ /dev/null @@ -1,3 +0,0 @@ -(* ** Encoding of lists *) - -From Undecidability.L.Datatypes.List Require Export List_basics List_eqb List_extra List_in List_nat List_enc. diff --git a/theories/L/Functions/Ackermann.v b/theories/L/Functions/Ackermann.v deleted file mode 100644 index 76de2992d..000000000 --- a/theories/L/Functions/Ackermann.v +++ /dev/null @@ -1,18 +0,0 @@ -From Undecidability.L Require Import Datatypes.LNat Tactics.LTactics. - -(* ** Computability of Ackermann *) - -Fixpoint ackermann n : nat -> nat := - match n with - 0 => S - | S n => fix ackermann_Sn m : nat := - match m with - 0 => (fun _ => ackermann n 1) - | S m => (fun _ => ackermann n (ackermann_Sn m)) - end true - end. - -Lemma term_ackermann : computable ackermann. -Proof. - extract. -Qed. diff --git a/theories/L/Functions/Encoding.v b/theories/L/Functions/Encoding.v deleted file mode 100644 index 96393e618..000000000 --- a/theories/L/Functions/Encoding.v +++ /dev/null @@ -1,58 +0,0 @@ -From Undecidability.L.Tactics Require Import LTactics. -From Undecidability.L.Datatypes Require Import LNat LTerm LBool LProd List.List_enc LOptions. - -(* ** Extracted encoding of natural numbers *) - -#[global] -Instance term_nat_enc : computable (enc (X:= nat)). -Proof. - unfold enc;cbn. extract. -Qed. - -(* ** Extracted term encoding *) - -#[global] -Instance term_term_enc : computable (enc (X:=term)). -Proof. - unfold enc;cbn. extract. -Qed. - - - -#[global] -Instance bool_enc :computable (enc (X:=bool)). -Proof. - unfold enc;cbn. extract. -Qed. - -(* ** Extracted tuple encoding *) - -#[global] -Instance term_prod_enc X Y (R1:encodable X) (R2:encodable Y) - {HX : computable (enc (X := X))} {HY : computable (enc (X := Y))} - :computable (enc (X:=X*Y)). -Proof. - unfold enc;cbn. - extract. -Qed. - - -#[global] -Instance term_list_enc X (R:encodable X) - {HX : computable (enc (X := X))} - :computable (enc (X:=list X)). -Proof. - unfold enc;cbn. - extract. -Qed. - -Import LOptions. - -#[global] -Instance term_option_enc X (R:encodable X) - {HX : computable (enc (X := X))} - :computable (enc (X:=option X)). -Proof. - unfold enc;cbn. - extract. -Qed. diff --git a/theories/L/Functions/EqBool.v b/theories/L/Functions/EqBool.v deleted file mode 100644 index 77c92981a..000000000 --- a/theories/L/Functions/EqBool.v +++ /dev/null @@ -1,50 +0,0 @@ -From Undecidability.L Require Import L Tactics.LTactics LBool. - -Class eqbClass X (eqb : X -> X -> bool): Type := - _eqb_spec : forall (x y:X), reflect (x=y) (eqb x y). - -#[export] Hint Mode eqbClass + -: typeclass_instances. (* treat argument as input and force evar-freeness*) - -Definition eqb X eqb `{H:eqbClass (X:=X) eqb} := eqb. - -Arguments eqb {_ _ _}: simpl never. - -Lemma eqb_spec {X} {f : X -> X -> bool} {_:eqbClass f}: - forall (x y:X), reflect (x=y) (eqb x y). -Proof. - intros. eapply _eqb_spec. -Qed. - -#[global] -Instance eqbBool_inst : eqbClass Bool.eqb. -Proof. - intros ? ?. eapply iff_reflect. rewrite eqb_true_iff. reflexivity. -Qed. - -Lemma dec_reflect_remove {P Y} (d:dec P) b (H:reflect P b) (y y' : Y): - (if d then y else y') = (if b then y else y'). -Proof. - destruct H,d;easy. -Qed. - -Lemma eqDec_remove {X Y eqb} {H:eqbClass (X:=X) eqb} x x' (d:dec (x=x')) (a b : Y): - (if d then a else b) = (if eqb x x' then a else b). -Proof. - apply dec_reflect_remove. eapply eqb_spec. -Qed. - -Class eqbComp X {R:encodable X} eqb {H:eqbClass (X:=X) eqb} := - { comp_eqb : computable eqb }. -Arguments eqbComp _ {_ _ _}. - -#[export] Hint Mode eqbComp + - - -: typeclass_instances. - -#[global] -Existing Instance comp_eqb. - -#[global] -Instance eqbComp_bool : eqbComp bool. -Proof. - constructor. unfold Bool.eqb. - extract. -Qed. diff --git a/theories/L/Functions/Equality.v b/theories/L/Functions/Equality.v deleted file mode 100644 index c367c425f..000000000 --- a/theories/L/Functions/Equality.v +++ /dev/null @@ -1,38 +0,0 @@ -From Undecidability.L Require Export Datatypes.LBool Datatypes.LNat Datatypes.LTerm. -Require Import Nat. -From Undecidability.L Require Import Tactics.LTactics Functions.EqBool. -Import EqBool. -(* * Extracted Functions *) - - -(* ** Extracted equality of encoded terms *) - -Fixpoint term_eqb s t := - match s,t with - | var n, var m => eqb n m - | L.app s1 t1, L.app s2 t2 => andb (term_eqb s1 s2) (term_eqb t1 t2) - | lam s',lam t' => term_eqb s' t' - | _,_ => false - end. - -Lemma term_eqb_spec : forall x y1 : term, reflect (x = y1) (term_eqb x y1). -Proof with try (constructor;congruence). - induction x;cbn; destruct y1... - - destruct (eqb_spec n n0)... - -destruct (IHx1 y1_1)... - destruct (IHx2 y1_2)... - -destruct (IHx y1)... -Qed. - -#[global] -Instance eqbTerm : eqbClass term_eqb. -Proof. - exact term_eqb_spec. -Qed. - -Global -Instance eqbComp_nat : eqbComp term. -Proof. - constructor. unfold term_eqb. - extract. -Qed. diff --git a/theories/L/Functions/Eval.v b/theories/L/Functions/Eval.v deleted file mode 100644 index d40bf0ece..000000000 --- a/theories/L/Functions/Eval.v +++ /dev/null @@ -1,86 +0,0 @@ -From Undecidability.L Require Export Functions.Subst Computability.Seval Computability.MuRec Datatypes.LOptions Datatypes.LTerm. - -(* ** Extracted step-indexed L-interpreter *) - -#[global] -Instance term_eva : computable eva. -Proof. - extract. -Qed. - -(* ** Computability of full evaluation *) - -Definition doesHaltIn := fun u n => match eva n u with None => false | _ => true end. - -#[global] -Instance term_doesHaltIn : computable doesHaltIn. -Proof. - extract. -Qed. - -Section hoas. Import HOAS_Notations. -Definition Eval :term := Eval cbn in - convert(λ u, !!(ext eva) - (!!mu (λ n, !!(ext doesHaltIn) u n)) u !!I !!I). -End hoas. - -Import L_Notations. - -Lemma Eval_correct (s v:term) : lambda v -> (Eval (ext s) == v <-> exists (n:nat) (v':term), (ext eva) (ext n) (ext s) == ext (Some v') /\ v = ext v' /\ lambda v'). -Proof. - intros lv. unfold Eval. split. - -intros H. LsimplHypo. evar (c:term). - assert (C:converges c). exists v. split. exact H. Lproc. subst c. apply app_converges in C as [C _]. - apply app_converges in C as [C _]. apply app_converges in C as [C _]. apply app_converges in C as [_ C]. - destruct C as [w [R lw]]. - rewrite R in H. - apply mu_sound in R as [n [ eq [R _]]];try Lproc. - +subst w. LsimplHypo. Lrewrite in H. Lrewrite in R. apply enc_extinj in R. unfold doesHaltIn in R. destruct (eva n) eqn:eq. - *exists n,t. split. Lsimpl. now rewrite eq. split. apply unique_normal_forms;[Lproc..|]. - rewrite <- H. unfold I. clear H. now Lsimpl. eapply eva_lam. eauto. - *congruence. - +intros. eexists. Lsimpl. reflexivity. - -intros [n [v' [H [eq lv']]]]. subst v. Lrewrite in H. Lsimpl. - apply enc_extinj in H. destruct mu_complete with (P:=(lam ((ext doesHaltIn) (ext s) 0))) (n:=n);try Lproc. - +intros n0. destruct (eva n0 s) eqn:eq;eexists; Lsimpl;reflexivity. - + Lsimpl. unfold doesHaltIn. rewrite H. reflexivity. - +rewrite H0. Lsimpl. apply mu_sound in H0. 2,4:Lproc. - * destruct H0 as [n' [eq [R _]]]. apply inj_enc in eq. subst. LsimplHypo. - Lrewrite in R. apply enc_extinj in R. unfold doesHaltIn in R. destruct (eva n' s) eqn:eq. 2:congruence. - Lsimpl. apply eva_equiv in H. assert (lambda t) by now apply eva_lam in eq. apply eva_equiv in eq. rewrite H in eq. unfold I. - apply unique_normal_forms in eq;[|Lproc..]. subst. reflexivity. - *intros n0. eexists; Lsimpl. reflexivity. -Qed. - -Lemma seval_Eval n (s t:term): seval n s t -> Eval (ext s) == (ext t). -Proof. - intros. apply seval_eva in H. - rewrite Eval_correct;try Lproc. exists n,t. repeat split. - -Lsimpl. rewrite H. reflexivity. - -apply eva_lam in H. Lproc. -Qed. - -Lemma eval_Eval s t : eval s t -> Eval (ext s) == (ext t). -Proof. - intros H. eapply eval_seval in H. destruct H. eapply seval_Eval. eassumption. -Qed. - -Lemma Eval_eval (s t : term) : lambda t -> Eval (ext s) == t -> exists t', ext t' = t /\ eval s t'. -Proof with Lproc. - intros p H. rewrite Eval_correct in H;try Lproc. destruct H as [n [v [R [eq lv]]]]. subst t. - eexists. split. reflexivity. Lrewrite in R. apply enc_extinj in R. apply eva_equiv in R. split. apply equiv_lambda;try Lproc. assumption. assumption. -Qed. - -Lemma eval_converges s : converges s -> exists t, eval s t. -Proof. - intros [x [R ?]]. exists x. eauto using equiv_lambda. -Qed. - -Lemma Eval_converges s : converges s <-> converges (Eval (ext s)). -Proof with eauto. - split; intros H. - - destruct (eval_converges H) as [t Ht]. - pose proof (eval_Eval Ht) as He. - rewrite He. eexists;split;[reflexivity|Lproc]. - - destruct H as [x [H l]]. apply Eval_eval in H;try Lproc. destruct H as [t' [? t]]. exists t'. destruct t. split. now rewrite H0. auto. -Qed. diff --git a/theories/L/Functions/FinTypeLookup.v b/theories/L/Functions/FinTypeLookup.v deleted file mode 100644 index 3b8a3917b..000000000 --- a/theories/L/Functions/FinTypeLookup.v +++ /dev/null @@ -1,56 +0,0 @@ -From Undecidability.L.Tactics Require Import LTactics. -From Undecidability.L.Datatypes Require Import LFinType LBool LProd. -From Undecidability.L.Datatypes.List Require Export List_basics. -From Undecidability.L.Functions Require Import EqBool. - -Section Lookup. - Variable X Y : Type. - Context {eqbX : X -> X -> bool}. - Context `{eqbClass X eqbX}. - - Fixpoint lookup (x:X) (A:list (X*Y)) d: Y := - match A with - [] => d - | (key,Lproc)::A => - if eqb x key then Lproc else lookup x A d - end. - - Context `{encodable X} `{@eqbComp X _ eqbX _}. - - Global Instance term_lookup `{encodable Y}: - computable (lookup). - Proof using H1. - unfold lookup. unfold eqb. - extract. - Qed. - -End Lookup. - -Section funTable. - - Variable X : finType. - Variable Y : Type. - Variable f : X -> Y. - - Definition funTable := - map (fun x => (x,f x)) (elem X). - - - Variable (eqbX : X -> X -> bool). - Context `{eqbClass X eqbX}. - - Lemma lookup_funTable x d: - lookup x funTable d = f x. - Proof. - unfold funTable. - specialize (elem_spec x). - generalize (elem X) as l. - induction l;cbn;intros Hel. - -tauto. - -destruct (eqb_spec x a). - +congruence. - +destruct Hel. 1:congruence. - eauto. - Qed. - -End funTable. diff --git a/theories/L/Functions/Proc.v b/theories/L/Functions/Proc.v deleted file mode 100644 index 973d81eaa..000000000 --- a/theories/L/Functions/Proc.v +++ /dev/null @@ -1,80 +0,0 @@ -From Undecidability.L Require Import Computability.Decidability Datatypes.LNat Datatypes.LTerm L. -Require Import Nat. - -(* ** Decidabiity of closedness, boundedness and procness *) - -Fixpoint boundb (k : nat) (t : term) : bool := -match t with -| var n => negb (k <=? n) -| app s t => andb (boundb k s) (boundb k t) -| lam s => boundb (S k) s -end. - - -#[global] -Instance term_boundb : computable boundb. -Proof. - extract. -Qed. - -Lemma boundb_spec k t : Bool.reflect (bound k t) (boundb k t). -Proof. - revert k. induction t;intros;cbn. simpl. - -destruct (Nat.leb_spec0 k n); simpl;constructor. intros H. inv H. lia. constructor. lia. - -specialize (IHt1 k). specialize (IHt2 k). inv IHt1;simpl. - +inv IHt2;constructor. - *now constructor. - *intros C. now inv C. - +constructor. intros C. now inv C. - -specialize (IHt (S k)). inv IHt;constructor. - +now constructor. - +intros C. now inv C. -Qed. - -Definition closedb := boundb 0. - -Lemma closedb_spec s : Bool.reflect (closed s) (closedb s). -Proof. - unfold closedb. - destruct (boundb_spec 0 s);constructor; rewrite closed_dcl;auto. -Qed. - -#[global] -Instance termT_closedb : computable closedb. -Proof. - change closedb with (fun x => boundb 0 x). - extract. -Qed. - - -Definition lambdab (t : term) : bool := -match t with -| lam _ => true -| _ => false -end. - -#[global] -Instance term_lambdab : computable lambdab. -Proof. - extract. -Qed. - -Lemma lambdab_spec t : Bool.reflect (lambda t) (lambdab t). -Proof. - destruct t;constructor;[intros H;inv H;congruence..|auto]. -Qed. - -Lemma ldec_lambda : ldec lambda. -Proof. - apply (dec_ldec lambdab). apply lambdab_spec. -Qed. - -Lemma ldec_closed : ldec closed. -Proof. - apply (dec_ldec closedb). apply closedb_spec. -Qed. - -Lemma ldec_proc : ldec proc. -Proof. - apply ldec_conj. apply ldec_closed. apply ldec_lambda. -Qed. diff --git a/theories/L/Functions/Subst.v b/theories/L/Functions/Subst.v deleted file mode 100644 index fc815cd40..000000000 --- a/theories/L/Functions/Subst.v +++ /dev/null @@ -1,11 +0,0 @@ -From Undecidability.L Require Import Tactics.LTactics. -From Undecidability.L.Datatypes Require Import LNat LTerm LBool. - - -(* ** Extracted substitution on terms *) -Global -Instance term_substT : - computable subst. -Proof. - extract. -Qed. diff --git a/theories/L/Reductions/H10_to_L.v b/theories/L/Reductions/H10_to_L.v deleted file mode 100644 index 8b08e3e40..000000000 --- a/theories/L/Reductions/H10_to_L.v +++ /dev/null @@ -1,261 +0,0 @@ -From Undecidability.H10 Require Import H10 dio_single dio_logic. -Require Import Undecidability.PCP.Util.PCP_facts. -Require Import Undecidability.Shared.Libs.PSL.FiniteTypes. -From Undecidability.Synthetic Require Export DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts. -From Undecidability.L.Datatypes Require Import LNat LProd. -From Undecidability.L Require Import Tactics.LTactics Computability.MuRec Computability.Synthetic Tactics.GenEncode. -From Undecidability.Shared.Libs.DLW.Vec Require Import pos. -From Undecidability.L.Datatypes.List Require Import List_basics List_extra. - -Local Ltac in_app n := - (match goal with - | [ |- In _ (_ ++ _) ] => - match n with - | 0 => idtac - | 1 => eapply in_app_iff; left - | S ?n => eapply in_app_iff; right; in_app n - end - end) || (repeat (try right; eapply in_app_iff; right)). - -Require Import Nat Datatypes. - -(* * Diophantine Equations *) - -Inductive poly : Set := - poly_cnst : nat -> poly - | poly_var : nat -> poly - | poly_add : poly -> poly -> poly - | poly_mul : poly -> poly -> poly. - -MetaCoq Run (tmGenEncode "enc_poly" poly). -#[export] Hint Resolve enc_poly_correct : Lrewrite. - -#[export] -Instance term_poly_cnst: computable poly_cnst. Proof. extract constructor. Qed. -#[export] -Instance term_poly_var : computable poly_var. Proof. extract constructor. Qed. -#[export] -Instance term_poly_add : computable poly_add. Proof. extract constructor. Qed. -#[export] -Instance term_poly_mul : computable poly_mul. Proof. extract constructor. Qed. - -Fixpoint eval (p : poly) (L : list nat) := - match p with - | poly_cnst n => n - | poly_var n => nth n L 0 - | poly_add p1 p2 => eval p1 L + eval p2 L - | poly_mul p1 p2 => eval p1 L * eval p2 L - end. -#[export] -Instance term_eval : computable eval. Proof. extract. Qed. - -Definition poly_add' '(x,y) : poly := poly_add x y. -#[export] -Instance term_poly_add' : computable poly_add'. Proof. extract. Qed. - -Definition poly_mul' '(x,y) : poly := poly_mul x y. -#[export] -Instance term_poly_mul' : computable poly_mul'. Proof. extract. Qed. - -Fixpoint L_poly n : list (poly) := - match n with - | 0 => [] - | S n => L_poly n ++ map poly_cnst (L_nat n) - ++ map poly_var (L_nat n) - ++ map poly_add' (list_prod (L_poly n) (L_poly n)) - ++ map poly_mul' (list_prod (L_poly n) (L_poly n)) - end. - -#[export] -Instance term_L_poly : computable L_poly. Proof. extract. Qed. - -#[export] -Instance enum_poly : - list_enumerator__T L_poly poly. -Proof. - intros p. induction p. - + destruct (el_T n) as [m]. - exists (1 + m). cbn. in_app 2. apply in_map_iff. eauto. - + destruct (el_T n) as [m]. - exists (1 + m). cbn. in_app 3. apply in_map_iff. eauto. - + destruct IHp1 as [m1]. destruct IHp2 as [m2]. - exists (1 + m1 + m2). cbn. in_app 4. apply in_map_iff. exists (p1, p2). split; [reflexivity|]. - apply in_prod_iff. split; eapply cum_ge'; eauto; lia. - + destruct IHp1 as [m1]. destruct IHp2 as [m2]. - exists (1 + m1 + m2). cbn. in_app 5. apply in_map_iff. exists (p1, p2). split; [reflexivity|]. - apply in_prod_iff. split; eapply cum_ge'; eauto; lia. -Defined. (* because instance *) - -Fixpoint conv n (p : dio_single.dio_polynomial (pos n) (pos 0)) : poly. -Proof. - destruct p as [ | p | p | ]. - - exact (poly_cnst n0). - - exact (poly_var (pos.pos2nat p)). - - invert pos p. - - destruct d. - + exact (poly_add (conv _ p1) (conv _ p2)). - + exact (poly_mul (conv _ p1) (conv _ p2)). -Defined. (* because term *) - -Fixpoint L_from (n : nat) : (pos n -> nat) -> list nat. -Proof. - intros phi. destruct n. - - exact []. - - refine (_ :: L_from _ _)%list. - + exact (phi pos.pos_fst). - + intros. eapply phi. econstructor 2. exact H. -Defined. (* because term *) - - -Lemma L_nth n phi (p : pos n) : nth (pos2nat p) (L_from phi) 0 = phi p. -Proof. - induction n. - - invert pos p. - - cbn. invert pos p. - + cbn. now rewrite pos.pos2nat_fst. - + now rewrite pos.pos2nat_nxt, IHn. -Qed. - -Lemma phi_to_L n : forall phi, forall p, dp_eval phi (fun _ => 0) p = eval (@conv n p) (L_from phi). -Proof. - induction p; cbn. - - reflexivity. - - now rewrite L_nth. - - invert pos p. - - destruct d; cbn; congruence. -Qed. - -Lemma eval_L_from n p L : - eval (@conv n p) (L_from (fun p : pos n => nth (pos2nat p) L 0)) = eval (conv p) L. -Proof. - induction p; cbn. - - reflexivity. - - revert L; induction n; intros; cbn. - + invert pos v. - + invert pos v. - * rewrite pos2nat_fst. reflexivity. - * rewrite pos2nat_nxt in *. - destruct L. - -- cbn. clear. induction n. - ++ cbn. invert pos v. - ++ cbn. invert pos v. rewrite !pos.pos2nat_fst. - now rewrite pos.pos2nat_nxt. - now rewrite pos.pos2nat_nxt. - -- cbn. now rewrite <- IHn with (L := L). - - invert pos p. - - destruct d; cbn; congruence. -Qed. - -Lemma red : - H10 ⪯ (fun '(p1, p2) => exists L, eval p1 L = eval p2 L). -Proof. - unshelve eexists. - - intros (n & p1 & p2). exact (conv p1, conv p2). - - intros (n & p1 & p2). cbn. - unfold dio_single_pred. cbn. split. - + intros [phi]. exists (L_from phi). now rewrite <- !phi_to_L. - + intros [L]. exists (fun n => nth (pos.pos2nat n) L 0). - now rewrite !phi_to_L, !eval_L_from. -Qed. - -Definition test_eq := (fun '(p1,p2,L) => Nat.eqb (eval p1 L) (eval p2 L)). - -#[export] -Instance term_test_eq : computable test_eq. -Proof. - extract. -Qed. - -Definition cons' : nat * list nat -> list nat := fun '(n, L) => n :: L. - -#[export] -Instance term_cons' : computable cons'. -Proof. - extract. -Qed. - -Definition T_list_nat := @L_list nat opt_to_list. - -#[export] -Instance computable_cumul {X} `{encodable X} : computable (@cumul X). -Proof. - extract. -Qed. - -#[export] -Instance term_T_list : computable T_list_nat. -Proof. - unfold T_list_nat, L_list. - change (computable - (fix T_list (n : nat) : list (list nat) := - match n with - | 0 => [[]] - | S n0 => (T_list n0 ++ map cons' (list_prod (L_nat n0) (T_list n0)))%list - end)). - extract. -Qed. - -Lemma H10_enumerable : L_enumerable (fun '(p1, p2) => exists L, eval p1 L = eval p2 L). -Proof. - eapply L_enumerable_ext. - eapply projection with (Y := list nat). - instantiate (1 := fun '( (p1,p2), L) => eval p1 L = eval p2 L). - 2:{ intros []. firstorder. } - eapply L_enumerable_enum. - exists (fix L n := match n with 0 => [] | S n => L n ++ filter test_eq (list_prod (list_prod (L_poly n) (L_poly n)) (T_list_nat n)) end)%list. - repeat split. - - extract. - - eauto. - - destruct x as [[p1 p2] L]. intros. - destruct (enum_poly p1) as [m1], (enum_poly p2) as [m2], (enumerator__T_list opt_to_list _ L) as [m3]. - exists (1 + m1 + m2 + m3). in_app 2. - fold plus. eapply filter_In. split. - + rewrite !in_prod_iff. repeat split; eapply cum_ge'; try eassumption; eauto; lia. - + unfold test_eq. edestruct (Nat.eqb_spec (eval p1 L) (eval p2 L)); eauto. - - destruct x as [[p1 p2] L]. intros [m]. - induction m. - + inv H. - + eapply in_app_iff in H as [|]. - * eauto. - * eapply filter_In in H as []. unfold test_eq in H0. - destruct (Nat.eqb_spec (eval p1 L) (eval p2 L)); easy. -Qed. - -Fixpoint poly_eqb p1 p2 := - match p1, p2 with - | poly_cnst n1, poly_cnst n2 => Nat.eqb n1 n2 - | poly_var v1, poly_var v2 => Nat.eqb v1 v2 - | poly_add p1 p2, poly_add p1' p2' => poly_eqb p1 p1' && poly_eqb p2 p2' - | poly_mul p1 p2, poly_mul p1' p2' => poly_eqb p1 p1' && poly_eqb p2 p2' - | _,_ => false - end. - -Lemma poly_eqb_spec p1 p2 : - reflect (p1 = p2) (poly_eqb p1 p2). -Proof. - revert p2; induction p1; destruct p2; cbn. - all: try destruct d; try destruct d0; try now (econstructor; congruence). - - destruct (Nat.eqb_spec n n0); subst; econstructor; congruence. - - destruct (Nat.eqb_spec n n0); subst; econstructor; congruence. - - destruct (IHp1_1 p2_1), (IHp1_2 p2_2); cbn; econstructor; congruence. - - destruct (IHp1_1 p2_1), (IHp1_2 p2_2); cbn; econstructor; congruence. -Qed. - -#[export] -Instance term_poly_beq : computable poly_eqb. -Proof. - extract. -Qed. - -Theorem H10_converges : - H10 ⪯ converges. -Proof. - eapply reduces_transitive. eapply red. - eapply L_enumerable_halt. - 2: eapply H10_enumerable. - exists (fun '( (p1, p2), (p1', p2')) => poly_eqb p1 p1' && poly_eqb p2 p2'). split. - - econstructor. extract. - - intros ( (p1, p2), (p1', p2')). - destruct (poly_eqb_spec p1 p1'), (poly_eqb_spec p2 p2'); cbn; firstorder congruence. -Qed. -(* Print Assumptions eval_L_from. *) diff --git a/theories/L/Reductions/HaltMuRec_to_HaltL.v b/theories/L/Reductions/HaltMuRec_to_HaltL.v deleted file mode 100644 index d6ed06fc9..000000000 --- a/theories/L/Reductions/HaltMuRec_to_HaltL.v +++ /dev/null @@ -1,671 +0,0 @@ -Set Default Goal Selector "!". - -From Undecidability.H10 Require Import H10 dio_single dio_logic. -From Undecidability.L.Datatypes Require Import LNat LOptions LSum. -From Undecidability.L Require Import Tactics.LTactics Computability.MuRec Computability.Synthetic Tactics.GenEncode. -From Undecidability.Shared Require Import DLW.Utils.finite DLW.Vec.vec DLW.Vec.pos. -From Undecidability.MuRec Require Import MuRec recalg ra_sem_eq. - -Reserved Notation " '[' f ';' v ';' min ';' c ']' '▹' x " (at level 70). - -(* Bigstep semantics for recursive algorithms *) - -Inductive ra_bs_c : nat -> nat -> forall k, recalg k -> vec nat k -> nat -> Prop := - | in_ra_bs_c_cst : forall min c n v, [ra_cst n; v; min; S c] ▹ n - | in_ra_bs_c_zero : forall min c v, [ra_zero; v; min; S c] ▹ 0 - | in_ra_bs_c_succ : forall min c v, [ra_succ; v; min; S c] ▹ S (vec_head v) - | in_ra_bs_c_proj : forall min c k v j, [@ra_proj k j; v; min; S c] ▹ vec_pos v j - - | in_ra_bs_c_comp : forall min c k i f (gj : vec (recalg i) k) v w x, - (forall j, [vec_pos gj j; v; min; c - pos2nat j] ▹ vec_pos w j) - -> [f; w; min; S c] ▹ x - -> [ra_comp f gj; v; min; S (S c)] ▹ x - - | in_ra_bs_c_rec_0 : forall min c k f (g : recalg (S (S k))) v x, - [f; v; min; c] ▹ x - -> [ra_rec f g; 0##v; min; S c] ▹ x - - | in_ra_bs_c_rec_S : forall min c k f (g : recalg (S (S k))) v n x y, - [ra_rec f g; n##v; min; c] ▹ x - -> [g; n##x##v; min; c] ▹ y - -> [ra_rec f g; S n##v; min; S c] ▹ y - - | in_ra_bs_c_min : forall min c k (f : recalg (S k)) v x w , x >= min -> - (forall j : pos x, pos2nat j >= min -> [f; pos2nat j##v; 0; c - (pos2nat j - min)] ▹ S (vec_pos w j)) - -> [f; x##v; 0; c - (x - min)] ▹ 0 - -> [ra_min f; v; min; S c] ▹ x -where " [ f ; v ; min ; c ] ▹ x " := (@ra_bs_c min c _ f v x). - -Lemma ra_bs_mono min k (f : recalg k) v c1 x : - [f ; v ; min ; c1 ] ▹ x -> forall c2, c1 <= c2 -> [f ; v ; min; c2] ▹ x. -Proof. - induction 1; intros; try (destruct c2;[ lia | ]). - - econstructor. - - econstructor. - - econstructor. - - econstructor. - - destruct c2; try lia. econstructor. - + intros. eapply H0. lia. - + eapply IHra_bs_c. lia. - - econstructor. eapply IHra_bs_c. lia. - - econstructor. - + eapply IHra_bs_c1. lia. - + eapply IHra_bs_c2. lia. - - econstructor. - + lia. - + intros. eapply H1; lia. - + eapply IHra_bs_c. lia. -Qed. - -Lemma vec_sum_le: - forall (k : nat) (cst : vec nat k) (j : pos k), vec_pos cst j <= vec_sum cst. -Proof. - intros k cst j. - induction cst; cbn. - - invert pos j. - - invert pos j. - + lia. - + specialize (IHcst j); lia. -Qed. - -Lemma ra_bs_from_c k (f : recalg k) c v x : - [f ; v ; 0 ; c] ▹ x -> [ f; v ] ▹ x. -Proof. - remember 0 as min. - induction 1; subst; eauto using ra_bs. - econstructor. - + intros; eapply H1; lia. - + auto. -Qed. - -Lemma ra_bs_to_c k (f : recalg k) v x : - [ f; v ] ▹ x -> exists c, [f ; v ; 0 ; c] ▹ x. -Proof. - induction 1. - - exists 1. econstructor. - - exists 1. econstructor. - - exists 1. econstructor. - - exists 1. econstructor. - - destruct IHra_bs as [c]. - eapply vec_reif in H0 as [cst]. - exists (2 + c + vec_sum cst + k). cbn. - econstructor. - + intros. eapply ra_bs_mono. 1:eauto. - rewrite <- Nat.add_sub_assoc. - 2: pose (pos2nat_prop j); lia. - enough (vec_pos cst j <= vec_sum cst). - 1: lia. eapply vec_sum_le. - + eapply ra_bs_mono. 1: eauto. lia. - - destruct IHra_bs as [c]. exists (S c). now econstructor. - - destruct IHra_bs1 as [c1]. - destruct IHra_bs2 as [c2]. - exists (1 + c1 + c2). - cbn. econstructor. - + eapply ra_bs_mono. 1: eauto. lia. - + eapply ra_bs_mono. 1: eauto. lia. - - destruct IHra_bs as [c]. - eapply vec_reif in H0 as [cst]. - exists (1 + c + vec_sum cst + x). cbn. - econstructor. 1: lia. - + intros. eapply ra_bs_mono. 1: eauto. - rewrite <- Nat.add_sub_assoc. - 2: pose (pos2nat_prop j); lia. - enough (vec_pos cst j <= vec_sum cst) by lia. - eapply vec_sum_le. - + eapply ra_bs_mono. 1: eauto. lia. -Qed. - -Local Hint Resolve ra_bs_from_c ra_bs_to_c : core. - -Fact ra_bs_c_correct k (f : recalg k) v x : - [|f|] v x <-> exists c, [f ; v ; 0 ; c] ▹ x. -Proof. - rewrite ra_bs_correct; split; auto. - intros (c & H); revert H; apply ra_bs_from_c. -Qed. - -(* -Inductive reccode := -| rc_cst (n : nat) -| rc_zero -| rc_succ -| rc_proj (n : nat) -| rc_comp (f : reccode) (g : reccode) -| rc_cons (f : reccode) (g : reccode) -| rc_nil -| rc_rec (f : reccode) (g : reccode) -| rc_min (f : reccode). - -Fixpoint eval (fuel : nat) (min : nat) (c : reccode) (v : list nat) : option (nat + list nat) := - match fuel with - | 0 => None - | S fuel => - match c with - | rc_cst n => Some (inl n) - | rc_zero => Some (inl 0) - | rc_succ => match v with - | x :: _ => Some (inl (S x)) - | _ => None - end - | rc_proj n => match nth_error v n with Some r => Some (inl r) | None => None end - | rc_comp f g => match eval fuel min g v - with - | Some (inr g) => match eval fuel min f g with Some (inl f) => Some (inl f) | _ => None end - | _ => None - end - | rc_cons f g => match eval fuel min f v, eval fuel min g v with - | Some (inl f), Some (inr g) => Some (inr (f :: g)) - | _, _ => None - end - | rc_nil => Some (inr nil) - | rc_rec f g => match v with - | 0 :: v => match eval fuel min f v with Some (inl r) => Some (inl r) | _ => None end - | S n :: v => match eval fuel min (rc_rec f g) (n :: v) with - | Some (inl y) => match eval fuel min g (n :: y :: v) with Some (inl r) => Some (inl r) | _ => None end - | _ => None - end - | _ => None - end - | rc_min f => match eval fuel 0 f (min :: v) with - | Some (inl 0) => Some (inl min) - | Some (inl _) => match eval fuel (S min) (rc_min f) v with Some (inl r) => Some (inl r) | _ => None end - | _ => None - end - end - end. -*) - -Require Import Undecidability.L.Reductions.MuRec.MuRec_extract. - -Definition rec_erase i (erase : forall i, recalg i -> reccode) := (fix rec k (v : vec (recalg i) k) := match v with vec_nil => rc_nil | x ## v => rc_cons (erase _ x) (rec _ v) end). - -Fixpoint erase k (f : recalg k) : reccode := - match f with - | ra_cst n => rc_cst n - | ra_zero => rc_zero - | ra_succ => rc_succ - | ra_proj _ p => rc_proj (pos2nat p) - | ra_comp _ _ f g => rc_comp (erase f) (rec_erase erase g) - | ra_rec _ f g => rc_rec (erase f) (erase g) - | ra_min _ f => rc_min (erase f) - end. - -Lemma vec_list_nth: - forall (k : nat) (p : pos k) (v : vec nat k), nth_error (vec_list v) (pos2nat p) = Some (vec_pos v p). -Proof. - intros k p v. - induction v. - - invert pos p. - - cbn; invert pos p. - + reflexivity. - + eapply IHv. -Qed. - -Lemma eval_inv n min i k (v : vec (recalg i) k) a l : - eval n min (rec_erase erase v) a = Some (inr l) -> - exists x, vec_list x = l /\ - (forall j : pos k, eval (n -S (pos2nat j)) min (erase (vec_pos v j)) a = Some (inl (vec_pos x j))). -Proof. - induction v in n,l |- *. - - destruct n; cbn. - + firstorder congruence. - exact vec_nil. - + intros [=]; subst. - exists vec_nil. - split; auto. - intro j; invert pos j. - - destruct n. 1: inversion 1. - intros ?. cbn in H. - destruct (eval n) eqn:E1; try congruence. - destruct s; try congruence. - destruct (eval n min (rec_erase erase v) a) eqn:E2; try congruence. - destruct s; try congruence. inv H. - edestruct IHv as (? & ? & ?). 1: eauto. - exists (n1 ## x). split. 1: cbn; firstorder congruence. - intros j; pos_inv j. - + rewrite pos2nat_fst in *. assert (S n - 1 = n) by lia. rewrite H1 in *. - cbn -[eval]. eassumption. - + rewrite pos2nat_nxt. - specialize (H0 j). - assert (S n - S (S (pos2nat j)) = n - S (pos2nat j)) by lia. rewrite H1 in *. - cbn. rewrite H0. reflexivity. -Qed. - -Lemma le_ind2 m (P : nat -> Prop) : - P m -> (forall n, P (S n) -> S n <= m -> P n) -> forall n, n <= m -> P n. -Proof. - intros. induction H1. - - eauto. - - eauto. -Qed. - -Lemma vec_pos_gt n X (w : vec X n) j k n1: - pos2nat k < pos2nat j -> - vec_pos w j = vec_pos (vec_change w k n1) j. -Proof. - intros. - induction w. - - invert pos j. - - invert pos j; cbn. - + invert pos k; cbn; auto; lia. - + invert pos k; cbn; auto. - apply IHw. - rewrite !pos2nat_nxt in H; lia. -Qed. - -Lemma erase_correct k min (f : recalg k) v n c : - (ra_bs_c min c f v n <-> eval c min (erase f) (vec_list v) = Some (inl n)). -Proof. - revert k min f v n. - pattern c. eapply lt_wf_ind. intros. - destruct f; cbn. - - split. - + inversion 1. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H4. subst. - reflexivity. - + destruct n; inversion 1. subst. econstructor. - - split. - + inversion 1. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H3. subst. - reflexivity. - + destruct n; inversion 1. subst. econstructor. - - split. - + inversion 1. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H3. subst. - cbn; revert H0; vec split v with x; auto. - + destruct n; inversion 1. - revert H0 H2; vec split v with x; cbn. - intros [=] _; subst; constructor. - - split. - + inversion 1. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H5. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H6. subst. - cbn. rewrite vec_list_nth. reflexivity. - + destruct n; inversion 1. rewrite vec_list_nth in H2. inv H2. econstructor. - - split. - + inversion 1. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H2. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H7. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H7. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H8. subst. - assert (forall j : pos k, eval (c0 - pos2nat j) min (erase (vec_pos t j)) (vec_list v) = Some (inl (vec_pos w j))). - { intros. eapply H. 1: lia. - - cbn. eapply H. 1: lia. eapply H. 1: lia. specialize (H9 j). - eapply H in H9. 2:lia. eapply H. 1: lia. eauto. } - - remember (S c0) as c'. cbn. - - assert (eval c' min (rec_erase erase t) (vec_list v) = Some (inr (vec_list w))). - { subst. clear - H1. revert c0 H1. induction t; intros. - - cbn; vec nil w; reflexivity. - - cbn. pose proof (H1 pos_fst). cbn in H. rewrite pos2nat_fst in H. - replace (c0 - 0) with c0 in H by lia. rewrite H. - revert H1 H; vec split w with y; intros H1 H. - destruct c0. 1: cbn in H. 1: inv H. erewrite IHt. - 1: reflexivity. - intros. specialize (H1 (pos_nxt j)). rewrite pos2nat_nxt in H1. - eassumption. - } - rewrite H2. subst. eapply H in H10. 1: rewrite H10. 1: reflexivity. lia. - + destruct n; inversion 1. - destruct (eval n min (rec_erase erase t) (vec_list v)) eqn:E; try congruence. - destruct s; try congruence. - destruct (eval n min (erase f) l) eqn:E2; try congruence. - destruct s; try congruence. inv H2. - destruct n; try now inv E2. - - destruct (list_vec_full l). - destruct (eval_inv E) as (w & ? & ?). subst. - - eapply in_ra_bs_c_comp with (w := w). - * intros. eapply H. 1: lia. specialize (H2 j). assert (S n - S (pos2nat j) = n - pos2nat j) by lia. rewrite H1 in *. - eauto. - * eapply H. 1: lia. eassumption. - - split. 1: inversion 1. - + eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H4. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H6. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H7. subst. - cbn. - eapply H in H8. 2:lia. rewrite H8. reflexivity. - + eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H2. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H5. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H6. subst. - eapply H in H7. - 1: cbn. 2:lia. cbn in H7. rewrite H7. - eapply H in H9. 2:lia. cbn in H9. rewrite H9. reflexivity. - + intros. destruct n; inv H0. - revert H2; vec split v with n1; cbn; intros H2. - destruct n1. - * destruct (eval n min (erase f1) (vec_list v)) eqn:E. - 1: destruct s; inv H2. - -- econstructor. eapply H. 1: lia. eauto. - -- econstructor. congruence. - * destruct eval eqn:E2; try congruence. - destruct s; try congruence. - destruct (eval n min (erase f2)) eqn:E3. - 1: destruct s; inv H2. - -- econstructor. 1: eapply H. 1: lia. 1: eauto. eapply H. 1: lia. eauto. - -- congruence. - - split. - + inversion 1. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H1. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H2. subst. - clear H0. unfold ge in *. - revert c0 H w H7 H8. pattern n0. revert min H3. - eapply le_ind2; intros. - * cbn in *. eapply H in H8. 2:lia. - assert (c0 - (n0 - n0) = c0) by lia. rewrite H0 in *. - cbn in H8. rewrite H8. reflexivity. - * destruct n0; try lia. - assert (n < S n0) by lia. - assert (H10 := H7). - specialize (H7 (nat2pos H2)). rewrite pos2nat_nat2pos in H7. - assert (n <= n) by lia. eapply H7 in H3. - eapply H1 in H3. 2: lia. cbn. - assert (c0 - (n - n) = c0) by lia. rewrite H4 in *. cbn in H3. rewrite H3. - - assert (eval c0 (S n) (rc_min (erase f)) (vec_list v) = Some (inl (S n0))). - { eapply H1 with (f := ra_min f). 1: lia. - destruct c0. 1: inv H3. - econstructor. 1: lia. - - intros ? ?. specialize (H10 j). - assert (S c0 - (pos2nat j - n) = c0 - (pos2nat j - S n)) by lia. - rewrite H6 in *. eapply H10. lia. - - assert (S c0 - (S n0 - n) = c0 - (S n0 - S n)) by lia. rewrite H5 in *. - eassumption. } - now rewrite H5. - + intros. - destruct n; try now inv H0. cbn in H0. - destruct (eval n) eqn:E1; try now inv H0. - destruct s; try congruence. - destruct n1; inv H0. - * econstructor. 1: lia. - -- intros. pose proof (pos2nat_prop j). lia. - -- eapply H. 1:lia. assert (n - (n0 - n0) = n) as -> by lia. eassumption. - * destruct (eval n (S min)) eqn:E2; try now inv H2. - destruct s; inv H2. - eapply H with (f := ra_min f) in E2. 2:lia. - eapply H with (v := vec_cons min v) in E1. 2:lia. - inversion E2; subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H0. subst. - eapply (Eqdep_dec.inj_pair2_eq_dec _ nat_eq_dec) in H1. subst. - assert (min < n0) by lia. - eapply in_ra_bs_c_min with (w := vec_change w (nat2pos H0) n1). - -- lia. - -- intros. inversion H1. - ++ subst. - rewrite nat2pos_pos2nat. - rewrite vec_change_eq. 2:reflexivity. - assert (S c0 - (pos2nat j - pos2nat j) = S c0) as -> by lia. - eassumption. - ++ specialize (H6 j). - assert (S c0 - (S m - min) = c0 - (pos2nat j - S min)) by lia. rewrite H5 in *. - enough (vec_pos w j = vec_pos (vec_change w (nat2pos H0) n1) j). - { rewrite H8 in H6. rewrite H3. eapply H6. lia. } - assert (pos2nat j > min) by lia. - eapply vec_pos_gt. - rewrite pos2nat_nat2pos. lia. - -- assert (S c0 - (n0 - min) = c0 - (n0 - S min)) by lia. rewrite H1. eassumption. - Unshelve. exact vec_zero. -Qed. - -Require Import Undecidability.L.Reductions.MuRec.MuRec_extract. - -Definition evalfun fuel c v := match eval fuel 0 c v with Some (inl x) => Some x | _ => None end. - -From Undecidability Require Import MuRec_computable LVector. -From Undecidability.L.Util Require Import NaryApp. - -Import L_Notations. - -Definition cont_vec (k : nat) : term := lam (many_lam k (k (Vector.fold_right (fun n s => (ext (@cons nat) (var n)) s) (many_vars k) (ext (@nil nat))))). - -Lemma helper_closed k : - bound k (Vector.fold_right (fun (n : nat) (s0 : term) => ext (@cons nat) n s0) (many_vars k) (ext (@nil nat))). -Proof. - induction k. - - cbn. cbv. repeat econstructor. - - rewrite many_vars_S. cbn. econstructor. 1: econstructor. 1: eapply closed_dcl_x. 1: Lproc. - 1: econstructor; lia. - eapply bound_ge. 1: eauto. lia. -Qed. - -Lemma subst_closed s n u : - closed s -> subst s n u = s. -Proof. - now intros ->. -Qed. - -Lemma vector_closed: - forall (k : nat) (v : Vector.t nat k) (x : term), Vector.In x (Vector.map enc v) -> proc x. -Proof. - intros k v. - induction v; cbn; intros ? Hi. 1: inversion Hi. inv Hi. 1:Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. 1:subst; eauto. eapply nat_eq_dec. -Qed. - -Lemma equiv_R (s t t' : term): - t == t' -> s t == s t'. -Proof. - now intros ->. -Qed. - -Lemma cont_vec_correct k s (v : Vector.t nat k) : - proc s -> - many_app (cont_vec k s) (Vector.map enc v) == s (enc v). -Proof. - intros Hs. - unfold cont_vec. - rewrite equiv_many_app_L. - 2:{ eapply beta_red. 1:Lproc. rewrite subst_many_lam. replace (k + 0) with k by lia. reflexivity. } - cbn -[plus mult]. rewrite Nat.eqb_refl. - rewrite bound_closed_k. 2:eapply helper_closed. - replace (3 * k) with (k + 2 * k) by lia. - etransitivity. - { apply many_beta. eapply vector_closed. } - rewrite many_subst_app. - rewrite many_subst_closed. 2:Lproc. - replace (2 * k) with (2 * k + 0) by lia. - eapply equiv_R. - induction v. - - cbn. reflexivity. - - rewrite many_vars_S. cbn -[mult]. rewrite subst_closed; [ | now Lproc]. - rewrite Nat.eqb_refl. - rewrite !many_subst_app. - repeat (rewrite many_subst_closed; [ | now Lproc]). - rewrite bound_closed_k. 2:eapply helper_closed. rewrite IHv. - rewrite !enc_vector_eq. - now Lsimpl. -Qed. - -Definition mu_option : term := (lam (0 (mu (lam (1 0 (lam (enc true)) (enc false)))) (lam 0) (lam 0))). - -Lemma mu_option_proc : proc mu_option. -Proof. - unfold mu_option. Lproc. -Qed. -#[export] Hint Resolve mu_option_proc : Lproc. - -From Undecidability Require Import LOptions. - -Lemma mu_option_equiv {X} `{encodable X} s (b : X) : - proc s -> - mu_option s == s (mu (lam (s 0 (lam (enc true)) (enc false)))) (lam 0) (lam 0). -Proof. - unfold mu_option. intros Hs. now Lsimpl. -Qed. - -Definition mu_option_spec {X} {ENC : encodable X} {I : encInj ENC} s (b : X) : - proc s -> - (forall x : X, enc x <> lam 0) -> - (forall n : nat, exists o : option X, s (enc n) == enc o) -> - (forall b : X, forall m n : nat, s (enc n) == enc (Some b) -> m >= n -> s (enc m) == enc (Some b)) -> - mu_option s == enc b <-> exists n : nat, s (enc n) == enc (Some b). -Proof. - intros Hs Hinv Ht Hm. - rewrite (@mu_option_equiv X); eauto. - split. - - intros He. - match goal with [He : ?s == _ |- _ ] => assert (converges s) as Hc end. - { eexists. split. 1: exact He. Lproc. } - eapply app_converges in Hc as [Hc _]. - eapply app_converges in Hc as [Hc _]. - eapply app_converges in Hc as [_ Hc]. - destruct Hc as [v [Hc Hv]]. - pose proof (Hc' := Hc). - eapply mu_sound in Hc as [n [-> [Hc1 _]]]; eauto. - * exists n. - destruct (Ht n) as [ [x | ] Htt]. - -- rewrite Htt. - enough (enc b == enc x) as -> % enc_extinj. 1: reflexivity. - rewrite <- He. - rewrite Hc'. Lsimpl. rewrite Htt. now Lsimpl. - -- exfalso. eapply (Hinv b). eapply unique_normal_forms; try Lproc. - rewrite <- He, Hc'. Lsimpl. - rewrite Htt. Lsimpl. reflexivity. - * Lproc. - * intros n. destruct (Ht n) as [[] ]; - eexists; Lsimpl; rewrite H; Lsimpl; reflexivity. - - intros [n Hn]. - edestruct mu_complete' with (n := n) as [n' [H' H'']]. - 4: rewrite H'. - + Lproc. - + intros m. destruct (Ht m) as [ [] ]; - eexists; Lsimpl; rewrite H; Lsimpl; reflexivity. - + Lsimpl. rewrite Hn. now Lsimpl. - + destruct (Ht n') as [[] Heq]; rewrite Heq; Lsimpl. - * enough (HH : enc (Some x) == enc (Some b))by now eapply enc_extinj in HH; inv HH. - assert (n <= n' \/ n' <= n) as [Hl | Hl] by lia. - -- eapply Hm in Hl; eauto. now rewrite <- Heq, Hl. - -- eapply Hm in Hl; eauto. now rewrite <- Hn, Hl. - * enough (false = true) by congruence. - eapply enc_extinj. rewrite <- H''. - symmetry. Lsimpl. rewrite Heq. now Lsimpl. -Qed. - -#[export] -Instance computable_evalfun : computable evalfun. -Proof. extract. Qed. - -Lemma vec_list_eq {n X} (v : Vector.t X n) : - vec_list v = Vector.to_list v. -Proof. - induction v; cbn; f_equal; eassumption. -Qed. - -Require Import Undecidability.L.Reductions.MuRec.MuRec_extract. - -Lemma eval_mono c min k (v : Vector.t nat k) (f : recalg k) o : - eval c min (erase f) (vec_list v) = Some (inl o) -> forall c', c' >= c -> eval c' min (erase f) (vec_list v) = Some (inl o). -Proof. - intros H c' Hl. eapply erase_correct in H. - eapply ra_bs_mono in H. 2: eauto. - now eapply erase_correct in H. -Qed. - -Lemma many_app_eq_nat {k} (v : Vector.t nat k) s : many_app s (Vector.map enc v) = Vector.fold_left (fun (s : term) n => s (nat_enc n)) s v. -Proof. - induction v in s |- *. - * cbn. reflexivity. - * cbn. now rewrite IHv. -Qed. - -Theorem computable_MuRec_to_L {k} (R : Vector.t nat k -> nat -> Prop) : - MuRec_computable R -> L_computable R. -Proof. - intros [f Hf]. - exists (cont_vec k (lam (mu_option (lam (ext evalfun 0 (enc (erase f)) 1))))). - intros v. rewrite <- many_app_eq_nat. split. - - intros m. rewrite L_facts.eval_iff. - assert (lambda (nat_enc m)) as [b Hb]. { change (lambda (enc m)). Lproc. } - rewrite Hb. rewrite eproc_equiv. rewrite cont_vec_correct. 2: unfold mu_option; Lproc. - assert (lam (mu_option (lam (ext evalfun 0 (enc (erase f)) 1))) (enc v) == - mu_option (lam (ext evalfun 0 (enc (erase f)) (enc v)))). - { unfold mu_option. now Lsimpl. } - rewrite H. rewrite <- Hb. - change (nat_enc m) with (enc m). - rewrite mu_option_spec. 2:Lproc. - 2:{ intros []; cbv; congruence. } - 2:{ intros. eexists. rewrite !enc_vector_eq. Lsimpl. reflexivity. } - 1: rewrite Hf. - 1: split. - + intros [n Hn % erase_correct] % ra_bs_to_c. exists n. - rewrite !enc_vector_eq. Lsimpl. - unfold evalfun. rewrite <- vec_list_eq. now rewrite Hn. - + intros [n Hn]. eapply ra_bs_from_c. eapply erase_correct with (c := n). - match goal with [Hn : ?s == ?b |- _ ] => evar (t : term); assert (s == t) end. - { rewrite !enc_vector_eq. Lsimpl. subst t. reflexivity. } subst t. - rewrite vec_list_eq. rewrite H0 in Hn. eapply enc_extinj in Hn. - unfold evalfun in Hn. now destruct eval as [[] | ]; inv Hn. - + intros. rewrite enc_vector_eq in *. - match type of H0 with ?s == ?b => evar (t : term); assert (s == t) end. 1: Lsimpl. all: subst t. 1: reflexivity. rewrite H2 in H0. clear H2. - eapply enc_extinj in H0. Lsimpl. - unfold evalfun in *. - destruct (eval n) as [ [] | ] eqn:E; inv H0. - rewrite <- vec_list_eq in *. - eapply eval_mono in E. 1: rewrite E; eauto. lia. - - intros v' [H1 H2] % eval_iff. - eapply star_equiv_subrelation in H1. - rewrite cont_vec_correct in H1. 2: unfold mu_option; Lproc. - match goal with [Hn : ?s == ?b |- _ ] => evar (t : term); assert (s == t) end. - 1: unfold mu_option. 1: Lsimpl. all: subst t. 1: reflexivity. - rewrite H in H1. - match type of H1 with ?s == _ => assert (converges s) end. - 1: exists v'; split; eassumption. - eapply app_converges in H0 as [Hc _]. - eapply app_converges in Hc as [Hc _]. - eapply app_converges in Hc as [_ Hc]. - destruct Hc as [v'' [Hc1 Hc2]]. - pose proof (Hc1' := Hc1). - eapply mu_sound in Hc1; eauto. - + destruct Hc1 as [m [-> []]]. - rewrite Hc1' in H1. - rewrite enc_vector_eq in H1. - destruct (evalfun m (erase f) (Vector.to_list v)) eqn:E. - * match type of H1 with ?s == ?b => evar (t : term); assert (s == t) end. 1: Lsimpl. all: subst t. 1: reflexivity. - rewrite H4, E in H1. - match type of H1 with ?s == ?b => evar (t : term); assert (s == t) end. 1: Lsimpl. all: subst t. 1: reflexivity. - rewrite H5 in H1. - eapply unique_normal_forms in H1. 2,3: Lproc. - subst. exists n. reflexivity. - * enough (true = false) by congruence. eapply enc_extinj. - rewrite <- H0. rewrite enc_vector_eq. Lsimpl. - now rewrite E. - + Lproc. - + intros n. - destruct (evalfun n (erase f) (Vector.to_list v)) eqn:EE; - eexists; rewrite enc_vector_eq; Lsimpl; rewrite EE; try Lsimpl; reflexivity. -Qed. - -Definition UMUREC_HALTING c := exists fuel, evalfun fuel c nil <> None. - -Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.ReducibilityFacts. - -Lemma MUREC_red : recalg.MUREC_HALTING ⪯ UMUREC_HALTING. -Proof. - unshelve eexists. - - intros f. exact (erase f). - - unfold UMUREC_HALTING, MUREC_HALTING. - intros f. - split; intros []. - + rewrite ra_bs_correct in H. eapply ra_bs_to_c in H as []. - exists x0. eapply erase_correct in H. unfold evalfun. cbn in H. rewrite H. congruence. - + unfold evalfun in H. destruct eval eqn:E; try congruence. - destruct s; try congruence. - eapply erase_correct with (v := vec_nil) in E. - exists n. eapply ra_bs_correct. now eapply ra_bs_from_c. -Qed. - -Local Definition r := (fun c n => match eval n 0 c [] with Some (inl n) => true | _ => false end). - -Lemma MUREC_WCBV : MUREC_HALTING ⪯ converges. -Proof. - eapply reduces_transitive. 1:eapply MUREC_red. - eapply L_recognisable_halt. - exists (fun c n => match eval n 0 c [] with Some (inl n) => true | _ => false end). - split. - - econstructor. extract. - - firstorder. - + unfold evalfun in *. exists x0. destruct eval; try destruct s; try congruence. - + exists x0. unfold evalfun in *. destruct eval; try destruct s; try congruence. -Qed. diff --git a/theories/L/Reductions/MuRec/MuRec_extract.v b/theories/L/Reductions/MuRec/MuRec_extract.v deleted file mode 100644 index daf24f1de..000000000 --- a/theories/L/Reductions/MuRec/MuRec_extract.v +++ /dev/null @@ -1,81 +0,0 @@ -From Undecidability.L.Datatypes Require Import LNat LOptions LSum List.List_nat. -Require Import Undecidability.L.Tactics.GenEncode. - -Inductive reccode := -| rc_cst (n : nat) -| rc_zero -| rc_succ -| rc_proj (n : nat) -| rc_comp (f : reccode) (g : reccode) -| rc_cons (f : reccode) (g : reccode) -| rc_nil -| rc_rec (f : reccode) (g : reccode) -| rc_min (f : reccode). - -Definition id_Some_inl (o : option (nat + list nat)) : option (nat + list nat) := - match o with - | Some (inl f) => o - | _ => None - end. - -#[global] Arguments id_Some_inl /. - -Definition eval_rec (eval : nat -> reccode -> list nat -> option (nat + list nat)) (min : nat) (c : reccode) (v : list nat) : option (nat + list nat) := - match c with - | rc_cst n => Some (inl n) - | rc_zero => Some (inl 0) - | rc_succ => match v with - | x :: _ => Some (inl (S x)) - | _ => None - end - | rc_proj n => option_map inl (nth_error v n) - | rc_comp f g => match eval min g v - with - | Some (inr g) => id_Some_inl (eval min f g) - | _ => None - end - | rc_cons f g => match eval min f v, eval min g v with - | Some (inl f), Some (inr g) => Some (inr (f :: g)) - | _, _ => None - end - | rc_nil => Some (inr nil) - | rc_rec f g => match v with - | 0 :: v => id_Some_inl (eval min f v) - | S n :: v => match eval min (rc_rec f g) (n :: v) with - | Some (inl y) => id_Some_inl (eval min g (n :: y :: v)) - | _ => None - end - | _ => None - end - | rc_min f => match eval 0 f (min :: v) with - | Some (inl 0) => Some (inl min) - | Some (inl _) => id_Some_inl (eval (S min) (rc_min f) v) - | _ => None - end - end. - -Fixpoint eval (fuel : nat) (min : nat) (c : reccode) (v : list nat) : option (nat + list nat) := - match fuel with - | 0 => None - | S fuel => eval_rec (eval fuel) min c v - end. - -MetaCoq Run (tmGenEncode "enc_reccode" reccode). -#[export] Hint Resolve enc_reccode_correct : Lrewrite. - -#[global] -Instance term_rc_comp: computable rc_comp. Proof. extract constructor. Qed. -#[global] -Instance term_rc_cons : computable rc_cons. Proof. extract constructor. Qed. -#[global] -Instance term_rc_rec : computable rc_rec. Proof. extract constructor. Qed. -#[global] -Instance term_rc_min : computable rc_min. Proof. extract constructor. Qed. -#[local] Instance term_id_Some_inl : computable id_Some_inl. -Proof. extract. Qed. -#[local] Instance term_eval_rec : computable eval_rec. -Proof. extract. Qed. -#[global] Instance term_eval : computable eval. -Proof. - extract. -Qed. diff --git a/theories/L/Reductions/MuRec_computable_to_L_computable.v b/theories/L/Reductions/MuRec_computable_to_L_computable.v deleted file mode 100644 index d1e35849b..000000000 --- a/theories/L/Reductions/MuRec_computable_to_L_computable.v +++ /dev/null @@ -1,9 +0,0 @@ - -From Undecidability.L Require Import L HaltMuRec_to_HaltL. -From Undecidability.MuRec Require Import MuRec. - -Theorem MuRec_computable_to_L_computable {k} (R : Vector.t nat k -> nat -> Prop) : - MuRec_computable R -> L_computable R. -Proof. - eapply HaltMuRec_to_HaltL.computable_MuRec_to_L. -Qed. diff --git a/theories/L/Reductions/PCPb_to_HaltL.v b/theories/L/Reductions/PCPb_to_HaltL.v deleted file mode 100644 index 95a61c2d5..000000000 --- a/theories/L/Reductions/PCPb_to_HaltL.v +++ /dev/null @@ -1,251 +0,0 @@ -Set Default Goal Selector "!". - -From Undecidability.Synthetic Require Import Definitions EnumerabilityFacts ListEnumerabilityFacts. -From Undecidability Require Export PCP.PCP. -Require Import Lia. - -From Undecidability.L Require Import LProd LBool LNat LOptions. -From Undecidability.L.Datatypes.List Require Import List_basics List_eqb List_extra List_nat. - -Definition blist_eqb := - list_eqb Bool.eqb. - -Lemma blist_eqb_spec : forall l1 l2, l1 = l2 <-> blist_eqb l1 l2 = true. -Proof. - intros l1 l2. unfold blist_eqb. - destruct (list_eqb_spec Bool.eqb_spec l1 l2); firstorder congruence. -Qed. - -#[export] Instance comp_eqb_list : computable blist_eqb. -Proof. - unfold blist_eqb. extract. -Defined. - -Definition stack_eqb := - list_eqb (prod_eqb (list_eqb Bool.eqb) (list_eqb Bool.eqb)). - -#[export] Instance computable_stack_eqb : computable stack_eqb. -Proof. - unfold stack_eqb. extract. -Qed. - -Lemma stack_eqb_spec : forall l1 l2, l1 = l2 <-> stack_eqb l1 l2 = true. -Proof. - intros l1 l2. unfold stack_eqb. - destruct (list_eqb_spec (prod_eqb_spec (list_eqb_spec Bool.eqb_spec) (list_eqb_spec Bool.eqb_spec)) l1 l2); firstorder congruence. -Qed. - -#[export] Instance computable_bool_enum : computable bool_enum. -Proof. - extract. -Qed. - -From Coq Require Cantor. - -Definition of_list_enum {X} (f : nat -> list X) := (fun n : nat => let (n0, m) := Cantor.of_nat n in nth_error (f n0) m). - -Definition unembed' := (fix F (k : nat) := - match k with 0 => (0,0) | S n => match fst (F n) with 0 => (S (snd (F n)), 0) | S x => (x, S (snd (F n))) end end). - -#[export] Instance unembed_computable : computable Cantor.of_nat. -Proof. - eapply computableExt with (x := unembed'). 2:extract. - intros n. cbn. induction n. - - reflexivity. - - simpl. rewrite IHn. now destruct (Cantor.of_nat n). -Qed. - -#[export] Instance computable_of_list_enum {X} `{encodable X} : - computable (@of_list_enum X). -Proof. - extract. -Qed. - -Definition to_list_enum {X} (f : nat -> option X) := - (fun n : nat => match f n with - | Some x => [x] - | None => [] - end) . - -#[export] Instance computable_to_list_enum {X} `{encodable X} : - computable (@to_list_enum X). -Proof. - extract. -Qed. - -#[export] Instance computable_to_cumul {X} `{encodable X} : - computable (@to_cumul X). -Proof. - extract. -Qed. -(* -#[export] Instance computable_list_prod {X} `{encodable X} {Y} `{encodable Y} : - computable (@list_prod X Y). -Proof. - unfold list_prod. - extract. - unfold L_list. cbn. *) - -Definition cons' {X} : X * list X -> list X := fun '(pair x L0) => cons x L0. - -#[export] Instance computable_cons' {X} `{encodable X} : - computable (@cons' X). -Proof. - extract. -Qed. - -#[export] Instance computable_L_list {X} `{encodable X} : - computable (@L_list X). -Proof. - change (computable (fun (L : forall _ : nat, list X) => - fix L_list (n : nat) : list (list X) := - match n with - | O => cons nil nil - | S n0 => - Datatypes.app (L_list n0) - (map cons' - (list_prod (to_cumul L n0) (L_list n0))) - end)). extract. -Qed. - -#[export] Instance computable_prod_enum {X} `{encodable X} {Y} `{encodable Y} : - computable (@prod_enum X Y). -Proof. - unfold prod_enum. - extract. -Qed. - -Definition stack_enum n := - of_list_enum (L_list (to_list_enum (prod_enum (of_list_enum (L_list (to_list_enum bool_enum))) (of_list_enum (L_list (to_list_enum bool_enum)))))) n. - -#[export] Instance computable_stack_enum : computable stack_enum. -Proof. - extract. -Qed. - -Lemma stack_enum_spec : - enumerator__T stack_enum (PCP.stack bool). -Proof. - exact _. -Qed. - -From Undecidability Require Import PCP. - -Fixpoint tau1' (A : list (list bool * list bool)) : list bool := - match A with - | [] => @nil bool - | (x,y) :: A0 => x ++ tau1' A0 - end. - -#[export] Instance computable_tau1' : - computable tau1'. -Proof. - extract. -Qed. - -#[export] Instance computable_tau1 : computable (@tau1 bool). -Proof. - eapply computableExt with (x := tau1'). 2:exact _. - intros n. cbn. induction n as [ | [] ]; cbn; congruence. -Qed. - -Fixpoint tau2' (A : list (list bool * list bool)) : list bool := - match A with - | [] => @nil bool - | (x,y) :: A0 => y ++ tau2' A0 - end. - -Lemma tau1'_spec A : tau1' A = tau1 A. -Proof. - induction A as [ | []]; cbn; congruence. -Qed. - -Lemma tau2'_spec A : tau2' A = tau2 A. -Proof. - induction A as [ | []]; cbn; congruence. -Qed. - -#[export] Instance computable_tau2' : - computable tau2'. -Proof. - extract. -Qed. - -#[export] Instance computable_tau2 : computable (@tau2 bool). -Proof. - eapply computableExt with (x := tau2'). 2:exact _. - intros n. cbn. induction n as [ | [] ]; cbn; congruence. -Qed. - -Definition my_inb (P : stack bool) := - (list_in_decb ((prod_eqb (list_eqb Bool.eqb) (list_eqb Bool.eqb))) P). - -#[export] Instance computable_myinb : - computable my_inb. -Proof. - extract. -Qed. - -Fixpoint subsetb A P := - match A with - | nil => true - | a :: A => my_inb P a && subsetb A P - end. - -Lemma subsetb_spec A P : - subsetb A P = forallb (my_inb P) A. -Proof. - induction A; cbn; congruence. -Qed. - -#[export] Instance computable_subsetb : - computable subsetb. -Proof. - extract. -Qed. - -Opaque blist_eqb subsetb. - -Definition sdec_PCPb := (fun (P : PCP.stack bool) n => match stack_enum n with Some [] | None => false | Some A => andb (subsetb A P) (blist_eqb (tau1' A) (tau2' A)) end). - -#[export] Instance computable_sdec_PCPb : - computable sdec_PCPb. -Proof. - extract. -Qed. - -Transparent subsetb. - -Lemma semi_decidable_PCPb : - semi_decider sdec_PCPb PCPb. -Proof. - intros P. unfold sdec_PCPb. split. - - intros (A & H1 & H2 & H3). - destruct (stack_enum_spec A) as [nA HnA]. exists nA. rewrite HnA. - destruct A as [ | c A]; try congruence. - eapply andb_true_intro. split. - + rewrite subsetb_spec. eapply forallb_forall. intros ? H % H1. unfold my_inb. - eapply list_in_decb_iff. 2: eassumption. - intros a b. destruct (prod_eqb_spec (list_eqb_spec Bool.eqb_spec) (list_eqb_spec Bool.eqb_spec) a b); firstorder congruence. - + eapply blist_eqb_spec. now rewrite tau1'_spec, tau2'_spec. - - intros [n Hn]. destruct stack_enum as [A | ] eqn:E; try congruence. - exists A. - destruct A; try congruence. - eapply Bool.andb_true_iff in Hn as [H1 H2]. - rewrite subsetb_spec in H1. rewrite tau1'_spec, tau2'_spec in H2. unfold my_inb in H1. - rewrite forallb_forall in H1. eapply blist_eqb_spec in H2. - repeat eapply conj; try congruence. - intros ? ? % H1. eapply list_in_decb_iff. 2: eassumption. - intros a_ b_. destruct (prod_eqb_spec (list_eqb_spec Bool.eqb_spec) (list_eqb_spec Bool.eqb_spec) a_ b_); firstorder congruence. -Qed. - -From Undecidability.L Require Import Synthetic. - -Theorem reduction_PCPb_HaltL : - PCPb ⪯ HaltL. -Proof. - eapply L_recognisable_HaltL. - exists sdec_PCPb. split. - - econstructor. exact _. - - eapply semi_decidable_PCPb. -Qed. diff --git a/theories/L/Reductions/TM_to_L.v b/theories/L/Reductions/TM_to_L.v deleted file mode 100644 index 31359c5d7..000000000 --- a/theories/L/Reductions/TM_to_L.v +++ /dev/null @@ -1,31 +0,0 @@ -From Undecidability Require Import TM.TMEncoding TM.TMinL TM.Util.TM_facts. -From Undecidability.L Require Import Computability.MuRec. -Require Import Undecidability.Synthetic.Definitions. - -Lemma TM_eval_halts Σ n (M : TM Σ n) q t q' t' : - TM.eval M q t q' t' -> halt M q' = true. -Proof. - induction 1; eauto. -Qed. - -(* ** Reducing halting problem for TMs to halting problem for L *) -Theorem HaltMTM_to_HaltL : - HaltMTM ⪯ HaltL. -Proof. - eexists (fun '(existT2 (Sigma, n) M tp) => - (L.app mu (@ext _ _ _ (term_test (mk_mconfig (start M) tp))))). - intros [ [Sigma n] M tp ]. cbn. - unfold HaltL. setoid_rewrite eval_iff. - split. - - intros H. - epose proof (Halt_red (mk_mconfig (start M) tp)) as [[v [H1 H2]] _]. - + destruct H as (? & ? & ?). eexists (mk_mconfig _ _). - rewrite <- TM_eval_iff. split. 2:eassumption. - eapply TM_eval_halts. eassumption. - + exists v. split; eauto. - eapply equiv_lambda. eassumption. eassumption. - - intros [t [H1 H2]]. - epose proof (Halt_red (mk_mconfig (start M) tp)) as [_ [[q' t']]]. - + eexists. eauto. - + exists q', t'. eapply TM_eval_iff. eapply H. -Qed. diff --git a/theories/L/TM/TMEncoding.v b/theories/L/TM/TMEncoding.v deleted file mode 100644 index db697eded..000000000 --- a/theories/L/TM/TMEncoding.v +++ /dev/null @@ -1,118 +0,0 @@ -From Undecidability.L.Datatypes Require Import LVector. -From Undecidability.L Require Import Functions.EqBool. -From Undecidability.TM.Util Require Import TM_facts. -From Undecidability.L.Tactics Require Import LTactics GenEncode. - -Import L_Notations. - -(* ** Extraction of Turing Machine interpreter *) - -MetaCoq Run (tmGenEncodeInj "move_enc" move). -#[export] Hint Resolve move_enc_correct : Lrewrite. - -Import TM. -Local Notation L := TM.Lmove. -Local Notation R := TM.Rmove. -Local Notation N := TM.Nmove. - -Definition move_eqb (m n : move) : bool := - match m,n with - N,N => true - | L,L => true - | R,R => true - | _,_ => false - end. - -Lemma move_eqb_spec x y : reflect (x = y) (move_eqb x y). -Proof. - destruct x, y;constructor. all:easy. -Qed. - - -#[export] -Instance eqb_move: - eqbClass move_eqb. -Proof. - intros ? ?. eapply move_eqb_spec. -Qed. - - -#[export] -Instance eqbComp_bool : eqbComp move. -Proof. - constructor. unfold move_eqb. - extract. -Qed. - -(* *** Encoding Tapes *) -Section reg_tapes. - Variable sig : Type. - Context `{reg_sig : encodable sig}. - - Implicit Type (t : TM.tape sig). - Import GenEncode. - MetaCoq Run (tmGenEncode "tape_enc" (TM.tape sig)). - Hint Resolve tape_enc_correct : Lrewrite. - - #[export] Instance encInj_tape_enc {H : encInj reg_sig} : encInj (encodable_tape_enc). - Proof. register_inj. Qed. - - (*Internalize constructors **) - - #[export] Instance term_leftof : computable (@leftof sig). - Proof. - extract constructor. - Qed. - - #[export] Instance term_rightof : computable (@rightof sig). - Proof. - extract constructor. - Qed. - - #[export] Instance term_midtape : computable (@midtape sig). - Proof. - extract constructor. - Qed. - -End reg_tapes. - - -Section fix_sig. - Variable sig : finType. - Context `{reg_sig : encodable sig}. - - - Definition mconfigAsPair {B : finType} {n} (c:mconfig sig B n):= let (x,y) := c in (x,y). - - #[export] Instance encodable_mconfig (B : finType) `{encodable B} n: encodable (mconfig sig B n). - Proof using reg_sig. - eapply (registerAs mconfigAsPair). - Defined. - - #[export] Instance term_mconfigAsPair (B : finType) `{encodable B} n: computable (@mconfigAsPair B n). - Proof. - apply cast_computable. - Qed. - - #[export] Instance term_cstate (B : finType) `{encodable B} n: computable (@cstate sig B n). - Proof. - apply computableExt with (x:=fun x => fst (mconfigAsPair x)). - 2:{extract. } - intros [];reflexivity. - Qed. - - #[export] Instance term_ctapes (B : finType) `{encodable B} n: computable (@ctapes sig B n). - Proof. - apply computableExt with (x:=fun x => snd (mconfigAsPair x)). - 2:{extract. } - intros [];reflexivity. - Qed. - - #[export] Instance encodable_mk_mconfig (B : finType) `{encodable B} n: computable (@mk_mconfig sig B n). - Proof. - computable_casted_result. - extract. - Qed. -End fix_sig. - -#[export] Hint Resolve tape_enc_correct : Lrewrite. diff --git a/theories/L/TM/TMinL.v b/theories/L/TM/TMinL.v deleted file mode 100644 index 1a5410f87..000000000 --- a/theories/L/TM/TMinL.v +++ /dev/null @@ -1,49 +0,0 @@ -From Undecidability.L.Datatypes Require Import LOptions. -From Undecidability.L Require Import Computability.MuRec. - -From Undecidability.TM Require Import TM_facts. - -Require Import Undecidability.L.TM.TMinL.TMinL_extract. - -Definition Halt' (Sigma : finType) n (M: TM Sigma n) (start: mconfig Sigma (state M) n) := - exists (f: mconfig _ (state M) _), halt (cstate f)=true /\ exists k, loopM start k = Some f. - -Definition Halt :{ '(Sigma, n) : finType * nat & TM Sigma n & tapes Sigma n} -> _ := - fun '(existT2 (Sigma, n) M tp) => - exists (f: mconfig _ (state M) _), halt (cstate f) = true - /\ exists k, loopM (mk_mconfig (start M) tp) k = Some f. - -Section loopM. - Context (sig : finType) (n : nat) (M : TM sig n). - - Definition term_test := TMinL_extract.term_test. - Existing Instance term_test. - - Import L_Notations. - Lemma Halt_red cfg : - Halt' cfg <-> converges (mu (ext ((fun k => LOptions.isSome (loopM (M := M) cfg k))))). - Proof. - split; intros. - - destruct H as (f & ? & k & ?). - edestruct (mu_complete) with (P:= ext (fun k0 : nat => isSome (loopM cfg k0))) (n:=k). - + Lproc. - + intros. eexists. rewrite !ext_is_enc. now Lsimpl. - + Lsimpl. now rewrite H0. - + exists (ext x). split. eauto. Lproc. - - destruct H as (v & ? & ?). edestruct mu_sound as (k & ? & ? & _). - + eapply term_test. - + intros. eexists. now Lsimpl'. - + eassumption. - + eauto. - + subst. - assert ((ext (fun k : nat => LOptions.isSome (loopM cfg k))) (ext k) == - ext (LOptions.isSome (loopM cfg k))) by now Lsimpl. - rewrite H1 in H2. clear H1. - eapply unique_normal_forms in H2; try Lproc. eapply inj_enc in H2. - destruct (loopM cfg k) eqn:E. - * exists m. split. 2: eauto. - unfold loopM in E. now eapply loop_fulfills in E. - * inv H2. - Qed. - -End loopM. diff --git a/theories/L/TM/TMinL/TMinL_extract.v b/theories/L/TM/TMinL/TMinL_extract.v deleted file mode 100644 index 6cac599e1..000000000 --- a/theories/L/TM/TMinL/TMinL_extract.v +++ /dev/null @@ -1,81 +0,0 @@ -From Undecidability.L.Datatypes Require Import LProd LFinType. -From Undecidability.L Require Import Functions.FinTypeLookup. -From Undecidability.L Require Import TM.TapeFuns TM.TMEncoding. - -From Undecidability.TM Require Import TM_facts. - -Local Notation L := TM.Lmove. -Local Notation R := TM.Rmove. -Local Notation N := TM.Nmove. - -Section loopM. - Context (sig : finType). - Let reg_sig := @encodable_finType sig. - Existing Instance reg_sig. - - Let eqb_sig := eqbFinType_inst (X:=sig). - Existing Instance eqb_sig. - Variable n : nat. - Variable M : TM sig n. - - Let reg_state := @encodable_finType (state M). - Existing Instance reg_state. - - Let eqb_state := eqbFinType_inst (X:=state M). - Existing Instance eqb_state. - Import Vector. - - (* *** Computability of transition relation *) - #[export] Instance term_trans : computable (trans (m:=M)). - Proof. - pose (t:= (funTable (trans (m:=M)))). - apply computableExt with (x:= (fun c => lookup c t (start M,Vector.const (None , N) _ ) )). - 2:{ remember t as lock__t . - extract. } - - cbn -[t] ;intro. subst t. setoid_rewrite lookup_funTable. reflexivity. - Qed. - - Definition step' (c : mconfig sig (state M) n) : mconfig sig (state M) n := - let (news, actions) := trans (cstate c, current_chars (ctapes c)) in - mk_mconfig news (doAct_multi (ctapes c) actions). - - #[export] Instance term_doAct_multi: computable (doAct_multi (n:=n) (sig:=sig)). - Proof. - extract. - Qed. - - - #[export] Instance term_step' : computable (step (M:=M)). - Proof. - extract. - Qed. - - #[export] Instance term_halt : computable (halt (m:=M)). - Proof. - pose (t:= (funTable (halt (m:=M)))). - apply computableExt with (x:= fun c => lookup c t false). - 2:{ extract. } - cbn;intro. subst t. setoid_rewrite lookup_funTable. reflexivity. - Qed. - - #[export] Instance term_haltConf : computable (haltConf (M:=M)). - Proof. - extract. - Qed. - - (* *** Computability of step-ndexed interpreter *) - #[export] Instance term_loopM : - computable (loopM (M:=M)). - Proof. - unfold loopM. (* as loop is already an encodable instance, this here is a bit out of the scope. Therefore, we unfold manually here. *) - extract. - Qed. - - Instance term_test cfg : - computable (fun k => LOptions.isSome (loopM (M := M) cfg k)). - Proof. - extract. - Qed. - -End loopM. diff --git a/theories/L/TM/TapeFuns.v b/theories/L/TM/TapeFuns.v deleted file mode 100644 index 206078f61..000000000 --- a/theories/L/TM/TapeFuns.v +++ /dev/null @@ -1,87 +0,0 @@ -From Undecidability.L.Datatypes Require Import LBool List.List_nat. -From Undecidability.L Require Import TM.TMEncoding. -From Undecidability.TM Require Import Util.TM_facts. - -Section fix_sig. - Variable sig : Type. - Context `{reg_sig : encodable sig}. - - Section reg_tapes. - - #[export] Instance term_tape_move_left' : computable (@tape_move_left' sig). - Proof. - extract. - Qed. - - #[export] Instance term_tape_move_left : computable (@tape_move_left sig). - Proof. - extract. - Qed. - - #[export] Instance term_tape_move_right' : computable (@tape_move_right' sig). - Proof. - extract. - Qed. - - #[export] Instance term_tape_move_right : computable (@tape_move_right sig). - Proof. - extract. - Qed. - - #[export] Instance term_tape_move : computable (@tape_move sig). - Proof. - extract. - Qed. - - #[export] Instance term_left : computable (@left sig). - Proof. - extract. - Qed. - - #[export] Instance term_right : computable (@right sig). - Proof. - extract. - Qed. - - #[export] Instance term_tape_write : computable (@tape_write sig). - Proof. - extract. - Qed. - - #[export] Instance term_tapeToList: computable (@tapeToList sig). - Proof. - extract. - Qed. - - #[export] Instance term_sizeOfTape: computable (@sizeOfTape sig). - Proof. - extract. - Qed. - - Import Nat. - - #[export] Instance term_current: computable ((current (Σ:=sig))). - Proof. - extract. - Qed. - - #[export] Instance term_current_chars n: computable (current_chars (sig:=sig) (n:=n)). - Proof. - extract. - Qed. - - #[export] Instance term_doAct: computable (doAct (sig:=sig)). - Proof. - extract. - Qed. - - - End reg_tapes. -End fix_sig. - -#[export] -Instance term_loop A `{encodable A} : - computable (@loop A). -Proof. - extract. -Qed. diff --git a/theories/L/Tactics/Computable.v b/theories/L/Tactics/Computable.v deleted file mode 100644 index a635e85e3..000000000 --- a/theories/L/Tactics/Computable.v +++ /dev/null @@ -1,245 +0,0 @@ -From Undecidability.L Require Export Util.L_facts Tactics.Extract. -Require Import String. - -(* * Correctness and time bounds *) - -(* Typeclass for registering types *) - -(* Encodable is in GenEncode *) - -Class encInj (X : Type) `(R : encodable X) := - inj_enc : injective (A:=X) enc (* encoding is injective *). - -#[export] Hint Mode encInj - + : typeclass_instances. (* treat argument as input and force evar-freeness*) - - -(* ** Correctness *) - -(* Definition of the valid types for extraction *) - -Inductive TT : Type -> Type := - TyB t (R : encodable t) : TT t -| TyArr t1 t2 (tt1 : TT t1) (tt2 : TT t2) - : TT (t1 -> t2). - -Existing Class TT. -#[export] Existing Instance TyB. -#[export] Existing Instance TyArr. - -Arguments TyB _ {_}. -Arguments TyArr {_} {_} _ _. - -#[export] Hint Mode TT + : typeclass_instances. (* treat argument as input and force evar-freeness*) - -Notation "! X" := (TyB X) (at level 69). -Notation "X ~> Y" := (TyArr X Y) (right associativity, at level 70). - - -Fixpoint computes {A} (tau : TT A) {struct tau}: A -> L.term -> Type := - match tau with - !_ => fun x xInt => (xInt = enc x) - | @TyArr A B tau1 tau2 => - fun f t_f => - proc t_f * forall (a : A) t_a, - computes tau1 a t_a - -> {v : term & (app t_f t_a >* v) * computes tau2 (f a) v} - end%type. - -Lemma computesProc t (ty : TT t) (f : t) fInt: - computes ty f fInt -> proc fInt. -Proof. - destruct ty. - -intros ->. unfold enc. now destruct R. - -now intros [? _]. -Qed. - -(* This is for a user to give an definition *) -Class computable X {ty : TT X} (x : X) : Type := - { - ext : extracted x; - extCorrect : computes ty x ext; - }. - -Global Arguments computable {X} {ty} x. -Global Arguments extCorrect {X} ty x {computable} : simpl never. -Global Arguments ext {X} {ty} x {computable} : simpl never. - -#[export] Hint Mode computable + - +: typeclass_instances. (* treat argument as input and force evar-freeness*) -#[export] Hint Extern 4 (@extracted ?t ?f) => let ty := constr:(_ : TT t) in notypeclasses refine (ext (ty:=ty) f) : typeclass_instances. - -#[export] Typeclasses Opaque ext. - -Lemma proc_ext X (ty : TT X) (x : X) ( H : computable x) : proc (ext x). -Proof. - unfold ext. destruct H. apply (computesProc extCorrect0). -Qed. - - -#[global] -Instance reg_is_ext ty (R : encodable ty) (x : ty) : computable x. -Proof. - exists (enc x). reflexivity. -Defined. (* because ? *) - - -Lemma computesTyB (t:Type) (x:t) `{encodable t}: computes (TyB t) x (ext x). -Proof. - unfold ext. now destruct R. -Qed. - -#[global] -Instance extApp' t1 t2 {tt1:TT t1} {tt2 : TT t2} (f: t1 -> t2) (x:t1) (Hf : computable f) (Hx : computable x) : computable (f x). -Proof. - destruct Hf, Hx. - edestruct extCorrect0 as [? H]. - edestruct H as (?&?&?). - eassumption. - now eapply (@Build_computable _ _ _ x0). -Defined. (* because ? *) - -Lemma extApp t1 t2 {tt1:TT t1} {tt2 : TT t2} (f: t1 -> t2) (x:t1) (Hf : computable f) (Hx : computable x) : - app (ext f) (ext x) >* ext (f x). -Proof. - unfold ext, extApp'. - destruct Hf, Hx. - destruct extCorrect0 as (? & correct0). - destruct correct0 as (?&?&?). tauto. -Qed. - -Lemma ext_is_enc t1 (R:encodable t1) (x: t1) (Hf : computable x) : - @ext _ _ x Hf = enc x. -Proof. - now destruct Hf. -Defined. (* because ? *) - -Definition computesExp {t} (ty : TT t) (f:t) (s fExt : term) : Type := - eval s fExt * computes ty f fExt. - -Lemma computesExpStart t1 (tt1 : TT t1) (f : t1) (fExt : term): - proc fExt -> - {v :term & computesExp tt1 f fExt v} -> computes tt1 f fExt. -Proof. - intros ? (?&?&?). replace fExt with x. tauto. apply unique_normal_forms. eapply e. eapply H. destruct e as [e ?]. now rewrite e. -Qed. - -Lemma computesExpStep t1 t2 (tt1 : TT t1) (tt2 : TT t2) (f : t1 -> t2) (s:term) (fExt : term): - eval s fExt -> closed s -> - (forall (y : t1) (yExt : term), computes tt1 y yExt -> {v : term & computesExp tt2 (f y) (app s yExt) v}%type) -> - computesExp (tt1 ~> tt2) f s fExt. -Proof. - intros ? ? H. split. assumption. split. split. now rewrite <-H0. now destruct H0. - intros ? ? exted. - edestruct H as (v&?&?). eassumption. - eexists v. split. rewrite H0 in e. now rewrite e. eauto. -Qed. - -Lemma computesTyArr t1 t2 (tt1 : TT t1) (tt2 : TT t2) f fExt : - proc fExt - -> (forall (y : t1) (yExt : term), - computes tt1 y yExt - -> {v : term & eval (app fExt yExt) v * (proc v -> computes tt2 (f y) v)}%type) - -> computes (tt1 ~> tt2) f fExt. -Proof. - intros ? H'. - split;[assumption|]. - intros y yExt yCorrect. - edestruct H' as (?&(R&?) & H''). eassumption. - eexists. split. - eassumption. - eapply H''. - split. 2:assumption. - rewrite <- R. apply app_closed. now destruct H. specialize (computesProc yCorrect) as []. easy. -Qed. - -(* Extensional equality to extract similar functions without unsopported features (e.g. informative deciders) instead *) - -Fixpoint extEq t {tt:TT t} : t -> t -> Prop:= - match tt with - TyB _ _ => eq - | @TyArr t1 t2 _ _ => fun f f' => forall (x : t1), extEq (f x) (f' x) - end. - - -#[global] -Instance extEq_refl t (tt:TT t): Reflexive (extEq (tt:=tt)). -Proof. - unfold Reflexive. - induction tt;cbn. - -reflexivity. - -intros f x. eauto. -Qed. - -Lemma computesExt X (tt : TT X) (x x' : X) s: - extEq x x' -> computes tt x s -> computes tt x' s. -Proof. - induction tt in x,x',s |-*;intros eq. - -inv eq. tauto. - -cbn in eq|-*. intros [H1 H2]. split. 1:tauto. - intros y t exts. - specialize (H2 y t exts) as (v&R&H2). - exists v. split. 1:assumption. - eapply IHtt2. 2:now eassumption. - apply eq. -Qed. - -Lemma computableExt X (tt : TT X) (x x' : X): - extEq x x' -> computable x -> computable x'. -Proof. - intros ? (s&?). exists s. eauto using computesExt. -Defined. (* because ? *) - -(* register a datatype via an function to another, e.g. vectors as lists *) - -Lemma registerAs X Y `{encodable X} (f:Y -> X) : encodable Y. -Proof. - eexists (fun x => enc (f x)). now destruct H. -Defined. -Arguments registerAs {_ _ _} _. - -Lemma registerInjAs X Y R `{@encInj X R} (f:Y -> X) : injective f -> encInj (registerAs f). -Proof. - unfold encInj. - intros ? ? ? H'. eapply H0, @inj_enc. all:easy. -Defined. (* because ? *) - - -(* Support for extracting registerAs-ed functions *) - -Fixpoint changeResType t1 t2 (tt1:TT t1) (tt2 : TT t2) : {t & TT t}:= - match tt1 with - TyB _ _ => existT _ t2 tt2 - | TyArr _ _ tt11 tt12 => - existT _ _ (TyArr tt11 (projT2 (changeResType tt12 tt2))) - end. - -Fixpoint resType t1 (tt1 : TT t1) : {t & encodable t} := - match tt1 with - @TyB _ R => existT _ _ R - | TyArr _ _ _ t2 => resType t2 - end. - -Fixpoint insertCast t1 (tt1 : TT t1) Y (R: encodable Y) {struct tt1}: - forall (cast : projT1 (resType tt1) -> Y) (f : t1), projT1 (changeResType tt1 (TyB Y)) := - match tt1 with - TyB _ _ => fun cast x => cast x - | TyArr _ _ tt11 tt12 => fun cast f x=> (insertCast (tt1:=tt12) R cast (f x)) - end. - - -Lemma cast_registeredAs t1 (tt1 : TT t1) Y (R: encodable Y) (cast : projT1 (resType tt1) -> Y) (f:t1) : - projT2 (resType tt1) = registerAs cast -> - computable (ty:=projT2 (changeResType tt1 (TyB Y))) (insertCast R cast f) -> - computable f. -Proof. - intros H (s&exts). - exists s. - induction tt1 in cast,f,H,s,exts |- *. - -cbn in H,exts|-*;unfold enc in *. rewrite H. exact exts. - -destruct exts as (?&exts). split. assumption. - intros x s__x ext__x. - specialize (exts x s__x ext__x) as (v &?&exts). - exists v. split. tauto. - eapply IHtt1_2. all:eassumption. -Qed. - -Opaque computes. diff --git a/theories/L/Tactics/ComputableTactics.v b/theories/L/Tactics/ComputableTactics.v deleted file mode 100644 index 2987f9c40..000000000 --- a/theories/L/Tactics/ComputableTactics.v +++ /dev/null @@ -1,314 +0,0 @@ -Require Import MetaCoq.Template.All Strings.Ascii. -From Undecidability.L.Tactics Require Import Lproc Computable Lsimpl Lbeta Lrewrite. -Require Export Ring Arith Lia. -Import L_Notations. - -(* ** Tactics proving correctness *) -Module Intern. - -Ltac visibleHead t := - match t with - ?h _ => visibleHead h - | _ => t - end. - -Ltac fold_encs := - match goal with - x:_ |- _ => - revert x;fold_encs;intros x; - let H := fresh "H" in - try (assert (H:@enc _ _ x= @enc _ _ x) by reflexivity; - try (unfold enc in H at 1; cbn in H;rewrite !H);clear H) - | _ => idtac - end. - - -Ltac recRem P:= - match goal with - | |- context[rho ?s] => - let rP := fresh "rP" in - set (rP:=s); - assert (proc rP);[unfold rP;solve [Lproc]| - set (P := rho rP); - assert (proc P);[unfold P;solve [Lproc]|]] - end. - -Ltac recStepInit P:= - once lazymatch eval lazy [P] in P with - | rho ?rP => - once lazymatch goal with - | |- eval _ _ => - let rec loop := - once lazymatch goal with - | |- ARS.star step (app P _) _ =>unfold P;apply rho_correct;now Lproc - | |- ARS.star step (app _ _) _ => eapply star_step_app_proper;[loop|reflexivity] - end - in - eapply eval_helper;[loop|fold P; unfold rP] - end - end. - - -Ltac recStepNew P := recStepInit P. - - -Ltac destructRefine := - once lazymatch goal with - |- ?R ?s _ => - match s with - | context C [match ?x with _ => _ end]=> - let t := type of x in - refine (_:R _ ((fun y:t => ltac:(destruct y)) x)); - (* refine index if applicable*) - once lazymatch goal with - |- (?R' ?i ?s1 ?s2) => tryif is_evar i then - refine (_:R' ((fun (y:t) (*(_ : x=y)*) => ltac:(destruct y)) x ) s1 s2) - else idtac - | _ => idtac - end; - once lazymatch goal with - | |- ?R2 ?i ?s ?t => - let i':= eval cbn zeta in i in - refine (_:R2 i' s t) + match goal with |- ?G => let G' := constr:(R2 i' s t) in idtac "could not refine" G "with" G' end - | _ => idtac - end; - let eq := fresh "eq" in destruct x eqn:eq - end - end. - -Ltac shelveIfUnsolved msg:= first[let n:= numgoals in guard n=0| - match goal with - |- ?G => idtac "Could not solve some subgoal("msg"):";idtac G;shelve - end]. - -Ltac ugly_fix_fix IH n := - (* we must destruct to allow the fix to reduce...*) - once lazymatch eval cbn in n with - 0 => fix IH 1 - | 1 => fix IH 4 - | 2 => fix IH 7 - | 3 => fix IH 10 - | _ => let m := eval cbn in (1+3*n) in - fail 1000 "please add '| "n" => fix IH"m"'" " in the definition of Ltac-tactic ugly_fix_fix!" - end. - -(* a non-recursive step*) -Ltac cstep' extractSimp:= - let x := fresh "x" in - once lazymatch goal with - | |- computes _ _ (match ?x with _ => _ end)=> - let eq := fresh "eq" in destruct x eqn:eq - | |- computes (TyArr ?tt1 ?tt2) ?f ?intF=> - let fRep := constr:(ltac:(quote_term f (fun x => exact x))) in - once lazymatch fRep with - (* a potentially recursive step *) - Ast.tFix (_::_::_) => fail 1000 "mutual recursion not supported" - | Ast.tFix [BasicAst.mkdef _ _ _(*<-dtype*) _(*<-dbody*) ?recArg(*<-recArg*)] 0 => - (let P := fresh "P" in - recRem P; - eapply computesExpStart;[solve [Lproc]|]; - let n:= (eval cbn in (S recArg)) in - let rec step n:= - (once lazymatch n with - | S ?n => - eexists; - eapply computesExpStep;[try recStep P;extractSimp;shelveIfUnsolved "pos5"|Lproc;shelveIfUnsolved "pos6"|]; - (*simple notypeclasses refine (_:computes (_ ~> _) _ _ (fun x xInt xNorm => (_,_)));try exact tt;shelve_unifiable;*) - let x := fresh "x" in - let xInt := fresh x "Int" in - let xInts := fresh x "Ints" in - intros x xInt xInts; - change xInt with (@ext _ _ x (Build_computable xInts)); - once lazymatch type of xInts with - computes (@TyB _ ?reg) _ _ => - rewrite (ext_is_enc (Build_computable xInts)) in *; - clear xInt xInts;assert (xInt:True) by constructor; assert (xInts:True) by constructor - | computes (TyArr _ _) _ _ => idtac - end; - step n; - revert x xInt xInts - | 0 => idtac - end) in - step n; - let IH := fresh "IH" P in - ugly_fix_fix IH recArg; - let rec loop n := (* destruct the struct-recursive argument*) - once lazymatch n with - 0 => intros [] ? ? - | S ?n' => intros ? ? ?;loop n' - end in - loop recArg; - eexists; - (split;[try recStepNew P;extractSimp;shelveIfUnsolved "pos7"|])) - - (* a non-recursive function *) - | _=> - let xInt := fresh x "Int" in - let xNorm := fresh x "Norm" in - let xInts := fresh x "Ints" in - let vProc := fresh "vProc" in - (*simple notypeclasses refine (_:computes (tt1 ~> tt2) _ _ (fun x xInt xNorm => (_,_)));try exact tt;shelve_unifiable;*) - eapply computesTyArr;[try Lproc;shelveIfUnsolved "pos1"|idtac]; - intros x xInt xInts; - change xInt with (@ext _ _ x (Build_computable xInts)); - once lazymatch tt1 with - TyB _ => rewrite (ext_is_enc (Build_computable xInts)) in *; - clear xInt xInts;assert (xInt:True) by constructor; assert (xInts:True) by constructor - | _ => idtac - end; - eexists;split;[extractSimp;shelveIfUnsolved "pos2" | intros vProc] - end - - | |- computes (TyB _) _ ?t=> has_no_evar t;apply computesTyB - - | |- computes _ _ (@ext _ _)=> apply extCorrect - - end. - -Tactic Notation "progress'" tactic(t) := - once lazymatch goal with - | |- ?R ?s _ =>idtac "now";print_goal; - t tt;idtac"then";print_goal; - once lazymatch goal with - |- R s _ => fail "noprogress" - | |- _ => idtac - end - end. - -Ltac extractCorrectCrush := - idtac; - try Lsimpl;try Lreflexivity; - try repeat' (repeat' Intern.destructRefine;Lsimpl;try Lreflexivity); - try Lreflexivity. - -Ltac extractSimple := - lazymatch goal with - |- eval _ _ => extractCorrectCrush - | |- ?G => idtac "cstep found unexpected" G - end;try (idtac;[idtac "could not simplify some occuring term, shelved instead"];shelve). - -Ltac cstep := cstep' extractSimple. - -Ltac computable_match:= - intros; - once lazymatch goal with - | |- ?R ?lhs ?rhs => - once lazymatch lhs with - | context C [@enc _ ?reg ?x] => - induction x; - let encf := (eval hnf in (@enc _ reg)) in - change (@enc _ reg) with encf; - cbn -[enc]; - repeat change encf with (@enc _ reg); - fold_encs; - once lazymatch goal with - | |- _ >(<= _ ) _ => Lreduce;try Lreflexivity - | |- _ >(_) _ => repeat progress Lbeta;try Lreflexivity - | |- _ >* _ => Lreduce;try Lreflexivity (* test *) - | |- eval _ _ => Lreduce;try Lreflexivity (* test *) - (*| |- _ >* _ => repeat Lsimpl';try reflexivity' - | |- eval _ _ => repeat Lsimpl';try reflexivity'*) - | |- _ == _ => repeat Lsimpl';try reflexivity' - end - end - end. - -Ltac infer_instances := - repeat match goal with - | [ |- context [ int_ext ?t ] ] => first [change (int_ext t) with (ext t) | fail 3 "Could not fold int-instance for " t] - end. - -Ltac computable_prepare t := - let h := visibleHead t in - tryif is_const h then unfold h else idtac. - -Ltac computable_using_noProof Lter:= - once lazymatch goal with - | [ |- computable ?t ] => - eexists Lter;unfold Lter;try clear Lter; - let t' := eval hnf in t in - let h := visibleHead t' in - try unfold h;computable_prepare t;infer_instances - end. - - -Ltac extractAs s := - once lazymatch goal with - | [ H : @extracted _ |- _ ] => idtac "WARNING: extraction is buggy if used while a term of type 'extracted _' is in Context" - | [ |- computable ?t ] => - (run_template_program (tmExtract None t) - (fun e => pose (s:= ( e : extracted t)))) - end. - - -Ltac extractThis t s := - (run_template_program (tmExtract None t) - (fun e => pose (s:= ( e : extracted t)))). - -End Intern. - -Import Intern. - -Ltac register_inj := - abstract (intros x; induction x; let y := fresh "y" in destruct y;simpl; intros eq; - try (injection eq || discriminate eq);intros;f_equal;auto;try apply inj_enc;try easy). - -Ltac register_proc := - solve [ - let x := fresh "x" in - (((intros x;induction x || intros *); - cbn; fold_encs;Lproc - ))]. - -Ltac register encf := refine (@mk_encodable _ encf _);[ - (((let x := fresh "x" in induction x || intros);(let f := Intern.visibleHead encf in unfold f;cbn [f]); - Lproc - ))]. - - -Tactic Notation "computable" "using" open_constr(Lter) := - computable_using_noProof Lter;repeat cstep. - -Tactic Notation "computable" "instead" open_constr(t) := - let s := fresh "s" in - extractThis t s; computable using s. - -Tactic Notation "computable" "infer" := - once lazymatch goal with - | [ |- computable ?t ] => - let e := constr:(int_ext t) in let e' := eval unfold int_ext in e in computable using e' - end. - -Tactic Notation "extract" := - unshelve - let term := fresh "used_term" in - extractAs term;computable using term. - - -Tactic Notation "extract" "constructor":= - let term := fresh "used_term" in - once lazymatch goal with - | [ |- computable ?t ] => - run_template_program (tmExtractConstr' None t) - (fun e => pose (term:= ( e : extracted t)); computable using term) - end. - -Tactic Notation "extract" "match" := computable_match. - -Lemma cast_computable X Y `{encodable Y} (cast : X -> Y) : - let _ := registerAs cast in - computable cast. -Proof. - cbn. - pose (t:=lam 0). - computable using t. -Qed. - -Ltac computable_casted_result := - match goal with - |- @computable _ _ _ => - simple notypeclasses refine (cast_registeredAs _ _); - [ | | | - cbn - [registerAs];reflexivity| ]; - cbn - end. diff --git a/theories/L/Tactics/Extract.v b/theories/L/Tactics/Extract.v deleted file mode 100644 index 4f60f7ecf..000000000 --- a/theories/L/Tactics/Extract.v +++ /dev/null @@ -1,625 +0,0 @@ -Require Import Ascii String. -From Undecidability.L Require Import Util.L_facts. -From MetaCoq Require Import Template.All Template.Checker. -Require Import Undecidability.Shared.Libs.PSL.Base. -Require Import MetaCoq.Utils.bytestring. - -Open Scope bs. - -Import MCMonadNotation. - -Fixpoint name_after_dot' (s : String.string) (r : String.string) := - match s with - | EmptyString => r - | String "#" xs => name_after_dot' xs xs (* see Coq_name in a section *) - | String "." xs => name_after_dot' xs xs - | String _ xs => name_after_dot' xs r - end. - -Definition name_after_dot s := name_after_dot' s s. - -Unset Universe Minimization ToSet. - -(* ** Extraction *) - -(* Global definition of fuel for step-indexed computations *) -Notation FUEL := 1000. - -(* Auxiliary functions *) -Definition string_of_int n := - match n with - | 0 => "0" - | 1 => "1" - | 2 => "2" - | 3 => "3" - | 4 => "4" - | 5 => "5" - | 6 => "6" - | 7 => "7" - | 8 => "8" - | 9 => "9" - | _ => "todo string_of_int" - end. - -(* it with acces to i *) -Section it_i. - Variables (X: Type) (f: nat -> X -> X). - - Fixpoint it_i' (i : nat) (n : nat) (x : X) : X := - match n with - | 0 => x - | S n' => f i (it_i' (S i) n' x) - end. - - Definition it_i := it_i' 0. -End it_i. - -(* apply all functions in a list of functions from right to left *) -Definition stack {X : Type} (l : list (X -> X)) (x : X) := fold_right (fun f x => f x) x l. - -(* Auxiliary monadic functions *) - -Open Scope bs. - -(* Get the head of a list *) -Definition hd {X : Type} (l : list X) : TemplateMonad X := - match l with - | nil => tmFail "hd: empty list" - | x :: _ => ret x - end. - -(* Get the type of a quoted term *) -Definition tmTypeOf (s : Ast.term) := - u <- tmUnquote s ;; - tmEval hnf (my_projT1 u) >>= tmQuote. - -(* Try to infer instance, otherwise make lemma *) -Definition tmTryInfer (n : ident) (red : option reductionStrategy) (A : Type) : TemplateMonad A := - r <- tmInferInstance red A ;; - match r with - | my_Some i => ret i - | my_None => - A' <- match red with Some red => ret A | None => ret A end;; - - (* term <- tmQuote A';; *) - (* tmEval cbv ("Did not find an instance for " ++ string_of_term term ++". You might want to register a instance for this.") >>= tmFail *) - (*Commented out because inside tactics, the error that tmLemmaRed is not allowed will hide the mor informative error massage above. *) - tmPrint "Did not find an instance for ";; - (tmPrint A');; - (tmEval cbv ("open obligation " ++ n ++ " for it. You might want to register a instance before and rerun this.") >>= tmPrint);; - tmLemma n A - end. - -(* Generate a name for a quoted term *) -Definition name_of (t : Ast.term) : ident := - match t with - tConst (modp, n) _ => String.of_string (name_after_dot (String.to_string n)) - | tConstruct (mkInd (modp, n) _) i _ => "cnstr_" ++ String.of_string (name_after_dot (String.to_string n)) ++ string_of_int i - | tInd (mkInd (modp, n) _) _ => "type_" ++ String.of_string (name_after_dot (String.to_string n)) - | tVar i => "var_" ++ i - | _ => "no_name" - end. - -(* Fixpoint fixNames (t : term) := *) -(* match t with *) -(* | tRel i => tRel i *) -(* | tEvar ev args => tEvar ev (List.map (fixNames) args) *) -(* | tLambda na T M => tLambda na (fixNames T) (fixNames M) *) -(* | tApp u v => tApp (fixNames u) (List.map (fixNames) v) *) -(* | tProd na A B => tProd na (fixNames A) (fixNames B) *) -(* | tCast C kind t => tCast (fixNames C) kind (fixNames t) *) -(* | tLetIn na b t b' => tLetIn na (fixNames b) (fixNames t) (fixNames b') *) -(* | tCase ind p C brs => *) -(* let brs' := List.map (on_snd (fixNames)) brs in *) -(* tCase ind (fixNames p) (fixNames C) brs' *) -(* | tProj p C => tProj p (fixNames C) *) -(* | tFix mfix idx => *) -(* let mfix' := List.map (map_def (fixNames) (fixNames)) mfix in *) -(* tFix mfix' idx *) -(* | tCoFix mfix idx => *) -(* let mfix' := List.map (map_def (fixNames) (fixNames)) mfix in *) -(* tCoFix mfix' idx *) -(* | tConst name u => tConst (name_after_dot name) u *) -(* | tInd (mkInd name i) u => tInd (mkInd (name_after_dot name) i) u *) -(* | x => x *) -(* end. *) - -(* Check whether a list of quoted terms starts with a type *) -Fixpoint tmIsType (s : Ast.term) : TemplateMonad bool := - match s with - | tInd _ _ => ret true - | tConst n u => t <- tmTypeOf (tConst n u) ;; match t with tSort _ => ret true | _ => ret false end - | tVar x => t <- tmTypeOf (tVar x) ;; match t with tSort _ => ret true | _ => ret false end - | tApp h _ => tmIsType h - | _ => ret false - end. - -(* Get the number of constructors for an inductive type *) -Definition tmNumConstructors (n : kername) : TemplateMonad nat := - i <- tmQuoteInductive n ;; - match ind_bodies i with - [ i ] => tmEval cbv (| ind_ctors i |) - | _ => tmFail "Mutual inductive types are not supported" - end. - -(* Get all argument types for a type *) -Fixpoint argument_types (B : Ast.term) := - match B with - | tProd _ A B => A :: argument_types B - | _ => [] - end. - -(* Split an inductive types applied to parameters into the naked inductive, the number of parameters and the list of parameters *) -Definition split_head_symbol A : option (inductive * list term) := - match A with - | tApp (tInd ind u) R => Some (ind, R) - | tInd ind u => Some (ind, []) - | _ => None - end. - -(* Get the list of consturcors for an inductive type (name, quoted term, number of arguments) *) -Definition list_constructors (ind : inductive) : TemplateMonad (list (ident * term * context)) := - A <- tmQuoteInductive (inductive_mind ind) ;; - match ind_bodies A with - | [ B ] => tmReturn (map (fun cstr => (cstr.(cstr_name), cstr.(cstr_type), cstr.(cstr_args))) (ind_ctors B)) - | _ => tmFail "error: no mutual inductives supported" - end. - -(* determine whether two inductives are equal, based on their name *) -Definition eq_inductive (hs hs2 : inductive) := - match hs, hs2 with - | mkInd k _, mkInd k2 _ => if eq_constant k k2 then true else false - end. - -(* Get the argument types for a constructor (specified by inductive and index) *) -Definition tmArgsOfConstructor ind i := - A <- tmTypeOf (tConstruct ind i []) ;; - ret (argument_types A). - - -(* Classes for computable terms and (Scott-) encodable types *) - -Class extracted {A : Type} (a : A) : Set := int_ext : L.term. -Arguments int_ext {_} _ {_}. -#[export] Typeclasses Transparent extracted. (* This is crucial to use this inside monads *) -#[export] Hint Extern 0 (extracted _) => progress (cbn [Common.my_projT1]): typeclass_instances. - -Class encodable (X : Type) := mk_encodable - { - enc : X -> L.term ; (* the encoding function for X *) - proc_enc : forall x, proc (enc x) ; (* encodings need to be a procedure *) - }. -Global Hint Mode encodable + : typeclass_instances. (* treat argument as input and force evar-freeness*) - -Arguments enc : simpl never. (* Never unfold with cbn/simpl *) - -(* Construct quoted L terms and natural numbers *) - -MetaCoq Quote Definition tTerm := L.term. - -Definition term_mp := MPfile ["L"; "L"; "Undecidability"]. -Definition term_kn := (term_mp, "term"). - -Definition mkLam x := tApp (tConstruct (mkInd term_kn 0) 2 []) [x]. -Definition mkVar x := tApp (tConstruct (mkInd term_kn 0) 0 []) [x]. -Definition mkApp x y := tApp (tConstruct (mkInd term_kn 0) 1 []) [x; y]. - -Definition mkAppList s B := fold_left (fun a b => mkApp a b) B s. - -MetaCoq Quote Definition mkZero := 0. -MetaCoq Quote Definition mkSucc := S. - -Fixpoint mkNat n := match n with - | 0 => mkZero - | S n => tApp mkSucc [mkNat n] - end. - -(* *** Generation of Scott encodings *) - -Fixpoint insert_params fuel Params i t := - let params := List.length Params in - match fuel with 0 => tmFail "out of fuel in insert_params" | S fuel => - match t with - | tRel n => (match nth_error Params (params + i - n - 1) with Some x => ret x | _ => ret (tRel n) (* tmFail "HERE" *) end) - | tApp s R => s <- insert_params fuel Params i s ;; - R <- monad_map (insert_params fuel Params i) R;; - ret (tApp s R) - | _ => ret t - end end. - - -Definition tmGetOption {X} (o : option X) (err : string) : TemplateMonad X := - match o with - | Some x => ret x - | None => tmFail err - end. - - -Definition tmGetMyOption {X} (o : option_instance X) (err : string) : TemplateMonad X := - match o with - | my_Some x => ret x - | my_None => tmFail err - end. - -Definition naNamed n := {| binder_name := nNamed n; binder_relevance := Relevant |}. -Definition naAnon := {| binder_name := nAnon; binder_relevance := Relevant |}. - -Fixpoint context_to_bcontext (ctx : context) : list aname := - match ctx with - | [] => [] - | mkdecl a b c :: L => a :: context_to_bcontext L - end. - -Definition mkFixMatch (f x : ident) (t1 t2 : Ast.term) (pred : Ast.predicate term) (cases : nat -> list term -> TemplateMonad term) := - hs_num <- tmGetOption (split_head_symbol t1) "no head symbol found";; - let '(ind, Params) := hs_num in - let params := List.length Params in - L <- list_constructors ind >>= tmEval hnf ;; - body <- monad_map_i (fun i '(n, s, args) => - l <- tmArgsOfConstructor ind i ;; - l' <- monad_map_i (insert_params FUEL Params) (skipn params l) ;; - t <- cases i l' ;; ret (mk_branch (context_to_bcontext args) t)) L ;; - ret (Ast.tFix [BasicAst.mkdef - Ast.term - (naNamed f) - (tProd naAnon t1 t2) - (tLambda (naNamed x) t1 (tCase (mk_case_info ind params Relevant) - pred - (tRel 0) - body)) 0] 0). - -#[global] -Existing Instance config.default_checker_flags. - -Definition encode_arguments (B : term) (a i : nat) A_j := - if eq_term uGraph.init_graph B A_j - then (* insert a recursive call *) - ret (tApp (tRel (S a)) [tRel (a - i -1)]) - else (* insert a call to the appropriate encoding function *) - A <- tmUnquoteTyped Type A_j ;; - name <- (tmEval cbv (name_of A_j ++ "_term") >>= tmFreshName) ;; - E <- tmTryInfer name None (encodable A);; - l <- tmQuote (@enc A E);; - ret (tApp l [tRel (a - i - 1) ]). - -Definition tmInstanceRed name red {X} (x:X) := - def' <- tmDefinitionRed name red x;; - def <- tmQuote def';; - match def with - tConst name _ => tmExistingInstance global (ConstRef name) - | _ => tmFail "internal invariant violated : tmInstanceRed" - end;; - tmReturn def'. - -Definition tmQuoteInductiveDecl (na : kername) : TemplateMonad (mutual_inductive_body * one_inductive_body) := - mdecl <- tmQuoteInductive na ;; - match ind_bodies mdecl with - [ idecl ] => tmReturn (mdecl, idecl) - | _ => tmFail "Mutual inductive types are not supported" - end. - -Definition tmEncode (A : Type) : TemplateMonad (A -> L.term) := - t <- (tmEval hnf A >>= tmQuote) ;; - hs_num <- tmGetOption (split_head_symbol t) "no inductive";; - let '(ind, Params) := hs_num in - decl <- tmQuoteInductiveDecl (inductive_mind ind) ;; - let '(mdecl,idecl) := decl in - num <- tmEval cbv (| ind_ctors idecl |) ;; - let params := firstn mdecl.(ind_npars) Params in - f <- tmFreshName ("enc_" ++ snd (inductive_mind ind)) ;; -(* - Definition tmEncode (A : Type) : TemplateMonad (A -> L.term):= - t <- (tmEval hnf A >>= tmQuote) ;; - hs_num <- tmGetOption (split_head_symbol t) "no inductive";; - let '(ind, Params) := hs_num in - num <- tmNumConstructors (inductive_mind ind) ;; - f <- tmFreshName ("enc_" ++ snd (inductive_mind ind)) ;; -*) - x <- tmFreshName "x" ;; - ter <- mkFixMatch f x t (* argument type *) tTerm (* return type *) (mk_predicate Instance.empty params (context_to_bcontext (ind_predicate_context ind mdecl idecl)) tTerm) - (fun i (* ctr index *) ctr_types (* ctr type *) => - args <- tmEval cbv (|ctr_types|);; - C <- monad_map_i (encode_arguments t args) ctr_types ;; - ret ( (* stack (map (tLambda (naAnon)) ctr_types) *) - (it mkLam num ((fun s => mkAppList s C) (mkVar (mkNat (num - i - 1)))))) - ) ;; - u <- tmUnquoteTyped (A -> L.term) ter;; - ret u. - -(* **** Examples *) -(* Commented out for less printing while compiling *) - -(* MetaCoq Run (tmEncode unit >>= tmPrint). - -MetaCoq Run (tmEncode bool >>= tmPrint). - -MetaCoq Run (tmEncode nat >>= tmPrint). - -Section term. - Context { encA : encodable nat}. - MetaCoq Run (tmEncode L.term >>= tmPrint). -End term. - -Inductive triple (X Y Z : Type) : Type := - trip (x : X) (y : Y) (z : Z) : triple X Y Z. - -Section encode. - - Variable A B C : Type. - Context { encA : encodable A}. - Context { encB : encodable B}. - Context { encC : encodable C}. - - MetaCoq Run (tmEncode (@prod A B) >>= tmPrint). - - MetaCoq Run (tmEncode (@list A) >>= tmPrint). - - MetaCoq Run (tmEncode (@triple A B C) >>= tmPrint). - -End encode. *) - -(* *** Generation of constructors *) - -Definition gen_constructor args num i := - it lam args (it lam num (it_i (fun n s => L.app s #(n + num)) args (var (num - i - 1)))). - -Definition extract_constr {A} (a : A) n (i : nat) (t : Ast.term) def' := - num <- tmNumConstructors n ;; - r <- tmEval cbv (gen_constructor (|argument_types t|) num i : extracted a) ;; - match def' with - | Some def => def2 <- tmFreshName def ;; - tmInstanceRed def2 None r;;tmReturn tt - | None => tmReturn tt - end;; - ret r. - -Definition tmExtractConstr' (def : option ident) {A : Type} (a : A) := - s <- (tmEval cbv a >>= tmQuote) ;; - t <- (tmEval hnf A >>= tmQuote) ;; - match s with - | Ast.tApp (Ast.tConstruct (mkInd n _) i _) _ => - extract_constr a n i t def - | Ast.tConstruct (mkInd n _) i _ => - extract_constr a n i t def - | _ => tmFail "this is not a constructor" - end. - -Definition tmExtractConstr (def : ident) {A : Type} (a : A) := - tmExtractConstr' (Some def) a. - -(* **** Examples *) -(* Commented out for less printing while compiling *) - -(* Section Fix_X. *) - -(* Context {X : Set}. *) - -(* MetaCoq Run (tmExtractConstr "zero_term" 0 >>= tmPrint). *) - -(* MetaCoq Run (tmExtractConstr "S_term" S >>= tmPrint). *) - -(* MetaCoq Run (tmExtractConstr "nil_term" (@nil X) >>= tmPrint). *) - -(* MetaCoq Run (tmExtractConstr "cons_term" (@cons X) >>= tmPrint). *) - -(* End Fix_X. *) - -(* *** Extracting terms from Coq to L *) - -Definition lift env := (fun n => match n with 0 => 0 | S n => S (env n) end). - -Notation "↑ env" := (fun n => match n with 0 => 0 | S n => S (env n) end) (at level 10). -(* -Local Definition error {A} (a:A) := 1000. -Opaque error. - -(*Get the free variables*) -Fixpoint freeVars (s:Ast.term) : list nat := - match s with - tProd _ ty bd=> - freeVars ty ++ (List.concat (map (fun x => match x with 0 => [] | S n => [n] end) (freeVars bd))) - | tRel i => [i] - | tApp hd args => - fold_left (fun l1 l2 =>List.app l1 (freeVars l2)) args (freeVars hd) - | tInd _ _ => [] - | tSort _ => [] - | tConstruct _ _ _ => [] - | tConst _ _ => [] - | _ => [error ("freeVars",s)] - end. - -Definition isClosed (s:Ast.term) -(*Get a term representing a type of form 'forall x1 ...xn, T' and returns the number of paramaters*) -Fixpoint dependentArgs (s:Ast.term) : nat := - match s with - tProd _ ty bd=> - let l := dependentArgs bd in - match l with - S n => S l - | 0 => if existsb (fun x => x <=? 0) (freeVars bd) then 1 else 0 - end - | _ => 0 - end. - -Definition tmDependentArgs x:= - match x with - Ast.tConst _ _ => t <- tmTypeOf x;;tmEval cbn (dependentArgs t) >>= ret - | Ast.tConstruct _ _ _ => t <- tmTypeOf x;;tmEval cbn (dependentArgs t) >>= ret - | Ast.tRel _ => ret 0 - | Ast.tLambda _ _ _ => (*tmPrint ("tmDependentArgs currently assumes that abstractions on head position mean there are no parametric arguments");;*)ret 0 - | _ => (*tmPrint ("tmDependentArgs not supported");;*)ret 0 - end. - *) - -Fixpoint inferHead' (s:Ast.term) (revArg R: list Ast.term) : TemplateMonad (L.term * list Ast.term) := - s'0 <- tmEval cbn (if forallb (fun _ => false) revArg then s else Ast.tApp s (rev revArg));; - s' <- tmUnquote s'0;; - s'' <- tmEval cbn (my_projT2 s');; - res <- tmInferInstance None (extracted (A:=my_projT1 s') s'');; - match res with - my_Some s'' => ret (s'',R) - | my_None => - let doSplit := match R with - | [] => false - | r :: R => if closedn 0 r then true else false - end - in - match doSplit,R with - true,r::R => inferHead' s (r::revArg) R - | _,_ => let lhs := string_of_term s'0 in - let rhs := string_of_list string_of_term R in - tmMsg "More readable: initial segment:";;tmPrint s'';;tmMsg "With remainder:";;tmPrint R;; - tmFail ("Could not extract in inferHead (moreReadable version in *coq*): could not infer any instance for initial segment of " ++lhs ++ " with further arguments "++ rhs) - end - end. - -(* Tries to infer an extracted instance for all initial segments of the term, or to give *) -Definition inferHead (s:Ast.term) (R:list Ast.term) : TemplateMonad ((L.term + Ast.term) * list Ast.term) := - match s with - Ast.tConst _ _ | - Ast.tConstruct _ _ _ => - res <- inferHead' s [] R;; - let '(s',R):= res in - ret (inl s',R) - | _ => ret (inr s,R) - end. - -Fixpoint extract (env : nat -> nat) (s : Ast.term) (fuel : nat) : TemplateMonad L.term := - match fuel with 0 => tmFail "out of fuel" | S fuel => - match s with - Ast.tRel n => - t <- tmEval cbv (var (env n));; - ret t - | Ast.tLambda _ _ s => - t <- extract (↑ env) s fuel ;; - ret (lam t) - | Ast.tFix [BasicAst.mkdef nm ty s _] _ => - t <- extract (fun n => S (env n)) (Ast.tLambda nm ty s) fuel ;; - ret (rho t) - | Ast.tApp s R => - res <- inferHead s R;; - let '(res,R') := res in - (*tmPrint ("infHead:",res,R');;*) - t <- (match res with - inl s' => ret s' - | inr s => extract env s fuel - end);; - monad_fold_left (fun t1 s2 => t2 <- extract env s2 fuel ;; ret (L.app t1 t2)) R' t - (*else - let (P, L) := (firstn params R,skipn params R) in - s' <- tmEval cbv (Ast.tApp s P);; - (if closedn 0 s' then ret tt else tmPrint ("Can't extract ",s);;tmFail "The term contains variables as type parameters.");; - a <- tmUnquote s' ;; - a' <- tmEval cbn (my_projT2 a);; - nm <- (tmEval cbv (String.append (name_of s) "_term") >>= tmFreshName) ;; - i <- tmTryInfer nm (Some cbn) (extracted a') ;; - let t := (@int_ext _ _ i) in - monad_fold_left (fun t1 s2 => t2 <- extract env s2 fuel ;; ret (L.app t1 t2)) L t *) - | Ast.tConst n _ => - a <- tmUnquote s ;; - a' <- tmEval cbn (my_projT2 a);; - n <- (tmEval cbv (String.append (name_of s) "_term") >>= tmFreshName) ;; - i <- tmTryInfer n (Some cbn) (extracted a') ;; (* TODO: Is hnf okay? *) - ret (@int_ext _ _ i) - - | Ast.tConstruct (mkInd n _) _ _ => - a <- tmUnquote s ;; - a' <- tmEval cbn (my_projT2 a);; - nm <- (tmEval cbv (String.append (name_of s) "_term") >>= tmFreshName) ;; - i <- tmTryInfer nm (Some cbn) (extracted a') ;; - ret (@int_ext _ _ i) - | Ast.tCase _ _ s cases => - t <- extract env s fuel ;; - M <- monad_fold_left (fun t1 br => len <- tmEval cbv (List.length br.(bcontext)) ;; t2 <- extract (fun i => S (it lift (len) env i)) br.(bbody) fuel ;; t2' <- tmEval cbn (it lam len (lam t2)) ;; ret (L.app t1 t2')) cases t ;; - ret (L.app M I) - | Ast.tLetIn _ s1 _ s2 => - t1 <- extract env s1 fuel ;; - t2 <- extract (↑ env) s2 fuel ;; - ret( L.app (lam t2) t1) - - | Ast.tFix _ _ => tmFail "Mutual Fixpoints are not supported" - | tVar _ => a <- tmUnquote s ;; - a' <- tmEval cbn (my_projT2 a);; - n <- (tmEval cbv (String.append (name_of s) "_term") >>= tmFreshName) ;; - i <- tmTryInfer n (Some cbn) (extracted a') ;; - ret (@int_ext _ _ i) - | tEvar _ _ => tmFail "tEvar is not supported" - | tSort _ => tmFail "tSort is not supported" - | tCast _ _ _ => tmFail "tCast is not supported" - | tProd _ _ _ => tmFail "tProd is not supported" - | tInd a _ => tmPrint a;;tmFail "tInd is not supported (probably there is a type not in prenex-normal form)" - | tProj _ _ => tmFail "tProj is not supported" - | tCoFix _ _ => tmFail "tCoFix is not supported" - | tInt _ => tmFail "tInt is not supported" - | tFloat _ => tmFail "tFloat is not supported" - | tString _ => tmFail "tString is not supported" - | tArray _ _ _ _ => tmFail "tArray is not supported" - end end. - -Fixpoint head_of_const (t : term) := - match t with - | tConst h _ => Some h - | tApp s _ => head_of_const s - | _ => None - end. - -Definition tmUnfoldTerm {A}(a:A) := - t <- tmQuote a;; - match head_of_const t with - | Some h => tmEval (unfold h) a >>=tmQuote - | _ => ret t - end. - -Polymorphic Definition tmExtract (nm : option string) {A} (a : A) : TemplateMonad (extracted a) := - q <- tmUnfoldTerm a ;; - t <- extract (fun x => x) q FUEL ;; - match nm with - Some nm => nm <- tmFreshName nm ;; - @tmInstanceRed nm None (extracted a) t ;; - ret t - | None => ret t - end. - -Opaque extracted. - -(* **** Examples *) -(* Commented out for less printing while compiling *) - -(* Fixpoint ackermann n : nat -> nat := *) -(* match n with *) -(* 0 => S *) -(* | S n => fix ackermann_Sn m : nat := *) -(* match m with *) -(* 0 => ackermann n 1 *) -(* | S m => ackermann n (ackermann_Sn m) *) -(* end *) -(* end. *) - -(* MetaCoq Run (tmExtractConstr "tm_zero" 0). *) -(* MetaCoq Run (tmExtractConstr "tm_succ" S). *) -(* (* MetaCoq Run (tmExtract (Some "tm_ack") ackermann >>= tmPrint). *) *) - -(* (* Print tm_ack. *) *) - -(* Require Import Init.Nat. *) -(* MetaCoq Run (tmExtract (Some "add_term") add ). *) -(* Print add_term. *) - -(* MetaCoq Run (tmExtract (Some "mult_term") mult). *) - -(* Section extract. *) - -(* Context { A B : Set }. *) -(* Context { encB : encodable B }. *) - - -(* MetaCoq Run (tmExtract (Some "map_term") (@map A B) >>= tmPrint). *) -(* Print map_term. *) - -(* MetaCoq Run (tmExtract (Some "filter_term") (@filter A) >>= tmPrint). *) -(* Print filter_term. *) - -(* End extract. *) - -Global Obligation Tactic := idtac. - diff --git a/theories/L/Tactics/GenEncode.v b/theories/L/Tactics/GenEncode.v deleted file mode 100644 index 042b57924..000000000 --- a/theories/L/Tactics/GenEncode.v +++ /dev/null @@ -1,111 +0,0 @@ -From Undecidability.L Require Import L Tactics.Computable Tactics.ComputableTactics Tactics.Extract. -From MetaCoq Require Import Template.All TemplateMonad.Core Template.Ast. -Require Import List. -Require Export MetaCoq.Utils.bytestring. - -Import MCMonadNotation. -Local Open Scope bs. - -(* *** Generation of encoding functions *) - -Fixpoint mkLApp (s : term) (L : list term) := - match L with - | [] => s - | t :: L => mkLApp (tApp (tConstruct (mkInd term_kn 0) 1 []) [s; t]) L - end. - -Definition encode_arguments (B : term) (a i : nat) A_j := - A <- tmUnquoteTyped Type A_j ;; - name <- (tmEval cbv (name_of A_j ++ "_term") >>= Core.tmFreshName) ;; - E <- tmTryInfer name None (encodable A);; - t <- ret (@enc A E);; - l <- tmQuote t;; - ret (tApp l [tRel (a - i - 1) ]). - -Definition mkMatch (t1 t2 d : Ast.term) (pred : Ast.predicate term) (cases : nat -> list term -> Core.TemplateMonad term) := - hs_num <- tmGetOption (split_head_symbol t1) "no head symbol found";; - let '(ind, Params) := hs_num in - let params := List.length Params in - L <- list_constructors ind >>= tmEval hnf ;; - body <- monad_map_i (fun i '(n, s, args) => - l <- tmArgsOfConstructor ind i ;; - l' <- monad_map_i (insert_params FUEL Params) (skipn params l) ;; - t <- cases i l' ;; ret (mk_branch (context_to_bcontext args) t)) L ;; -ret (tCase (mk_case_info ind params Relevant) - pred - d - body). - -Definition L_facts_mp := MPfile ["L_facts"; "Util"; "L"; "Undecidability"]. - -Definition tmMatchCorrect (A : Type) : Core.TemplateMonad Prop := - t <- (tmEval hnf A >>= tmQuote) ;; - hs_num <- tmGetOption (split_head_symbol t) "no inductive";; - let '(ind, Params) := hs_num in - decl <- tmQuoteInductiveDecl (inductive_mind ind) ;; - let '(mdecl,idecl) := decl in - let params := firstn mdecl.(ind_npars) Params in - num <- tmEval cbv (| ind_ctors idecl |) ;; - x <- Core.tmFreshName "x" ;; - mtch <- mkMatch t (* argument type *) tTerm (* return type *) (tRel (2 * num)) - (mk_predicate Instance.empty params (context_to_bcontext (ind_predicate_context ind mdecl idecl)) tTerm) - (fun i (* ctr index *) ctr_types (* ctr type *) => - args <- tmEval cbv (|ctr_types|);; - C <- monad_map_i (encode_arguments t args) ctr_types ;; - ret ( (* stack (map (tLambda (naAnon)) ctr_types) *) - (((fun s => mkAppList s C) (tRel (args + 2 * (num - i) - 1))))) - ) ;; - E' <- Core.tmInferInstance None (encodable A);; - E <- tmGetMyOption E' "failed" ;; - t' <- ret (@enc A E);; - l <- tmQuote t';; - encn <- ret (tApp l [tRel (2*num) ]) ;; - lhs <- ret (mkLApp encn ((fix f n := match n with 0 => [] | S n => tRel (2 * n + 1) :: f n end ) num)) ;; - ter <- ret (tProd naAnon t (it (fun s : term => tProd naAnon tTerm (tProd naAnon (tApp (tConst (L_facts_mp, "proc") []) [tRel 0]) s)) num ((tApp (tConst (L_facts_mp, "redLe") []) [mkNat num; lhs; mtch]))));; - ter <- tmEval cbv ter ;; - tmUnquoteTyped Prop ter. - -Definition matchlem n A := (Core.tmBind (tmMatchCorrect A) (fun m => tmLemma n m ;; ret tt)). - -Definition tmGenEncode (n : ident) (A : Type) : TemplateMonad (encodable A) := - e <- tmEncode A;; - modpath <- tmCurrentModPath tt ;; - p <- Core.tmLemma (n ++ "_proc") (forall x : A, proc (e x)) ;; - n3 <- tmEval cbv ("encodable_" ++ n) ;; - d <- tmInstanceRed n3 None (mk_encodable p);; - m <- tmMatchCorrect A;; - n4 <- tmEval cbv (n ++ "_correct") ;; - Core.tmBind (tmMatchCorrect A) (fun m' => tmLemma n4 m';;ret d). - -Arguments tmGenEncode _%_bs _%_type. - -Definition tmGenEncodeInj (n : ident) (A : Type) : TemplateMonad unit := - d <- tmGenEncode n A;; - n2 <- tmEval cbv ((n ++ "_inj"));; - i <- Core.tmLemma n2 (@encInj A d);; - n3 <- tmEval cbv ("encInj_" ++ n) ;; - d <- tmInstanceRed n3 None i;; - ret tt. - -Arguments tmGenEncodeInj _%_bs _%_type. - - -(* -Definition tmGenEncode' (n : ident) (A : Type) := - e <- tmEncode n A;; - modpath <- tmCurrentModPath tt ;; - e <- tmUnquoteTyped (encodable A) (tConst (modpath, n) []);; - p <- Core.tmLemma (n ++ "_proc") (forall x : A, proc (@enc_f A e x)) ;; - n2 <- tmEval cbv ((n ++ "_inj"));; - i <- Core.tmLemma n2 (injective (@enc_f _ e)) ;; - n3 <- tmEval cbv ("encodable_" ++ n) ;; - d <- tmInstanceRed n3 None (@mk_registered A e p i);; - m <- tmMatchCorrect A ;; ret tt. *) - -(* TODO : use other methode instead, e.g. with typeclasses, as default obligation tactic is very fragile *) -Global Obligation Tactic := match goal with - | [ |- forall x : ?X, proc ?f ] => try register_proc - | [ |- encInj _ ] => unfold encInj;register_inj - | [ |- injective ?f ] => register_inj - | [ |- context [_ >(<= _) _] ] => extract match - end || Tactics.program_simpl. diff --git a/theories/L/Tactics/LClos.v b/theories/L/Tactics/LClos.v deleted file mode 100644 index cd1dc93ca..000000000 --- a/theories/L/Tactics/LClos.v +++ /dev/null @@ -1,648 +0,0 @@ -From Undecidability.L Require Export Util.L_facts. - -(* **** Closure calculus *) - -Inductive Comp : Type := -| CompVar (x:nat) -| CompApp (s : Comp) (t : Comp) : Comp -| CompClos (s : term) (A : list Comp) : Comp. - -Coercion CompApp : Comp >-> Funclass. - -Inductive lamComp : Comp -> Prop := lambdaComp s A: lamComp (CompClos (lam s) A). - -Inductive validComp : Comp -> Prop := -| validCompApp s t : validComp s -> validComp t -> validComp (s t) -| validCompClos (s : term) (A : list Comp) : - (forall a, a el A -> validComp a) -> (forall a, a el A -> lamComp a) -> bound (length A) s -> validComp (CompClos s A). - -#[export] Hint Constructors Comp lamComp validComp : core. - -Definition validEnv A := forall a, a el A -> validComp a (*/\ lamComp a)*). - -Definition validEnv' A := forall a, a el A -> closed a. - -#[export] Hint Unfold validEnv validEnv' : core. - -Lemma validEnv_cons a A : validEnv (a::A) <-> ((validComp a) /\ validEnv A). -Proof. - unfold validEnv. simpl. split. auto. intros [? ?] a' [eq|el']; subst;auto. -Qed. - -Lemma validEnv'_cons a A : validEnv' (a::A) <-> (closed a /\ validEnv' A). -Proof. - unfold validEnv'. simpl. intuition. now subst. -Qed. - -Ltac inv_validComp := - match goal with - | H : validComp (CompApp _ _) |- _ => inv H - | H : validComp (CompClos _ _) |- _ => inv H - end. - -Definition Comp_ind_deep' - (P : Comp -> Prop) - (Pl : list Comp -> Prop) - (IHVar : forall x : nat, P (CompVar x)) - (IHApp : forall s : Comp, P s -> forall t : Comp, P t -> P (s t)) - (IHClos : forall (s : term) (A : list Comp), - Pl A -> P (CompClos s A)) - (IHNil : Pl nil) - (IHCons : forall (a:Comp) (A : list Comp), - P a -> Pl A -> Pl (a::A)) - (x:Comp) : P x := - (fix f c : P c:= - match c with - | CompVar x => IHVar x - | CompApp s t => IHApp s (f s) t (f t) - | CompClos s A => IHClos s A - ((fix g A : Pl A := - match A with - [] => IHNil - | a::A => IHCons a A (f a) (g A) - end) A) - end) x -. - -Definition Comp_ind_deep - (P : Comp -> Prop) - (IHVar : forall x : nat, P (CompVar x)) - (IHApp : forall s : Comp, P s -> forall t : Comp, P t -> P (s t)) - (IHClos : forall (s : term) (A : list Comp), - (forall a, a el A -> P a) -> P (CompClos s A)) : forall x, P x. -Proof. - apply Comp_ind_deep' with (Pl:=fun A => (forall a, a el A -> P a)); [auto..|easy|]. - intros. inv H1;auto. -Qed. - -(* -Lemma subst_comm s x1 u1 x2 u2 : closed u1 -> closed u2 -> x1 <> x2 -> subst (subst s x1 u1) x2 u2 = subst (subst s x2 u2) x1 u1. -Proof with try (congruence||auto). - intros cl1 cl2 neq. revert x1 x2 neq;induction s;simpl;intros. - -decide (n=x1); decide (n=x2); try rewrite cl1;try rewrite cl2;subst;simpl... - +decide (x1=x1)... - +decide (x2=x2)... - +decide (n=x2);decide (n=x1)... - -rewrite IHs1,IHs2... - -rewrite IHs... -Qed. -*) (* -Lemma subst_twice s x u1 u2 : closed u1 -> subst (subst s x u1) x u2 = subst s x u1. -Proof with try (congruence||auto). - intros cl. revert x;induction s;simpl;intros. - -decide (n=x);subst. now rewrite cl. simpl. decide (n=x);subst;congruence. - -rewrite IHs1,IHs2... - -rewrite IHs... -Qed.*) -(* -Lemma subst_free a s k u y: closed a -> subst s k u = s -> subst (subst s y a) k u = subst s y a. -Proof. - intros ca eq. revert y k u eq. induction s;simpl;intros. - -decide (n=y). now rewrite ca. apply eq. - -simpl in eq. inversion eq. rewrite H0, H1, IHs1, IHs2;auto. - -f_equal. simpl in eq. inversion eq. rewrite !H0. now rewrite IHs. -Qed.*) -(* -Lemma bound_ge k s m: bound k s -> m >= k -> bound m s. -Proof. - intros. decide (m=k);subst. - -auto. - -eapply bound_gt;eauto. lia. -Qed. -*) -(* -Lemma bound_subst' x s a y: bound x s -> closed a -> bound x (subst s y a). -Proof. - intros dcl cl. revert y. induction dcl;simpl;intros. - -decide (n=y);subst. - +eapply bound_ge. now apply closed_dcl. lia. - +now constructor. - -now constructor. - -now constructor. -Qed. -*) - -(* -Fixpoint substList' (s:term) (x:nat) (A: list term): term := - match A with - | nil => s - | a::A => substList' (subst s x a) (S x) A - end.*) - -Fixpoint substList (s:term) (x:nat) (A: list term): term := - match s with - | var n => if Dec (x>n) then var n else nth (n-x) A (var n) - | app s t => app (substList s x A) (substList t x A) - | lam s => lam (substList s (S x) A) - end. - - -Fixpoint deClos (s:Comp) : term := - match s with - | CompVar x => var x - | CompApp s t => app (deClos s) (deClos t) - | CompClos s A => substList s 0 (map deClos A) - end. - -(* Reduction *) - -Reserved Notation "s '>[(' l ')]' t" (at level 50, format "s '>[(' l ')]' t"). - -Declare Scope LClos. - -Inductive CPow : nat -> Comp -> Comp -> Prop := -| CPowRefl (s:Comp) : s >[(0)] s -| CPowTrans (s t u:Comp) i j : s >[(i)] t -> t >[(j)] u -> s >[(i+j)] u -| CPowAppL (s s' t :Comp) l: s >[(l)] s' -> (s t) >[(l)] (s' t) -| CPowAppR (s t t':Comp) l: t >[(l)] t' -> (s t) >[(l)] (s t') -| CPowApp (s t:term) (A:list Comp) : - CompClos (app s t) A >[(0)] (CompClos s A) (CompClos t A) -| CPowVar (x:nat) (A:list Comp): - CompClos (var x) A >[(0)] nth x A (CompVar x) -| CPowVal (s t:term) (A B:list Comp): - lambda t -> (CompClos (lam s) A) (CompClos t B) >[(1)] (CompClos s ((CompClos t B)::A)) -where "s '>[(' l ')]' t" := (CPow l s t) : LClos. - -Open Scope LClos. - -Ltac inv_CompStep := - match goal with - | H : (CompApp _ _) >(_) CompClos _ _ |- _ => inv H - | H : (CompClos _ _) >(_) CompApp _ _ |- _ => inv H - end. - -#[export] Hint Constructors CPow : core. - -Lemma CPow_congL n s s' t : - s >[(n)] s' -> s t >[(n)] s' t. -Proof. - induction 1;eauto. -Qed. - -Lemma CPow_congR n (s t t' : Comp) : - t >[(n)] t' -> s t >[(n)] s t'. -Proof. - induction 1;eauto. -Qed. - -Lemma CPow_trans s t u i j k : s >[(i)] t -> t >[(j)] u -> i + j = k -> s >[(k)] u. -Proof. - intros. subst. eauto. -Qed. - - -#[global] -Instance CPow'_App_properR n: - Proper (eq ==> (CPow n) ==> (CPow n)) CompApp. -Proof. - intros ? ? -> ? ? ?. now eapply CPow_congR. -Qed. -(* -Definition CStar s t:= exists k , CPow k s t . - -Notation "s '>[]*' t" := (CStar s t) (at level 50) : L.los. - -Instance rStar'_PreOrder : PreOrder CStar. -Proof. - constructor; hnf. - -now eexists. - -eapply star_trans. -Qed. - -Lemma rStar'_trans_l s s' t : - s >[]* s' -> s t >[]* s' t. -Proof. - induction 1; eauto using star. -Qed. - -Lemma rStar'_trans_r (s t t' : Comp): - t >[]* t' -> s t >[]* s t'. -Proof. - induction 1; eauto using star. -Qed. - -Instance rStar'_App_proper : - Proper ((star CStep) ==> (star CStep) ==> (star CStep)) CompApp. -Proof. - cbv. intros s s' A t t' B. etransitivity. - apply rStar'_trans_l, A. apply rStar'_trans_r, B. -Qed. - -Instance CStep_star_subrelation : subrelation CStep (star CStep). -Proof. - intros s t st. eauto using star. -Qed. - -*) - - -(* Properties of step-indexed version *) -(* -Notation "x '>[]^' n y" := (ARS.pow CStep n x y) (at level 50) : L.cope. - -Lemma CStep_Lam n: forall (s t u:Comp), lamComp u -> (ARS.pow CStep n (s t) u) -> - exists m1 m2 (s' t':Comp),(m1 < n /\ ARS.pow CStep m1 s s' /\ lamComp s') - /\ (m2 < n /\ ARS.pow CStep m2 t t' /\ lamComp t'). -Proof with repeat intuition;try now reflexivity. - induction n;intros ? ? ? lu R. - -inv R. inv lu. - -destruct R as [u' [R R']]. inv R. - +apply IHn in R'... decompose [ex and] R'. exists (S x), x0, x1, x2... change (S x) with (1+x). apply pow_add;simpl. exists s';intuition. eexists;simpl... - +apply IHn in R'... decompose [ex and] R'. exists x, (S x0), x1, x2... change (S x0) with (1+x0). apply pow_add;simpl. exists t';intuition. eexists;simpl... - +inv H2. eexists 0,0,_,_... -Qed. - -Lemma CStep_Lam' (s t u:Comp) : lamComp u -> (s t) >[]* u -> - exists (s' t':Comp),( s >[]* s' /\ lamComp s') - /\ (t >[]* t' /\ lamComp t'). -Proof with repeat intuition;try now reflexivity. - intros lu R. apply star_pow in R. destruct R as [n R]. revert s t u lu R. induction n;intros. - -inv R. inv lu. - -destruct R as [u' [R R']]. inv R. - +apply IHn in R'... decompose [ex and] R'. exists x, x0... eauto using star. - +apply IHn in R'... decompose [ex and] R'. exists x, x0... eauto using star. - +inv H2. eexists _,_... -Qed. - - - -*) -Lemma substList_bound x s A: bound x s -> substList s x A = s. -Proof. - revert x;induction s;intros;simpl. - -inv H. decide (x>n);tauto. - -inv H. now rewrite IHs1,IHs2. - -inv H. rewrite IHs;auto. -Qed. - -Lemma substList_closed s A x: closed s -> substList s x A = s. -Proof. - intros. apply substList_bound. destruct x. now apply closed_dcl. eapply bound_gt;[rewrite <- closed_dcl|];auto. lia. -Qed. - -Lemma substList_var' y x A: y >= x -> substList (var y) x A = nth (y-x) A (var y). -Proof. - intros ge. simpl. decide (x>y). lia. auto. -Qed. - -Lemma substList_var y A: substList (var y) 0 A = nth y A (var y). -Proof. - rewrite substList_var'. f_equal. lia. lia. -Qed. - -Lemma substList_is_bound y A s: validEnv' A -> bound (y+|A|) (s) -> bound y (substList s y A). -Proof. - intros vA. revert y. induction s;intros y dA. - -apply closed_k_bound. intros k u ge. simpl. decide (y>n). - +simpl. destruct (Nat.eqb_spec n k). lia. auto. - +inv dA. assert (n-y<|A|) by lia. now rewrite (vA _ (nth_In A #n H)). - -inv dA. simpl. constructor;auto. - -simpl. constructor. apply IHs. now inv dA. -Qed. - -Lemma substList_closed' A s: validEnv' A -> bound (|A|) (s) -> closed (substList s 0 A). -Proof. - intros. rewrite closed_dcl. apply substList_is_bound;auto. -Qed. - - - -Lemma deClos_valComp a: validComp a -> closed (deClos a). -Proof. - intros va. induction va;simpl. - -now apply app_closed. - -apply substList_closed'. intros a ain. rewrite in_map_iff in ain. destruct ain as [a' [eq a'in]];subst. now apply H0. now rewrite length_map. -Qed. - -Lemma deClos_validEnv A : validEnv A -> validEnv' (map deClos A). -Proof. - intros vA. induction A;simpl. - -unfold validEnv'. simpl. tauto. - -rewrite validEnv'_cons. apply validEnv_cons in vA as [ca cA]. split;auto. apply deClos_valComp; auto. -Qed. - -#[export] Hint Resolve deClos_validEnv : core. - -Lemma subst_substList x s t A: validEnv' A -> subst (substList s (S x) A) x t = substList s x (t::A). -Proof. - revert x;induction s;simpl;intros x cl. - -decide (S x > n);simpl. decide (x>n); destruct (Nat.eqb_spec n x);try lia;try tauto. subst. now rewrite Nat.sub_diag. decide (x>n). lia. destruct (n-x) eqn: eq. lia. assert (n2=n-S x) by lia. subst n2. destruct (nth_in_or_default (n-S x) A #n). - + apply cl in i. now rewrite i. - +rewrite e. simpl. destruct (Nat.eqb_spec n x). lia. auto. - -now rewrite IHs1,IHs2. - -now rewrite IHs. -Qed. - -Lemma validComp_step s t l: validComp s -> s >[(l)] t -> validComp t. -Proof with repeat (subst || firstorder). - intros vs R. induction R;repeat inv_validComp... - -inv H3. constructor... - -inv H3. apply H1. apply nth_In. lia. - -inv H8. constructor;auto;intros a [?|?];subst;auto. -Qed. - -#[export] Hint Resolve validComp_step : core. -(* -Lemma deClos_correct''' s t : validComp s -> s >(0) t -> deClos s = deClos t. -Proof with repeat (cbn in * || eauto || congruence || lia || subst). - intros cs R. remember 0 as n eqn:eq in R. revert eq. induction R;intros ?;repeat inv_validComp... - -destruct i... rewrite IHR1,IHR2... - -destruct IHR... - -rewrite IHR... - -simpl. rewrite Nat.sub_0_r. rewrite <-map_nth with (f:=deClos)... -Qed. - -Lemma deClos_correct'' s t : validComp s -> s >(1) t -> deClos s = deClos t \/ deClos s ≻ deClos t. -Proof with repeat (cbn in * || eauto || congruence || lia || subst). - intros cs R. remember 1 as n eqn:eq in R. revert eq. induction R;intros ?;repeat inv_validComp... - -destruct i... - +destruct IHR2... apply deClos_correct''' in R1... left... aply deClos_correct''' in R1... right... - right... split;eauto. destruct IHR. auto. left... right... - -destruct IHR. auto. left... right... - -left... - -left. simpl. rewrite Nat.sub_0_r. rewrite <-map_nth with (f:=deClos)... - -right. inv H. simpl. rewrite <-subst_substList... -Qed.*) - -Lemma deClos_correct l s t : validComp s -> s >[(l)] t -> deClos s >(l) deClos t. -Proof with repeat (cbn in * || eauto 10 using star || congruence || lia || subst). - intros cs R. - induction R... - -eapply pow_trans;eauto. - -inv cs;apply pow_step_congL... - -inv cs;apply pow_step_congR... - -rewrite Nat.sub_0_r. rewrite <-map_nth with (f:=deClos)... - -inv H. inv cs. inv H1. eexists;split... rewrite <- subst_substList... -Qed. - -(* - -(* relation that tries to capture that two closures 'reduce' to one another *) - -Reserved Notation "s '=[]>' t" (at level 70). - -Inductive reduceC : Comp -> Comp -> Prop := - | redC s t: deClos s >* deClos t -> s =[]> t -where "s '=[]>' t" := (reduceC s t). - -#[export] Hint Constructors reduceC. - -Lemma reduceC_if s t : s =[]> t -> deClos s >* deClos t. -Proof. - now inversion 1. -Qed. - - -(* ** Properties of the extended reduction relation *) - -Instance reduceC_PreOrder : PreOrder reduceC. -Proof. - constructor;repeat intros;constructor. - -reflexivity. - -inv H. inv H0. now rewrite H1. -Qed. - -Instance reduceC_App_proper : - Proper (reduceC ==> reduceC ==> reduceC) CompApp. -Proof. - cbv. intros s s' A t t' B. constructor. simpl. apply star_step_app_proper. - -now inv A. - -now inv B. -Qed. - -Lemma CStep_reduceC l s t: validComp s -> s >(l) t -> s =[]> t. -Proof. - intros. constructor. eapply deClos_correct;eauto. -Qed. - - -(* relation that tries to capture that two closures 'are the same' *) - -Reserved Notation "s '=[]=' t" (at level 70). - -Inductive equivC : Comp -> Comp -> Prop := - | eqC s t: deClos s == deClos t -> s =[]= t -where "s '=[]=' t" := (equivC s t). - -#[export] Hint Constructors equivC. - -Lemma equivC_if s t : s =[]= t -> deClos s == deClos t. -Proof. - now inversion 1. -Qed. - - -(* ** Properties of the equivalence relation *) - -Instance equivC_Equivalence : Equivalence equivC. -Proof. - constructor;repeat intros;constructor. - -reflexivity. - -inv H. now rewrite H0. - -inv H0. inv H. now rewrite H0. -Qed. - -Instance equivC_App_proper : - Proper (equivC ==> equivC ==> equivC) CompApp. -Proof. - cbv. intros s s' A t t' B. constructor. simpl. apply equiv_app_proper. - -now inv A. - -now inv B. -Qed. - -Lemma CStep_equivC s t: validComp s -> s >[]> t -> s =[]= t. - intros vs R. induction R;repeat inv_validComp. - -now rewrite IHR. - -now rewrite IHR. - -constructor. reflexivity. - -constructor. simpl. rewrite Nat.sub_0_r. rewrite <-map_nth with (f:= deClos). reflexivity. - -constructor. rewrite deClos_correct'. reflexivity. auto. auto. -Qed. - - -Lemma starC_equivC s t : - validComp s -> s >[]* t -> s =[]= t. -Proof. - intros vs R. induction R. - -reflexivity. - -rewrite <-IHR. - +eauto using CStep_equivC. - +eauto using validComp_step. -Qed. - -*) - -Lemma substList_nil s x: substList s x [] = s. -Proof. - revert x. induction s;intros;simpl. - -decide (x>n). reflexivity. now destruct(n-x). - -congruence. - -congruence. -Qed. -(* -Lemma equivC_deClos s : s =[]> CompClos (deClos s) []. -Proof. - constructor. simpl. induction s;simpl. - -now destruct x. - -rewrite IHs1 at 1. rewrite IHs2 at 1. reflexivity. - -now rewrite substList_nil. -Qed. - - *) -(* -Goal uniform_confluent CStep. -Proof with try (congruence||(now (subst;tauto))||(now (right;eauto))||(now (right;eauto;eexists;eauto))). - intros s. induction s;intros. - -inv H. - -inv H;inv H0... - +destruct (IHs1 _ _ H4 H3) as [?|[? [? ?]]]... - +destruct (IHs2 _ _ H4 H3) as [?|[? [? ?]]]... - +inv H4; now inv H3. - +inv H3; now inv H4. - -inv H; inv H0... -Qed.*) -(* -Lemma lamComp_noStep l s t : lamComp s -> ~ s>(S l)t. -Proof. - intros H R. remember (S l). revert Heqn. revert H. induction R;intros;try congruence. - destruct i. inv H. inv R.lia. . -Qed. -*) -Lemma validComp_closed s: closed s -> validComp (CompClos s []). -Proof. - intros cs. constructor;simpl;try tauto. now apply closed_dcl. -Qed. -(* -Lemma lamComp_star s t : lamComp s -> s >[]* t -> s = t. -Proof. - intros H R. induction R. auto. now apply lamComp_noStep in H0. -Qed. - -Lemma validComp_star s t: validComp s -> s >[]* t -> validComp t. -Proof. - intros vs R. induction R; eauto using validComp_step. -Qed. - -*) -(* -Lemma deClos_lam p s: (λ s) = deClos p -> exists t, lamComp t /\ deClos t = (lam s) /\ p >[]* t. -Proof. - revert s. apply Comp_ind_deep with (x:=p);clear p;simpl. - -congruence. - -congruence. - -intros p A IH s eq. destruct p; simpl in eq. - +rewrite Nat.sub_0_r in eq. change (var n) with (deClos (CompVar n)) in eq. rewrite map_nth in eq. apply IH in eq as [t [? [? R]]]. exists t;repeat split;auto. now rewrite CStepVar. destruct (nth_in_or_default n A (CompVar n)). - *auto. - *rewrite e in eq. simpl in eq. congruence. - +inv eq. - +exists (CompClos (lam p) A). simpl. repeat split;auto. reflexivity. -Qed. - - -Fixpoint normComp' s A:= - match s with - | app s t => (normComp' s A) (normComp' t A) - | var x => CompClos (var x) A (*nth x A (CompVar x)*) - | lam s => CompClos (lam s) A - end. - -Fixpoint normComp s := - match s with - | CompApp s t => (normComp s) (normComp t) - | CompClos s A => normComp' s A - | s => s - end. - -Lemma normComp'_deClos s A: deClos (CompClos s A) = deClos (normComp' s A). -Proof. - induction s;simpl. - -rewrite Nat.sub_0_r. reflexivity. - -simpl in *. congruence. - -simpl in *. congruence. -Qed. - - -Lemma normComp_deClos s: deClos s = deClos (normComp s). -Proof. - induction s;simpl. - -auto. - -congruence. - -rewrite <- normComp'_deClos. reflexivity. -Qed. - -Lemma normComp'_star s A: CompClos s A >[]* normComp' s A. -Proof. - induction s;simpl;eauto using star. - -rewrite CStepApp. now rewrite IHs1,IHs2. -Qed. - -Lemma normComp_star s: s >[]* normComp s. -Proof. - induction s;simpl. - -reflexivity. - -now rewrite <- IHs1,<-IHs2. - -apply normComp'_star. -Qed. - -Lemma normComp'_idem s A:normComp (normComp' s A)=normComp' s A. -Proof. - induction s;simpl; congruence. -Qed. - - -Lemma normComp_idem s: normComp (normComp s)=normComp s. -Proof. - induction s;simpl. - -reflexivity. - -congruence. - -apply normComp'_idem. -Qed. - - -Lemma normComp'_valid s A: validComp (CompClos s A) -> validComp (normComp' s A). -Proof. - intros vA. induction s;simpl. - -auto. - -inv vA. inv H3. auto. - -auto. -Qed. - - -Lemma normComp_valid s: validComp s -> validComp (normComp s). -Proof. - intros vs. induction s;simpl. - -auto. - -inv vs. auto. - -apply normComp'_valid. auto. -Qed. - - -Lemma CompStep_correct2' s t : normComp s = s -> validComp s -> deClos s ≻ t -> exists t', t = deClos t' /\ s >[]* t'. -Proof. - intros nc vs. revert t. induction vs as [s1 s2|]; intros t R. - -simpl in R. inv R;simpl in nc. - +destruct (deClos_lam H0) as [t'[lt' [eq R]]]. - destruct (deClos_lam H1) as [u [lu [equ Ru]]]. - inv lt'. - exists (CompClos s0 (u::A)). simpl;split. - *rewrite equ. rewrite <-subst_substList. simpl in eq. congruence. apply deClos_validEnv. apply validComp_star in R;auto. inv R. auto. - *rewrite R, Ru. inv lu. rewrite <- CStepVal. reflexivity. auto. - +apply IHvs2 in H2 as [u [? R]]. exists (s1 u). split; simpl. congruence. now rewrite R. congruence. - +apply IHvs1 in H2 as [u [? R]]. exists (u s2). split; simpl. congruence. now rewrite R. congruence. - -destruct s;simpl in nc. - +simpl in R. rewrite Nat.sub_0_r in R. change (var n) with (deClos (CompVar n)) in R. rewrite map_nth in R. apply H0 in R. destruct R as [t' [? ?]]. - *eexists. split. eauto. now rewrite CStepVar. - *apply nth_In. now inv H2. - *destruct (nth_in_or_default n A (CompVar n)). apply H1 in i. inv i. now simpl. rewrite e. reflexivity. - +inv nc. - +simpl in R. inv R. -Qed. - - -Lemma CompStep_correct2 s t : validComp s -> deClos s ≻ t -> exists t', t = deClos t' /\ s >[]* t'. -Proof. - intros vs R. rewrite normComp_deClos in R. destruct (CompStep_correct2' (normComp_idem s) (normComp_valid vs) R) as [t' [eq R']]. exists t'. split. auto. now rewrite normComp_star. -Qed. - - -Close Scope L.los.*) diff --git a/theories/L/Tactics/LTactics.v b/theories/L/Tactics/LTactics.v deleted file mode 100644 index 7046f85b6..000000000 --- a/theories/L/Tactics/LTactics.v +++ /dev/null @@ -1,5 +0,0 @@ -From MetaCoq.Template Require Export TemplateMonad.Core. - -(* * Certifying extraction from Coq to L with time bounds *) -From Undecidability.L.Tactics Require Export Lsimpl Lbeta Computable ComputableTactics Lproc Lrewrite. - diff --git a/theories/L/Tactics/Lbeta.v b/theories/L/Tactics/Lbeta.v deleted file mode 100644 index e74b00587..000000000 --- a/theories/L/Tactics/Lbeta.v +++ /dev/null @@ -1,221 +0,0 @@ -From Undecidability.L Require Import Util.L_facts. -Require Import ListTactics. -From Undecidability.L.Tactics Require Import Lproc Reflection. - -(* *** Lbeta: symbolic beta reduction *) - -(* This module procides tactics to simlify L-term w.r.t beta reduction in L. -It does so by the reflective tactic simplify_L' using the module Reflextion. *) - -Lemma eval_helper s t u: s >* u -> eval u t -> eval s t. -Proof. - intros R H. now rewrite R. -Qed. - -Ltac addToList a l := AddFvTail a l. - -Ltac has_no_evar s := try (has_evar s;fail 1). - -Ltac reflexivity' := - match goal with - | |- ?G => has_no_evar G;reflexivity - end. - -Lemma eval_refl s : lambda s -> s ⇓ s. -Proof. - intros. split. reflexivity. Lproc. -Qed. - - -(*make all variables to coq-variables in the context *) -Ltac allVarsPrep _s := -lazymatch _s with -| var ?_n => idtac -| app ?_s ?_t => - allVarsPrep _s; - allVarsPrep _t -| lam ?_s => allVarsPrep _s -| rho ?_s => allVarsPrep _s -| _ => let x := fresh "__x" in set (x:= _s) -end. - -Ltac allVarsSubstL vars := -lazymatch vars with -| [] => idtac -| ?x::?vars'' => try subst x;allVarsSubstL vars'' -end. - -Ltac allVars' vars _s := -lazymatch _s with -| var ?_n => vars -| app ?_s ?_t => - let vars := allVars' vars _s in - allVars' vars _t -| lam ?_s => allVars' vars _s -| rho ?_s => allVars' vars _s -| _ => addToList (_s:term) (* cast is for coersions to work *) vars -end. - -Ltac allVars _s := allVars' (@nil term) _s. - -Ltac Find_at' a l := - lazymatch l with - | (cons a _) => constr:(0) - | (cons _ ?l) => - let n := Find_at' a l in - constr:(S n) - end. - -Ltac reifyTerm vars _s := - lazymatch _s with - | var ?_n => constr:(rVar _n) - | app ?_s ?_t => - let _s := reifyTerm vars _s in - let _t := reifyTerm vars _t in - constr:(rApp _s _t) - | lam ?_s => - let _s := reifyTerm vars _s in - constr:(rLam _s) - | rho ?_s => - let _s := reifyTerm vars _s in - constr:(rRho _s) - | _ => - let vars' := eval hnf in vars in - let _n := (Find_at' (_s:term) (* cast is for coersions to work *) vars') in - constr:(rConst (_n)) - end. - -Ltac vm_hypo := - match goal with - | H: ?s == ?t |- _ => revert H;try vm_hypo;intros H; vm_compute in H - end. - -Ltac ProcPhi vars := - let H := fresh "H" in - let s := fresh "s" in - apply liftPhi_correct,Forall_forall;allVarsSubstL vars; - repeat - once lazymatch goal with - | |- Forall _ (@nil _) => solve [simple apply Forall_nil] - | |- _ => simple apply Forall_cons;[Lproc| ] - end . - -(* solve goals of shape s >(?l) ?t for evars ?l, ?t!*) -Ltac simplify_L' n:= - once lazymatch goal with - |- ?s >(_) _ => - allVarsPrep s; - once lazymatch goal with - |- ?s >(_) _ => - let vars:= allVars s in - (* let vars' := fresh "vars'" in - pose (vars':=vars); *) - let s' := reifyTerm vars s in - let phi := fresh "phi" in - pose (phi := Reflection.liftPhi vars); - let pp := fresh "pp" in - let cs := fresh "cs" in - assert (pp:Reflection.Proc phi) by (ProcPhi vars); - assert (cs :Reflection.rClosed phi s') by (simple apply Reflection.rClosed_decb_correct;[exact pp|vm_cast_no_check (@eq_refl bool true) ]); - let R := fresh "R" in - assert (R:= Reflection.rStandardizeUsePow n pp cs); - let eq := fresh "eq" in - let s'' := fresh "s''" in - set (s'':= Reflection.rCompSeval n (0, Reflection.rCompClos (s') [])) in R; - vm_compute in (value of s''); - subst s''; lazy -[rho pow phi Reflection.liftPhi] in R; - lazy [phi Reflection.liftPhi nth] in R; - (*repeat allVarsSubstL vars';*) - clear (*vars' eq *) cs phi pp; exact R - end - end. - - -Lemma pow_trans_eq: forall (s t u : term) (i j k: nat), s >(i) t -> t >(j) u -> i+j=k -> s >(k) u. -Proof. - intros. subst. eapply pow_trans;eauto. -Qed. - -Ltac Lreflexivity := - once lazymatch goal with - | |- _ >(<= _ ) _ => apply redLe_refl - | |- _ ⇓ _ => solve [apply eval_refl;Lproc] - | |- _ >* _ => reflexivity - | |- _ >(_) _ => now apply pow0_refl - | |- ?t => fail "not supported by Lreflexivity:" t - end. - - -Ltac Lbeta' n := - once lazymatch goal with - |- ?rel ?s _ => - once lazymatch goal with - | |- _ >(?i) _ => tryif is_evar i - then eapply pow_trans;[simplify_L' n|] - else (eapply pow_trans_eq;[simplify_L' n| |try reflexivity]) - | |- _ >(<=?i) _ => tryif is_evar i - then eapply redle_trans;[apply pow_redLe_subrelation;simplify_L' n|] - else ((eapply redle_trans_eq;[ | apply pow_redLe_subrelation;simplify_L' n| ]);[try reflexivity | ..]) - | |- _ ⇓ _ => eapply eval_helper;[eapply pow_star_subrelation;simplify_L' n|] - | |- _ >* _ => etransitivity;[eapply pow_star_subrelation;simplify_L' n|] - | |- ?G => fail "Not supported for LSimpl (or other failed):" G - end; - once lazymatch goal with - |- ?rel s _ => fail "No Progress in beta' in " rel s "(progress in indexes are not currently noticed...)" - | |- _ => idtac - (* don;t change evars if you did not make progress!*) - end - end. - -Tactic Notation "Lbeta" := once(Lbeta' 50). - - -(* test, approx. 2+1 seconds (proof + qed) on w550s -Lemma test : (lam 0) (lam 0) >(1 ) (lam 0). -Proof. - do 300 (assert ((lam 0) (lam 0) >(1 ) (lam 0)) by (unfold I;simplify_L' 50);clear H); - simplify_L' 50. -Qed.*) - -(* legacy: asserts R:= s >* ?t for some reduction of ?t *) -Tactic Notation "standardize" ident(R) constr(n) constr(s) := - has_no_evar s; - let l := fresh "l" in - let t := fresh "t" in - evar (l : nat); - evar (t : term); - assert (R : s >(l) t) by simplify_L' n;subst l t;apply pow_star in R. - - -(* Goal I I >* I. *) -(* Proof. *) -(* standardize R 100 ((lam 0) (lam 0)); exact R. *) -(* Qed. *) - -Ltac standardizeGoal' _n:= - let R:= fresh "R" in - once lazymatch goal with (* try etransitivity is for debugging, so we can disable ProcPhi iff needed*) - | |- ?s == _ => let R:= fresh "R" in standardize R _n s;try (etransitivity;[exact (star_equiv R)|];clear R) - | |- ?s >* _ => let R:= fresh "R" in standardize R _n s;try (etransitivity;[exact R|];clear R) - end. - -Ltac standardizeGoal _n := - try progress Lbeta' _n; - try progress standardizeGoal' _n; - try progress (symmetry;standardizeGoal' _n;symmetry). - -Lemma stHypo s s' t : s >* s' -> s == t -> s' == t. -Proof. - intros R R'. rewrite R in R'. exact R'. -Qed. - -Ltac standardizeHypo _n:= -match goal with - | eq_new_name : ?s == ?t |- _=> - revert eq_new_name;try standardizeHypo _n; intros eq_new_name; - try (progress (let R:= fresh "R" in - standardize R _n s;apply (stHypo R) in eq_new_name;clear R )); - try (progress (let R':= fresh "R'" in - symmetry;standardize R' _n s; - apply (stHypo R') in eq_new_name;symmetry;clear R' )) -end. diff --git a/theories/L/Tactics/Lbeta_nonrefl.v b/theories/L/Tactics/Lbeta_nonrefl.v deleted file mode 100644 index 4c3bf54c8..000000000 --- a/theories/L/Tactics/Lbeta_nonrefl.v +++ /dev/null @@ -1,121 +0,0 @@ -From Undecidability.L Require Import ComputableTactics Lproc Tactics.Computable Lrewrite. - -Import L_Notations. - -Local Fixpoint subst' (s : term) (k : nat) (u : term) {struct s} : term := - match s with - | # n => if Init.Nat.eqb n k then u else # n - | app s0 t => (subst' s0 k u) (subst' t k u) - | (lam s0) => (lam (subst' s0 (S k) u)) - end. - -Lemma subst'_eq s k u: subst s k u = subst' s k u. -Proof. - revert k;induction s;intros;simpl;try congruence. -Qed. - -Lemma lStep s t u: lambda t -> (subst' s 0 t) >* u -> (lam s) t >* u. -Proof. - intros. rewrite <- H0. apply step_star_subrelation. rewrite <- subst'_eq. now apply step_Lproc. -Qed. - - -Lemma subst'_cls s : closed s -> forall x t, subst' s x t = s. -Proof. - intros. rewrite <- subst'_eq. apply H. -Qed. - -Ltac redStep':= - match goal with - |- _ == _ => apply star_equiv;redStep' - | |- app (lam ?s) ?t >* _ => apply lStep;[now Lproc|reflexivity] - | |- app ?s ?t >* _ => progress (etransitivity;[apply star_step_app_proper;redStep'|]);[reflexivity] - | |- _ => reflexivity - end. - -Ltac redStep2 := etransitivity;[redStep'|]. -(* -iLtac redSimpl' s x t:= - match s with - | app ?s1 ?s2 -> - let s1' := resSimpl' s1 x t in - let s2' := resSimpl' s2 x t in - constr:(app s1' s2') - | - *) - - -Ltac Lbeta_old := cbn [subst' Init.Nat.eqb]. - -Lemma subst'_int (X:Set) (ty : TT X) (f:X) (H : computable f) : forall x t, subst' (ext f) x t = (ext f). -Proof. -intros. apply subst'_cls. Lproc. -Qed. -(* -Lemma subst'_enc Y (H:encodable Y): forall y x t, subst' (enc y) x t = (enc y). -Proof. - intros. apply subst'_cls. Lproc. -Qed. -*) - -Local Ltac closedRewrite2 := rewrite ?subst'_int; - match goal with - | [ |- context[subst' ?s _ _] ] => - let cl := fresh "cl" in assert (cl:closed s) by Lproc; - let cl' := fresh "cl'" in assert (cl':= subst'_cls cl); - rewrite ?cl';clear cl;clear cl' - - end. - -Lemma app_eq_proper (s s' t t' :term) : s = s' -> t = t' -> s t = s' t'. -Proof. - congruence. -Qed. - -Lemma lam_app_proper (s s' :term) : s = s' -> lam s = lam s'. -Proof. - congruence. -Qed. - -Lemma subst'_eq_proper (s s':term) x t : s = s' -> subst' s x t = subst' s' x t. -Proof. - congruence. -Qed. - -Lemma clR s s' t : s' = s -> s >* t -> s' >* t. -Proof. - congruence. -Qed. - -Lemma clR' s s' t : s' = s -> s == t -> s' == t. -Proof. - congruence. -Qed. - -Lemma subst'_rho s x u : subst' (rho s) x u = rho (subst' s (S x) u). -Proof. - reflexivity. -Qed. - -Ltac closedRewrite3' := - match goal with - | |- app _ _ = _ => try etransitivity;[progress (apply app_eq_proper;closedRewrite3';reflexivity)|] - | |- lam _ = _ => apply lam_app_proper;closedRewrite3' - | |- rho _ = _ => eapply f_equal;Lbeta_old;closedRewrite3' - | |- subst' (subst' _ _ _) _ _ = _ => etransitivity;[apply subst'_eq_proper;closedRewrite3'|closedRewrite3'] - | |- subst' (subst' _ _ _) _ _ = _ => etransitivity;[apply subst'_eq_proper;closedRewrite3'|closedRewrite3'] - | |- subst' (ext _) _ _ = _ => apply subst'_int - | |- subst' (rho _) _ _ = _ => rewrite subst'_rho;f_equal;closedRewrite3' - | |- subst' _ _ _ = _ => apply subst'_cls;now Lproc - | |- _ => reflexivity - end. - -Ltac closedRewrite3 := etransitivity;[cbn;(eapply clR||eapply clR');closedRewrite3';reflexivity|]. - - -Ltac Lred' := (progress redStep2); Lbeta_old. -Tactic Notation "redStep" := Lred';closedRewrite3. - -Ltac redSteps := progress (reflexivity || ((repeat Lred');closedRewrite3)). - -Ltac LsimplRed := repeat ( redSteps ; try Lrewrite). diff --git a/theories/L/Tactics/Lproc.v b/theories/L/Tactics/Lproc.v deleted file mode 100644 index 019147ce5..000000000 --- a/theories/L/Tactics/Lproc.v +++ /dev/null @@ -1,70 +0,0 @@ -From Undecidability.L Require Export Util.L_facts. -From Undecidability.L.Tactics Require Import Reflection Computable. - -(* ** Symbolic simplification for L*) - -(* *** Lproc *) - -(* This module provides tactics fLproc and Lproc that solve goals of the form [lambda s] or [proc s] or [closed s] for L-terms [s]. *) - -#[export] Hint Resolve rho_lambda rho_cls : LProc. - -Lemma proc_closed p : proc p -> closed p. -Proof. - firstorder easy. -Qed. - -Lemma proc_lambda p : proc p -> lambda p. -Proof. - firstorder easy. -Qed. - -Ltac fLproc :=intros; - once lazymatch goal with - | [ |- proc _ ] => split;fLproc - | [ |- lambda ?s ] => eexists; reflexivity || fail "Prooving 'lambda " s " ' by computation failed. It is either not a fixed term, some used identifier is opaqie or the goal does not hold" - | [ |- closed ?s ] => vm_compute; reflexivity || fail "Prooving 'closed " s " ' by computation failed. It is either not a fixed term, some used identifier is opaque or the goal does not hold" - end. - - - -Ltac Lproc' :=idtac; - once lazymatch goal with - | |- bound _ (L.app _ _) => refine (dclApp _ _) - | |- bound _ (L.lam _) => refine (dcllam _) - | |- bound ?y (L.var ?x) => exact (dclvar (proj1 (Nat.ltb_lt x y) eq_refl)) - | |- lambda (match ?c with _ => _ end) => destruct c - | |- lambda (@enc ?t ?H ?x) => exact_no_check (proc_lambda (@proc_enc t H x)) - | |- lambda (@ext ?X ?tt ?x ?H) => exact_no_check (proc_lambda (@proc_ext X tt x H)) - | |- lambda (app _ _) => fail - | |- lambda _ => (simple apply proc_lambda;(trivial with nocore LProc || tauto)) || tauto || (eexists;reflexivity) - | |- rClosed ?phi _ => solve [simple apply rClosed_decb_correct;[assumption|reflexivity]] - | |- L.closed ?s => refine (proj2 (closed_dcl s) _) - | |- bound _ (match ?c with _ => _ end) => destruct c - | |- bound _ (rho ?s) => simple apply rho_dcls - | |- bound ?k (@ext ?X ?tt ?x ?H) => - exact_no_check (closed_dcl_x k (proc_closed (@proc_ext X tt x H))) - | |- bound ?k (@enc ?t ?H ?x) => - exact_no_check (closed_dcl_x k (proc_closed (@proc_enc t H x))) - | |- bound ?k ?s => (refine (@closed_dcl_x k s _); (trivial with LProc || (apply proc_closed;trivial with LProc || tauto) || tauto )) - | |- ?s => idtac s;fail 1000 - end. - - -(* early abort for speed!*) -Tactic Notation (at level 3) "repeat'" tactic3(t) := - let rec loop := (once t);try loop in loop. - -Ltac Lproc := (* match goal with |- ?G => idtac G end ;time "Lproc"( *) - lazymatch goal with - | |- proc (app _ _) => fail - | |- proc (@enc ?t ?H ?x) => exact_no_check (@proc_enc t H x) - | |- proc (@ext ?X ?tt ?x ?H) => exact_no_check (@proc_ext X tt x H) - | |- proc _ => refine (conj _ _);[|solve [Lproc]];Lproc - - | |- closed _ => solve [repeat' Lproc'] - - | |- lambda (app _ _) => fail - | |- lambda _ => repeat' Lproc' - | s := ?t |- ?p ?s => change (p t);Lproc - end. \ No newline at end of file diff --git a/theories/L/Tactics/Lrewrite.v b/theories/L/Tactics/Lrewrite.v deleted file mode 100644 index 8818a11d7..000000000 --- a/theories/L/Tactics/Lrewrite.v +++ /dev/null @@ -1,273 +0,0 @@ -From Undecidability.L Require Import Tactics.Computable Lproc Lbeta. -Import L_Notations. - -(* *** Lrewrite: simplification with correctness statements*) - -(* This module simplifies L-terms by rewriting with correctness-lemmatas form the hint library Lrewrite *) - -(* For Time Complexity: *) - -Lemma redLe_app_helper s s' t t' u i j k: - s >(<= i) s' -> t >(<= j) t' -> s' t' >(<=k) u -> s t >(<=i+j+k) u. -Proof. - intros (i' & ? & R1) (j' & ? & R2) (k' & ? & R3). - exists ((i'+j')+k'). split. lia. apply pow_trans with (t:=s' t'). - apply pow_trans with (t:=s' t). - now apply pow_step_congL. - now apply pow_step_congR. eauto. -Qed. - -Lemma pow_app_helper s s' t t' u: - s >* s' -> t >* t' -> s' t' >* u -> s t >* u. -Proof. - now intros -> -> -> . -Qed. - - -Lemma LrewriteTime_helper s s' t i : - s' = s -> s >(<= i) t -> s' >(<= i) t. -Proof. - intros;now subst. -Qed. - -Lemma Lrewrite_helper s s' t : - s' = s -> s >* t -> s' >* t. -Proof. - intros;now subst. -Qed. - -Lemma Lrewrite_equiv_helper s s' t t' : - s >* s' -> t >* t' -> s' == t' -> s == t. -Proof. - intros -> ->. tauto. -Qed. - - -Ltac find_Lrewrite_lemma := - once lazymatch goal with - | |- ?R (lam _) => fail - | |- ?R (enc _) => fail - | |- ?R (ext (ty:=TyB _) _) => fail - | |- ?R ?s _ => has_no_evar s;solve [eauto 20 with Lrewrite nocore] - end. - -Create HintDb Lrewrite discriminated. -#[export] Hint Constants Opaque : Lrewrite. -#[export] Hint Variables Opaque : Lrewrite. - -#[export] Hint Extern 0 (proc _) => solve [Lproc] : Lrewrite. -#[export] Hint Extern 0 (lambda _) => solve [Lproc] : Lrewrite. -#[export] Hint Extern 0 (closed _) => solve [Lproc] : Lrewrite. - -Lemma pow_redLe_subrelation' i s t : pow step i s t -> redLe i s t. -Proof. apply pow_redLe_subrelation. Qed. (* for performance, without [subrelation] in type*) - - -#[export] Hint Extern 0 (_ >(<= _ ) _) => simple eapply pow_redLe_subrelation' : Lrewrite. -#[export] Hint Extern 0 (_ >* _) => simple eapply redLe_star_subrelation : Lrewrite. -#[export] Hint Extern 0 (_ >* _) => simple eapply eval_star_subrelation : Lrewrite. - -(* replace int by intT if possible*) - -Ltac Ltransitivity := - once lazymatch goal with - | |- _ >(<= _ ) _ => refine (redle_trans _ _);[shelve.. | | ] - | |- _ >* _ => refine (star_trans _ _);[shelve.. | | ] - | |- _ >(_) _ => eapply pow_add with (R:=step) - | |- ?t => fail "not supported by Ltransitivity:" t - end. - -(* generate all goals for bottom-up-rewriting*) -Ltac Lrewrite_generateGoals := - once lazymatch goal with - | |- app _ _ >(<= _ ) _ => eapply redLe_app_helper;[idtac;Lrewrite_generateGoals..|idtac] - | |- app _ _ >* _ => eapply pow_app_helper ;[idtac;Lrewrite_generateGoals..|idtac] - | |- ?s >(<= _ ) _ => (is_evar s;fail 10000) ||idtac - | |- ?s >* _ => (is_evar s;reflexivity) ||idtac - end. - -Ltac useFixHypo := - once lazymatch goal with - |- ?s >* ?t => - has_no_evar s; - let IH := fresh "IH" in - unshelve epose (IH:=_);[|(notypeclasses refine (_:{v:term & computesExp _ _ s v}));solve [once auto with nocore]|]; - let v := constr:(projT1 IH) in - assert (IHR := fst (projT2 IH)); - let IHInts := constr:( snd (projT2 IH)) in - once lazymatch type of IHInts with - computes ?ty _ ?v => - change v with (@ext _ ty _ (Build_computable IHInts)) in IHR;exact (proj1 IHR) - end - end. - -Ltac LrewriteTime_solveGoals := - try find_Lrewrite_lemma; - try useFixHypo; - once lazymatch goal with - (* Computability: *) - | |- @ext _ (@TyB _ _) _ ?inted >* _ => - (progress rewrite (ext_is_enc);[>LrewriteTime_solveGoals..]) || Lreflexivity - | |- app (@ext _ (_ ~> _ ) _ _) (ext _) >* _ => etransitivity;[apply extApp|LrewriteTime_solveGoals] - | |- app (@ext _ (_ ~> _ ) _ ?ints) (@enc _ ?reg ?x) >* ?v => - change (app (@ext _ _ _ ints) (@ext _ _ _ (reg_is_ext reg x)) >* v);LrewriteTime_solveGoals - | |- _ >* _ => reflexivity (* TO DEBUG: use idtac here*) - end. - -Ltac Lrewrite' := - once lazymatch goal with - |- ?rel ?s _ => - once lazymatch goal with - | |- _ >(<=_) _ => - try (eapply redle_trans;[Lrewrite_generateGoals;[>LrewriteTime_solveGoals..]|]) - | |- _ >* _ => - try (etransitivity;[Lrewrite_generateGoals;[>LrewriteTime_solveGoals..]|]) - end; - once lazymatch goal with - |- ?rel s _ => fail "No Progress (progress in indices are not currently noticed...)" - (* don;t change evars if you did not make progress!*) - | |- _ => idtac - end - | |- _ => idtac - end. - -Tactic Notation "Lrewrite_wrapper" tactic(k):= -once lazymatch goal with -| |- _ >(<= _) _ => k -| |- _ >(_) _ => idtac "Lrewrite_prepare does not support s >(k) y, only s >(<=k) t)" -| |- _ >* _ => k (* Lrewrite_prepare_old *) -| |- eval _ _ => (eapply eval_helper;[k;Lreflexivity|]) -| |- _ == _ => progress ((eapply Lrewrite_equiv_helper;[try (* inefficient, but needed if only one side does progress *)k;reflexivity..|])) -end. - -(* does work on coq variables that are not abstactions *) -Ltac Lrewrite := Lrewrite_wrapper Lrewrite'. - - - -Lemma Lrewrite_in_helper s t s' t' : - s >* s' -> t >* t' -> s == t -> s' == t'. -Proof. - intros R1 R2 E. now rewrite R1,R2 in E. -Qed. - - -Tactic Notation "Lrewrite" "in" hyp(_H) := - once lazymatch type of _H with - | _ == _ => eapply Lrewrite_in_helper in _H; [ |try Lrewrite;reflexivity |try Lrewrite;reflexivity] - | _ >* _ => idtac "not supported yet" - end. - -Lemma ext_rel_helper X `(H:encodable X) (x:X) (inst : computable x) (R: term -> term -> Prop) u: - R (enc x) u -> R (@ext _ _ _ inst) u. -Proof. - now rewrite ext_is_enc. -Qed. - -Lemma redLe_app_helperL s s' t u i j: -s >(<= i) s' -> app s' t >(<=j) u -> app s t >(<=i+j) u. -Proof. intros ? H'. eapply redLe_app_helper in H'. 2:eassumption. 2:Lreflexivity. now rewrite Nat.add_0_r in H'. Qed. - -Lemma redLe_app_helperR s t t' u i j: -t >(<= i) t' -> app s t' >(<=j) u -> app s t >(<=i+j) u. -Proof. intros ? H'. eapply redLe_app_helper in H'. 3:eassumption. 2:Lreflexivity. eassumption. Qed. - -Lemma pow_app_helperL s s' t u: -s >* s' -> app s' t >* u -> app s t >* u. -Proof. now intros -> -> . Qed. - -Lemma pow_app_helperR s t t' u: -t >* t' -> app s t' >* u -> app s t >* u. -Proof. now intros -> -> . Qed. - - -Ltac LrewriteSimpl_appL R:= - lazymatch R with - | star step => refine (pow_app_helperL _ _) - | redLe _ => refine (redLe_app_helperL _ _) - end. - -Ltac LrewriteSimpl_appR R:= -lazymatch R with -| star step => refine (pow_app_helperR _ _) -| redLe _ => refine (redLe_app_helperR _ _) -end. - -Ltac isValue s:= - lazymatch s with - | lam _ => idtac - | app _ _ => fail - | @ext _ _ _ _ => idtac - | @enc _ _ _ => idtac - | I => idtac - | ?P => tryif (is_var P;lazymatch eval unfold P in P with rho _ => idtac end) then idtac - else - lazymatch goal with - | H : proc s |- _ => idtac - | H : lambda s |- _ => idtac - | _ => (* idtac "noFastValue, default to true" s; *)idtac - end - end. - -(* version of Lrewrite that des the beta-steps as well *) -(* clears the flag iff head is not applied to values *) -Ltac LrewriteSimpl'' canReduceFlag := - idtac; - (* time "LrewriteSimpl'" *) - once lazymatch goal with - | |- _ (@ext _ (@TyB _ ?reg) _ _) _ => refine (ext_rel_helper _ _) (* for backwards-compability, if used on term with hole*) - | |- ?R ?s _ => has_no_evar s;(* idtac "recurse to" s; *) - - repeat' (idtac; - lazymatch goal with - | |- _ (lam _) _ => fail - | |- _ (enc _) _ => fail - - (* use correctness lemmatas of int here*) - | |- L.app (@ext _ (_ ~> _ ) _ _) (ext _) >* _ => Ltransitivity;[apply extApp|] - | |- L.app (@ext _ (_ ~> _ ) _ ?ints) (@enc _ ?reg ?x) >* ?v => - change (app (@ext _ _ _ ints) (@ext _ _ _ (reg_is_ext reg x)) >* v); - Ltransitivity;[refine (extApp _ _)|] - (* clean up goal *) - | |- _ (@ext _ (@TyB _ ?reg) _ _) _ => refine (ext_rel_helper _ _) - - (* last reduce recursively, and then try to apply rewrite lemmas o Lbeta *) - | |- ?R (L.app _ _) _ => - (* idtac "at app0"; *) - let progressFlag := fresh in - let recCanReduceFlag := fresh in - let tmp := fresh in - assert (progressFlag:=tt); - assert (tmp:=tt); - assert (recCanReduceFlag:=tt); - try (LrewriteSimpl_appR R;[solve [LrewriteSimpl'' tmp;Lreflexivity]|(* idtac"didR"; *)try clear progressFlag]); - try clear tmp; (*we don't care for RHS*) - try (LrewriteSimpl_appL R;[solve [LrewriteSimpl'' canReduceFlag;Lreflexivity]|(* idtac"didL"; *)try clear progressFlag]); - (* idtac "at app"; *) - lazymatch goal with - | |- ?R (L.app ?s ?t) _ => - (* idtac "still app" s t; *) - let maybeBeta _ := lazymatch s with lam _ => Lbeta end in - try (maybeBeta ();try clear progressFlag); - tryif (tryif is_var recCanReduceFlag then isValue t else fail) - then - try ( - Ltransitivity;[solve [find_Lrewrite_lemma|useFixHypo]|]; - try clear progressFlag (* we did something *); - - (* We mus re-evaluate if we produce an assumption where s rewrite could apply*) - try (clear canReduceFlag;pose (canReduceFlag:=tt)) - ) - else clear canReduceFlag - end; - (* fail if no progress *) - tryif is_var progressFlag then (* lazymatch goal with |- ?H => idtac "leaving behind" H end; *)fail else idtac -(* | |- ?H => fail 1000 "unexpected goal" H *) - | |- ?H => (* idtac "fallback" H; *)Ltransitivity;[solve[find_Lrewrite_lemma]|] - end) - end. - -Ltac LrewriteSimpl' := let flag := fresh in assert (flag:=tt); - (tryif Lbeta then try LrewriteSimpl'' flag else LrewriteSimpl'' flag);try clear flag. - -Ltac LrewriteSimpl := Lrewrite_wrapper ltac:(idtac;LrewriteSimpl'). diff --git a/theories/L/Tactics/Lsimpl.v b/theories/L/Tactics/Lsimpl.v deleted file mode 100644 index 3b88880ac..000000000 --- a/theories/L/Tactics/Lsimpl.v +++ /dev/null @@ -1,111 +0,0 @@ -From Undecidability.L Require Export Util.L_facts. -From Undecidability.L.Tactics Require Import Lproc Lbeta Lrewrite Reflection. -Require Import ListTactics. -Import L_Notations. - -Local Ltac wLsimpl' _n := intros;try reflexivity';try standardizeGoal _n ; try reflexivity'. -Local Ltac wLsimpl := wLsimpl' 100. - -(* Lsimpl' uses correctnes lemmas and wLsimpl*) -Ltac Lsimpl' := - match goal with - | |- eval ?s _ => assert (lambda s) by Lproc;split;[ (exact (starR _ _);fail 1)|Lproc] - | |- eval ?s _ => (progress (eapply eval_helper;[Lsimpl';reflexivity|])) - - | _ => try Lrewrite;try wLsimpl' 100 - end. - -Ltac Lreduce := - repeat progress ( (Lrewrite;try Lbeta) || Lbeta). - -Ltac Lsimpl := - lazymatch goal with - | |- _ >( _ ) _ => repeat progress Lbeta;try Lreflexivity - | |- _ => LrewriteSimpl - end. - -Ltac LsimplHypo := standardizeHypo 100. - - - -Tactic Notation "closedRewrite" := - match goal with - | [ |- context[subst ?s _ _] ] => - let cl := fresh "cl" in assert (cl:closed s);[Lproc|rewrite !cl;clear cl] - - end. - -Tactic Notation "closedRewrite" "in" hyp(h):= - match type of h with - | context[subst ?s _ _] => - let cl := fresh "cl" in assert (cl:closed s);[Lproc|rewrite !cl in h;clear cl] - end. - -Tactic Notation "redStep" "at" integer(pos) := rewrite step_Lproc at pos;[simpl;try closedRewrite|Lproc]. - -Tactic Notation "redStep" "in" hyp(h) "at" integer(pos) := rewrite step_Lproc in h at pos;[simpl in h;try closedRewrite in h|Lproc]. -(* -Tactic Notation "redStep" := redStep at 1. -*) -Tactic Notation "redStep" "in" hyp(h) := redStep in h at 1. - -(* register needed lemmas:*) - - -Lemma rho_correct s t : proc s -> lambda t -> rho s t >* s (rho s) t. -Proof. - intros. unfold rho,r. redStep at 1. apply star_trans_l. now Lsimpl. -Qed. - -(* Hint Resolve rho_correct : Lrewrite. *) - - -Lemma rho_inj s t: rho s = rho t -> s = t. -Proof. - unfold rho,r. congruence. -Qed. - - -#[export] Hint Resolve rho_lambda rho_cls : LProc. - -Tactic Notation "recStep" constr(P) "at" integer(i):= - match eval lazy [P] in P with - | rho ?rP => unfold P;rewrite rho_correct at i;[|Lproc..];fold P;try unfold rP - end. - -Tactic Notation "recStep" constr(P) := - intros;recStep P at 1. - -(* -Lemma rClosed_closed s: recProc s -> proc s. -Proof. - intros [? [? ?]]. subst. split; auto with LProc. -Qed. - -#[export] Hint Resolve rClosed_closed : LProc cbv. - *) - -Lemma I_proc : proc I. -Proof. - fLproc. -Qed. - -Lemma K_proc : proc K. -Proof. - fLproc. -Qed. - -Lemma omega_proc : proc omega. -Proof. - fLproc. -Qed. - -Lemma Omega_closed : closed Omega. -Proof. - fLproc. -Qed. - -#[export] Hint Resolve I_proc K_proc omega_proc Omega_closed: LProc. - -#[export] Hint Extern 0 (I >(_) _)=> unfold I;reflexivity : Lrewrite. -#[export] Hint Extern 0 (K >(_) _)=> unfold K;reflexivity : Lrewrite. diff --git a/theories/L/Tactics/Reflection.v b/theories/L/Tactics/Reflection.v deleted file mode 100644 index 6f5611940..000000000 --- a/theories/L/Tactics/Reflection.v +++ /dev/null @@ -1,329 +0,0 @@ -From Undecidability.L Require Export Util.L_facts. -From Undecidability.L.Tactics Require Import LClos. -Require Import ZArith. (* ? *) -Require Import FunInd. - -(* *** Reflexted closure calculus *) -(* This moduel provides definitions of an symbolic simplifier for reflected L-terms used in Lbeta *) - -Open Scope LClos. - -Inductive rTerm : Type := -| rVar (x : nat) : rTerm -| rApp (s : rTerm) (t : rTerm) : rTerm -| rLam (s : rTerm) -| rConst (x : nat) : rTerm -| rRho (s : rTerm). - -Coercion rApp : rTerm >-> Funclass. - -Definition denoteTerm (phi : nat -> term) :rTerm->term := - fix denoteTerm s := - match s with - | rVar n => var n - | rApp s t=> app (denoteTerm s) (denoteTerm t) - | rLam s => lam (denoteTerm s) - | rConst n => phi n - | rRho s => rho (denoteTerm s) - end. - -Definition Proc phi := forall (n:nat) , proc (phi n). - -Definition rClosed phi s:= Proc phi /\ closed (denoteTerm phi s). - -Definition rPow phi n s t := - denoteTerm phi s >(n) denoteTerm phi t. - -Lemma rReduceIntro phi l s t : Proc phi -> rClosed phi s -> rClosed phi t -> denoteTerm phi s >(l) denoteTerm phi t -> rPow phi l s t. -Proof. - unfold rPow;tauto. -Qed. - -Inductive rComp : Type := -| rCompVar (x:nat) -| rCompApp (s : rComp) (t : rComp) : rComp -| rCompClos (s : rTerm) (A : list rComp) : rComp. - -Coercion rCompApp : rComp >-> Funclass. - - -Definition denoteComp (phi : nat -> term) :rComp -> Comp:= - fix denoteComp s := - match s with - | rCompVar x => CompVar x - | rCompApp s t => (denoteComp s) (denoteComp t) - | rCompClos s A => CompClos (denoteTerm phi s) (map denoteComp A) - end. - -Fixpoint rSubstList (s:rTerm) (x:nat) (A: list rTerm): rTerm := - match s with - | rVar n => if Dec ( n < x )then rVar n else nth (n-x) A (rVar n) - | rApp s t => (rSubstList s x A) (rSubstList t x A) - | rLam s => rLam (rSubstList s (S x) A) - | rRho s => rRho (rSubstList s (S x) A) - | rConst x => rConst x - end. - -Fixpoint rDeClos (s:rComp) : rTerm := - match s with - | rCompVar x => rVar x - | rCompApp s t => (rDeClos s) (rDeClos t) - | rCompClos s A => rSubstList s 0 (map rDeClos A) - end. - - -Definition rComp_ind_deep' - (P : rComp -> Prop) - (Pl : list rComp -> Prop) - (IHVar : forall x : nat, P (rCompVar x)) - (IHApp : forall s : rComp, P s -> forall t : rComp, P t -> P (s t)) - (IHClos : forall (s : rTerm) (A : list rComp), - Pl A -> P (rCompClos s A)) - (IHNil : Pl nil) - (IHCons : forall (a:rComp) (A : list rComp), - P a -> Pl A -> Pl (a::A)) - (x:rComp) : P x := - (fix f c : P c:= - match c with - | rCompVar x => IHVar x - | rCompApp s t => IHApp s (f s) t (f t) - | rCompClos s A => IHClos s A - ((fix g A : Pl A := - match A with - [] => IHNil - | a::A => IHCons a A (f a) (g A) - end) A) - end) x -. - -Definition rComp_ind_deep - (P : rComp -> Prop) - (IHVar : forall x : nat, P (rCompVar x)) - (IHApp : forall s : rComp, P s -> forall t : rComp, P t -> P (s t)) - (IHClos : forall (s : rTerm) (A : list rComp), - (forall a, a el A -> P a) -> P (rCompClos s A)) : forall x, P x. -Proof. - apply rComp_ind_deep' with (Pl:=fun A => (forall a, a el A -> P a)); [auto..|easy|]. - -intros. inv H1;auto. -Qed. - -Definition rValidComp phi s := Proc phi /\validComp (denoteComp phi s). - -Lemma rSubstList_correct phi s x A: Proc phi -> denoteTerm phi (rSubstList s x A) = substList (denoteTerm phi s) x (map (denoteTerm phi) A). -Proof. - revert x. induction s; intros;simpl. - - decide (x < x0); decide (x0 > x); try lia ;intuition (try congruence);simpl. - now rewrite <-map_nth with (f:= denoteTerm phi). - -now rewrite IHs1,IHs2. - -now rewrite IHs. - -rewrite substList_closed. auto. apply H. - -rewrite IHs. 2:tauto. reflexivity. -Qed. - -Lemma map_ext' : forall (A B : Type) (f g : A -> B) (l:list A), - (forall a : A, a el l -> f a = g a) -> map f l = map g l. -Proof. - intros. induction l. - -reflexivity. - -simpl. rewrite H;auto using in_eq, in_cons. f_equal. apply IHl. intros. apply H. - auto using in_eq, in_cons. -Qed. - -Lemma denoteTerm_correct phi s: Proc phi -> deClos (denoteComp phi s) = denoteTerm phi (rDeClos s). -Proof. - intros pp. unfold denoteComp, rDeClos. pattern s. apply rComp_ind_deep;intros;simpl;try congruence. - -rewrite rSubstList_correct;auto. f_equal. - rewrite !map_map. now apply map_ext'. -Qed. - -Definition rCompBeta s t := - match s,t with - |rCompClos (rLam ls) A,rCompClos (rLam lt) B => Some (rCompClos ls (t::A)) - |rCompClos (rLam ls) A,rCompClos (rConst x) B => Some (rCompClos ls (t::A)) - |rCompClos (rLam ls) A,rCompClos (rRho lt) B => Some (rCompClos ls (t::A)) - |_,_ => None - end. - - -Definition rCompAppCount := - fun (j : nat) (u v : nat * rComp) => let (l, u0) := u in let (k, v0) := v in (j + (l + k), u0 v0). - -Fixpoint rCompSeval' n (u : nat*rComp) : (nat *rComp)*bool:= - match n with - S n => - match u with - | (l, rCompApp s t) => - match rCompSeval' n (0,s),rCompSeval' n (0,t) with - (i, s',true),(j, t',true) => - match rCompBeta s' t' with - Some u => rCompSeval' n ((S l)+(i+j),u) - | None => ((l+(i+j),s' t'),false) - end - | ((i,s'),_),((j,t'),_) => ((l+(i+j),s' t'),false) - end - | (l, rCompClos (rApp s t) A ) => - rCompSeval' n (l, rCompApp (rCompClos s A) (rCompClos t A)) - | (l , rCompClos (rVar x) A )=> (l,nth x A (rCompVar x),true) - | (l, rCompClos (rConst x) A )=> (u,true) - | (l, rCompVar x ) => (u,true) - | (l, rCompClos (rLam _) A) => (u,true) - | (l, rCompClos (rRho _) A) => (u,true) - end - | 0 => (u,true) - end. - - - -Definition rCompSeval n u : (nat*rComp):= - (fst (rCompSeval' n u)). - -Lemma rCompBeta_sound phi (s t u: rComp) : Proc phi -> rCompBeta s t = Some u -> denoteComp phi (s t) >[(1)] denoteComp phi u. -Proof with simpl in *;try congruence;auto. - intros pp eq. destruct s... destruct s... destruct t... destruct s0; inv eq... - -constructor. apply pp. - -constructor. eexists. reflexivity. -Qed. - - -Functional Scheme rCompSeval'_ind := Induction for rCompSeval' Sort Prop. - - -Lemma rCompSeval_sound n phi s l: - Proc phi -> let (k,t) := rCompSeval n (l,s) in k >= l /\ denoteComp phi s >[(k-l)] denoteComp phi t. -Proof with (repeat inv_validComp;repeat (eassumption || constructor || intuition idtac || lia || subst ; eauto using star || rewrite Nat.sub_diag in * || rewrite Nat.sub_0_r in *||cbn in * )). - intros. unfold rCompSeval. - pose (p:= (l,s)). - change (let (k, t) := fst (rCompSeval' n p) in k >= fst p /\denoteComp phi (snd p) >[(k-(fst p))] denoteComp phi t). - generalize p. clear l s p. intros p. - functional induction (rCompSeval' n p); intros;cbn... - -rewrite e2,e5 in *... eapply rCompBeta_sound in e8;try eauto. destruct (rCompSeval' _ (S _,_ ));destruct p... eapply (CPow_trans (t:= denoteComp phi (s' t')))... - -rewrite e2,e5 in *... eapply (CPow_trans (t:= denoteComp phi (s' t')))... - -rewrite e2,e5 in *... eapply (CPow_trans (t:= denoteComp phi (s' t')))... - -rewrite e2,e5 in *... eapply (CPow_trans (t:= denoteComp phi (s' t')))... - -rewrite <- map_nth... - -repeat destruct (rCompSeval' _ _)... destruct p... eapply CPow_trans... -Qed. - -Lemma rCompBeta_rValidComp s t u phi : rValidComp phi s -> rValidComp phi t -> rCompBeta s t = Some u -> rValidComp phi u. -Proof with repeat (congruence || subst || simpl in * || intuition ). - unfold rValidComp in *. intros vs vt eq. assert (pp:Proc phi)by (inv vs;auto). split;auto. unfold rCompBeta in eq. destruct s... destruct s... destruct t... destruct s0... - -inv eq. inv H0; inv H2. constructor... rewrite length_map in *. now inv H7. - -inv eq. inv H0; inv H2. constructor... - +destruct (pp x) as [_ H']. inv H'. now rewrite H0. - +rewrite length_map in *. now inv H7. - -inv eq. inv H0; inv H2. constructor... - +rewrite length_map in *. now inv H7. - +rewrite length_map in *. now inv H7. -Qed. - -Lemma rCompSeval_rValidComp n s phi k : Proc phi -> rValidComp phi s -> rValidComp phi (snd (rCompSeval n (k,s))). -Proof with repeat (eapply validCompApp ||apply validCompClos || congruence || subst || simpl in * || intuition). - intros P. unfold rCompSeval. revert s k. induction n; intros s k [? vs];(split;[auto|])... destruct s;try now inv vs;cbn... - -inv vs. assert (IHn1 := IHn s1 0 ). assert (IHn2 := IHn s2 0). - unfold snd,fst in *. do 2 destruct ((rCompSeval' n (_,_)))... destruct p,p0... unfold rValidComp in *. destruct b,b0... destruct (rCompBeta r r0) eqn:eq;unfold rValidComp in *. - +apply IHn... eapply rCompBeta_rValidComp;eauto; unfold rValidComp in *... - +idtac... - -unfold rValidComp in *. inv vs. destruct s;simpl... - +rewrite <- map_nth. apply H2. apply nth_In. now inv H4. - +apply IHn;auto. simpl in *. split;auto. inv H4. repeat constructor... -Qed. - -Lemma rClosed_valid s phi : Proc phi -> (rClosed phi s <-> rValidComp phi (rCompClos s [])). -Proof. - intros pp. unfold rClosed. unfold rValidComp. rewrite closed_dcl. split;intros H. - -repeat constructor;simpl;intuition;apply H0. - -inv H. inv H1. now tauto. -Qed. - - - -Lemma expandDenote phi s: Proc phi -> denoteTerm phi s = deClos (denoteComp phi (rCompClos s [])). -Proof. - intros pp. rewrite (denoteTerm_correct _ pp). simpl. rewrite rSubstList_correct;auto. simpl. now rewrite substList_nil. -Qed. - -Lemma rDeClos_reduce phi s: Proc phi -> rValidComp phi s -> deClos (denoteComp phi s) = deClos (denoteComp phi (rCompClos (rDeClos s) [])). -Proof. - intros pp vc. simpl. rewrite <- denoteTerm_correct;auto. now rewrite substList_nil. -Qed. - - -Lemma rDeClos_rValidComp phi s: Proc phi -> rValidComp phi s -> rValidComp phi (rCompClos (rDeClos s) []). -Proof with repeat (eauto || congruence || subst || simpl in * || intuition). - intros pp [? H]. unfold rValidComp in *. split;try tauto. simpl. apply deClos_valComp in H. apply validComp_closed. now rewrite <- denoteTerm_correct. -Qed. - - -Lemma rStandardize n phi s : Proc phi -> rClosed phi s -> let (l,s') := (rCompSeval n (0,rCompClos s [])) in rPow phi l s (rDeClos s'). -Proof with eauto. - intros pp cl. unfold rPow. rewrite rClosed_valid in *;auto. assert (cl': rValidComp phi (snd (rCompSeval n (0,rCompClos s [])))). - -apply rCompSeval_rValidComp;auto. - - destruct rCompSeval eqn:eq1. rewrite !expandDenote;auto. specialize (rCompSeval_sound n (rCompClos s []) 0 pp);intros H. rewrite eq1 in H. - destruct H as [_ H]. rewrite Nat.sub_0_r in H. rewrite <- rDeClos_reduce... apply deClos_correct... destruct cl... -Qed. - -Lemma rStandardizeUsePow n phi s: - Proc phi -> rClosed phi s -> - let (l,s') := (rCompSeval n (0,rCompClos s [])) in denoteTerm phi s >(l) denoteTerm phi (rDeClos s'). -Proof. - apply rStandardize. -Qed. - -Lemma rStandardizeUse n phi s: - Proc phi -> rClosed phi s -> - let (l,s') := (rCompSeval n (0,rCompClos s [])) in denoteTerm phi s >* denoteTerm phi (rDeClos s'). -Proof. - intros a b. - specialize (rStandardizeUsePow n a b). destruct (rCompSeval _ _). rewrite star_pow. firstorder. -Qed. - - -Fixpoint rClosed_decb' n u : bool:= - match u with - | rApp s t => andb (rClosed_decb' n s) (rClosed_decb' n t) - | rVar x => negb (leb n x) - | rConst x => true - | rLam s =>rClosed_decb' (S n) s - | rRho s =>rClosed_decb' (S n) s - end. - -Lemma rClosed_decb'_correct s phi n: Proc phi -> rClosed_decb' n s = true -> bound n (denoteTerm phi s). -Proof. - intros pp. revert n. induction s;intros n eq;simpl in *. - -rewrite Bool.negb_true_iff in eq. apply leb_complete_conv in eq. now constructor. - -rewrite Bool.andb_true_iff in eq. constructor; intuition. - -constructor. auto. - -apply bound_ge with (k:=0);[|lia]. rewrite <- closed_dcl. apply pp. - -unfold rho,r. - repeat (eapply dclApp||eapply dcllam||eapply dclvar). - all:try lia. eauto. -Qed. - -Definition rClosed_decb s:= rClosed_decb' 0 s. - -Lemma rClosed_decb_correct phi s : Proc phi -> rClosed_decb s = true -> rClosed phi s. -Proof. - intros. hnf;split;[auto|]. rewrite closed_dcl. apply rClosed_decb'_correct;auto. -Qed. - -(* Facts about denote *) - -Definition liftPhi Vars n:=nth n Vars I. - -Arguments liftPhi Vars n/. - -Lemma liftPhi_correct Vars: (forall s, s el Vars -> proc s) -> Proc (liftPhi Vars). -Proof. - intros H n. unfold liftPhi. destruct (nth_in_or_default n Vars I) as [?|eq]. - -now apply H. - -rewrite eq. cbv. split. auto. eexists. eauto. -Qed. - - -Fixpoint benchTerm x : rTerm := - match x with - 0 => (rLam (rVar 0)) - | S x => (rLam (benchTerm x)) (rLam (rVar 0)) - end. - -Close Scope LClos. diff --git a/theories/L/Util/ClosedLAdmissible.v b/theories/L/Util/ClosedLAdmissible.v deleted file mode 100644 index d82746ce5..000000000 --- a/theories/L/Util/ClosedLAdmissible.v +++ /dev/null @@ -1,157 +0,0 @@ -From Undecidability.Shared.Libs.PSL Require Import Vectors. - -From Coq Require Import Vector List. - -From Undecidability.L Require Import L LTactics L_facts Functions.Eval. - -From Undecidability.L.Util Require Import NaryApp. - -Notation encNatL := nat_enc. - -Import ListNotations. -Import VectorNotations. -Import L_Notations. - -Lemma logical {X} (P Q : X -> Prop) : -(forall x, Q x -> P x) -> ((forall x, Q x -> P x) -> forall x, P x -> Q x) -> forall x, P x <-> Q x. -Proof. firstorder. Qed. - - -Definition apply_to (s : L.term) {k} {X : Type} `{encodable X} (v : Vector.t X k) := - many_app s (Vector.map enc v). - -Lemma apply_to_cons (s : L.term) {k} {X : Type} `{encodable X} (v : Vector.t X k) x : - apply_to s (x :: v) = apply_to (L.app s (enc x)) v. -Proof. - reflexivity. -Qed. - -Lemma equiv_eval_equiv s t o : - s == t -> s ⇓ o <-> t ⇓ o. -Proof. - intros H. split; now rewrite H. -Qed. - -Lemma apply_to_equiv' s t {X k} (v : Vector.t X k) `{encodable X} : - s == t -> apply_to s v == apply_to t v. -Proof. - eapply equiv_many_app_L. -Qed. - -Lemma subst_closed s n u : - closed s -> subst s n u = s. -Proof. - now intros ->. -Qed. - -Lemma equiv_R (s t t' : term): - t == t' -> s t == s t'. -Proof. - now intros ->. -Qed. - -Section lemma. - - Context {X : Type}. - Context {Hr : encodable X}. - Context {Hcmp : computable (@enc X _)}. - -Definition apply_encs_to (s : term) k := ((Vector.fold_left (fun s n => ext L.app s (ext (@enc X _) (var n))) s (many_vars k))). - -Lemma subst_apply_encs_to s n u k : - k >= n -> subst (apply_encs_to s n) k u = apply_encs_to (subst s k u) n. -Proof. - induction n in s, k |- *; intros Hk; cbn -[many_vars]. - + reflexivity. - + unfold apply_encs_to. rewrite many_vars_S. cbn. unfold apply_encs_to in IHn. rewrite IHn. - cbn. repeat (rewrite subst_closed; [| now Lproc]). destruct (Nat.eqb_spec n k). lia. - match goal with |- context[subst (ext ?s) _ _] => assert (closed (ext s)) by Lproc end. - repeat f_equal. eapply H. lia. -Qed. - -Lemma many_subst_apply_encs_to s n (u : Vector.t term n) : -closed s -> (forall x, Vector.In x u -> closed x) -> - many_subst (apply_encs_to s n) 0 u = ((Vector.fold_left (fun s n => ext L.app s (ext (@enc X _) n)) s u)). -Proof. - induction u in s |- *; intros Hs Hu; cbn -[many_vars]. - - reflexivity. - - unfold apply_encs_to. rewrite many_vars_S. cbn. unfold apply_encs_to in IHu. rewrite <- IHu. - fold (apply_encs_to (ext L.app s (ext (@enc X _) n)) n). - rewrite subst_apply_encs_to. 2:lia. unfold apply_encs_to. repeat f_equal. - cbn. repeat (rewrite subst_closed; [| now Lproc]). now rewrite Nat.eqb_refl. - assert (closed h) as Hh. eapply Hu. econstructor. Lproc. intros. eapply Hu. now econstructor. -Qed. - -Lemma equiv_fold_left n t1 t2 {v : Vector.t X n} : t1 == t2 -> Vector.fold_left (fun s n => ext L.app s (ext (@enc X _) n)) t1 (Vector.map enc v) == Vector.fold_left (fun s n => ext L.app s (ext (@enc X _) n)) t2 (Vector.map enc v). -Proof. - induction v in t1, t2 |- *; cbn; intros H. - - exact H. - - eapply IHv. now rewrite H. -Qed. - -#[local] Instance nat_unenc_term : computable nat_unenc. -Proof. extract. Qed. - -Lemma total_decodable_closed_new k (s : L.term) : - (forall v : Vector.t X k, forall o : L.term, L_facts.eval (apply_to s v) o -> exists l : nat, o = enc l) -> - exists s', closed s' /\ forall v : Vector.t X k, forall o, L_facts.eval (apply_to s' v) o <-> L_facts.eval (apply_to s v) o. -Proof using Hcmp. - intros Htot. - assert (closed Eval) as He. { unfold Eval. Lproc. } - exists (many_lam k (ext nat_unenc (Eval (apply_encs_to (enc s) k)) (lam 0) (ext false))). - split. { intros n u. rewrite subst_many_lam. cbn -[Eval]. repeat (rewrite subst_closed; [| now Lproc]). rewrite subst_apply_encs_to. 2:lia. now repeat (rewrite subst_closed; [| now Lproc]). } - intros v. revert s Htot. induction v; intros s Htot o. - - cbn. specialize (Htot (Vector.nil _)). cbn in Htot. - eapply logical; clear o. - + intros o Hl. pose proof Hl as [y ->] % Htot. eapply eval_Eval in Hl. rewrite Hl. - split. 2: Lproc. Lsimpl. rewrite unenc_correct. now Lsimpl. - + intros Hrev o Heval. - match type of Heval with L_facts.eval ?l _ => assert (Hc : converges l) by eauto end. - eapply app_converges in Hc as [[[_ Hc]%app_converges _] % app_converges _]. - eapply Eval_converges in Hc as [o' [Hc Hl]]. rewrite Hc. - enough (o = o'). subst. now econstructor; eauto. eapply eval_unique. - eapply Heval. eapply Hrev. rewrite Hc. split; eauto. reflexivity. - - cbn -[apply_to many_vars]. rewrite !apply_to_cons. specialize (IHv (s (enc h))). rewrite <- IHv. - + unfold apply_encs_to. cbn -[many_vars]. rewrite many_vars_S. cbn. eapply equiv_eval_equiv. etransitivity. eapply apply_to_equiv'. eapply beta_red. Lproc. reflexivity. - rewrite subst_many_lam. cbn [subst]. replace (n + 0) with n by lia. - rewrite He. assert (closed (ext nat_unenc)) as H2 by Lproc. unfold closed in H2. rewrite H2. clear H2. cbn. - assert (closed (ext false)) as H2 by Lproc. unfold closed in H2. rewrite H2. clear H2. unfold apply_to. - rewrite many_beta. rewrite !many_subst_app. repeat (rewrite many_subst_closed; [ | now Lproc]). - symmetry. - rewrite many_beta. rewrite !many_subst_app. repeat (rewrite many_subst_closed; [ | now Lproc]). - 2:{ clear. induction v; cbn; intros ? Hi. inversion Hi. inv Hi. Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. subst. eauto. eapply nat_eq_dec. } - 2:{ clear. induction v; cbn; intros ? Hi. inversion Hi. inv Hi. Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. subst. eauto. eapply nat_eq_dec. } - repeat (eapply equiv_app_proper; try reflexivity). clear. - fold (@apply_encs_to (enc (s (enc h))) n). fold (apply_encs_to (ext L.app (enc s) (ext (@enc X _) n)) n). - rewrite subst_apply_encs_to. cbn. repeat (rewrite subst_closed; [ | now Lproc]). rewrite Nat.eqb_refl. - rewrite !many_subst_apply_encs_to. - * rewrite equiv_fold_left. reflexivity. now Lsimpl. - * Lproc. - * clear. induction v; cbn; intros ? Hi. inversion Hi. inv Hi. Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. subst. eauto. eapply nat_eq_dec. - * Lproc. - * clear. induction v; cbn; intros ? Hi. inversion Hi. inv Hi. Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. subst. eauto. eapply nat_eq_dec. - * lia. - + intros. now apply (Htot (h :: v0)). -Qed. -End lemma. - -Lemma many_app_eq_nat {k} (v : Vector.t nat k) s : many_app s (Vector.map enc v) = Vector.fold_left (fun (s : term) n => s (encNatL n)) s v. -Proof. - induction v in s |- *. - * cbn. reflexivity. - * cbn. now rewrite IHv. -Qed. - -Lemma L_computable_can_closed k R: - L_computable_closed R <-> L_computable (k:=k) R. -Proof. - split. - - intros (s & _ & H). exists s. exact H. - - intros (s & H). - unshelve edestruct (@total_decodable_closed_new nat _ _ k s) as (s' & Hcl & Hs'). - + intros v o. rewrite <- eval_iff. intros. eapply (H v). unfold apply_to in H0. revert H0. - now rewrite many_app_eq_nat. - + unfold apply_to in Hs'. exists s'. split. change (closed s'). Lproc. intros v. split. - * intros m. specialize (H v) as [H1 H2]. rewrite H1. rewrite !eval_iff. rewrite <- !many_app_eq_nat. now rewrite Hs'. - * intros o. rewrite eval_iff. rewrite <- many_app_eq_nat. rewrite Hs'. rewrite <- eval_iff. rewrite many_app_eq_nat. eapply H. -Qed. diff --git a/theories/L/Util/NaryApp.v b/theories/L/Util/NaryApp.v deleted file mode 100644 index 040428e4e..000000000 --- a/theories/L/Util/NaryApp.v +++ /dev/null @@ -1,110 +0,0 @@ -Require Import Undecidability.L.L Undecidability.L.Util.L_facts. -Require Import Undecidability.Shared.Libs.PSL.Vectors.Vectors. -Require Import Vector List. -Import ListNotations. -Import VectorNotations. -Import L_Notations. - -Fixpoint many_lam k s := match k with 0 => s | S k => lam (many_lam k s) end. - -Lemma subst_many_lam k n u s : - subst (many_lam k s) n u = many_lam k (subst s (k + n) u). -Proof. - induction k in n |- *; cbn. - - reflexivity. - - f_equal. rewrite IHk. repeat f_equal. lia. -Qed. - -Fixpoint many_app k s (v : Vector.t term k) := - match v with - | Vector.nil _ => s - | Vector.cons _ x _ v => many_app (L.app s x) v - end. - -Lemma subst_many_app k (v : Vector.t term k) n u s : - subst (many_app s v) n u = many_app (subst s n u) (Vector.map (fun s => subst s n u) v). -Proof. - induction v in s |- *; cbn. - - reflexivity. - - now rewrite IHv. -Qed. - -Lemma equiv_many_app_L k (v : Vector.t term k) s t : - s == t -> many_app s v == many_app t v. -Proof. - induction v in s, t |- *; intros H; cbn. - - eassumption. - - eapply IHv. now rewrite H. -Qed. - -Fixpoint tabulate {X : Type} (n : nat) (f : Fin.t n -> X) {struct n} : Vector.t X n := - match n as m return ((Fin.t m -> X) -> t X m) with - | 0 => fun _ => [] - | S m => fun f => f Fin.F1 :: @tabulate _ m (fun i => f (Fin.FS i)) - end f. - -Definition many_vars k := (tabulate (n := k) (fun i => k - S (proj1_sig (Fin.to_nat i)))). - -Lemma tabulate_ext {X} k f1 f2 : - (forall i, f1 i = f2 i :> X) -> tabulate (n := k) f1 = tabulate f2. -Proof. - intros H. induction k in f1, f2, H |- *; cbn. - - reflexivity. - - f_equal; eauto. -Qed. - -Lemma many_vars_S n : - many_vars (S n) = n :: many_vars n. -Proof. - cbn. f_equal. unfold many_vars. lia. eapply tabulate_ext. intros i. destruct Fin.to_nat as [i_ Hi]. - reflexivity. -Qed. - -Fixpoint many_subst {k} s n (v : Vector.t term k) := - match v with - | [] => s - | Vector.cons _ u k v => many_subst (subst s (n + k) u) n v - end. - -Lemma beta_red s t t' : lambda t -> t' == subst s 0 t -> (lam s) t == t'. -Proof. - intros [u ->] ->. repeat econstructor. -Qed. - -Lemma many_beta k (v : Vector.t term k) s : - (forall x, Vector.In x v -> proc x) -> - many_app (many_lam k s) v == many_subst s 0 v. -Proof. - induction v in s |- *; cbn; intros Hv. - - reflexivity. - - rewrite equiv_many_app_L. 2:{ eapply beta_red. eapply Hv. econstructor. reflexivity. } - rewrite subst_many_lam. replace (n + 0) with n by lia. rewrite IHv. reflexivity. - intros. eapply Hv. now econstructor. -Qed. - -Lemma many_subst_app (s t : term) {k} n (v : Vector.t term k) : - many_subst (s t) n v = (many_subst s n v) (many_subst t n v). -Proof. - induction v in n, s, t |- *. - - reflexivity. - - cbn. now rewrite IHv. -Qed. - -Lemma many_subst_many_app (s : term) {k} n (ts v : Vector.t term k) : - many_subst (many_app s ts) n v = many_app (many_subst s n v) (Vector.map (fun t => many_subst t n v) ts). -Proof. - induction v in n, s, ts |- *. - - cbn. revert ts. apply case0. reflexivity. - - cbn. apply (caseS' ts). cbn. intros. - rewrite subst_many_app, IHv. cbn. rewrite many_subst_app. - now rewrite Vector.map_map. -Qed. - -Lemma many_subst_closed (s : term) {k} n (v : Vector.t term k) : - closed s -> many_subst s n v = s. -Proof. - induction v in n, s |- *. - - reflexivity. - - cbn. intros H. rewrite H. now eapply IHv. -Qed. - \ No newline at end of file diff --git a/theories/_CoqProject b/theories/_CoqProject index c8b83b0e0..b5bb34e21 100644 --- a/theories/_CoqProject +++ b/theories/_CoqProject @@ -530,71 +530,6 @@ L/AbstractMachines/wCBV.v L/Enumerators/HaltL_enum.v L/L_enum.v -#extraction framework - -L/Util/NaryApp.v -L/Util/ClosedLAdmissible.v - -L/Tactics/Computable.v -L/Tactics/LTactics.v -L/Tactics/Extract.v -L/Tactics/GenEncode.v -L/Tactics/Lbeta_nonrefl.v -L/Tactics/Lproc.v -L/Tactics/Lbeta.v -L/Tactics/Reflection.v -L/Tactics/LClos.v -L/Tactics/Lrewrite.v -L/Tactics/Lsimpl.v -L/Tactics/ComputableTactics.v - -L/Datatypes/LUnit.v -L/Datatypes/LBool.v -L/Datatypes/List/List_basics.v -L/Datatypes/List/List_enc.v -L/Datatypes/List/List_eqb.v -L/Datatypes/List/List_extra.v -L/Datatypes/List/List_in.v -L/Datatypes/List/List_nat.v -L/Datatypes/Lists.v -L/Datatypes/LNat.v -L/Datatypes/LOptions.v -L/Datatypes/LProd.v -L/Datatypes/LSum.v -L/Datatypes/LTerm.v -L/Datatypes/LFinType.v -L/Datatypes/LVector.v - -L/Functions/EqBool.v -L/Functions/Equality.v -L/Functions/Encoding.v -L/Functions/Proc.v -L/Functions/Subst.v -L/Functions/Eval.v -L/Functions/FinTypeLookup.v -L/Functions/Ackermann.v - -L/TM/TMEncoding.v -L/TM/TMinL.v -L/TM/TMinL/TMinL_extract.v -L/TM/TapeFuns.v -L/Reductions/TM_to_L.v -L/Reductions/H10_to_L.v -L/Reductions/PCPb_to_HaltL.v -L/Reductions/MuRec/MuRec_extract.v -L/Reductions/HaltMuRec_to_HaltL.v -L/Reductions/MuRec_computable_to_L_computable.v - -L/Computability/Acceptability.v -L/Computability/Computability.v -L/Computability/Decidability.v -L/Computability/Fixpoints.v -L/Computability/MuRec.v -L/Computability/Por.v -L/Computability/Synthetic.v -L/Computability/Scott.v -L/Computability/Rice.v - HOU/std/tactics.v HOU/std/misc.v HOU/std/decidable.v