From 889cb48af31d827e96a76fbca4bd6be48b8d4456 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 5 Oct 2021 14:38:37 +0200 Subject: [PATCH 01/40] synthesize tag --- Makefile.coq.local | 1 + _CoqProject | 3 ++- src/large_defs.v | 6 +++-- src/list_defs.v | 5 ++++- src/option_defs.v | 20 +++++++++-------- src/tag.elpi | 56 ++++++++++++++++++++++++++++++++++++++++++++++ src/tag.v | 24 ++++++++++++++++++++ 7 files changed, 102 insertions(+), 13 deletions(-) create mode 100644 Makefile.coq.local create mode 100644 src/tag.elpi create mode 100644 src/tag.v diff --git a/Makefile.coq.local b/Makefile.coq.local new file mode 100644 index 0000000..266958a --- /dev/null +++ b/Makefile.coq.local @@ -0,0 +1 @@ +src/tag.vo : src/tag.elpi \ No newline at end of file diff --git a/_CoqProject b/_CoqProject index 9f8ae50..19b0d58 100644 --- a/_CoqProject +++ b/_CoqProject @@ -17,4 +17,5 @@ src/option_defs.v src/list_defs.v src/nested_defs.v src/nested_list_defs.v -src/large_defs.v \ No newline at end of file +src/large_defs.v +src/tag.v \ No newline at end of file diff --git a/src/large_defs.v b/src/large_defs.v index c3f6903..691fe18 100644 --- a/src/large_defs.v +++ b/src/large_defs.v @@ -1,7 +1,7 @@ Require Import Eqdep_dec. From mathcomp Require Import all_ssreflect. -Require Import core_defs. +Require Import core_defs tag. Set Implicit Arguments. Unset Strict Implicit. @@ -212,7 +212,8 @@ Inductive t := Module AUX. -Definition tag (x : t) := +Elpi tag t. +Definition tag := t_tag. (* (x : t) := match x with | T1 => 1 | T2 => 2 @@ -414,6 +415,7 @@ Definition tag (x : t) := | T198 => 198 | T199 => 199 end. +*) Definition fields_t (p:positive) : Type := unit. diff --git a/src/list_defs.v b/src/list_defs.v index 8bdf5a7..d810755 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -1,7 +1,7 @@ Require Import Eqdep_dec. From mathcomp Require Import all_ssreflect. -Require Import core_defs. +Require Import core_defs tag. Set Implicit Arguments. Unset Strict Implicit. @@ -27,11 +27,14 @@ Module AUX. Section Section. Context {A : Type}. +Elpi tag list. +Definition tag {A} := @list_tag A. (* Definition tag (x : list A) := match x with | [::] => 1 | _ :: _ => 2 end. +*) Definition fields_t (t : positive) : Type := match t with diff --git a/src/option_defs.v b/src/option_defs.v index 22cf892..365e82a 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -1,7 +1,7 @@ Require Import Eqdep_dec. From mathcomp Require Import all_ssreflect. -Require Import core_defs. +Require Import core_defs tag. Set Implicit Arguments. Unset Strict Implicit. @@ -27,15 +27,17 @@ Module AUX. Section Section. Context {A : Type}. -Definition tag (x : option A) := +Elpi tag option. +Definition tag {A} := @option_tag A. (*(x : option A) := match x with | None => 1 | Some _ => 2 end. +*) Definition fields_t (t:positive) : Type := match t with - | 2 => A + | 1 => A | _ => unit end. @@ -47,8 +49,8 @@ Definition fields (x:option A) : fields_t (tag x) := Definition construct (t:positive) : fields_t t -> option (option A) := match t with - | 1 => fun _ => Some None - | 2 => fun a => Some (Some a) + | 1 => fun a => Some (Some a) + | 2 => fun _ => Some None | _ => fun _ => None end. @@ -70,15 +72,15 @@ Context (A:Type) (Aeqb : A -> A -> bool). Definition eqb_fields (t:positive) : fields_t t -> fields_t t -> bool := match t return fields_t t -> fields_t t -> bool with - | 1 => eq_op - | 2 => Aeqb + | 1 => Aeqb + | 2 => eq_op | _ => eq_op end. Definition eqb (x1 x2:option A) := match x1 with - | None => eqb_body eqb_fields (t1:=1) tt x2 - | Some a => eqb_body eqb_fields (t1:=2) a x2 + | Some a => eqb_body eqb_fields (t1:=1) a x2 + | None => eqb_body eqb_fields (t1:=2) tt x2 end. Lemma eqb_correct_on_None : eqb_correct_on eqb None. diff --git a/src/tag.elpi b/src/tag.elpi new file mode 100644 index 0000000..bc646a1 --- /dev/null +++ b/src/tag.elpi @@ -0,0 +1,56 @@ + +% not necessary, but gives pointers to relevant files +shorten std.{ fold-map , do! , spy-do!, last }. % from elpi-builtin.elpi +shorten coq.{ build-match , bind-ind-arity }. % from coq-lib.elpi +shorten coq.{ typecheck }. % from coq-builtin.elpi + +% if we load this file together with others files, we avoid chlashes +namespace tag { + +% we return the clauses for the tag.db since we may need them right away +% if we run other derivations immediately +pred main i:inductive, i:string, o:list prop. +main I Prefix CL :- do! [ + + % build fun params (x : I params) => ... do-match ... + coq.env.indt I _ _ _ Arity _ _, + bind-ind-arity (global (indt I)) Arity do-match Body, + + % typecheck (and infer univ constraints) + std.assert-ok! (typecheck Body Ty) "tag generates illtyped code", + + % save constant + Name is Prefix ^ "tag", + coq.env.add-const Name Body Ty ff C, + + % store in the DB the tag function, so that other Elpi commands can find it + CL = [tag-for I C], + std.forall CL (x\ coq.elpi.accumulate _ "tag.db" (clause _ _ x)), +]. + +% We build the match with dummy branches (you get the lambdas for the +% arguments of constructors, then Prop). Then we put the right number in place. +pred do-match i:term, i:list term, i:list term, o:term. +do-match _ Vars Tys (match X Rty BL1) :- do! [ + last Vars X, % the last variable is the one for the inductive type + last Tys XTy, + build-match X XTy do-rty do-dummy-branch (match X Rty BL), + fold-map BL {{ 1 }} do-branch BL1 _, % XXX why 1 based? +]. + +% builds the return clause of the match +pred do-rty i:term, i:list term,i:list term, o:term. +do-rty _ _ _ {{ positive }}. + +% build each branch +pred do-dummy-branch i:term, i:term, i:list term, i:list term, o:term. +do-dummy-branch _ _ _ _ {{ Prop }}. % dummy + +% [do-branch InTerm Acc NewTem NewAcc] descends into a branch and puts Acc +% in place of the dummy +pred do-branch i:term, i:term, o:term, o:term. +do-branch {{ Prop }} X X Y :- coq.reduction.lazy.norm {{ lp:X + 1 }} Y. +do-branch (fun N T F) X (fun N T R) Y :- + @pi-decl N T x\ do-branch (F x) X (R x) Y. + +} \ No newline at end of file diff --git a/src/tag.v b/src/tag.v new file mode 100644 index 0000000..a08f96c --- /dev/null +++ b/src/tag.v @@ -0,0 +1,24 @@ +From elpi Require Import elpi. +From Coq Require Import PArith. +Open Scope positive_scope. + +Elpi Db tag.db lp:{{ + +% this is how one registers the tag function to an inductive and let other +% elpi commands use that piece of info +pred tag-for o:inductive, o:constant. + +}}. + +Elpi Command tag. +Elpi Accumulate File "src/tag.elpi". +Elpi Accumulate Db tag.db. +Elpi Accumulate lp:{{ + + main [str S] :- + std.assert! (coq.locate S (indt I)) "Not an inductive type", + Prefix is S ^ "_", + tag.main I Prefix _. + +}}. +Elpi Typecheck. From 872f13c265a01b3d4ceb2fff7447b39c57f01d33 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 5 Oct 2021 14:41:47 +0200 Subject: [PATCH 02/40] color elpi files --- .gitattributes | 1 + 1 file changed, 1 insertion(+) create mode 100644 .gitattributes diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..e181b66 --- /dev/null +++ b/.gitattributes @@ -0,0 +1 @@ +*.elpi linguist-language=prolog From 1e70dc3fb55fea01c6c00086d645deb4a1c40438 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 5 Oct 2021 15:03:45 +0200 Subject: [PATCH 03/40] be agnostic on the type of tags --- src/tag.elpi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tag.elpi b/src/tag.elpi index bc646a1..3e69f23 100644 --- a/src/tag.elpi +++ b/src/tag.elpi @@ -40,7 +40,7 @@ do-match _ Vars Tys (match X Rty BL1) :- do! [ % builds the return clause of the match pred do-rty i:term, i:list term,i:list term, o:term. -do-rty _ _ _ {{ positive }}. +do-rty _ _ _ _. % we leave a hole % build each branch pred do-dummy-branch i:term, i:term, i:list term, i:list term, o:term. From 01b32fa2e0c8c3b4069b8d026e34d50b1292d4a9 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 5 Oct 2021 16:16:33 +0200 Subject: [PATCH 04/40] I'm stupid --- src/tag.elpi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tag.elpi b/src/tag.elpi index 3e69f23..7d147f2 100644 --- a/src/tag.elpi +++ b/src/tag.elpi @@ -35,7 +35,7 @@ do-match _ Vars Tys (match X Rty BL1) :- do! [ last Vars X, % the last variable is the one for the inductive type last Tys XTy, build-match X XTy do-rty do-dummy-branch (match X Rty BL), - fold-map BL {{ 1 }} do-branch BL1 _, % XXX why 1 based? + fold-map BL {{ 1 }} do-branch BL1 _, ]. % builds the return clause of the match From b98f20093b903f51865b13bbfd1b09f67b3beb2d Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 6 Oct 2021 08:59:04 +0200 Subject: [PATCH 05/40] please vscode --- .vscode/settings.json | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 .vscode/settings.json diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 0000000..ac5b5e6 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,12 @@ +{ + "files.exclude": { + "**/*.d": true, + "**/*.vo": true, + "**/*.vok": true, + "**/*.vos": true, + "**/*.glob": true, + "**/*.aux": true, + "**/Makefile.coq": true, + "**/Makefile.coq.conf": true + } +} \ No newline at end of file From 3aea0872794c5a24e32507e4d586f5c67a24937c Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 6 Oct 2021 11:49:37 +0200 Subject: [PATCH 06/40] first stab at fields --- Makefile.coq.local | 3 ++- _CoqProject | 3 ++- src/fields.elpi | 62 ++++++++++++++++++++++++++++++++++++++++++++++ src/fields.v | 26 +++++++++++++++++++ src/list_defs.v | 6 +++-- src/option_defs.v | 7 +++--- 6 files changed, 100 insertions(+), 7 deletions(-) create mode 100644 src/fields.elpi create mode 100644 src/fields.v diff --git a/Makefile.coq.local b/Makefile.coq.local index 266958a..8abcff7 100644 --- a/Makefile.coq.local +++ b/Makefile.coq.local @@ -1 +1,2 @@ -src/tag.vo : src/tag.elpi \ No newline at end of file +src/tag.vo : src/tag.elpi +src/fields.vo : src/fields.elpi \ No newline at end of file diff --git a/_CoqProject b/_CoqProject index 19b0d58..27083da 100644 --- a/_CoqProject +++ b/_CoqProject @@ -18,4 +18,5 @@ src/list_defs.v src/nested_defs.v src/nested_list_defs.v src/large_defs.v -src/tag.v \ No newline at end of file +src/tag.v +src/fields.v \ No newline at end of file diff --git a/src/fields.elpi b/src/fields.elpi new file mode 100644 index 0000000..b19d11b --- /dev/null +++ b/src/fields.elpi @@ -0,0 +1,62 @@ +namespace fields { + + + +pred main i:inductive, i:string, o:list prop. +main I Prefix CL :- std.do! [ + + coq.env.indt-decl I Decl, % Decl is easier to manipulate than KL & co above + do-params Decl (global (indt I)) Body_t, + + std.assert-ok! (coq.typecheck Body_t Ty) "fields generates illtyped fields_t", + + Name is Prefix ^ "fields_t", + coq.env.add-const Name Body_t Ty ff C_t, + + CL = [fields-for I C_t C], + +]. + +pred do-params i:indt-decl, i:term, o:term. +do-params (parameter ID _ Ty Decl) I (fun N Ty F) :- + coq.id->name ID N, + @pi-decl N Ty x\ do-params (Decl x) {coq.mk-app I [x]} (F x). +do-params (inductive ID tt Arity Decl) Self (fun `x` {{ positive }} F) :- + @pi-inductive ID Arity i\ + copy i Self => + @pi-decl `x` {{ positive }} x\ + build-positive-match x (Decl i) (F x). +do-params (inductive _ ff _ _) _ _ :- std.assert! fail "records and coinductives not supported". +do-params (record _ _ _ _) _ _ :- std.assert! fail "records and coinductives not supported". + +pred build-positive-match i:term, i:list indc-decl, o:term. +build-positive-match _ [] {{ unit }}. +build-positive-match X KL R :- + coq.build-match X {{ positive }} do-rty (do-branch KL) R. + +pred do-rty i:term, i:list term,i:list term, o:term. +do-rty _ _ _ {{ Type }}. % we leave a hole + +pred list-bitmask i:list A, o:list A, o:list A. +list-bitmask [] [] []. +list-bitmask [X] [X] []. +list-bitmask [X,Y|L] [X|A] [Y|B] :- list-bitmask L A B. + +pred do-branch i:list indc-decl, i:term, i:term, i:list term, i:list term, o:term. +do-branch [_|KS] {{ xO }} _ [P] _ R :- + list-bitmask KS KODD _, + build-positive-match P KODD R. +do-branch [_|KS] {{ xI }} _ [P] _ R :- + list-bitmask KS _ KEVEN, + build-positive-match P KEVEN R. +do-branch [constructor _ Arity|_] {{ xH }} _ _ _ R :- + to-tuple {coq.arity->term Arity} R. + +pred to-tuple i:term, o:term. +to-tuple (prod N Ty F) {{ (lp:Ty1 * lp:X)%type }} :- (F = x\prod _ _ _), !, % not the last one + copy Ty Ty1, + @pi-decl N Ty x\ to-tuple (F x) X. +to-tuple (prod _ Ty _) Ty1 :- copy Ty Ty1. +to-tuple _ {{ unit }}. % other branches + +} \ No newline at end of file diff --git a/src/fields.v b/src/fields.v new file mode 100644 index 0000000..858b33b --- /dev/null +++ b/src/fields.v @@ -0,0 +1,26 @@ +From elpi Require Import elpi. +From Coq Require Import PArith. +Require Export tag. +Open Scope positive_scope. + +Elpi Db fields.db lp:{{ + +% this is how one registers the fields_t and fields constants to an inductive +% and let other elpi commands use that piece of info +pred fields-for o:inductive, o:constant, o:constant. + +}}. + +Elpi Command fields. +Elpi Accumulate File "src/fields.elpi". +Elpi Accumulate Db tag.db. +Elpi Accumulate Db fields.db. +Elpi Accumulate lp:{{ + + main [str S] :- + std.assert! (coq.locate S (indt I)) "Not an inductive type", + Prefix is S ^ "_", + fields.main I Prefix _. + +}}. +Elpi Typecheck. diff --git a/src/list_defs.v b/src/list_defs.v index d810755..dd2f9a2 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -1,7 +1,7 @@ Require Import Eqdep_dec. From mathcomp Require Import all_ssreflect. -Require Import core_defs tag. +Require Import core_defs tag fields. Set Implicit Arguments. Unset Strict Implicit. @@ -36,11 +36,13 @@ Definition tag (x : list A) := end. *) -Definition fields_t (t : positive) : Type := +Elpi fields list. +Definition fields_t := @list_fields_t A. (*(t : positive) : Type := match t with | 2 => (A * list A)%type | _ => unit end. +*) Definition fields (x : list A) : fields_t (tag x) := match x return fields_t (tag x) with diff --git a/src/option_defs.v b/src/option_defs.v index 365e82a..96343b0 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -1,7 +1,7 @@ Require Import Eqdep_dec. From mathcomp Require Import all_ssreflect. -Require Import core_defs tag. +Require Import core_defs tag fields. Set Implicit Arguments. Unset Strict Implicit. @@ -35,11 +35,12 @@ Definition tag {A} := @option_tag A. (*(x : option A) := end. *) -Definition fields_t (t:positive) : Type := +Elpi fields option. +Definition fields_t := @option_fields_t A. (*(t:positive) : Type := match t with | 1 => A | _ => unit - end. + end.*) Definition fields (x:option A) : fields_t (tag x) := match x return fields_t (tag x) with From 575d00f4c92344f7534cf2c3418ea29cdf71b2d8 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 6 Oct 2021 14:57:00 +0200 Subject: [PATCH 07/40] fields --- src/fields.elpi | 48 ++++++++++++++++++++++++++++++++++++++--------- src/list_defs.v | 4 ++-- src/option_defs.v | 4 ++-- 3 files changed, 43 insertions(+), 13 deletions(-) diff --git a/src/fields.elpi b/src/fields.elpi index b19d11b..217ef6b 100644 --- a/src/fields.elpi +++ b/src/fields.elpi @@ -8,12 +8,22 @@ main I Prefix CL :- std.do! [ coq.env.indt-decl I Decl, % Decl is easier to manipulate than KL & co above do-params Decl (global (indt I)) Body_t, - std.assert-ok! (coq.typecheck Body_t Ty) "fields generates illtyped fields_t", + std.assert-ok! (coq.typecheck Body_t Ty_t) "fields generates illtyped fields_t", - Name is Prefix ^ "fields_t", - coq.env.add-const Name Body_t Ty ff C_t, + Name_t is Prefix ^ "fields_t", + coq.env.add-const Name_t Body_t Ty_t ff C_t, + + coq.env.indt I _ _ _ Arity _ _, + std.assert! (tag-for I Tag) "no tag for this inductive", + coq.bind-ind-arity (global (indt I)) Arity (do-repack C_t Tag) Body, + + std.assert-ok! (coq.typecheck Body Ty) "fields generates illtyped fields", + + Name is Prefix ^ "fields", + coq.env.add-const Name Body Ty ff C, CL = [fields-for I C_t C], + std.forall CL (x\ coq.elpi.accumulate _ "fields.db" (clause _ _ x)), ]. @@ -50,13 +60,33 @@ do-branch [_|KS] {{ xI }} _ [P] _ R :- list-bitmask KS _ KEVEN, build-positive-match P KEVEN R. do-branch [constructor _ Arity|_] {{ xH }} _ _ _ R :- - to-tuple {coq.arity->term Arity} R. + prod->tuple {coq.arity->term Arity} R. -pred to-tuple i:term, o:term. -to-tuple (prod N Ty F) {{ (lp:Ty1 * lp:X)%type }} :- (F = x\prod _ _ _), !, % not the last one +pred prod->tuple i:term, o:term. +prod->tuple (prod N Ty F) {{ (lp:Ty1 * lp:X)%type }} :- (F = x\prod _ _ _), !, % not the last one copy Ty Ty1, - @pi-decl N Ty x\ to-tuple (F x) X. -to-tuple (prod _ Ty _) Ty1 :- copy Ty Ty1. -to-tuple _ {{ unit }}. % other branches + @pi-decl N Ty x\ prod->tuple (F x) X. +prod->tuple (prod _ Ty _) Ty1 :- copy Ty Ty1. +prod->tuple _ {{ unit }}. % other branches + +pred do-repack i:constant, i:constant, i:term, i:list term, i:list term, o:term. +do-repack C_t Tag _ Vars Tys R :- + std.appendR Params [X] Vars, + std.last Tys XTy, + coq.mk-app (global (const C_t)) Params C_tp, + coq.mk-app (global (const Tag)) Params Tagp, + coq.build-match X XTy (do-rty_t C_tp Tagp) args->tuple R. + +pred do-rty_t i:term, i:term, i:term, i:list term,i:list term, o:term. +do-rty_t C_t Tag _ Vars _ R :- + std.last Vars X, + coq.mk-app Tag [X] TagX, + coq.mk-app C_t [TagX] R. + +pred args->tuple i:term, i:term, i:list term, i:list term, o:term. +args->tuple _ _ [] _ {{ tt }}. +args->tuple _ _ [X] _ X. +args->tuple A B [X|XS] C {{ ( lp:X , lp:R ) }} :- + args->tuple A B XS C R. } \ No newline at end of file diff --git a/src/list_defs.v b/src/list_defs.v index dd2f9a2..a8d715d 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -44,11 +44,11 @@ Definition fields_t := @list_fields_t A. (*(t : positive) : Type := end. *) -Definition fields (x : list A) : fields_t (tag x) := +Definition fields := @list_fields A. (*(x : list A) : fields_t (tag x) := match x return fields_t (tag x) with | [::] => tt | a::l => (a, l) - end. + end.*) Definition construct (t:positive) : fields_t t -> option (list A) := match t with diff --git a/src/option_defs.v b/src/option_defs.v index 96343b0..1e89ad8 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -42,11 +42,11 @@ Definition fields_t := @option_fields_t A. (*(t:positive) : Type := | _ => unit end.*) -Definition fields (x:option A) : fields_t (tag x) := +Definition fields := @option_fields A. (* (x:option A) : fields_t (tag x) := match x return fields_t (tag x) with | None => tt | Some a => a - end. + end.*) Definition construct (t:positive) : fields_t t -> option (option A) := match t with From 12973c5e06a99781ed8058223de7fa05935dc1c2 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 13 Oct 2021 15:19:25 +0200 Subject: [PATCH 08/40] wip construct --- src/fields.elpi | 121 ++++++++++++++++++++++++++++++++++------------ src/list_defs.v | 4 +- src/option_defs.v | 4 +- 3 files changed, 93 insertions(+), 36 deletions(-) diff --git a/src/fields.elpi b/src/fields.elpi index 217ef6b..0cee3d2 100644 --- a/src/fields.elpi +++ b/src/fields.elpi @@ -1,12 +1,14 @@ namespace fields { - +pred fields_t. % chose between fields_t and construct +pred self o:term. pred main i:inductive, i:string, o:list prop. main I Prefix CL :- std.do! [ - coq.env.indt-decl I Decl, % Decl is easier to manipulate than KL & co above - do-params Decl (global (indt I)) Body_t, + coq.bind-ind-parameters I + (_\ params\ _\ bind-positive (kty->tuple I params)) + Body_t, std.assert-ok! (coq.typecheck Body_t Ty_t) "fields generates illtyped fields_t", @@ -15,7 +17,7 @@ main I Prefix CL :- std.do! [ coq.env.indt I _ _ _ Arity _ _, std.assert! (tag-for I Tag) "no tag for this inductive", - coq.bind-ind-arity (global (indt I)) Arity (do-repack C_t Tag) Body, + coq.bind-ind-arity (global (indt I)) Arity (repack-as-tuple C_t Tag) Body, std.assert-ok! (coq.typecheck Body Ty) "fields generates illtyped fields", @@ -25,42 +27,97 @@ main I Prefix CL :- std.do! [ CL = [fields-for I C_t C], std.forall CL (x\ coq.elpi.accumulate _ "fields.db" (clause _ _ x)), + CL => + coq.bind-ind-parameters I + (_\ params\ _\ bind-positive (fun-tuple->kapp-proj I params)) + Body_c, + + std.assert-ok! (coq.typecheck Body_c Ty_c) "fields generates illtyped construct", + + Name_c is Prefix ^ "construct", + coq.env.add-const Name_c Body_c Ty_c ff _, + ]. -pred do-params i:indt-decl, i:term, o:term. -do-params (parameter ID _ Ty Decl) I (fun N Ty F) :- - coq.id->name ID N, - @pi-decl N Ty x\ do-params (Decl x) {coq.mk-app I [x]} (F x). -do-params (inductive ID tt Arity Decl) Self (fun `x` {{ positive }} F) :- - @pi-inductive ID Arity i\ - copy i Self => - @pi-decl `x` {{ positive }} x\ - build-positive-match x (Decl i) (F x). -do-params (inductive _ ff _ _) _ _ :- std.assert! fail "records and coinductives not supported". -do-params (record _ _ _ _) _ _ :- std.assert! fail "records and coinductives not supported". - -pred build-positive-match i:term, i:list indc-decl, o:term. -build-positive-match _ [] {{ unit }}. -build-positive-match X KL R :- - coq.build-match X {{ positive }} do-rty (do-branch KL) R. - -pred do-rty i:term, i:list term,i:list term, o:term. -do-rty _ _ _ {{ Type }}. % we leave a hole +% match p with ... n => TyKn.1 * TyKn.2 ... +pred kty->tuple i:inductive, i:list term, i:term, o:term. +kty->tuple I Params P R :- + coq.env.indt I _ _ _ _ _ KT, + std.map KT (coq.subst-prod Params) L, + splay-over-positive P L {{ fun _ => Type }} + {{ unit }} + prod->tuple + R. + +% match p with ... n => fun x => Kn x.1 x.2 ... +pred fun-tuple->kapp-proj i:inductive, i:list term, i:term, o:term. +fun-tuple->kapp-proj I Params P R :- + coq.env.indt I _ _ _ _ KS KT, + fields-for I C_t _, + coq.mk-app (global (const C_t)) Params Fields_t, + coq.mk-app (global (indt I)) Params Ind, + std.map KS (c\coq.mk-app (global (indc c)) Params) L1, + std.map KT (coq.subst-prod Params) L2, + std.zip L1 L2 L, + splay-over-positive P L {{ fun p => lp:Fields_t p -> option lp:Ind }} + {{ fun p => None }} + fun-tuple->kapp + R. + +pred fun-tuple->kapp i:(pair term term), o:term. +fun-tuple->kapp (pr K Ty) {{ fun p => lp:(R p) }} :- + @pi-decl `p` _ p\ tuple->kapp Ty K p (R p). + +pred tuple->kapp i:term, i:term, i:term, o:term. +tuple->kapp (prod N T F) K P R :- F = (x\prod _ _ _), !, % not the last one + @pi-decl N T x\ tuple->kapp (F x) {coq.mk-app K [{{ fst lp:P }}]} {{ snd lp:P }} R. +tuple->kapp (prod N T F) K P R :- + @pi-decl N T x\ tuple->kapp (F x) {coq.mk-app K [P]} {{ snd lp:P }} R. +tuple->kapp _ K _ {{ Some lp:K }}. + +% TODO: move in coq-lib.elpi +pred coq.bind-ind-parameters i:inductive, i:(term -> list term -> list term -> term -> prop), o:term. +coq.bind-ind-parameters I K O :- + coq.env.indt I _ _ N A _ _, + coq.bind-ind-parameters.aux N A [] [] K O. +coq.bind-ind-parameters.aux 0 Ty Vars Tys K O :- !, K Ty {std.rev Vars} {std.rev Tys} O. +coq.bind-ind-parameters.aux I (prod N T F) Vs Ts K (fun N T G) :- I > 0, !, J is I - 1, + @pi-decl N T x\ + coq.bind-ind-parameters.aux J (F x) [x|Vs] [T|Ts] K (G x). +coq.bind-ind-parameters.aux I (let N T B F) Vs Ts K (fun N T G) :- I > 0, !, J is I - 1, + @pi-def N T B x\ + coq.bind-ind-parameters.aux J (F x) [x|Vs] [T|Ts] K (G x). +coq.bind-ind-parameters.aux I T Vs Ts K O :- I > 0, whd1 T T', !, + coq.bind-ind-parameters.aux I T' Vs Ts K O. + +pred bind-positive i:(term -> term -> prop), o:term. +bind-positive K {{ fun p : positive => lp:(R p) }} :- + @pi-decl `p` {{ positive }} p\ K p (R p). + +pred splay-over-positive i:term, i:list A, i:term, i:term, i:(A -> term -> prop), o:term. +splay-over-positive X L DoRty Def DoBranch R :- + splay-over-positive.aux X (x\x) L DoRty DoBranch Def R. +pred splay-over-positive.aux i:term, i:(term -> term), i:list A, i:term, i:(A -> term -> prop), i:term, o:term. +splay-over-positive.aux _ _ [] _ _ Def Def. +splay-over-positive.aux X XCtx KL DoRty DoBranch Def R :- + coq.build-match X {{ positive }} (do-rty XCtx DoRty) (do-branch XCtx DoRty DoBranch Def KL) R. + +pred do-rty i:(term -> term), i:term, i:term, i:list term,i:list term, o:term. +do-rty Ctx DoRty _ Vs _ R :- P = Ctx {std.last Vs}, whd1 {{ lp:DoRty lp:P }} R. pred list-bitmask i:list A, o:list A, o:list A. list-bitmask [] [] []. list-bitmask [X] [X] []. list-bitmask [X,Y|L] [X|A] [Y|B] :- list-bitmask L A B. -pred do-branch i:list indc-decl, i:term, i:term, i:list term, i:list term, o:term. -do-branch [_|KS] {{ xO }} _ [P] _ R :- +pred do-branch i:(term -> term), i:term, i:(A -> term -> prop), i:term, i:list A, i:term, i:term, i:list term, i:list term, o:term. +do-branch PCtx DoRty DoBranch Def [_|KS] {{ xO }} _ [P] _ R :- list-bitmask KS KODD _, - build-positive-match P KODD R. -do-branch [_|KS] {{ xI }} _ [P] _ R :- + splay-over-positive.aux P (x\ PCtx {{ xO lp:x }}) KODD DoRty DoBranch Def R. +do-branch PCtx DoRty DoBranch Def [_|KS] {{ xI }} _ [P] _ R :- list-bitmask KS _ KEVEN, - build-positive-match P KEVEN R. -do-branch [constructor _ Arity|_] {{ xH }} _ _ _ R :- - prod->tuple {coq.arity->term Arity} R. + splay-over-positive.aux P (x\ PCtx {{ xI lp:x }}) KEVEN DoRty DoBranch Def R. +do-branch _ _ DoBranch _ [X|_] {{ xH }} _ _ _ R :- DoBranch X R. pred prod->tuple i:term, o:term. prod->tuple (prod N Ty F) {{ (lp:Ty1 * lp:X)%type }} :- (F = x\prod _ _ _), !, % not the last one @@ -69,8 +126,8 @@ prod->tuple (prod N Ty F) {{ (lp:Ty1 * lp:X)%type }} :- (F = x\prod _ _ _), !, % prod->tuple (prod _ Ty _) Ty1 :- copy Ty Ty1. prod->tuple _ {{ unit }}. % other branches -pred do-repack i:constant, i:constant, i:term, i:list term, i:list term, o:term. -do-repack C_t Tag _ Vars Tys R :- +pred repack-as-tuple i:constant, i:constant, i:term, i:list term, i:list term, o:term. +repack-as-tuple C_t Tag _ Vars Tys R :- std.appendR Params [X] Vars, std.last Tys XTy, coq.mk-app (global (const C_t)) Params C_tp, diff --git a/src/list_defs.v b/src/list_defs.v index a8d715d..bd40852 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -50,12 +50,12 @@ Definition fields := @list_fields A. (*(x : list A) : fields_t (tag x) := | a::l => (a, l) end.*) -Definition construct (t:positive) : fields_t t -> option (list A) := +Definition construct := @ list_construct A. (*(t:positive) : fields_t t -> option (list A) := match t with | 1 => fun _ => Some [::] | 2 => fun p => Some (p.1 :: p.2) | _ => fun _ => None - end. + end.*) Lemma constructP x : construct (fields x) = Some x. Proof. by case: x. Qed. diff --git a/src/option_defs.v b/src/option_defs.v index 1e89ad8..e51432c 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -48,12 +48,12 @@ Definition fields := @option_fields A. (* (x:option A) : fields_t (tag x) := | Some a => a end.*) -Definition construct (t:positive) : fields_t t -> option (option A) := +Definition construct := @option_construct A. (* (t:positive) : fields_t t -> option (option A) := match t with | 1 => fun a => Some (Some a) | 2 => fun _ => Some None | _ => fun _ => None - end. + end.*) Lemma constructP x : construct (fields x) = Some x. Proof. by case: x. Qed. From daf239265ad9b52c480a8f2349e6620fb3c17fa2 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 13 Oct 2021 15:25:47 +0200 Subject: [PATCH 09/40] cleanup --- src/fields.elpi | 43 ++++++++++++++++++------------------------- 1 file changed, 18 insertions(+), 25 deletions(-) diff --git a/src/fields.elpi b/src/fields.elpi index 0cee3d2..5f1265f 100644 --- a/src/fields.elpi +++ b/src/fields.elpi @@ -6,9 +6,7 @@ pred self o:term. pred main i:inductive, i:string, o:list prop. main I Prefix CL :- std.do! [ - coq.bind-ind-parameters I - (_\ params\ _\ bind-positive (kty->tuple I params)) - Body_t, + coq.bind-ind-parameters I (_\ params\ _\ kty->tuple I params) Body_t, std.assert-ok! (coq.typecheck Body_t Ty_t) "fields generates illtyped fields_t", @@ -28,9 +26,7 @@ main I Prefix CL :- std.do! [ std.forall CL (x\ coq.elpi.accumulate _ "fields.db" (clause _ _ x)), CL => - coq.bind-ind-parameters I - (_\ params\ _\ bind-positive (fun-tuple->kapp-proj I params)) - Body_c, + coq.bind-ind-parameters I (_\ params\ _\ fun-tuple->kapp-proj I params) Body_c, std.assert-ok! (coq.typecheck Body_c Ty_c) "fields generates illtyped construct", @@ -40,18 +36,19 @@ main I Prefix CL :- std.do! [ ]. % match p with ... n => TyKn.1 * TyKn.2 ... -pred kty->tuple i:inductive, i:list term, i:term, o:term. -kty->tuple I Params P R :- +pred kty->tuple i:inductive, i:list term, o:term. +kty->tuple I Params {{ fun p : positive => lp:(R p) }} :- coq.env.indt I _ _ _ _ _ KT, std.map KT (coq.subst-prod Params) L, - splay-over-positive P L {{ fun _ => Type }} - {{ unit }} - prod->tuple - R. + @pi-decl `p` {{ positive }} p\ + splay-over-positive p L {{ fun _ => Type }} + {{ unit }} + prod->tuple + (R p). % match p with ... n => fun x => Kn x.1 x.2 ... -pred fun-tuple->kapp-proj i:inductive, i:list term, i:term, o:term. -fun-tuple->kapp-proj I Params P R :- +pred fun-tuple->kapp-proj i:inductive, i:list term, o:term. +fun-tuple->kapp-proj I Params {{ fun p : positive => lp:(R p) }} :- coq.env.indt I _ _ _ _ KS KT, fields-for I C_t _, coq.mk-app (global (const C_t)) Params Fields_t, @@ -59,10 +56,11 @@ fun-tuple->kapp-proj I Params P R :- std.map KS (c\coq.mk-app (global (indc c)) Params) L1, std.map KT (coq.subst-prod Params) L2, std.zip L1 L2 L, - splay-over-positive P L {{ fun p => lp:Fields_t p -> option lp:Ind }} - {{ fun p => None }} - fun-tuple->kapp - R. + @pi-decl `p` {{ positive }} p\ + splay-over-positive p L {{ fun x => lp:Fields_t x -> option lp:Ind }} + {{ fun _ => None }} + fun-tuple->kapp + (R p). pred fun-tuple->kapp i:(pair term term), o:term. fun-tuple->kapp (pr K Ty) {{ fun p => lp:(R p) }} :- @@ -90,10 +88,6 @@ coq.bind-ind-parameters.aux I (let N T B F) Vs Ts K (fun N T G) :- I > 0, !, J i coq.bind-ind-parameters.aux I T Vs Ts K O :- I > 0, whd1 T T', !, coq.bind-ind-parameters.aux I T' Vs Ts K O. -pred bind-positive i:(term -> term -> prop), o:term. -bind-positive K {{ fun p : positive => lp:(R p) }} :- - @pi-decl `p` {{ positive }} p\ K p (R p). - pred splay-over-positive i:term, i:list A, i:term, i:term, i:(A -> term -> prop), o:term. splay-over-positive X L DoRty Def DoBranch R :- splay-over-positive.aux X (x\x) L DoRty DoBranch Def R. @@ -120,10 +114,9 @@ do-branch PCtx DoRty DoBranch Def [_|KS] {{ xI }} _ [P] _ R :- do-branch _ _ DoBranch _ [X|_] {{ xH }} _ _ _ R :- DoBranch X R. pred prod->tuple i:term, o:term. -prod->tuple (prod N Ty F) {{ (lp:Ty1 * lp:X)%type }} :- (F = x\prod _ _ _), !, % not the last one - copy Ty Ty1, +prod->tuple (prod N Ty F) {{ (lp:Ty * lp:X)%type }} :- (F = x\prod _ _ _), !, % not the last one @pi-decl N Ty x\ prod->tuple (F x) X. -prod->tuple (prod _ Ty _) Ty1 :- copy Ty Ty1. +prod->tuple (prod _ Ty _) Ty. prod->tuple _ {{ unit }}. % other branches pred repack-as-tuple i:constant, i:constant, i:term, i:list term, i:list term, o:term. From 9d0b4cff0a8679dcee2c58f757c7f32b2b5c8f97 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 14 Oct 2021 11:16:35 +0200 Subject: [PATCH 10/40] constructP --- src/fields.elpi | 87 +++++++++++++++++++++++++++-------------------- src/fields.v | 11 ++++-- src/list_defs.v | 4 +-- src/option_defs.v | 4 +-- 4 files changed, 62 insertions(+), 44 deletions(-) diff --git a/src/fields.elpi b/src/fields.elpi index 5f1265f..9480a95 100644 --- a/src/fields.elpi +++ b/src/fields.elpi @@ -6,34 +6,51 @@ pred self o:term. pred main i:inductive, i:string, o:list prop. main I Prefix CL :- std.do! [ + std.assert! (tag-for I Tag) "no tag for this inductive, run that derivation first", + coq.bind-ind-parameters I (_\ params\ _\ kty->tuple I params) Body_t, - std.assert-ok! (coq.typecheck Body_t Ty_t) "fields generates illtyped fields_t", - Name_t is Prefix ^ "fields_t", - coq.env.add-const Name_t Body_t Ty_t ff C_t, + coq.env.add-const Name_t Body_t Ty_t ff Fields_t, coq.env.indt I _ _ _ Arity _ _, - std.assert! (tag-for I Tag) "no tag for this inductive", - coq.bind-ind-arity (global (indt I)) Arity (repack-as-tuple C_t Tag) Body, - + coq.bind-ind-arity (global (indt I)) Arity (repack-as-tuple Fields_t Tag) Body, std.assert-ok! (coq.typecheck Body Ty) "fields generates illtyped fields", - Name is Prefix ^ "fields", - coq.env.add-const Name Body Ty ff C, + coq.env.add-const Name Body Ty ff Fields, - CL = [fields-for I C_t C], + coq.bind-ind-parameters I (_\ params\ _\ fun-tuple->kapp-proj Fields_t I params) Body_c, + std.assert-ok! (coq.typecheck Body_c Ty_c) "fields generates illtyped construct", + Name_c is Prefix ^ "construct", + coq.env.add-const Name_c Body_c Ty_c ff Construct, + + coq.bind-ind-arity (global (indt I)) Arity (case-refl Fields Construct) Body_P, + std.assert-ok! (coq.typecheck Body_P Ty_P) "fields generates illtyped constructP", + Name_P is Prefix ^ "constructP", + coq.env.add-const Name_P Body_P Ty_P @opaque! ConstructP, + + CL = [fields-for I Fields_t Fields Construct ConstructP], std.forall CL (x\ coq.elpi.accumulate _ "fields.db" (clause _ _ x)), - CL => - coq.bind-ind-parameters I (_\ params\ _\ fun-tuple->kapp-proj I params) Body_c, +]. - std.assert-ok! (coq.typecheck Body_c Ty_c) "fields generates illtyped construct", +% match x return construct (fields x) = Some x with _ => erefl +pred case-refl i:constant, i:constant, i:term, i:list term, i:list term, o:term. +case-refl Fields Construct _ ParamsX Tys R :- + std.appendR Params [X] ParamsX, + coq.mk-app (global (const Fields)) Params FP, + coq.mk-app (global (const Construct)) Params CP, + coq.build-match X {std.last Tys} + (case-refl-rty FP CP) + case-refl-branch + R. - Name_c is Prefix ^ "construct", - coq.env.add-const Name_c Body_c Ty_c ff _, +pred case-refl-rty i:term, i:term, i:term, i:list term,i:list term, o:term. +case-refl-rty Fields Construct _ Vs _ {{ lp:Construct _ (lp:Fields lp:X) = Some lp:X }} :- + std.last Vs X. -]. +pred case-refl-branch i:term, i:term, i:list term,i:list term, o:term. +case-refl-branch _ _ _ _ {{ refl_equal }}. % match p with ... n => TyKn.1 * TyKn.2 ... pred kty->tuple i:inductive, i:list term, o:term. @@ -47,10 +64,9 @@ kty->tuple I Params {{ fun p : positive => lp:(R p) }} :- (R p). % match p with ... n => fun x => Kn x.1 x.2 ... -pred fun-tuple->kapp-proj i:inductive, i:list term, o:term. -fun-tuple->kapp-proj I Params {{ fun p : positive => lp:(R p) }} :- +pred fun-tuple->kapp-proj i:constant, i:inductive, i:list term, o:term. +fun-tuple->kapp-proj C_t I Params {{ fun p : positive => lp:(R p) }} :- coq.env.indt I _ _ _ _ KS KT, - fields-for I C_t _, coq.mk-app (global (const C_t)) Params Fields_t, coq.mk-app (global (indt I)) Params Ind, std.map KS (c\coq.mk-app (global (indc c)) Params) L1, @@ -73,21 +89,6 @@ tuple->kapp (prod N T F) K P R :- @pi-decl N T x\ tuple->kapp (F x) {coq.mk-app K [P]} {{ snd lp:P }} R. tuple->kapp _ K _ {{ Some lp:K }}. -% TODO: move in coq-lib.elpi -pred coq.bind-ind-parameters i:inductive, i:(term -> list term -> list term -> term -> prop), o:term. -coq.bind-ind-parameters I K O :- - coq.env.indt I _ _ N A _ _, - coq.bind-ind-parameters.aux N A [] [] K O. -coq.bind-ind-parameters.aux 0 Ty Vars Tys K O :- !, K Ty {std.rev Vars} {std.rev Tys} O. -coq.bind-ind-parameters.aux I (prod N T F) Vs Ts K (fun N T G) :- I > 0, !, J is I - 1, - @pi-decl N T x\ - coq.bind-ind-parameters.aux J (F x) [x|Vs] [T|Ts] K (G x). -coq.bind-ind-parameters.aux I (let N T B F) Vs Ts K (fun N T G) :- I > 0, !, J is I - 1, - @pi-def N T B x\ - coq.bind-ind-parameters.aux J (F x) [x|Vs] [T|Ts] K (G x). -coq.bind-ind-parameters.aux I T Vs Ts K O :- I > 0, whd1 T T', !, - coq.bind-ind-parameters.aux I T' Vs Ts K O. - pred splay-over-positive i:term, i:list A, i:term, i:term, i:(A -> term -> prop), o:term. splay-over-positive X L DoRty Def DoBranch R :- splay-over-positive.aux X (x\x) L DoRty DoBranch Def R. @@ -128,10 +129,7 @@ repack-as-tuple C_t Tag _ Vars Tys R :- coq.build-match X XTy (do-rty_t C_tp Tagp) args->tuple R. pred do-rty_t i:term, i:term, i:term, i:list term,i:list term, o:term. -do-rty_t C_t Tag _ Vars _ R :- - std.last Vars X, - coq.mk-app Tag [X] TagX, - coq.mk-app C_t [TagX] R. +do-rty_t C_t Tag _ Vars _ {{ lp:C_t (lp:Tag lp:X) }} :- std.last Vars X. pred args->tuple i:term, i:term, i:list term, i:list term, o:term. args->tuple _ _ [] _ {{ tt }}. @@ -139,4 +137,19 @@ args->tuple _ _ [X] _ X. args->tuple A B [X|XS] C {{ ( lp:X , lp:R ) }} :- args->tuple A B XS C R. +% TODO: move in coq-lib.elpi +pred coq.bind-ind-parameters i:inductive, i:(term -> list term -> list term -> term -> prop), o:term. +coq.bind-ind-parameters I K O :- + coq.env.indt I _ _ N A _ _, + coq.bind-ind-parameters.aux N A [] [] K O. +coq.bind-ind-parameters.aux 0 Ty Vars Tys K O :- !, K Ty {std.rev Vars} {std.rev Tys} O. +coq.bind-ind-parameters.aux I (prod N T F) Vs Ts K (fun N T G) :- I > 0, !, J is I - 1, + @pi-decl N T x\ + coq.bind-ind-parameters.aux J (F x) [x|Vs] [T|Ts] K (G x). +coq.bind-ind-parameters.aux I (let N T B F) Vs Ts K (fun N T G) :- I > 0, !, J is I - 1, + @pi-def N T B x\ + coq.bind-ind-parameters.aux J (F x) [x|Vs] [T|Ts] K (G x). +coq.bind-ind-parameters.aux I T Vs Ts K O :- I > 0, whd1 T T', !, + coq.bind-ind-parameters.aux I T' Vs Ts K O. + } \ No newline at end of file diff --git a/src/fields.v b/src/fields.v index 858b33b..2a04a61 100644 --- a/src/fields.v +++ b/src/fields.v @@ -5,9 +5,14 @@ Open Scope positive_scope. Elpi Db fields.db lp:{{ -% this is how one registers the fields_t and fields constants to an inductive -% and let other elpi commands use that piece of info -pred fields-for o:inductive, o:constant, o:constant. +% this is how one registers the fields_t, fields and construct[P] +% constants to an inductive and let other elpi commands use that piece of info +pred fields-for + o:inductive, + o:constant, % fields_t + o:constant, % fields + o:constant, % construct + o:constant. % constructP }}. diff --git a/src/list_defs.v b/src/list_defs.v index bd40852..e307f74 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -57,8 +57,8 @@ Definition construct := @ list_construct A. (*(t:positive) : fields_t t -> optio | _ => fun _ => None end.*) -Lemma constructP x : construct (fields x) = Some x. -Proof. by case: x. Qed. +Definition constructP := @list_constructP A. (*x : construct (fields x) = Some x. +Proof. by case: x. Qed.*) End Section. End AUX. diff --git a/src/option_defs.v b/src/option_defs.v index e51432c..5bb24e3 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -55,8 +55,8 @@ Definition construct := @option_construct A. (* (t:positive) : fields_t t -> opt | _ => fun _ => None end.*) -Lemma constructP x : construct (fields x) = Some x. -Proof. by case: x. Qed. +Definition constructP := @option_constructP A. (*x : construct (fields x) = Some x. +Proof. by case: x. Qed.*) End Section. End AUX. From eed194bd66bc9d3f00ad8545852eda061450f456 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 14 Oct 2021 13:42:11 +0200 Subject: [PATCH 11/40] scaffoldings for eqb, no code yet --- Makefile.coq.local | 3 ++- _CoqProject | 3 ++- src/eqb.elpi | 7 +++++++ src/eqb.v | 27 +++++++++++++++++++++++++++ src/list_defs.v | 4 +++- src/option_defs.v | 4 +++- 6 files changed, 44 insertions(+), 4 deletions(-) create mode 100644 src/eqb.elpi create mode 100644 src/eqb.v diff --git a/Makefile.coq.local b/Makefile.coq.local index 8abcff7..3c2916f 100644 --- a/Makefile.coq.local +++ b/Makefile.coq.local @@ -1,2 +1,3 @@ src/tag.vo : src/tag.elpi -src/fields.vo : src/fields.elpi \ No newline at end of file +src/fields.vo : src/fields.elpi +src/eqb.vo : src/eqb.elpi \ No newline at end of file diff --git a/_CoqProject b/_CoqProject index 27083da..2ced6c4 100644 --- a/_CoqProject +++ b/_CoqProject @@ -19,4 +19,5 @@ src/nested_defs.v src/nested_list_defs.v src/large_defs.v src/tag.v -src/fields.v \ No newline at end of file +src/fields.v +src/eqb.v \ No newline at end of file diff --git a/src/eqb.elpi b/src/eqb.elpi new file mode 100644 index 0000000..d277e1e --- /dev/null +++ b/src/eqb.elpi @@ -0,0 +1,7 @@ +namespace eqb { + +pred main i:inductive, i:string, o:list prop. +main U Prefix CL :- + true. + +} \ No newline at end of file diff --git a/src/eqb.v b/src/eqb.v new file mode 100644 index 0000000..3c1a149 --- /dev/null +++ b/src/eqb.v @@ -0,0 +1,27 @@ +From elpi Require Import elpi. +From Coq Require Import PArith. +Require Export tag fields. +Open Scope positive_scope. + +Elpi Db eqb.db lp:{{ + +pred eqb-for + o:inductive, + o:constant. % eqb + +}}. + +Elpi Command eqb. +Elpi Accumulate File "src/eqb.elpi". +Elpi Accumulate Db tag.db. +Elpi Accumulate Db fields.db. +Elpi Accumulate Db eqb.db. +Elpi Accumulate lp:{{ + + main [str S] :- + std.assert! (coq.locate S (indt I)) "Not an inductive type", + Prefix is S ^ "_", + eqb.main I Prefix _. + +}}. +Elpi Typecheck. diff --git a/src/list_defs.v b/src/list_defs.v index e307f74..19035ce 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -1,7 +1,7 @@ Require Import Eqdep_dec. From mathcomp Require Import all_ssreflect. -Require Import core_defs tag fields. +Require Import core_defs tag fields eqb. Set Implicit Arguments. Unset Strict Implicit. @@ -77,6 +77,8 @@ Section Fields. Context (eqb : list A -> list A -> bool). +Elpi eqb list. + Definition eqb_fields (t:positive) : fields_t t -> fields_t t -> bool := match t return fields_t t -> fields_t t -> bool with | 1 => eq_op diff --git a/src/option_defs.v b/src/option_defs.v index 5bb24e3..2bb5302 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -1,7 +1,7 @@ Require Import Eqdep_dec. From mathcomp Require Import all_ssreflect. -Require Import core_defs tag fields. +Require Import core_defs tag fields eqb. Set Implicit Arguments. Unset Strict Implicit. @@ -71,6 +71,8 @@ Section Section. Context (A:Type) (Aeqb : A -> A -> bool). +Elpi eqb option. + Definition eqb_fields (t:positive) : fields_t t -> fields_t t -> bool := match t return fields_t t -> fields_t t -> bool with | 1 => Aeqb From c9baecc2f0560adeb74dd4983c9e3fb0520d15c2 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 3 Dec 2021 22:06:22 +0100 Subject: [PATCH 12/40] cleanup --- Makefile.coq.local | 2 +- src/core_defs.v | 23 ++++-- src/eqb.elpi | 49 ++++++++++++- src/eqb.v | 6 +- src/list_defs.v | 175 ++++++++++++++++++--------------------------- src/option_defs.v | 48 ++----------- 6 files changed, 142 insertions(+), 161 deletions(-) diff --git a/Makefile.coq.local b/Makefile.coq.local index 3c2916f..4fd4d73 100644 --- a/Makefile.coq.local +++ b/Makefile.coq.local @@ -1,3 +1,3 @@ src/tag.vo : src/tag.elpi src/fields.vo : src/fields.elpi -src/eqb.vo : src/eqb.elpi \ No newline at end of file +src/eqb.vo : src/eqb.elpi src/fields.elpi \ No newline at end of file diff --git a/src/core_defs.v b/src/core_defs.v index 4d64207..d472f8f 100644 --- a/src/core_defs.v +++ b/src/core_defs.v @@ -16,17 +16,26 @@ Definition eqb_correct_on (eqb : A -> A -> bool) (a1:A) := Definition eqb_refl_on (eqb : A -> A -> bool) (a:A) := eqb a a. +Definition eqb_correct (eqb : A -> A -> bool) := + forall (a1:A) a2, eqb a1 a2 -> a1 = a2. + +Definition eqb_reflexive (eqb : A -> A -> bool) := forall (a:A), + eqb a a. + +Lemma iffP2 (f : A -> A -> bool) (H1 : eqb_correct f) (H2 : eqb_reflexive f) + (x1 x2 : A) : reflect (x1 = x2) (f x1 x2). +Proof. apply (iffP idP);[ apply H1 | move->; apply H2 ]. Qed. + Definition eqax_on (eqb : A -> A -> bool) (a1:A) := forall a2, reflect (a1 = a2) (eqb a1 a2). -Class obj := - { tag : A -> positive - ; fields_t : positive -> Type - ; fields : forall a, fields_t (tag a) - ; construct : forall t, fields_t t -> option A - ; constructP : forall a, construct (fields a) = Some a }. +Variable tag : A -> positive. +Variable fields_t : positive -> Type. +Variable fields : forall a, fields_t (tag a). +Variable construct : forall t, fields_t t -> option A. +Variable constructP : forall a, construct (fields a) = Some a. -Context {o:obj} (eqb_fields : forall t, fields_t t -> fields_t t -> bool). +Variable eqb_fields : forall t, fields_t t -> fields_t t -> bool. Definition eqb_body (t1:positive) (f1:fields_t t1) (x2:A) := let t2 := tag x2 in diff --git a/src/eqb.elpi b/src/eqb.elpi index d277e1e..263eb46 100644 --- a/src/eqb.elpi +++ b/src/eqb.elpi @@ -1,7 +1,52 @@ namespace eqb { pred main i:inductive, i:string, o:list prop. -main U Prefix CL :- - true. +main I Prefix CL :- std.do! [ + coq.env.indt I _ _ N Arity _ _, + do-params N Arity (global (indt I)) R, + coq.say {coq.term->string R}, + std.assert-ok! (coq.typecheck R Rty) "eqb generates illtyped term", + Name is Prefix ^ "eqb_fields", + coq.env.add-const Name R Rty ff C, + + + CL = [eqb-for _ (global (const C))], % TODO, quantify params +]. + +pred do-params i:int, i:term, i:term, o:term. +do-params J (prod _ T F) I {{ fun (p : lp:T) (eqp : p -> p -> bool) => lp:(R p eqp) }} :- J > 0, !, K is J - 1, + @pi-decl `P` T p\ + @pi-decl `eqP` {{ lp:p -> lp:p -> bool }} eqP\ + eqb-for p eqP => + do-params K (F p) {coq.mk-app I [p]} (R p eqP). +do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => lp:(R rec x) }} :- + coq.safe-dest-app Ind (global (indt I)) Params, + coq.env.indt I _ _ _ _ _ KT, + std.map KT (coq.subst-prod Params) L, + fields-for I F_t _ _ _, + coq.mk-app (global (const F_t)) Params Fields_t, + @pi-decl `rec` {{ lp:Ind -> lp:Ind -> bool }} rec\ + @pi-decl `x` {{ positive }} x\ + eqb-for Ind rec => + fields.splay-over-positive x L {{ fun x => lp:Fields_t x -> lp:Fields_t x -> bool }} + {{ fun _ _ => true }} + do-fields + (R rec x). +pred do-fields i:term, o:term. +do-fields Ty {{ fun a b => lp:(R a b) }} :- + @pi-decl `x` _ x\ + @pi-decl `y` _ y\ + do-fields.aux Ty x y (R x y). + +do-fields.aux (prod N T F) P1 P2 {{ lp:X && lp:R }} :- F = (x\prod _ _ _), !, % not the last one + eqb-for T EQB, + coq.mk-app EQB [{{ fst lp:P1 }}, {{ fst lp:P2 }}] X, + do-fields.aux (F {{ unit }}) {{ snd lp:P1 }} {{ snd lp:P2 }} R. + +do-fields.aux (prod N T _) P1 P2 X :- + eqb-for T EQB, + coq.mk-app EQB [P1, P2] X. + +do-fields.aux _ _ _ {{ true }}. } \ No newline at end of file diff --git a/src/eqb.v b/src/eqb.v index 3c1a149..90fd3b1 100644 --- a/src/eqb.v +++ b/src/eqb.v @@ -2,16 +2,18 @@ From elpi Require Import elpi. From Coq Require Import PArith. Require Export tag fields. Open Scope positive_scope. +Open Scope bool_scope. Elpi Db eqb.db lp:{{ pred eqb-for - o:inductive, - o:constant. % eqb + o:term, + o:term. % eqb }}. Elpi Command eqb. +Elpi Accumulate File "src/fields.elpi". Elpi Accumulate File "src/eqb.elpi". Elpi Accumulate Db tag.db. Elpi Accumulate Db fields.db. diff --git a/src/list_defs.v b/src/list_defs.v index 19035ce..4f5f41c 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -9,143 +9,104 @@ Unset Printing Implicit Defensive. Require Import PArith. Open Scope positive_scope. -Section Ind. - - Context (A : Type) (PA : A -> Prop) (P : list A -> Prop). - Context (A_ind : forall a, PA a) (Hnil : P [::]) (Hcons : forall a l, PA a -> P l -> P (a::l)). - - Fixpoint list_Ind (l : list A) : P l := - match l with - | [::] => Hnil - | a :: l => Hcons (A_ind a) (list_Ind l) - end. - -End Ind. - -Module AUX. - -Section Section. -Context {A : Type}. - Elpi tag list. -Definition tag {A} := @list_tag A. (* -Definition tag (x : list A) := - match x with - | [::] => 1 - | _ :: _ => 2 - end. -*) +Definition tag {A} := @list_tag A. Elpi fields list. -Definition fields_t := @list_fields_t A. (*(t : positive) : Type := - match t with - | 2 => (A * list A)%type - | _ => unit - end. -*) - -Definition fields := @list_fields A. (*(x : list A) : fields_t (tag x) := - match x return fields_t (tag x) with - | [::] => tt - | a::l => (a, l) - end.*) - -Definition construct := @ list_construct A. (*(t:positive) : fields_t t -> option (list A) := - match t with - | 1 => fun _ => Some [::] - | 2 => fun p => Some (p.1 :: p.2) - | _ => fun _ => None - end.*) - -Definition constructP := @list_constructP A. (*x : construct (fields x) = Some x. -Proof. by case: x. Qed.*) - -End Section. End AUX. +Definition fields_t {A} := @list_fields_t A. -Local Instance list_obj (A:Type) : @obj (list A) := - {| tag := AUX.tag - ; fields_t := AUX.fields_t - ; fields := AUX.fields - ; construct := AUX.construct - ; constructP := AUX.constructP |}. +Definition fields {A} := @list_fields A. -Section Section. +Definition construct {A} := @ list_construct A. -Context (A:Type) (Aeqb : A -> A -> bool). - -Section Fields. - -Context (eqb : list A -> list A -> bool). +Definition constructP {A} := @list_constructP A. Elpi eqb list. +Print list_eqb_fields. -Definition eqb_fields (t:positive) : fields_t t -> fields_t t -> bool := - match t return fields_t t -> fields_t t -> bool with - | 1 => eq_op - | 2 => fun p1 p2 => Aeqb p1.1 p2.1 && eqb p1.2 p2.2 - | _ => eq_op - end. - -End Fields. +Definition eqb_fields := list_eqb_fields. -Fixpoint eqb (x1 x2 : list A) := +About eqb_body. +Definition list_eqb A (eqA : A -> A -> bool) := fix eqb (x1 x2 : list A) := match x1 with - | [::] => eqb_body (eqb_fields eqb) (t1:=1) tt x2 - | a::l => eqb_body (eqb_fields eqb) (t1:=2) (a,l) x2 + | [::] => @eqb_body (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_eqb_fields A eqA eqb) (@list_tag A [::]) tt x2 + | a::l => @eqb_body (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_eqb_fields A eqA eqb) (@list_tag A (a::l)) (a,l) x2 end. -Lemma eqb_correct_on_nil : eqb_correct_on eqb nil. +Ltac eqb_correct_on__solver := + by repeat (try case/andP; match goal with H : eqb_correct_on _ _ |- _ => move=> /=/H-> end). + + +Lemma eqb_correct_on_nil A (eqA : A -> A -> bool) : eqb_correct_on (list_eqb eqA) nil. Proof. - rewrite /eqb_correct_on /eqb. - by apply (@eqb_body_correct _ (list_obj A) (eqb_fields eqb) [::]). + refine ( + @eqb_body_correct (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_construct A) (@list_constructP A) + (@list_eqb_fields A eqA (@list_eqb A eqA)) + [::] _). + eqb_correct_on__solver. Qed. -Lemma eqb_correct_on_cons a l: - eqb_correct_on Aeqb a -> - eqb_correct_on eqb l -> - eqb_correct_on eqb (a :: l). +Lemma eqb_correct_on_cons A (eqA : A -> A -> bool): + forall a, eqb_correct_on eqA a -> + forall l, eqb_correct_on (list_eqb eqA) l -> + eqb_correct_on (list_eqb eqA) (a :: l). Proof. - rewrite /eqb_correct_on => ha hl. - apply (@eqb_body_correct _ (list_obj A) (eqb_fields eqb) (a :: l)). - by move=> a2 /andP[] /= /ha -> /hl ->. + refine (fun a P1 l P2 => + @eqb_body_correct (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_construct A) (@list_constructP A) + (@list_eqb_fields A eqA (@list_eqb A eqA)) + (a::l) (fun f => _)). + eqb_correct_on__solver. Qed. -Lemma eqb_refl_on_nil : eqb_refl_on eqb [::]. -Proof. done. Qed. -Lemma eqb_refl_on_cons a l: - eqb_refl_on Aeqb a -> - eqb_refl_on eqb l -> - eqb_refl_on eqb (a :: l). -Proof. - rewrite /eqb_refl_on=> ha hl. - apply (@eqb_body_refl _ (list_obj A) (eqb_fields eqb) (a :: l)). - by rewrite /eqb_fields_refl_on /= ha hl. +Ltac eqb_refl_on__solver := + rewrite /eqb_fields_refl_on /=; + repeat + (reflexivity || apply/andP; split; assumption). + +Lemma eqb_refl_on_nil A (eqA : A -> A -> bool) : eqb_refl_on (list_eqb eqA) [::]. +Proof. + refine ( + (@eqb_body_refl _ _ _ _ (@list_eqb_fields A eqA (list_eqb eqA)) [::]) _). + eqb_refl_on__solver. Qed. -End Section. +Lemma eqb_refl_on_cons A (eqA : A -> A -> bool): + forall a, eqb_refl_on eqA a -> + forall l, eqb_refl_on (list_eqb eqA) l -> + eqb_refl_on (list_eqb eqA) (a :: l). +Proof. + refine (fun a ha l hl => + (@eqb_body_refl _ _ _ _ (@list_eqb_fields A eqA (list_eqb eqA)) (a :: l)) _). + eqb_refl_on__solver. +Qed. -Section EqType. -Context (A:eqType). +From elpi.apps Require Import derive. +#[only(induction,param1_full,param1_trivial)] derive list. -Lemma eqb_correct (x:list A) : eqb_correct_on (eqb eq_op) x. +Lemma list_eqb_correct (A:Type) (eqA: A -> A -> bool) (eqAc : eqb_correct eqA) + (x:list A) : eqb_correct_on (list_eqb eqA) x. Proof. - elim: x => [ | a l hrec]. - + by apply eqb_correct_on_nil. - by apply eqb_correct_on_cons => // a'; apply /eqP. + refine (@list_induction _ _ _ + (@eqb_correct_on_nil A eqA) + (@eqb_correct_on_cons A eqA) + x (@list_is_list_full _ _ eqAc x)). Qed. -Lemma eqb_refl (x:list A) : eqb_refl_on (eqb eq_op) x. +Lemma list_eqb_refl (A:Type) (eqA: A -> A -> bool) (eqAr : @eqb_reflexive A eqA) + (x:list A) : eqb_refl_on (list_eqb eqA) x. Proof. - elim x => [ | a l hrec]. - + by apply eqb_refl_on_nil. - apply eqb_refl_on_cons => //; apply /eqxx. + refine (@list_induction _ _ _ + (@eqb_refl_on_nil A eqA) + (@eqb_refl_on_cons A eqA) + x (@list_is_list_full _ _ eqAr x)). Qed. -Lemma eqbP (x1 x2 : list A) : reflect (x1 = x2) (eqb eq_op x1 x2). -Proof. apply (iffP idP);[ apply eqb_correct | move=> ->; apply eqb_refl]. Qed. - -End EqType. +Lemma list_eqbP (A:Type) (eqA: A -> A -> bool) + (eqAc : eqb_correct eqA) + (eqAr : eqb_reflexive eqA) +: forall (x1 x2 : list A), reflect (x1 = x2) (list_eqb eqA x1 x2). +Proof. refine (iffP2 (list_eqb_correct eqAc) (list_eqb_refl eqAr)). Qed. diff --git a/src/option_defs.v b/src/option_defs.v index 2bb5302..576290d 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -22,56 +22,20 @@ Section Ind. End Ind. -Module AUX. - -Section Section. -Context {A : Type}. - Elpi tag option. -Definition tag {A} := @option_tag A. (*(x : option A) := - match x with - | None => 1 - | Some _ => 2 - end. -*) +Definition tag {A} := @option_tag A. Elpi fields option. -Definition fields_t := @option_fields_t A. (*(t:positive) : Type := - match t with - | 1 => A - | _ => unit - end.*) - -Definition fields := @option_fields A. (* (x:option A) : fields_t (tag x) := - match x return fields_t (tag x) with - | None => tt - | Some a => a - end.*) - -Definition construct := @option_construct A. (* (t:positive) : fields_t t -> option (option A) := - match t with - | 1 => fun a => Some (Some a) - | 2 => fun _ => Some None - | _ => fun _ => None - end.*) - -Definition constructP := @option_constructP A. (*x : construct (fields x) = Some x. -Proof. by case: x. Qed.*) - -End Section. End AUX. +Definition fields_t {A} := @option_fields_t A. -Local Instance option_obj (A:Type) : @obj (option A) := - {| tag := AUX.tag - ; fields_t := AUX.fields_t - ; fields := AUX.fields - ; construct := AUX.construct - ; constructP := AUX.constructP |}. +Definition fields {A} := @option_fields A. -Section Section. +Definition construct {A} := @option_construct A. -Context (A:Type) (Aeqb : A -> A -> bool). +Definition constructP {A} := @option_constructP A. Elpi eqb option. +Print option_eqb_fields. Definition eqb_fields (t:positive) : fields_t t -> fields_t t -> bool := match t return fields_t t -> fields_t t -> bool with From 7f2b8160987897fab5e1d7233a0dd439b00da1df Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 6 Dec 2021 12:24:03 +0100 Subject: [PATCH 13/40] ale --- src/elpi-ltac.elpi | 111 +++++++++++++++++++++++++++++++++++++++++++++ src/eqb.elpi | 10 ++-- src/eqb.v | 4 +- src/list_defs.v | 92 ++++++++++++++++++++++++++++++++++++- 4 files changed, 210 insertions(+), 7 deletions(-) create mode 100644 src/elpi-ltac.elpi diff --git a/src/elpi-ltac.elpi b/src/elpi-ltac.elpi new file mode 100644 index 0000000..8ff9564 --- /dev/null +++ b/src/elpi-ltac.elpi @@ -0,0 +1,111 @@ +/* elpi-ltac: building blocks for tactics */ +/* license: GNU Lesser General Public License Version 2.1 or later */ +/* ------------------------------------------------------------------------- */ +typeabbrev tactic (sealed-goal -> (list sealed-goal -> prop)). +typeabbrev open-tactic (goal -> (list sealed-goal -> prop)). + +% The one tactic ------------------------------------------------------------ +pred refine i:term, i:goal, o:list sealed-goal. +refine T G GS :- refine.elaborate T G GS. + +pred refine.elaborate i:term, i:goal, o:list sealed-goal. +refine.elaborate T (goal _ RawEv _ Ev _) GS :- + RawEv = T, coq.ltac.collect-goals Ev GS _. + +pred refine.typecheck i:term, i:goal, o:list sealed-goal. +refine.typecheck T (goal _ _ Ty Ev _) GS :- + coq.typecheck T Ty ok, + Ev = T, coq.ltac.collect-goals Ev GS _. + +pred refine.no_check i:term, i:goal, o:list sealed-goal. +refine.no_check T (goal _ _ _ Ev _) GS :- + Ev = T, coq.ltac.collect-goals Ev GS _. + +% calling other tactics, with arguments --------------------------------------- + +pred coq.ltac i:string, i:sealed-goal, o:list sealed-goal. +coq.ltac Tac G GS :- coq.ltac.open (coq.ltac.call-ltac1 Tac) G GS. + +namespace coq.ltac { + +pred call i:string, i:list argument, i:goal, o:list sealed-goal. +call Tac Args G GS :- + set-goal-arguments Args G (seal G) (seal G1), + coq.ltac.call-ltac1 Tac G1 GS. + +pred set-goal-arguments i:list argument, i:goal, i:sealed-goal, o:sealed-goal. +set-goal-arguments A G (nabla SG) (nabla R) :- pi x\ set-goal-arguments A G (SG x) (R x). +set-goal-arguments A (goal Ctx1 _ _ _ _) (seal (goal Ctx2 REv2 Ty2 Ev2 _)) (seal (goal Ctx2 REv2 Ty2 Ev2 I)) :- + std.map A (private.move-goal-argument Ctx1 Ctx2) I. + +% Tacticals ---------------------------------------------------------------- + +pred try i:tactic, i:sealed-goal, o:list sealed-goal. +try T G GS :- T G GS. +try _ G [G]. + +:index(_ 1) +pred all i:tactic, i:list sealed-goal, o:list sealed-goal. +all T [G|Gs] O :- T G O1, all T Gs O2, std.append O1 O2 O. +all _ [] []. + +pred thenl i:list tactic, i:sealed-goal, o:list sealed-goal. +thenl [] G [G]. +thenl [T|Ts] G GS :- T G NG, all (thenl Ts) NG GS. + +pred repeat i:tactic, i:sealed-goal, o:list sealed-goal. +repeat T G GS :- T G GS1, all (repeat T) GS1 GS. +repeat _ G [G]. + +pred repeat! i:tactic, i:sealed-goal, o:list sealed-goal. +repeat! T G GS :- T G GS1, !, all (repeat T) GS1 GS. +repeat! _ G [G]. + +pred or i:list tactic, i:sealed-goal, o:list sealed-goal. +or TL G GS :- std.exists TL (t\ t G GS). + +:index(_ 1) +pred open i:open-tactic, i:sealed-goal, o:list sealed-goal. +open T (nabla G) O :- (pi x\ open T (G x) (NG x)), private.distribute-nabla NG O. +open _ (seal (goal _ _ _ Solution _)) [] :- not (var Solution), !. % solved by side effect +open T (seal (goal Ctx _ _ _ _ as G)) O :- + std.filter Ctx private.not-already-assumed Ctx1, + Ctx1 => T G O, + if (var O) + (G = goal _ _ _ P _, coq.ltac.collect-goals P O1 O2, std.append O1 O2 O) + true. + +% helper code --------------------------------------------------------------- + +namespace private { + +:index(_ _ 1) +pred move-goal-argument i:list prop, i:list prop, i:argument, o:argument. +move-goal-argument _ _ (int _ as A) A. +move-goal-argument _ _ (str _ as A) A. +move-goal-argument C D (trm T) (trm T1) :- + std.rev C Cr, std.rev D Dr, + std.assert! (move-term Cr Dr T T1) "cannot move goal argument to the right context", !. + +:index(2) +pred move-term i:list prop, i:list prop, i:term, o:term. +move-term [] _ T T1 :- copy T T1. +move-term [decl X _ TX|C1] [decl Y _ TY|C2] T T1 :- std.do! [ copy TX TX1, same_term TX1 TY ], !, + copy X Y => move-term C1 C2 T T1. +move-term [def X _ TX BX|C1] [def Y _ TY BY|C2] T T1 :- std.do! [ copy TX TX1, same_term TX1 TY, copy BX BX1, same_term BX1 BY ], !, + copy X Y => move-term C1 C2 T T1. +move-term [decl X _ _|C1] C2 T T1 :- not(occurs X T), !, move-term C1 C2 T T1. +move-term [def X _ _ _|C1] C2 T T1 :- not(occurs X T), !, move-term C1 C2 T T1. +move-term C1 [_|C2] T T1 :- move-term C1 C2 T T1. + +pred distribute-nabla i:(term -> list sealed-goal), o:list sealed-goal. +distribute-nabla (_\ []) []. +distribute-nabla (x\ [X x| XS x]) [nabla X|R] :- (pi x\ occurs x (X x)), !, + distribute-nabla XS R. +distribute-nabla (x\ [X| XS x]) [X|R] :- distribute-nabla XS R. + +pred not-already-assumed i:prop. +not-already-assumed (decl X _ _Ty) :- not(decl X _ _ ; def X _ _ _). +not-already-assumed (def X _ _Ty _Bo) :- not(decl X _ _ ; def X _ _ _). + +}} \ No newline at end of file diff --git a/src/eqb.elpi b/src/eqb.elpi index 263eb46..b038839 100644 --- a/src/eqb.elpi +++ b/src/eqb.elpi @@ -13,6 +13,8 @@ main I Prefix CL :- std.do! [ CL = [eqb-for _ (global (const C))], % TODO, quantify params ]. +% eqb-for {{ list lp:A }} {{ list_eq lp:F }} :- eq-for A F. + pred do-params i:int, i:term, i:term, o:term. do-params J (prod _ T F) I {{ fun (p : lp:T) (eqp : p -> p -> bool) => lp:(R p eqp) }} :- J > 0, !, K is J - 1, @pi-decl `P` T p\ @@ -40,10 +42,12 @@ do-fields Ty {{ fun a b => lp:(R a b) }} :- do-fields.aux (prod N T F) P1 P2 {{ lp:X && lp:R }} :- F = (x\prod _ _ _), !, % not the last one eqb-for T EQB, - coq.mk-app EQB [{{ fst lp:P1 }}, {{ fst lp:P2 }}] X, - do-fields.aux (F {{ unit }}) {{ snd lp:P1 }} {{ snd lp:P2 }} R. + X = {{ lp:EQB (fst lp:P1) (fst lp:P2) }}, + (pi x\ if (occurs x (F x)) (coq.error "dependent type not supported yet") true), + @pi-decl N T n\ + do-fields.aux (F n) {{ snd lp:P1 }} {{ snd lp:P2 }} R. -do-fields.aux (prod N T _) P1 P2 X :- +do-fields.aux (prod _ T _) P1 P2 X :- eqb-for T EQB, coq.mk-app EQB [P1, P2] X. diff --git a/src/eqb.v b/src/eqb.v index 90fd3b1..5118f93 100644 --- a/src/eqb.v +++ b/src/eqb.v @@ -7,8 +7,8 @@ Open Scope bool_scope. Elpi Db eqb.db lp:{{ pred eqb-for - o:term, - o:term. % eqb + o:term, % type + o:term. % eqb_type }}. diff --git a/src/list_defs.v b/src/list_defs.v index 4f5f41c..f4611d8 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -10,9 +10,11 @@ Require Import PArith. Open Scope positive_scope. Elpi tag list. + Definition tag {A} := @list_tag A. Elpi fields list. + Definition fields_t {A} := @list_fields_t A. Definition fields {A} := @list_fields A. @@ -22,11 +24,13 @@ Definition construct {A} := @ list_construct A. Definition constructP {A} := @list_constructP A. Elpi eqb list. + Print list_eqb_fields. Definition eqb_fields := list_eqb_fields. About eqb_body. + Definition list_eqb A (eqA : A -> A -> bool) := fix eqb (x1 x2 : list A) := match x1 with | [::] => @eqb_body (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_eqb_fields A eqA eqb) (@list_tag A [::]) tt x2 @@ -36,6 +40,88 @@ Definition list_eqb A (eqA : A -> A -> bool) := fix eqb (x1 x2 : list A) := Ltac eqb_correct_on__solver := by repeat (try case/andP; match goal with H : eqb_correct_on _ _ |- _ => move=> /=/H-> end). +Elpi Accumulate eqb.db lp:{{ + + pred eqb-fields i:term, o:term. + + eqb-for {{ list lp:A }} {{ @list_eqb lp:A lp:F }} :- eqb-for A F. + eqb-fields {{ list lp:A }} {{ @list_eqb_fields lp:A lp:EA lp:ELA }} :- eqb-for A EA, eqb-for {{ list lp:A }} ELA. + %eqb-for {{ forall x : lp:S, lp:(T x) }} {{ @prod_eqb lp:A lp:F lp:B lp:G }} :- eqb-for A F, eqb-for B G. + % eqb-for {{ unit }} {{ true }}. + +}}. + + + + + + +Elpi Command eqcorrect. +Elpi Accumulate Db eqb.db. +Elpi Accumulate Db fields.db. +Elpi Accumulate File "src/elpi-ltac.elpi". +Elpi Accumulate lp:{{ + + main [str S] :- + std.assert! (coq.locate S (indt I)) "Not an inductive type", + Prefix is S ^ "_", + eqb.main I Prefix _. + + +pred eqb.main i:inductive, i:string, o:list prop. +eqb.main I Prefix [] :- std.do! [ + coq.env.indt I _ _ N _ Ks KTs, + KTs = [_,KT], + Ks = [_,K], + do-params N KT (global (indc K)) R, + std.assert-ok! (coq.typecheck R Ty) "R casse", + /* + + coq.ltac.collect-goals R [G] _, + coq.ltac.open (coq.ltac.call "eqb_correct_on__solver" []) G [], + std.assert-ok! (coq.typecheck R Ty) "R casse2", +*/ + Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)}, + coq.env.add-const Name R Ty @opaque! _, + +]. + +% forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. +% T : Type |- T -> list T -> list T ---> +pred do-params i:int, i:term, i:term, o:term. +do-params NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, + @pi-decl N T a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + eqb-for a eqA => + do-params NP1 (F a) {{ lp:K lp:a }} (R a eqA). +do-params 0 T K R :- do-args T K R. + +pred do-args i:term, i:term, o:term. +do-args (prod N T F) K {{ fun (x : lp:T) (Px : eqb_correct_on lp:Cmp x) => lp:(R x Px) }} :- !, + eqb-for T Cmp, + @pi-decl N T x\ + @pi-decl `px` {{ eqb_correct_on lp:Cmp lp:x }} px\ + do-args (F x) {{ lp:K lp:x }} (R x px). +do-args T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ + eqb-for T Cmp, + coq.safe-dest-app T (global (indt I)) Args, + fields-for I _ _ _ ConstructPC, + coq.mk-app (global (const ConstructPC)) Args ConstructP, + eqb-fields T Fields, + B = {{ @eqb_body_correct _ _ _ _ _ lp:ConstructP lp:Fields lp:K (fun f => _) }}, + coq.typecheck {{ lp:B : eqb_correct_on lp:Cmp lp:K }} _ _, + coq.ltac.collect-goals B [G] _, + coq.ltac.open (coq.ltac.call "eqb_correct_on__solver" []) G [], +]. + +}}. +Elpi Typecheck. + +Elpi eqcorrect list. + +About list_eqb_correct_on_cons. + +Definition eqb_correct_on_cons := list_eqb_correct_on_cons Lemma eqb_correct_on_nil A (eqA : A -> A -> bool) : eqb_correct_on (list_eqb eqA) nil. Proof. @@ -46,6 +132,7 @@ Proof. eqb_correct_on__solver. Qed. +(* Lemma eqb_correct_on_cons A (eqA : A -> A -> bool): forall a, eqb_correct_on eqA a -> forall l, eqb_correct_on (list_eqb eqA) l -> @@ -58,6 +145,7 @@ Proof. eqb_correct_on__solver. Qed. +*) Ltac eqb_refl_on__solver := rewrite /eqb_fields_refl_on /=; @@ -67,7 +155,7 @@ Ltac eqb_refl_on__solver := Lemma eqb_refl_on_nil A (eqA : A -> A -> bool) : eqb_refl_on (list_eqb eqA) [::]. Proof. refine ( - (@eqb_body_refl _ _ _ _ (@list_eqb_fields A eqA (list_eqb eqA)) [::]) _). + (@eqb_body_refl _ _ _ _ (@list_eqb_fields A eqA (list_eqb eqA)) _) _). eqb_refl_on__solver. Qed. @@ -77,7 +165,7 @@ Lemma eqb_refl_on_cons A (eqA : A -> A -> bool): eqb_refl_on (list_eqb eqA) (a :: l). Proof. refine (fun a ha l hl => - (@eqb_body_refl _ _ _ _ (@list_eqb_fields A eqA (list_eqb eqA)) (a :: l)) _). + (@eqb_body_refl _ _ _ _ (@list_eqb_fields A eqA (list_eqb eqA)) _) _). eqb_refl_on__solver. Qed. From 5207b5575ab0eaf5884814c83687c4f696a7fb72 Mon Sep 17 00:00:00 2001 From: Benjamin Gregoire Date: Mon, 6 Dec 2021 13:44:22 +0100 Subject: [PATCH 14/40] fix nix --- coqword.nix | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ default.nix | 2 +- 2 files changed, 50 insertions(+), 1 deletion(-) create mode 100644 coqword.nix diff --git a/coqword.nix b/coqword.nix new file mode 100644 index 0000000..8b01b86 --- /dev/null +++ b/coqword.nix @@ -0,0 +1,49 @@ +{ stdenv, lib, fetchFromGitHub, coqPackages, ocaml, dune_2 }: + +let inherit (coqPackages) coq; in + +let mathcomp = + (if coqPackages ? mathcomp_ + then coqPackages.mathcomp_ "1.12.0" + else coqPackages.mathcomp.override { version = "1.12.0"; } + ).algebra +; in + +let rev = "e39e96d51aa96f386222fd1b38776f2117f325c5"; in + +stdenv.mkDerivation rec { + version = "1.0-git-${builtins.substring 0 8 rev}"; + name = "coq${coq.coq-version}-coqword-${version}"; + + src = fetchFromGitHub { + owner = "jasmin-lang"; + repo = "coqword"; + inherit rev; + sha256 = "sha256:0703m97rnivcbc7vvbd9rl2dxs6l8n52cbykynw61c6w9rhxspcg"; + }; + + buildInputs = [ coq ocaml dune_2 ]; + + propagatedBuildInputs = [ mathcomp ]; + + buildPhase = '' + runHook preBuild + dune build -p coq-mathcomp-word + runHook postBuild + ''; + + installPhase = '' + runHook preInstall + dune install --prefix=$out + mkdir -p $out/lib/coq/${coq.coq-version}/ + mv $out/lib/coq/user-contrib $out/lib/coq/${coq.coq-version}/ + runHook postInstall + ''; + + meta = { + description = "Yet Another Coq Library on Machine Words"; + license = lib.licenses.cecill-b; + inherit (src.meta) homepage; + inherit (coq.meta) platforms; + }; +} diff --git a/default.nix b/default.nix index d0fb24b..fe011e0 100644 --- a/default.nix +++ b/default.nix @@ -11,7 +11,7 @@ with pkgs; let inherit (lib) optionals; in -let coqPackages = coqPackages_8_12; in +let coqPackages = coqPackages_8_14; in let coqword = callPackage ./coqword.nix { inherit coqPackages; }; in From bf79987c7f9f2c4afb04f6cfe91a8db2590ef8ff Mon Sep 17 00:00:00 2001 From: Benjamin Gregoire Date: Tue, 7 Dec 2021 14:16:52 +0100 Subject: [PATCH 15/40] WIP --- .vscode/settings.json | 3 +- default.nix | 2 +- src/list_defs.v | 96 +++++++++++++++++++++++++++++++++---------- 3 files changed, 77 insertions(+), 24 deletions(-) diff --git a/.vscode/settings.json b/.vscode/settings.json index ac5b5e6..ed0d8ae 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -8,5 +8,6 @@ "**/*.aux": true, "**/Makefile.coq": true, "**/Makefile.coq.conf": true - } + }, + "coqtop.binPath": "/nix/store/bfygibqxf976p49svngbkzkls6fqwywz-coq-8.14.0/bin/" } \ No newline at end of file diff --git a/default.nix b/default.nix index fe011e0..c0fc220 100644 --- a/default.nix +++ b/default.nix @@ -35,7 +35,7 @@ stdenv.mkDerivation { name = "jasmin-0"; src = null; buildInputs = [] - ++ optionals coqDeps [ coqPackages.coq coqword coqPackages.coq.ocamlPackages.ocaml ] + ++ optionals coqDeps [ coqPackages.coq coqPackages.coq-elpi coqword coqPackages.coq.ocamlPackages.ocaml ] ++ optionals testDeps ([ ocamlPackages.apron.out ] ++ (with python3Packages; [ python pyyaml ])) ++ optionals ocamlDeps ([ mpfr ppl ] ++ (with oP; [ ocaml findlib ocamlbuild diff --git a/src/list_defs.v b/src/list_defs.v index f4611d8..9f347eb 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -29,7 +29,10 @@ Print list_eqb_fields. Definition eqb_fields := list_eqb_fields. -About eqb_body. +From elpi.apps Require Import derive. +#[only(induction,param1_full,param1_trivial)] derive list. + + Definition list_eqb A (eqA : A -> A -> bool) := fix eqb (x1 x2 : list A) := match x1 with @@ -38,7 +41,7 @@ Definition list_eqb A (eqA : A -> A -> bool) := fix eqb (x1 x2 : list A) := end. Ltac eqb_correct_on__solver := - by repeat (try case/andP; match goal with H : eqb_correct_on _ _ |- _ => move=> /=/H-> end). + by repeat (try case/andP; match reverse goal with H : eqb_correct_on _ _ |- _ => move=> /=/H{H}-> end). Elpi Accumulate eqb.db lp:{{ @@ -55,11 +58,24 @@ Elpi Accumulate eqb.db lp:{{ - Elpi Command eqcorrect. Elpi Accumulate Db eqb.db. Elpi Accumulate Db fields.db. +Elpi Accumulate Db derive.induction.db. Elpi Accumulate File "src/elpi-ltac.elpi". + +(* +Elpi Db eqb_correct.db lp:{{ + +% this is how one registers the fields_t, fields and construct[P] +% constants to an inductive and let other elpi commands use that piece of info +pred eqb_correct-for + o:constructor, % constructor name XXX of type YYY + o:constant. % YYY_eq_correct_on_XXX +}}. +*) +Print list_induction. + Elpi Accumulate lp:{{ main [str S] :- @@ -70,20 +86,23 @@ Elpi Accumulate lp:{{ pred eqb.main i:inductive, i:string, o:list prop. eqb.main I Prefix [] :- std.do! [ - coq.env.indt I _ _ N _ Ks KTs, - KTs = [_,KT], - Ks = [_,K], + % Add error msg if not a inductive ? + coq.env.indt I _ _ N TI Ks KTs, + std.map2 KTs Ks (add-decl Prefix N) L, + induction-db I Indu, + std.map L (c\ d\ d = global (const c)) Lt, + coq.say "TI=", coq.say TI, + KTs = [TTTT, _], + coq.say "TTTT=" TTTT, + add-indu TTTT Indu Lt +]. + +pred add-decl i:string, i:int, i:term, i:constructor, o : constant. +add-decl Prefix N KT K P:- std.do![ do-params N KT (global (indc K)) R, std.assert-ok! (coq.typecheck R Ty) "R casse", - /* - - coq.ltac.collect-goals R [G] _, - coq.ltac.open (coq.ltac.call "eqb_correct_on__solver" []) G [], - std.assert-ok! (coq.typecheck R Ty) "R casse2", -*/ Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)}, - coq.env.add-const Name R Ty @opaque! _, - + coq.env.add-const Name R Ty @opaque! P, ]. % forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. @@ -114,25 +133,47 @@ do-args T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ coq.ltac.open (coq.ltac.call "eqb_correct_on__solver" []) G [], ]. +pred add-indu i:term, i:term, i:list term. +add-indu (prod N T F) Indu LS :-!, + coq.say T, + @pi-decl N T a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + @pi-decl `eqAc` {{ eqb_correct lp:eqA }} eqAc\ + eqb-for a eqA => + coq.say "CCC", + coq.say LS, + std.map LS (t\ t'\ t' = {{ lp:t lp:a}}) LS', + coq.say "BBB", + add-indu (F a) Indu LS'. +add-indu T Indu LS:- + coq.say Indu, + coq.say LS +. + }}. Elpi Typecheck. -Elpi eqcorrect list. +Elpi eqcorrect list. -About list_eqb_correct_on_cons. -Definition eqb_correct_on_cons := list_eqb_correct_on_cons +Elpi Query lp:{{ + std.assert! (coq.locate "list" (indt I)) "Not an inductive type", + induction-db I GR}}. + +About list_eqb_correct_on_cons. +(* Definition eqb_correct_on_cons := list_eqb_correct_on_cons. *) +(* Lemma eqb_correct_on_nil A (eqA : A -> A -> bool) : eqb_correct_on (list_eqb eqA) nil. Proof. refine ( @eqb_body_correct (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_construct A) (@list_constructP A) (@list_eqb_fields A eqA (@list_eqb A eqA)) - [::] _). + [::] (fun f => _)). eqb_correct_on__solver. Qed. -(* + Lemma eqb_correct_on_cons A (eqA : A -> A -> bool): forall a, eqb_correct_on eqA a -> forall l, eqb_correct_on (list_eqb eqA) l -> @@ -142,11 +183,13 @@ Proof. @eqb_body_correct (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_construct A) (@list_constructP A) (@list_eqb_fields A eqA (@list_eqb A eqA)) (a::l) (fun f => _)). + + eqb_correct_on__solver. Qed. - *) + Ltac eqb_refl_on__solver := rewrite /eqb_fields_refl_on /=; repeat @@ -170,9 +213,18 @@ Proof. Qed. -From elpi.apps Require Import derive. -#[only(induction,param1_full,param1_trivial)] derive list. + +Inductive t (A B :Type):= + | C1 of A + | C2 of B + | C3 of list (t A B) + | C4. + +#[only(induction,param1_full,param1_trivial)] derive t. +Check t_induction. + +induction-db GR (global (const I)) Lemma list_eqb_correct (A:Type) (eqA: A -> A -> bool) (eqAc : eqb_correct eqA) (x:list A) : eqb_correct_on (list_eqb eqA) x. Proof. From 8b857f57eab2262ad7e413f968aaa5bf4bd2ba06 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 8 Dec 2021 10:48:29 +0100 Subject: [PATCH 16/40] some progress --- src/list_defs.v | 53 +++++++++++++++++++++++++++---------------------- 1 file changed, 29 insertions(+), 24 deletions(-) diff --git a/src/list_defs.v b/src/list_defs.v index 9f347eb..8e8a3e0 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -88,17 +88,16 @@ pred eqb.main i:inductive, i:string, o:list prop. eqb.main I Prefix [] :- std.do! [ % Add error msg if not a inductive ? coq.env.indt I _ _ N TI Ks KTs, - std.map2 KTs Ks (add-decl Prefix N) L, + std.map2 KTs Ks (add-decl Prefix N) Lt, induction-db I Indu, - std.map L (c\ d\ d = global (const c)) Lt, coq.say "TI=", coq.say TI, KTs = [TTTT, _], coq.say "TTTT=" TTTT, - add-indu TTTT Indu Lt + add-indu TTTT Indu Lt R, ]. -pred add-decl i:string, i:int, i:term, i:constructor, o : constant. -add-decl Prefix N KT K P:- std.do![ +pred add-decl i:string, i:int, i:term, i:constructor, o:term. +add-decl Prefix N KT K (global (const P)) :- std.do![ do-params N KT (global (indc K)) R, std.assert-ok! (coq.typecheck R Ty) "R casse", Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)}, @@ -133,34 +132,39 @@ do-args T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ coq.ltac.open (coq.ltac.call "eqb_correct_on__solver" []) G [], ]. -pred add-indu i:term, i:term, i:list term. -add-indu (prod N T F) Indu LS :-!, +pred add-indu i:term, i:term, i:list term, o:term. +add-indu (prod N T F) Indu LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_correct eqA) => lp:(R a eqA eqAc) }} :- !, coq.say T, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ @pi-decl `eqAc` {{ eqb_correct lp:eqA }} eqAc\ - eqb-for a eqA => + % eqb-for a eqA => coq.say "CCC", coq.say LS, - std.map LS (t\ t'\ t' = {{ lp:t lp:a}}) LS', - coq.say "BBB", - add-indu (F a) Indu LS'. -add-indu T Indu LS:- - coq.say Indu, - coq.say LS -. - + coq.say "BBB", + + % Full' = {{ Full eqAc }} + + add-indu (F a) {coq.mk-app Indu [a,eqAc]} {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAc). +add-indu T Indu LS {{ fun x => lp:(R x) }} :- + @pi-decl N T x\ + % coq.mk-app Indu [_|LS , x , {coq.mk-app Full [x]} ] TOTO, + coq.say {coq.term->string TOTO}. }}. Elpi Typecheck. -Elpi eqcorrect list. +Elpi Trace. +Elpi Query lp:{{ + pi x\ x = A x + +}}. + +Elpi Print eqcorrect. +Set Printing All. +Elpi eqcorrect list. -Elpi Query lp:{{ - std.assert! (coq.locate "list" (indt I)) "Not an inductive type", - induction-db I GR}}. -About list_eqb_correct_on_cons. (* Definition eqb_correct_on_cons := list_eqb_correct_on_cons. *) (* @@ -224,15 +228,16 @@ Inductive t (A B :Type):= #[only(induction,param1_full,param1_trivial)] derive t. Check t_induction. -induction-db GR (global (const I)) Lemma list_eqb_correct (A:Type) (eqA: A -> A -> bool) (eqAc : eqb_correct eqA) (x:list A) : eqb_correct_on (list_eqb eqA) x. Proof. refine (@list_induction _ _ _ - (@eqb_correct_on_nil A eqA) - (@eqb_correct_on_cons A eqA) + (@list_eqb_correct_on_nil A eqA) + (@list_eqb_correct_on_cons A eqA) x (@list_is_list_full _ _ eqAc x)). Qed. +Set Printing All. +Print list_eqb_correct. Lemma list_eqb_refl (A:Type) (eqA: A -> A -> bool) (eqAr : @eqb_reflexive A eqA) (x:list A) : eqb_refl_on (list_eqb eqA) x. From 553b3c1a3d8c5214eceb65bd862d416e21f2550a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Dec 2021 11:07:46 +0100 Subject: [PATCH 17/40] finish eqb --- src/eqb.elpi | 84 +++++++++++++++++++++++++++++++++++++++---------- src/eqb.v | 8 +++++ src/list_defs.v | 79 ---------------------------------------------- 3 files changed, 76 insertions(+), 95 deletions(-) diff --git a/src/eqb.elpi b/src/eqb.elpi index b038839..91c5c4a 100644 --- a/src/eqb.elpi +++ b/src/eqb.elpi @@ -3,25 +3,41 @@ namespace eqb { pred main i:inductive, i:string, o:list prop. main I Prefix CL :- std.do! [ coq.env.indt I _ _ N Arity _ _, - do-params N Arity (global (indt I)) R, - coq.say {coq.term->string R}, + eqbf.do-params N Arity (global (indt I)) R, std.assert-ok! (coq.typecheck R Rty) "eqb generates illtyped term", Name is Prefix ^ "eqb_fields", coq.env.add-const Name R Rty ff C, + + eqbf.do-clause N Arity (global (indt I)) (global (const C)) [] CL1, + do-params N Arity (global (indt I)) (global (const C)) R1, + std.assert-ok! (coq.typecheck R1 R1ty) "eqb generates illtyped term", + Name1 is Prefix ^ "eqb", + coq.env.add-const Name1 R1 R1ty ff C1, + + do-clause N Arity (global (indt I)) (global (const C1)) [] CL2, + + CL = [CL1,CL2], % TODO, quantify params + std.forall CL (x\ coq.elpi.accumulate _ "eqb.db" (clause _ _ x)), - CL = [eqb-for _ (global (const C))], % TODO, quantify params ]. -% eqb-for {{ list lp:A }} {{ list_eq lp:F }} :- eq-for A F. +pred eqbf.do-clause i:int, i:term, i:term, i:term, i:list prop, o:prop. +eqbf.do-clause N (prod _ _ A) I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, + pi a ea\ + eqbf.do-clause M (A a) {coq.mk-app I [a]} {coq.mk-app F [a,ea]} [eqb-for a ea|Todo] (C a ea). +eqbf.do-clause 0 _ I F Todo (pi ela\ eqb-fields I (F1 ela) :- [C ela|Todo]) :- + pi ela\ + (coq.mk-app F [ela] (F1 ela), + C ela = eqb-for I ela). -pred do-params i:int, i:term, i:term, o:term. -do-params J (prod _ T F) I {{ fun (p : lp:T) (eqp : p -> p -> bool) => lp:(R p eqp) }} :- J > 0, !, K is J - 1, +pred eqbf.do-params i:int, i:term, i:term, o:term. +eqbf.do-params J (prod _ T F) I {{ fun (p : lp:T) (eqp : p -> p -> bool) => lp:(R p eqp) }} :- J > 0, !, K is J - 1, @pi-decl `P` T p\ @pi-decl `eqP` {{ lp:p -> lp:p -> bool }} eqP\ eqb-for p eqP => - do-params K (F p) {coq.mk-app I [p]} (R p eqP). -do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => lp:(R rec x) }} :- + eqbf.do-params K (F p) {coq.mk-app I [p]} (R p eqP). +eqbf.do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => lp:(R rec x) }} :- coq.safe-dest-app Ind (global (indt I)) Params, coq.env.indt I _ _ _ _ _ KT, std.map KT (coq.subst-prod Params) L, @@ -32,25 +48,61 @@ do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => lp:( eqb-for Ind rec => fields.splay-over-positive x L {{ fun x => lp:Fields_t x -> lp:Fields_t x -> bool }} {{ fun _ _ => true }} - do-fields + eqbf.do-fields (R rec x). -pred do-fields i:term, o:term. -do-fields Ty {{ fun a b => lp:(R a b) }} :- +pred eqbf.do-fields i:term, o:term. +eqbf.do-fields Ty {{ fun a b => lp:(R a b) }} :- @pi-decl `x` _ x\ @pi-decl `y` _ y\ - do-fields.aux Ty x y (R x y). + eqbf.do-fields.aux Ty x y (R x y). -do-fields.aux (prod N T F) P1 P2 {{ lp:X && lp:R }} :- F = (x\prod _ _ _), !, % not the last one +eqbf.do-fields.aux (prod N T F) P1 P2 {{ lp:X && lp:R }} :- F = (x\prod _ _ _), !, % not the last one eqb-for T EQB, X = {{ lp:EQB (fst lp:P1) (fst lp:P2) }}, (pi x\ if (occurs x (F x)) (coq.error "dependent type not supported yet") true), @pi-decl N T n\ - do-fields.aux (F n) {{ snd lp:P1 }} {{ snd lp:P2 }} R. + eqbf.do-fields.aux (F n) {{ snd lp:P1 }} {{ snd lp:P2 }} R. -do-fields.aux (prod _ T _) P1 P2 X :- +eqbf.do-fields.aux (prod _ T _) P1 P2 X :- eqb-for T EQB, coq.mk-app EQB [P1, P2] X. -do-fields.aux _ _ _ {{ true }}. +eqbf.do-fields.aux _ _ _ {{ true }}. + + +pred do-clause i:int, i:term, i:term, i:term, i:list prop, o:prop. +do-clause N (prod _ _ A) I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, + pi a ea\ + do-clause M (A a) {coq.mk-app I [a]} {coq.mk-app F [a,ea]} [eqb-for a ea|Todo] (C a ea). +do-clause 0 _ I F Todo (eqb-for I F :- Todo). + +do-params N {{ forall x : lp:T, lp:(F x) }} I EF {{ fun (x : lp:T) (eqx : x -> x -> bool) => lp:(R x eqx) }} :- N > 0, !, M is N - 1, + @pi-decl `x` T x\ + @pi-decl `eqx` {{ lp:x -> lp:x -> bool }} eqx\ + do-params M (F x) {coq.mk-app I [x]} {coq.mk-app EF [x,eqx]} (R x eqx). +do-params 0 _ I EF {{ fix rec (x1 x2 : lp:I) {struct x1} : bool := lp:(R rec x1 x2) }} :- + @pi-decl `rec` {{ lp:I -> lp:I -> bool }} rec\ + @pi-decl `x1` I x1\ + @pi-decl `x2` I x2\ + do-match x1 I x2 {coq.mk-app EF [rec]} (R rec x1 x2). + +do-match X1 I X2 F R :- + coq.build-match X1 I + (_\_\_\r\ r = {{ bool }}) + (do-branch X2 F) + R. + +do-branch X2 F K KTY Vars _ {{ @eqb_body _ _ _ lp:FLDP lp:F lp:TAG lp:X lp:X2 }} :- + coq.safe-dest-app KTY (global (indt I)) Params, + fields-for I _ FLD _ _, + tag-for I T, + coq.mk-app (global (const FLD)) Params FLDP, + coq.mk-app (global (const T)) Params TA, + coq.mk-app TA [{coq.mk-app K Vars}] TAG, + to-tuple Vars X. + +to-tuple [] {{ tt }}. +to-tuple [X] X. +to-tuple [X|XS] {{ ( lp:X, lp:R ) }} :- to-tuple XS R. } \ No newline at end of file diff --git a/src/eqb.v b/src/eqb.v index 5118f93..f3b2c2b 100644 --- a/src/eqb.v +++ b/src/eqb.v @@ -1,6 +1,9 @@ From elpi Require Import elpi. From Coq Require Import PArith. + +Require Import core_defs. Require Export tag fields. + Open Scope positive_scope. Open Scope bool_scope. @@ -10,6 +13,11 @@ pred eqb-for o:term, % type o:term. % eqb_type +pred eqb-fields + o:term, % type + o:term. % eq_fields_type + + }}. Elpi Command eqb. diff --git a/src/list_defs.v b/src/list_defs.v index 8e8a3e0..f0b80ca 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -25,57 +25,17 @@ Definition constructP {A} := @list_constructP A. Elpi eqb list. -Print list_eqb_fields. - -Definition eqb_fields := list_eqb_fields. - From elpi.apps Require Import derive. #[only(induction,param1_full,param1_trivial)] derive list. - - -Definition list_eqb A (eqA : A -> A -> bool) := fix eqb (x1 x2 : list A) := - match x1 with - | [::] => @eqb_body (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_eqb_fields A eqA eqb) (@list_tag A [::]) tt x2 - | a::l => @eqb_body (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_eqb_fields A eqA eqb) (@list_tag A (a::l)) (a,l) x2 - end. - Ltac eqb_correct_on__solver := by repeat (try case/andP; match reverse goal with H : eqb_correct_on _ _ |- _ => move=> /=/H{H}-> end). -Elpi Accumulate eqb.db lp:{{ - - pred eqb-fields i:term, o:term. - - eqb-for {{ list lp:A }} {{ @list_eqb lp:A lp:F }} :- eqb-for A F. - eqb-fields {{ list lp:A }} {{ @list_eqb_fields lp:A lp:EA lp:ELA }} :- eqb-for A EA, eqb-for {{ list lp:A }} ELA. - %eqb-for {{ forall x : lp:S, lp:(T x) }} {{ @prod_eqb lp:A lp:F lp:B lp:G }} :- eqb-for A F, eqb-for B G. - % eqb-for {{ unit }} {{ true }}. - -}}. - - - - - Elpi Command eqcorrect. Elpi Accumulate Db eqb.db. Elpi Accumulate Db fields.db. Elpi Accumulate Db derive.induction.db. Elpi Accumulate File "src/elpi-ltac.elpi". - -(* -Elpi Db eqb_correct.db lp:{{ - -% this is how one registers the fields_t, fields and construct[P] -% constants to an inductive and let other elpi commands use that piece of info -pred eqb_correct-for - o:constructor, % constructor name XXX of type YYY - o:constant. % YYY_eq_correct_on_XXX -}}. -*) -Print list_induction. - Elpi Accumulate lp:{{ main [str S] :- @@ -153,47 +113,8 @@ add-indu T Indu LS {{ fun x => lp:(R x) }} :- }}. Elpi Typecheck. -Elpi Trace. -Elpi Query lp:{{ - - pi x\ x = A x - -}}. - -Elpi Print eqcorrect. -Set Printing All. Elpi eqcorrect list. - - -(* Definition eqb_correct_on_cons := list_eqb_correct_on_cons. *) -(* -Lemma eqb_correct_on_nil A (eqA : A -> A -> bool) : eqb_correct_on (list_eqb eqA) nil. -Proof. - refine ( - @eqb_body_correct (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_construct A) (@list_constructP A) - (@list_eqb_fields A eqA (@list_eqb A eqA)) - [::] (fun f => _)). - eqb_correct_on__solver. -Qed. - - -Lemma eqb_correct_on_cons A (eqA : A -> A -> bool): - forall a, eqb_correct_on eqA a -> - forall l, eqb_correct_on (list_eqb eqA) l -> - eqb_correct_on (list_eqb eqA) (a :: l). -Proof. - refine (fun a P1 l P2 => - @eqb_body_correct (list A) (@list_tag A) (@list_fields_t A) (@list_fields A) (@list_construct A) (@list_constructP A) - (@list_eqb_fields A eqA (@list_eqb A eqA)) - (a::l) (fun f => _)). - - - eqb_correct_on__solver. -Qed. -*) - - Ltac eqb_refl_on__solver := rewrite /eqb_fields_refl_on /=; repeat From 2f87acf1a3b5a16cf9627218fc58528f6d9e2f89 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Dec 2021 11:09:32 +0100 Subject: [PATCH 18/40] types --- src/eqb.elpi | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/eqb.elpi b/src/eqb.elpi index 91c5c4a..8a63c85 100644 --- a/src/eqb.elpi +++ b/src/eqb.elpi @@ -76,6 +76,7 @@ do-clause N (prod _ _ A) I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, do-clause M (A a) {coq.mk-app I [a]} {coq.mk-app F [a,ea]} [eqb-for a ea|Todo] (C a ea). do-clause 0 _ I F Todo (eqb-for I F :- Todo). +pred do-params i:int, i:term, i:term, i:term, o:term. do-params N {{ forall x : lp:T, lp:(F x) }} I EF {{ fun (x : lp:T) (eqx : x -> x -> bool) => lp:(R x eqx) }} :- N > 0, !, M is N - 1, @pi-decl `x` T x\ @pi-decl `eqx` {{ lp:x -> lp:x -> bool }} eqx\ @@ -86,12 +87,14 @@ do-params 0 _ I EF {{ fix rec (x1 x2 : lp:I) {struct x1} : bool := lp:(R rec x1 @pi-decl `x2` I x2\ do-match x1 I x2 {coq.mk-app EF [rec]} (R rec x1 x2). +pred do-match i:term, i:term, i:term, i:term, o:term. do-match X1 I X2 F R :- coq.build-match X1 I (_\_\_\r\ r = {{ bool }}) (do-branch X2 F) R. +pred do-branch i:term, i:term, i:term, i:term, i:list term, i:A, o:term. do-branch X2 F K KTY Vars _ {{ @eqb_body _ _ _ lp:FLDP lp:F lp:TAG lp:X lp:X2 }} :- coq.safe-dest-app KTY (global (indt I)) Params, fields-for I _ FLD _ _, @@ -101,6 +104,7 @@ do-branch X2 F K KTY Vars _ {{ @eqb_body _ _ _ lp:FLDP lp:F lp:TAG lp:X lp:X2 }} coq.mk-app TA [{coq.mk-app K Vars}] TAG, to-tuple Vars X. +pred to-tuple i:list term, o:term. to-tuple [] {{ tt }}. to-tuple [X] X. to-tuple [X|XS] {{ ( lp:X, lp:R ) }} :- to-tuple XS R. From 7fba810bc7b6349fe4c417f540ba2e35b8e85c74 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Dec 2021 11:14:47 +0100 Subject: [PATCH 19/40] cleanup --- src/eqb.elpi | 92 ++++++++++++++++++++++++++++------------------------ 1 file changed, 50 insertions(+), 42 deletions(-) diff --git a/src/eqb.elpi b/src/eqb.elpi index 8a63c85..cb8c046 100644 --- a/src/eqb.elpi +++ b/src/eqb.elpi @@ -1,43 +1,24 @@ -namespace eqb { - -pred main i:inductive, i:string, o:list prop. -main I Prefix CL :- std.do! [ - coq.env.indt I _ _ N Arity _ _, - eqbf.do-params N Arity (global (indt I)) R, - std.assert-ok! (coq.typecheck R Rty) "eqb generates illtyped term", - Name is Prefix ^ "eqb_fields", - coq.env.add-const Name R Rty ff C, - - eqbf.do-clause N Arity (global (indt I)) (global (const C)) [] CL1, +namespace eqbf { - do-params N Arity (global (indt I)) (global (const C)) R1, - std.assert-ok! (coq.typecheck R1 R1ty) "eqb generates illtyped term", - Name1 is Prefix ^ "eqb", - coq.env.add-const Name1 R1 R1ty ff C1, - - do-clause N Arity (global (indt I)) (global (const C1)) [] CL2, - - CL = [CL1,CL2], % TODO, quantify params - std.forall CL (x\ coq.elpi.accumulate _ "eqb.db" (clause _ _ x)), - -]. - -pred eqbf.do-clause i:int, i:term, i:term, i:term, i:list prop, o:prop. -eqbf.do-clause N (prod _ _ A) I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, +% example: +% eqb-fields {{ list lp:A }} {{ @list_eqb_fields lp:A lp:EA lp:ELA }} :- +% eqb-for A EA, eqb-for {{ list lp:A }} ELA. +pred do-clause i:int, i:term, i:term, i:term, i:list prop, o:prop. +do-clause N (prod _ _ A) I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, pi a ea\ - eqbf.do-clause M (A a) {coq.mk-app I [a]} {coq.mk-app F [a,ea]} [eqb-for a ea|Todo] (C a ea). -eqbf.do-clause 0 _ I F Todo (pi ela\ eqb-fields I (F1 ela) :- [C ela|Todo]) :- + do-clause M (A a) {coq.mk-app I [a]} {coq.mk-app F [a,ea]} [eqb-for a ea|Todo] (C a ea). +do-clause 0 _ I F Todo (pi ela\ eqb-fields I (F1 ela) :- [C ela|Todo]) :- pi ela\ (coq.mk-app F [ela] (F1 ela), C ela = eqb-for I ela). -pred eqbf.do-params i:int, i:term, i:term, o:term. -eqbf.do-params J (prod _ T F) I {{ fun (p : lp:T) (eqp : p -> p -> bool) => lp:(R p eqp) }} :- J > 0, !, K is J - 1, +pred do-params i:int, i:term, i:term, o:term. +do-params J {{ forall p : lp:T, lp:(F p) }} I {{ fun (p : lp:T) (eqp : p -> p -> bool) => lp:(R p eqp) }} :- J > 0, !, K is J - 1, @pi-decl `P` T p\ @pi-decl `eqP` {{ lp:p -> lp:p -> bool }} eqP\ eqb-for p eqP => - eqbf.do-params K (F p) {coq.mk-app I [p]} (R p eqP). -eqbf.do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => lp:(R rec x) }} :- + do-params K (F p) {coq.mk-app I [p]} (R p eqP). +do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => lp:(R rec x) }} :- coq.safe-dest-app Ind (global (indt I)) Params, coq.env.indt I _ _ _ _ _ KT, std.map KT (coq.subst-prod Params) L, @@ -48,30 +29,57 @@ eqbf.do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => eqb-for Ind rec => fields.splay-over-positive x L {{ fun x => lp:Fields_t x -> lp:Fields_t x -> bool }} {{ fun _ _ => true }} - eqbf.do-fields + do-fields (R rec x). -pred eqbf.do-fields i:term, o:term. -eqbf.do-fields Ty {{ fun a b => lp:(R a b) }} :- +pred do-fields i:term, o:term. +do-fields Ty {{ fun a b => lp:(R a b) }} :- @pi-decl `x` _ x\ @pi-decl `y` _ y\ - eqbf.do-fields.aux Ty x y (R x y). + do-fields.aux Ty x y (R x y). -eqbf.do-fields.aux (prod N T F) P1 P2 {{ lp:X && lp:R }} :- F = (x\prod _ _ _), !, % not the last one +pred do-fields.aux i:term, i:term, i:term, o:term. +do-fields.aux {{ forall p : lp:T, lp:(F p) }} P1 P2 {{ lp:X && lp:R }} :- F = (x\prod _ _ _), !, % not the last one eqb-for T EQB, X = {{ lp:EQB (fst lp:P1) (fst lp:P2) }}, (pi x\ if (occurs x (F x)) (coq.error "dependent type not supported yet") true), - @pi-decl N T n\ - eqbf.do-fields.aux (F n) {{ snd lp:P1 }} {{ snd lp:P2 }} R. + @pi-decl `p` T n\ + do-fields.aux (F n) {{ snd lp:P1 }} {{ snd lp:P2 }} R. -eqbf.do-fields.aux (prod _ T _) P1 P2 X :- +do-fields.aux {{ lp:T -> _ }} P1 P2 X :- eqb-for T EQB, coq.mk-app EQB [P1, P2] X. -eqbf.do-fields.aux _ _ _ {{ true }}. +do-fields.aux _ _ _ {{ true }}. +} -pred do-clause i:int, i:term, i:term, i:term, i:list prop, o:prop. -do-clause N (prod _ _ A) I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, +namespace eqb { + +pred main i:inductive, i:string, o:list prop. +main I Prefix CL :- std.do! [ + coq.env.indt I _ _ N Arity _ _, + eqbf.do-params N Arity (global (indt I)) R, + std.assert-ok! (coq.typecheck R Rty) "eqbf generates illtyped term", + Name is Prefix ^ "eqb_fields", + coq.env.add-const Name R Rty ff C, + + eqbf.do-clause N Arity (global (indt I)) (global (const C)) [] CL1, + + do-params N Arity (global (indt I)) (global (const C)) R1, + std.assert-ok! (coq.typecheck R1 R1ty) "eqb generates illtyped term", + Name1 is Prefix ^ "eqb", + coq.env.add-const Name1 R1 R1ty ff C1, + + do-clause N Arity (global (indt I)) (global (const C1)) [] CL2, + + CL = [CL1,CL2], + std.forall CL (x\ coq.elpi.accumulate _ "eqb.db" (clause _ _ x)), + +]. + +% example: eqb-for {{ list lp:A }} {{ @list_eqb lp:A lp:F }} :- eqb-for A F. +pred do-clause i:int, i:term, i:term, i:term, i:list prop, o:prop. +do-clause N {{ forall p, lp:(A p) }} I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, pi a ea\ do-clause M (A a) {coq.mk-app I [a]} {coq.mk-app F [a,ea]} [eqb-for a ea|Todo] (C a ea). do-clause 0 _ I F Todo (eqb-for I F :- Todo). From 1f3b6aceebf36023e6d41469d5e3c0d1572a5f30 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Dec 2021 11:16:27 +0100 Subject: [PATCH 20/40] more cleanup --- src/eqb.elpi | 125 ++++++++++++++++++++++++++------------------------- 1 file changed, 63 insertions(+), 62 deletions(-) diff --git a/src/eqb.elpi b/src/eqb.elpi index cb8c046..3e99aba 100644 --- a/src/eqb.elpi +++ b/src/eqb.elpi @@ -1,58 +1,3 @@ -namespace eqbf { - -% example: -% eqb-fields {{ list lp:A }} {{ @list_eqb_fields lp:A lp:EA lp:ELA }} :- -% eqb-for A EA, eqb-for {{ list lp:A }} ELA. -pred do-clause i:int, i:term, i:term, i:term, i:list prop, o:prop. -do-clause N (prod _ _ A) I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, - pi a ea\ - do-clause M (A a) {coq.mk-app I [a]} {coq.mk-app F [a,ea]} [eqb-for a ea|Todo] (C a ea). -do-clause 0 _ I F Todo (pi ela\ eqb-fields I (F1 ela) :- [C ela|Todo]) :- - pi ela\ - (coq.mk-app F [ela] (F1 ela), - C ela = eqb-for I ela). - -pred do-params i:int, i:term, i:term, o:term. -do-params J {{ forall p : lp:T, lp:(F p) }} I {{ fun (p : lp:T) (eqp : p -> p -> bool) => lp:(R p eqp) }} :- J > 0, !, K is J - 1, - @pi-decl `P` T p\ - @pi-decl `eqP` {{ lp:p -> lp:p -> bool }} eqP\ - eqb-for p eqP => - do-params K (F p) {coq.mk-app I [p]} (R p eqP). -do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => lp:(R rec x) }} :- - coq.safe-dest-app Ind (global (indt I)) Params, - coq.env.indt I _ _ _ _ _ KT, - std.map KT (coq.subst-prod Params) L, - fields-for I F_t _ _ _, - coq.mk-app (global (const F_t)) Params Fields_t, - @pi-decl `rec` {{ lp:Ind -> lp:Ind -> bool }} rec\ - @pi-decl `x` {{ positive }} x\ - eqb-for Ind rec => - fields.splay-over-positive x L {{ fun x => lp:Fields_t x -> lp:Fields_t x -> bool }} - {{ fun _ _ => true }} - do-fields - (R rec x). -pred do-fields i:term, o:term. -do-fields Ty {{ fun a b => lp:(R a b) }} :- - @pi-decl `x` _ x\ - @pi-decl `y` _ y\ - do-fields.aux Ty x y (R x y). - -pred do-fields.aux i:term, i:term, i:term, o:term. -do-fields.aux {{ forall p : lp:T, lp:(F p) }} P1 P2 {{ lp:X && lp:R }} :- F = (x\prod _ _ _), !, % not the last one - eqb-for T EQB, - X = {{ lp:EQB (fst lp:P1) (fst lp:P2) }}, - (pi x\ if (occurs x (F x)) (coq.error "dependent type not supported yet") true), - @pi-decl `p` T n\ - do-fields.aux (F n) {{ snd lp:P1 }} {{ snd lp:P2 }} R. - -do-fields.aux {{ lp:T -> _ }} P1 P2 X :- - eqb-for T EQB, - coq.mk-app EQB [P1, P2] X. - -do-fields.aux _ _ _ {{ true }}. - -} - namespace eqb { pred main i:inductive, i:string, o:list prop. @@ -77,13 +22,6 @@ main I Prefix CL :- std.do! [ ]. -% example: eqb-for {{ list lp:A }} {{ @list_eqb lp:A lp:F }} :- eqb-for A F. -pred do-clause i:int, i:term, i:term, i:term, i:list prop, o:prop. -do-clause N {{ forall p, lp:(A p) }} I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, - pi a ea\ - do-clause M (A a) {coq.mk-app I [a]} {coq.mk-app F [a,ea]} [eqb-for a ea|Todo] (C a ea). -do-clause 0 _ I F Todo (eqb-for I F :- Todo). - pred do-params i:int, i:term, i:term, i:term, o:term. do-params N {{ forall x : lp:T, lp:(F x) }} I EF {{ fun (x : lp:T) (eqx : x -> x -> bool) => lp:(R x eqx) }} :- N > 0, !, M is N - 1, @pi-decl `x` T x\ @@ -117,4 +55,67 @@ to-tuple [] {{ tt }}. to-tuple [X] X. to-tuple [X|XS] {{ ( lp:X, lp:R ) }} :- to-tuple XS R. +% example: eqb-for {{ list lp:A }} {{ @list_eqb lp:A lp:F }} :- eqb-for A F. +pred do-clause i:int, i:term, i:term, i:term, i:list prop, o:prop. +do-clause N {{ forall p, lp:(A p) }} I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, + pi a ea\ + do-clause M (A a) {coq.mk-app I [a]} {coq.mk-app F [a,ea]} [eqb-for a ea|Todo] (C a ea). +do-clause 0 _ I F Todo (eqb-for I F :- Todo). + +} + +% ----------------------------------------------------------------------------- + +namespace eqbf { + +pred do-params i:int, i:term, i:term, o:term. +do-params J {{ forall p : lp:T, lp:(F p) }} I {{ fun (p : lp:T) (eqp : p -> p -> bool) => lp:(R p eqp) }} :- J > 0, !, K is J - 1, + @pi-decl `P` T p\ + @pi-decl `eqP` {{ lp:p -> lp:p -> bool }} eqP\ + eqb-for p eqP => + do-params K (F p) {coq.mk-app I [p]} (R p eqP). +do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => lp:(R rec x) }} :- + coq.safe-dest-app Ind (global (indt I)) Params, + coq.env.indt I _ _ _ _ _ KT, + std.map KT (coq.subst-prod Params) L, + fields-for I F_t _ _ _, + coq.mk-app (global (const F_t)) Params Fields_t, + @pi-decl `rec` {{ lp:Ind -> lp:Ind -> bool }} rec\ + @pi-decl `x` {{ positive }} x\ + eqb-for Ind rec => + fields.splay-over-positive x L {{ fun x => lp:Fields_t x -> lp:Fields_t x -> bool }} + {{ fun _ _ => true }} + do-fields + (R rec x). +pred do-fields i:term, o:term. +do-fields Ty {{ fun a b => lp:(R a b) }} :- + @pi-decl `x` _ x\ + @pi-decl `y` _ y\ + do-fields.aux Ty x y (R x y). + +pred do-fields.aux i:term, i:term, i:term, o:term. +do-fields.aux {{ forall p : lp:T, lp:(F p) }} P1 P2 {{ lp:X && lp:R }} :- F = (x\prod _ _ _), !, % not the last one + eqb-for T EQB, + X = {{ lp:EQB (fst lp:P1) (fst lp:P2) }}, + (pi x\ if (occurs x (F x)) (coq.error "dependent type not supported yet") true), + @pi-decl `p` T n\ + do-fields.aux (F n) {{ snd lp:P1 }} {{ snd lp:P2 }} R. +do-fields.aux {{ lp:T -> _ }} P1 P2 X :- + eqb-for T EQB, + coq.mk-app EQB [P1, P2] X. +do-fields.aux _ _ _ {{ true }}. + +% example: +% eqb-fields {{ list lp:A }} {{ @list_eqb_fields lp:A lp:EA lp:ELA }} :- +% eqb-for A EA, eqb-for {{ list lp:A }} ELA. +pred do-clause i:int, i:term, i:term, i:term, i:list prop, o:prop. +do-clause N (prod _ _ A) I F Todo (pi a ea\ C a ea) :- N > 0, !, M is N - 1, + pi a ea\ + do-clause M (A a) {coq.mk-app I [a]} {coq.mk-app F [a,ea]} [eqb-for a ea|Todo] (C a ea). +do-clause 0 _ I F Todo (pi ela\ eqb-fields I (F1 ela) :- [C ela|Todo]) :- + pi ela\ + (coq.mk-app F [ela] (F1 ela), + C ela = eqb-for I ela). + + } \ No newline at end of file From 0bf43dd0bbf6a08c6870bee1b5c1c87da5eaf638 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Dec 2021 11:22:57 +0100 Subject: [PATCH 21/40] cleanup --- src/eqb.elpi | 47 +++++++++++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/src/eqb.elpi b/src/eqb.elpi index 3e99aba..44863c1 100644 --- a/src/eqb.elpi +++ b/src/eqb.elpi @@ -1,27 +1,32 @@ -namespace eqb { -pred main i:inductive, i:string, o:list prop. -main I Prefix CL :- std.do! [ +pred eqb.main i:inductive, i:string, o:list prop. +eqb.main I Prefix CL :- std.do! [ coq.env.indt I _ _ N Arity _ _, - eqbf.do-params N Arity (global (indt I)) R, + Ind = global (indt I), + + % the non recursive code comparing all fields according to their types + eqbf.do-params N Arity Ind R, std.assert-ok! (coq.typecheck R Rty) "eqbf generates illtyped term", Name is Prefix ^ "eqb_fields", coq.env.add-const Name R Rty ff C, + EQBF = global (const C), - eqbf.do-clause N Arity (global (indt I)) (global (const C)) [] CL1, - - do-params N Arity (global (indt I)) (global (const C)) R1, + % the fix + eqb.do-params N Arity Ind EQBF R1, std.assert-ok! (coq.typecheck R1 R1ty) "eqb generates illtyped term", Name1 is Prefix ^ "eqb", coq.env.add-const Name1 R1 R1ty ff C1, + EQB = global (const C1), - do-clause N Arity (global (indt I)) (global (const C1)) [] CL2, - + % populate dbs + eqbf.do-clause N Arity Ind EQBF [] CL1, + eqb.do-clause N Arity Ind EQB [] CL2, CL = [CL1,CL2], std.forall CL (x\ coq.elpi.accumulate _ "eqb.db" (clause _ _ x)), - ]. +namespace eqb { + pred do-params i:int, i:term, i:term, i:term, o:term. do-params N {{ forall x : lp:T, lp:(F x) }} I EF {{ fun (x : lp:T) (eqx : x -> x -> bool) => lp:(R x eqx) }} :- N > 0, !, M is N - 1, @pi-decl `x` T x\ @@ -41,14 +46,15 @@ do-match X1 I X2 F R :- R. pred do-branch i:term, i:term, i:term, i:term, i:list term, i:A, o:term. -do-branch X2 F K KTY Vars _ {{ @eqb_body _ _ _ lp:FLDP lp:F lp:TAG lp:X lp:X2 }} :- +do-branch X2 F K KTY Vars _ {{ @eqb_body _ _ _ lp:FLDP lp:F lp:TAG lp:X lp:X2 }} :- std.do! [ coq.safe-dest-app KTY (global (indt I)) Params, fields-for I _ FLD _ _, tag-for I T, coq.mk-app (global (const FLD)) Params FLDP, coq.mk-app (global (const T)) Params TA, coq.mk-app TA [{coq.mk-app K Vars}] TAG, - to-tuple Vars X. + to-tuple Vars X, +]. pred to-tuple i:list term, o:term. to-tuple [] {{ tt }}. @@ -74,19 +80,20 @@ do-params J {{ forall p : lp:T, lp:(F p) }} I {{ fun (p : lp:T) (eqp : p -> p -> @pi-decl `eqP` {{ lp:p -> lp:p -> bool }} eqP\ eqb-for p eqP => do-params K (F p) {coq.mk-app I [p]} (R p eqP). -do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => lp:(R rec x) }} :- +do-params 0 _ Ind {{ fun (rec : lp:Ind -> lp:Ind -> bool) (x : positive) => lp:(R rec x) }} :- std.do! [ coq.safe-dest-app Ind (global (indt I)) Params, coq.env.indt I _ _ _ _ _ KT, std.map KT (coq.subst-prod Params) L, fields-for I F_t _ _ _, coq.mk-app (global (const F_t)) Params Fields_t, - @pi-decl `rec` {{ lp:Ind -> lp:Ind -> bool }} rec\ - @pi-decl `x` {{ positive }} x\ - eqb-for Ind rec => - fields.splay-over-positive x L {{ fun x => lp:Fields_t x -> lp:Fields_t x -> bool }} - {{ fun _ _ => true }} - do-fields - (R rec x). + (@pi-decl `rec` {{ lp:Ind -> lp:Ind -> bool }} rec\ + @pi-decl `x` {{ positive }} x\ + eqb-for Ind rec => + fields.splay-over-positive x L {{ fun x => lp:Fields_t x -> lp:Fields_t x -> bool }} + {{ fun _ _ => true }} + do-fields + (R rec x)), +]. pred do-fields i:term, o:term. do-fields Ty {{ fun a b => lp:(R a b) }} :- @pi-decl `x` _ x\ From d42d01f3c7fade0b0de718f28dbda6f12ad96d3c Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Dec 2021 11:33:15 +0100 Subject: [PATCH 22/40] remove cruft --- src/list_defs.v | 32 ++++---------------------------- 1 file changed, 4 insertions(+), 28 deletions(-) diff --git a/src/list_defs.v b/src/list_defs.v index f0b80ca..0bb3439 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -9,24 +9,12 @@ Unset Printing Implicit Defensive. Require Import PArith. Open Scope positive_scope. -Elpi tag list. - -Definition tag {A} := @list_tag A. - -Elpi fields list. - -Definition fields_t {A} := @list_fields_t A. - -Definition fields {A} := @list_fields A. - -Definition construct {A} := @ list_construct A. - -Definition constructP {A} := @list_constructP A. - -Elpi eqb list. - From elpi.apps Require Import derive. + #[only(induction,param1_full,param1_trivial)] derive list. +Elpi tag list. +Elpi fields list. +Elpi eqb list. Ltac eqb_correct_on__solver := by repeat (try case/andP; match reverse goal with H : eqb_correct_on _ _ |- _ => move=> /=/H{H}-> end). @@ -137,18 +125,6 @@ Proof. eqb_refl_on__solver. Qed. - - - -Inductive t (A B :Type):= - | C1 of A - | C2 of B - | C3 of list (t A B) - | C4. - -#[only(induction,param1_full,param1_trivial)] derive t. -Check t_induction. - Lemma list_eqb_correct (A:Type) (eqA: A -> A -> bool) (eqAc : eqb_correct eqA) (x:list A) : eqb_correct_on (list_eqb eqA) x. Proof. From 49dc8eb09b9803b8011529ca680eeff75e03f2e7 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Dec 2021 11:36:45 +0100 Subject: [PATCH 23/40] cleanup --- src/list_defs.v | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/src/list_defs.v b/src/list_defs.v index 0bb3439..ef0742b 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -1,21 +1,17 @@ -Require Import Eqdep_dec. - -From mathcomp Require Import all_ssreflect. +From elpi.apps Require Import derive. Require Import core_defs tag fields eqb. Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. -Require Import PArith. -Open Scope positive_scope. - -From elpi.apps Require Import derive. #[only(induction,param1_full,param1_trivial)] derive list. Elpi tag list. Elpi fields list. Elpi eqb list. +From mathcomp Require Import all_ssreflect. +Require Import PArith. +Open Scope positive_scope. + Ltac eqb_correct_on__solver := by repeat (try case/andP; match reverse goal with H : eqb_correct_on _ _ |- _ => move=> /=/H{H}-> end). From 96c9b659e85a8e3511d3670024ec80f026e13367 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Dec 2021 11:39:02 +0100 Subject: [PATCH 24/40] cleanup --- src/list_defs.v | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/list_defs.v b/src/list_defs.v index ef0742b..3ab9b96 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -15,6 +15,12 @@ Open Scope positive_scope. Ltac eqb_correct_on__solver := by repeat (try case/andP; match reverse goal with H : eqb_correct_on _ _ |- _ => move=> /=/H{H}-> end). +Ltac eqb_refl_on__solver := + rewrite /eqb_fields_refl_on /=; + repeat + (reflexivity || apply/andP; split; assumption). + +(* TODO: move to a file *) Elpi Command eqcorrect. Elpi Accumulate Db eqb.db. Elpi Accumulate Db fields.db. @@ -99,11 +105,6 @@ Elpi Typecheck. Elpi eqcorrect list. -Ltac eqb_refl_on__solver := - rewrite /eqb_fields_refl_on /=; - repeat - (reflexivity || apply/andP; split; assumption). - Lemma eqb_refl_on_nil A (eqA : A -> A -> bool) : eqb_refl_on (list_eqb eqA) [::]. Proof. refine ( @@ -129,8 +130,6 @@ Proof. (@list_eqb_correct_on_cons A eqA) x (@list_is_list_full _ _ eqAc x)). Qed. -Set Printing All. -Print list_eqb_correct. Lemma list_eqb_refl (A:Type) (eqA: A -> A -> bool) (eqAr : @eqb_reflexive A eqA) (x:list A) : eqb_refl_on (list_eqb eqA) x. From d0757aed80f26bcf257f511867d3a1d07bd9e2b9 Mon Sep 17 00:00:00 2001 From: Benjamin Gregoire Date: Fri, 10 Dec 2021 13:01:00 +0100 Subject: [PATCH 25/40] WIP --- src/core_defs.v | 4 ++-- src/list_defs.v | 58 ++++++++++++++++++++++++------------------------- 2 files changed, 31 insertions(+), 31 deletions(-) diff --git a/src/core_defs.v b/src/core_defs.v index d472f8f..050d3cc 100644 --- a/src/core_defs.v +++ b/src/core_defs.v @@ -17,8 +17,8 @@ Definition eqb_refl_on (eqb : A -> A -> bool) (a:A) := eqb a a. Definition eqb_correct (eqb : A -> A -> bool) := - forall (a1:A) a2, eqb a1 a2 -> a1 = a2. - + forall (a1:A), eqb_correct_on eqb a1. + Definition eqb_reflexive (eqb : A -> A -> bool) := forall (a:A), eqb a a. diff --git a/src/list_defs.v b/src/list_defs.v index 3ab9b96..6201d58 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -19,13 +19,16 @@ Ltac eqb_refl_on__solver := rewrite /eqb_fields_refl_on /=; repeat (reflexivity || apply/andP; split; assumption). - + + (* TODO: move to a file *) Elpi Command eqcorrect. Elpi Accumulate Db eqb.db. Elpi Accumulate Db fields.db. Elpi Accumulate Db derive.induction.db. +Elpi Accumulate Db derive.param1.trivial.db. Elpi Accumulate File "src/elpi-ltac.elpi". + Elpi Accumulate lp:{{ main [str S] :- @@ -40,10 +43,15 @@ eqb.main I Prefix [] :- std.do! [ coq.env.indt I _ _ N TI Ks KTs, std.map2 KTs Ks (add-decl Prefix N) Lt, induction-db I Indu, - coq.say "TI=", coq.say TI, - KTs = [TTTT, _], - coq.say "TTTT=" TTTT, - add-indu TTTT Indu Lt R, + %param1-trivial-db (global (indt I)) Is_full, + %coq.say "IS_full = " Is_full, + coq.say "TI =" TI, + add-indu TI Indu {{@list_is_list_full}} Lt R, + coq.say "Indu = " Indu, + coq.say "R = " R, + std.assert-ok! (coq.elaborate-skeleton R Ty R2) "fail demande a JC", + Name is Prefix ^ "eqb_correct", + coq.env.add-const Name R2 Ty @opaque! P, ]. pred add-decl i:string, i:int, i:term, i:constructor, o:term. @@ -82,28 +90,28 @@ do-args T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ coq.ltac.open (coq.ltac.call "eqb_correct_on__solver" []) G [], ]. -pred add-indu i:term, i:term, i:list term, o:term. -add-indu (prod N T F) Indu LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_correct eqA) => lp:(R a eqA eqAc) }} :- !, +pred add-indu i:term, i:term, i:term, i:list term, o:term. +add-indu (prod N T F) Indu Is_full LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_correct eqA) => lp:(R a eqA eqAc) }} :- !, coq.say T, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ @pi-decl `eqAc` {{ eqb_correct lp:eqA }} eqAc\ % eqb-for a eqA => - coq.say "CCC", - coq.say LS, - coq.say "BBB", - - % Full' = {{ Full eqAc }} - - add-indu (F a) {coq.mk-app Indu [a,eqAc]} {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAc). -add-indu T Indu LS {{ fun x => lp:(R x) }} :- - @pi-decl N T x\ - % coq.mk-app Indu [_|LS , x , {coq.mk-app Full [x]} ] TOTO, - coq.say {coq.term->string TOTO}. + add-indu (F a) + {{ lp:Indu lp:a (eqb_correct_on lp:eqA)}} + {{ lp:Is_full lp:a (eqb_correct_on lp:eqA) lp:eqAc}} + {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAc). + +add-indu _T Indu Is_full LS {{ fun x => lp:(R x) }} :- + @pi-decl `x` _ x\ + coq.mk-app { coq.mk-app Indu [_|LS] } [x, {{ lp:Is_full lp:x}}] (R x). + }}. Elpi Typecheck. -Elpi eqcorrect list. +Set Printing All. +Elpi eqcorrect list. +Print list_eqb_correct. Lemma eqb_refl_on_nil A (eqA : A -> A -> bool) : eqb_refl_on (list_eqb eqA) [::]. Proof. @@ -122,15 +130,7 @@ Proof. eqb_refl_on__solver. Qed. -Lemma list_eqb_correct (A:Type) (eqA: A -> A -> bool) (eqAc : eqb_correct eqA) - (x:list A) : eqb_correct_on (list_eqb eqA) x. -Proof. - refine (@list_induction _ _ _ - (@list_eqb_correct_on_nil A eqA) - (@list_eqb_correct_on_cons A eqA) - x (@list_is_list_full _ _ eqAc x)). -Qed. - +(* Lemma list_eqb_refl (A:Type) (eqA: A -> A -> bool) (eqAr : @eqb_reflexive A eqA) (x:list A) : eqb_refl_on (list_eqb eqA) x. Proof. @@ -146,4 +146,4 @@ Lemma list_eqbP (A:Type) (eqA: A -> A -> bool) : forall (x1 x2 : list A), reflect (x1 = x2) (list_eqb eqA x1 x2). Proof. refine (iffP2 (list_eqb_correct eqAc) (list_eqb_refl eqAr)). Qed. - +*) From 490269fc9f30e0bf3e8692319c38105575a57b19 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 10 Dec 2021 14:51:34 +0100 Subject: [PATCH 26/40] fix ugly fix --- src/list_defs.v | 37 +++++++++++++++++-------------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/src/list_defs.v b/src/list_defs.v index 6201d58..7606a85 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -26,7 +26,8 @@ Elpi Command eqcorrect. Elpi Accumulate Db eqb.db. Elpi Accumulate Db fields.db. Elpi Accumulate Db derive.induction.db. -Elpi Accumulate Db derive.param1.trivial.db. +Elpi Accumulate Db derive.param1.db. +Elpi Accumulate Db derive.param1.inhab.db. Elpi Accumulate File "src/elpi-ltac.elpi". Elpi Accumulate lp:{{ @@ -43,15 +44,11 @@ eqb.main I Prefix [] :- std.do! [ coq.env.indt I _ _ N TI Ks KTs, std.map2 KTs Ks (add-decl Prefix N) Lt, induction-db I Indu, - %param1-trivial-db (global (indt I)) Is_full, - %coq.say "IS_full = " Is_full, - coq.say "TI =" TI, - add-indu TI Indu {{@list_is_list_full}} Lt R, - coq.say "Indu = " Indu, - coq.say "R = " R, - std.assert-ok! (coq.elaborate-skeleton R Ty R2) "fail demande a JC", + reali (global (indt I)) IR, % param1-db, really + add-indu TI Indu IR Lt R, + std.assert-ok! (coq.typecheck R Ty) "fail demande a JC", Name is Prefix ^ "eqb_correct", - coq.env.add-const Name R2 Ty @opaque! P, + coq.env.add-const Name R Ty @opaque! _P, ]. pred add-decl i:string, i:int, i:term, i:constructor, o:term. @@ -91,20 +88,22 @@ do-args T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ ]. pred add-indu i:term, i:term, i:term, i:list term, o:term. -add-indu (prod N T F) Indu Is_full LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_correct eqA) => lp:(R a eqA eqAc) }} :- !, +add-indu (prod N T F) Indu IR LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_correct eqA) => lp:(R a eqA eqAc) }} :- !, coq.say T, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ - @pi-decl `eqAc` {{ eqb_correct lp:eqA }} eqAc\ - % eqb-for a eqA => + @pi-decl `eqAc` {{ @eqb_correct lp:a lp:eqA }} eqAc\ % super nasty "bug", the _ does not see a, if you write lp:{{ FOO a }} it works. Elaborating the skeleton is also ok, but then param1-inhab-db does not work well :-/ + param1-inhab-db {{ @eqb_correct_on lp:a lp:eqA }} eqAc => add-indu (F a) - {{ lp:Indu lp:a (eqb_correct_on lp:eqA)}} - {{ lp:Is_full lp:a (eqb_correct_on lp:eqA) lp:eqAc}} - {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAc). + {{ lp:Indu lp:a (@eqb_correct_on lp:a lp:eqA)}} + {{ lp:IR lp:a (@eqb_correct_on lp:a lp:eqA)}} + {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAc). -add-indu _T Indu Is_full LS {{ fun x => lp:(R x) }} :- +add-indu _T Indu IR LS {{ fun x => lp:(R x) }} :- + std.assert! (param1-inhab-db IR Is_full) "not trivially inhabited", @pi-decl `x` _ x\ - coq.mk-app { coq.mk-app Indu [_|LS] } [x, {{ lp:Is_full lp:x}}] (R x). + std.append LS [x, app[Is_full,x]] (Args x), + R x = app [Indu, _ | Args x]. }}. Elpi Typecheck. @@ -130,7 +129,7 @@ Proof. eqb_refl_on__solver. Qed. -(* + Lemma list_eqb_refl (A:Type) (eqA: A -> A -> bool) (eqAr : @eqb_reflexive A eqA) (x:list A) : eqb_refl_on (list_eqb eqA) x. Proof. @@ -145,5 +144,3 @@ Lemma list_eqbP (A:Type) (eqA: A -> A -> bool) (eqAr : eqb_reflexive eqA) : forall (x1 x2 : list A), reflect (x1 = x2) (list_eqb eqA x1 x2). Proof. refine (iffP2 (list_eqb_correct eqAc) (list_eqb_refl eqAr)). Qed. - -*) From 0546703cbf1707a5974cc2b94bcb6a2ac9b3eb1c Mon Sep 17 00:00:00 2001 From: Benjamin Gregoire Date: Fri, 10 Dec 2021 18:26:13 +0100 Subject: [PATCH 27/40] add reflexivity proof, thank to JC --- src/core_defs.v | 6 +-- src/list_defs.v | 126 ++++++++++++++++++++++++++++++------------------ 2 files changed, 81 insertions(+), 51 deletions(-) diff --git a/src/core_defs.v b/src/core_defs.v index 050d3cc..ec24887 100644 --- a/src/core_defs.v +++ b/src/core_defs.v @@ -14,13 +14,13 @@ Definition eqb_correct_on (eqb : A -> A -> bool) (a1:A) := forall a2, eqb a1 a2 -> a1 = a2. Definition eqb_refl_on (eqb : A -> A -> bool) (a:A) := - eqb a a. + is_true (eqb a a). Definition eqb_correct (eqb : A -> A -> bool) := forall (a1:A), eqb_correct_on eqb a1. -Definition eqb_reflexive (eqb : A -> A -> bool) := forall (a:A), - eqb a a. +Definition eqb_reflexive (eqb : A -> A -> bool) := + forall (a:A), eqb_refl_on eqb a. Lemma iffP2 (f : A -> A -> bool) (H1 : eqb_correct f) (H2 : eqb_reflexive f) (x1 x2 : A) : reflect (x1 = x2) (f x1 x2). diff --git a/src/list_defs.v b/src/list_defs.v index 7606a85..6182ab2 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -42,18 +42,25 @@ pred eqb.main i:inductive, i:string, o:list prop. eqb.main I Prefix [] :- std.do! [ % Add error msg if not a inductive ? coq.env.indt I _ _ N TI Ks KTs, - std.map2 KTs Ks (add-decl Prefix N) Lt, + std.map2 KTs Ks (add-decl-correct Prefix N) Lt-correct, + std.map2 KTs Ks (add-decl-refl Prefix N) Lt-refl, induction-db I Indu, reali (global (indt I)) IR, % param1-db, really - add-indu TI Indu IR Lt R, + add-indu-correct TI Indu IR Lt-correct R, std.assert-ok! (coq.typecheck R Ty) "fail demande a JC", Name is Prefix ^ "eqb_correct", - coq.env.add-const Name R Ty @opaque! _P, + coq.env.add-const Name R Ty @opaque! _, + add-indu-refl TI Indu IR Lt-refl Rr, + std.assert-ok! (coq.typecheck Rr Tyr) "fail demande a JC", + Namer is Prefix ^ "eqb_refl", + coq.env.add-const Namer Rr Tyr @opaque! _, ]. -pred add-decl i:string, i:int, i:term, i:constructor, o:term. -add-decl Prefix N KT K (global (const P)) :- std.do![ - do-params N KT (global (indc K)) R, +/************************** correct *********************************************/ + +pred add-decl-correct i:string, i:int, i:term, i:constructor, o:term. +add-decl-correct Prefix N KT K (global (const P)) :- std.do![ + do-params-correct N KT (global (indc K)) R, std.assert-ok! (coq.typecheck R Ty) "R casse", Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)}, coq.env.add-const Name R Ty @opaque! P, @@ -61,21 +68,21 @@ add-decl Prefix N KT K (global (const P)) :- std.do![ % forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. % T : Type |- T -> list T -> list T ---> -pred do-params i:int, i:term, i:term, o:term. -do-params NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, +pred do-params-correct i:int, i:term, i:term, o:term. +do-params-correct NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ eqb-for a eqA => - do-params NP1 (F a) {{ lp:K lp:a }} (R a eqA). -do-params 0 T K R :- do-args T K R. + do-params-correct NP1 (F a) {{ lp:K lp:a }} (R a eqA). +do-params-correct 0 T K R :- do-args-correct T K R. -pred do-args i:term, i:term, o:term. -do-args (prod N T F) K {{ fun (x : lp:T) (Px : eqb_correct_on lp:Cmp x) => lp:(R x Px) }} :- !, +pred do-args-correct i:term, i:term, o:term. +do-args-correct (prod N T F) K {{ fun (x : lp:T) (Px : eqb_correct_on lp:Cmp x) => lp:(R x Px) }} :- !, eqb-for T Cmp, @pi-decl N T x\ @pi-decl `px` {{ eqb_correct_on lp:Cmp lp:x }} px\ - do-args (F x) {{ lp:K lp:x }} (R x px). -do-args T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ + do-args-correct (F x) {{ lp:K lp:x }} (R x px). +do-args-correct T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ eqb-for T Cmp, coq.safe-dest-app T (global (indt I)) Args, fields-for I _ _ _ ConstructPC, @@ -87,57 +94,80 @@ do-args T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ coq.ltac.open (coq.ltac.call "eqb_correct_on__solver" []) G [], ]. -pred add-indu i:term, i:term, i:term, i:list term, o:term. -add-indu (prod N T F) Indu IR LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_correct eqA) => lp:(R a eqA eqAc) }} :- !, - coq.say T, +pred add-indu-correct i:term, i:term, i:term, i:list term, o:term. +add-indu-correct (prod N T F) Indu IR LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_correct eqA) => lp:(R a eqA eqAc) }} :- !, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ @pi-decl `eqAc` {{ @eqb_correct lp:a lp:eqA }} eqAc\ % super nasty "bug", the _ does not see a, if you write lp:{{ FOO a }} it works. Elaborating the skeleton is also ok, but then param1-inhab-db does not work well :-/ param1-inhab-db {{ @eqb_correct_on lp:a lp:eqA }} eqAc => - add-indu (F a) + add-indu-correct (F a) {{ lp:Indu lp:a (@eqb_correct_on lp:a lp:eqA)}} {{ lp:IR lp:a (@eqb_correct_on lp:a lp:eqA)}} {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAc). -add-indu _T Indu IR LS {{ fun x => lp:(R x) }} :- +add-indu-correct _T Indu IR LS {{ fun x => lp:(R x) }} :- std.assert! (param1-inhab-db IR Is_full) "not trivially inhabited", @pi-decl `x` _ x\ std.append LS [x, app[Is_full,x]] (Args x), R x = app [Indu, _ | Args x]. +/******************************** Refl **************************************************************/ +pred add-decl-refl i:string, i:int, i:term, i:constructor, o:term. +add-decl-refl Prefix N KT K (global (const P)) :- std.do![ + do-params-refl N KT (global (indc K)) R, + std.assert-ok! (coq.typecheck R Ty) "R casse", + Name is Prefix ^ "eqb_refl_on_" ^ {coq.gref->id (indc K)}, + coq.env.add-const Name R Ty @opaque! P, +]. + +% forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. +% T : Type |- T -> list T -> list T ---> +pred do-params-refl i:int, i:term, i:term, o:term. +do-params-refl NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, + @pi-decl N T a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + eqb-for a eqA => + do-params-refl NP1 (F a) {{ lp:K lp:a }} (R a eqA). +do-params-refl 0 T K R :- do-args-refl T K R. + +pred do-args-refl i:term, i:term, o:term. +do-args-refl (prod N T F) K {{ fun (x : lp:T) (Px : eqb_refl_on lp:Cmp x) => lp:(R x Px) }} :- !, + eqb-for T Cmp, + @pi-decl N T x\ + @pi-decl `px` {{ eqb_refl_on lp:Cmp lp:x }} px\ + do-args-refl (F x) {{ lp:K lp:x }} (R x px). +do-args-refl T K {{ lp:B : eqb_refl_on lp:Cmp lp:K }} :- std.do! [ + eqb-for T Cmp, + eqb-fields T Fields, + B = {{ @eqb_body_refl _ _ _ _ lp:Fields lp:K _ }}, + coq.typecheck {{ lp:B : eqb_refl_on lp:Cmp lp:K }} _ _, + coq.ltac.collect-goals B [G] _, + coq.ltac.open (coq.ltac.call "eqb_refl_on__solver" []) G [], +]. + +pred add-indu-refl i:term, i:term, i:term, i:list term, o:term. +add-indu-refl (prod N T F) Indu IR LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_reflexive eqA) => lp:(R a eqA eqAc) }} :- !, + @pi-decl N T a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + @pi-decl `eqAr` {{ @eqb_reflexive lp:a lp:eqA }} eqAr\ % super nasty "bug", the _ does not see a, if you write lp:{{ FOO a }} it works. Elaborating the skeleton is also ok, but then param1-inhab-db does not work well :-/ + param1-inhab-db {{ @eqb_refl_on lp:a lp:eqA }} eqAr => + add-indu-refl (F a) + {{ lp:Indu lp:a (@eqb_refl_on lp:a lp:eqA)}} + {{ lp:IR lp:a (@eqb_refl_on lp:a lp:eqA)}} + {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAr). + +add-indu-refl _T Indu IR LS {{ fun x => lp:(R x) }} :- + std.assert! (param1-inhab-db IR Is_full) "not trivially inhabited", + @pi-decl `x` _ x\ + std.append LS [x, app[Is_full,x]] (Args x), + R x = app [Indu, _ | Args x]. + }}. Elpi Typecheck. -Set Printing All. Elpi eqcorrect list. -Print list_eqb_correct. - -Lemma eqb_refl_on_nil A (eqA : A -> A -> bool) : eqb_refl_on (list_eqb eqA) [::]. -Proof. - refine ( - (@eqb_body_refl _ _ _ _ (@list_eqb_fields A eqA (list_eqb eqA)) _) _). - eqb_refl_on__solver. -Qed. - -Lemma eqb_refl_on_cons A (eqA : A -> A -> bool): - forall a, eqb_refl_on eqA a -> - forall l, eqb_refl_on (list_eqb eqA) l -> - eqb_refl_on (list_eqb eqA) (a :: l). -Proof. - refine (fun a ha l hl => - (@eqb_body_refl _ _ _ _ (@list_eqb_fields A eqA (list_eqb eqA)) _) _). - eqb_refl_on__solver. -Qed. - - -Lemma list_eqb_refl (A:Type) (eqA: A -> A -> bool) (eqAr : @eqb_reflexive A eqA) - (x:list A) : eqb_refl_on (list_eqb eqA) x. -Proof. - refine (@list_induction _ _ _ - (@eqb_refl_on_nil A eqA) - (@eqb_refl_on_cons A eqA) - x (@list_is_list_full _ _ eqAr x)). -Qed. +Print list_eqb_refl. +Print list_eqb_correct_on_cons. Lemma list_eqbP (A:Type) (eqA: A -> A -> bool) (eqAc : eqb_correct eqA) From 7f18ea0a6dac36aa3d1f97dab92ef45eae1e03d3 Mon Sep 17 00:00:00 2001 From: Benjamin Gregoire Date: Sat, 11 Dec 2021 09:05:15 +0100 Subject: [PATCH 28/40] list_eqbP automatically added --- src/list_defs.v | 51 +++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 41 insertions(+), 10 deletions(-) diff --git a/src/list_defs.v b/src/list_defs.v index 6182ab2..395349f 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -46,14 +46,27 @@ eqb.main I Prefix [] :- std.do! [ std.map2 KTs Ks (add-decl-refl Prefix N) Lt-refl, induction-db I Indu, reali (global (indt I)) IR, % param1-db, really + add-indu-correct TI Indu IR Lt-correct R, std.assert-ok! (coq.typecheck R Ty) "fail demande a JC", Name is Prefix ^ "eqb_correct", - coq.env.add-const Name R Ty @opaque! _, + coq.env.add-const Name R Ty @opaque! Correct, + add-indu-refl TI Indu IR Lt-refl Rr, std.assert-ok! (coq.typecheck Rr Tyr) "fail demande a JC", Namer is Prefix ^ "eqb_refl", - coq.env.add-const Namer Rr Tyr @opaque! _, + coq.env.add-const Namer Rr Tyr @opaque! Refl, + + add-reflect TI (global (const Correct)) (global (const Refl)) Breflect, + std.assert-ok! (coq.typecheck Breflect Treflect) "fail demande a JC", + Namerf is Prefix ^ "eqb_reflect", + coq.env.add-const Namerf Breflect Treflect @opaque! Reflect, + + add-eqP TI (global (indt I)) (global (const Reflect)) BeqP, + std.assert-ok! (coq.typecheck BeqP TeqP) "fail demande a JC", + NameeqP is Prefix ^ "eqbP", + coq.env.add-const NameeqP BeqP TeqP @opaque! _EqP, + ]. /************************** correct *********************************************/ @@ -162,15 +175,33 @@ add-indu-refl _T Indu IR LS {{ fun x => lp:(R x) }} :- std.append LS [x, app[Is_full,x]] (Args x), R x = app [Indu, _ | Args x]. +/***************************** Equality *************************************/ + +pred add-reflect i:term, i:term, i:term, o:term. +add-reflect (prod N T F) Correct Refl + {{fun (a:lp:T) (eqA:a -> a -> bool) (H: forall x1 x2, reflect (x1 = x2) (eqA x1 x2)) => lp:(R a eqA H) }} :- !, +@pi-decl N T a\ +@pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ +@pi-decl `H` {{ forall x1 x2, reflect (x1 = x2) (lp:eqA x1 x2)}} H\ +add-reflect (F a) + {{lp:Correct lp:a lp:eqA (fun (a1 a2 : lp:a) => @elimT (@eq lp:a a1 a2) (lp:eqA a1 a2) (lp:H a1 a2))}} + {{lp:Refl lp:a lp:eqA (fun (a1: lp:a) => @introT (@eq lp:a a1 a1) (lp:eqA a1 a1) (lp:H a1 a1) (@erefl lp:a a1))}} + (R a eqA H). + +add-reflect _T Correct Refl {{iffP2 lp:Correct lp:Refl}}. + +pred add-eqP i:term, i:term, i:term, o:term. +add-eqP (prod N T F) Ty Reflect {{fun (a:eqType) => lp:(R a)}} :- !, + @pi-decl N {{eqType}} a\ + eqb-for {{Equality.sort lp:a}} {{@eq_op lp:a}} => + add-eqP (F a) + {{lp:Ty (Equality.sort lp:a)}} + {{lp:Reflect (Equality.sort lp:a) (@eq_op lp:a) (@eqP lp:a)}} (R a). + +add-eqP _ Ty Reflect {{lp:Reflect : Equality.axiom lp:Cmp}} :- + eqb-for Ty Cmp. + }}. Elpi Typecheck. Elpi eqcorrect list. -Print list_eqb_refl. -Print list_eqb_correct_on_cons. - -Lemma list_eqbP (A:Type) (eqA: A -> A -> bool) - (eqAc : eqb_correct eqA) - (eqAr : eqb_reflexive eqA) -: forall (x1 x2 : list A), reflect (x1 = x2) (list_eqb eqA x1 x2). -Proof. refine (iffP2 (list_eqb_correct eqAc) (list_eqb_refl eqAr)). Qed. From 37f843cc568f13581d05faaa80365d02f8612485 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 13 Dec 2021 11:24:12 +0100 Subject: [PATCH 29/40] cleanup + CS declaration --- Makefile.coq.local | 4 +- _CoqProject | 4 +- src/eqbP.elpi | 48 +++++++++++ src/eqbP.v | 15 ++++ src/eqbcorrect.elpi | 134 +++++++++++++++++++++++++++++ src/eqbcorrect.v | 42 +++++++++ src/list_defs.v | 205 ++------------------------------------------ 7 files changed, 253 insertions(+), 199 deletions(-) create mode 100644 src/eqbP.elpi create mode 100644 src/eqbP.v create mode 100644 src/eqbcorrect.elpi create mode 100644 src/eqbcorrect.v diff --git a/Makefile.coq.local b/Makefile.coq.local index 4fd4d73..b1c7a79 100644 --- a/Makefile.coq.local +++ b/Makefile.coq.local @@ -1,3 +1,5 @@ src/tag.vo : src/tag.elpi src/fields.vo : src/fields.elpi -src/eqb.vo : src/eqb.elpi src/fields.elpi \ No newline at end of file +src/eqb.vo : src/eqb.elpi src/fields.elpi +src/eqbcorrect.vo : src/eqbcorrect.elpi src/fields.elpi src/eqb.elpi +src/eqbP.vo : src/eqbP.elpi src/eqbcorrect.elpi src/fields.elpi src/eqb.elpi \ No newline at end of file diff --git a/_CoqProject b/_CoqProject index 2ced6c4..d574a20 100644 --- a/_CoqProject +++ b/_CoqProject @@ -20,4 +20,6 @@ src/nested_list_defs.v src/large_defs.v src/tag.v src/fields.v -src/eqb.v \ No newline at end of file +src/eqb.v +src/eqbcorrect.v +src/eqbP.v \ No newline at end of file diff --git a/src/eqbP.elpi b/src/eqbP.elpi new file mode 100644 index 0000000..c86b7de --- /dev/null +++ b/src/eqbP.elpi @@ -0,0 +1,48 @@ +namespace eqbP { + +pred add-reflect i:term, i:term, i:term, o:term. +add-reflect (prod N T F) Correct Refl + {{fun (a:lp:T) (eqA:a -> a -> bool) (H: forall x1 x2, reflect (x1 = x2) (eqA x1 x2)) => lp:(R a eqA H) }} :- !, +@pi-decl N T a\ +@pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ +@pi-decl `H` {{ forall x1 x2, reflect (x1 = x2) (lp:eqA x1 x2)}} H\ +add-reflect (F a) + {{lp:Correct lp:a lp:eqA (fun (a1 a2 : lp:a) => @elimT (@eq lp:a a1 a2) (lp:eqA a1 a2) (lp:H a1 a2))}} + {{lp:Refl lp:a lp:eqA (fun (a1: lp:a) => @introT (@eq lp:a a1 a1) (lp:eqA a1 a1) (lp:H a1 a1) (@erefl lp:a a1))}} + (R a eqA H). + +add-reflect _T Correct Refl {{iffP2 lp:Correct lp:Refl}}. + +pred add-eqP i:term, i:term, i:term, o:term. +add-eqP (prod N T F) Ty Reflect {{fun (a:eqType) => lp:(R a)}} :- !, + @pi-decl N {{eqType}} a\ + eqb-for {{Equality.sort lp:a}} {{@eq_op lp:a}} => + add-eqP (F a) + {{lp:Ty (Equality.sort lp:a)}} + {{lp:Reflect (Equality.sort lp:a) (@eq_op lp:a) (@eqP lp:a)}} (R a). + +add-eqP _ Ty Reflect {{ @Equality.Pack lp:Ty (@Equality.Mixin lp:Ty lp:Cmp lp:Reflect) }} :- + eqb-for Ty Cmp. + +pred main i:inductive, i:string, o:list prop. +main I Prefix [] :- std.do! [ + % Add error msg if not a inductive ? + coq.env.indt I _ _ N TI Ks KTs, + + std.assert! (eqcorrect-for I Correct Refl) "run eqcorrect before", + + add-reflect TI (global (const Correct)) (global (const Refl)) Breflect, + std.assert-ok! (coq.typecheck Breflect Treflect) "fail demande a JC", + Namerf is Prefix ^ "eqb_reflect", + coq.env.add-const Namerf Breflect Treflect @transparent! Reflect, + + add-eqP TI (global (indt I)) (global (const Reflect)) BeqP, + std.assert-ok! (coq.typecheck BeqP TeqP) "fail demande a JC", + NameeqP is Prefix ^ "eqbP", + coq.env.add-const NameeqP BeqP TeqP @transparent! EqP, + + coq.CS.declare-instance (const EqP), + +]. + +} diff --git a/src/eqbP.v b/src/eqbP.v new file mode 100644 index 0000000..36662e4 --- /dev/null +++ b/src/eqbP.v @@ -0,0 +1,15 @@ +Require Import core_defs. +Require Export eqb eqbcorrect. +From mathcomp Require Import ssreflect ssrfun ssrbool eqtype. + +Elpi Command eqbP. +Elpi Accumulate Db eqcorrect.db. +Elpi Accumulate Db eqb.db. +Elpi Accumulate File "src/eqbP.elpi". +Elpi Accumulate lp:{{ + main [str S] :- + std.assert! (coq.locate S (indt I)) "Not an inductive type", + Prefix is S ^ "_", + eqbP.main I Prefix _. +}}. +Elpi Typecheck. diff --git a/src/eqbcorrect.elpi b/src/eqbcorrect.elpi new file mode 100644 index 0000000..3caab3e --- /dev/null +++ b/src/eqbcorrect.elpi @@ -0,0 +1,134 @@ + +namespace eqbcorrect { + +pred main i:inductive, i:string, o:list prop. +main I Prefix [CL] :- std.do! [ + % Add error msg if not a inductive ? + coq.env.indt I _ _ N TI Ks KTs, + std.map2 KTs Ks (add-decl-correct Prefix N) Lt-correct, + std.map2 KTs Ks (add-decl-refl Prefix N) Lt-refl, + induction-db I Indu, + reali (global (indt I)) IR, % param1-db, really + + add-indu-correct TI Indu IR Lt-correct R, + std.assert-ok! (coq.typecheck R Ty) "fail demande a JC", + Name is Prefix ^ "eqb_correct", + coq.env.add-const Name R Ty @opaque! Correct, + + add-indu-refl TI Indu IR Lt-refl Rr, + std.assert-ok! (coq.typecheck Rr Tyr) "fail demande a JC", + Namer is Prefix ^ "eqb_refl", + coq.env.add-const Namer Rr Tyr @opaque! Refl, + + CL = eqcorrect-for I Correct Refl, + coq.elpi.accumulate _ "eqcorrect.db" (clause _ _ CL), + +]. + +/************************** correct *********************************************/ + +pred add-decl-correct i:string, i:int, i:term, i:constructor, o:term. +add-decl-correct Prefix N KT K (global (const P)) :- std.do![ + do-params-correct N KT (global (indc K)) R, + std.assert-ok! (coq.typecheck R Ty) "R casse", + Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)}, + coq.env.add-const Name R Ty @opaque! P, +]. + +% forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. +% T : Type |- T -> list T -> list T ---> +pred do-params-correct i:int, i:term, i:term, o:term. +do-params-correct NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, + @pi-decl N T a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + eqb-for a eqA => + do-params-correct NP1 (F a) {{ lp:K lp:a }} (R a eqA). +do-params-correct 0 T K R :- do-args-correct T K R. + +pred do-args-correct i:term, i:term, o:term. +do-args-correct (prod N T F) K {{ fun (x : lp:T) (Px : eqb_correct_on lp:Cmp x) => lp:(R x Px) }} :- !, + eqb-for T Cmp, + @pi-decl N T x\ + @pi-decl `px` {{ eqb_correct_on lp:Cmp lp:x }} px\ + do-args-correct (F x) {{ lp:K lp:x }} (R x px). +do-args-correct T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ + eqb-for T Cmp, + coq.safe-dest-app T (global (indt I)) Args, + fields-for I _ _ _ ConstructPC, + coq.mk-app (global (const ConstructPC)) Args ConstructP, + eqb-fields T Fields, + B = {{ @eqb_body_correct _ _ _ _ _ lp:ConstructP lp:Fields lp:K (fun f => _) }}, + coq.typecheck {{ lp:B : eqb_correct_on lp:Cmp lp:K }} _ _, + coq.ltac.collect-goals B [G] _, + std.assert! (coq.ltac.open (coq.ltac.call "eqb_correct_on__solver" []) G []) "solver broken", +]. + +pred add-indu-correct i:term, i:term, i:term, i:list term, o:term. +add-indu-correct (prod N T F) Indu IR LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_correct eqA) => lp:(R a eqA eqAc) }} :- !, + @pi-decl N T a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + @pi-decl `eqAc` {{ @eqb_correct lp:a lp:eqA }} eqAc\ % super nasty "bug", the _ does not see a, if you write lp:{{ FOO a }} it works. Elaborating the skeleton is also ok, but then param1-inhab-db does not work well :-/ + param1-inhab-db {{ @eqb_correct_on lp:a lp:eqA }} eqAc => + add-indu-correct (F a) + {{ lp:Indu lp:a (@eqb_correct_on lp:a lp:eqA)}} + {{ lp:IR lp:a (@eqb_correct_on lp:a lp:eqA)}} + {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAc). + +add-indu-correct _T Indu IR LS {{ fun x => lp:(R x) }} :- + std.assert! (param1-inhab-db IR Is_full) "not trivially inhabited", + @pi-decl `x` _ x\ + std.append LS [x, app[Is_full,x]] (Args x), + R x = app [Indu, _ | Args x]. + +/******************************** Refl **************************************************************/ +pred add-decl-refl i:string, i:int, i:term, i:constructor, o:term. +add-decl-refl Prefix N KT K (global (const P)) :- std.do![ + do-params-refl N KT (global (indc K)) R, + std.assert-ok! (coq.typecheck R Ty) "R casse", + Name is Prefix ^ "eqb_refl_on_" ^ {coq.gref->id (indc K)}, + coq.env.add-const Name R Ty @opaque! P, +]. + +% forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. +% T : Type |- T -> list T -> list T ---> +pred do-params-refl i:int, i:term, i:term, o:term. +do-params-refl NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, + @pi-decl N T a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + eqb-for a eqA => + do-params-refl NP1 (F a) {{ lp:K lp:a }} (R a eqA). +do-params-refl 0 T K R :- do-args-refl T K R. + +pred do-args-refl i:term, i:term, o:term. +do-args-refl (prod N T F) K {{ fun (x : lp:T) (Px : eqb_refl_on lp:Cmp x) => lp:(R x Px) }} :- !, + eqb-for T Cmp, + @pi-decl N T x\ + @pi-decl `px` {{ eqb_refl_on lp:Cmp lp:x }} px\ + do-args-refl (F x) {{ lp:K lp:x }} (R x px). +do-args-refl T K {{ lp:B : eqb_refl_on lp:Cmp lp:K }} :- std.do! [ + eqb-for T Cmp, + eqb-fields T Fields, + B = {{ @eqb_body_refl _ _ _ _ lp:Fields lp:K _ }}, + coq.typecheck {{ lp:B : eqb_refl_on lp:Cmp lp:K }} _ _, + coq.ltac.collect-goals B [G] _, + std.assert! (coq.ltac.open (coq.ltac.call "eqb_refl_on__solver" []) G []) "solver broken", +]. + +pred add-indu-refl i:term, i:term, i:term, i:list term, o:term. +add-indu-refl (prod N T F) Indu IR LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_reflexive eqA) => lp:(R a eqA eqAc) }} :- !, + @pi-decl N T a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + @pi-decl `eqAr` {{ @eqb_reflexive lp:a lp:eqA }} eqAr\ % super nasty "bug", the _ does not see a, if you write lp:{{ FOO a }} it works. Elaborating the skeleton is also ok, but then param1-inhab-db does not work well :-/ + param1-inhab-db {{ @eqb_refl_on lp:a lp:eqA }} eqAr => + add-indu-refl (F a) + {{ lp:Indu lp:a (@eqb_refl_on lp:a lp:eqA)}} + {{ lp:IR lp:a (@eqb_refl_on lp:a lp:eqA)}} + {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAr). + +add-indu-refl _T Indu IR LS {{ fun x => lp:(R x) }} :- + std.assert! (param1-inhab-db IR Is_full) "not trivially inhabited", + @pi-decl `x` _ x\ + std.append LS [x, app[Is_full,x]] (Args x), + R x = app [Indu, _ | Args x]. + +} diff --git a/src/eqbcorrect.v b/src/eqbcorrect.v new file mode 100644 index 0000000..593ab49 --- /dev/null +++ b/src/eqbcorrect.v @@ -0,0 +1,42 @@ +From elpi Require Import elpi. +From elpi.apps Require Import derive. + +From Coq Require Import PArith ssreflect ssrfun ssrbool. +Open Scope positive_scope. + +Require Import core_defs. +Require Export tag fields eqb. + +Export ssreflect ssrbool ssrfun. (* otherwise the tactic fails *) +Ltac eqb_correct_on__solver := + by repeat (try case/andP; match reverse goal with H : @eqb_correct_on _ _ _ |- _ => move=> /=/H{H}-> end). +Ltac eqb_refl_on__solver := + rewrite /eqb_fields_refl_on /=; + repeat + (reflexivity || apply/andP; split; assumption). + +Elpi Db eqcorrect.db lp:{{ + + pred eqcorrect-for + o:inductive, + o:constant, % correct + o:constant. % reflexive + +}}. + +Elpi Command eqbcorrect. +Elpi Accumulate Db eqb.db. +Elpi Accumulate Db fields.db. +Elpi Accumulate Db eqcorrect.db. +Elpi Accumulate Db derive.induction.db. +Elpi Accumulate Db derive.param1.db. +Elpi Accumulate Db derive.param1.inhab.db. +Elpi Accumulate File "src/elpi-ltac.elpi". +Elpi Accumulate File "src/eqbcorrect.elpi". +Elpi Accumulate lp:{{ + main [str S] :- + std.assert! (coq.locate S (indt I)) "Not an inductive type", + Prefix is S ^ "_", + eqbcorrect.main I Prefix _. +}}. +Elpi Typecheck. diff --git a/src/list_defs.v b/src/list_defs.v index 395349f..dc7ed4d 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -1,5 +1,5 @@ From elpi.apps Require Import derive. -Require Import core_defs tag fields eqb. +Require Import core_defs tag fields eqb eqbcorrect eqbP. Set Implicit Arguments. @@ -7,201 +7,12 @@ Set Implicit Arguments. Elpi tag list. Elpi fields list. Elpi eqb list. +Elpi eqbcorrect list. +Elpi eqbP list. -From mathcomp Require Import all_ssreflect. -Require Import PArith. -Open Scope positive_scope. -Ltac eqb_correct_on__solver := - by repeat (try case/andP; match reverse goal with H : eqb_correct_on _ _ |- _ => move=> /=/H{H}-> end). - -Ltac eqb_refl_on__solver := - rewrite /eqb_fields_refl_on /=; - repeat - (reflexivity || apply/andP; split; assumption). - - -(* TODO: move to a file *) -Elpi Command eqcorrect. -Elpi Accumulate Db eqb.db. -Elpi Accumulate Db fields.db. -Elpi Accumulate Db derive.induction.db. -Elpi Accumulate Db derive.param1.db. -Elpi Accumulate Db derive.param1.inhab.db. -Elpi Accumulate File "src/elpi-ltac.elpi". - -Elpi Accumulate lp:{{ - - main [str S] :- - std.assert! (coq.locate S (indt I)) "Not an inductive type", - Prefix is S ^ "_", - eqb.main I Prefix _. - - -pred eqb.main i:inductive, i:string, o:list prop. -eqb.main I Prefix [] :- std.do! [ - % Add error msg if not a inductive ? - coq.env.indt I _ _ N TI Ks KTs, - std.map2 KTs Ks (add-decl-correct Prefix N) Lt-correct, - std.map2 KTs Ks (add-decl-refl Prefix N) Lt-refl, - induction-db I Indu, - reali (global (indt I)) IR, % param1-db, really - - add-indu-correct TI Indu IR Lt-correct R, - std.assert-ok! (coq.typecheck R Ty) "fail demande a JC", - Name is Prefix ^ "eqb_correct", - coq.env.add-const Name R Ty @opaque! Correct, - - add-indu-refl TI Indu IR Lt-refl Rr, - std.assert-ok! (coq.typecheck Rr Tyr) "fail demande a JC", - Namer is Prefix ^ "eqb_refl", - coq.env.add-const Namer Rr Tyr @opaque! Refl, - - add-reflect TI (global (const Correct)) (global (const Refl)) Breflect, - std.assert-ok! (coq.typecheck Breflect Treflect) "fail demande a JC", - Namerf is Prefix ^ "eqb_reflect", - coq.env.add-const Namerf Breflect Treflect @opaque! Reflect, - - add-eqP TI (global (indt I)) (global (const Reflect)) BeqP, - std.assert-ok! (coq.typecheck BeqP TeqP) "fail demande a JC", - NameeqP is Prefix ^ "eqbP", - coq.env.add-const NameeqP BeqP TeqP @opaque! _EqP, - -]. - -/************************** correct *********************************************/ - -pred add-decl-correct i:string, i:int, i:term, i:constructor, o:term. -add-decl-correct Prefix N KT K (global (const P)) :- std.do![ - do-params-correct N KT (global (indc K)) R, - std.assert-ok! (coq.typecheck R Ty) "R casse", - Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)}, - coq.env.add-const Name R Ty @opaque! P, -]. - -% forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. -% T : Type |- T -> list T -> list T ---> -pred do-params-correct i:int, i:term, i:term, o:term. -do-params-correct NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, - @pi-decl N T a\ - @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ - eqb-for a eqA => - do-params-correct NP1 (F a) {{ lp:K lp:a }} (R a eqA). -do-params-correct 0 T K R :- do-args-correct T K R. - -pred do-args-correct i:term, i:term, o:term. -do-args-correct (prod N T F) K {{ fun (x : lp:T) (Px : eqb_correct_on lp:Cmp x) => lp:(R x Px) }} :- !, - eqb-for T Cmp, - @pi-decl N T x\ - @pi-decl `px` {{ eqb_correct_on lp:Cmp lp:x }} px\ - do-args-correct (F x) {{ lp:K lp:x }} (R x px). -do-args-correct T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ - eqb-for T Cmp, - coq.safe-dest-app T (global (indt I)) Args, - fields-for I _ _ _ ConstructPC, - coq.mk-app (global (const ConstructPC)) Args ConstructP, - eqb-fields T Fields, - B = {{ @eqb_body_correct _ _ _ _ _ lp:ConstructP lp:Fields lp:K (fun f => _) }}, - coq.typecheck {{ lp:B : eqb_correct_on lp:Cmp lp:K }} _ _, - coq.ltac.collect-goals B [G] _, - coq.ltac.open (coq.ltac.call "eqb_correct_on__solver" []) G [], -]. - -pred add-indu-correct i:term, i:term, i:term, i:list term, o:term. -add-indu-correct (prod N T F) Indu IR LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_correct eqA) => lp:(R a eqA eqAc) }} :- !, - @pi-decl N T a\ - @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ - @pi-decl `eqAc` {{ @eqb_correct lp:a lp:eqA }} eqAc\ % super nasty "bug", the _ does not see a, if you write lp:{{ FOO a }} it works. Elaborating the skeleton is also ok, but then param1-inhab-db does not work well :-/ - param1-inhab-db {{ @eqb_correct_on lp:a lp:eqA }} eqAc => - add-indu-correct (F a) - {{ lp:Indu lp:a (@eqb_correct_on lp:a lp:eqA)}} - {{ lp:IR lp:a (@eqb_correct_on lp:a lp:eqA)}} - {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAc). - -add-indu-correct _T Indu IR LS {{ fun x => lp:(R x) }} :- - std.assert! (param1-inhab-db IR Is_full) "not trivially inhabited", - @pi-decl `x` _ x\ - std.append LS [x, app[Is_full,x]] (Args x), - R x = app [Indu, _ | Args x]. - -/******************************** Refl **************************************************************/ -pred add-decl-refl i:string, i:int, i:term, i:constructor, o:term. -add-decl-refl Prefix N KT K (global (const P)) :- std.do![ - do-params-refl N KT (global (indc K)) R, - std.assert-ok! (coq.typecheck R Ty) "R casse", - Name is Prefix ^ "eqb_refl_on_" ^ {coq.gref->id (indc K)}, - coq.env.add-const Name R Ty @opaque! P, -]. - -% forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. -% T : Type |- T -> list T -> list T ---> -pred do-params-refl i:int, i:term, i:term, o:term. -do-params-refl NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, - @pi-decl N T a\ - @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ - eqb-for a eqA => - do-params-refl NP1 (F a) {{ lp:K lp:a }} (R a eqA). -do-params-refl 0 T K R :- do-args-refl T K R. - -pred do-args-refl i:term, i:term, o:term. -do-args-refl (prod N T F) K {{ fun (x : lp:T) (Px : eqb_refl_on lp:Cmp x) => lp:(R x Px) }} :- !, - eqb-for T Cmp, - @pi-decl N T x\ - @pi-decl `px` {{ eqb_refl_on lp:Cmp lp:x }} px\ - do-args-refl (F x) {{ lp:K lp:x }} (R x px). -do-args-refl T K {{ lp:B : eqb_refl_on lp:Cmp lp:K }} :- std.do! [ - eqb-for T Cmp, - eqb-fields T Fields, - B = {{ @eqb_body_refl _ _ _ _ lp:Fields lp:K _ }}, - coq.typecheck {{ lp:B : eqb_refl_on lp:Cmp lp:K }} _ _, - coq.ltac.collect-goals B [G] _, - coq.ltac.open (coq.ltac.call "eqb_refl_on__solver" []) G [], -]. - -pred add-indu-refl i:term, i:term, i:term, i:list term, o:term. -add-indu-refl (prod N T F) Indu IR LS {{ fun (a : lp:T) (eqA : a -> a -> bool) (eqAc : eqb_reflexive eqA) => lp:(R a eqA eqAc) }} :- !, - @pi-decl N T a\ - @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ - @pi-decl `eqAr` {{ @eqb_reflexive lp:a lp:eqA }} eqAr\ % super nasty "bug", the _ does not see a, if you write lp:{{ FOO a }} it works. Elaborating the skeleton is also ok, but then param1-inhab-db does not work well :-/ - param1-inhab-db {{ @eqb_refl_on lp:a lp:eqA }} eqAr => - add-indu-refl (F a) - {{ lp:Indu lp:a (@eqb_refl_on lp:a lp:eqA)}} - {{ lp:IR lp:a (@eqb_refl_on lp:a lp:eqA)}} - {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA eqAr). - -add-indu-refl _T Indu IR LS {{ fun x => lp:(R x) }} :- - std.assert! (param1-inhab-db IR Is_full) "not trivially inhabited", - @pi-decl `x` _ x\ - std.append LS [x, app[Is_full,x]] (Args x), - R x = app [Indu, _ | Args x]. - -/***************************** Equality *************************************/ - -pred add-reflect i:term, i:term, i:term, o:term. -add-reflect (prod N T F) Correct Refl - {{fun (a:lp:T) (eqA:a -> a -> bool) (H: forall x1 x2, reflect (x1 = x2) (eqA x1 x2)) => lp:(R a eqA H) }} :- !, -@pi-decl N T a\ -@pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ -@pi-decl `H` {{ forall x1 x2, reflect (x1 = x2) (lp:eqA x1 x2)}} H\ -add-reflect (F a) - {{lp:Correct lp:a lp:eqA (fun (a1 a2 : lp:a) => @elimT (@eq lp:a a1 a2) (lp:eqA a1 a2) (lp:H a1 a2))}} - {{lp:Refl lp:a lp:eqA (fun (a1: lp:a) => @introT (@eq lp:a a1 a1) (lp:eqA a1 a1) (lp:H a1 a1) (@erefl lp:a a1))}} - (R a eqA H). - -add-reflect _T Correct Refl {{iffP2 lp:Correct lp:Refl}}. - -pred add-eqP i:term, i:term, i:term, o:term. -add-eqP (prod N T F) Ty Reflect {{fun (a:eqType) => lp:(R a)}} :- !, - @pi-decl N {{eqType}} a\ - eqb-for {{Equality.sort lp:a}} {{@eq_op lp:a}} => - add-eqP (F a) - {{lp:Ty (Equality.sort lp:a)}} - {{lp:Reflect (Equality.sort lp:a) (@eq_op lp:a) (@eqP lp:a)}} (R a). - -add-eqP _ Ty Reflect {{lp:Reflect : Equality.axiom lp:Cmp}} :- - eqb-for Ty Cmp. - -}}. -Elpi Typecheck. - -Elpi eqcorrect list. +From mathcomp Require Import ssrnat eqtype. +Goal (cons 1 nil == nil). +unfold eq_op. +unfold list_eqbP, list_eqb. +Abort. From c94adcfd492855910bbc734b58c2dbf50ea0bf58 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 13 Dec 2021 11:39:18 +0100 Subject: [PATCH 30/40] fix solver --- src/eqbcorrect.elpi | 17 +++++++++++++++-- src/eqbcorrect.v | 3 +-- src/list_defs.v | 9 ++++++++- 3 files changed, 24 insertions(+), 5 deletions(-) diff --git a/src/eqbcorrect.elpi b/src/eqbcorrect.elpi index 3caab3e..30e667c 100644 --- a/src/eqbcorrect.elpi +++ b/src/eqbcorrect.elpi @@ -25,6 +25,19 @@ main I Prefix [CL] :- std.do! [ ]. +pred run-solver i:sealed-goal, i:string. +run-solver G Name :- + if (coq.ltac.open (coq.ltac.call Name []) G []) true + (coq.sealed-goal->string G SG, + std.fatal-error {calc ( "solver " ^ Name ^ " fails on goal:\n" ^ SG )}). + +coq.sealed-goal->string (nabla G) R :- pi x\ coq.sealed-goal->string (G x) R. +coq.sealed-goal->string (seal (goal Ctx _ Ty _ _)) R :- + Ctx => (std.map {std.rev Ctx} coq.ctx->string L, coq.term->string Ty G, R is {std.string.concat "\n" L} ^ "\n===============\n" ^ G). + +coq.ctx->string (decl X _ Ty) R :- R is {coq.term->string X} ^ " : " ^ {coq.term->string Ty}. +coq.ctx->string (def X _ Ty B) R :- R is {coq.term->string X} ^ " : " ^ {coq.term->string Ty} ^ " := " ^ {coq.term->string B}. + /************************** correct *********************************************/ pred add-decl-correct i:string, i:int, i:term, i:constructor, o:term. @@ -60,7 +73,7 @@ do-args-correct T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ B = {{ @eqb_body_correct _ _ _ _ _ lp:ConstructP lp:Fields lp:K (fun f => _) }}, coq.typecheck {{ lp:B : eqb_correct_on lp:Cmp lp:K }} _ _, coq.ltac.collect-goals B [G] _, - std.assert! (coq.ltac.open (coq.ltac.call "eqb_correct_on__solver" []) G []) "solver broken", + run-solver G "eqb_correct_on__solver", ]. pred add-indu-correct i:term, i:term, i:term, i:list term, o:term. @@ -111,7 +124,7 @@ do-args-refl T K {{ lp:B : eqb_refl_on lp:Cmp lp:K }} :- std.do! [ B = {{ @eqb_body_refl _ _ _ _ lp:Fields lp:K _ }}, coq.typecheck {{ lp:B : eqb_refl_on lp:Cmp lp:K }} _ _, coq.ltac.collect-goals B [G] _, - std.assert! (coq.ltac.open (coq.ltac.call "eqb_refl_on__solver" []) G []) "solver broken", + run-solver G "eqb_refl_on__solver", ]. pred add-indu-refl i:term, i:term, i:term, i:list term, o:term. diff --git a/src/eqbcorrect.v b/src/eqbcorrect.v index 593ab49..8787b97 100644 --- a/src/eqbcorrect.v +++ b/src/eqbcorrect.v @@ -12,8 +12,7 @@ Ltac eqb_correct_on__solver := by repeat (try case/andP; match reverse goal with H : @eqb_correct_on _ _ _ |- _ => move=> /=/H{H}-> end). Ltac eqb_refl_on__solver := rewrite /eqb_fields_refl_on /=; - repeat - (reflexivity || apply/andP; split; assumption). + by repeat (reflexivity || apply/andP; split; assumption). Elpi Db eqcorrect.db lp:{{ diff --git a/src/list_defs.v b/src/list_defs.v index dc7ed4d..75e73e4 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -11,7 +11,14 @@ Elpi eqbcorrect list. Elpi eqbP list. -From mathcomp Require Import ssrnat eqtype. +#[only(induction,param1_full,param1_trivial)] derive nat. +Elpi tag nat. +Elpi fields nat. +Elpi eqb nat. +Elpi eqbcorrect nat. +Elpi eqbP nat. + +From mathcomp Require Import eqtype. Goal (cons 1 nil == nil). unfold eq_op. unfold list_eqbP, list_eqb. From 7d6cbad182690a24e5fd1bf81641609de579bc23 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 13 Dec 2021 13:12:50 +0100 Subject: [PATCH 31/40] wip --- src/eqbcorrect.elpi | 23 +- src/large_defs.v | 668 +------------------------------------------- src/list_defs.v | 6 +- src/nested_defs.v | 29 +- src/option_defs.v | 105 +------ 5 files changed, 60 insertions(+), 771 deletions(-) diff --git a/src/eqbcorrect.elpi b/src/eqbcorrect.elpi index 30e667c..efb2b6b 100644 --- a/src/eqbcorrect.elpi +++ b/src/eqbcorrect.elpi @@ -5,8 +5,14 @@ pred main i:inductive, i:string, o:list prop. main I Prefix [CL] :- std.do! [ % Add error msg if not a inductive ? coq.env.indt I _ _ N TI Ks KTs, + + coq.say {gettimeofday} "0", + std.map2 KTs Ks (add-decl-correct Prefix N) Lt-correct, std.map2 KTs Ks (add-decl-refl Prefix N) Lt-refl, + + coq.say {gettimeofday} "1", + induction-db I Indu, reali (global (indt I)) IR, % param1-db, really @@ -15,11 +21,15 @@ main I Prefix [CL] :- std.do! [ Name is Prefix ^ "eqb_correct", coq.env.add-const Name R Ty @opaque! Correct, + coq.say {gettimeofday} "2", + add-indu-refl TI Indu IR Lt-refl Rr, std.assert-ok! (coq.typecheck Rr Tyr) "fail demande a JC", Namer is Prefix ^ "eqb_refl", coq.env.add-const Namer Rr Tyr @opaque! Refl, + coq.say {gettimeofday} "3", + CL = eqcorrect-for I Correct Refl, coq.elpi.accumulate _ "eqcorrect.db" (clause _ _ CL), @@ -41,11 +51,12 @@ coq.ctx->string (def X _ Ty B) R :- R is {coq.term->string X} ^ " : " ^ {coq.ter /************************** correct *********************************************/ pred add-decl-correct i:string, i:int, i:term, i:constructor, o:term. -add-decl-correct Prefix N KT K (global (const P)) :- std.do![ +add-decl-correct Prefix N KT K R /*(global (const P))*/ :- std.do![ do-params-correct N KT (global (indc K)) R, std.assert-ok! (coq.typecheck R Ty) "R casse", - Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)}, - coq.env.add-const Name R Ty @opaque! P, + % Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)}, + % coq.env.add-const Name R Ty @opaque! P, + % coq.say {gettimeofday} ".", ]. % forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. @@ -95,11 +106,11 @@ add-indu-correct _T Indu IR LS {{ fun x => lp:(R x) }} :- /******************************** Refl **************************************************************/ pred add-decl-refl i:string, i:int, i:term, i:constructor, o:term. -add-decl-refl Prefix N KT K (global (const P)) :- std.do![ +add-decl-refl Prefix N KT K R /*(global (const P))*/ :- std.do![ do-params-refl N KT (global (indc K)) R, std.assert-ok! (coq.typecheck R Ty) "R casse", - Name is Prefix ^ "eqb_refl_on_" ^ {coq.gref->id (indc K)}, - coq.env.add-const Name R Ty @opaque! P, + % Name is Prefix ^ "eqb_refl_on_" ^ {coq.gref->id (indc K)}, + % coq.env.add-const Name R Ty @opaque! P, ]. % forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. diff --git a/src/large_defs.v b/src/large_defs.v index 691fe18..bac5835 100644 --- a/src/large_defs.v +++ b/src/large_defs.v @@ -1,13 +1,7 @@ -Require Import Eqdep_dec. - -From mathcomp Require Import all_ssreflect. -Require Import core_defs tag. +From elpi.apps Require Import derive. +Require Import core_defs tag fields eqb eqbcorrect eqbP. Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. -Require Import PArith. -Open Scope positive_scope. Inductive t := | T1 @@ -210,655 +204,9 @@ Inductive t := | T198 | T199. -Module AUX. - -Elpi tag t. -Definition tag := t_tag. (* (x : t) := - match x with - | T1 => 1 - | T2 => 2 - | T3 => 3 - | T4 => 4 - | T5 => 5 - | T6 => 6 - | T7 => 7 - | T8 => 8 - | T9 => 9 - | T10 => 10 - | T11 => 11 - | T12 => 12 - | T13 => 13 - | T14 => 14 - | T15 => 15 - | T16 => 16 - | T17 => 17 - | T18 => 18 - | T19 => 19 - | T20 => 20 - | T21 => 21 - | T22 => 22 - | T23 => 23 - | T24 => 24 - | T25 => 25 - | T26 => 26 - | T27 => 27 - | T28 => 28 - | T29 => 29 - | T30 => 30 - | T31 => 31 - | T32 => 32 - | T33 => 33 - | T34 => 34 - | T35 => 35 - | T36 => 36 - | T37 => 37 - | T38 => 38 - | T39 => 39 - | T40 => 40 - | T41 => 41 - | T42 => 42 - | T43 => 43 - | T44 => 44 - | T45 => 45 - | T46 => 46 - | T47 => 47 - | T48 => 48 - | T49 => 49 - | T50 => 50 - | T51 => 51 - | T52 => 52 - | T53 => 53 - | T54 => 54 - | T55 => 55 - | T56 => 56 - | T57 => 57 - | T58 => 58 - | T59 => 59 - | T60 => 60 - | T61 => 61 - | T62 => 62 - | T63 => 63 - | T64 => 64 - | T65 => 65 - | T66 => 66 - | T67 => 67 - | T68 => 68 - | T69 => 69 - | T70 => 70 - | T71 => 71 - | T72 => 72 - | T73 => 73 - | T74 => 74 - | T75 => 75 - | T76 => 76 - | T77 => 77 - | T78 => 78 - | T79 => 79 - | T80 => 80 - | T81 => 81 - | T82 => 82 - | T83 => 83 - | T84 => 84 - | T85 => 85 - | T86 => 86 - | T87 => 87 - | T88 => 88 - | T89 => 89 - | T90 => 90 - | T91 => 91 - | T92 => 92 - | T93 => 93 - | T94 => 94 - | T95 => 95 - | T96 => 96 - | T97 => 97 - | T98 => 98 - | T99 => 99 - | T100 => 100 - | T101 => 101 - | T102 => 102 - | T103 => 103 - | T104 => 104 - | T105 => 105 - | T106 => 106 - | T107 => 107 - | T108 => 108 - | T109 => 109 - | T110 => 110 - | T111 => 111 - | T112 => 112 - | T113 => 113 - | T114 => 114 - | T115 => 115 - | T116 => 116 - | T117 => 117 - | T118 => 118 - | T119 => 119 - | T120 => 120 - | T121 => 121 - | T122 => 122 - | T123 => 123 - | T124 => 124 - | T125 => 125 - | T126 => 126 - | T127 => 127 - | T128 => 128 - | T129 => 129 - | T130 => 130 - | T131 => 131 - | T132 => 132 - | T133 => 133 - | T134 => 134 - | T135 => 135 - | T136 => 136 - | T137 => 137 - | T138 => 138 - | T139 => 139 - | T140 => 140 - | T141 => 141 - | T142 => 142 - | T143 => 143 - | T144 => 144 - | T145 => 145 - | T146 => 146 - | T147 => 147 - | T148 => 148 - | T149 => 149 - | T150 => 150 - | T151 => 151 - | T152 => 152 - | T153 => 153 - | T154 => 154 - | T155 => 155 - | T156 => 156 - | T157 => 157 - | T158 => 158 - | T159 => 159 - | T160 => 160 - | T161 => 161 - | T162 => 162 - | T163 => 163 - | T164 => 164 - | T165 => 165 - | T166 => 166 - | T167 => 167 - | T168 => 168 - | T169 => 169 - | T170 => 170 - | T171 => 171 - | T172 => 172 - | T173 => 173 - | T174 => 174 - | T175 => 175 - | T176 => 176 - | T177 => 177 - | T178 => 178 - | T179 => 179 - | T180 => 180 - | T181 => 181 - | T182 => 182 - | T183 => 183 - | T184 => 184 - | T185 => 185 - | T186 => 186 - | T187 => 187 - | T188 => 188 - | T189 => 189 - | T190 => 190 - | T191 => 191 - | T192 => 192 - | T193 => 193 - | T194 => 194 - | T195 => 195 - | T196 => 196 - | T197 => 197 - | T198 => 198 - | T199 => 199 - end. -*) - -Definition fields_t (p:positive) : Type := unit. - -Definition fields (x:t) : fields_t (tag x) := tt. - -Definition construct (p:positive) : fields_t p -> option t := - match p with - | 1 => fun _ => Some T1 - | 2 => fun _ => Some T2 - | 3 => fun _ => Some T3 - | 4 => fun _ => Some T4 - | 5 => fun _ => Some T5 - | 6 => fun _ => Some T6 - | 7 => fun _ => Some T7 - | 8 => fun _ => Some T8 - | 9 => fun _ => Some T9 - | 10 => fun _ => Some T10 - | 11 => fun _ => Some T11 - | 12 => fun _ => Some T12 - | 13 => fun _ => Some T13 - | 14 => fun _ => Some T14 - | 15 => fun _ => Some T15 - | 16 => fun _ => Some T16 - | 17 => fun _ => Some T17 - | 18 => fun _ => Some T18 - | 19 => fun _ => Some T19 - | 20 => fun _ => Some T20 - | 21 => fun _ => Some T21 - | 22 => fun _ => Some T22 - | 23 => fun _ => Some T23 - | 24 => fun _ => Some T24 - | 25 => fun _ => Some T25 - | 26 => fun _ => Some T26 - | 27 => fun _ => Some T27 - | 28 => fun _ => Some T28 - | 29 => fun _ => Some T29 - | 30 => fun _ => Some T30 - | 31 => fun _ => Some T31 - | 32 => fun _ => Some T32 - | 33 => fun _ => Some T33 - | 34 => fun _ => Some T34 - | 35 => fun _ => Some T35 - | 36 => fun _ => Some T36 - | 37 => fun _ => Some T37 - | 38 => fun _ => Some T38 - | 39 => fun _ => Some T39 - | 40 => fun _ => Some T40 - | 41 => fun _ => Some T41 - | 42 => fun _ => Some T42 - | 43 => fun _ => Some T43 - | 44 => fun _ => Some T44 - | 45 => fun _ => Some T45 - | 46 => fun _ => Some T46 - | 47 => fun _ => Some T47 - | 48 => fun _ => Some T48 - | 49 => fun _ => Some T49 - | 50 => fun _ => Some T50 - | 51 => fun _ => Some T51 - | 52 => fun _ => Some T52 - | 53 => fun _ => Some T53 - | 54 => fun _ => Some T54 - | 55 => fun _ => Some T55 - | 56 => fun _ => Some T56 - | 57 => fun _ => Some T57 - | 58 => fun _ => Some T58 - | 59 => fun _ => Some T59 - | 60 => fun _ => Some T60 - | 61 => fun _ => Some T61 - | 62 => fun _ => Some T62 - | 63 => fun _ => Some T63 - | 64 => fun _ => Some T64 - | 65 => fun _ => Some T65 - | 66 => fun _ => Some T66 - | 67 => fun _ => Some T67 - | 68 => fun _ => Some T68 - | 69 => fun _ => Some T69 - | 70 => fun _ => Some T70 - | 71 => fun _ => Some T71 - | 72 => fun _ => Some T72 - | 73 => fun _ => Some T73 - | 74 => fun _ => Some T74 - | 75 => fun _ => Some T75 - | 76 => fun _ => Some T76 - | 77 => fun _ => Some T77 - | 78 => fun _ => Some T78 - | 79 => fun _ => Some T79 - | 80 => fun _ => Some T80 - | 81 => fun _ => Some T81 - | 82 => fun _ => Some T82 - | 83 => fun _ => Some T83 - | 84 => fun _ => Some T84 - | 85 => fun _ => Some T85 - | 86 => fun _ => Some T86 - | 87 => fun _ => Some T87 - | 88 => fun _ => Some T88 - | 89 => fun _ => Some T89 - | 90 => fun _ => Some T90 - | 91 => fun _ => Some T91 - | 92 => fun _ => Some T92 - | 93 => fun _ => Some T93 - | 94 => fun _ => Some T94 - | 95 => fun _ => Some T95 - | 96 => fun _ => Some T96 - | 97 => fun _ => Some T97 - | 98 => fun _ => Some T98 - | 99 => fun _ => Some T99 - | 100 => fun _ => Some T100 - | 101 => fun _ => Some T101 - | 102 => fun _ => Some T102 - | 103 => fun _ => Some T103 - | 104 => fun _ => Some T104 - | 105 => fun _ => Some T105 - | 106 => fun _ => Some T106 - | 107 => fun _ => Some T107 - | 108 => fun _ => Some T108 - | 109 => fun _ => Some T109 - | 110 => fun _ => Some T110 - | 111 => fun _ => Some T111 - | 112 => fun _ => Some T112 - | 113 => fun _ => Some T113 - | 114 => fun _ => Some T114 - | 115 => fun _ => Some T115 - | 116 => fun _ => Some T116 - | 117 => fun _ => Some T117 - | 118 => fun _ => Some T118 - | 119 => fun _ => Some T119 - | 120 => fun _ => Some T120 - | 121 => fun _ => Some T121 - | 122 => fun _ => Some T122 - | 123 => fun _ => Some T123 - | 124 => fun _ => Some T124 - | 125 => fun _ => Some T125 - | 126 => fun _ => Some T126 - | 127 => fun _ => Some T127 - | 128 => fun _ => Some T128 - | 129 => fun _ => Some T129 - | 130 => fun _ => Some T130 - | 131 => fun _ => Some T131 - | 132 => fun _ => Some T132 - | 133 => fun _ => Some T133 - | 134 => fun _ => Some T134 - | 135 => fun _ => Some T135 - | 136 => fun _ => Some T136 - | 137 => fun _ => Some T137 - | 138 => fun _ => Some T138 - | 139 => fun _ => Some T139 - | 140 => fun _ => Some T140 - | 141 => fun _ => Some T141 - | 142 => fun _ => Some T142 - | 143 => fun _ => Some T143 - | 144 => fun _ => Some T144 - | 145 => fun _ => Some T145 - | 146 => fun _ => Some T146 - | 147 => fun _ => Some T147 - | 148 => fun _ => Some T148 - | 149 => fun _ => Some T149 - | 150 => fun _ => Some T150 - | 151 => fun _ => Some T151 - | 152 => fun _ => Some T152 - | 153 => fun _ => Some T153 - | 154 => fun _ => Some T154 - | 155 => fun _ => Some T155 - | 156 => fun _ => Some T156 - | 157 => fun _ => Some T157 - | 158 => fun _ => Some T158 - | 159 => fun _ => Some T159 - | 160 => fun _ => Some T160 - | 161 => fun _ => Some T161 - | 162 => fun _ => Some T162 - | 163 => fun _ => Some T163 - | 164 => fun _ => Some T164 - | 165 => fun _ => Some T165 - | 166 => fun _ => Some T166 - | 167 => fun _ => Some T167 - | 168 => fun _ => Some T168 - | 169 => fun _ => Some T169 - | 170 => fun _ => Some T170 - | 171 => fun _ => Some T171 - | 172 => fun _ => Some T172 - | 173 => fun _ => Some T173 - | 174 => fun _ => Some T174 - | 175 => fun _ => Some T175 - | 176 => fun _ => Some T176 - | 177 => fun _ => Some T177 - | 178 => fun _ => Some T178 - | 179 => fun _ => Some T179 - | 180 => fun _ => Some T180 - | 181 => fun _ => Some T181 - | 182 => fun _ => Some T182 - | 183 => fun _ => Some T183 - | 184 => fun _ => Some T184 - | 185 => fun _ => Some T185 - | 186 => fun _ => Some T186 - | 187 => fun _ => Some T187 - | 188 => fun _ => Some T188 - | 189 => fun _ => Some T189 - | 190 => fun _ => Some T190 - | 191 => fun _ => Some T191 - | 192 => fun _ => Some T192 - | 193 => fun _ => Some T193 - | 194 => fun _ => Some T194 - | 195 => fun _ => Some T195 - | 196 => fun _ => Some T196 - | 197 => fun _ => Some T197 - | 198 => fun _ => Some T198 - | 199 => fun _ => Some T199 - | _ => fun _ => None - end. - -Lemma constructP x : construct (fields x) = Some x. -Proof. by case: x. Qed. - -End AUX. - -Local Instance t_obj : @obj t := - {| tag := AUX.tag - ; fields_t := AUX.fields_t - ; fields := AUX.fields - ; construct := AUX.construct - ; constructP := AUX.constructP |}. - -Definition eqb_fields (t:positive) : fields_t t -> fields_t t -> bool := - eq_op. - -(* Remark this is unusefull for this kind of type. - This pattern is usefull only for recursive type or for polymorphic type (this allows to use the definition for nested inductive *) -Definition eqb (x1 x2:t) := - match x1 with - | T1 => eqb_body eqb_fields (t1:=1 ) tt x2 - | T2 => eqb_body eqb_fields (t1:=2 ) tt x2 - | T3 => eqb_body eqb_fields (t1:=3 ) tt x2 - | T4 => eqb_body eqb_fields (t1:=4 ) tt x2 - | T5 => eqb_body eqb_fields (t1:=5 ) tt x2 - | T6 => eqb_body eqb_fields (t1:=6 ) tt x2 - | T7 => eqb_body eqb_fields (t1:=7 ) tt x2 - | T8 => eqb_body eqb_fields (t1:=8 ) tt x2 - | T9 => eqb_body eqb_fields (t1:=9 ) tt x2 - | T10 => eqb_body eqb_fields (t1:=10 ) tt x2 - | T11 => eqb_body eqb_fields (t1:=11 ) tt x2 - | T12 => eqb_body eqb_fields (t1:=12 ) tt x2 - | T13 => eqb_body eqb_fields (t1:=13 ) tt x2 - | T14 => eqb_body eqb_fields (t1:=14 ) tt x2 - | T15 => eqb_body eqb_fields (t1:=15 ) tt x2 - | T16 => eqb_body eqb_fields (t1:=16 ) tt x2 - | T17 => eqb_body eqb_fields (t1:=17 ) tt x2 - | T18 => eqb_body eqb_fields (t1:=18 ) tt x2 - | T19 => eqb_body eqb_fields (t1:=19 ) tt x2 - | T20 => eqb_body eqb_fields (t1:=20 ) tt x2 - | T21 => eqb_body eqb_fields (t1:=21 ) tt x2 - | T22 => eqb_body eqb_fields (t1:=22 ) tt x2 - | T23 => eqb_body eqb_fields (t1:=23 ) tt x2 - | T24 => eqb_body eqb_fields (t1:=24 ) tt x2 - | T25 => eqb_body eqb_fields (t1:=25 ) tt x2 - | T26 => eqb_body eqb_fields (t1:=26 ) tt x2 - | T27 => eqb_body eqb_fields (t1:=27 ) tt x2 - | T28 => eqb_body eqb_fields (t1:=28 ) tt x2 - | T29 => eqb_body eqb_fields (t1:=29 ) tt x2 - | T30 => eqb_body eqb_fields (t1:=30 ) tt x2 - | T31 => eqb_body eqb_fields (t1:=31 ) tt x2 - | T32 => eqb_body eqb_fields (t1:=32 ) tt x2 - | T33 => eqb_body eqb_fields (t1:=33 ) tt x2 - | T34 => eqb_body eqb_fields (t1:=34 ) tt x2 - | T35 => eqb_body eqb_fields (t1:=35 ) tt x2 - | T36 => eqb_body eqb_fields (t1:=36 ) tt x2 - | T37 => eqb_body eqb_fields (t1:=37 ) tt x2 - | T38 => eqb_body eqb_fields (t1:=38 ) tt x2 - | T39 => eqb_body eqb_fields (t1:=39 ) tt x2 - | T40 => eqb_body eqb_fields (t1:=40 ) tt x2 - | T41 => eqb_body eqb_fields (t1:=41 ) tt x2 - | T42 => eqb_body eqb_fields (t1:=42 ) tt x2 - | T43 => eqb_body eqb_fields (t1:=43 ) tt x2 - | T44 => eqb_body eqb_fields (t1:=44 ) tt x2 - | T45 => eqb_body eqb_fields (t1:=45 ) tt x2 - | T46 => eqb_body eqb_fields (t1:=46 ) tt x2 - | T47 => eqb_body eqb_fields (t1:=47 ) tt x2 - | T48 => eqb_body eqb_fields (t1:=48 ) tt x2 - | T49 => eqb_body eqb_fields (t1:=49 ) tt x2 - | T50 => eqb_body eqb_fields (t1:=50 ) tt x2 - | T51 => eqb_body eqb_fields (t1:=51 ) tt x2 - | T52 => eqb_body eqb_fields (t1:=52 ) tt x2 - | T53 => eqb_body eqb_fields (t1:=53 ) tt x2 - | T54 => eqb_body eqb_fields (t1:=54 ) tt x2 - | T55 => eqb_body eqb_fields (t1:=55 ) tt x2 - | T56 => eqb_body eqb_fields (t1:=56 ) tt x2 - | T57 => eqb_body eqb_fields (t1:=57 ) tt x2 - | T58 => eqb_body eqb_fields (t1:=58 ) tt x2 - | T59 => eqb_body eqb_fields (t1:=59 ) tt x2 - | T60 => eqb_body eqb_fields (t1:=60 ) tt x2 - | T61 => eqb_body eqb_fields (t1:=61 ) tt x2 - | T62 => eqb_body eqb_fields (t1:=62 ) tt x2 - | T63 => eqb_body eqb_fields (t1:=63 ) tt x2 - | T64 => eqb_body eqb_fields (t1:=64 ) tt x2 - | T65 => eqb_body eqb_fields (t1:=65 ) tt x2 - | T66 => eqb_body eqb_fields (t1:=66 ) tt x2 - | T67 => eqb_body eqb_fields (t1:=67 ) tt x2 - | T68 => eqb_body eqb_fields (t1:=68 ) tt x2 - | T69 => eqb_body eqb_fields (t1:=69 ) tt x2 - | T70 => eqb_body eqb_fields (t1:=70 ) tt x2 - | T71 => eqb_body eqb_fields (t1:=71 ) tt x2 - | T72 => eqb_body eqb_fields (t1:=72 ) tt x2 - | T73 => eqb_body eqb_fields (t1:=73 ) tt x2 - | T74 => eqb_body eqb_fields (t1:=74 ) tt x2 - | T75 => eqb_body eqb_fields (t1:=75 ) tt x2 - | T76 => eqb_body eqb_fields (t1:=76 ) tt x2 - | T77 => eqb_body eqb_fields (t1:=77 ) tt x2 - | T78 => eqb_body eqb_fields (t1:=78 ) tt x2 - | T79 => eqb_body eqb_fields (t1:=79 ) tt x2 - | T80 => eqb_body eqb_fields (t1:=80 ) tt x2 - | T81 => eqb_body eqb_fields (t1:=81 ) tt x2 - | T82 => eqb_body eqb_fields (t1:=82 ) tt x2 - | T83 => eqb_body eqb_fields (t1:=83 ) tt x2 - | T84 => eqb_body eqb_fields (t1:=84 ) tt x2 - | T85 => eqb_body eqb_fields (t1:=85 ) tt x2 - | T86 => eqb_body eqb_fields (t1:=86 ) tt x2 - | T87 => eqb_body eqb_fields (t1:=87 ) tt x2 - | T88 => eqb_body eqb_fields (t1:=88 ) tt x2 - | T89 => eqb_body eqb_fields (t1:=89 ) tt x2 - | T90 => eqb_body eqb_fields (t1:=90 ) tt x2 - | T91 => eqb_body eqb_fields (t1:=91 ) tt x2 - | T92 => eqb_body eqb_fields (t1:=92 ) tt x2 - | T93 => eqb_body eqb_fields (t1:=93 ) tt x2 - | T94 => eqb_body eqb_fields (t1:=94 ) tt x2 - | T95 => eqb_body eqb_fields (t1:=95 ) tt x2 - | T96 => eqb_body eqb_fields (t1:=96 ) tt x2 - | T97 => eqb_body eqb_fields (t1:=97 ) tt x2 - | T98 => eqb_body eqb_fields (t1:=98 ) tt x2 - | T99 => eqb_body eqb_fields (t1:=99 ) tt x2 - | T100 => eqb_body eqb_fields (t1:=100) tt x2 - | T101 => eqb_body eqb_fields (t1:=101) tt x2 - | T102 => eqb_body eqb_fields (t1:=102) tt x2 - | T103 => eqb_body eqb_fields (t1:=103) tt x2 - | T104 => eqb_body eqb_fields (t1:=104) tt x2 - | T105 => eqb_body eqb_fields (t1:=105) tt x2 - | T106 => eqb_body eqb_fields (t1:=106) tt x2 - | T107 => eqb_body eqb_fields (t1:=107) tt x2 - | T108 => eqb_body eqb_fields (t1:=108) tt x2 - | T109 => eqb_body eqb_fields (t1:=109) tt x2 - | T110 => eqb_body eqb_fields (t1:=110) tt x2 - | T111 => eqb_body eqb_fields (t1:=111) tt x2 - | T112 => eqb_body eqb_fields (t1:=112) tt x2 - | T113 => eqb_body eqb_fields (t1:=113) tt x2 - | T114 => eqb_body eqb_fields (t1:=114) tt x2 - | T115 => eqb_body eqb_fields (t1:=115) tt x2 - | T116 => eqb_body eqb_fields (t1:=116) tt x2 - | T117 => eqb_body eqb_fields (t1:=117) tt x2 - | T118 => eqb_body eqb_fields (t1:=118) tt x2 - | T119 => eqb_body eqb_fields (t1:=119) tt x2 - | T120 => eqb_body eqb_fields (t1:=120) tt x2 - | T121 => eqb_body eqb_fields (t1:=121) tt x2 - | T122 => eqb_body eqb_fields (t1:=122) tt x2 - | T123 => eqb_body eqb_fields (t1:=123) tt x2 - | T124 => eqb_body eqb_fields (t1:=124) tt x2 - | T125 => eqb_body eqb_fields (t1:=125) tt x2 - | T126 => eqb_body eqb_fields (t1:=126) tt x2 - | T127 => eqb_body eqb_fields (t1:=127) tt x2 - | T128 => eqb_body eqb_fields (t1:=128) tt x2 - | T129 => eqb_body eqb_fields (t1:=129) tt x2 - | T130 => eqb_body eqb_fields (t1:=130) tt x2 - | T131 => eqb_body eqb_fields (t1:=131) tt x2 - | T132 => eqb_body eqb_fields (t1:=132) tt x2 - | T133 => eqb_body eqb_fields (t1:=133) tt x2 - | T134 => eqb_body eqb_fields (t1:=134) tt x2 - | T135 => eqb_body eqb_fields (t1:=135) tt x2 - | T136 => eqb_body eqb_fields (t1:=136) tt x2 - | T137 => eqb_body eqb_fields (t1:=137) tt x2 - | T138 => eqb_body eqb_fields (t1:=138) tt x2 - | T139 => eqb_body eqb_fields (t1:=139) tt x2 - | T140 => eqb_body eqb_fields (t1:=140) tt x2 - | T141 => eqb_body eqb_fields (t1:=141) tt x2 - | T142 => eqb_body eqb_fields (t1:=142) tt x2 - | T143 => eqb_body eqb_fields (t1:=143) tt x2 - | T144 => eqb_body eqb_fields (t1:=144) tt x2 - | T145 => eqb_body eqb_fields (t1:=145) tt x2 - | T146 => eqb_body eqb_fields (t1:=146) tt x2 - | T147 => eqb_body eqb_fields (t1:=147) tt x2 - | T148 => eqb_body eqb_fields (t1:=148) tt x2 - | T149 => eqb_body eqb_fields (t1:=149) tt x2 - | T150 => eqb_body eqb_fields (t1:=150) tt x2 - | T151 => eqb_body eqb_fields (t1:=151) tt x2 - | T152 => eqb_body eqb_fields (t1:=152) tt x2 - | T153 => eqb_body eqb_fields (t1:=153) tt x2 - | T154 => eqb_body eqb_fields (t1:=154) tt x2 - | T155 => eqb_body eqb_fields (t1:=155) tt x2 - | T156 => eqb_body eqb_fields (t1:=156) tt x2 - | T157 => eqb_body eqb_fields (t1:=157) tt x2 - | T158 => eqb_body eqb_fields (t1:=158) tt x2 - | T159 => eqb_body eqb_fields (t1:=159) tt x2 - | T160 => eqb_body eqb_fields (t1:=160) tt x2 - | T161 => eqb_body eqb_fields (t1:=161) tt x2 - | T162 => eqb_body eqb_fields (t1:=162) tt x2 - | T163 => eqb_body eqb_fields (t1:=163) tt x2 - | T164 => eqb_body eqb_fields (t1:=164) tt x2 - | T165 => eqb_body eqb_fields (t1:=165) tt x2 - | T166 => eqb_body eqb_fields (t1:=166) tt x2 - | T167 => eqb_body eqb_fields (t1:=167) tt x2 - | T168 => eqb_body eqb_fields (t1:=168) tt x2 - | T169 => eqb_body eqb_fields (t1:=169) tt x2 - | T170 => eqb_body eqb_fields (t1:=170) tt x2 - | T171 => eqb_body eqb_fields (t1:=171) tt x2 - | T172 => eqb_body eqb_fields (t1:=172) tt x2 - | T173 => eqb_body eqb_fields (t1:=173) tt x2 - | T174 => eqb_body eqb_fields (t1:=174) tt x2 - | T175 => eqb_body eqb_fields (t1:=175) tt x2 - | T176 => eqb_body eqb_fields (t1:=176) tt x2 - | T177 => eqb_body eqb_fields (t1:=177) tt x2 - | T178 => eqb_body eqb_fields (t1:=178) tt x2 - | T179 => eqb_body eqb_fields (t1:=179) tt x2 - | T180 => eqb_body eqb_fields (t1:=180) tt x2 - | T181 => eqb_body eqb_fields (t1:=181) tt x2 - | T182 => eqb_body eqb_fields (t1:=182) tt x2 - | T183 => eqb_body eqb_fields (t1:=183) tt x2 - | T184 => eqb_body eqb_fields (t1:=184) tt x2 - | T185 => eqb_body eqb_fields (t1:=185) tt x2 - | T186 => eqb_body eqb_fields (t1:=186) tt x2 - | T187 => eqb_body eqb_fields (t1:=187) tt x2 - | T188 => eqb_body eqb_fields (t1:=188) tt x2 - | T189 => eqb_body eqb_fields (t1:=189) tt x2 - | T190 => eqb_body eqb_fields (t1:=190) tt x2 - | T191 => eqb_body eqb_fields (t1:=191) tt x2 - | T192 => eqb_body eqb_fields (t1:=192) tt x2 - | T193 => eqb_body eqb_fields (t1:=193) tt x2 - | T194 => eqb_body eqb_fields (t1:=194) tt x2 - | T195 => eqb_body eqb_fields (t1:=195) tt x2 - | T196 => eqb_body eqb_fields (t1:=196) tt x2 - | T197 => eqb_body eqb_fields (t1:=197) tt x2 - | T198 => eqb_body eqb_fields (t1:=198) tt x2 - | T199 => eqb_body eqb_fields (t1:=199) tt x2 - end. - -Lemma eqb_correct (x : t) : eqb_correct_on eqb x. -Proof. - by case: x; - rewrite /eqb_correct_on /eqb => ha htt; - apply (@eqb_body_correct _ t_obj eqb_fields). -Qed. - -Lemma eqb_refl (x:t) : eqb_refl_on eqb x. -Proof. - by case: x; apply (@eqb_body_refl _ t_obj eqb_fields). -Qed. - -Lemma eqbP (x1 x2 : t) : reflect (x1 = x2) (eqb x1 x2). -Proof. apply (iffP idP);[ apply eqb_correct | move=> ->; apply eqb_refl]. Qed. - - - +Time #[only(induction,param1_full,param1_trivial)] derive t. +Time Elpi tag t. +Time Elpi fields t. +Time Elpi eqb t. +Time Elpi eqbcorrect t. +Time Elpi eqbP t. diff --git a/src/list_defs.v b/src/list_defs.v index 75e73e4..599017b 100644 --- a/src/list_defs.v +++ b/src/list_defs.v @@ -10,6 +10,7 @@ Elpi eqb list. Elpi eqbcorrect list. Elpi eqbP list. +Check list_eqbP : eqtype.Equality.type -> eqtype.Equality.type. #[only(induction,param1_full,param1_trivial)] derive nat. Elpi tag nat. @@ -18,7 +19,10 @@ Elpi eqb nat. Elpi eqbcorrect nat. Elpi eqbP nat. -From mathcomp Require Import eqtype. +Check nat_eqbP : eqtype.Equality.type. + +Import eqtype. + Goal (cons 1 nil == nil). unfold eq_op. unfold list_eqbP, list_eqb. diff --git a/src/nested_defs.v b/src/nested_defs.v index ad85358..91d209f 100644 --- a/src/nested_defs.v +++ b/src/nested_defs.v @@ -1,18 +1,30 @@ -Require Import Eqdep_dec. -From mathcomp Require Import all_ssreflect. -Require Import PArith core_defs. -Require option_defs. -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. +From elpi.apps Require Import derive. +Require Import core_defs tag fields eqb eqbcorrect eqbP. -Open Scope positive_scope. +Require Import option_defs. Inductive t := | T0 | T1 of option t. + +#[only(induction,param1_full,param1_trivial)] derive t. +Elpi tag t. +Elpi fields t. +Elpi eqb t. +Elpi eqbcorrect t. +Elpi eqbP t. + + +(* + + + + + + + Section Ind. Context (Po : option t -> Prop) (P : t -> Prop). @@ -127,3 +139,4 @@ Qed. Lemma eqbP x1 x2 : reflect (x1 = x2) (eqb x1 x2). Proof. apply (iffP idP);[ apply eqb_correct | move=> ->; apply eqb_refl]. Qed. +*) diff --git a/src/option_defs.v b/src/option_defs.v index 576290d..72a2be4 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -1,100 +1,13 @@ -Require Import Eqdep_dec. +From elpi.apps Require Import derive. +Require Import core_defs tag fields eqb eqbcorrect eqbP. -From mathcomp Require Import all_ssreflect. -Require Import core_defs tag fields eqb. +#[only(induction,param1_full,param1_trivial)] derive option. +Elpi tag option. +Elpi fields option. +Elpi eqb option. +Elpi eqbcorrect option. +Elpi eqbP option. -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. -Require Import PArith. -Open Scope positive_scope. +Check option_eqbP : eqtype.Equality.type -> eqtype.Equality.type. -Section Ind. - - Context (A : Type) (PA : A -> Prop) (P : option A -> Prop). - Context (A_ind : forall a, PA a) (Hnone : P None) (Hsome : forall a, PA a -> P (Some a)). - - Definition option_Ind (o : option A) : P o := - match o with - | None => Hnone - | Some a => Hsome (A_ind a) - end. - -End Ind. - -Elpi tag option. -Definition tag {A} := @option_tag A. - -Elpi fields option. -Definition fields_t {A} := @option_fields_t A. - -Definition fields {A} := @option_fields A. - -Definition construct {A} := @option_construct A. - -Definition constructP {A} := @option_constructP A. - -Elpi eqb option. -Print option_eqb_fields. - -Definition eqb_fields (t:positive) : fields_t t -> fields_t t -> bool := - match t return fields_t t -> fields_t t -> bool with - | 1 => Aeqb - | 2 => eq_op - | _ => eq_op - end. - -Definition eqb (x1 x2:option A) := - match x1 with - | Some a => eqb_body eqb_fields (t1:=1) a x2 - | None => eqb_body eqb_fields (t1:=2) tt x2 - end. - -Lemma eqb_correct_on_None : eqb_correct_on eqb None. -Proof. - rewrite /eqb_correct_on /eqb. - by apply (@eqb_body_correct _ (option_obj A) eqb_fields None). -Qed. - -Lemma eqb_correct_on_Some a : - eqb_correct_on Aeqb a -> - eqb_correct_on eqb (Some a). -Proof. - rewrite /eqb_correct_on /eqb => ha. - apply (@eqb_body_correct _ (option_obj A) eqb_fields (Some a)). - by move=> a2 /ha ->. -Qed. - -Lemma eqb_refl_on_None : eqb_refl_on eqb None. -Proof. done. Qed. - -Lemma eqb_refl_on_Some a : - eqb_refl_on Aeqb a -> - eqb_refl_on eqb (Some a). -Proof. apply (@eqb_body_refl _ (option_obj A) eqb_fields (Some a)). Qed. - -End Section. - -Section EqType. - -Context (A:eqType). - -Lemma eqb_correct (x:option A) : eqb_correct_on (eqb eq_op) x. -Proof. - case: x => [ a | ]. - + by apply/eqb_correct_on_Some => x'; apply /eqP. - apply eqb_correct_on_None. -Qed. - -Lemma eqb_refl (x:option A) : eqb_refl_on (eqb eq_op) x. -Proof. - case: x => [ a | ]. - + by apply/eqb_refl_on_Some/eqxx. - apply eqb_refl_on_None. -Qed. - -Lemma eqbP (x1 x2 : option A) : reflect (x1 = x2) (eqb eq_op x1 x2). -Proof. apply (iffP idP);[ apply eqb_correct | move=> ->; apply eqb_refl]. Qed. - -End EqType. From 8e55f36dab850b45e1c4b5012c7c2e6b315b46df Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 13 Dec 2021 13:55:55 +0100 Subject: [PATCH 32/40] speedup --- _CoqProject | 1 + src/eqbcorrect.elpi | 19 ++-- src/eqbcorrect.v | 1 + src/large_defs.v | 210 ++++++++++++++++++++++++++++++++++++++++++-- src/large_defs2.v | 8 ++ 5 files changed, 226 insertions(+), 13 deletions(-) create mode 100644 src/large_defs2.v diff --git a/_CoqProject b/_CoqProject index d574a20..e3b2845 100644 --- a/_CoqProject +++ b/_CoqProject @@ -18,6 +18,7 @@ src/list_defs.v src/nested_defs.v src/nested_list_defs.v src/large_defs.v +src/large_defs2.v src/tag.v src/fields.v src/eqb.v diff --git a/src/eqbcorrect.elpi b/src/eqbcorrect.elpi index efb2b6b..476bfb5 100644 --- a/src/eqbcorrect.elpi +++ b/src/eqbcorrect.elpi @@ -9,6 +9,9 @@ main I Prefix [CL] :- std.do! [ coq.say {gettimeofday} "0", std.map2 KTs Ks (add-decl-correct Prefix N) Lt-correct, + + coq.say {gettimeofday} "0.5", + std.map2 KTs Ks (add-decl-refl Prefix N) Lt-refl, coq.say {gettimeofday} "1", @@ -62,12 +65,12 @@ add-decl-correct Prefix N KT K R /*(global (const P))*/ :- std.do![ % forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. % T : Type |- T -> list T -> list T ---> pred do-params-correct i:int, i:term, i:term, o:term. +do-params-correct 0 T K R :- !, do-args-correct T K R. do-params-correct NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ eqb-for a eqA => do-params-correct NP1 (F a) {{ lp:K lp:a }} (R a eqA). -do-params-correct 0 T K R :- do-args-correct T K R. pred do-args-correct i:term, i:term, o:term. do-args-correct (prod N T F) K {{ fun (x : lp:T) (Px : eqb_correct_on lp:Cmp x) => lp:(R x Px) }} :- !, @@ -116,12 +119,12 @@ add-decl-refl Prefix N KT K R /*(global (const P))*/ :- std.do![ % forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. % T : Type |- T -> list T -> list T ---> pred do-params-refl i:int, i:term, i:term, o:term. +do-params-refl 0 T K R :- !, do-args-refl T K R. do-params-refl NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ eqb-for a eqA => do-params-refl NP1 (F a) {{ lp:K lp:a }} (R a eqA). -do-params-refl 0 T K R :- do-args-refl T K R. pred do-args-refl i:term, i:term, o:term. do-args-refl (prod N T F) K {{ fun (x : lp:T) (Px : eqb_refl_on lp:Cmp x) => lp:(R x Px) }} :- !, @@ -130,10 +133,16 @@ do-args-refl (prod N T F) K {{ fun (x : lp:T) (Px : eqb_refl_on lp:Cmp x) => lp: @pi-decl `px` {{ eqb_refl_on lp:Cmp lp:x }} px\ do-args-refl (F x) {{ lp:K lp:x }} (R x px). do-args-refl T K {{ lp:B : eqb_refl_on lp:Cmp lp:K }} :- std.do! [ + coq.safe-dest-app T (global (indt I)) Args, + tag-for I TagC, + fields-for I Fields_tC FieldsC _ _, + coq.mk-app (global (const TagC)) Args Tag, + coq.mk-app (global (const Fields_tC)) Args Fields_t, + coq.mk-app (global (const FieldsC)) Args Fields, eqb-for T Cmp, - eqb-fields T Fields, - B = {{ @eqb_body_refl _ _ _ _ lp:Fields lp:K _ }}, - coq.typecheck {{ lp:B : eqb_refl_on lp:Cmp lp:K }} _ _, + eqb-fields T EqbFields, + B = {{ @eqb_body_refl lp:T lp:Tag lp:Fields_t lp:Fields lp:EqbFields lp:K _ }}, + std.assert-ok! (coq.typecheck {{ lp:B (*: eqb_refl_on lp:Cmp lp:K*) }} _) "illtyped", coq.ltac.collect-goals B [G] _, run-solver G "eqb_refl_on__solver", ]. diff --git a/src/eqbcorrect.v b/src/eqbcorrect.v index 8787b97..fc26395 100644 --- a/src/eqbcorrect.v +++ b/src/eqbcorrect.v @@ -24,6 +24,7 @@ Elpi Db eqcorrect.db lp:{{ }}. Elpi Command eqbcorrect. +Elpi Accumulate Db tag.db. Elpi Accumulate Db eqb.db. Elpi Accumulate Db fields.db. Elpi Accumulate Db eqcorrect.db. diff --git a/src/large_defs.v b/src/large_defs.v index bac5835..ecc17e0 100644 --- a/src/large_defs.v +++ b/src/large_defs.v @@ -1,5 +1,4 @@ From elpi.apps Require Import derive. -Require Import core_defs tag fields eqb eqbcorrect eqbP. Set Implicit Arguments. @@ -202,11 +201,206 @@ Inductive t := | T196 | T197 | T198 -| T199. +| T199 +| U1 +| U2 +| U3 +| U4 +| U5 +| U6 +| U7 +| U8 +| U9 +| U10 +| U11 +| U12 +| U13 +| U14 +| U15 +| U16 +| U17 +| U18 +| U19 +| U20 +| U21 +| U22 +| U23 +| U24 +| U25 +| U26 +| U27 +| U28 +| U29 +| U30 +| U31 +| U32 +| U33 +| U34 +| U35 +| U36 +| U37 +| U38 +| U39 +| U40 +| U41 +| U42 +| U43 +| U44 +| U45 +| U46 +| U47 +| U48 +| U49 +| U50 +| U51 +| U52 +| U53 +| U54 +| U55 +| U56 +| U57 +| U58 +| U59 +| U60 +| U61 +| U62 +| U63 +| U64 +| U65 +| U66 +| U67 +| U68 +| U69 +| U70 +| U71 +| U72 +| U73 +| U74 +| U75 +| U76 +| U77 +| U78 +| U79 +| U80 +| U81 +| U82 +| U83 +| U84 +| U85 +| U86 +| U87 +| U88 +| U89 +| U90 +| U91 +| U92 +| U93 +| U94 +| U95 +| U96 +| U97 +| U98 +| U99 +| U100 +| U101 +| U102 +| U103 +| U104 +| U105 +| U106 +| U107 +| U108 +| U109 +| U110 +| U111 +| U112 +| U113 +| U114 +| U115 +| U116 +| U117 +| U118 +| U119 +| U120 +| U121 +| U122 +| U123 +| U124 +| U125 +| U126 +| U127 +| U128 +| U129 +| U130 +| U131 +| U132 +| U133 +| U134 +| U135 +| U136 +| U137 +| U138 +| U139 +| U140 +| U141 +| U142 +| U143 +| U144 +| U145 +| U146 +| U147 +| U148 +| U149 +| U150 +| U151 +| U152 +| U153 +| U154 +| U155 +| U156 +| U157 +| U158 +| U159 +| U160 +| U161 +| U162 +| U163 +| U164 +| U165 +| U166 +| U167 +| U168 +| U169 +| U170 +| U171 +| U172 +| U173 +| U174 +| U175 +| U176 +| U177 +| U178 +| U179 +| U180 +| U181 +| U182 +| U183 +| U184 +| U185 +| U186 +| U187 +| U188 +| U189 +| U190 +| U191 +| U192 +| U193 +| U194 +| U195 +| U196 +| U197 +| U198 +| U199 +. -Time #[only(induction,param1_full,param1_trivial)] derive t. -Time Elpi tag t. -Time Elpi fields t. -Time Elpi eqb t. -Time Elpi eqbcorrect t. -Time Elpi eqbP t. +Time #[only(induction,param1_trivial)] derive t. \ No newline at end of file diff --git a/src/large_defs2.v b/src/large_defs2.v new file mode 100644 index 0000000..3394d88 --- /dev/null +++ b/src/large_defs2.v @@ -0,0 +1,8 @@ +Require Import large_defs. +Require Import core_defs tag fields eqb eqbcorrect eqbP. + +Time Elpi tag t. +Time Elpi fields t. +Time Elpi eqb t. +Time Elpi eqbcorrect t. +Time Elpi eqbP t. From 24c384f6a6af294767055941c965746f32e67b38 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 13 Dec 2021 15:23:56 +0100 Subject: [PATCH 33/40] draft --- src/nested_defs.v | 65 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 64 insertions(+), 1 deletion(-) diff --git a/src/nested_defs.v b/src/nested_defs.v index 91d209f..1ce4af1 100644 --- a/src/nested_defs.v +++ b/src/nested_defs.v @@ -9,13 +9,76 @@ Inductive t := | T1 of option t. -#[only(induction,param1_full,param1_trivial)] derive t. +#[only(induction,param1_functor,param1_trivial)] derive t. +About t_induction. Elpi tag t. Elpi fields t. Elpi eqb t. + +Lemma option_some_correct : + forall (A : Type) (eqA : A -> A -> bool), + let PA := @eqb_correct_on A eqA in + let P := @eqb_correct_on (option A) (@option_eqb A eqA) in + forall s1 : option A, option_is_option A PA s1 -> P s1. +move=> A eqA PA P o. +apply: option_induction. + move=> x Px. +Admitted. + +reali A PA => + reali (list A) P => + + option (list A) ----< option_is_option A P + option (box A) ----< option_is_option A (box_is_box A PA) + + + +Lemma T1_correct : + let P := @eqb_correct_on t t_eqb in + forall s1 : t, t_is_t s1 -> P s1. +move=> P s1. +apply: t_induction. + move=> x Px. admit. + move=> x Px. + have H := @option_some_correct t t_eqb _ Px. + rewrite /P. + apply: @eqb_body_correct _ _ _ _ t_construct _ _ _ _. + apply: t_constructP. + rewrite /eqb_fields_correct_on /= -/t_eqb => y H1. + by rewrite (H _ H1). + + +About option_induction. + + + +About option_eqb_correct. +About t_induction. + + + + + (forall x : option t, option_is_option t (eqb_correct_on t_eqb) x -> + (eqb_correct_on t_eqb) (T1 x)) -> + + (forall x : option t, option_is_option (option_eqb t t_eqb) x -> + (eqb_correct_on t_eqb) (T1 x) + + + + Elpi eqbcorrect t. Elpi eqbP t. +rec (t -> P) +IH : list t -> list_is_list P +bool -> bool_is_bool + +x : T +rec : P x + +IH -> (list_is_list P -> list_is_list Q) + (* From 7ea2ea1273bdf664340656dd6f0db904721d5d67 Mon Sep 17 00:00:00 2001 From: Benjamin Gregoire Date: Mon, 13 Dec 2021 20:14:56 +0100 Subject: [PATCH 34/40] WIP --- src/nested_defs.v | 4 +-- src/option_defs.v | 90 ++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 91 insertions(+), 3 deletions(-) diff --git a/src/nested_defs.v b/src/nested_defs.v index 1ce4af1..f5a63f6 100644 --- a/src/nested_defs.v +++ b/src/nested_defs.v @@ -69,7 +69,7 @@ About t_induction. Elpi eqbcorrect t. Elpi eqbP t. - + (* rec (t -> P) IH : list t -> list_is_list P bool -> bool_is_bool @@ -78,7 +78,7 @@ x : T rec : P x IH -> (list_is_list P -> list_is_list Q) - +*) (* diff --git a/src/option_defs.v b/src/option_defs.v index 72a2be4..0ce8b40 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -8,6 +8,94 @@ Elpi eqb option. Elpi eqbcorrect option. Elpi eqbP option. -Check option_eqbP : eqtype.Equality.type -> eqtype.Equality.type. +Print option_induction. + +Lemma option_eqb_correct_Some (A:Type) (eqA: A -> A -> bool) (a:A) : + eqb_correct_on eqA a -> eqb_correct_on (option_eqb A eqA) (Some a). +Proof. + move=> H. + refine + (@eqb_body_correct (option A) (option_tag A) (option_fields_t A) (option_fields A) (option_construct A) + (option_constructP A) (option_eqb_fields A eqA (option_eqb A eqA)) (Some a) (fun x => _)). + eqb_correct_on__solver. +Qed. + +Lemma option_eqb_correct_None (A:Type) (eqA: A -> A -> bool) : + eqb_correct_on (option_eqb A eqA) None. +Proof. + refine + (@eqb_body_correct (option A) (option_tag A) (option_fields_t A) (option_fields A) (option_construct A) + (option_constructP A) (option_eqb_fields A eqA (option_eqb A eqA)) None (fun x => _)). + eqb_correct_on__solver. +Qed. + +Lemma option_eqb_correct_aux (A : Type) (eqA : A -> A -> bool) : + let PA := @eqb_correct_on A eqA in + let P := @eqb_correct_on (option A) (option_eqb A eqA) in + forall (o : option A) (H:option_is_option A PA o), P o. +Proof. + move=> PA P. + apply: (@option_induction A PA P); rewrite /PA /P. + + apply option_eqb_correct_Some. + apply option_eqb_correct_None. +Qed. + +Lemma option_eqb_correct' (A : Type) (eqA : A -> A -> bool) : + eqb_correct eqA -> + eqb_correct (option_eqb A eqA). +Proof. + move=> H o; apply:option_eqb_correct_aux. + apply: option_is_option_full; apply H. +Qed. + + +Inductive t := + | T0 + | T1 of option t. + +#[only(induction,param1_functor,param1_trivial)] derive t. +Elpi tag t. +Elpi fields t. +Elpi eqb t. + +Check t_induction. + +Lemma t_eqb_correct_T0 : eqb_correct_on t_eqb T0. +Proof. + refine + (@eqb_body_correct t t_tag t_fields_t t_fields t_construct + t_constructP (t_eqb_fields t_eqb) T0 (fun x => _)). + eqb_correct_on__solver. +Qed. + +Lemma t_eqb_correct_T1 (o : option t) : + option_is_option t (eqb_correct_on t_eqb) o -> eqb_correct_on t_eqb (T1 o). +Proof. + move=> H. + refine + (@eqb_body_correct t t_tag t_fields_t t_fields t_construct + t_constructP (t_eqb_fields t_eqb) (T1 o) (fun x => _)). + (* FIXME : eqb_correct_on__solver. *) + rewrite /=. + by move=> /(option_eqb_correct_aux _ _ _ H) ->. +Qed. + +Lemma t_eqb_correct_aux : + let P := @eqb_correct_on t t_eqb in + forall x : t, t_is_t x -> P x. +Proof. + move=> P. + apply: (@t_induction P); rewrite /P. + + apply t_eqb_correct_T0. + apply t_eqb_correct_T1. +Qed. + +Lemma t_eqb_correct : eqb_correct t_eqb. +Proof. + move=> t; apply t_eqb_correct_aux. + apply t_is_t_full. +Qed. + + From b21b1f523d7a2fb154c7a3db8e438e91b51aa79b Mon Sep 17 00:00:00 2001 From: Benjamin Gregoire Date: Mon, 13 Dec 2021 20:32:13 +0100 Subject: [PATCH 35/40] WIP --- src/option_defs.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/option_defs.v b/src/option_defs.v index 0ce8b40..3d16ce2 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -72,12 +72,12 @@ Lemma t_eqb_correct_T1 (o : option t) : option_is_option t (eqb_correct_on t_eqb) o -> eqb_correct_on t_eqb (T1 o). Proof. move=> H. + (* This is the key point. If we don't do it here the tactic eqb_correct_on__solver does not work *) + have H' := option_eqb_correct_aux _ _ _ H. refine (@eqb_body_correct t t_tag t_fields_t t_fields t_construct t_constructP (t_eqb_fields t_eqb) (T1 o) (fun x => _)). - (* FIXME : eqb_correct_on__solver. *) - rewrite /=. - by move=> /(option_eqb_correct_aux _ _ _ H) ->. + eqb_correct_on__solver. Qed. Lemma t_eqb_correct_aux : From ef29e9965312d1a1099d0a39d0e6fb6471797146 Mon Sep 17 00:00:00 2001 From: Benjamin Gregoire Date: Tue, 14 Dec 2021 07:44:26 +0100 Subject: [PATCH 36/40] Try to build the expected type of auxiliary lemmas --- src/eqbcorrect.elpi | 42 ++++++++++++++++++++++++++++++++++++++++++ src/option_defs.v | 3 ++- 2 files changed, 44 insertions(+), 1 deletion(-) diff --git a/src/eqbcorrect.elpi b/src/eqbcorrect.elpi index 476bfb5..e908a4e 100644 --- a/src/eqbcorrect.elpi +++ b/src/eqbcorrect.elpi @@ -8,6 +8,8 @@ main I Prefix [CL] :- std.do! [ coq.say {gettimeofday} "0", + std.map2 KTs Ks (add-decl-correct-ty Prefix N) Lt-correct-ty, + std.map2 KTs Ks (add-decl-correct Prefix N) Lt-correct, coq.say {gettimeofday} "0.5", @@ -53,6 +55,46 @@ coq.ctx->string (def X _ Ty B) R :- R is {coq.term->string X} ^ " : " ^ {coq.ter /************************** correct *********************************************/ +/* Build the type */ +pred add-decl-correct-ty i:string, i:int, i:term, i:constructor, o:term. +add-decl-correct-ty Prefix N KT K R /*(global (const P))*/ :- std.do![ + do-params-correct-ty N KT (global (indc K)) R, + coq.say "R=" R, + std.assert-ok! (coq.typecheck R Ty) "R casse", + Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)} ^ "_t", + coq.env.add-const Name R Ty @opaque! P, + % coq.say {gettimeofday} ".", +]. + +pred do-params-correct-ty i:int, i:term, i:term, o:term. +do-params-correct-ty 0 T K R :- !, do-args-correct-ty T K R. +do-params-correct-ty NP (prod N T F) K {{ forall (a : lp:T) (eqA : a -> a -> bool), lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, + @pi-decl N T a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + eqb-for a eqA => + reali a {{ @eqb_correct_on lp:a lp:eqA }} => + do-params-correct-ty NP1 (F a) {{ lp:K lp:a }} (R a eqA). + +pred do-args-correct-ty i:term, i:term, o:term. +do-args-correct-ty (prod N T F) K {{ forall (x : lp:T) (Px : lp:EqbOn x), lp:(R x Px) }} :- !, + reali T EqbOn, + @pi-decl N T x\ + @pi-decl `px` {{ lp:EqbOn lp:x }} px\ + do-args-correct-ty (F x) {{ lp:K lp:x }} (R x px). + +do-args-correct-ty T K {{ eqb_correct_on lp:Cmp lp:K }} :- std.do! [ + eqb-for T Cmp, +% coq.safe-dest-app T (global (indt I)) Args, +% fields-for I _ _ _ ConstructPC, +% coq.mk-app (global (const ConstructPC)) Args ConstructP, +% eqb-fields T Fields, +% B = {{ @eqb_body_correct _ _ _ _ _ lp:ConstructP lp:Fields lp:K (fun f => _) }}, +% coq.typecheck {{ lp:B : eqb_correct_on lp:Cmp lp:K }} _ _, +% coq.ltac.collect-goals B [G] _, +% run-solver G "eqb_correct_on__solver", +% +]. + pred add-decl-correct i:string, i:int, i:term, i:constructor, o:term. add-decl-correct Prefix N KT K R /*(global (const P))*/ :- std.do![ do-params-correct N KT (global (indc K)) R, diff --git a/src/option_defs.v b/src/option_defs.v index 3d16ce2..7ca1e24 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -8,7 +8,7 @@ Elpi eqb option. Elpi eqbcorrect option. Elpi eqbP option. -Print option_induction. + Lemma option_eqb_correct_Some (A:Type) (eqA: A -> A -> bool) (a:A) : eqb_correct_on eqA a -> eqb_correct_on (option_eqb A eqA) (Some a). @@ -57,6 +57,7 @@ Inductive t := Elpi tag t. Elpi fields t. Elpi eqb t. +Elpi eqbcorrect t. Check t_induction. From c71721c329af2197459ea0e104d6209604a0ecd1 Mon Sep 17 00:00:00 2001 From: Benjamin Gregoire Date: Tue, 14 Dec 2021 08:02:45 +0100 Subject: [PATCH 37/40] WIP --- src/eqbcorrect.elpi | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/eqbcorrect.elpi b/src/eqbcorrect.elpi index e908a4e..ec0fe0a 100644 --- a/src/eqbcorrect.elpi +++ b/src/eqbcorrect.elpi @@ -8,7 +8,7 @@ main I Prefix [CL] :- std.do! [ coq.say {gettimeofday} "0", - std.map2 KTs Ks (add-decl-correct-ty Prefix N) Lt-correct-ty, + std.map2 KTs Ks (add-decl-correct-ty Prefix N I) Lt-correct-ty, std.map2 KTs Ks (add-decl-correct Prefix N) Lt-correct, @@ -56,9 +56,9 @@ coq.ctx->string (def X _ Ty B) R :- R is {coq.term->string X} ^ " : " ^ {coq.ter /************************** correct *********************************************/ /* Build the type */ -pred add-decl-correct-ty i:string, i:int, i:term, i:constructor, o:term. -add-decl-correct-ty Prefix N KT K R /*(global (const P))*/ :- std.do![ - do-params-correct-ty N KT (global (indc K)) R, +pred add-decl-correct-ty i:string, i:int, i:inductive, i:term, i:constructor, o:term. +add-decl-correct-ty Prefix N I KT K R /*(global (const P))*/ :- std.do![ + do-params-correct-ty N KT (global (indt I)) (global (indc K)) R, coq.say "R=" R, std.assert-ok! (coq.typecheck R Ty) "R casse", Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)} ^ "_t", @@ -66,14 +66,17 @@ add-decl-correct-ty Prefix N KT K R /*(global (const P))*/ :- std.do![ % coq.say {gettimeofday} ".", ]. -pred do-params-correct-ty i:int, i:term, i:term, o:term. -do-params-correct-ty 0 T K R :- !, do-args-correct-ty T K R. -do-params-correct-ty NP (prod N T F) K {{ forall (a : lp:T) (eqA : a -> a -> bool), lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, +pred do-params-correct-ty i:int, i:term, i:term, i:term, o:term. +do-params-correct-ty 0 T I K R :- !, + eqb-for I Cmp, + reali I {{ eqb_correct_on lp:I lp:Cmp }} => + do-args-correct-ty T K R. +do-params-correct-ty NP (prod N T F) I K {{ forall (a : lp:T) (eqA : a -> a -> bool), lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ eqb-for a eqA => reali a {{ @eqb_correct_on lp:a lp:eqA }} => - do-params-correct-ty NP1 (F a) {{ lp:K lp:a }} (R a eqA). + do-params-correct-ty NP1 (F a) {{ lp:I lp:a }} {{ lp:K lp:a }} (R a eqA). pred do-args-correct-ty i:term, i:term, o:term. do-args-correct-ty (prod N T F) K {{ forall (x : lp:T) (Px : lp:EqbOn x), lp:(R x Px) }} :- !, From 7f0715133bf7619d68f0d115e0139b010beb5182 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 14 Dec 2021 13:14:41 +0100 Subject: [PATCH 38/40] wip --- src/eqbcorrect.elpi | 39 +++++--- src/eqbcorrect.v | 27 +++++- src/option_defs.v | 65 +++++++++---- src/param1.elpi | 221 ++++++++++++++++++++++++++++++++++++++++++++ src/paramX-lib.elpi | 78 ++++++++++++++++ 5 files changed, 399 insertions(+), 31 deletions(-) create mode 100644 src/param1.elpi create mode 100644 src/paramX-lib.elpi diff --git a/src/eqbcorrect.elpi b/src/eqbcorrect.elpi index ec0fe0a..c8db9da 100644 --- a/src/eqbcorrect.elpi +++ b/src/eqbcorrect.elpi @@ -10,7 +10,7 @@ main I Prefix [CL] :- std.do! [ std.map2 KTs Ks (add-decl-correct-ty Prefix N I) Lt-correct-ty, - std.map2 KTs Ks (add-decl-correct Prefix N) Lt-correct, + std.map2 KTs Ks (add-decl-correct Prefix N (global (indt I))) Lt-correct, coq.say {gettimeofday} "0.5", @@ -59,7 +59,8 @@ coq.ctx->string (def X _ Ty B) R :- R is {coq.term->string X} ^ " : " ^ {coq.ter pred add-decl-correct-ty i:string, i:int, i:inductive, i:term, i:constructor, o:term. add-decl-correct-ty Prefix N I KT K R /*(global (const P))*/ :- std.do![ do-params-correct-ty N KT (global (indt I)) (global (indc K)) R, - coq.say "R=" R, + coq.term->string R RS, + coq.say "R=" RS, std.assert-ok! (coq.typecheck R Ty) "R casse", Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)} ^ "_t", coq.env.add-const Name R Ty @opaque! P, @@ -69,7 +70,7 @@ add-decl-correct-ty Prefix N I KT K R /*(global (const P))*/ :- std.do![ pred do-params-correct-ty i:int, i:term, i:term, i:term, o:term. do-params-correct-ty 0 T I K R :- !, eqb-for I Cmp, - reali I {{ eqb_correct_on lp:I lp:Cmp }} => + reali I {{ @eqb_correct_on lp:I lp:Cmp }} => do-args-correct-ty T K R. do-params-correct-ty NP (prod N T F) I K {{ forall (a : lp:T) (eqA : a -> a -> bool), lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, @pi-decl N T a\ @@ -98,9 +99,9 @@ do-args-correct-ty T K {{ eqb_correct_on lp:Cmp lp:K }} :- std.do! [ % ]. -pred add-decl-correct i:string, i:int, i:term, i:constructor, o:term. -add-decl-correct Prefix N KT K R /*(global (const P))*/ :- std.do![ - do-params-correct N KT (global (indc K)) R, +pred add-decl-correct i:string, i:int, i:term, i:term, i:constructor, o:term. +add-decl-correct Prefix N I KT K R /*(global (const P))*/ :- std.do![ + do-params-correct N I KT (global (indc K)) R, std.assert-ok! (coq.typecheck R Ty) "R casse", % Name is Prefix ^ "eqb_correct_on_" ^ {coq.gref->id (indc K)}, % coq.env.add-const Name R Ty @opaque! P, @@ -109,20 +110,32 @@ add-decl-correct Prefix N KT K R /*(global (const P))*/ :- std.do![ % forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. % T : Type |- T -> list T -> list T ---> -pred do-params-correct i:int, i:term, i:term, o:term. -do-params-correct 0 T K R :- !, do-args-correct T K R. -do-params-correct NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, +pred do-params-correct i:int, i:term, i:term, i:term, o:term. +do-params-correct 0 I T K R :- !, + eqb-for I Cmp, + reali I {{ @eqb_correct_on lp:I lp:Cmp }} => + do-args-correct T K R. +do-params-correct NP I (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ eqb-for a eqA => - do-params-correct NP1 (F a) {{ lp:K lp:a }} (R a eqA). + reali a {{ @eqb_correct_on lp:a lp:eqA }} => + do-params-correct NP1 {coq.mk-app I [a]} (F a) {{ lp:K lp:a }} (R a eqA). pred do-args-correct i:term, i:term, o:term. -do-args-correct (prod N T F) K {{ fun (x : lp:T) (Px : eqb_correct_on lp:Cmp x) => lp:(R x Px) }} :- !, + +do-args-correct (prod N T F) K {{ fun (x : lp:T) (px : lp:EqbOn x) (* (h := lp:TOTO x px) *) => lp:(R x px) (*h*) }} :- !, + reali T EqbOn, eqb-for T Cmp, @pi-decl N T x\ - @pi-decl `px` {{ eqb_correct_on lp:Cmp lp:x }} px\ - do-args-correct (F x) {{ lp:K lp:x }} (R x px). + @pi-decl `px` {{ lp:EqbOn lp:x }} px\ + /* + JC : HERE + eqb-correct-aux-for EqbOn TOTO, + @pi-def `h` {{ @eqb_correct_on lp:T lp:Cmp }} (TOTO x px) h\ + */ + do-args-correct (F x) {{ lp:K lp:x }} (R x px /*h*/). + do-args-correct T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ eqb-for T Cmp, coq.safe-dest-app T (global (indt I)) Args, diff --git a/src/eqbcorrect.v b/src/eqbcorrect.v index fc26395..a0cfb98 100644 --- a/src/eqbcorrect.v +++ b/src/eqbcorrect.v @@ -20,7 +20,28 @@ Elpi Db eqcorrect.db lp:{{ o:inductive, o:constant, % correct o:constant. % reflexive + /* JC HERE + + pred eqb-correct-aux-for o:term, o:term. + eqb-correct-aux-for + {{ @eq_correct_on lp:T lp:F }} + {{ (fun (a : lp:T) (H : @eq_correct_on lp:T lp:F) => H) }}. + % + eqb-correct-aux-for + {{ option_is_option lp:T (@eqb_correct_on _ _) }} + {{ (fun (a : lp:T) (H : option_eqb_correct_aux lp:T lp:Cmp }}. + eqb-correct-aux-for + {{ option_is_option lp:T lp:P }} + {{ fun x H => option_is_option_functor lp:T _ (@eqb_correct_on _ _) (lp:Rec x H) }} :- + eqb-correct-aux-for P Rec. + + eqb-correct-aux-for {{ list_is_list lp:A lp:P }} {{ list_eqb_correct_aux ... }} :- + eqb-correct-aux-for P X. + + option_is_option (list A) (list_is_list A (eqb_correct_on A FA)) +*/ + }}. Elpi Command eqbcorrect. @@ -29,10 +50,12 @@ Elpi Accumulate Db eqb.db. Elpi Accumulate Db fields.db. Elpi Accumulate Db eqcorrect.db. Elpi Accumulate Db derive.induction.db. -Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.inhab.db. Elpi Accumulate File "src/elpi-ltac.elpi". Elpi Accumulate File "src/eqbcorrect.elpi". +Elpi Accumulate File "src/paramX-lib.elpi". +Elpi Accumulate File "src/param1.elpi". +Elpi Accumulate Db derive.param1.db. Elpi Accumulate lp:{{ main [str S] :- std.assert! (coq.locate S (indt I)) "Not an inductive type", @@ -40,3 +63,5 @@ Elpi Accumulate lp:{{ eqbcorrect.main I Prefix _. }}. Elpi Typecheck. + +Elpi Print eqbcorrect. \ No newline at end of file diff --git a/src/option_defs.v b/src/option_defs.v index 7ca1e24..79d16bb 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -1,14 +1,25 @@ From elpi.apps Require Import derive. Require Import core_defs tag fields eqb eqbcorrect eqbP. -#[only(induction,param1_full,param1_trivial)] derive option. +#[verbose,only(induction,param1_functor,param1_trivial)] derive option. Elpi tag option. Elpi fields option. Elpi eqb option. Elpi eqbcorrect option. Elpi eqbP option. +#[verbose,only(induction,param1_functor,param1_trivial)] derive list. +Elpi tag list. +Elpi fields list. +Elpi eqb list. +Elpi eqbcorrect list. +Elpi eqbP list. +About option_is_option_functor. +About list_is_list_functor. +(* forall (A : Type) (PA1 PA2 : A -> Type), + (forall x : A, PA1 x -> PA2 x) -> + forall x : option A, option_is_option A PA1 x -> option_is_option A PA2 x *) Lemma option_eqb_correct_Some (A:Type) (eqA: A -> A -> bool) (a:A) : eqb_correct_on eqA a -> eqb_correct_on (option_eqb A eqA) (Some a). @@ -29,15 +40,12 @@ Proof. eqb_correct_on__solver. Qed. -Lemma option_eqb_correct_aux (A : Type) (eqA : A -> A -> bool) : - let PA := @eqb_correct_on A eqA in - let P := @eqb_correct_on (option A) (option_eqb A eqA) in - forall (o : option A) (H:option_is_option A PA o), P o. +Lemma option_eqb_correct_aux (A : Type) (eqA : A -> A -> bool) (o : option A) : + @option_is_option A (@eqb_correct_on A eqA) o -> + @eqb_correct_on (option A) (option_eqb A eqA) o. Proof. - move=> PA P. - apply: (@option_induction A PA P); rewrite /PA /P. - + apply option_eqb_correct_Some. - apply option_eqb_correct_None. + refine (@option_induction A _ _ (option_eqb_correct_Some A eqA) + (option_eqb_correct_None A eqA) o). Qed. Lemma option_eqb_correct' (A : Type) (eqA : A -> A -> bool) : @@ -49,17 +57,22 @@ Proof. Qed. + + +Lemma list_eqb_correct_aux (A : Type) (eqA : A -> A -> bool) (o : list A) : + @list_is_list A (@eqb_correct_on A eqA) o -> + @eqb_correct_on (list A) (list_eqb A eqA) o. +Admitted. + Inductive t := | T0 - | T1 of option t. + | T1 of option (list (option t)). #[only(induction,param1_functor,param1_trivial)] derive t. Elpi tag t. Elpi fields t. Elpi eqb t. -Elpi eqbcorrect t. - -Check t_induction. +(* Elpi eqbcorrect t. *) Lemma t_eqb_correct_T0 : eqb_correct_on t_eqb T0. Proof. @@ -69,16 +82,34 @@ Proof. eqb_correct_on__solver. Qed. -Lemma t_eqb_correct_T1 (o : option t) : - option_is_option t (eqb_correct_on t_eqb) o -> eqb_correct_on t_eqb (T1 o). +Lemma t_eqb_correct_T1 (o : option (list (option t))) : + option_is_option (list (option t)) + (list_is_list (option t) + (option_is_option t (eqb_correct_on t_eqb))) o -> + eqb_correct_on t_eqb (T1 o). Proof. move=> H. - (* This is the key point. If we don't do it here the tactic eqb_correct_on__solver does not work *) - have H' := option_eqb_correct_aux _ _ _ H. + + refine + (@eqb_body_correct t t_tag t_fields_t t_fields t_construct + t_constructP (t_eqb_fields t_eqb) (T1 o) (fun x => _)). + rewrite /= => W. + congr (Some (T1 _)). + move: x W. + change (eqb_correct_on (option_eqb _ (list_eqb (option t) (option_eqb t t_eqb))) o). + + apply option_eqb_correct_aux. + move: o H; apply option_is_option_functor => o H. + apply list_eqb_correct_aux. + move: o H; apply list_is_list_functor => o H. + apply option_eqb_correct_aux. + by []. +(* refine (@eqb_body_correct t t_tag t_fields_t t_fields t_construct t_constructP (t_eqb_fields t_eqb) (T1 o) (fun x => _)). eqb_correct_on__solver. + *) Qed. Lemma t_eqb_correct_aux : diff --git a/src/param1.elpi b/src/param1.elpi new file mode 100644 index 0000000..4a250b7 --- /dev/null +++ b/src/param1.elpi @@ -0,0 +1,221 @@ +/* Unary parametricity translation (Realizability) */ +/* license: GNU Lesser General Public License Version 2.1 or later */ +/* ------------------------------------------------------------------------- */ + +% Author: Cyril Cohen + +shorten std.{forall, forall2, do!, rev, map2, map}. + +:before "subst-fun:fail" +coq.subst-fun XS T TXS :- !, coq.mk-app T XS TXS. + +% this is outside the namespace since the predicate is also the db-one +reali (sort prop as P) (fun `s` P x\ prod `s1` x _\ P) :- !. +reali (sort _) (fun `s` (sort (typ U)) x\ prod `s1` x _\ (sort (typ V))) :- !, + coq.univ.new [] U, coq.univ.new [] V. + +reali (fun N T B) (fun N T x\ fun N1 (TRsubst x) xR\ BR x xR) :- !, do! [ + coq.name-suffix `P` N N1, + reali T TR, + (pi x xR\ reali x xR => reali (B x) (BR x xR)), + (TRsubst = x\ {coq.subst-fun [x] TR}) +]. + +reali (prod N T P as Prod) ProdR :- !, do! [ + coq.name-suffix `P` N N1, + reali T TR, + (pi x xR\ reali x xR => reali (P x) (PR x xR)), + ProdR = fun `f` Prod f\ + prod N T x\ prod N1 {coq.subst-fun [x] TR} xR\ + {coq.subst-fun [{coq.mk-app f [x]}] (PR x xR)} +]. + +reali (app [A|Bs]) ARBsR :- !, do! [ + reali A AR, + derive.param1.reali-args Bs BsR, + coq.mk-app AR BsR ARBsR +]. + +reali (let N T V B) LetR :- !, std.do! [ + coq.name-suffix `P` N N1, + reali T TR, + reali V VR, + (pi x xR\ reali x xR => reali (B x) (BR x xR)), + LetR = let N T V x\ let N1 {coq.mk-app TR [x]} VR xR\ BR x xR +]. + +reali (match T P Bs) MR :- !, do! [ + reali T TR, + derive.param1.reali-match P PRM, + reali T TR => derive.param1.reali-map Bs BsR, + MR = match TR (PRM (x\ match x P Bs)) BsR +]. + +reali (fix N Rno T F as Fix) FixR :- !, std.do! [ + RnoR is 2 * Rno + 1, + RnoR1 is RnoR + 1, + reali T TR, + (pi x xR\ reali x xR => reali (F x) (FR x xR)), + (TRsubst = f\ {coq.subst-fun [f] TR}), + (pi f xR\ FixBody f xR = let N (TRsubst (F f)) (FR f xR) fr\ + {paramX.mk-trivial-match RnoR (TRsubst f) [] fr}), + (pi f xR\ coq.mk-eta RnoR1 (TRsubst f) (FixBody f xR) (EtaFixBody f xR)), + coq.name-suffix N 1 N1, + FixR = (let N T Fix f\ fix N1 RnoR (TRsubst f) xR\ EtaFixBody f xR), +]. + +namespace derive.param1 { + +pred reali-args o:list term, o:list term. +reali-args [] []. +reali-args [X|Xs] [X,XR|XsR] :- do! [ + reali X XR, + reali-args Xs XsR +]. + +pred reali-map o:list term, o:list term. +reali-map [] []. +reali-map [X|Xs] [XR|XsR] :- do! [ + reali X XR, + reali-map Xs XsR +]. + +% helpers for match return type +pred reali-match i:term, o:((term -> term) -> term). +reali-match (fun N T B) PRM :- pi x\ not (B x = fun _ _ _), !, do! [ + reali T TR, + (pi x xR\ reali x xR => reali (B x) (BR x xR)), + coq.name-suffix `P` N N1, + (pi z z1\ PRM z = + fun N T x\ fun N1 {coq.subst-fun [x] TR} xR\ {coq.mk-app (BR x xR) [z x]}) +]. + +reali-match (fun N T B) PRM :- do! [ + reali T TR, + (pi x xR\ reali x xR => reali-match (B x) (BR x xR)), + coq.name-suffix N 1 N1, + (pi z \ PRM z = fun N T x\ fun N1 {coq.subst-fun [x] TR} xR\ BR x xR z) +]. + +% Storage: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +pred reali-store + i:string, % Name suffix for the type class + i:term, % Term + i:term. % Translation +reali-store N X XR :- !, + Nreali is "reali_" ^ N, + Args = [_, _, X, XR], + T1 = app [{{ lib:@param1.store_reali }}|Args], + std.assert-ok! (coq.typecheck T1 T2) "reali-store: T1 illtyped", + coq.env.add-const Nreali T1 T2 _ GR, + @global! => coq.TC.declare-instance (const GR) 0. + +pred reali-store-indc i:string, i:constructor, i:constructor. +reali-store-indc Prefix K XR :- + reali-store {calc (Prefix ^ {coq.gref->id (indc K)})} (global (indc K)) (global (indc XR)). + +% toplevel predicates %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +pred dispatch + i:gref, % input of the translation + i:string, % the name + o:list prop. % the clause + +dispatch (const GR) Prefix Clauses :- !, do! [ + Term = global (const GR), + Name is Prefix ^ {coq.gref->id (const GR)}, + std.assert! (coq.env.const GR (some V) Ty) "param1: cannot handle axioms", + + reali V VR, + reali Ty TyR, + coq.mk-app TyR [V] TyRV, + % apparently calling the type checker with the expected type is weaker in this case + std.assert-ok! (coq.typecheck VR VRTy) "param1: illtyped constant", + std.assert-ok! (coq.unify-leq VRTy TyRV) "param1: constant does not have the right type", + + coq.env.add-const Name VR TyRV _ TermR, + + reali-store Name Term (global (const TermR)), + + C1 = (reali Term (global (const TermR)) :- !), + coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "reali:fail") C1), + C2 = (realiR Term (global (const TermR)) :- !), + coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "realiR:fail") C2), + Clauses = [C1, C2] +]. + +pred prefix-indc i:string, i:constructor, o:pair constructor id. +prefix-indc Prefix K (pr K NewName) :- + coq.gref->id (indc K) Name, NewName is Prefix ^ Name. + +dispatch (indt GR) Prefix Clauses :- !, do! [ + Ind = global (indt GR), + coq.env.indt GR _ _ Lno Ty Knames Ktypes, + + LnoR is 2 * Lno, + + pi new_name\ sigma KnamesR KtypesR TyR\ ( + reali Ind (global (indt new_name)) => reali Ty TyR, + reali Ind (global (indt new_name)) => + map2 Knames Ktypes (k\ ty\ r\ sigma tyr\ + reali ty tyr, coq.subst-fun [global (indc k)] tyr r) + KtypesR, + map Knames (prefix-indc Prefix) KnamesR, + + NewName is Prefix ^ {coq.gref->id (indt GR)}, + + coq.build-indt-decl + (pr new_name NewName) tt LnoR LnoR {coq.subst-fun [Ind] TyR} KnamesR KtypesR DeclR + ), + + std.assert-ok! (coq.typecheck-indt-decl DeclR) "derive.param1 generates illtyped inductive", + + coq.env.add-indt DeclR GRR, + + reali-store NewName Ind (global (indt GRR)), + coq.env.indt GRR _ _ _ _ RealNamesR _, + forall2 Knames RealNamesR (reali-store-indc NewName), + C1 = (reali Ind (global (indt GRR)) :- !), + coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "reali:fail") C1), + C2 = (realiR Ind (global (indt GRR)) :- !), + coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "realiR:fail") C2), + map2 Knames RealNamesR (a\ b\ r\ r = reali (global (indc a)) (global (indc b))) CK, + forall CK (c\ + coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "reali:fail") c)), + Clauses = [C1,C2|CK] +]. + +dispatch (indc _) _ _ :- + coq.error "derive.param1: cannot translate a constructor". + +pred main i:gref, i:string, o:list prop. +main T Out Clauses :- dispatch T Out Clauses. + +} + +/* +%%%%%%%%%%%%%%%%%%%%% +% Tactic entrypoint % +%%%%%%%%%%%%%%%%%%%%% + +% We disable coq-refiner +:before "refiner-assign-evar" + evar _ _ _ :- !. + +pred ctx->TC i:(list prop), o:(list (pair term term)). +ctx->TC [] [] :- !. +ctx->TC [decl X _ Ty |Xs] [pr X Ty|Is] :- !, ctx->TC Xs Is. +ctx->TC [def X _ _ _ Ty |Xs] [pr X Ty|Is] :- !, ctx->TC Xs Is. + +solve _ [goal Ctx Ev (app[{{@reali}}, T, TR, X, XR]) _] _ :- !, + coq.sigma.print, + coq.say "goal->TC" {ctx->TC Ctx}, + coq.say "searching reali for" X, + reali T TR, + reali X XR, + Ev = app [{{@Reali}}, T, TR, X, XR], + coq.typecheck Ev Ty ok, + coq.say "Ty=" Ty. + +*/ diff --git a/src/paramX-lib.elpi b/src/paramX-lib.elpi new file mode 100644 index 0000000..ac1e744 --- /dev/null +++ b/src/paramX-lib.elpi @@ -0,0 +1,78 @@ +/* coq-elpi: Coq terms as the object language of elpi */ +/* license: GNU Lesser General Public License Version 2.1 or later */ +/* ------------------------------------------------------------------------- */ + +namespace paramX { + +pred mk-trivial-match i:int, i:term, i:list term, i:term, o:term. +mk-trivial-match Rno (prod N T P) Args F (fun N T B) :- Rno >= 0, !, std.do! [ + Rno' is Rno - 1, + (pi x\ decl x N T => mk-trivial-match Rno' (P x) [x|Args] F (B x)), +]. + +mk-trivial-match Rno Prod Args F R :- Rno >= 0, whd1 Prod Prod1, !, + mk-trivial-match Rno Prod1 Args F R. + +mk-trivial-match -1 P RArgs F Match :- std.do! [ + RArgs = [RecArg|ROtherArgs], + (decl RecArg _ T, unwind {whd T []} Twhd), % unneeded with elpi 1.13.7 + coq.safe-dest-app Twhd (global (indt I)) IndArgs, + coq.env.indt I _ Lno _ _ _ _, + std.drop Lno IndArgs RIndArgs, + coq.build-match RecArg T + (mk-trivial-match.rty {std.append RIndArgs [RecArg]} P) + (mk-trivial-match.branch Lno RIndArgs {std.rev ROtherArgs} F) Match, +]. + +pred mk-trivial-match.rty i:list term, i:term, i:term, i:list term, i:list term, o:term. +mk-trivial-match.rty Args P _ Vars _ R :- std.do! [ + std.map2 Args Vars (x\y\r\ r = copy x y) Subst, + Subst => copy P R, +]. + +pred mk-trivial-match.branch i:int, i:list term, i:list term, i:term, i:term, i:term, i:list term, i:list term, o:term. +mk-trivial-match.branch Lno Args OtherArgs F K KTy Vars _ R1 :- std.do! [ + coq.mk-app K Vars KArgs, + coq.safe-dest-app KTy _ KTyArgs, + std.drop Lno KTyArgs IdxVals, + std.map2 Args IdxVals (x\y\r\ r = copy x y) Subst, + (R = let `K` KTy KArgs x\ {coq.mk-app F {std.append OtherArgs [x]}}), + Subst => copy R R1, +]. + + +% prove H G P finds a P : H => G +pred prove i:term, i:term, o:term. +pred cross i:term. + +% prove-arg AppliedHyp AppliedGoal Argument ProofAppliedHyp Proof. +pred prove-arg i:term, i:term, i:term, i:term, o:term. + +prove-arg X X _ P P :- !. + +prove-arg (app [H|Hs]) (app[G|Gs]) X PHX PGX :- + std.appendR HArgs [X] Hs, coq.mk-app H HArgs Hyp, + std.appendR GArgs [X] Gs, coq.mk-app G GArgs Goal, + prove Hyp Goal Proof, + coq.mk-app Proof [X,PHX] PGX. + +prove-arg (prod _ X x\ prod _ (PX x) (H x)) (prod _ _ y\ prod _ (PX y) (G y)) A PA (fun `x` X x\ fun `px` (PX x) (Proof x)) :- + pi x px\ + prove-arg (H x px) (G x px) {coq.mk-app A [x]} {coq.mk-app PA [x,px]} (Proof x px). + +pred prove-args i:list term, i:list term, o:list term. +prove-args [] [] []. +prove-args [X,Pr|Args] [_,PX|ArgsT] [X,Proof|QArgs] :- + coq.safe-dest-app PX HD _, cross HD, !, + copy PX Goal, + (prove-arg PX Goal X Pr Proof ; Proof = Pr), !, + prove-args Args ArgsT QArgs. +prove-args [X|Args] [PX|ArgsT] [ProofX|QArgs] :- + copy PX Goal, + prove PX Goal Proof, !, + coq.mk-app Proof [X] ProofX, + prove-args Args ArgsT QArgs. +prove-args [X|Args] [_|ArgsT] [X|QArgs] :- + prove-args Args ArgsT QArgs. + +} \ No newline at end of file From 18ada4228a40fd83ed403687519ce481bb831148 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 17 Dec 2021 17:05:42 +0100 Subject: [PATCH 39/40] wip --- src/eqbcorrect.elpi | 82 +++++++++++++++------- src/eqbcorrect.v | 18 ++++- src/option_defs.v | 161 ++++++++++++++++---------------------------- 3 files changed, 134 insertions(+), 127 deletions(-) diff --git a/src/eqbcorrect.elpi b/src/eqbcorrect.elpi index c8db9da..8e8eb6b 100644 --- a/src/eqbcorrect.elpi +++ b/src/eqbcorrect.elpi @@ -2,19 +2,21 @@ namespace eqbcorrect { pred main i:inductive, i:string, o:list prop. -main I Prefix [CL] :- std.do! [ +main I Prefix CLs :- std.do! [ % Add error msg if not a inductive ? coq.env.indt I _ _ N TI Ks KTs, coq.say {gettimeofday} "0", - std.map2 KTs Ks (add-decl-correct-ty Prefix N I) Lt-correct-ty, + % std.map2 KTs Ks (add-decl-correct-ty Prefix N I) Lt-correct-ty, + + coq.say {gettimeofday} "0.1", std.map2 KTs Ks (add-decl-correct Prefix N (global (indt I))) Lt-correct, coq.say {gettimeofday} "0.5", - std.map2 KTs Ks (add-decl-refl Prefix N) Lt-refl, + std.map2 KTs Ks (add-decl-refl Prefix N (global (indt I))) Lt-refl, coq.say {gettimeofday} "1", @@ -26,6 +28,11 @@ main I Prefix [CL] :- std.do! [ Name is Prefix ^ "eqb_correct", coq.env.add-const Name R Ty @opaque! Correct, + add-indu-correct-aux TI Indu IR Lt-correct Rx, + std.assert-ok! (coq.typecheck Rx Tyx) "fail demande a JC", + Namex is Prefix ^ "eqb_correct_aux", + coq.env.add-const Namex Rx Tyx @opaque! Correctx, + coq.say {gettimeofday} "2", add-indu-refl TI Indu IR Lt-refl Rr, @@ -35,8 +42,11 @@ main I Prefix [CL] :- std.do! [ coq.say {gettimeofday} "3", - CL = eqcorrect-for I Correct Refl, - coq.elpi.accumulate _ "eqcorrect.db" (clause _ _ CL), + CLs = [ + eqcorrect-for I Correct Refl, + correct-lemma-for (indt I) (global (const Correctx)), + ], + std.forall CLs (x\ coq.elpi.accumulate _ "eqcorrect.db" (clause _ _ x)), ]. @@ -55,7 +65,8 @@ coq.ctx->string (def X _ Ty B) R :- R is {coq.term->string X} ^ " : " ^ {coq.ter /************************** correct *********************************************/ -/* Build the type */ +/* Build the type + pred add-decl-correct-ty i:string, i:int, i:inductive, i:term, i:constructor, o:term. add-decl-correct-ty Prefix N I KT K R /*(global (const P))*/ :- std.do![ do-params-correct-ty N KT (global (indt I)) (global (indc K)) R, @@ -99,6 +110,8 @@ do-args-correct-ty T K {{ eqb_correct_on lp:Cmp lp:K }} :- std.do! [ % ]. +*/ + pred add-decl-correct i:string, i:int, i:term, i:term, i:constructor, o:term. add-decl-correct Prefix N I KT K R /*(global (const P))*/ :- std.do![ do-params-correct N I KT (global (indc K)) R, @@ -113,28 +126,28 @@ add-decl-correct Prefix N I KT K R /*(global (const P))*/ :- std.do![ pred do-params-correct i:int, i:term, i:term, i:term, o:term. do-params-correct 0 I T K R :- !, eqb-for I Cmp, - reali I {{ @eqb_correct_on lp:I lp:Cmp }} => + reali I {{ @eqb_correct_on lp:I lp:Cmp }} => + eqb-correct-aux-for I {{ fun x H => H }} => do-args-correct T K R. do-params-correct NP I (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ eqb-for a eqA => + eqb-correct-aux-for a {{ fun (x: lp:a) (H : @eqb_correct_on lp:a lp:eqA x) => H }} => reali a {{ @eqb_correct_on lp:a lp:eqA }} => - do-params-correct NP1 {coq.mk-app I [a]} (F a) {{ lp:K lp:a }} (R a eqA). + do-params-correct NP1 {{ lp:I lp:a }} (F a) {{ lp:K lp:a }} (R a eqA). pred do-args-correct i:term, i:term, o:term. -do-args-correct (prod N T F) K {{ fun (x : lp:T) (px : lp:EqbOn x) (* (h := lp:TOTO x px) *) => lp:(R x px) (*h*) }} :- !, +do-args-correct (prod N T F) K {{ fun (x : lp:T) (px : lp:EqbOn x) (h : @eqb_correct_on lp:T lp:Cmp x := lp:View x px) => lp:(R x px h) }} :- !, std.spy-do! [ reali T EqbOn, eqb-for T Cmp, + eqb-correct-aux-for T View, @pi-decl N T x\ @pi-decl `px` {{ lp:EqbOn lp:x }} px\ - /* - JC : HERE - eqb-correct-aux-for EqbOn TOTO, - @pi-def `h` {{ @eqb_correct_on lp:T lp:Cmp }} (TOTO x px) h\ - */ - do-args-correct (F x) {{ lp:K lp:x }} (R x px /*h*/). + @pi-def `H` {{ @eqb_correct_on lp:T lp:Cmp lp:x }} {{ lp:View lp:x lp:px }} h\ + do-args-correct (F x) {{ lp:K lp:x }} (R x px h) +]. do-args-correct T K {{ lp:B : eqb_correct_on lp:Cmp lp:K }} :- std.do! [ eqb-for T Cmp, @@ -165,10 +178,22 @@ add-indu-correct _T Indu IR LS {{ fun x => lp:(R x) }} :- std.append LS [x, app[Is_full,x]] (Args x), R x = app [Indu, _ | Args x]. + +pred add-indu-correct-aux i:term, i:term, i:term, i:list term, o:term. +add-indu-correct-aux (prod N T F) Indu IR LS {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- !, + @pi-decl N T a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + add-indu-correct-aux (F a) + {{ lp:Indu lp:a (@eqb_correct_on lp:a lp:eqA)}} + {{ lp:IR lp:a (@eqb_correct_on lp:a lp:eqA)}} + {std.map LS (t\coq.mk-app t [a, eqA])} (R a eqA). +add-indu-correct-aux _T Indu IR LS R :- + R = app [Indu, _ | LS]. + /******************************** Refl **************************************************************/ -pred add-decl-refl i:string, i:int, i:term, i:constructor, o:term. -add-decl-refl Prefix N KT K R /*(global (const P))*/ :- std.do![ - do-params-refl N KT (global (indc K)) R, +pred add-decl-refl i:string, i:int, i:term, i:term, i:constructor, o:term. +add-decl-refl Prefix N I KT K R /*(global (const P))*/ :- std.do![ + do-params-refl N I KT (global (indc K)) R, std.assert-ok! (coq.typecheck R Ty) "R casse", % Name is Prefix ^ "eqb_refl_on_" ^ {coq.gref->id (indc K)}, % coq.env.add-const Name R Ty @opaque! P, @@ -176,20 +201,29 @@ add-decl-refl Prefix N KT K R /*(global (const P))*/ :- std.do![ % forall T : Type, T -> list T -> list T ---> forall a eqA, ..R.. % T : Type |- T -> list T -> list T ---> -pred do-params-refl i:int, i:term, i:term, o:term. -do-params-refl 0 T K R :- !, do-args-refl T K R. -do-params-refl NP (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, +pred do-params-refl i:int, i:term, i:term, i:term, o:term. +do-params-refl 0 I T K R :- !, + eqb-for I Cmp, + reali I {{ @eqb_refl_on lp:I lp:Cmp }} => + do-args-refl T K R. +do-params-refl NP I (prod N T F) K {{ fun (a : lp:T) (eqA : a -> a -> bool) => lp:(R a eqA) }} :- NP > 0, !, NP1 is NP - 1, @pi-decl N T a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ eqb-for a eqA => - do-params-refl NP1 (F a) {{ lp:K lp:a }} (R a eqA). + reali a {{ @eqb_refl_on lp:a lp:eqA }} => + do-params-refl NP1 {{ lp:I lp:a }} (F a) {{ lp:K lp:a }} (R a eqA). pred do-args-refl i:term, i:term, o:term. -do-args-refl (prod N T F) K {{ fun (x : lp:T) (Px : eqb_refl_on lp:Cmp x) => lp:(R x Px) }} :- !, + +do-args-refl (prod N T F) K {{ fun (x : lp:T) (px : lp:EqbOn x) (h : @eqb_refl_on lp:T lp:Cmp x := lp:View x px) => lp:(R x px h) }} :- !, + reali T EqbOn, eqb-for T Cmp, + eqb-refl-aux-for T View, @pi-decl N T x\ @pi-decl `px` {{ eqb_refl_on lp:Cmp lp:x }} px\ - do-args-refl (F x) {{ lp:K lp:x }} (R x px). + @pi-def `H` {{ @eqb_refl_on lp:T lp:Cmp lp:x }} {{ lp:View lp:x lp:px }} h\ + do-args-refl (F x) {{ lp:K lp:x }} (R x px h). + do-args-refl T K {{ lp:B : eqb_refl_on lp:Cmp lp:K }} :- std.do! [ coq.safe-dest-app T (global (indt I)) Args, tag-for I TagC, diff --git a/src/eqbcorrect.v b/src/eqbcorrect.v index a0cfb98..71a7bed 100644 --- a/src/eqbcorrect.v +++ b/src/eqbcorrect.v @@ -20,6 +20,14 @@ Elpi Db eqcorrect.db lp:{{ o:inductive, o:constant, % correct o:constant. % reflexive + + pred what-for i:(gref -> term -> prop), i:(term -> term -> prop), i:term, o:term. + pred eqb-correct-aux-for i:term, o:term. + eqb-correct-aux-for T R :- + what-for correct-lemma-for eqb-correct-aux-for T R. + + pred eqb-refl-aux-for i:term, o:term. + /* JC HERE pred eqb-correct-aux-for o:term, o:term. @@ -40,7 +48,14 @@ Elpi Db eqcorrect.db lp:{{ eqb-correct-aux-for P X. option_is_option (list A) (list_is_list A (eqb_correct_on A FA)) -*/ + + :name "eqb-correct-aux-for:default" + eqb-correct-aux-for T {{ fun (x : lp:T) H => H }}. + */ + :name "eqb-refl-aux-for:default" + eqb-refl-aux-for T {{ fun (x : lp:T) H => H }}. + + }}. @@ -51,6 +66,7 @@ Elpi Accumulate Db fields.db. Elpi Accumulate Db eqcorrect.db. Elpi Accumulate Db derive.induction.db. Elpi Accumulate Db derive.param1.inhab.db. +(*Elpi Accumulate Db derive.param1.functor.db. bad db shape *) Elpi Accumulate File "src/elpi-ltac.elpi". Elpi Accumulate File "src/eqbcorrect.elpi". Elpi Accumulate File "src/paramX-lib.elpi". diff --git a/src/option_defs.v b/src/option_defs.v index 79d16bb..e8c52c9 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -7,6 +7,7 @@ Elpi fields option. Elpi eqb option. Elpi eqbcorrect option. Elpi eqbP option. + #[verbose,only(induction,param1_functor,param1_trivial)] derive list. Elpi tag list. Elpi fields list. @@ -14,120 +15,76 @@ Elpi eqb list. Elpi eqbcorrect list. Elpi eqbP list. -About option_is_option_functor. -About list_is_list_functor. - -(* forall (A : Type) (PA1 PA2 : A -> Type), - (forall x : A, PA1 x -> PA2 x) -> - forall x : option A, option_is_option A PA1 x -> option_is_option A PA2 x *) +Lemma list_eqb_refl_aux (A : Type) (eqA : A -> A -> bool) (o : list A) : + @list_is_list A (@eqb_refl_on A eqA) o -> + @eqb_refl_on (list A) (list_eqb A eqA) o. +Admitted. -Lemma option_eqb_correct_Some (A:Type) (eqA: A -> A -> bool) (a:A) : - eqb_correct_on eqA a -> eqb_correct_on (option_eqb A eqA) (Some a). -Proof. - move=> H. - refine - (@eqb_body_correct (option A) (option_tag A) (option_fields_t A) (option_fields A) (option_construct A) - (option_constructP A) (option_eqb_fields A eqA (option_eqb A eqA)) (Some a) (fun x => _)). - eqb_correct_on__solver. -Qed. - -Lemma option_eqb_correct_None (A:Type) (eqA: A -> A -> bool) : - eqb_correct_on (option_eqb A eqA) None. +Lemma option_eqb_refl_aux (A : Type) (eqA : A -> A -> bool) (o : option A) : + @option_is_option A (@eqb_refl_on A eqA) o -> + @eqb_refl_on (option A) (option_eqb A eqA) o. Proof. - refine - (@eqb_body_correct (option A) (option_tag A) (option_fields_t A) (option_fields A) (option_construct A) - (option_constructP A) (option_eqb_fields A eqA (option_eqb A eqA)) None (fun x => _)). - eqb_correct_on__solver. -Qed. - -Lemma option_eqb_correct_aux (A : Type) (eqA : A -> A -> bool) (o : option A) : - @option_is_option A (@eqb_correct_on A eqA) o -> - @eqb_correct_on (option A) (option_eqb A eqA) o. -Proof. - refine (@option_induction A _ _ (option_eqb_correct_Some A eqA) - (option_eqb_correct_None A eqA) o). -Qed. +Admitted. -Lemma option_eqb_correct' (A : Type) (eqA : A -> A -> bool) : - eqb_correct eqA -> - eqb_correct (option_eqb A eqA). -Proof. - move=> H o; apply:option_eqb_correct_aux. - apply: option_is_option_full; apply H. -Qed. +Inductive t := + | T0 + | T1 of option (list (option t)). +Elpi Accumulate eqcorrect.db lp:{{ -Lemma list_eqb_correct_aux (A : Type) (eqA : A -> A -> bool) (o : list A) : - @list_is_list A (@eqb_correct_on A eqA) o -> - @eqb_correct_on (list A) (list_eqb A eqA) o. -Admitted. + what-for What Rec (app [global GR|L]) R :- std.spy-do! [ + What GR Aux, + functor-lemma-for GR Funct, + std.map L Rec Recs, + apply-functor Funct Recs TOTO, + R = {{ fun x H => lp:Aux _ _ x (lp:TOTO x H) }}, + ]. -Inductive t := - | T0 - | T1 of option (list (option t)). + pred apply-functor i:term, i:list term, o:term. + apply-functor X [] X. + apply-functor X [R|RS] TOTO :- apply-functor {{ lp:X _ _ _ lp:R }} RS TOTO. -#[only(induction,param1_functor,param1_trivial)] derive t. -Elpi tag t. -Elpi fields t. -Elpi eqb t. -(* Elpi eqbcorrect t. *) + % correct-lemma-for {{:gref list }} {{ list_eqb_correct_aux }}. + % correct-lemma-for {{:gref option }} {{ option_eqb_correct_aux }}. -Lemma t_eqb_correct_T0 : eqb_correct_on t_eqb T0. -Proof. - refine - (@eqb_body_correct t t_tag t_fields_t t_fields t_construct - t_constructP (t_eqb_fields t_eqb) T0 (fun x => _)). - eqb_correct_on__solver. -Qed. - -Lemma t_eqb_correct_T1 (o : option (list (option t))) : - option_is_option (list (option t)) - (list_is_list (option t) - (option_is_option t (eqb_correct_on t_eqb))) o -> - eqb_correct_on t_eqb (T1 o). -Proof. - move=> H. - - refine - (@eqb_body_correct t t_tag t_fields_t t_fields t_construct - t_constructP (t_eqb_fields t_eqb) (T1 o) (fun x => _)). - rewrite /= => W. - congr (Some (T1 _)). - move: x W. - change (eqb_correct_on (option_eqb _ (list_eqb (option t) (option_eqb t t_eqb))) o). - - apply option_eqb_correct_aux. - move: o H; apply option_is_option_functor => o H. - apply list_eqb_correct_aux. - move: o H; apply list_is_list_functor => o H. - apply option_eqb_correct_aux. - by []. -(* - refine - (@eqb_body_correct t t_tag t_fields_t t_fields t_construct - t_constructP (t_eqb_fields t_eqb) (T1 o) (fun x => _)). - eqb_correct_on__solver. - *) -Qed. - -Lemma t_eqb_correct_aux : - let P := @eqb_correct_on t t_eqb in - forall x : t, t_is_t x -> P x. -Proof. - move=> P. - apply: (@t_induction P); rewrite /P. - + apply t_eqb_correct_T0. - apply t_eqb_correct_T1. -Qed. + functor-lemma-for {{:gref list }} {{ list_is_list_functor }}. + functor-lemma-for {{:gref option }} {{ option_is_option_functor }}. -Lemma t_eqb_correct : eqb_correct t_eqb. -Proof. - move=> t; apply t_eqb_correct_aux. - apply t_is_t_full. -Qed. +/* + :before "eqb-correct-aux-for:default" + eqb-correct-aux-for {{ list lp:X }} + {{ fun x H => list_eqb_correct_aux _ _ x (list_is_list_functor _ _ _ lp:Rec x H) }} :- + eqb-correct-aux-for X Rec. + + :before "eqb-correct-aux-for:default" + eqb-correct-aux-for {{ option lp:X }} + {{ fun x H => option_eqb_correct_aux _ _ x (option_is_option_functor _ _ _ lp:Rec x H) }} :- + eqb-correct-aux-for X Rec. + +*/ + + :before "eqb-refl-aux-for:default" + eqb-refl-aux-for {{ list lp:X }} + {{ fun x H => list_eqb_refl_aux _ _ x (list_is_list_functor _ _ _ lp:Rec x H) }} :- + eqb-refl-aux-for X Rec. + + :before "eqb-refl-aux-for:default" + eqb-refl-aux-for {{ option lp:X }} + {{ fun x H => option_eqb_refl_aux _ _ x (option_is_option_functor _ _ _ lp:Rec x H) }} :- + eqb-refl-aux-for X Rec. + +}}. + +#[only(induction,param1_functor,param1_trivial)] derive t. +Elpi tag t. +Elpi fields t. +Elpi eqb t. +Elpi eqbcorrect t. +About t_eqb_correct. +About t_eqb_refl. From b4537e1b311e43bb902f17b77227357542c07a67 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 17 Dec 2021 17:33:39 +0100 Subject: [PATCH 40/40] . --- src/eqbcorrect.elpi | 19 +++++++++++++++++++ src/eqbcorrect.v | 5 ----- src/option_defs.v | 19 ++++++------------- 3 files changed, 25 insertions(+), 18 deletions(-) diff --git a/src/eqbcorrect.elpi b/src/eqbcorrect.elpi index 8e8eb6b..6b893cf 100644 --- a/src/eqbcorrect.elpi +++ b/src/eqbcorrect.elpi @@ -50,6 +50,25 @@ main I Prefix CLs :- std.do! [ ]. +pred what-for i:(gref -> term -> prop), i:(term -> term -> prop), i:term, o:term. +pred eqb-correct-aux-for i:term, o:term. +eqb-correct-aux-for T R :- + what-for correct-lemma-for eqb-correct-aux-for T R. + +what-for What Rec (app [global GR|L]) R :- std.spy-do! [ + What GR Aux, + functor-lemma-for GR Funct, + std.map L Rec Recs, + apply-functor Funct Recs TOTO, + R = {{ fun x H => lp:Aux _ _ x (lp:TOTO x H) }}, +]. + + pred apply-functor i:term, i:list term, o:term. + apply-functor X [] X. + apply-functor X [R|RS] TOTO :- apply-functor {{ lp:X _ _ _ lp:R }} RS TOTO. + + + pred run-solver i:sealed-goal, i:string. run-solver G Name :- if (coq.ltac.open (coq.ltac.call Name []) G []) true diff --git a/src/eqbcorrect.v b/src/eqbcorrect.v index 71a7bed..4ab7613 100644 --- a/src/eqbcorrect.v +++ b/src/eqbcorrect.v @@ -21,11 +21,6 @@ Elpi Db eqcorrect.db lp:{{ o:constant, % correct o:constant. % reflexive - pred what-for i:(gref -> term -> prop), i:(term -> term -> prop), i:term, o:term. - pred eqb-correct-aux-for i:term, o:term. - eqb-correct-aux-for T R :- - what-for correct-lemma-for eqb-correct-aux-for T R. - pred eqb-refl-aux-for i:term, o:term. /* JC HERE diff --git a/src/option_defs.v b/src/option_defs.v index e8c52c9..3b047a2 100644 --- a/src/option_defs.v +++ b/src/option_defs.v @@ -32,19 +32,9 @@ Inductive t := | T1 of option (list (option t)). -Elpi Accumulate eqcorrect.db lp:{{ - what-for What Rec (app [global GR|L]) R :- std.spy-do! [ - What GR Aux, - functor-lemma-for GR Funct, - std.map L Rec Recs, - apply-functor Funct Recs TOTO, - R = {{ fun x H => lp:Aux _ _ x (lp:TOTO x H) }}, - ]. +Elpi Accumulate eqcorrect.db lp:{{ - pred apply-functor i:term, i:list term, o:term. - apply-functor X [] X. - apply-functor X [R|RS] TOTO :- apply-functor {{ lp:X _ _ _ lp:R }} RS TOTO. % correct-lemma-for {{:gref list }} {{ list_eqb_correct_aux }}. % correct-lemma-for {{:gref option }} {{ option_eqb_correct_aux }}. @@ -84,7 +74,10 @@ Elpi tag t. Elpi fields t. Elpi eqb t. Elpi eqbcorrect t. +Elpi eqbP t. + +Import eqtype. + +Check (forall x : t, x == x). -About t_eqb_correct. -About t_eqb_refl.