diff --git a/Changelog.md b/Changelog.md index d8027949e..580c00429 100644 --- a/Changelog.md +++ b/Changelog.md @@ -40,6 +40,8 @@ Requires Elpi 3.7.1 and Rocq 9.0, 9.1 or 9.2. - New argument `const-decl` can now be introduces by the `Lemma` keyword, and not just by `Definition`. - New `coq.scheme` to query registered schemes +- New `coq.env.mutual-inductives` to list the inductive types in the same + mutual block without reifying the full inductive declaration # [3.3.1] 12/03/2026 diff --git a/apps/derive/elpi/derive.elpi b/apps/derive/elpi/derive.elpi index 300be4574..1137a3bd6 100644 --- a/apps/derive/elpi/derive.elpi +++ b/apps/derive/elpi/derive.elpi @@ -9,6 +9,25 @@ exists-indc I P :- coq.env.indt I _ _ _ _ KL _, std.exists! KL P. +func mutual-ids indt-decl -> list id. +mutual-ids (parameter ID _ Ty F) IDs :- !, + @pi-parameter ID Ty x\ mutual-ids (F x) IDs. +mutual-ids (minductive ID _ Arity Rest) [ID|IDs] :- !, + @pi-inductive ID Arity i\ mutual-ids (Rest i) IDs. +mutual-ids (mblock _) []. + +func mutual-indt-decl indt-decl ->. +mutual-indt-decl D :- mutual-ids D IDs, std.length IDs N, N > 1. + +func mutual-inductive inductive ->. +mutual-inductive I :- coq.env.mutual-inductives I GRS, std.length GRS N, N > 1. + +func id->indt id -> inductive. +id->indt ID GR :- coq.locate ID (indt GR). + +func mutual-inductives inductive -> list inductive. +mutual-inductives I GRS :- coq.env.mutual-inductives I GRS. + func if-verbose (func) ->. if-verbose P :- (get-option "verbose" tt ; get-option "recursive" tt), !, P. if-verbose _. @@ -148,7 +167,7 @@ decl+main TypeName DS :- std.do! [ if-verbose (coq.say "Done"), if (HasModule = tt) (coq.env.end-module _, - decl+main.post TypeName I DS CL) + decl+main.post ModName DS CL) check-no-no-alias ]. @@ -157,24 +176,57 @@ check-no-no-alias :- get-option "no_alias" tt, !, coq.error "The no_alias attribute only has an effect when a wrapper module is generated.". check-no-no-alias. -func decl+main.post string, inductive, indt-decl -> list prop. -decl+main.post TypeName I DS CL :- std.do! [ - coq.env.indt I _ _ _ _ KS _, +func indt-decl-ids indt-decl -> list id. +indt-decl-ids (parameter ID _ Ty F) IDs :- !, + @pi-parameter ID Ty x\ indt-decl-ids (F x) IDs. +indt-decl-ids (inductive ID _ _ _) [ID] :- !. +indt-decl-ids (minductive ID _ Arity Rest) [ID|IDs] :- !, + @pi-inductive ID Arity i\ indt-decl-ids (Rest i) IDs. +indt-decl-ids (record ID _ _ _) [ID] :- !. +indt-decl-ids (mblock _) []. + +func module-indt string, id -> inductive. +module-indt ModName ID I :- + QName is ModName ^ "." ^ ID, + coq.locate QName (indt I). + +func indt-constructors inductive -> list constructor. +indt-constructors I KS :- coq.env.indt I _ _ _ _ KS _. + +func set-indt-implicits inductive, list implicit_kind ->. +set-indt-implicits I Impl :- + if (coq.any-implicit? Impl) + (@global! ==> coq.arguments.set-implicit (indt I) [Impl]) + true. + +func set-indc-implicits constructor, list implicit_kind ->. +set-indc-implicits K Impl :- + if (coq.any-implicit? Impl) + (@global! ==> coq.arguments.set-implicit (indc K) [Impl]) + true. + +func set-indcs-implicits list constructor, list (list implicit_kind) ->. +set-indcs-implicits KS Impls :- + std.forall2 KS Impls set-indc-implicits. + +func decl+main.post string, indt-decl -> list prop. +decl+main.post ModName DS CL :- std.do! [ + indt-decl-ids DS IDs, + std.map IDs (module-indt ModName) IS, + std.map IS (i\r\ r = global (indt i)) ITS, + std.map IS indt-constructors KBlocks, + std.flatten KBlocks KS, std.map KS (k\r\ r = indc k) KGRS, std.map KGRS coq.gref->id KNS, std.map KGRS (gr\r\ r = global gr) KTS, - std.forall2 [TypeName|KNS] [global (indt I)|KTS] short-alias, + std.append IDs KNS AliasNames, + std.append ITS KTS AliasTerms, + std.forall2 AliasNames AliasTerms short-alias, - coq.indt-decl->implicits DS IndImpls KsImpls, - if (coq.any-implicit? IndImpls) - (@global! ==> coq.arguments.set-implicit (indt I) [IndImpls]) - true, - std.forall2 KsImpls KS (i\k\ - if (coq.any-implicit? i) - (@global! ==> coq.arguments.set-implicit (indc k) [i]) - true - ), + coq.indt-decl->implicits-all DS IndImpls KsImpls, + std.forall2 IS IndImpls set-indt-implicits, + std.forall2 KBlocks KsImpls set-indcs-implicits, std.map-filter CL export? P, std.do! P, ]. diff --git a/apps/derive/elpi/eqType.elpi b/apps/derive/elpi/eqType.elpi index 94de97839..1e8f09955 100644 --- a/apps/derive/elpi/eqType.elpi +++ b/apps/derive/elpi/eqType.elpi @@ -5,11 +5,43 @@ namespace derive.eqType.ast { func translate-indt inductive -> eqb.eqType, diagnostic. +translate-indt I O D :- + coq.env.mutual-inductives I GRS, std.length GRS N, N > 1, !, + coq.env.indt I _ Lno _ Arity KN KT, + translate-param-arity Lno Arity I KN KT O D. translate-indt I O D :- coq.env.indt-decl I Decl, coq.env.indt I _ _ _ _ KN _, translate-param Decl I KN O D. +func translate-param-arity int, term, inductive, list constructor, list term -> eqb.eqType, diagnostic. +translate-param-arity N (prod ID Ty F) I KS KTS (eqb.type-param F1) D :- N > 0, whd Ty [] {{ Type }} _, !, + @pi-decl ID Ty x\ pi y\ (term->trm x y ok :- !) ==> + sigma KTS1\ + std.map KTS (coq.subst-prod [x]) KTS1, + N1 is N - 1, + translate-param-arity N1 (F x) I KS KTS1 (F1 y) D. +translate-param-arity N (prod ID Ty F) I KS KTS (eqb.value-param Ty1 F1) D :- N > 0, term->trm Ty Ty1 ok, !, + @pi-decl ID Ty x\ pi y\ (term->trm x y ok :- !) ==> + sigma KTS1\ + std.map KTS (coq.subst-prod [x]) KTS1, + N1 is N - 1, + translate-param-arity N1 (F x) I KS KTS1 (F1 y) D. +translate-param-arity N (prod ID _ _) _ _ _ _ (error S) :- N > 0, !, + coq.name->id ID IDS, + S is "unsupported parameter " ^ IDS. +translate-param-arity 0 (sort _) I KS KTS (eqb.inductive I F) D :- !, + pi y\ (term->trm (global (indt I)) y ok :- !) => translate-constructors-terms KTS KS (F y) D. +translate-param-arity _ _ _ _ _ _ (error "unsupported inductive arity"). + +:index (1) +func translate-constructors-terms list term, list constructor -> list eqb.constructor, diagnostic. +translate-constructors-terms [] [] [] ok. +translate-constructors-terms [A|KS] [K|KK] [eqb.constructor K Args|KS1] D :- std.do-ok! D [ + translate-arguments A Args, + translate-constructors-terms KS KK KS1, +]. + func translate-param indt-decl, inductive, list constructor -> eqb.eqType, diagnostic. translate-param (parameter ID _ Ty F) I KS (eqb.type-param F1) D :- whd Ty [] {{ Type }} _, !, @pi-parameter ID Ty x\ pi y\ (term->trm x y ok :- !) => translate-param (F x) I KS (F1 y) D. @@ -44,6 +76,8 @@ translate-arguments (prod N Ty F) (eqb.dependent Ty1 F1) D :- !, std.do-ok! D [ (d\ @pi-decl N Ty x\ pi y\ term->trm x y ok => translate-arguments (F x) (F1 y) d), ]. translate-arguments Ty (eqb.stop Ty1) D :- name Ty, term->trm Ty Ty1 D, !. +translate-arguments (global _ as Ty) (eqb.stop Ty1) D :- term->trm Ty Ty1 D, !. +translate-arguments (app [global _|_] as Ty) (eqb.stop Ty1) D :- term->trm Ty Ty1 D, !. translate-arguments (app [N|_] as Ty) (eqb.stop Ty1) D :- name N, term->trm Ty Ty1 D, !. translate-arguments T _ (error S) :- S is "unsupported argument " ^ {coq.term->string T}. @@ -135,6 +169,17 @@ validate-arguments (eqb.dependent T Args) D :- std.do-ok! D [ (d\ pi x\ validate-arguments (Args x) d), ]. +func eqtype-clause inductive, eqb.eqType -> prop. +eqtype-clause I EQT (eqType (indt I) EQT). + +func main-mutual list inductive -> list prop. +main-mutual IS CL :- std.do! [ + std.map IS (i\eqt\ std.assert-ok! (translate-indt i eqt) "derive.eqType.ast: translate") EQTS, + std.map2 IS EQTS eqtype-clause CL, + CL =!=> std.forall EQTS (eqt\ std.assert-ok! (validate-eqType eqt) "derive.eqType.ast: validate"), + std.forall CL (c\ coq.elpi.accumulate _ "derive.eqType.db" (clause _ _ c)) +]. + func main inductive -> list prop. main I [C] :- std.assert-ok! (translate-indt I EQT) "derive.eqType.ast: translate", diff --git a/apps/derive/elpi/eqb.elpi b/apps/derive/elpi/eqb.elpi index 2c1ad32ba..4bec22c20 100644 --- a/apps/derive/elpi/eqb.elpi +++ b/apps/derive/elpi/eqb.elpi @@ -27,7 +27,9 @@ derive.eqb.main (indt I) Prefix CL :- std.do! [ derive.eqb.eqbf.do-clause FI FI [] [] EQBF [] CL1, derive.eqb.eqb.do-clause FI FI [] [] EQB [] CL2, CL = [CL1,CL2,eqb-done (indt I)], - std.forall CL (x\ coq.elpi.accumulate _ "derive.eqb.db" (clause _ _ x)), + coq.elpi.accumulate _ "derive.eqb.db" (clause _ _ CL1), + coq.elpi.accumulate _ "derive.eqb.db" (clause _ (before "eqb-for:whd") CL2), + coq.elpi.accumulate _ "derive.eqb.db" (clause _ _ (eqb-done (indt I))), ]. derive.eqb.main (const C) Prefix CL :- std.do! [ coq.env.const C (some T) _, @@ -41,6 +43,190 @@ derive.eqb.main (const C) Prefix CL :- std.do! [ ]. % derive.eqb.main (indc _) _ _ :- stop "eqrive.eqb cannot be called on constructors". +namespace derive.eqb.mutual { + +func eqb-ty eqb.eqType, eqb.eqType, list term, list term -> term. +eqb-ty (eqb.type-param FI) (eqb.type-param FJ) PI PJ {{ forall (p : Type) (eqp : p -> p -> bool), lp:(R p eqp) }} :- !, + @pi-trm `p` {{ Type }} y\p\ + @pi-decl `eqp` {{ lp:p -> lp:p -> bool }} eqp\ + eqb-ty (FI y) (FJ y) [p|PI] [p|PJ] (R p eqp). +eqb-ty (eqb.value-param TYI FI) (eqb.value-param TYJ FJ) PI PJ {{ forall (x : lp:TI) (y : lp:TJ), lp:(R x y) }} :- !, + feqb.trm->term TYI TI, + feqb.trm->term TYJ TJ, + @pi-trm `x` TI xx\x\ + @pi-trm `y` TJ yy\y\ + eqb-ty (FI xx) (FJ yy) [x|PI] [y|PJ] (R x y). +eqb-ty (eqb.inductive Ind _) (eqb.inductive Ind _) PI PJ {{ lp:I -> lp:J -> bool }} :- + coq.env.global (indt Ind) IndT, + coq.mk-app IndT {std.rev PI} I, + coq.mk-app IndT {std.rev PJ} J. + +func eqbf-ty eqb.eqType, eqb.eqType, list term, list term -> term. +eqbf-ty (eqb.type-param FI) (eqb.type-param FJ) PI PJ {{ forall (p : Type) (eqp : p -> p -> bool), lp:(R p eqp) }} :- !, + @pi-trm `p` {{ Type }} y\p\ + @pi-decl `eqp` {{ lp:p -> lp:p -> bool }} eqp\ + eqbf-ty (FI y) (FJ y) [p|PI] [p|PJ] (R p eqp). +eqbf-ty (eqb.value-param TYI FI) (eqb.value-param TYJ FJ) PI PJ {{ forall (x : lp:TI) (y : lp:TJ), lp:(R x y) }} :- !, + feqb.trm->term TYI TI, + feqb.trm->term TYJ TJ, + @pi-trm `x` TI xx\x\ + @pi-trm `y` TJ yy\y\ + eqbf-ty (FI xx) (FJ yy) [x|PI] [y|PJ] (R x y). +eqbf-ty (eqb.inductive Ind _) (eqb.inductive Ind _) PI PJ {{ (lp:I -> lp:J -> bool) -> forall x : lib:elpi.derive.positive, lp:FieldsI x -> lp:FieldsJ x -> bool }} :- + coq.env.global (indt Ind) IndT, + coq.mk-app IndT {std.rev PI} I, + coq.mk-app IndT {std.rev PJ} J, + std.assert! (fields-for Ind F_t _ _ _) "derive.eqb: run derive.fields before", + coq.env.global (const F_t) FT, + coq.mk-app FT {std.rev PI} FieldsI, + coq.mk-app FT {std.rev PJ} FieldsJ. + +func mutual-prefix inductive, string, inductive -> string. +mutual-prefix First Prefix T Prefix :- First = T, !. +mutual-prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_". + +kind eqb-mutual-spec type. +type eqb-mutual-spec inductive -> term -> eqb.eqType -> list term -> eqb-mutual-spec. + +func eqb-mutual-spec-of inductive -> eqb-mutual-spec. +eqb-mutual-spec-of I (eqb-mutual-spec I (global (indt I)) FI []) :- + std.assert! (eqType (indt I) FI) "this inductive is not supported". + +func eqb-mutual-spec-ind eqb-mutual-spec -> inductive. +eqb-mutual-spec-ind (eqb-mutual-spec I _ _ _) I. + +func eqb-mutual-ty eqb-mutual-spec -> term. +eqb-mutual-ty (eqb-mutual-spec _ IT _ _) {{ lp:IT -> lp:IT -> bool }}. + +func eqb-mutual-clause eqb-mutual-spec, term -> prop. +eqb-mutual-clause (eqb-mutual-spec _ IT _ _) F (eqb-for IT IT F). + +func eqb-mutual-body eqb-mutual-spec, term -> term. +eqb-mutual-body (eqb-mutual-spec _ IT FI PI) F (fun `x1` IT (x1\ fun `x2` IT (x2\ Bo x1 x2))) :- std.do! [ + derive.eqb.eqbf.main FI FI PI PI Eqbf, + @pi-decl `x1` IT x1\ + @pi-decl `x2` IT x2\ + derive.eqb.eqb.do-match x1 IT x2 IT {coq.mk-app Eqbf [F]} (Bo x1 x2) +]. + +func eqb-mutual-mfix-aux list eqb-mutual-spec, list eqb-mutual-spec, list term -> mfix-block. +eqb-mutual-mfix-aux All [] RevF (mfix-bo Bodies) :- !, + std.rev RevF Funs, + std.map2 All Funs eqb-mutual-clause Clauses, + Clauses =!=> std.map2 All Funs eqb-mutual-body Bodies. +eqb-mutual-mfix-aux All [S|SS] RevF (mfix-ty N 0 Ty Rest) :- + S = eqb-mutual-spec I _ _ _, + coq.gref->id (indt I) ID, + coq.id->name ID N, + eqb-mutual-ty S Ty, + @pi-decl N Ty f\ eqb-mutual-mfix-aux All SS [f|RevF] (Rest f). + +func eqb-mutual-mfix list eqb-mutual-spec, int -> term. +eqb-mutual-mfix Specs Focus (mfix Focus 0 Block) :- + eqb-mutual-mfix-aux Specs Specs [] Block. + +func eqb-mutual-spec-apply-type-param eqb.trm, term, eqb-mutual-spec -> eqb-mutual-spec. +eqb-mutual-spec-apply-type-param X A (eqb-mutual-spec I IT (eqb.type-param F) PI) (eqb-mutual-spec I ITA (F X) [A|PI]) :- !, + coq.mk-app IT [A] ITA. +eqb-mutual-spec-apply-type-param _ _ _ _ :- stop "derive.eqb: mutual parameter mismatch". + +func eqb-body-mutual-params list eqb-mutual-spec, int -> term. +eqb-body-mutual-params ([eqb-mutual-spec _ _ (eqb.type-param _) _|_] as Specs) Focus R :- !, + R = {{ fun (a : Type) (eqA : a -> a -> bool) => lp:(Bo a eqA) }}, + @pi-trm `a` {{ Type }} x\a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + sigma Specs1\ + std.map Specs (eqb-mutual-spec-apply-type-param x a) Specs1, + eqb-for a a eqA => + eqb-body-mutual-params Specs1 Focus (Bo a eqA). +eqb-body-mutual-params Specs Focus R :- + eqb-mutual-mfix Specs Focus R. + +func eqb-supported-arity term ->. +eqb-supported-arity (sort _) :- !. +eqb-supported-arity (prod _ S F) :- coq.sort? S, !, + @pi-decl `_` S x\ eqb-supported-arity (F x). + +func add-mutual-eqb-consts inductive, list eqb-mutual-spec, list eqb-mutual-spec, string, int -> list (pair inductive constant), list prop. +add-mutual-eqb-consts _ _ [] _ _ [] [] :- !. +add-mutual-eqb-consts Selected All [S|SS] Prefix Focus [pr I C|Cs] [Clause, eqb-done (indt I)|CLs] :- std.do! [ + S = eqb-mutual-spec I _ FI _, + eqb-body-mutual-params All Focus R, + std.assert-ok! (coq.typecheck R Ty) "derive.eqb generates illtyped mutual term", + mutual-prefix Selected Prefix I P, + Name is P ^ "eqb", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName R Ty @transparent! C, + derive.eqb.eqb.do-clause FI FI [] [] (global (const C)) [] Clause, + coq.elpi.accumulate _ "derive.eqb.db" (clause _ (before "eqb-for:whd") Clause), + coq.elpi.accumulate _ "derive.eqb.db" (clause _ _ (eqb-done (indt I))), + Focus1 is Focus + 1, + add-mutual-eqb-consts Selected All SS Prefix Focus1 Cs CLs +]. + +func add-mutual-eqbf-consts inductive, list eqb-mutual-spec, string, list prop -> list prop. +add-mutual-eqbf-consts _ [] _ _ [] :- !. +add-mutual-eqbf-consts Selected [S|SS] Prefix EqbClauses [CL1|CLs] :- std.do! [ + S = eqb-mutual-spec I _ FI _, + EqbClauses =!=> derive.eqb.eqbf.main FI FI [] [] R, + std.assert-ok! (coq.typecheck R Ty) "derive.eqbf generates illtyped mutual term", + mutual-prefix Selected Prefix I P, + Name is P ^ "eqb_fields", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName R Ty @transparent! C, + EqbClauses =!=> derive.eqb.eqbf.do-clause FI FI [] [] (global (const C)) [] CL1, + coq.elpi.accumulate _ "derive.eqb.db" (clause _ _ CL1), + add-mutual-eqbf-consts Selected SS Prefix EqbClauses CLs +]. + +func add-all-consts inductive, list inductive, string -> list prop. +add-all-consts Selected IS Prefix CL :- std.do! [ + std.map IS eqb-mutual-spec-of Specs, + add-mutual-eqb-consts Selected Specs Specs Prefix 0 _ EqbCL, + add-mutual-eqbf-consts Selected Specs Prefix EqbCL EqbfCL, + std.append EqbfCL EqbCL CL +]. + +func type-param1-eqb-ty inductive -> term. +type-param1-eqb-ty I EqbTy :- + coq.env.indt I _ 1 _ (prod N Ty _) _ _, !, + coq.env.global (indt I) IndT, + EqbTy = prod N Ty (p\ prod `eqp` (prod `_` p (_\ prod `_` p (_\ {{ bool }}))) (eqp\ prod `_` (Ip p) (_\ prod `_` (Ip p) (_\ {{ bool }})))), + @pi-decl N Ty p\ coq.mk-app IndT [p] (Ip p). + +func type-param1-eqbf-ty inductive -> term. +type-param1-eqbf-ty I EqbfTy :- + coq.env.indt I _ 1 _ (prod N Ty _) _ _, !, + coq.env.global (indt I) IndT, + std.assert! (fields-for I F_t _ _ _) "derive.eqb: run derive.fields before", + coq.env.global (const F_t) FT, + EqbfTy = prod N Ty (p\ prod `eqp` (prod `_` p (_\ prod `_` p (_\ {{ bool }}))) + (eqp\ prod `_` (prod `_` (Ip p) (_\ prod `_` (Ip p) (_\ {{ bool }}))) + (eqi\ prod `x` {{ lib:elpi.derive.positive }} (x\ prod `_` (app [Fields p, x]) (_\ prod `_` (app [Fields p, x]) (_\ {{ bool }})))))), + @pi-decl N Ty p\ + coq.mk-app IndT [p] (Ip p), + coq.mk-app FT [p] (Fields p). + +func add-one-param1 inductive, string -> list prop. +add-one-param1 I _ _ :- + coq.error "derive.eqb: mutual eqb generation for this parameterized shape still needs to be implemented" (indt I). + +func add-one inductive, string -> list prop. +add-one I Prefix CL :- eqType (indt I) (eqb.type-param _), coq.env.indt I _ 1 _ _ _ _, !, add-one-param1 I Prefix CL. +add-one I _ _ :- + std.assert! (eqType (indt I) _) "this inductive is not supported", + coq.error "derive.eqb: mutual eqb generation for this shape still needs to be implemented" (indt I). + +func main inductive, list inductive, string -> list prop. +main _ [] _ [] :- !. +main Selected ([First|_] as IS) Prefix CL :- coq.env.indt First _ Lno Lno Arity _ _, eqb-supported-arity Arity, !, + add-all-consts Selected IS Prefix CL. +main Selected IS Prefix CL :- + std.map IS (i\c\ sigma p\ mutual-prefix Selected Prefix i p, add-one i p c) CLS, + std.flatten CLS CL. + +} + namespace derive.eqb.eqb { % ----------------------------------------------------------------------------- @@ -112,8 +298,9 @@ do-clause (eqb.value-param _ AI) (eqb.value-param _ AJ) PI PJ F Todo (pi a b\ C do-clause (AI x) (AJ x) [a|PI] [b|PJ] {coq.mk-app F [a,b]} Todo (C a b). do-clause (eqb.inductive Ind _) (eqb.inductive Ind _) PI PJ F Todo (eqb-for I J F :- Todo) :- - coq.mk-app (global (indt Ind)) {std.rev PI} I, - coq.mk-app (global (indt Ind)) {std.rev PJ} J. + coq.env.global (indt Ind) IndT, + coq.mk-app IndT {std.rev PI} I, + coq.mk-app IndT {std.rev PJ} J. } @@ -236,8 +423,9 @@ do-clause (eqb.value-param _ AI) (eqb.value-param _ AJ) PI PJ F Todo (pi a b\ C do-clause (AI x) (AJ x) [a|PI] [b|PJ] {coq.mk-app F [a,b]} Todo (C a b). do-clause (eqb.inductive Ind _) (eqb.inductive Ind _) PI PJ F Todo (pi ela\ eqb-fields I J (F1 ela) :- [C ela|Todo]) :- !, - coq.mk-app (global (indt Ind)) {std.rev PI} I, - coq.mk-app (global (indt Ind)) {std.rev PJ} J, + coq.env.global (indt Ind) IndT, + coq.mk-app IndT {std.rev PI} I, + coq.mk-app IndT {std.rev PJ} J, pi ela\ (coq.mk-app F [ela] (F1 ela), C ela = eqb-for I J ela). diff --git a/apps/derive/elpi/eqbcorrect.elpi b/apps/derive/elpi/eqbcorrect.elpi index 2ae878955..ece4caa0e 100644 --- a/apps/derive/elpi/eqbcorrect.elpi +++ b/apps/derive/elpi/eqbcorrect.elpi @@ -20,6 +20,97 @@ has-params? (eqb.value-param _ _). % eg: config {{ @eqb_correct }} {{ @eqb_correct_on }} {{ @eqb_body_correct }} "eqb_correct_on__solver" correct-lemma-for pred config o:term, o:term, o:term, o:string, o:(pred i:term, o:term). +namespace mutual { + +func correct-ty eqb.eqType, list term, term -> term. +correct-ty (eqb.type-param F) PI EQB {{ forall (p : Type) (eqp : p -> p -> bool), @eqb_correct p eqp -> lp:(R p eqp) }} :- !, + @pi-trm `p` {{ Type }} y\p\ + @pi-decl `eqp` {{ lp:p -> lp:p -> bool }} eqp\ + correct-ty (F y) [p|PI] {coq.mk-app EQB [p,eqp]} (R p eqp). +correct-ty (eqb.value-param TY F) PI EQB {{ forall (x y : lp:Ty), lp:(R x y) }} :- !, + feqb.trm->term TY Ty, + @pi-trm `x` Ty xx\x\ + @pi-trm `y` Ty yy\y\ + correct-ty (F xx) [x|PI] {coq.mk-app EQB [x,y]} (R x y). +correct-ty (eqb.inductive Ind _) PI EQB {{ forall x : lp:I, @eqb_correct_on lp:I lp:EQB x }} :- + coq.mk-app (global (indt Ind)) {std.rev PI} I. + +func refl-ty eqb.eqType, list term, term -> term. +refl-ty (eqb.type-param F) PI EQB {{ forall (p : Type) (eqp : p -> p -> bool), @eqb_reflexive p eqp -> lp:(R p eqp) }} :- !, + @pi-trm `p` {{ Type }} y\p\ + @pi-decl `eqp` {{ lp:p -> lp:p -> bool }} eqp\ + refl-ty (F y) [p|PI] {coq.mk-app EQB [p,eqp]} (R p eqp). +refl-ty (eqb.value-param TY F) PI EQB {{ forall (x y : lp:Ty), lp:(R x y) }} :- !, + feqb.trm->term TY Ty, + @pi-trm `x` Ty xx\x\ + @pi-trm `y` Ty yy\y\ + refl-ty (F xx) [x|PI] {coq.mk-app EQB [x,y]} (R x y). +refl-ty (eqb.inductive Ind _) PI EQB {{ forall x : lp:I, @eqb_refl_on lp:I lp:EQB x }} :- + coq.mk-app (global (indt Ind)) {std.rev PI} I. + +func aux-ty term, eqb.eqType, list term, list term, term -> term. +aux-ty Pred_on (eqb.type-param F) PI RealiArgs EQB {{ forall (p : Type) (eqp : p -> p -> bool), lp:(R p eqp) }} :- !, + @pi-trm `p` {{ Type }} y\p\ + @pi-decl `eqp` {{ lp:p -> lp:p -> bool }} eqp\ + sigma RealiArgs1\ sigma EQB1\ std.do! [ + std.append RealiArgs [p,{{ lp:Pred_on lp:p lp:eqp }}] RealiArgs1, + coq.mk-app EQB [p,eqp] EQB1, + aux-ty Pred_on (F y) [p|PI] RealiArgs1 EQB1 (R p eqp) + ]. +aux-ty Pred_on (eqb.value-param TY F) PI RealiArgs EQB {{ forall (x : lp:Ty) (px : lp:TR x), lp:(R x px) }} :- !, + feqb.trm->term TY Ty, + mk-reali Ty TR, + @pi-trm `x` Ty xx\x\ + @pi-decl `px` {{ lp:TR lp:x }} px\ + sigma RealiArgs1\ sigma EQB1\ std.do! [ + std.append RealiArgs [x,px] RealiArgs1, + coq.mk-app EQB [x,x] EQB1, + aux-ty Pred_on (F xx) [x|PI] RealiArgs1 EQB1 (R x px) + ]. +aux-ty Pred_on (eqb.inductive Ind _) PI RealiArgs EQB {{ forall x : lp:I, lp:IRR x -> lp:Pred_on lp:I lp:EQB x }} :- + coq.mk-app (global (indt Ind)) {std.rev PI} I, + mk-reali (global (indt Ind)) IR, + coq.mk-app IR RealiArgs IRR. + +func mutual-prefix inductive, string, inductive -> string. +mutual-prefix First Prefix T Prefix :- First = T, !. +mutual-prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_". + +func add-one list inductive, list eqb.eqType, list term, inductive, string -> list prop. +add-one _MutualInds MutualFIs MutualRealis I Prefix [Clause, ClauseC, ClauseR] :- std.do! [ + std.assert! (eqType (indt I) FI) "this inductive is not supported", + std.assert! (induction-db I Indu) "call derive.induction before", + + std.assert! ((config {{ @eqb_correct }} {{ @eqb_correct_on }} {{ @eqb_body_correct }} "eqb_correct_on__solver" correct-lemma-for => + common-mutual FI [] Indu MutualFIs MutualRealis CorrectTerm)) "derive.eqbcorrect: failed to build mutual correct proof", + std.assert-ok! (coq.typecheck CorrectTerm CTy) "derive.eqbcorrect: mutual correct proof is illtyped", + CName is Prefix ^ "eqb_correct", + coq.ensure-fresh-global-id CName FCName, + coq.env.add-const FCName CorrectTerm CTy @transparent! Correct, + + std.assert! ((config {{ @eqb_reflexive }} {{ @eqb_refl_on }} {{ @eqb_body_refl }} "eqb_refl_on__solver" refl-lemma-for => + common-mutual FI [] Indu MutualFIs MutualRealis ReflTerm)) "derive.eqbcorrect: failed to build mutual refl proof", + std.assert-ok! (coq.typecheck ReflTerm RTy) "derive.eqbcorrect: mutual refl proof is illtyped", + RName is Prefix ^ "eqb_refl", + coq.ensure-fresh-global-id RName FRName, + coq.env.add-const FRName ReflTerm RTy @transparent! Refl, + + Clause = eqcorrect-for (indt I) Correct Refl, + ClauseC = correct-lemma-for (global (indt I)) (global (const Correct)), + ClauseR = refl-lemma-for (global (indt I)) (global (const Refl)), + std.forall [Clause,ClauseC,ClauseR] (x\coq.elpi.accumulate _ "derive.eqbcorrect.db" (clause _ _ x)) +]. + +func main inductive, list inductive, string -> list prop. +main _ [] _ [] :- !. +main Selected IS Prefix CL :- + std.map IS (i\fi\ std.assert! (eqType (indt i) fi) "this inductive is not supported") MutualFIs, + std.map IS (i\r\ mk-reali (global (indt i)) r) MutualRealis, + std.map IS (i\c\ sigma p\ mutual-prefix Selected Prefix i p, add-one IS MutualFIs MutualRealis i p c) CLS, + std.flatten CLS CL. + +} + func main gref, string -> list prop. main (indt I) Prefix CLs :- std.do! [ @@ -210,6 +301,103 @@ common (eqb.inductive I Ks) ParamsRev Ind O :- std.do! [ O = {{ fun (x :lp:Ty) (common : lp:CommonTy := lp:Common) => lp:(R x common) }}, ]. +%--------------------------------------------------------------------------- +% Variant of common used for mutual inductives. Constructor hypotheses for +% recursive fields already receive the mutual induction hypothesis, so branch +% generation consumes that hypothesis instead of looking for a previously +% registered correctness lemma for another member of the same block. + +func mutual-reali list term, term ->. +mutual-reali [IR|_] EqbOn :- + coq.safe-dest-app EqbOn HD _, same_term HD IR, !. +mutual-reali [_|IRS] EqbOn :- mutual-reali IRS EqbOn. + +func build-mutual-branches list term, list term, list eqb.eqType, (func (list term) -> term) -> term. +build-mutual-branches _ _ [] K R :- K [] R. +build-mutual-branches MutualRealis Params [eqb.inductive I Ks|Rest] K R :- std.do! [ + config _Pred _Pred_on Pred_body _Solver _Db, + coq.mk-app (global (indt I)) Params Ty, + tag-for I TagC, + fields-for I Fields_tC FieldsC ConstructC ConstructPC, + coq.mk-app (global (const TagC)) Params Tag, + coq.mk-app (global (const Fields_tC)) Params Fields_t, + coq.mk-app (global (const FieldsC)) Params Fields, + coq.mk-app (global (const ConstructC)) Params Construct, + coq.mk-app (global (const ConstructPC)) Params ConstructP, + eqb-fields Ty Ty EqbFields, + Common = ({{ lp:Pred_body lp:Ty lp:Tag lp:Fields_t lp:Fields lp:Construct lp:ConstructP lp:EqbFields }} : term), + std.assert-ok! (coq.typecheck Common CommonTy) "WTF", + @pi-def `common` CommonTy Common c\ std.do! [ + (common-body c => fields-t Tag Fields_t Fields Construct => + pi i\ (feqb.trm->term i Ty :- !) => + std.map (Ks i) (branch-mutual MutualRealis Params) (Branches c)), + build-mutual-branches MutualRealis Params Rest (more\r\ K {std.append (Branches c) more} r) (Body c) + ], + R = (let `common` CommonTy Common c\ Body c) +]. + +func mutual-fis-apply-type-param eqb.trm, list eqb.eqType -> list eqb.eqType. +mutual-fis-apply-type-param _ [] []. +mutual-fis-apply-type-param A [eqb.type-param F|FS] [F A|FS1] :- + mutual-fis-apply-type-param A FS FS1. + +:index (1) +func common-mutual eqb.eqType, list term, term, list eqb.eqType, list term -> term. +common-mutual (eqb.type-param F) Params Ind MutualFIs MutualRealis O :- std.do! [ + config Pred Pred_on _Pred_body _Solver Db, + O = {{ fun (a : lp:Type) (eqA : a -> a -> bool) (eqAc : lp:Pred a eqA) => lp:(R a eqA eqAc) }}, + Type = sort (typ {coq.univ.new}), + @pi-trm `a` Type aa\a\ + @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ + @pi-decl `eqAc` {{ lp:Pred lp:a lp:eqA }} eqAc\ + param1-inhab-db {{ lp:Pred_on lp:a lp:eqA }} eqAc => + eqb-for a a eqA => + reali a {{ lp:Pred_on lp:a lp:eqA }} => + prove Db a {{ fun (x: lp:a) (Hx : lp:Pred_on lp:a lp:eqA x) => Hx }} => sigma MutualFIs1\ std.do! [ + std.assert! (mutual-fis-apply-type-param aa MutualFIs MutualFIs1) "derive.eqbcorrect: failed to apply mutual type parameter", + std.assert! (common-mutual (F aa) [a|Params] + {coq.mk-app Ind [a, {{ lp:Pred_on lp:a lp:eqA }} ] } + MutualFIs1 MutualRealis (R a eqA eqAc)) "derive.eqbcorrect: failed after mutual type parameter" + ] +]. + +common-mutual (eqb.value-param TY F) Params Ind MutualFIs MutualRealis O :- std.do! [ + feqb.trm->term TY T, + O = {{ fun (a : lp:T) => lp:(R a) }}, + mk-reali T TR, + std.assert! (param1-inhab-db TR Is_full) "not trivially inhabited", + @pi-trm `a` T aa\a\ + reali a {{ lp:Is_full lp:a }} => std.do! [ + std.map MutualFIs (fi\fi1\ sigma F1 TY1\ fi = eqb.value-param TY1 F1, fi1 = F1 aa) MutualFIs1, + common-mutual (F aa) [a|Params] + {{ lp:Ind lp:a (lp:Is_full lp:a) }} + MutualFIs1 MutualRealis (R a) + ] +]. + +common-mutual (eqb.inductive I _) ParamsRev Ind MutualFIs MutualRealis O :- std.do! [ + config _Pred Pred_on _Pred_body _Solver _Db, + std.rev ParamsRev Params, + coq.mk-app (global (indt I)) Params Ty, + + mk-reali (global (indt I)) IR, + coq.safe-dest-app Ind _ RealiArgs, + coq.mk-app IR RealiArgs TyR, + std.assert! (param1-inhab-db TyR Is_full) "not trivially inhabited", + + std.map MutualFIs (fi\m\ sigma J Ks TyJ CmpJ\ + fi = eqb.inductive J Ks, + coq.mk-app (global (indt J)) Params TyJ, + mk-eqb-for TyJ CmpJ, + m = {{ lp:Pred_on lp:TyJ lp:CmpJ }}) Motives, + + (@pi-decl `x` Ty x\ + build-mutual-branches MutualRealis Params MutualFIs + (branches\r\ coq.mk-app Ind {std.append Motives {std.append branches [x, app[Is_full,x]]}} r) + (R x)), + O = {{ fun (x :lp:Ty) => lp:(R x) }}, +]. + %--------------------------------------------------------------------------- :index (1) @@ -264,6 +452,64 @@ common-aux (eqb.inductive I Ks) ParamsRev Ind O :- std.do! [ %--------------------------------------------------------------------------- +func branch-mutual list term, list term, eqb.constructor -> term. +branch-mutual MutualRealis Params (eqb.constructor K Args) R :- + coq.mk-app (global (indc K)) Params KParams, + args-mutual MutualRealis Args KParams [] [] [] 0 R. + +:index (2) +func args-mutual list term, eqb.arguments, term, list term, list term, list term, int -> term. +args-mutual MutualRealis (eqb.irrelevant TY Args) K As Hs Bs N O :- !, std.do! [ + O = {{ fun (x : lp:T) (px : lp:EqbOn x) => lp:(R x px) }}, + feqb.trm->term TY T, + mk-reali T EqbOn, + @pi-decl `x` T x\ + @pi-decl `px` {{ lp:EqbOn lp:x }} px\ + args-mutual MutualRealis Args {coq.mk-app K [x]} [x|As] Hs Bs {calc (N + 1)} (R x px) +]. + +args-mutual MutualRealis (eqb.regular TY Args) K As Hs Bs N O :- !, std.do! [ + config _Pred Pred_on _Pred_body _Solver Db, + feqb.trm->term TY T, + mk-reali T EqbOn, + mk-eqb-for T Cmp, + EqbOn' = {{ lp:Pred_on lp:T lp:Cmp }}, + if (mutual-reali MutualRealis EqbOn) + (O = {{ fun (x : lp:T) (px : lp:EqbOn x) (h : lp:EqbOn' x) => lp:(R x px h) }}, + @pi-decl `x` T x\ + @pi-decl `px` {{ lp:EqbOn lp:x }} px\ + @pi-decl `h` {{ lp:EqbOn' lp:x }} h\ + args-mutual MutualRealis Args {coq.mk-app K [x]} [x|As] [h|Hs] [{{ lp:Cmp lp:x }}|Bs] N (R x px h)) + (O = {{ fun (x : lp:T) (px : lp:EqbOn x) (h : lp:EqbOn' x := lp:View x px) => lp:(R x px h) }}, + if (same_term EqbOn EqbOn') (View = {{ fun (x : lp:T) (px : lp:EqbOn x) => px }}) (prove Db T View), + @pi-decl `x` T x\ + @pi-decl `px` {{ lp:EqbOn lp:x }} px\ + @pi-def `h` {{ lp:EqbOn' lp:x }} {{ lp:View lp:x lp:px }} h\ + args-mutual MutualRealis Args {coq.mk-app K [x]} [x|As] [h|Hs] [{{ lp:Cmp lp:x }}|Bs] N (R x px h)) +]. + +args-mutual MutualRealis (eqb.dependent TY Args) K As Hs Bs N O :- !, std.do! [ + config _Pred Pred_on _Pred_body _Solver Db, + feqb.trm->term TY T, + mk-reali T EqbOn, + mk-eqb-for T Cmp, + EqbOn' = {{ lp:Pred_on lp:T lp:Cmp }}, + if (mutual-reali MutualRealis EqbOn) + (O = {{ fun (x : lp:T) (px : lp:EqbOn x) (h : lp:EqbOn' x) => lp:(R x px h) }}, + @pi-trm `x` T xx\x\ + @pi-decl `px` {{ lp:EqbOn lp:x }} px\ reali x px => + @pi-decl `h` {{ lp:EqbOn' lp:x }} h\ + args-mutual MutualRealis (Args xx) {coq.mk-app K [x]} [x|As] [h|Hs] [{{ lp:Cmp lp:x }}|Bs] {calc (N + 1)} (R x px h)) + (O = {{ fun (x : lp:T) (px : lp:EqbOn x) (h : lp:EqbOn' x := lp:View x px) => lp:(R x px h) }}, + if (same_term EqbOn EqbOn') (View = {{ fun (x : lp:T) (px : lp:EqbOn x) => px }}) (prove Db T View), + @pi-trm `x` T xx\x\ + @pi-decl `px` {{ lp:EqbOn lp:x }} px\ reali x px => + @pi-def `h` {{ lp:EqbOn' lp:x }} {{ lp:View lp:x lp:px }} h\ + args-mutual MutualRealis (Args xx) {coq.mk-app K [x]} [x|As] [h|Hs] [{{ lp:Cmp lp:x }}|Bs] {calc (N + 1)} (R x px h)) +]. + +args-mutual _ (eqb.stop TY) K As Hs Bs N O :- !, args (eqb.stop TY) K As Hs Bs N O. + func branch list term, eqb.constructor -> term. branch Params (eqb.constructor K Args) R :- coq.mk-app (global (indc K)) Params KParams, diff --git a/apps/derive/elpi/fields.elpi b/apps/derive/elpi/fields.elpi index aa4213d08..28d87a032 100644 --- a/apps/derive/elpi/fields.elpi +++ b/apps/derive/elpi/fields.elpi @@ -49,7 +49,7 @@ main I Prefix AllCL :- std.do! [ std.assert-ok! (coq.elaborate-skeleton Body_PSkel Ty_P Body_P) "derive.fields generates illtyped constructP", Name_P is Prefix ^ "constructP", coq.ensure-fresh-global-id Name_P FName_P, - coq.env.add-const FName_P Body_P Ty_P @opaque! ConstructP, + coq.env.add-const FName_P Body_P Ty_P @opaque! ConstructP, AllCL = [fields-for I Fields_t Fields Construct ConstructP|CLB], std.forall AllCL (x\ coq.elpi.accumulate _ "derive.fields.db" (clause _ _ x)), @@ -59,9 +59,15 @@ main I Prefix AllCL :- std.do! [ % ---------------------------------------------------------------------- :index (1) +func type-param-domain term -> term. +type-param-domain I Ty :- + std.assert-ok! (coq.typecheck I ITy) "derive.fields: illtyped type parameter head", + ITy = prod _ Ty _. + func fields_t.main eqb.eqType, term -> term. -fields_t.main (eqb.type-param F) I {{ fun p : Type => lp:(R p) }} :- !, - @pi-trm `p` {{ Type }} x\p\ +fields_t.main (eqb.type-param F) I (fun `p` Ty R) :- !, + type-param-domain I Ty, + @pi-trm `p` Ty x\p\ fields_t.main (F x) {coq.mk-app I [p]} (R p). fields_t.main (eqb.value-param TY F) I {{ fun p : lp:Ty => lp:(R p) }} :- !, @@ -86,8 +92,9 @@ fields_t.k Params (eqb.constructor K _) T :- % ---------------------------------------------------------------------- func fields.main eqb.eqType, term, term, term -> term. -fields.main (eqb.type-param F) I F_t Tag {{ fun p : Type => lp:(R p) }} :- !, - @pi-trm `p` {{ Type }} x\p\ +fields.main (eqb.type-param F) I F_t Tag (fun `p` Ty R) :- !, + type-param-domain I Ty, + @pi-trm `p` Ty x\p\ fields.main (F x) {coq.mk-app I [p]} {coq.mk-app F_t [p]} {coq.mk-app Tag [p]} (R p). fields.main (eqb.value-param TY F) I F_t Tag {{ fun p : lp:Ty => lp:(R p) }} :- !, @@ -136,9 +143,10 @@ kind box-spec type. func box.aux eqb.eqType, term -> list box-spec. box.aux (eqb.type-param F) I L :- - (@pi-trm `p` {{ Type }} x\y\ + type-param-domain I Ty, + (@pi-trm `p` Ty x\y\ box.aux (F x) {coq.mk-app I [y]} (L1 y)), - distribute L1 (f\r\ sigma U\ r = parameter "A" explicit (sort (typ U)) f) L. + distribute L1 (f\r\ r = parameter "A" explicit Ty f) L. box.aux (eqb.value-param TY F) I L :- feqb.trm->term TY Ty, @@ -180,8 +188,9 @@ distribute (x\ [same-box K| XS x]) F [same-box K|R] :- distribute XS F R. % ---------------------------------------------------------------------- :index(1) func construct.main eqb.eqType, term, constant -> term. -construct.main (eqb.type-param F) I F_t {{ fun p : Type => lp:(R p) }} :- - @pi-trm `p` {{ Type }} x\p\ +construct.main (eqb.type-param F) I F_t (fun `p` Ty R) :- + type-param-domain I Ty, + @pi-trm `p` Ty x\p\ construct.main (F x) {coq.mk-app I [p]} F_t (R p). construct.main (eqb.value-param TY F) I F_t {{ fun p : lp:Ty => lp:(R p) }} :- diff --git a/apps/derive/elpi/induction.elpi b/apps/derive/elpi/induction.elpi index 39b790139..d15babe7f 100644 --- a/apps/derive/elpi/induction.elpi +++ b/apps/derive/elpi/induction.elpi @@ -117,6 +117,479 @@ params 0 Ity K KT Arity (fun `P` Pty p\ Bo p) :- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +kind derive.induction.mutual-spec type. +type derive.induction.mutual-spec inductive -> inductive -> term -> term -> list term -> list term -> derive.induction.mutual-spec. + +func mutual-spec inductive -> derive.induction.mutual-spec. +mutual-spec GR (derive.induction.mutual-spec GR GRR (global (indt GRR)) Arity K KT) :- + reali (global (indt GR)) (global (indt GRR)), + coq.env.indt GRR _ _ _ Arity KGR KT, + std.map KGR (k\r\ r = global (indc k)) K. + +func mutual-spec-ind derive.induction.mutual-spec -> inductive. +mutual-spec-ind (derive.induction.mutual-spec _ GRR _ _ _ _) GRR. + +func mutual-spec-arity derive.induction.mutual-spec -> term. +mutual-spec-arity (derive.induction.mutual-spec _ _ _ Arity _ _) Arity. + +func mutual-spec-apply-param term, derive.induction.mutual-spec -> derive.induction.mutual-spec. +mutual-spec-apply-param A (derive.induction.mutual-spec GR GRR IsT (prod _ _ F) K KT) + (derive.induction.mutual-spec GR GRR IsTA (F A) KA KTA) :- !, + coq.mk-app IsT [A] IsTA, + map K (k\ coq.mk-app k [A]) KA, + map KT (coq.subst-prod [A]) KTA. +mutual-spec-apply-param _ _ _ :- stop "derive.induction: mutual parameter mismatch". + +func mutual-spec-apply-param2 term, term, derive.induction.mutual-spec -> derive.induction.mutual-spec. +mutual-spec-apply-param2 A PA (derive.induction.mutual-spec GR GRR IsT (prod _ _ (a\ prod _ _ (pa\ F a pa))) K KT) + (derive.induction.mutual-spec GR GRR IsTAP (F A PA) KAP KTAP) :- !, + coq.mk-app IsT [A,PA] IsTAP, + map K (k\ coq.mk-app k [A,PA]) KAP, + map KT (coq.subst-prod [A,PA]) KTAP. +mutual-spec-apply-param2 _ _ _ _ :- stop "derive.induction: mutual parameter mismatch". + +func mutual-specs-apply-param2 term, term, list derive.induction.mutual-spec -> list derive.induction.mutual-spec. +mutual-specs-apply-param2 _ _ [] []. +mutual-specs-apply-param2 A PA [S|SS] [S1|SS1] :- + mutual-spec-apply-param2 A PA S S1, + mutual-specs-apply-param2 A PA SS SS1. + +func mk-app-prefix term, list term -> term. +mk-app-prefix (app L) Args (app AllArgs) :- !, + std.append L Args AllArgs. +mk-app-prefix F Args (app [F|Args]) :- !. + +pred pred-prefix i:term, i:term, o:list term. +pred-prefix IsT T Rest :- + coq.safe-dest-app IsT HDI IArgs, + coq.safe-dest-app T HD Args, + same_term HD HDI, + appendR IArgs Rest Args. + +func pred-app list term, list term, term -> term. +pred-app [IsT|_] [P|_] T R :- + pred-prefix IsT T Args, !, + coq.mk-app P Args R. +pred-app [_|IS] [_|PS] T R :- pred-app IS PS T R. + +func hyp-mutual list term, list term, term -> term. +hyp-mutual IsTs Ps (prod N S T) (prod N S R) :- !, + @pi-decl N S x\ + if (pred-app IsTs Ps S IH) + (R x = prod `IH` IH (ih\ R1 x ih), + @pi-decl `IH` IH ih\ hyp-mutual IsTs Ps (T x) (R1 x ih)) + (hyp-mutual IsTs Ps (T x) (R x)). +hyp-mutual IsTs Ps S R :- pred-app IsTs Ps S R, !. +hyp-mutual _ _ S S. + +func conclusion-mutual term, term, term -> term. +conclusion-mutual Arity IsT P Ty :- conclusion-mutual.aux Arity IsT P [] Ty. +func conclusion-mutual.aux term, term, term, list term -> term. +conclusion-mutual.aux (prod N S T) IsT P RevArgs (prod N S R) :- !, + @pi-decl N S x\ conclusion-mutual.aux (T x) IsT P [x|RevArgs] (R x). +conclusion-mutual.aux (sort _) IsT P RevArgs (prod `H` IsTArgs _\ PArgs) :- !, + std.rev RevArgs Args, + coq.mk-app IsT Args IsTArgs, + coq.mk-app P Args PArgs. +conclusion-mutual.aux _ _ _ _ _ :- stop "derive.induction: mutual indexed data types not supported". + +func add-hyps list term, list term, list term, list term, term -> term. +add-hyps _ _ [] [] K K. +add-hyps IsTs Ps [Kc|KS] [KT|KTS] K Ty :- + hyp-mutual IsTs Ps KT HTy, + coq.term->gref Kc GRK, + coq.name-suffix `H` {coq.gref->id GRK} HN, + Ty = prod HN HTy R, + @pi-decl HN HTy h\ add-hyps IsTs Ps KS KTS K (R h). + +func collect-terms list derive.induction.mutual-spec -> list term, list term, list term. +collect-terms [] [] [] []. +collect-terms [derive.induction.mutual-spec _ _ IsT _ K KT|SS] [IsT|IS] KAll KTAll :- + collect-terms SS IS KRest KTRest, + std.append K KRest KAll, + std.append KT KTRest KTAll. + +func mutual-induction-type-base list derive.induction.mutual-spec, int -> term. +mutual-induction-type-base Specs Focus Ty :- + mutual-induction-type-motives Specs Specs [] Focus Ty. + +func mutual-induction-type-motives list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, int -> term. +mutual-induction-type-motives All [] RevPs Focus Ty :- !, + std.rev RevPs Ps, + collect-terms All IsTs KAll KTAll, + std.nth Focus All S, + S = derive.induction.mutual-spec _ _ IsT Arity _ _, + std.nth Focus Ps P, + conclusion-mutual Arity IsT P Conclusion, + add-hyps IsTs Ps KAll KTAll Conclusion Ty. +mutual-induction-type-motives All [S|SS] RevPs Focus (prod `P` PTy R) :- + S = derive.induction.mutual-spec _ _ _ Arity _ _, + truncated-predicate-ty Arity PTy, + @pi-decl `P` PTy p\ mutual-induction-type-motives All SS [p|RevPs] Focus (R p). + +func mutual-induction-type int, list derive.induction.mutual-spec, int -> term. +mutual-induction-type 0 Specs Focus Ty :- !, mutual-induction-type-base Specs Focus Ty. +mutual-induction-type 2 ([S|_] as Specs) Focus (prod A TA (a\ prod P (TP a) (pa\ Rest a pa))) :- + mutual-spec-arity S (prod A TA (a\ prod P (TP a) _)), coq.sort? TA, !, + @pi-decl A TA a\ @pi-decl P (TP a) pa\ sigma Specs1\ + mutual-specs-apply-param2 a pa Specs Specs1, + mutual-induction-type 0 Specs1 Focus (Rest a pa). +mutual-induction-type N ([S|_] as Specs) Focus (prod A TA R) :- N > 0, !, + mutual-spec-arity S (prod A TA _), + M is N - 1, + @pi-decl A TA a\ sigma Specs1\ + std.map Specs (mutual-spec-apply-param a) Specs1, + mutual-induction-type M Specs1 Focus (R a). + +func arity-recno term, int -> int. +arity-recno (prod _ _ T) N R :- !, + pi x\ arity-recno (T x) {calc (N + 1)} R. +arity-recno (sort _) N N :- !. +arity-recno X N R :- whd1 X X1, !, arity-recno X1 N R. +arity-recno _ _ _ :- stop "derive.induction: mutual indexed data types not supported". + +func mutual-induction-fix-ty derive.induction.mutual-spec, term -> term, int. +mutual-induction-fix-ty (derive.induction.mutual-spec _ _ IsT Arity _ _) P Ty Recno :- + conclusion-mutual Arity IsT P Ty, + arity-recno Arity 0 Recno. + +func rec-call list term, list term, term, term -> term. +rec-call [IsT|_] [F|_] S X R :- + pred-prefix IsT S Args, !, + std.append Args [X] ArgsX, + coq.mk-app F ArgsX R. +rec-call [_|IS] [_|FS] S X R :- rec-call IS FS S X R. + +func mutual-branch-args list term, list term, list term, list term, list term -> list term. +mutual-branch-args _ _ [] [] Acc Args :- !, std.rev Acc Args. +mutual-branch-args IsTs Fs [V|VS] [VT|VTS] Acc Args :- + if (rec-call IsTs Fs VT V IH) + (mutual-branch-args IsTs Fs VS VTS [IH,V|Acc] Args) + (mutual-branch-args IsTs Fs VS VTS [V|Acc] Args). + +func branch-mutual list term, list term, term, term, list term, list term -> term. +branch-mutual IsTs Fs K _ Vars Tys R :- + induction-hyp-db K IH, + mutual-branch-args IsTs Fs Vars Tys [] Args, + coq.mk-app IH Args R. + +func oty-mutual list term, list term, term, list term, list term -> term. +oty-mutual IsTs Ps _ _ Tys R :- + last Tys ProofTy, + pred-app IsTs Ps ProofTy R. + +func mutual-induction-fix-body list term, list term, list term, derive.induction.mutual-spec -> term. +mutual-induction-fix-body IsTs Ps Fs (derive.induction.mutual-spec _ _GRR IsT Arity _ _) Body :- + mutual-induction-fix-body.aux IsTs Ps Fs IsT Arity [] Body. + +func mutual-induction-fix-body.aux list term, list term, list term, term, term, list term -> term. +mutual-induction-fix-body.aux IsTs Ps Fs IsT (prod N S T) RevArgs (fun N S R) :- !, + @pi-decl N S x\ mutual-induction-fix-body.aux IsTs Ps Fs IsT (T x) [x|RevArgs] (R x). +mutual-induction-fix-body.aux IsTs Ps Fs IsT (sort _) RevArgs (fun `H` IsTArgs Bo) :- !, + std.rev RevArgs Args, + coq.mk-app IsT Args IsTArgs, + @pi-decl `H` IsTArgs h\ + coq.build-match h IsTArgs (oty-mutual IsTs Ps) (branch-mutual IsTs Fs) (Bo h). +mutual-induction-fix-body.aux _ _ _ _ _ _ _ :- stop "derive.induction: mutual indexed data types not supported". + +func mutual-induction-mfix-aux list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, list term, list term -> mfix-block. +mutual-induction-mfix-aux All [] AllPs [] RevF (mfix-bo Bodies) :- !, + std.rev RevF Fs, + collect-terms All IsTs _ _, + std.map All (mutual-induction-fix-body IsTs AllPs Fs) Bodies. +mutual-induction-mfix-aux All [S|SS] AllPs [P|PS] PsRevF (mfix-ty N Recno Ty Rest) :- + S = derive.induction.mutual-spec _ GRR _ _ _ _, + ID is {coq.gref->id (indt GRR)} ^ "_induction_rec", + coq.id->name ID N, + mutual-induction-fix-ty S P Ty Recno, + @pi-decl N Ty f\ mutual-induction-mfix-aux All SS AllPs PS [f|PsRevF] (Rest f). + +func mutual-induction-mfix list derive.induction.mutual-spec, list term, int -> term. +mutual-induction-mfix Specs Ps Focus (mfix Focus Recno Block) :- + std.nth Focus Specs S, + std.nth Focus Ps P, + mutual-induction-fix-ty S P _ Recno, + mutual-induction-mfix-aux Specs Specs Ps Ps [] Block. + +func mutual-induction-param1-recno list derive.induction.mutual-spec, int -> int. +mutual-induction-param1-recno Specs Focus Recno :- + std.nth Focus Specs S, + S = derive.induction.mutual-spec _ _ _ Arity _ _, + arity-recno Arity 0 RecArity, + std.length Specs MotNo, + collect-terms Specs _ KAll _, + std.length KAll KNo, + Recno is 2 + MotNo + KNo + RecArity. + +func mutual-induction-param1-fix-ty list derive.induction.mutual-spec, int -> term, int. +mutual-induction-param1-fix-ty All Focus (prod A TA (a\ prod P (TP a) (pa\ Rest a pa))) Recno :- + std.nth Focus All S, + S = derive.induction.mutual-spec _ _ _ (prod A TA (a\ prod P (TP a) _)) _ _, + coq.sort? TA, !, + @pi-decl A TA a\ @pi-decl P (TP a) pa\ sigma Specs1\ + mutual-specs-apply-param2 a pa All Specs1, + mutual-induction-type-base Specs1 Focus (Rest a pa), + mutual-induction-param1-recno Specs1 Focus Recno. + +func mutual-induction-param1-rty-motives list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, list term, list term, list term, int, term -> term. +mutual-induction-param1-rty-motives _ [] RevPs IsTs KAll KTAll _ ProofTy R :- !, + std.rev RevPs Ps, + pred-app IsTs Ps ProofTy Conclusion, + add-hyps IsTs Ps KAll KTAll Conclusion R. +mutual-induction-param1-rty-motives All [S|SS] RevPs IsTs KAll KTAll Focus ProofTy (prod `P` PTy R) :- + S = derive.induction.mutual-spec _ _ _ Arity _ _, + truncated-predicate-ty Arity PTy, + @pi-decl `P` PTy p\ mutual-induction-param1-rty-motives All SS [p|RevPs] IsTs KAll KTAll Focus ProofTy (R p). + +func mutual-induction-param1-rty list derive.induction.mutual-spec, int, term, list term, list term -> term. +mutual-induction-param1-rty All Focus _ _ Tys R :- + std.assert! (last Tys ProofTy) "derive.induction: failed to select parameterized match proof type", + std.assert! (coq.safe-dest-app ProofTy _ [A,PA|_]) "derive.induction: failed to read parameterized match proof type", + std.assert! (mutual-specs-apply-param2 A PA All Specs1) "derive.induction: failed to apply parameterized match params", + std.assert! (collect-terms Specs1 IsTs KAll KTAll) "derive.induction: failed to collect parameterized match terms", + std.assert! (mutual-induction-param1-rty-motives Specs1 Specs1 [] IsTs KAll KTAll Focus ProofTy R) "derive.induction: failed to build parameterized match return type". + +func apply-rec-funs list term, list term -> list term. +apply-rec-funs _ [] []. +apply-rec-funs Args [F|FS] [FA|FAS] :- + coq.mk-app F Args FA, + apply-rec-funs Args FS FAS. + +func branch-mutual-applied list term, list term, term, list term, list term -> term. +branch-mutual-applied IsTs Fs K Vars Tys R :- + induction-hyp-db K IH, + mutual-branch-args IsTs Fs Vars Tys [] Args, + coq.mk-app IH Args R. + +func branch-mutual-param1-hyps term, term, list term, list term, list term, list term, list term, list term, term, list term, list term -> term. +branch-mutual-param1-hyps A PA IsTs Ps [] [] RevHs Fs K Vars Tys R :- !, + std.rev RevHs Hs, + std.append [A,PA] Ps Args0, + std.append Args0 Hs Args, + apply-rec-funs Args Fs FsApplied, + branch-mutual-applied IsTs FsApplied K Vars Tys R. +branch-mutual-param1-hyps A PA IsTs Ps [Kc|KS] [KT|KTS] RevHs Fs K Vars Tys (fun HN HTy R) :- + hyp-mutual IsTs Ps KT HTy, + coq.term->gref Kc GRK, + coq.name-suffix `H` {coq.gref->id GRK} HN, + @pi-decl HN HTy h\ + induction-hyp-db Kc h =!=> + branch-mutual-param1-hyps A PA IsTs Ps KS KTS [h|RevHs] Fs K Vars Tys (R h). + +func branch-mutual-param1-motives term, term, list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, list term, list term, list term, list term, term, list term, list term -> term. +branch-mutual-param1-motives A PA _All [] RevPs IsTs KAll KTAll Fs K Vars Tys R :- !, + std.rev RevPs Ps, + branch-mutual-param1-hyps A PA IsTs Ps KAll KTAll [] Fs K Vars Tys R. +branch-mutual-param1-motives A PA All [S|SS] RevPs IsTs KAll KTAll Fs K Vars Tys (fun `P` PTy R) :- + S = derive.induction.mutual-spec _ _ _ Arity _ _, + truncated-predicate-ty Arity PTy, + @pi-decl `P` PTy p\ branch-mutual-param1-motives A PA All SS [p|RevPs] IsTs KAll KTAll Fs K Vars Tys (R p). + +func branch-mutual-param1 list derive.induction.mutual-spec, list term, term, term, list term, list term -> term. +branch-mutual-param1 All Fs K _ [A,PA|Vars] [_T,_TP|Tys] R :- !, + sigma Specs1 KAP IsTs KAll KTAll\ + std.assert! (mutual-specs-apply-param2 A PA All Specs1) "derive.induction: failed to apply parameterized branch params", + std.assert! (coq.mk-app K [A,PA] KAP) "derive.induction: failed to apply parameterized branch constructor", + std.assert! (collect-terms Specs1 IsTs KAll KTAll) "derive.induction: failed to collect parameterized branch terms", + std.assert! (branch-mutual-param1-motives A PA Specs1 Specs1 [] IsTs KAll KTAll Fs KAP Vars Tys R) "derive.induction: failed to build parameterized branch body". + +func mutual-induction-param1-fix-body-final-aux list derive.induction.mutual-spec, term, list term, list term, list term, int, term, list term -> term. +mutual-induction-param1-fix-body-final-aux OrigAll IsT Ps Hs Fs Focus (prod N S T) RevArgs (fun N S R) :- !, + @pi-decl N S x\ mutual-induction-param1-fix-body-final-aux OrigAll IsT Ps Hs Fs Focus (T x) [x|RevArgs] (R x). +mutual-induction-param1-fix-body-final-aux OrigAll IsT Ps Hs Fs Focus (sort _) RevArgs (fun `H` IsTArgs Bo) :- !, + std.rev RevArgs Args, + std.assert! (mk-app-prefix IsT Args IsTArgs) "derive.induction: failed to apply parameterized mutual fix body proof type", + @pi-decl `H` IsTArgs h\ sigma Match Args0\ + std.assert! (coq.build-match h IsTArgs (mutual-induction-param1-rty OrigAll Focus) (branch-mutual-param1 OrigAll Fs) Match) "derive.induction: failed to build parameterized mutual proof match", + std.append Ps Hs Args0, + std.assert! (coq.mk-app Match Args0 (Bo h)) "derive.induction: failed to apply parameterized mutual proof match". +mutual-induction-param1-fix-body-final-aux _ _ _ _ _ _ _ _ _ :- stop "derive.induction: mutual indexed data types not supported". + +func mutual-induction-param1-fix-body-final list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, list term, list term, int -> term. +mutual-induction-param1-fix-body-final OrigAll Specs Ps Hs Fs Focus R :- + std.assert! (std.nth Focus Specs SF) "derive.induction: failed to select parameterized mutual fix body spec", + SF = derive.induction.mutual-spec _ _ IsT Arity _ _, + mutual-induction-param1-fix-body-final-aux OrigAll IsT Ps Hs Fs Focus Arity [] R. + +func mutual-induction-param1-fix-body-hyps list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, list term, list term, list term, list term, int -> term. +mutual-induction-param1-fix-body-hyps OrigAll Specs Ps [] [] RevHs Fs Focus R :- !, + std.rev RevHs Hs, + std.assert! (mutual-induction-param1-fix-body-final OrigAll Specs Ps Hs Fs Focus R) "derive.induction: failed to build parameterized mutual fix body final match". +mutual-induction-param1-fix-body-hyps OrigAll Specs Ps [Kc|KS] [KT|KTS] RevHs Fs Focus (fun HN HTy R) :- + std.assert! (collect-terms Specs IsTs _ _) "derive.induction: failed to collect parameterized mutual body terms", + std.assert! (hyp-mutual IsTs Ps KT HTy) "derive.induction: failed to build parameterized mutual body hypothesis type", + std.assert! (coq.term->gref Kc GRK) "derive.induction: failed to identify parameterized mutual body constructor", + coq.name-suffix `H` {coq.gref->id GRK} HN, + @pi-decl HN HTy h\ + induction-hyp-db Kc h =!=> + std.assert! (mutual-induction-param1-fix-body-hyps OrigAll Specs Ps KS KTS [h|RevHs] Fs Focus (R h)) "derive.induction: failed to build rest parameterized mutual body hypotheses". + +func mutual-induction-param1-fix-body-motives list derive.induction.mutual-spec, list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, list term, int -> term. +mutual-induction-param1-fix-body-motives OrigAll Specs [] RevPs Fs Focus R :- !, + std.rev RevPs Ps, + std.assert! (collect-terms Specs _ KAll KTAll) "derive.induction: failed to collect parameterized mutual body constructors", + std.assert! (mutual-induction-param1-fix-body-hyps OrigAll Specs Ps KAll KTAll [] Fs Focus R) "derive.induction: failed to build parameterized mutual body hypotheses". +mutual-induction-param1-fix-body-motives OrigAll Specs [S|SS] RevPs Fs Focus (fun `P` PTy R) :- + S = derive.induction.mutual-spec _ _ _ Arity _ _, + std.assert! (truncated-predicate-ty Arity PTy) "derive.induction: failed to build parameterized mutual body motive type", + @pi-decl `P` PTy p\ std.assert! (mutual-induction-param1-fix-body-motives OrigAll Specs SS [p|RevPs] Fs Focus (R p)) "derive.induction: failed to build rest parameterized mutual body motives". + +func mutual-induction-param1-fix-body list derive.induction.mutual-spec, list term, int -> term. +mutual-induction-param1-fix-body All Fs Focus (fun A TA (a\ fun P (TP a) (pa\ Rest a pa))) :- + std.assert! (std.nth Focus All S) "derive.induction: failed to select parameterized mutual body spec", + S = derive.induction.mutual-spec _ _ _ (prod A TA (a\ prod P (TP a) _)) _ _, coq.sort? TA, !, + @pi-decl A TA a\ @pi-decl P (TP a) pa\ sigma Specs1\ + std.assert! (mutual-specs-apply-param2 a pa All Specs1) "derive.induction: failed to apply parameterized mutual body params", + std.assert! (mutual-induction-param1-fix-body-motives All Specs1 Specs1 [] Fs Focus (Rest a pa)) "derive.induction: failed to build parameterized mutual body after params". + +func mutual-induction-param1-bodies list derive.induction.mutual-spec, list term, list derive.induction.mutual-spec, int -> list term. +mutual-induction-param1-bodies _ _ [] _ []. +mutual-induction-param1-bodies All Fs [_|SS] Focus [B|BS] :- + std.assert! (mutual-induction-param1-fix-body All Fs Focus B) "derive.induction: failed to build one parameterized mutual fix body", + Focus1 is Focus + 1, + std.assert! (mutual-induction-param1-bodies All Fs SS Focus1 BS) "derive.induction: failed to build rest parameterized mutual fix bodies". + +func mutual-induction-param1-mfix-aux list derive.induction.mutual-spec, list derive.induction.mutual-spec, int, list term -> mfix-block. +mutual-induction-param1-mfix-aux All [] _ RevF (mfix-bo Bodies) :- !, + std.rev RevF Fs, + std.assert! (mutual-induction-param1-bodies All Fs All 0 Bodies) "derive.induction: failed to build parameterized mutual fix bodies". +mutual-induction-param1-mfix-aux All [S|SS] Focus RevF (mfix-ty N Recno Ty Rest) :- + S = derive.induction.mutual-spec _ GRR _ _ _ _, + ID is {coq.gref->id (indt GRR)} ^ "_induction_rec", + coq.id->name ID N, + std.assert! (mutual-induction-param1-fix-ty All Focus Ty Recno) "derive.induction: failed to build parameterized mutual fix type", + @pi-decl N Ty f\ + Focus1 is Focus + 1, + std.assert! (mutual-induction-param1-mfix-aux All SS Focus1 [f|RevF] (Rest f)) "derive.induction: failed to build rest parameterized mutual fix block". + +func mutual-induction-param1-mfix list derive.induction.mutual-spec, int -> term. +mutual-induction-param1-mfix Specs Focus (mfix Focus Recno Block) :- + std.assert! (mutual-induction-param1-fix-ty Specs Focus _ Recno) "derive.induction: failed to build selected parameterized mutual fix type", + std.assert! (mutual-induction-param1-mfix-aux Specs Specs 0 [] Block) "derive.induction: failed to build parameterized mutual fix block". + +func mutual-induction-param1-term-final-aux term, term, list derive.induction.mutual-spec, term, list term, list term, int, term, list term -> term. +mutual-induction-param1-term-final-aux A PA OrigAll IsT Ps Hs Focus (prod N S T) RevArgs (fun N S R) :- !, + @pi-decl N S x\ mutual-induction-param1-term-final-aux A PA OrigAll IsT Ps Hs Focus (T x) [x|RevArgs] (R x). +mutual-induction-param1-term-final-aux A PA OrigAll IsT Ps Hs Focus (sort _) RevArgs (fun `H` IsTArgs Bo) :- !, + std.rev RevArgs IndArgs, + std.assert! (mk-app-prefix IsT IndArgs IsTArgs) "derive.induction: failed to apply parameterized mutual proof type", + @pi-decl `H` IsTArgs h\ sigma Fix Args0 Args1 Args2 Args\ + std.assert! (mutual-induction-param1-mfix OrigAll Focus Fix) "derive.induction: failed to build parameterized mutual fixpoint", + std.append [A,PA] Ps Args0, + std.append Args0 Hs Args1, + std.append Args1 IndArgs Args2, + std.append Args2 [h] Args, + std.assert! (coq.mk-app Fix Args (Bo h)) "derive.induction: failed to apply parameterized mutual fixpoint". +mutual-induction-param1-term-final-aux _ _ _ _ _ _ _ _ _ _ :- stop "derive.induction: mutual indexed data types not supported". + +func mutual-induction-param1-term-final term, term, list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, list term, int -> term. +mutual-induction-param1-term-final A PA OrigAll Specs Ps Hs Focus R :- + std.assert! (std.nth Focus Specs SF) "derive.induction: failed to select parameterized mutual final spec", + SF = derive.induction.mutual-spec _ _ IsT Arity _ _, + mutual-induction-param1-term-final-aux A PA OrigAll IsT Ps Hs Focus Arity [] R. + +func mutual-induction-param1-term-hyps term, term, list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, list term, list term, list term, int -> term. +mutual-induction-param1-term-hyps A PA OrigAll Specs Ps [] [] RevHs Focus R :- !, + std.rev RevHs Hs, + std.assert! (mutual-induction-param1-term-final A PA OrigAll Specs Ps Hs Focus R) "derive.induction: failed to build parameterized mutual final application". +mutual-induction-param1-term-hyps A PA OrigAll Specs Ps [Kc|KS] [KT|KTS] RevHs Focus (fun HN HTy R) :- + std.assert! (collect-terms Specs IsTs _ _) "derive.induction: failed to collect parameterized mutual terms", + std.assert! (hyp-mutual IsTs Ps KT HTy) "derive.induction: failed to build parameterized mutual hypothesis type", + std.assert! (coq.term->gref Kc GRK) "derive.induction: failed to identify parameterized mutual constructor", + coq.name-suffix `H` {coq.gref->id GRK} HN, + @pi-decl HN HTy h\ + induction-hyp-db Kc h =!=> + std.assert! (mutual-induction-param1-term-hyps A PA OrigAll Specs Ps KS KTS [h|RevHs] Focus (R h)) "derive.induction: failed to build rest parameterized mutual hypotheses". + +func mutual-induction-param1-term-motives term, term, list derive.induction.mutual-spec, list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, int -> term. +mutual-induction-param1-term-motives A PA OrigAll Specs [] RevPs Focus R :- !, + std.rev RevPs Ps, + std.assert! (collect-terms Specs _ KAll KTAll) "derive.induction: failed to collect parameterized mutual constructors", + std.assert! (mutual-induction-param1-term-hyps A PA OrigAll Specs Ps KAll KTAll [] Focus R) "derive.induction: failed to build parameterized mutual hypotheses". +mutual-induction-param1-term-motives A PA OrigAll Specs [S|SS] RevPs Focus (fun `P` PTy R) :- + S = derive.induction.mutual-spec _ _ _ Arity _ _, + std.assert! (truncated-predicate-ty Arity PTy) "derive.induction: failed to build parameterized mutual motive type", + @pi-decl `P` PTy p\ std.assert! (mutual-induction-param1-term-motives A PA OrigAll Specs SS [p|RevPs] Focus (R p)) "derive.induction: failed to build rest parameterized mutual motives". + +func mutual-induction-param1-term list derive.induction.mutual-spec, int -> term. +mutual-induction-param1-term All Focus (fun A TA (a\ fun P (TP a) (pa\ Rest a pa))) :- + std.assert! (std.nth Focus All S) "derive.induction: failed to select parameterized mutual spec", + S = derive.induction.mutual-spec _ _ _ (prod A TA (a\ prod P (TP a) _)) _ _, coq.sort? TA, !, + @pi-decl A TA a\ @pi-decl P (TP a) pa\ sigma Specs1\ + std.assert! (mutual-specs-apply-param2 a pa All Specs1) "derive.induction: failed to apply parameterized mutual params", + std.assert! (mutual-induction-param1-term-motives a pa All Specs1 Specs1 [] Focus (Rest a pa)) "derive.induction: failed to build parameterized mutual term body". + +func add-hyps-body list term, list term, list term, list term, list derive.induction.mutual-spec, list term, int -> term. +add-hyps-body _ _ [] [] All Ps Focus R :- !, + mutual-induction-mfix All Ps Focus R. +add-hyps-body IsTs Ps [Kc|KS] [KT|KTS] All AllPs Focus (fun HN HTy R) :- + hyp-mutual IsTs Ps KT HTy, + coq.term->gref Kc GRK, + coq.name-suffix `H` {coq.gref->id GRK} HN, + @pi-decl HN HTy h\ + induction-hyp-db Kc h =!=> + add-hyps-body IsTs Ps KS KTS All AllPs Focus (R h). + +func mutual-induction-term-base list derive.induction.mutual-spec, int -> term. +mutual-induction-term-base Specs Focus R :- + mutual-induction-term-motives Specs Specs [] Focus R. + +func mutual-induction-term-motives list derive.induction.mutual-spec, list derive.induction.mutual-spec, list term, int -> term. +mutual-induction-term-motives All [] RevPs Focus R :- !, + std.rev RevPs Ps, + collect-terms All IsTs KAll KTAll, + add-hyps-body IsTs Ps KAll KTAll All Ps Focus R. +mutual-induction-term-motives All [S|SS] RevPs Focus (fun `P` PTy R) :- + S = derive.induction.mutual-spec _ _ _ Arity _ _, + truncated-predicate-ty Arity PTy, + @pi-decl `P` PTy p\ mutual-induction-term-motives All SS [p|RevPs] Focus (R p). + +func mutual-induction-term int, list derive.induction.mutual-spec, int -> term. +mutual-induction-term 0 Specs Focus R :- !, mutual-induction-term-base Specs Focus R. +mutual-induction-term 2 ([S|_] as Specs) Focus R :- + mutual-spec-arity S (prod _ TA _), coq.sort? TA, !, + std.assert! (mutual-induction-param1-term Specs Focus R) "derive.induction: failed to build parameterized mutual induction term". +mutual-induction-term N ([S|_] as Specs) Focus (fun A TA R) :- N > 0, !, + mutual-spec-arity S (prod A TA _), + M is N - 1, + @pi-decl A TA a\ sigma Specs1\ + std.map Specs (mutual-spec-apply-param a) Specs1, + mutual-induction-term M Specs1 Focus (R a). + +func add-mutual-induction-consts list derive.induction.mutual-spec, list derive.induction.mutual-spec, inductive, string, int, int -> list prop. +add-mutual-induction-consts _ [] _ _ _ _ [] :- !. +add-mutual-induction-consts All [S|SS] Selected Prefix Lno Focus [Clause|CS] :- std.do! [ + S = derive.induction.mutual-spec GR _ _ _ _ _, + mutual-induction-term Lno All Focus R, + std.assert-ok! (coq.typecheck R Ty) "derive.induction generates illtyped mutual term", + if (GR = Selected) + (Name is Prefix ^ "induction") + (Name is {coq.gref->id (indt GR)} ^ "_induction"), + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName R Ty @transparent! I, + Clause = (induction-db GR (global (const I)) :- !), + coq.elpi.accumulate _ "derive.induction.db" (clause _ (before "induction-db:fail") Clause), + Focus1 is Focus + 1, + add-mutual-induction-consts All SS Selected Prefix Lno Focus1 CS +]. + +func mutual-lno list inductive, inductive -> int. +mutual-lno _ FirstGRR Lno :- coq.env.indt FirstGRR _ Lno _ _ _ _, Lno > 0, !. +mutual-lno [FirstOrig|_] _ Lno :- !, coq.env.indt FirstOrig _ OrigLno _ _ _ _, Lno is 2 * OrigLno. +mutual-lno _ _ 0 :- !. + +func main-mutual inductive, list inductive, string -> list prop. +main-mutual Selected GRS Prefix Clauses :- std.do! [ + std.map GRS mutual-spec Specs, + Specs = [First|_], + mutual-spec-ind First FirstGRR, + coq.env.indt FirstGRR _ LnoIs Luno _ _ _, + assert! (LnoIs = Luno) "derive.induction: Non-uniform parameters not supported", + mutual-lno GRS FirstGRR Lno, + if (coq.env.informative? FirstGRR) (Informative = [informative]) (Informative = []), + Informative =!=> add-mutual-induction-consts Specs Specs Selected Prefix Lno 0 Clauses +]. + func main inductive, string -> list prop. main GR Prefix [Clause] :- do! [ T = global (indt GR), diff --git a/apps/derive/elpi/map.elpi b/apps/derive/elpi/map.elpi index 4708f2200..e56eb86f2 100644 --- a/apps/derive/elpi/map.elpi +++ b/apps/derive/elpi/map.elpi @@ -16,6 +16,12 @@ map-db (app[global (indt GR1)|A1]) (app[global (indt GR2)|A2]) R :- namespace derive.map { +pred param-map-db i:term, i:term, o:term. + +func not-indt-app term ->. +not-indt-app (app [global (indt _)|_]) :- !, fail. +not-indt-app _. + % Building the body %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred bo-idx @@ -59,6 +65,10 @@ bo-k-args ParamsRev K _ Args Tys R :- pred bo-k-args.aux i:term, i:list term, i:list term, i:term, o:term. bo-k-args.aux R [] [] _ R :- coq.typecheck R _ ok. +bo-k-args.aux K [A|As] [T|Ts] (prod _ S Ty) R :- + param-map-db T S F, !, + coq.mk-app F [A] FA, + bo-k-args.aux {coq.mk-app K [FA]} As Ts (Ty FA) R. bo-k-args.aux K [A|As] [T|Ts] (prod _ S Ty) R :- map-db T S F, coq.mk-app F [A] FA, @@ -169,6 +179,176 @@ mk-clause N Lno Ity1 Ity2 (prod _ _ T) Todo Map (pi x y f\ C x y f) :- !, mk-clause N Lno Ity1 Ity2 X Todo Map C :- whd1 X X1, !, mk-clause N Lno Ity1 Ity2 X1 Todo Map C. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +kind derive.map.mutual-spec type. +type derive.map.mutual-spec inductive -> term -> term -> term -> term -> derive.map.mutual-spec. + +func mutual-spec inductive -> derive.map.mutual-spec. +mutual-spec GR (derive.map.mutual-spec GR T T Arity Arity) :- + T = global (indt GR), + coq.env.indt GR _ _ _ Arity _ _. + +func mutual-spec-ind derive.map.mutual-spec -> inductive. +mutual-spec-ind (derive.map.mutual-spec GR _ _ _ _) GR. + +func mutual-spec-arity1 derive.map.mutual-spec -> term. +mutual-spec-arity1 (derive.map.mutual-spec _ _ _ A _) A. + +func mutual-spec-apply-param term, term, derive.map.mutual-spec -> derive.map.mutual-spec. +mutual-spec-apply-param A B (derive.map.mutual-spec GR Ity1 Ity2 (prod _ _ F1) (prod _ _ F2)) + (derive.map.mutual-spec GR Ity1A Ity2B (F1 A) (F2 B)) :- !, + coq.mk-app Ity1 [A] Ity1A, + coq.mk-app Ity2 [B] Ity2B. +mutual-spec-apply-param _ _ _ _ :- stop "derive.map: mutual parameter mismatch". + +func mutual-map-indexed-ty-aux term, term, term, int -> term, int. +mutual-map-indexed-ty-aux Ity1 Ity2 (prod N S T) K (prod N S R) Recno :- !, + K1 is K + 1, + @pi-decl N S x\ sigma Ity1x Ity2x\ + coq.mk-app Ity1 [x] Ity1x, + coq.mk-app Ity2 [x] Ity2x, + mutual-map-indexed-ty-aux Ity1x Ity2x (T x) K1 (R x) Recno. +mutual-map-indexed-ty-aux Ity1 Ity2 (sort _) K (prod `_` Ity1 (_\ Ity2)) K :- !. +mutual-map-indexed-ty-aux Ity1 Ity2 X K Ty Recno :- whd1 X X1, !, + mutual-map-indexed-ty-aux Ity1 Ity2 X1 K Ty Recno. + +func mutual-map-indexed-ty derive.map.mutual-spec -> term, int. +mutual-map-indexed-ty (derive.map.mutual-spec _ Ity1 Ity2 Arity _) Ty Recno :- + mutual-map-indexed-ty-aux Ity1 Ity2 Arity 0 Ty Recno. + +func mutual-map-ty int, int, derive.map.mutual-spec -> term, int. +mutual-map-ty N Lno S Ty Recno :- N = Lno, !, + mutual-map-indexed-ty S Ty Recno. +mutual-map-ty N Lno S Ty Recno :- N < Lno, + S = derive.map.mutual-spec _ _Ity1 _Ity2 (prod A Sty1 _Rty1) (prod _ Sty2 _Rty2), !, + coq.name-suffix A 1 A1, + coq.name-suffix A 2 A2, + coq.name-suffix A "f" Af, + N1 is N + 1, + Ty = prod A1 Sty1 (a\ prod A2 Sty2 (b\ prod Af {{ lp:a -> lp:b }} (f\ Rest a b f))), + pi a b f\ sigma S1\ + mutual-spec-apply-param a b S S1, + mutual-map-ty N1 Lno S1 (Rest a b f) Recno. +mutual-map-ty _ _ _ _ _ :- stop "derive.map: mutual parameter mismatch". + +func mutual-map-identity term, term -> term. +mutual-map-identity Ity (prod N S T) (fun N S R) :- !, + @pi-decl N S x\ sigma Ityx\ + coq.mk-app Ity [x] Ityx, + mutual-map-identity Ityx (T x) (R x). +mutual-map-identity Ity (sort _) (fun `x` Ity (x\ x)) :- !. +mutual-map-identity Ity X R :- whd1 X X1, !, mutual-map-identity Ity X1 R. + +func mutual-prefix inductive, string, inductive -> string. +mutual-prefix First Prefix T Prefix :- First = T, !. +mutual-prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_". + +func mutual-map-clause derive.map.mutual-spec, term -> prop. +mutual-map-clause (derive.map.mutual-spec _ Ity1 Ity2 _ _) F (map-db Ity1 Ity2 F). + +func mutual-map-body list term, derive.map.mutual-spec -> term. +mutual-map-body _ (derive.map.mutual-spec _ Ity1 Ity2 Arity _) Body :- + coq.safe-dest-app Ity2 _ Params, + std.rev Params ParamsRev, + std.assert! (bo-idx Arity Ity1 Ity2 0 _ ParamsRev Body _) "derive.map: failed to generate mutual map body". + +func mutual-map-mfix-aux list derive.map.mutual-spec, list derive.map.mutual-spec, list term, list term -> mfix-block. +mutual-map-mfix-aux All [] Ps RevF (mfix-bo Bodies) :- !, + std.rev RevF Funs, + std.map2 All Funs mutual-map-clause Clauses, + Clauses =!=> std.map All (mutual-map-body Ps) Bodies. +mutual-map-mfix-aux All [S|SS] Ps RevF (mfix-ty N Recno Ty Rest) :- + S = derive.map.mutual-spec GR _ _ _ _, + ID is {coq.gref->id (indt GR)} ^ "_map_rec", + coq.id->name ID N, + mutual-map-ty 0 0 S Ty Recno, + @pi-decl N Ty f\ mutual-map-mfix-aux All SS Ps [f|RevF] (Rest f). + +func mutual-map-mfix list derive.map.mutual-spec, list term, int -> term. +mutual-map-mfix Specs Ps Focus (mfix Focus Recno Block) :- + std.nth Focus Specs S, + mutual-map-ty 0 0 S _ Recno, + mutual-map-mfix-aux Specs Specs Ps [] Block. + +func body-mutual-params int, int, list derive.map.mutual-spec, int, list term -> term. +body-mutual-params Lno Lno Specs Focus Ps R :- !, + mutual-map-mfix Specs Ps Focus R. +body-mutual-params N Lno ([S|_] as Specs) Focus Ps R :- N < Lno, + S = derive.map.mutual-spec _ _ _ (prod A Sty1 _) (prod _ Sty2 _), + coq.sort? Sty1, !, + coq.name-suffix A 1 A1, + coq.name-suffix A 2 A2, + coq.name-suffix A "f" Af, + N1 is N + 1, + R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Af (prod `_` a (_\ b)) f\ Bo a b f), + pi a b f\ sigma Specs1\ + std.map Specs (mutual-spec-apply-param a b) Specs1, + decl a A1 Sty1 => + decl b A2 Sty2 => + decl f Af (prod `_` a (_\ b)) => + (pi x y\ param-map-db x y f :- not-indt-app x, same_term x a, same_term y b) => + body-mutual-params N1 Lno Specs1 Focus [b|Ps] (Bo a b f). +body-mutual-params N Lno ([S|_] as Specs) Focus Ps R :- N < Lno, + S = derive.map.mutual-spec _ _ _ (prod A Sty1 _Rty1) (prod _ Sty2 _Rty2), !, + coq.name-suffix A 1 A1, + coq.name-suffix A 2 A2, + coq.name-suffix A "f" Af, + N1 is N + 1, + (pi a b f\ std.assert! (mk-map-ty a Sty1 b Sty2 (FAB a b) f _ (Clause a b f)) "derive.map: failed to generate parameter map clause"), + R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Af (FAB a b) f\ Bo a b f), + pi a b f\ sigma Specs1\ + std.map Specs (mutual-spec-apply-param a b) Specs1, + Clause a b f => + decl a A1 Sty1 => + decl b A2 Sty2 => + decl f Af (FAB a b) => + body-mutual-params N1 Lno Specs1 Focus [b|Ps] (Bo a b f). +body-mutual-params _ _ _ _ _ _ :- stop "derive.map: mutual indexed data types not supported". + +func add-mutual-map-consts inductive, list derive.map.mutual-spec, list derive.map.mutual-spec, string, int, int -> list prop. +add-mutual-map-consts _ _ [] _ _ _ [] :- !. +add-mutual-map-consts Selected All [S|SS] Prefix 0 Focus [map-done GR,Clause|CS] :- !, std.do! [ + S = derive.map.mutual-spec GR T T Arity _, + mutual-map-identity T Arity R, + std.assert-ok! (coq.typecheck R Ty) "derive.map generates illtyped mutual identity term", + mutual-prefix Selected Prefix GR P, + Name is P ^ "map", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName R Ty @transparent! Funct, + mk-clause 0 0 T T Arity [] (global (const Funct)) Clause, + coq.elpi.accumulate _ "derive.map.db" (clause _ _ Clause), + coq.elpi.accumulate _ "derive.map.db" (clause _ _ (map-done GR)), + Focus1 is Focus + 1, + add-mutual-map-consts Selected All SS Prefix 0 Focus1 CS +]. +add-mutual-map-consts Selected All [S|SS] Prefix Lno Focus [map-done GR,Clause|CS] :- std.do! [ + S = derive.map.mutual-spec GR T T Arity _, + body-mutual-params 0 Lno All Focus [] RSkel, + std.assert-ok! (coq.typecheck RSkel Ty) "derive.map generates illtyped mutual term", + R = RSkel, + mutual-prefix Selected Prefix GR P, + Name is P ^ "map", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName R Ty @transparent! Funct, + mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause, + coq.elpi.accumulate _ "derive.map.db" (clause _ _ Clause), + coq.elpi.accumulate _ "derive.map.db" (clause _ _ (map-done GR)), + Focus1 is Focus + 1, + add-mutual-map-consts Selected All SS Prefix Lno Focus1 CS +]. + +func main-mutual inductive, list inductive, string -> list prop. +main-mutual _ [] _ [] :- !. +main-mutual Selected GRS Prefix C :- std.do! [ + std.map GRS mutual-spec Specs, + Specs = [S|_], + mutual-spec-ind S FirstGR, + coq.env.indt FirstGR _ Lno Luno _ _ _, + assert! (Lno = Luno) "derive.map: Non-uniform parameters not supported", + add-mutual-map-consts Selected Specs Specs Prefix Lno 0 C +]. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% func main inductive, string -> list prop. main GR Prefix C :- do! [ diff --git a/apps/derive/elpi/param1.elpi b/apps/derive/elpi/param1.elpi index 308f8102d..61b0d376e 100644 --- a/apps/derive/elpi/param1.elpi +++ b/apps/derive/elpi/param1.elpi @@ -4,7 +4,10 @@ % Author: Cyril Cohen -shorten std.{forall, forall2, do!, rev, map2, map}. +shorten std.{forall, forall2, do!, rev, map2, map, append}. + +kind derive.param1.raw-mindt-spec type. +type derive.param1.raw-mindt-spec inductive -> id -> bool -> int -> int -> term -> list constructor -> list (pair constructor id) -> list term -> id -> derive.param1.raw-mindt-spec. :before "subst-fun:fail" coq.subst-fun XS T TXS :- !, coq.mk-app T XS TXS. @@ -157,6 +160,119 @@ prefix-indc Prefix K (pr K FNewName) :- NewName is Prefix ^ Name, coq.ensure-fresh-global-id NewName FNewName. +func mutual-ids indt-decl -> list id. +mutual-ids (parameter ID _ Ty F) IDs :- !, + @pi-parameter ID Ty x\ mutual-ids (F x) IDs. +mutual-ids (minductive ID _ Arity Rest) [ID|IDs] :- !, + @pi-inductive ID Arity i\ mutual-ids (Rest i) IDs. +mutual-ids (mblock _) []. + +func id->indt id -> inductive. +id->indt ID GR :- coq.locate ID (indt GR). + +func raw-mutual-spec string, inductive -> derive.param1.raw-mindt-spec. +raw-mutual-spec Prefix GR (derive.param1.raw-mindt-spec GR ID IsInd Lno Luno Ty KNames KNamesR KTypes FNewName) :- + coq.env.indt GR IsInd Lno Luno Ty KNames KTypes, + coq.gref->id (indt GR) ID, + std.map KNames (prefix-indc Prefix) KNamesR, + NewName is Prefix ^ ID, + coq.ensure-fresh-global-id NewName FNewName. + +func raw-mutual-spec-lno derive.param1.raw-mindt-spec -> int. +raw-mutual-spec-lno (derive.param1.raw-mindt-spec _ _ _ Lno _ _ _ _ _ _) Lno. + +func raw-mutual-spec-luno derive.param1.raw-mindt-spec -> int. +raw-mutual-spec-luno (derive.param1.raw-mindt-spec _ _ _ _ Luno _ _ _ _ _) Luno. + +func raw-mutual-spec-clause derive.param1.raw-mindt-spec, inductive -> prop. +raw-mutual-spec-clause (derive.param1.raw-mindt-spec GR _ _ _ _ _ _ _ _ _) NewGR + (reali (global (indt GR)) (global (indt NewGR)) :- !). + +func translate-mutual-spec derive.param1.raw-mindt-spec, inductive -> coq.mindt-spec. +translate-mutual-spec (derive.param1.raw-mindt-spec GR _ IsInd _ _ Ty KNames KNamesR KTypes FNewName) NewGR + (coq.mindt-spec NewGR FNewName IsInd TyOut KNamesR KTypesR) :- + Ind = global (indt GR), + reali Ty TyR, + coq.mk-app TyR [Ind] TyOut, + map2 KNames KTypes (k\ ty\ r\ sigma tyr\ + reali ty tyr, + coq.mk-app tyr [global (indc k)] r) KTypesR. + +func dispatch-mutual-gen list derive.param1.raw-mindt-spec, list derive.param1.raw-mindt-spec, list inductive -> list prop. +dispatch-mutual-gen All [] Acc Clauses :- !, + rev Acc NewGRs, + dispatch-mutual-do All NewGRs Clauses. +dispatch-mutual-gen All [_|Rest] Acc Clauses :- + pi newGR\ dispatch-mutual-gen All Rest [newGR|Acc] Clauses. + +func reali-store-mutual-indt (pair derive.param1.raw-mindt-spec inductive) -> prop. +reali-store-mutual-indt (pr (derive.param1.raw-mindt-spec GR _ _ _ _ _ _ _ _ FNewName) RealGR) P :- + P = reali-store FNewName (global (indt GR)) (global (indt RealGR)). + +func reali-store-mutual-indcs string, list constructor, list constructor -> list prop. +reali-store-mutual-indcs _ [] [] []. +reali-store-mutual-indcs Prefix [K|KS] [KR|KRS] [P|Rest] :- + N is Prefix ^ {coq.gref->id (indc K)}, + P = reali-store N (global (indc K)) (global (indc KR)), + reali-store-mutual-indcs Prefix KS KRS Rest. + +func mutual-stores list derive.param1.raw-mindt-spec, list inductive -> list prop. +mutual-stores [] [] []. +mutual-stores [derive.param1.raw-mindt-spec _ _ _ _ _ _ KNames _ _ FNewName|Raws] [RealGR|RealGRs] Stores :- + coq.env.indt RealGR _ _ _ _ RealKNames _, + Prefix1 is FNewName ^ "_", + reali-store-mutual-indcs Prefix1 KNames RealKNames StoreKs, + mutual-stores Raws RealGRs Rest, + append StoreKs Rest Stores. + +func mutual-clauses list derive.param1.raw-mindt-spec, list inductive -> list prop. +mutual-clauses [] [] []. +mutual-clauses [derive.param1.raw-mindt-spec GR _ _ _ _ _ KNames _ _ _|Raws] [RealGR|RealGRs] Clauses :- + coq.env.indt RealGR _ _ _ _ RealKNames _, + map2 KNames RealKNames (a\ b\ r\ r = (reali (global (indc a)) (global (indc b)) :- !)) CK, + This = [ + reali-done (indt GR), + (reali (global (indt GR)) (global (indt RealGR)) :- !), + (realiR (global (indt GR)) (global (indt RealGR)) :- !) + | CK], + mutual-clauses Raws RealGRs Rest, + append This Rest Clauses. + +func accumulate-param1-clause prop ->. +accumulate-param1-clause (reali-done _ as C) :- !, + coq.elpi.accumulate _ "derive.param1.db" (clause _ _ C). +accumulate-param1-clause ((realiR _ _ :- !) as C) :- !, + coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "realiR:fail") C). +accumulate-param1-clause C :- + coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "reali:fail") C). + +func dispatch-mutual-do list derive.param1.raw-mindt-spec, list inductive -> list prop. +dispatch-mutual-do Raws NewGRs Clauses :- std.do! [ + map2 Raws NewGRs raw-mutual-spec-clause Assumps, + Assumps =!=> ( + map2 Raws NewGRs translate-mutual-spec Specs, + coq.build-mindt-decl Specs 0 0 DeclR), + std.assert-ok! (coq.typecheck-indt-decl DeclR) "derive.param1 generates illtyped mutual inductive", + coq.env.add-indt DeclR _, + std.map Specs (s\r\ sigma name\ s = coq.mindt-spec _ name _ _ _ _, coq.locate name (indt r)) RealGRs, + map {std.zip Raws RealGRs} reali-store-mutual-indt StoreInds, + mutual-stores Raws RealGRs StoreKs, + forall StoreInds (p\ p), + forall StoreKs (p\ p), + mutual-clauses Raws RealGRs Clauses1, + forall Clauses1 accumulate-param1-clause, + Clauses = Clauses1 +]. + +dispatch (indt GR) Prefix Clauses :- coq.env.mutual-inductives GR GRS, std.length GRS N, N > 1, !, do! [ + map GRS (raw-mutual-spec Prefix) Raws, + Raws = [FirstRaw|_], + raw-mutual-spec-lno FirstRaw Lno, + raw-mutual-spec-luno FirstRaw Luno, + std.assert! (Lno = Luno) "derive.param1: Non-uniform parameters not supported", + dispatch-mutual-gen Raws Raws [] Clauses +]. + dispatch (indt GR) Prefix Clauses :- !, do! [ Ind = global (indt GR), coq.env.indt GR _ _ Lno Ty Knames Ktypes, diff --git a/apps/derive/elpi/param1_congr.elpi b/apps/derive/elpi/param1_congr.elpi index 78f3d0fb7..029b96be1 100644 --- a/apps/derive/elpi/param1_congr.elpi +++ b/apps/derive/elpi/param1_congr.elpi @@ -49,10 +49,31 @@ main-k Prefix Lno K KT Clause :- do! [ Clause = param1-congr-db K (global (const Cst)) ]. +func mutual-indt-count indt-decl -> int. +mutual-indt-count (parameter ID _ Ty F) N :- !, + @pi-parameter ID Ty x\ mutual-indt-count (F x) N. +mutual-indt-count (minductive ID _ Arity Rest) N :- !, + @pi-inductive ID Arity i\ mutual-indt-count (Rest i) M, + N is M + 1. +mutual-indt-count (mblock _) 0. + +func mutual-inductive inductive ->. +mutual-inductive I :- coq.env.mutual-inductives I GRS, std.length GRS N, N > 1. + +func translated-lno gref, gref -> int. +translated-lno (indt _Orig) (indt IsGR) Lno :- + coq.env.indt IsGR _ LnoIs _ _ _ _, LnoIs > 0, !, + Lno = LnoIs. +translated-lno (indt Orig) (indt _) Lno :- mutual-inductive Orig, !, + coq.env.indt Orig _ OrigLno _ _ _ _, + Lno is 2 * OrigLno. +translated-lno _ _ 0 :- !. + func main gref, gref, string -> list prop. -main _ (indt GR) Prefix Clauses2 :- +main Orig (indt GR) Prefix Clauses2 :- - coq.env.indt GR _ Lno _ _ K KT, + coq.env.indt GR _ _ _ _ K KT, + translated-lno Orig (indt GR) Lno, map2-filter K KT (main-k Prefix Lno) Clauses, Clauses2 = [param1-congr-done (indt GR)|Clauses], forall Clauses2 diff --git a/apps/derive/elpi/param1_functor.elpi b/apps/derive/elpi/param1_functor.elpi index 119660bfd..d89f77d75 100644 --- a/apps/derive/elpi/param1_functor.elpi +++ b/apps/derive/elpi/param1_functor.elpi @@ -193,6 +193,304 @@ mk-clause N Lno Ity1 Ity2 (prod _ _ T) Todo Map (pi x\ C x) I M CF :- !, mk-clause N Lno Ity1 Ity2 X Todo Map C I M CF :- whd1 X X1, !, mk-clause N Lno Ity1 Ity2 X1 Todo Map C I M CF. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +kind derive.param1.functor.mutual-spec type. +type derive.param1.functor.mutual-spec inductive -> term -> term -> term -> term -> derive.param1.functor.mutual-spec. + +func mutual-spec inductive -> derive.param1.functor.mutual-spec. +mutual-spec GR (derive.param1.functor.mutual-spec GRR T T Arity Arity) :- + reali (global (indt GR)) (global (indt GRR)), + T = global (indt GRR), + coq.env.indt GRR _ _ _ Arity _ _. + +func mutual-spec-ind derive.param1.functor.mutual-spec -> inductive. +mutual-spec-ind (derive.param1.functor.mutual-spec GRR _ _ _ _) GRR. + +func mutual-spec-arity1 derive.param1.functor.mutual-spec -> term. +mutual-spec-arity1 (derive.param1.functor.mutual-spec _ _ _ A _) A. + +func mutual-spec-apply-type-param term, term, term, derive.param1.functor.mutual-spec -> derive.param1.functor.mutual-spec. +mutual-spec-apply-type-param A P Q (derive.param1.functor.mutual-spec GRR Ity1 Ity2 (prod _ _ F1) (prod _ _ F2)) + (derive.param1.functor.mutual-spec GRR Ity1A Ity2A Arity1 Arity2) :- !, + F1 A = prod _ _ G1, F2 A = prod _ _ G2, + Arity1 = G1 P, Arity2 = G2 Q, + coq.mk-app Ity1 [A,P] Ity1A, + coq.mk-app Ity2 [A,Q] Ity2A. +mutual-spec-apply-type-param _ _ _ _ _ :- stop "derive.param1_functor: mutual parameter mismatch". + +func mutual-spec-apply-param term, derive.param1.functor.mutual-spec -> derive.param1.functor.mutual-spec. +mutual-spec-apply-param A (derive.param1.functor.mutual-spec GRR Ity1 Ity2 (prod _ _ F1) (prod _ _ F2)) + (derive.param1.functor.mutual-spec GRR Ity1A Ity2A (F1 A) (F2 A)) :- !, + coq.mk-app Ity1 [A] Ity1A, + coq.mk-app Ity2 [A] Ity2A. +mutual-spec-apply-param _ _ _ :- stop "derive.param1_functor: mutual parameter mismatch". + +func functor-fix-ty term, term, term, int, list term -> term, int. +functor-fix-ty (prod _ S1 T1) Ity1 Ity2 N Ps (prod `x` S1 Ty) M :- !, + pi x\ sigma Ity1x Ity2x\ + coq.mk-app Ity1 [x] Ity1x, + coq.mk-app Ity2 [x] Ity2x, + N1 is N + 1, + functor-fix-ty (T1 x) Ity1x Ity2x N1 Ps (Ty x) M. +functor-fix-ty (sort _) Ity1 Ity2 N _ (prod `_` Ity1 _\ Ity2) N :- !. +functor-fix-ty X Ity1 Ity2 N Ps Ty M :- whd1 X X1, !, + functor-fix-ty X1 Ity1 Ity2 N Ps Ty M. +functor-fix-ty _ _ _ _ _ _ _ :- stop "derive.param1_functor: mutual indexed data types not supported". + +func mutual-functor-ty derive.param1.functor.mutual-spec -> term, int. +mutual-functor-ty (derive.param1.functor.mutual-spec _ Ity1 Ity2 Arity1 _) Ty Recno :- + functor-fix-ty Arity1 Ity1 Ity2 0 [] Ty Recno. + +func mutual-functor-rec-clauses list derive.param1.functor.mutual-spec, list term -> list prop. +mutual-functor-rec-clauses [] [] []. +mutual-functor-rec-clauses [derive.param1.functor.mutual-spec _ Ity1 Ity2 Arity1 _|SS] [F|FS] Clauses :- + mk-rec-clause Arity1 Ity1 Ity2 F C, + mk-rec-clause-app Arity1 Ity1 Ity2 F D, + mutual-functor-rec-clauses SS FS Rest, + std.append [C,D] Rest Clauses. + +func mutual-functor-body list term, derive.param1.functor.mutual-spec -> term. +mutual-functor-body Ps (derive.param1.functor.mutual-spec _ Ity1 Ity2 Arity1 _ ) Body :- + std.assert! (bo-idx Arity1 Ity1 Ity2 0 _ Ps Body _) "derive.param1_functor: failed to build one mutual fix body". + +func mutual-functor-mfix-aux list term, list derive.param1.functor.mutual-spec, list derive.param1.functor.mutual-spec, list term -> mfix-block. +mutual-functor-mfix-aux Ps All [] RevF (mfix-bo Bodies) :- !, + std.rev RevF Funs, + std.assert! (mutual-functor-rec-clauses All Funs Clauses) "derive.param1_functor: failed to build mutual recursion clauses", + Clauses =!=> std.assert! (std.map All (mutual-functor-body Ps) Bodies) "derive.param1_functor: failed to build mutual fix bodies". +mutual-functor-mfix-aux Ps All [S|SS] RevF (mfix-ty N Recno Ty Rest) :- + S = derive.param1.functor.mutual-spec GRR _ _ _ _, + ID is {coq.gref->id (indt GRR)} ^ "_functor_rec", + coq.id->name ID N, + std.assert! (mutual-functor-ty S Ty Recno) "derive.param1_functor: failed to build one mutual fix type", + @pi-decl N Ty f\ std.assert! (mutual-functor-mfix-aux Ps All SS [f|RevF] (Rest f)) "derive.param1_functor: failed to build rest mutual fix block". + +func mutual-functor-mfix list term, list derive.param1.functor.mutual-spec, int -> term. +mutual-functor-mfix Ps Specs Focus (mfix Focus Recno Block) :- + std.assert! (std.nth Focus Specs S) "derive.param1_functor: failed to select mutual spec", + std.assert! (mutual-functor-ty S _ Recno) "derive.param1_functor: failed to build mutual fix type", + std.assert! (mutual-functor-mfix-aux Ps Specs Specs [] Block) "derive.param1_functor: failed to build mutual fix block". + +func mutual-functor-param1-fix-ty term, term, term, term, int -> term, int. +mutual-functor-param1-fix-ty A PA Ity1 (prod N S T) K Ty Recno :- !, + Ty = prod N S (x\ Ty1 x), + pi x\ sigma Ity1x\ + coq.mk-app Ity1 [x] Ity1x, + K1 is K + 1, + mutual-functor-param1-fix-ty A PA Ity1x (T x) K1 (Ty1 x) Recno. +mutual-functor-param1-fix-ty A PA Ity1 (sort _) K Ty K :- !, + coq.safe-dest-app Ity1 HD [_A,_PA|Idxs], + Ty = prod `Hx` Ity1 (_\ prod `PB` {{ lp:A -> Type }} (PB\ prod `f` (Fty PB) (_\ Target PB))), + pi PB\ + Fty PB = prod `z` A (z\ prod `_` (app [PA,z]) (_\ app [PB,z])), + coq.mk-app HD {std.append [A,PB] Idxs} (Target PB). +mutual-functor-param1-fix-ty _ _ _ _ _ _ _ :- stop "derive.param1_functor: mutual indexed data types not supported". + +func mutual-functor-param1-ty derive.param1.functor.mutual-spec -> term, int. +mutual-functor-param1-ty (derive.param1.functor.mutual-spec _ Ity1 _ Arity _) Ty Recno :- + Arity = prod A TA (a\ prod P (TP a) (pa\ Rest a pa)), !, + Ty = prod A TA (a\ prod P (TP a) (pa\ TyRest a pa)), + @pi-decl A TA a\ @pi-decl P (TP a) pa\ sigma Ity1AP\ + coq.mk-app Ity1 [a,pa] Ity1AP, + mutual-functor-param1-fix-ty a pa Ity1AP (Rest a pa) 2 (TyRest a pa) Recno. + +func mutual-functor-param1-rty term, term, list term, list term -> term. +mutual-functor-param1-rty ItyArgs _ Vs _ R :- + std.rev Vs [_|ArgsRev], + std.rev ArgsRev Args, + Args = [A,PA|Idxs], + coq.safe-dest-app ItyArgs HD _, + R = prod `PB` {{ lp:A -> Type }} (PB\ prod `f` (Fty PB) (_\ Target PB)), + pi PB\ + Fty PB = prod `z` A (z\ prod `_` (app [PA,z]) (_\ app [PB,z])), + coq.mk-app HD {std.append [A,PB] Idxs} (Target PB). + +func mutual-functor-param1-map-rec list derive.param1.functor.mutual-spec, list term, term, term, term, term, term, term, term -> term. +mutual-functor-param1-map-rec [derive.param1.functor.mutual-spec _ Ity _ _ _|_] [Rec|_] A PA PB F Src Tgt PX M :- + coq.safe-dest-app Src Ity [A,PA|Idxs], + coq.safe-dest-app Tgt Ity [A,PB|Idxs], !, + sigma RecIdx\ + coq.mk-app Rec {std.append [A,PA] Idxs} RecIdx, + coq.mk-app RecIdx [PX,PB,F] M. +mutual-functor-param1-map-rec [_|SS] [_|Recs] A PA PB F Src Tgt PX M :- + mutual-functor-param1-map-rec SS Recs A PA PB F Src Tgt PX M. + +func mutual-functor-param1-map-arg list derive.param1.functor.mutual-spec, list term, term, term, term, term, term, term, term -> term. +mutual-functor-param1-map-arg _ _ _ PA PB F (app [PA,X]) (app [PB,X]) PX M :- !, + coq.mk-app F [X,PX] M. +mutual-functor-param1-map-arg All Funs A PA PB F Src Tgt PX M :- + mutual-functor-param1-map-rec All Funs A PA PB F Src Tgt PX M, !. +mutual-functor-param1-map-arg _ _ _ _ _ _ Src Tgt PX M :- + param1-functor-db Src Tgt Map, + coq.mk-app Map [PX] M. + +func mutual-functor-param1-k-args-aux list derive.param1.functor.mutual-spec, list term, term, term, term, term, term, list term, list term, term -> term. +mutual-functor-param1-k-args-aux All Funs A PA PB F K [X,PX|Args] [_,TPA|Types] (prod _ _ (x\ prod _ (TPB x) (px\ Ty x px))) R :- + not(same_term TPA (TPB X)), + mutual-functor-param1-map-arg All Funs A PA PB F TPA (TPB X) PX MPX, !, + coq.mk-app K [X,MPX] KXPX, + mutual-functor-param1-k-args-aux All Funs A PA PB F KXPX Args Types (Ty X MPX) R. +mutual-functor-param1-k-args-aux All Funs A PA PB F K [X,PX|Args] [_,_|Types] (prod _ _ (x\ prod _ _ (px\ Ty x px))) R :- !, + coq.mk-app K [X,PX] KXPX, + mutual-functor-param1-k-args-aux All Funs A PA PB F KXPX Args Types (Ty X PX) R. +mutual-functor-param1-k-args-aux _ _ _ _ _ _ R [] [] _ R. + +func mutual-functor-param1-k-args list derive.param1.functor.mutual-spec, list term, term, term, list term, list term -> term. +mutual-functor-param1-k-args All Funs K _ Args Tys R :- + Args = [A,PA|RestArgs], + Tys = [_,_|RestTys], + R = fun `PB` {{ lp:A -> Type }} (PB\ fun `f` (Fty PB) (F\ Body PB F)), + @pi-decl `PB` {{ lp:A -> Type }} PB\ @pi-decl `f` (Fty PB) F\ sigma GR KT KAPB\ + Fty PB = prod `z` A (z\ prod `_` (app [PA,z]) (_\ app [PB,z])), + coq.safe-dest-app K (global (indc GR)) _, + coq.env.typeof (indc GR) KTy, + coq.subst-prod [A,PB] KTy KT, + coq.mk-app K [A,PB] KAPB, + mutual-functor-param1-k-args-aux All Funs A PA PB F KAPB RestArgs RestTys KT (Body PB F). + +func mutual-functor-param1-body list derive.param1.functor.mutual-spec, list term, derive.param1.functor.mutual-spec -> term. +mutual-functor-param1-body All Funs (derive.param1.functor.mutual-spec _ Ity1 _ Arity _) Body :- + Arity = prod A TA (a\ prod P (TP a) (pa\ Rest a pa)), !, + Body = fun A TA (a\ fun P (TP a) (pa\ BodyRest a pa)), + @pi-decl A TA a\ @pi-decl P (TP a) pa\ sigma Ity1AP\ + coq.mk-app Ity1 [a,pa] Ity1AP, + mutual-functor-param1-body-rest All Funs Ity1AP (Rest a pa) (BodyRest a pa). + +func mutual-functor-param1-body-rest list derive.param1.functor.mutual-spec, list term, term, term -> term. +mutual-functor-param1-body-rest All Funs Ity1 (prod N S T) (fun N S (x\ R x)) :- !, + @pi-decl N S x\ sigma Ity1x\ + coq.mk-app Ity1 [x] Ity1x, + mutual-functor-param1-body-rest All Funs Ity1x (T x) (R x). +mutual-functor-param1-body-rest All Funs Ity1 (sort _) (fun `Hx` Ity1 (Hx\ Match Hx)) :- !, + @pi-decl `Hx` Ity1 Hx\ + coq.build-match Hx Ity1 (mutual-functor-param1-rty Ity1) (mutual-functor-param1-k-args All Funs) (Match Hx). + +func mutual-functor-param1-mfix-aux list derive.param1.functor.mutual-spec, list derive.param1.functor.mutual-spec, list term -> mfix-block. +mutual-functor-param1-mfix-aux All [] RevF (mfix-bo Bodies) :- !, + std.rev RevF Funs, + std.map All (mutual-functor-param1-body All Funs) Bodies. +mutual-functor-param1-mfix-aux All [S|SS] RevF (mfix-ty N Recno Ty Rest) :- + S = derive.param1.functor.mutual-spec GRR _ _ _ _, + ID is {coq.gref->id (indt GRR)} ^ "_functor_rec", + coq.id->name ID N, + mutual-functor-param1-ty S Ty Recno, + @pi-decl N Ty f\ mutual-functor-param1-mfix-aux All SS [f|RevF] (Rest f). + +func mutual-functor-param1-mfix list derive.param1.functor.mutual-spec, int -> term. +mutual-functor-param1-mfix Specs Focus (mfix Focus Recno Block) :- + std.nth Focus Specs S, + mutual-functor-param1-ty S _ Recno, + mutual-functor-param1-mfix-aux Specs Specs [] Block. + +func mutual-functor-param1-apply-rest term, term, term, term, term -> term. +mutual-functor-param1-apply-rest Ity1 Fix (prod N S T) PB F (fun N S (x\ R x)) :- !, + @pi-decl N S x\ sigma Ity1x Fixx\ + coq.mk-app Ity1 [x] Ity1x, + coq.mk-app Fix [x] Fixx, + mutual-functor-param1-apply-rest Ity1x Fixx (T x) PB F (R x). +mutual-functor-param1-apply-rest Ity1 Fix (sort _) PB F (fun `Hx` Ity1 (Hx\ App Hx)) :- !, + pi Hx\ coq.mk-app Fix [Hx,PB,F] (App Hx). + +func body-mutual-param1 term, list derive.param1.functor.mutual-spec, int -> term. +body-mutual-param1 (prod A TA (a\ prod P (TP a) (pa\ Rest a pa))) Specs Focus R :- + R = fun A TA (a\ fun P (TP a) (pa\ fun P (TP a) (pb\ fun `f` (Fty a pa pb) (f\ Body a pa pb f)))), + @pi-decl A TA a\ @pi-decl P (TP a) pa\ @pi-decl P (TP a) pb\ + Fty a pa pb = prod `z` a (z\ prod `_` (app [pa,z]) (_\ app [pb,z])), + @pi-decl `f` (Fty a pa pb) f\ sigma Fix SF Ity1AP FixAP\ + std.assert! (mutual-functor-param1-mfix Specs Focus Fix) "derive.param1_functor: failed to build param1 mutual mfix", + std.assert! (std.nth Focus Specs SF) "derive.param1_functor: failed to select param1 mutual spec", + SF = derive.param1.functor.mutual-spec _ Ity1 _ _ _, + std.assert! (coq.mk-app Ity1 [a,pa] Ity1AP) "derive.param1_functor: failed to apply param1 source type", + std.assert! (coq.mk-app Fix [a,pa] FixAP) "derive.param1_functor: failed to apply param1 mfix params", + std.assert! (mutual-functor-param1-apply-rest Ity1AP FixAP (Rest a pa) pb f (Body a pa pb f)) "derive.param1_functor: failed to apply param1 mutual mfix". + +func body-mutual-params int, list derive.param1.functor.mutual-spec, int -> term. +body-mutual-params 2 Specs Focus R :- + std.nth Focus Specs S, mutual-spec-arity1 S Arity, Arity = prod _ TA _, coq.sort? TA, !, + std.assert! (body-mutual-param1 Arity Specs Focus R) "derive.param1_functor: failed to build param1 mutual body". +body-mutual-params N Specs Focus R :- body-mutual-params-aux N Specs Focus [] R. + +func body-mutual-params-aux int, list derive.param1.functor.mutual-spec, int, list term -> term. +body-mutual-params-aux 0 Specs Focus Ps R :- !, + std.assert! (mutual-functor-mfix Ps Specs Focus R) "derive.param1_functor: failed to build mutual mfix". +body-mutual-params-aux N ([S|_] as Specs) Focus Ps R :- N > 0, + mutual-spec-arity1 S {{ forall (a : lp:T1) (p : a -> Type), lp:(Rty a p) }}, whd T1 [] {{ Type }} [], !, + M is N - 2, + pi a b f\ mk-map-ty a {{ lp:a -> Type }} b {{ lp:b -> Type }} (FAB a b) f _ (Clause a b f), + R = {{ fun (a : Type) (pa pb : a -> Type) (f : forall x : a, pa x -> pb x) => lp:(Bo a pa pb f) }}, + pi a pa pb f\ + sigma Specs1\ + std.assert! (std.map Specs (mutual-spec-apply-type-param a pa pb) Specs1) "derive.param1_functor: failed to apply mutual type parameters", + Clause pa pb f => + decl a `a` {{ Type }} => + decl pa `pa` {{ lp:a -> Type }} => + decl pb `pb` {{ lp:a -> Type }} => + decl f `f` (FAB pa pb) => + std.assert! (body-mutual-params-aux M Specs1 Focus [pb,a|Ps] (Bo a pa pb f)) "derive.param1_functor: failed after mutual type parameters". +body-mutual-params-aux N ([S|_] as Specs) Focus Ps R :- N > 0, !, + mutual-spec-arity1 S (prod A TA _), + M is N - 1, + R = (fun A TA a\ Bo a), + @pi-decl A TA a\ + sigma Specs1\ + std.map Specs (mutual-spec-apply-param a) Specs1, + body-mutual-params-aux M Specs1 Focus [a|Ps] (Bo a). +body-mutual-params-aux _ _ _ _ _ :- stop "derive.param1_functor: wrong mutual shape". + +func body-mutual-params-ty int, derive.param1.functor.mutual-spec -> term. +body-mutual-params-ty 0 S Ty :- !, + mutual-functor-ty S Ty _. +body-mutual-params-ty N S Ty :- N > 0, + mutual-spec-arity1 S (prod A TA a\ prod P (TP a) _), coq.sort? TA, !, + M is N - 2, + Ty = prod A TA (a\ prod P (TP a) (pa\ prod P (TP a) (pb\ prod `f` (Fty a pa pb) (f\ Rest a pa pb f)))), + @pi-decl A TA a\ @pi-decl P (TP a) pa\ @pi-decl P (TP a) pb\ + Fty a pa pb = prod `x` a (x\ prod `_` (app [pa, x]) (_\ app [pb, x])), + @pi-decl `f` (Fty a pa pb) f\ + sigma S1\ + mutual-spec-apply-type-param a pa pb S S1, + body-mutual-params-ty M S1 (Rest a pa pb f). +body-mutual-params-ty N S Ty :- N > 0, !, + mutual-spec-arity1 S (prod A TA _), + M is N - 1, + Ty = prod A TA (a\ Rest a), + @pi-decl A TA a\ + sigma S1\ + mutual-spec-apply-param a S S1, + body-mutual-params-ty M S1 (Rest a). +body-mutual-params-ty _ _ _ :- stop "derive.param1_functor: wrong mutual shape". + +func add-mutual-functor-consts list derive.param1.functor.mutual-spec, list derive.param1.functor.mutual-spec, string, int, int -> list prop. +add-mutual-functor-consts _ [] _ _ _ []. +add-mutual-functor-consts All [S|SS] Suffix Lno Focus [Clause1, Clause2|CS] :- std.do! [ + S = derive.param1.functor.mutual-spec GRR T T Arity _, + Name is {coq.gref->id (indt GRR)} ^ Suffix, + std.assert! (body-mutual-params Lno All Focus R) "derive.param1_functor: failed to generate mutual term", + std.assert-ok! (coq.typecheck R Rty) "derive.param1_functor generates illtyped mutual term", + coq.env.add-const Name R Rty @transparent! Funct, + mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause1 GRR [] Clause2, + std.forall [Clause1,Clause2] (x\coq.elpi.accumulate _ "derive.param1.functor.db" (clause _ _ x)), + Focus1 is Focus + 1, + add-mutual-functor-consts All SS Suffix Lno Focus1 CS +]. + +func mutual-lno list inductive, inductive -> int. +mutual-lno _ FirstGRR Lno :- coq.env.indt FirstGRR _ Lno _ _ _ _, Lno > 0, !. +mutual-lno [FirstOrig|_] _ Lno :- !, coq.env.indt FirstOrig _ OrigLno _ _ _ _, Lno is 2 * OrigLno. +mutual-lno _ _ 0 :- !. + +func main-mutual list inductive, string -> list prop. +main-mutual GRS Suffix C :- std.do! [ + std.map GRS mutual-spec Specs, + Specs = [First|_], + mutual-spec-ind First FirstGRR, + coq.env.indt FirstGRR _ LnoIs Luno _ _ _, + assert! (LnoIs = Luno) "derive.param1.functor: Non-uniform parameters not supported", + mutual-lno GRS FirstGRR Lno, + add-mutual-functor-consts Specs Specs Suffix Lno 0 C +]. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% func main gref, gref, string -> list prop. main _ (indt GR) Suffix C :- do! [ diff --git a/apps/derive/elpi/param1_inhab.elpi b/apps/derive/elpi/param1_inhab.elpi index 5a3fa7ebb..774a6e9b9 100644 --- a/apps/derive/elpi/param1_inhab.elpi +++ b/apps/derive/elpi/param1_inhab.elpi @@ -104,6 +104,163 @@ body-params _ IsT _ _ _ _ :- ". It does not look like a unary parametricity translation of an inductive with no indexes.", stop M. +kind derive.param1.inhab.mutual-spec type. +type derive.param1.inhab.mutual-spec inductive -> inductive -> term -> term -> list constructor -> list term -> list term -> derive.param1.inhab.mutual-spec. + +func mutual-spec inductive -> derive.param1.inhab.mutual-spec. +mutual-spec GR (derive.param1.inhab.mutual-spec GR GRR (global (indt GRR)) Arity KOrig K KT) :- std.do! [ + reali (global (indt GR)) (global (indt GRR)), + coq.env.indt GR _ _ _ _ KOrig _, + coq.env.indt GRR _ _ _ Arity KR KT, + std.map KR (k\r\ r = global (indc k)) K +]. + +func mutual-spec-arity derive.param1.inhab.mutual-spec -> term. +mutual-spec-arity (derive.param1.inhab.mutual-spec _ _ _ Arity _ _ _) Arity. + +func mutual-spec-ind derive.param1.inhab.mutual-spec -> inductive. +mutual-spec-ind (derive.param1.inhab.mutual-spec _ GRR _ _ _ _ _) GRR. + +func mutual-spec-apply-sort-param term, term, derive.param1.inhab.mutual-spec -> derive.param1.inhab.mutual-spec. +mutual-spec-apply-sort-param A P (derive.param1.inhab.mutual-spec GR GRR IsT (prod _ _ F) KOrig K KT) + (derive.param1.inhab.mutual-spec GR GRR IsTAP ArityAP KOrig KAP KTAP) :- !, + F A = prod _ _ G, + ArityAP = G P, + coq.mk-app IsT [A,P] IsTAP, + map K (k\ coq.mk-app k [A,P]) KAP, + map KT (coq.subst-prod [A,P]) KTAP. +mutual-spec-apply-sort-param _ _ _ _ :- stop "derive.param1_inhab: mutual parameter mismatch". + +func mutual-spec-apply-param term, derive.param1.inhab.mutual-spec -> derive.param1.inhab.mutual-spec. +mutual-spec-apply-param A (derive.param1.inhab.mutual-spec GR GRR IsT (prod _ _ F) KOrig K KT) + (derive.param1.inhab.mutual-spec GR GRR IsTA (F A) KOrig KA KTA) :- !, + coq.mk-app IsT [A] IsTA, + map K (k\ coq.mk-app k [A]) KA, + map KT (coq.subst-prod [A]) KTA. +mutual-spec-apply-param _ _ _ :- stop "derive.param1_inhab: mutual parameter mismatch". + +func mutual-inhab-ty derive.param1.inhab.mutual-spec -> term. +mutual-inhab-ty (derive.param1.inhab.mutual-spec _ _ IsT (prod _ T _\ sort _) _ _ _) Ty :- !, + Ty = prod `x` T R, + pi x\ coq.mk-app IsT [x] (R x). +mutual-inhab-ty _ _ :- stop "derive.param1_inhab: mutual indexed data types not supported". + +func mutual-inhab-body derive.param1.inhab.mutual-spec -> term. +mutual-inhab-body (derive.param1.inhab.mutual-spec _GR _ IsT (prod _ T _\ sort _) KOrig K KT) (fun `x` T Bo) :- !, + RT = (x\ {coq.mk-app IsT [x]}), + map2 KOrig {zip K KT} (a\b\r\ r = (global (indc a)) `-> b) K2KR, + K2KR =!=> @pi-decl `x` T x\ coq.build-match x T (oty RT) body (Bo x). +mutual-inhab-body _ _ :- stop "derive.param1_inhab: mutual indexed data types not supported". + +func mutual-inhab-db-clauses list derive.param1.inhab.mutual-spec, list term -> list prop. +mutual-inhab-db-clauses [] [] []. +mutual-inhab-db-clauses [S|SS] [F|FS] [C|CS] :- + S = derive.param1.inhab.mutual-spec _ _ IsT _ _ _ _, + C = (param1-inhab-db IsT F), + mutual-inhab-db-clauses SS FS CS. + +func mutual-inhab-mfix-aux list derive.param1.inhab.mutual-spec, list derive.param1.inhab.mutual-spec, list term -> mfix-block. +mutual-inhab-mfix-aux All [] RevF (mfix-bo Bodies) :- !, + rev RevF Funs, + mutual-inhab-db-clauses All Funs Clauses, + Clauses =!=> map All mutual-inhab-body Bodies. +mutual-inhab-mfix-aux All [S|SS] RevF (mfix-ty N 0 Ty Rest) :- + S = derive.param1.inhab.mutual-spec _ GRR _ _ _ _ _, + ID is {coq.gref->id (indt GRR)} ^ "_inhab_rec", + coq.id->name ID N, + mutual-inhab-ty S Ty, + @pi-decl N Ty f\ mutual-inhab-mfix-aux All SS [f|RevF] (Rest f). + +func mutual-inhab-mfix list derive.param1.inhab.mutual-spec, int -> term. +mutual-inhab-mfix Specs Focus (mfix Focus 0 Block) :- + mutual-inhab-mfix-aux Specs Specs [] Block. + +func body-mutual-params int, list derive.param1.inhab.mutual-spec, int -> term. +body-mutual-params 0 Specs Focus R :- !, mutual-inhab-mfix Specs Focus R. +body-mutual-params N ([S|_] as Specs) Focus R :- N > 0, + mutual-spec-arity S (prod A TA a\ prod P (TP a) _), coq.sort? TA, !, + M is N - 2, + R = (fun A TA a\ fun P (TP a) p\ fun _ {{ lib:elpi.derive.full lp:a lp:p }} pf\ Bo a p pf), + @pi-decl A TA a\ @pi-decl P (TP a) p\ @pi-decl _ {{ lib:elpi.derive.full lp:a lp:p }} pf\ + sigma Specs1\ + map Specs (mutual-spec-apply-sort-param a p) Specs1, + (reali a p :- !) => param1-inhab-db p pf => + body-mutual-params M Specs1 Focus (Bo a p pf). +body-mutual-params N ([S|_] as Specs) Focus R :- N > 0, !, + mutual-spec-arity S (prod A TA _F), + M is N - 1, + R = (fun A TA a\ Bo a), + @pi-decl A TA a\ + sigma Specs1\ + map Specs (mutual-spec-apply-param a) Specs1, + body-mutual-params M Specs1 Focus (Bo a). +body-mutual-params _ _ _ _ :- stop "derive.param1_inhab: wrong mutual shape". + +func full-ty term, term -> term. +full-ty T P (prod `x` T B) :- + pi x\ coq.mk-app P [x] (B x). + +func mutual-inhab-result-ty derive.param1.inhab.mutual-spec -> term. +mutual-inhab-result-ty (derive.param1.inhab.mutual-spec _ _ IsT (prod _ T _\ sort _) _ _ _) Ty :- !, + full-ty T IsT Ty. +mutual-inhab-result-ty _ _ :- stop "derive.param1_inhab: mutual indexed data types not supported". + +func body-mutual-params-ty int, derive.param1.inhab.mutual-spec -> term. +body-mutual-params-ty 0 S Ty :- !, + mutual-inhab-result-ty S Ty. +body-mutual-params-ty N S Ty :- N > 0, + mutual-spec-arity S (prod A TA a\ prod P (TP a) _), coq.sort? TA, !, + M is N - 2, + Ty = prod A TA (a\ prod P (TP a) (p\ prod _ (FullAP a p) (pf\ Rest a p pf))), + @pi-decl A TA a\ @pi-decl P (TP a) p\ + full-ty a p (FullAP a p), + @pi-decl _ (FullAP a p) pf\ + sigma S1\ + mutual-spec-apply-sort-param a p S S1, + body-mutual-params-ty M S1 (Rest a p pf). +body-mutual-params-ty N S Ty :- N > 0, !, + mutual-spec-arity S (prod A TA _), + M is N - 1, + Ty = prod A TA (a\ Rest a), + @pi-decl A TA a\ + sigma S1\ + mutual-spec-apply-param a S S1, + body-mutual-params-ty M S1 (Rest a). +body-mutual-params-ty _ _ _ :- stop "derive.param1_inhab: wrong mutual shape". + +func add-mutual-inhab-consts list derive.param1.inhab.mutual-spec, list derive.param1.inhab.mutual-spec, string, int, int -> list prop. +add-mutual-inhab-consts _ [] _ _ _ []. +add-mutual-inhab-consts All [S|SS] Suffix Lno Focus [ClauseW, param1-inhab-done (indt GRR)|CS] :- std.do! [ + S = derive.param1.inhab.mutual-spec _ GRR IsT _ _ _ _, + body-mutual-params Lno All Focus RSkel, + std.assert-ok! (coq.typecheck RSkel RT) "derive.param1_inhab generates illtyped mutual term", + R = RSkel, + Name is {coq.gref->id (indt GRR)} ^ Suffix, + coq.env.add-const Name R RT @transparent! Witness, + ClauseW = (param1-inhab-db IsT (global (const Witness))), + coq.elpi.accumulate _ "derive.param1.trivial.db" (clause _ _ ClauseW), + coq.elpi.accumulate _ "derive.param1.trivial.db" (clause _ _ (param1-inhab-done (indt GRR))), + Focus1 is Focus + 1, + add-mutual-inhab-consts All SS Suffix Lno Focus1 CS +]. + +func mutual-lno list inductive, inductive -> int. +mutual-lno _ FirstGRR Lno :- coq.env.indt FirstGRR _ Lno _ _ _ _, Lno > 0, !. +mutual-lno [FirstOrig|_] _ Lno :- !, coq.env.indt FirstOrig _ OrigLno _ _ _ _, Lno is 2 * OrigLno. +mutual-lno _ _ 0 :- !. + +func main-mutual list inductive, string -> list prop. +main-mutual GRS Suffix Clauses :- std.do! [ + map GRS mutual-spec Specs, + Specs = [First|_], + mutual-spec-ind First FirstGRR, + coq.env.indt FirstGRR Ind LnoIs Luno _ _ _, + assert! (Ind = tt) "derive.param1_inhab: Coinductive types are not supported", + assert! (LnoIs = Luno) "derive.param1_inhab: Non-uniform parameters not supported", + mutual-lno GRS FirstGRR Lno, + add-mutual-inhab-consts Specs Specs Suffix Lno 0 Clauses +]. + func main gref, gref, string -> list prop. main _ (indt GR) Suffix [ClauseW, param1-inhab-done (indt GR)] :- do! [ diff --git a/apps/derive/elpi/param1_trivial.elpi b/apps/derive/elpi/param1_trivial.elpi index 071d878f2..02dbf9896 100644 --- a/apps/derive/elpi/param1_trivial.elpi +++ b/apps/derive/elpi/param1_trivial.elpi @@ -112,6 +112,185 @@ body-params _ T _ _ :- ". It does not look like a unary parametricity translation of an inductive with no indexes.", fail. +kind derive.param1.trivial.mutual-spec type. +type derive.param1.trivial.mutual-spec inductive -> term -> term -> derive.param1.trivial.mutual-spec. + +func mutual-spec inductive -> derive.param1.trivial.mutual-spec. +mutual-spec GR (derive.param1.trivial.mutual-spec GRR (global (indt GRR)) Arity) :- + reali (global (indt GR)) (global (indt GRR)), + coq.env.indt GRR _ _ _ Arity _ _. + +func mutual-spec-ind derive.param1.trivial.mutual-spec -> inductive. +mutual-spec-ind (derive.param1.trivial.mutual-spec GRR _ _) GRR. + +func mutual-spec-arity derive.param1.trivial.mutual-spec -> term. +mutual-spec-arity (derive.param1.trivial.mutual-spec _ _ Arity) Arity. + +func mutual-spec-apply-sort-param term, term, derive.param1.trivial.mutual-spec -> derive.param1.trivial.mutual-spec. +mutual-spec-apply-sort-param A P (derive.param1.trivial.mutual-spec GRR IsT (prod _ _ F)) + (derive.param1.trivial.mutual-spec GRR IsTAP ArityAP) :- !, + F A = prod _ _ G, + ArityAP = G P, + coq.mk-app IsT [A,P] IsTAP. +mutual-spec-apply-sort-param _ _ _ _ :- stop "derive.param1_trivial: mutual parameter mismatch". + +func mutual-spec-apply-param term, derive.param1.trivial.mutual-spec -> derive.param1.trivial.mutual-spec. +mutual-spec-apply-param A (derive.param1.trivial.mutual-spec GRR IsT (prod _ _ F)) + (derive.param1.trivial.mutual-spec GRR IsTA (F A)) :- !, + coq.mk-app IsT [A] IsTA. +mutual-spec-apply-param _ _ _ :- stop "derive.param1_trivial: mutual parameter mismatch". + +func mutual-trivial-eq-ty derive.param1.trivial.mutual-spec, term -> term. +mutual-trivial-eq-ty (derive.param1.trivial.mutual-spec _ IsT (prod _ T _\ sort _)) W Ty :- !, + Ty = prod `x` T R1, + pi x\ sigma IsTx Wx\ + coq.mk-app IsT [x] IsTx, + coq.mk-app W [x] Wx, + R1 x = prod `y` IsTx (y\ {{ lib:@elpi.eq lp:IsTx lp:Wx lp:y }}). +mutual-trivial-eq-ty _ _ _ :- stop "derive.param1_trivial: mutual indexed data types not supported". + +func mutual-trivial-eq-body derive.param1.trivial.mutual-spec, term -> term. +mutual-trivial-eq-body (derive.param1.trivial.mutual-spec _ IsT (prod _ T _\ sort _)) W (fun `x` T Bo1) :- !, + @pi-decl `x` T x\ sigma IsTx\ + coq.mk-app IsT [x] IsTx, + Bo1 x = fun `y` IsTx (Bo2 x), + @pi-decl `y` IsTx y\ coq.build-match y IsTx (oty IsT W) (body IsT W) (Bo2 x y). +mutual-trivial-eq-body _ _ _ :- stop "derive.param1_trivial: mutual indexed data types not supported". + +func mutual-trivial-db-clauses list derive.param1.trivial.mutual-spec, list term, list term -> list prop. +mutual-trivial-db-clauses [] [] [] []. +mutual-trivial-db-clauses [S|SS] [W|WS] [F|FS] [C|CS] :- + S = derive.param1.trivial.mutual-spec _ IsT (prod _ T _\ sort _), + C = (param1-trivial-db IsT {{ fun x : lp:T => lib:elpi.derive.contracts lp:T lp:IsT x (lp:W x) (lp:F x) }}), + mutual-trivial-db-clauses SS WS FS CS. + +func mutual-trivial-mfix-aux list derive.param1.trivial.mutual-spec, list derive.param1.trivial.mutual-spec, list term, list term, list term -> mfix-block. +mutual-trivial-mfix-aux All [] AllWs [] RevF (mfix-bo Bodies) :- !, + std.rev RevF Funs, + mutual-trivial-db-clauses All AllWs Funs Clauses, + Clauses =!=> std.map2 All AllWs mutual-trivial-eq-body Bodies. +mutual-trivial-mfix-aux All [S|SS] AllWs [W|WS] RevF (mfix-ty N 1 Ty Rest) :- + S = derive.param1.trivial.mutual-spec GRR _ _, + ID is {coq.gref->id (indt GRR)} ^ "_trivial_rec", + coq.id->name ID N, + mutual-trivial-eq-ty S W Ty, + @pi-decl N Ty f\ mutual-trivial-mfix-aux All SS AllWs WS [f|RevF] (Rest f). + +func mutual-trivial-mfix list derive.param1.trivial.mutual-spec, list term, int -> term. +mutual-trivial-mfix Specs Ws Focus (mfix Focus 1 Block) :- + mutual-trivial-mfix-aux Specs Specs Ws Ws [] Block. + +func mutual-trivial-result derive.param1.trivial.mutual-spec, term, term -> term. +mutual-trivial-result (derive.param1.trivial.mutual-spec _ IsT (prod _ T _\ sort _)) W EqFun R :- !, + R = {{ fun x : lp:T => lib:elpi.derive.contracts lp:T lp:IsT x (lp:W x) (lp:EqFun x) }}. +mutual-trivial-result _ _ _ _ :- stop "derive.param1_trivial: mutual indexed data types not supported". + +func mutual-inhab-witness derive.param1.trivial.mutual-spec -> term. +mutual-inhab-witness (derive.param1.trivial.mutual-spec _ IsT _) W :- + std.assert! (param1-inhab-db IsT W) "derive.param1_trivial: use derive.param1_inhab first". + +func body-mutual-params int, list derive.param1.trivial.mutual-spec, int -> term. +body-mutual-params 0 Specs Focus R :- !, + std.map Specs mutual-inhab-witness Ws, + mutual-trivial-mfix Specs Ws Focus EqFun, + std.nth Focus Specs S, + std.nth Focus Ws W, + mutual-trivial-result S W EqFun R. +body-mutual-params N ([S|_] as Specs) Focus R :- N > 0, + mutual-spec-arity S (prod A TA a\ prod P (TP a) _), coq.sort? TA, !, + M is N - 2, + R = (fun A TA a\ fun P (TP a) p\ fun _ {{ lib:elpi.derive.trivial lp:a lp:p }} pf\ Bo a p pf), + @pi-decl A TA a\ @pi-decl P (TP a) p\ @pi-decl _ {{ lib:elpi.derive.trivial lp:a lp:p }} pf\ + sigma Specs1\ + std.map Specs (mutual-spec-apply-sort-param a p) Specs1, + (reali a p :- !) => + param1-trivial-db p pf => + param1-inhab-db p {{ lib:elpi.derive.trivial_full lp:a lp:p lp:pf }} => + body-mutual-params M Specs1 Focus (Bo a p pf). +body-mutual-params N ([S|_] as Specs) Focus R :- N > 0, !, + mutual-spec-arity S (prod A TA _F), + M is N - 1, + R = (fun A TA a\ Bo a), + @pi-decl A TA a\ + sigma Specs1\ + std.map Specs (mutual-spec-apply-param a) Specs1, + body-mutual-params M Specs1 Focus (Bo a). +body-mutual-params _ _ _ _ :- stop "derive.param1_trivial: wrong mutual shape". + +func contractible-ty term -> term. +contractible-ty T + (app [global (indt SigT), T, + fun `x` T (x\ prod `y` T (y\ app [global (indt Eq), T, x, y]))]) :- + coq.locate "sigT" (indt SigT), + coq.locate "eq" (indt Eq). + +func trivial-ty term, term -> term. +trivial-ty T P (prod `x` T B) :- + pi x\ sigma Px\ + coq.mk-app P [x] Px, + contractible-ty Px (B x). + +func mutual-trivial-result-ty derive.param1.trivial.mutual-spec -> term. +mutual-trivial-result-ty (derive.param1.trivial.mutual-spec _ IsT (prod _ T _\ sort _)) Ty :- !, + trivial-ty T IsT Ty. +mutual-trivial-result-ty _ _ :- stop "derive.param1_trivial: mutual indexed data types not supported". + +func body-mutual-params-ty int, derive.param1.trivial.mutual-spec -> term. +body-mutual-params-ty 0 S Ty :- !, + mutual-trivial-result-ty S Ty. +body-mutual-params-ty N S Ty :- N > 0, + mutual-spec-arity S (prod A TA a\ prod P (TP a) _), coq.sort? TA, !, + M is N - 2, + Ty = prod A TA (a\ prod P (TP a) (p\ prod _ (TrivAP a p) (pf\ Rest a p pf))), + @pi-decl A TA a\ @pi-decl P (TP a) p\ + trivial-ty a p (TrivAP a p), + @pi-decl _ (TrivAP a p) pf\ + sigma S1\ + mutual-spec-apply-sort-param a p S S1, + body-mutual-params-ty M S1 (Rest a p pf). +body-mutual-params-ty N S Ty :- N > 0, !, + mutual-spec-arity S (prod A TA _), + M is N - 1, + Ty = prod A TA (a\ Rest a), + @pi-decl A TA a\ + sigma S1\ + mutual-spec-apply-param a S S1, + body-mutual-params-ty M S1 (Rest a). +body-mutual-params-ty _ _ _ :- stop "derive.param1_trivial: wrong mutual shape". + +func add-mutual-trivial-consts list derive.param1.trivial.mutual-spec, list derive.param1.trivial.mutual-spec, string, int, int -> list prop. +add-mutual-trivial-consts _ [] _ _ _ []. +add-mutual-trivial-consts All [S|SS] Suffix Lno Focus [Clause,param1-trivial-done (indt GRR)|CS] :- std.do! [ + S = derive.param1.trivial.mutual-spec GRR IsT _, + Name is {coq.gref->id (indt GRR)} ^ Suffix, + if (Lno > 0) + (coq.error "derive.param1_trivial: mutual triviality generation for parameterized mutual inductives still needs to be implemented" (indt GRR)) + (body-mutual-params Lno All Focus R, + std.assert-ok! (coq.typecheck R RT) "derive.param1_trivial generates illtyped mutual term", + coq.env.add-const Name R RT @transparent! Cst), + Clause = (param1-trivial-db IsT (global (const Cst))), + coq.elpi.accumulate _ "derive.param1.trivial.db" (clause _ _ Clause), + coq.elpi.accumulate _ "derive.param1.trivial.db" (clause _ _ (param1-trivial-done (indt GRR))), + Focus1 is Focus + 1, + add-mutual-trivial-consts All SS Suffix Lno Focus1 CS +]. + +func mutual-lno list inductive, inductive -> int. +mutual-lno _ FirstGRR Lno :- coq.env.indt FirstGRR _ Lno _ _ _ _, Lno > 0, !. +mutual-lno [FirstOrig|_] _ Lno :- !, coq.env.indt FirstOrig _ OrigLno _ _ _ _, Lno is 2 * OrigLno. +mutual-lno _ _ 0 :- !. + +func main-mutual list inductive, string -> list prop. +main-mutual GRS Suffix Clauses :- std.do! [ + std.map GRS mutual-spec Specs, + Specs = [First|_], + mutual-spec-ind First FirstGRR, + coq.env.indt FirstGRR _ LnoIs Luno _ _ _, + assert! (LnoIs = Luno) "derive.param1_trivial: Non-uniform parameters not supported", + mutual-lno GRS FirstGRR Lno, + add-mutual-trivial-consts Specs Specs Suffix Lno 0 Clauses +]. + func main gref, gref, string -> list prop. main _ (indt GR) Suffix [Clause,param1-trivial-done (indt GR)] :- do! [ coq.env.indt GR _ Lno _ Arity _ _, diff --git a/apps/derive/elpi/param2.elpi b/apps/derive/elpi/param2.elpi index 33cd16195..e35a6d731 100644 --- a/apps/derive/elpi/param2.elpi +++ b/apps/derive/elpi/param2.elpi @@ -319,9 +319,117 @@ store-param-indc Suffix K KR :- % toplevel predicates % %%%%%%%%%%%%%%%%%%%%%%% +func mutual-ids indt-decl -> list id. +mutual-ids (parameter ID _ Ty F) IDs :- !, + @pi-parameter ID Ty x\ mutual-ids (F x) IDs. +mutual-ids (minductive ID _ Arity Rest) [ID|IDs] :- !, + @pi-inductive ID Arity i\ mutual-ids (Rest i) IDs. +mutual-ids (mblock _) []. + +func id->indt id -> inductive. +id->indt ID GR :- coq.locate ID (indt GR). + +kind derive.param2.raw-mindt-spec type. +type derive.param2.raw-mindt-spec inductive -> id -> bool -> int -> int -> term -> list constructor -> list term -> list (pair constructor id) -> list term -> id -> derive.param2.raw-mindt-spec. + +func raw-mutual-spec string, inductive -> derive.param2.raw-mindt-spec. +raw-mutual-spec Suffix GR (derive.param2.raw-mindt-spec GR ID IsInd Lno Luno Ty KNames KTerms KNamesR KTypes FNameR) :- + coq.env.indt GR IsInd Lno Luno Ty KNames KTypes, + coq.gref->id (indt GR) ID, + NameR is ID ^ Suffix, + coq.ensure-fresh-global-id NameR FNameR, + map KNames (rename-indc Suffix) KNamesR, + std.map KNames (k\r\ coq.env.global (indc k) r) KTerms. + +func raw-mutual-spec-lno derive.param2.raw-mindt-spec -> int. +raw-mutual-spec-lno (derive.param2.raw-mindt-spec _ _ _ Lno _ _ _ _ _ _ _) Lno. + +func raw-mutual-spec-luno derive.param2.raw-mindt-spec -> int. +raw-mutual-spec-luno (derive.param2.raw-mindt-spec _ _ _ _ Luno _ _ _ _ _ _) Luno. + +func raw-mutual-assumption derive.param2.raw-mindt-spec, inductive -> prop. +raw-mutual-assumption (derive.param2.raw-mindt-spec GR _ _ _ _ _ _ _ _ _ _) NewGR + (param.gref (indt GR) (indt GR) (indt NewGR) :- !). + +func translate-mutual-spec derive.param2.raw-mindt-spec, inductive -> coq.mindt-spec. +translate-mutual-spec (derive.param2.raw-mindt-spec GR _ IsInd _ _ Ty _ KTerms KNamesR KTypes FNameR) NewGR + (coq.mindt-spec NewGR FNameR IsInd TyOut KNamesR KTypesR) :- + Ind = global (indt GR), + param Ty _ TyR, + map2 KTerms KTypes param-indc KTypesR, + coq.subst-fun [Ind,Ind] TyR TyOut. + +func dispatch-mutual-gen list derive.param2.raw-mindt-spec, list derive.param2.raw-mindt-spec, list inductive, int -> list prop. +dispatch-mutual-gen All [] Acc LnoR Clauses :- !, + rev Acc NewGRs, + dispatch-mutual-do All NewGRs LnoR Clauses. +dispatch-mutual-gen All [_|Rest] Acc LnoR Clauses :- + pi newGR\ dispatch-mutual-gen All Rest [newGR|Acc] LnoR Clauses. + +func mutual-store-indt string, derive.param2.raw-mindt-spec, inductive -> prop. +mutual-store-indt _ (derive.param2.raw-mindt-spec GR _ _ _ _ _ _ _ _ _ FNameR) RealGR P :- + P = store-param FNameR (global (indt GR)) (global (indt GR)) (global (indt RealGR)). + +func mutual-store-indcs string, list constructor, list constructor -> list prop. +mutual-store-indcs _ [] [] []. +mutual-store-indcs Suffix [K|KS] [KR|KRS] [P|Rest] :- + P = store-param-indc Suffix K KR, + mutual-store-indcs Suffix KS KRS Rest. + +func mutual-stores string, list derive.param2.raw-mindt-spec, list inductive -> list prop. +mutual-stores _ [] [] []. +mutual-stores Suffix [Raw|Raws] [RealGR|RealGRs] Stores :- + Raw = derive.param2.raw-mindt-spec _ _ _ _ _ _ KNames _ _ _ _, + coq.env.indt RealGR _ _ _ _ RealKNames _, + mutual-store-indcs Suffix KNames RealKNames StoreKs, + mutual-stores Suffix Raws RealGRs Rest, + std.append StoreKs Rest Stores. + +func mutual-clauses list derive.param2.raw-mindt-spec, list inductive -> list prop. +mutual-clauses [] [] []. +mutual-clauses [Raw|Raws] [RealGR|RealGRs] Clauses :- + Raw = derive.param2.raw-mindt-spec GR _ _ _ _ _ KNames _ _ _ _, + coq.env.indt RealGR _ _ _ _ RealKNames _, + map2 KNames RealKNames (a\b\r\ r = (param.gref (indc a) (indc a) (indc b) :- !)) CK, + This = [param-done (indt GR), (param.gref (indt GR) (indt GR) (indt RealGR) :- !)|CK], + mutual-clauses Raws RealGRs Rest, + std.append This Rest Clauses. + +func accumulate-param2-clause prop ->. +accumulate-param2-clause (param-done _ as C) :- !, + coq.elpi.accumulate _ "derive.param2.db" (clause _ _ C). +accumulate-param2-clause C :- + coq.elpi.accumulate _ "derive.param2.db" (clause _ (before "param:fail") C). + +func dispatch-mutual-do list derive.param2.raw-mindt-spec, list inductive, int -> list prop. +dispatch-mutual-do Raws NewGRs LnoR Clauses :- std.do! [ + map2 Raws NewGRs raw-mutual-assumption Assumps, + Assumps =!=> map2 Raws NewGRs translate-mutual-spec Specs, + coq.build-mindt-decl Specs LnoR LnoR DeclR, + std.assert-ok! (coq.typecheck-indt-decl DeclR) "derive.param2 generates illtyped mutual inductive", + coq.env.add-indt DeclR _, + std.map Specs (s\r\ sigma name\ s = coq.mindt-spec _ name _ _ _ _, coq.locate name (indt r)) RealGRs, + map2 Raws RealGRs (mutual-store-indt "") StoreInds, + mutual-stores "_R" Raws RealGRs StoreKs, + forall StoreInds (p\ p), + forall StoreKs (p\ p), + mutual-clauses Raws RealGRs Clauses1, + forall Clauses1 accumulate-param2-clause, + Clauses = Clauses1 +]. + :index (1) func dispatch gref, string -> list prop. +dispatch (indt GR) Suffix Clauses :- coq.env.mutual-inductives GR GRS, std.length GRS N, N > 1, !, std.do! [ + map GRS (raw-mutual-spec Suffix) Raws, + Raws = [FirstRaw|_], + raw-mutual-spec-lno FirstRaw Lno, + raw-mutual-spec-luno FirstRaw Luno, + std.assert! (Lno = Luno) "derive.param2: Non-uniform parameters not supported", + dispatch-mutual-gen Raws Raws [] 0 Clauses +]. + dispatch ((const GR) as C) Suffix Clauses :- do! [ coq.env.global C Term, NameR is {coq.gref->id C} ^ Suffix, diff --git a/apps/derive/tests/test_derive_mutual.v b/apps/derive/tests/test_derive_mutual.v new file mode 100644 index 000000000..2b2962a32 --- /dev/null +++ b/apps/derive/tests/test_derive_mutual.v @@ -0,0 +1,4870 @@ +(* This is the same derivation set exported by derive.std, kept explicit so + each standard derivation is tested independently. Each derive call below + lives in its own module and is checked against a signature documenting the + Coq definitions that derivation is expected to add. *) +From Corelib Require Import BinNums Nat ssrbool. +Definition bool_is_true := is_true. +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook_for_mutual_wrapper_test. +From elpi.apps.derive.elpi Extra Dependency "derive.elpi" as derive_core_for_mutual_wrapper_test. +From elpi.apps Require Import + derive + derive.map + derive.lens + derive.lens_laws + derive.param1 + derive.param1_congr + derive.param1_trivial + derive.param1_functor + derive.param2 + derive.induction + derive.tag + derive.fields + derive.eqb + derive.eqbcorrect + derive.eqbOK + derive.isK + derive.projK + derive.bcongr. + +Elpi Command derive_mutual_wrapper_test. +#[synterp] Elpi Accumulate lp:{{ + main _ :- coq.env.begin-module "wleft" none, coq.env.end-module _. +}}. +Elpi Accumulate File derive_hook_for_mutual_wrapper_test. +Elpi Accumulate File derive_core_for_mutual_wrapper_test. +Elpi Accumulate lp:{{ + derivation (indt _) _ ff (derive "noop" (cl\ cl = []) true). + + main _ :- + D = (parameter "A" maximal {{ Type }} a\ + (minductive "wleft" tt (arity {{ Type }}) l\ + (minductive "wright" tt (arity {{ Type }}) r\ + (mblock [ + [constructor "wleftK" (arity {{ lp:a -> lp:l }})], + [constructor "wrightK" (arity {{ lp:a -> lp:r }})] + ])))), + get-option "module" "" ==> derive.decl+main "wleft" D. +}}. + +Module WrapperMutualDeclaration. + Elpi derive_mutual_wrapper_test. + + Check wright : Type. + Check wleftK 0 : wleft. + Check wrightK true : wright. +End WrapperMutualDeclaration. + +Module Type MutualBase. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). +End MutualBase. + +Module Type MutualMapExpected. + Include MutualBase. + Definition tree_map : tree -> tree := + fun x : tree => x. + Definition forest_map : forest -> forest := + fun x : forest => x. +End MutualMapExpected. + +Module Type MutualLensExpected. + Include MutualBase. + (* tree/forest are not records, so lens derives no Coq definitions. *) +End MutualLensExpected. + +Module Type MutualLensLawsExpected. + Include MutualLensExpected. + (* No lenses means no lens-law constants. *) +End MutualLensLawsExpected. + +Module Type MutualParam1Expected. + Include MutualBase. + Universe tree_reali_u forest_reali_u. + Constraint Set < tree_reali_u. + Constraint Set < forest_reali_u. + Inductive is_tree : tree -> Type@{tree_reali_u} := + | is_node (f : forest) (Pf : is_forest f) : is_tree (node f) + with is_forest : forest -> Type@{forest_reali_u} := + | is_empty : is_forest empty + | is_cons (t : tree) (Pt : is_tree t) + (f : forest) (Pf : is_forest f) : is_forest (cons t f). + Definition reali_is_tree : param1.reali_db tree is_tree := + @param1.store_reali _ _ tree is_tree. + Definition reali_is_forest : param1.reali_db forest is_forest := + @param1.store_reali _ _ forest is_forest. + Definition reali_is_tree_node : param1.reali_db node is_node := + @param1.store_reali _ _ node is_node. + Definition reali_is_forest_empty : param1.reali_db empty is_empty := + @param1.store_reali _ _ empty is_empty. + Definition reali_is_forest_cons : param1.reali_db cons is_cons := + @param1.store_reali _ _ cons is_cons. +End MutualParam1Expected. + +Module Type MutualParam1CongrExpected. + Include MutualParam1Expected. + Definition congr_is_node : forall (x : forest) + (p1 p2 : is_forest x), + p1 = p2 -> + is_node x p1 = is_node x p2 := + fun (x : forest) (p1 p2 : is_forest x) + (e : p1 = p2) => + match + e in _ = i + return is_node x p1 = is_node x i + with + | eq_refl => eq_refl + end. + Definition congr_is_empty : is_empty = is_empty := + eq_refl. + Definition congr_is_cons : forall (x : tree) + (p1 p2 : is_tree x), + p1 = p2 -> + forall (x0 : forest) + (p3 p4 : is_forest x0), + p3 = p4 -> + is_cons x p1 x0 p3 = + is_cons x p2 x0 p4 := + fun (x : tree) (p1 p2 : is_tree x) + (e : p1 = p2) => + match + e in _ = i + return + (forall (x0 : forest) + (p3 p4 : is_forest x0), + p3 = p4 -> + is_cons x p1 x0 p3 = + is_cons x i x0 p4) + with + | eq_refl => + fun (x0 : forest) + (p3 p4 : is_forest x0) (e0 : p3 = p4) => + match + e0 in _ = i + return + is_cons x p1 x0 p3 = + is_cons x p1 x0 i + with + | eq_refl => eq_refl + end + end. +End MutualParam1CongrExpected. + +Module Type MutualParam1TrivialExpected. + Include MutualParam1CongrExpected. + Definition is_tree_inhab : forall x : tree, is_tree x := + fix is_tree_inhab_rec (x : tree) : + is_tree x := + match x as i return is_tree i with + | node f => + is_node f (is_forest_inhab_rec f) + end + with is_forest_inhab_rec (x : forest) : + is_forest x := + match x as i return is_forest i with + | empty => is_empty + | cons t f => + is_cons t (is_tree_inhab_rec t) f + (is_forest_inhab_rec f) + end + for + is_tree_inhab_rec. + Definition is_forest_inhab : forall x : forest, is_forest x := + fix is_tree_inhab_rec (x : tree) : + is_tree x := + match x as i return is_tree i with + | node f => + is_node f (is_forest_inhab_rec f) + end + with is_forest_inhab_rec (x : forest) : + is_forest x := + match x as i return is_forest i with + | empty => is_empty + | cons t f => + is_cons t (is_tree_inhab_rec t) f + (is_forest_inhab_rec f) + end + for + is_forest_inhab_rec. + Definition is_tree_trivial : forall x : tree, + {u : is_tree x & + forall v : is_tree x, u = v} := + fun x : tree => + param1.contracts tree is_tree x + (is_tree_inhab x) + ((fix is_tree_trivial_rec + (x0 : tree) (y : is_tree x0) + {struct y} : is_tree_inhab x0 = y := + match + y as i in is_tree s1 + return is_tree_inhab s1 = i + with + | is_node f Pf => + match + param1.trivial_uniq forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f Pf + in _ = H + return + is_node f + (param1.trivial_full forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f) = + is_node f H + with + | eq_refl => eq_refl + end + end + with is_forest_trivial_rec + (x0 : forest) + (y : is_forest x0) {struct y} : + is_forest_inhab x0 = y := + match + y as i in is_forest s1 + return is_forest_inhab s1 = i + with + | is_empty => eq_refl + | is_cons t Pt f Pf => + match + param1.trivial_uniq forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f Pf + in _ = H + return + is_cons t + (param1.trivial_full tree + is_tree + (fun x1 : tree => + param1.contracts tree + is_tree x1 + (is_tree_inhab x1) + (is_tree_trivial_rec x1)) + t) + f + (param1.trivial_full forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f) = + is_cons t Pt f H + with + | eq_refl => + match + param1.trivial_uniq tree + is_tree + (fun x1 : tree => + param1.contracts tree + is_tree x1 + (is_tree_inhab x1) + (is_tree_trivial_rec x1)) + t Pt + in _ = H + return + is_cons t + (param1.trivial_full tree + is_tree + (fun x1 : tree => + param1.contracts tree + is_tree x1 + (is_tree_inhab x1) + (is_tree_trivial_rec x1)) + t) + f + (param1.trivial_full forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f) = + is_cons t H f + (param1.trivial_full forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f) + with + | eq_refl => eq_refl + end + end + end + for + is_tree_trivial_rec) x). + Definition is_forest_trivial : forall x : forest, + {u : is_forest x & + forall v : is_forest x, u = v} := + fun x : forest => + param1.contracts forest is_forest x + (is_forest_inhab x) + ((fix is_tree_trivial_rec + (x0 : tree) (y : is_tree x0) + {struct y} : is_tree_inhab x0 = y := + match + y as i in is_tree s1 + return is_tree_inhab s1 = i + with + | is_node f Pf => + match + param1.trivial_uniq forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f Pf + in _ = H + return + is_node f + (param1.trivial_full forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f) = + is_node f H + with + | eq_refl => eq_refl + end + end + with is_forest_trivial_rec + (x0 : forest) + (y : is_forest x0) {struct y} : + is_forest_inhab x0 = y := + match + y as i in is_forest s1 + return is_forest_inhab s1 = i + with + | is_empty => eq_refl + | is_cons t Pt f Pf => + match + param1.trivial_uniq forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f Pf + in _ = H + return + is_cons t + (param1.trivial_full tree + is_tree + (fun x1 : tree => + param1.contracts tree + is_tree x1 + (is_tree_inhab x1) + (is_tree_trivial_rec x1)) + t) + f + (param1.trivial_full forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f) = + is_cons t Pt f H + with + | eq_refl => + match + param1.trivial_uniq tree + is_tree + (fun x1 : tree => + param1.contracts tree + is_tree x1 + (is_tree_inhab x1) + (is_tree_trivial_rec x1)) + t Pt + in _ = H + return + is_cons t + (param1.trivial_full tree + is_tree + (fun x1 : tree => + param1.contracts tree + is_tree x1 + (is_tree_inhab x1) + (is_tree_trivial_rec x1)) + t) + f + (param1.trivial_full forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f) = + is_cons t H f + (param1.trivial_full forest + is_forest + (fun x1 : forest => + param1.contracts forest + is_forest x1 + (is_forest_inhab x1) + (is_forest_trivial_rec x1)) + f) + with + | eq_refl => eq_refl + end + end + end + for + is_forest_trivial_rec) x). +End MutualParam1TrivialExpected. + +Module Type MutualParam1FunctorExpected. + Include MutualParam1Expected. + Definition is_tree_functor : forall x : tree, + is_tree x -> is_tree x := + fix is_tree_functor_rec + (x : tree) (x0 : is_tree x) {struct + x0} : is_tree x := + match + x0 in is_tree s1 + return is_tree s1 + with + | is_node f Pf => is_node f Pf + end + with is_forest_functor_rec + (x : forest) (x0 : is_forest x) + {struct x0} : is_forest x := + match + x0 in is_forest s1 + return is_forest s1 + with + | is_empty => is_empty + | is_cons t Pt f Pf => + is_cons t Pt f Pf + end + for + is_tree_functor_rec. + Definition is_forest_functor : forall x : forest, + is_forest x -> is_forest x := + fix is_tree_functor_rec + (x : tree) (x0 : is_tree x) {struct + x0} : is_tree x := + match + x0 in is_tree s1 + return is_tree s1 + with + | is_node f Pf => is_node f Pf + end + with is_forest_functor_rec + (x : forest) (x0 : is_forest x) + {struct x0} : is_forest x := + match + x0 in is_forest s1 + return is_forest s1 + with + | is_empty => is_empty + | is_cons t Pt f Pf => + is_cons t Pt f Pf + end + for + is_forest_functor_rec. +End MutualParam1FunctorExpected. + +Module Type MutualParam2Expected. + Include MutualBase. + Inductive tree_R : tree -> tree -> Set := + | node_R (f1 f2 : forest) (fR : forest_R f1 f2) : + tree_R (node f1) (node f2) + with forest_R : forest -> forest -> Set := + | empty_R : forest_R empty empty + | cons_R (t1 t2 : tree) (tR : tree_R t1 t2) + (f1 f2 : forest) (fR : forest_R f1 f2) : + forest_R (cons t1 f1) (cons t2 f2). + Definition param_tree_R : param2.param_db tree tree + tree_R := + @param2.store_param _ _ _ tree tree tree_R. + Definition param_forest_R : param2.param_db forest forest + forest_R := + @param2.store_param _ _ _ forest forest forest_R. + Definition param_node_R : param2.param_db node node + node_R := + @param2.store_param _ _ _ node node node_R. + Definition param_empty_R : param2.param_db empty empty + empty_R := + @param2.store_param _ _ _ empty empty empty_R. + Definition param_cons_R : param2.param_db cons cons + cons_R := + @param2.store_param _ _ _ cons cons cons_R. +End MutualParam2Expected. + +Module Type MutualInductionExpected. + Include MutualParam1FunctorExpected. + Definition tree_induction : forall (P : tree -> Type) + (P0 : forest -> Type), + (forall f : forest, + is_forest f -> P0 f -> P (node f)) -> + P0 empty -> + (forall t : tree, + is_tree t -> + P t -> + forall f : forest, + is_forest f -> P0 f -> P0 (cons t f)) -> + forall s1 : tree, is_tree s1 -> P s1 := + fun (P : tree -> Type) (P0 : forest -> Type) + (His_node : forall f : forest, + is_forest f -> + P0 f -> P (node f)) + (His_empty : P0 empty) + (His_cons : forall t : tree, + is_tree t -> + P t -> + forall f : forest, + is_forest f -> + P0 f -> P0 (cons t f)) => + fix is_tree_induction_rec + (s1 : tree) (H : is_tree s1) {struct H} : + P s1 := + match H in is_tree s2 return P s2 with + | is_node f Pf => + His_node f Pf (is_forest_induction_rec f Pf) + end + with is_forest_induction_rec + (s1 : forest) (H : is_forest s1) {struct H} : + P0 s1 := + match H in is_forest s2 return P0 s2 with + | is_empty => His_empty + | is_cons t Pt f Pf => + His_cons t Pt (is_tree_induction_rec t Pt) f Pf + (is_forest_induction_rec f Pf) + end + for + is_tree_induction_rec. +End MutualInductionExpected. + +Module Type MutualTagExpected. + Include MutualBase. + Definition tree_tag : tree -> BinNums.positive := + fun i : tree => match i with + | node _ => BinNums.xH + end. + Definition forest_tag : forest -> BinNums.positive := + fun i : forest => + match i with + | empty => BinNums.xH + | cons _ _ => BinNums.xO BinNums.xH + end. +End MutualTagExpected. + +Module Type MutualFieldsExpected. + Include MutualTagExpected. + Universe box_tree_node_u box_forest_empty_u box_forest_cons_u. + Constraint Set < box_tree_node_u. + Constraint Set < box_forest_empty_u. + Constraint Set < box_forest_cons_u. + Record box_tree_node : Type@{box_tree_node_u} := Box_tree_node { Box_tree_node_0 : forest }. + Record box_forest_empty : Type@{box_forest_empty_u} := Box_forest_empty {}. + Record box_forest_cons : Type@{box_forest_cons_u} := Box_forest_cons { + Box_forest_cons_0 : tree; + Box_forest_cons_1 : forest; + }. + Definition tree_fields_t : BinNums.positive -> Type := + fun _ : BinNums.positive => box_tree_node. + Definition tree_fields : forall i : tree, + tree_fields_t (tree_tag i) := + fun i : tree => + match + i as i0 return tree_fields_t (tree_tag i0) + with + | node f => {| Box_tree_node_0 := f |} + end. + Definition tree_construct : BinNums.positive -> + box_tree_node -> option tree := + fun (_ : BinNums.positive) (b : box_tree_node) => + match b with + | {| Box_tree_node_0 := Box_tree_node_0 |} => + Some (node Box_tree_node_0) + end. + Parameter tree_constructP : forall i : tree, + tree_construct (tree_tag i) + (tree_fields i) = + Some i. + Definition forest_fields_t : BinNums.positive -> Type := + fun p : BinNums.positive => + match p with + | BinNums.xI _ => unit + | BinNums.xO _ => box_forest_cons + | BinNums.xH => box_forest_empty + end. + Definition forest_fields : forall i : forest, + forest_fields_t (forest_tag i) := + fun i : forest => + match + i as i0 return forest_fields_t (forest_tag i0) + with + | empty => Box_forest_empty + | cons t f => + {| + Box_forest_cons_0 := t; + Box_forest_cons_1 := f + |} + end. + Definition forest_construct : forall p : BinNums.positive, + forest_fields_t p -> option forest := + fun p : BinNums.positive => + match + p as i return forest_fields_t i -> option forest + with + | BinNums.xI _ => fun _ : unit => None + | BinNums.xO _ => + fun b : box_forest_cons => + match b with + | {| + Box_forest_cons_0 := Box_forest_cons_0; + Box_forest_cons_1 := Box_forest_cons_1 + |} => Some (cons Box_forest_cons_0 Box_forest_cons_1) + end + | BinNums.xH => + fun _ : box_forest_empty => Some empty + end. + Parameter forest_constructP : forall i : forest, + forest_construct (forest_tag i) + (forest_fields i) = + Some i. +End MutualFieldsExpected. + +Module Type MutualEqbExpected. + Include MutualFieldsExpected. + Definition tree_eqb : tree -> tree -> bool := + fix tree (x1 x2 : tree) {struct x1} : bool := + match x1 with + | node f => + eqb_core_defs.eqb_body (tagB:=tree_tag) + (fields_tA:=fun _ : BinNums.positive => box_tree_node) + (fields_tB:=tree_fields_t) tree_fields + (fun (_ : BinNums.positive) (a b : box_tree_node) => + match a with + | {| Box_tree_node_0 := Box_tree_node_0 |} => + match b with + | {| Box_tree_node_0 := Box_tree_node_1 |} => + (forest Box_tree_node_0 Box_tree_node_1 && true)%bool + end + end) + (t1:=tree_tag (node f)) + {| Box_tree_node_0 := f |} x2 + end + with forest (x1 x2 : forest) {struct x1} : bool := + match x1 with + | empty => + eqb_core_defs.eqb_body (tagB:=forest_tag) + (fields_tA:=forest_fields_t) + (fields_tB:=forest_fields_t) forest_fields + (fun x : BinNums.positive => + match + x as i + return + forest_fields_t i -> + forest_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_forest_cons => + match a with + | {| + Box_forest_cons_0 := Box_forest_cons_0; + Box_forest_cons_1 := Box_forest_cons_1 + |} => + match b with + | {| + Box_forest_cons_0 := Box_forest_cons_2; + Box_forest_cons_1 := Box_forest_cons_3 + |} => + (tree Box_forest_cons_0 Box_forest_cons_2 && + (forest Box_forest_cons_1 Box_forest_cons_3 && true))%bool + end + end + | BinNums.xH => fun _ _ : box_forest_empty => true + end) + (t1:=forest_tag empty) Box_forest_empty + x2 + | cons t f => + eqb_core_defs.eqb_body (tagB:=forest_tag) + (fields_tA:=forest_fields_t) + (fields_tB:=forest_fields_t) forest_fields + (fun x : BinNums.positive => + match + x as i + return + forest_fields_t i -> + forest_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_forest_cons => + match a with + | {| + Box_forest_cons_0 := Box_forest_cons_0; + Box_forest_cons_1 := Box_forest_cons_1 + |} => + match b with + | {| + Box_forest_cons_0 := Box_forest_cons_2; + Box_forest_cons_1 := Box_forest_cons_3 + |} => + (tree Box_forest_cons_0 Box_forest_cons_2 && + (forest Box_forest_cons_1 Box_forest_cons_3 && true))%bool + end + end + | BinNums.xH => fun _ _ : box_forest_empty => true + end) + (t1:=forest_tag (cons t f)) + {| + Box_forest_cons_0 := t; Box_forest_cons_1 := f + |} x2 + end + for + tree. + Definition forest_eqb : forest -> forest -> bool := + fix tree (x1 x2 : tree) {struct x1} : bool := + match x1 with + | node f => + eqb_core_defs.eqb_body (tagB:=tree_tag) + (fields_tA:=fun _ : BinNums.positive => box_tree_node) + (fields_tB:=tree_fields_t) tree_fields + (fun (_ : BinNums.positive) (a b : box_tree_node) => + match a with + | {| Box_tree_node_0 := Box_tree_node_0 |} => + match b with + | {| Box_tree_node_0 := Box_tree_node_1 |} => + (forest Box_tree_node_0 Box_tree_node_1 && true)%bool + end + end) + (t1:=tree_tag (node f)) + {| Box_tree_node_0 := f |} x2 + end + with forest (x1 x2 : forest) {struct x1} : bool := + match x1 with + | empty => + eqb_core_defs.eqb_body (tagB:=forest_tag) + (fields_tA:=forest_fields_t) + (fields_tB:=forest_fields_t) forest_fields + (fun x : BinNums.positive => + match + x as i + return + forest_fields_t i -> + forest_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_forest_cons => + match a with + | {| + Box_forest_cons_0 := Box_forest_cons_0; + Box_forest_cons_1 := Box_forest_cons_1 + |} => + match b with + | {| + Box_forest_cons_0 := Box_forest_cons_2; + Box_forest_cons_1 := Box_forest_cons_3 + |} => + (tree Box_forest_cons_0 Box_forest_cons_2 && + (forest Box_forest_cons_1 Box_forest_cons_3 && true))%bool + end + end + | BinNums.xH => fun _ _ : box_forest_empty => true + end) + (t1:=forest_tag empty) Box_forest_empty + x2 + | cons t f => + eqb_core_defs.eqb_body (tagB:=forest_tag) + (fields_tA:=forest_fields_t) + (fields_tB:=forest_fields_t) forest_fields + (fun x : BinNums.positive => + match + x as i + return + forest_fields_t i -> + forest_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_forest_cons => + match a with + | {| + Box_forest_cons_0 := Box_forest_cons_0; + Box_forest_cons_1 := Box_forest_cons_1 + |} => + match b with + | {| + Box_forest_cons_0 := Box_forest_cons_2; + Box_forest_cons_1 := Box_forest_cons_3 + |} => + (tree Box_forest_cons_0 Box_forest_cons_2 && + (forest Box_forest_cons_1 Box_forest_cons_3 && true))%bool + end + end + | BinNums.xH => fun _ _ : box_forest_empty => true + end) + (t1:=forest_tag (cons t f)) + {| + Box_forest_cons_0 := t; Box_forest_cons_1 := f + |} x2 + end + for + forest. + Definition tree_eqb_fields : (tree -> tree -> bool) -> + BinNums.positive -> + box_tree_node -> box_tree_node -> bool := + fun (_ : tree -> tree -> bool) + (_ : BinNums.positive) (a b : box_tree_node) => + match a with + | {| Box_tree_node_0 := Box_tree_node_0 |} => + match b with + | {| Box_tree_node_0 := Box_tree_node_1 |} => + (forest_eqb Box_tree_node_0 Box_tree_node_1 && true)%bool + end + end. + Definition forest_eqb_fields : (forest -> forest -> bool) -> + forall x : BinNums.positive, + forest_fields_t x -> forest_fields_t x -> bool := + fun (rec : forest -> forest -> bool) + (x : BinNums.positive) => + match + x as i + return forest_fields_t i -> forest_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_forest_cons => + match a with + | {| + Box_forest_cons_0 := Box_forest_cons_0; + Box_forest_cons_1 := Box_forest_cons_1 + |} => + match b with + | {| + Box_forest_cons_0 := Box_forest_cons_2; + Box_forest_cons_1 := Box_forest_cons_3 + |} => + (tree_eqb Box_forest_cons_0 Box_forest_cons_2 && + (rec Box_forest_cons_1 Box_forest_cons_3 && true))%bool + end + end + | BinNums.xH => fun _ _ : box_forest_empty => true + end. +End MutualEqbExpected. + +Module Type MutualEqbCorrectExpected. + Include MutualEqbExpected. + Universe tree_reali_u forest_reali_u. + Constraint Set < tree_reali_u. + Constraint Set < forest_reali_u. + Inductive is_tree : tree -> Type@{tree_reali_u} := + | is_node (f : forest) (Pf : is_forest f) : is_tree (node f) + with is_forest : forest -> Type@{forest_reali_u} := + | is_empty : is_forest empty + | is_cons (t : tree) (Pt : is_tree t) + (f : forest) (Pf : is_forest f) : is_forest (cons t f). + Definition is_tree_inhab : forall x : tree, is_tree x := + fix is_tree_inhab_rec (x : tree) : + is_tree x := + match x as i return is_tree i with + | node f => + is_node f (is_forest_inhab_rec f) + end + with is_forest_inhab_rec (x : forest) : + is_forest x := + match x as i return is_forest i with + | empty => is_empty + | cons t f => + is_cons t (is_tree_inhab_rec t) f + (is_forest_inhab_rec f) + end + for + is_tree_inhab_rec. + Definition is_forest_inhab : forall x : forest, is_forest x := + fix is_tree_inhab_rec (x : tree) : + is_tree x := + match x as i return is_tree i with + | node f => + is_node f (is_forest_inhab_rec f) + end + with is_forest_inhab_rec (x : forest) : + is_forest x := + match x as i return is_forest i with + | empty => is_empty + | cons t f => + is_cons t (is_tree_inhab_rec t) f + (is_forest_inhab_rec f) + end + for + is_forest_inhab_rec. + Definition tree_induction : forall (P : tree -> Type) + (P0 : forest -> Type), + (forall f : forest, + is_forest f -> P0 f -> P (node f)) -> + P0 empty -> + (forall t : tree, + is_tree t -> + P t -> + forall f : forest, + is_forest f -> + P0 f -> P0 (cons t f)) -> + forall s1 : tree, is_tree s1 -> P s1 := + fun (P : tree -> Type) + (P0 : forest -> Type) + (His_node : forall f : forest, + is_forest f -> + P0 f -> P (node f)) + (His_empty : P0 empty) + (His_cons : forall t : tree, + is_tree t -> + P t -> + forall f : forest, + is_forest f -> + P0 f -> P0 (cons t f)) => + fix is_tree_induction_rec + (s1 : tree) (H : is_tree s1) {struct H} : + P s1 := + match H in is_tree s2 return P s2 with + | is_node f Pf => + His_node f Pf (is_forest_induction_rec f Pf) + end + with is_forest_induction_rec + (s1 : forest) (H : is_forest s1) {struct + H} : P0 s1 := + match H in is_forest s2 return P0 s2 with + | is_empty => His_empty + | is_cons t Pt f Pf => + His_cons t Pt (is_tree_induction_rec t Pt) f Pf + (is_forest_induction_rec f Pf) + end + for + is_tree_induction_rec. + Definition forest_induction : forall (P : tree -> Type) + (P0 : forest -> Type), + (forall f : forest, + is_forest f -> P0 f -> P (node f)) -> + P0 empty -> + (forall t : tree, + is_tree t -> + P t -> + forall f : forest, + is_forest f -> + P0 f -> P0 (cons t f)) -> + forall s1 : forest, + is_forest s1 -> P0 s1 := + fun (P : tree -> Type) + (P0 : forest -> Type) + (His_node : forall f : forest, + is_forest f -> + P0 f -> P (node f)) + (His_empty : P0 empty) + (His_cons : forall t : tree, + is_tree t -> + P t -> + forall f : forest, + is_forest f -> + P0 f -> P0 (cons t f)) => + fix is_tree_induction_rec + (s1 : tree) (H : is_tree s1) {struct H} : + P s1 := + match H in is_tree s2 return P s2 with + | is_node f Pf => + His_node f Pf (is_forest_induction_rec f Pf) + end + with is_forest_induction_rec + (s1 : forest) (H : is_forest s1) {struct + H} : P0 s1 := + match H in is_forest s2 return P0 s2 with + | is_empty => His_empty + | is_cons t Pt f Pf => + His_cons t Pt (is_tree_induction_rec t Pt) f Pf + (is_forest_induction_rec f Pf) + end + for + is_forest_induction_rec. + Parameter tree_eqb_correct : forall x : tree, @eqb_correct_on tree tree_eqb x. + Parameter forest_eqb_correct : forall x : forest, @eqb_correct_on forest forest_eqb x. + Parameter tree_eqb_refl : forall x : tree, @eqb_refl_on tree tree_eqb x. + Parameter forest_eqb_refl : forall x : forest, @eqb_refl_on forest forest_eqb x. +End MutualEqbCorrectExpected. + +Module Type MutualEqbOKExpected. + Include MutualEqbCorrectExpected. + Parameter tree_eqb_OK : forall x1 x2 : tree, reflect (@eq tree x1 x2) (tree_eqb x1 x2). + Parameter forest_eqb_OK : forall x1 x2 : forest, reflect (@eq forest x1 x2) (forest_eqb x1 x2). + Parameter tree_eqb_OK_sumbool : forall x y : tree, sumbool (@eq tree x y) (not (@eq tree x y)). + Parameter forest_eqb_OK_sumbool : forall x y : forest, sumbool (@eq forest x y) (not (@eq forest x y)). +End MutualEqbOKExpected. + +Module Type MutualIsKExpected. + Include MutualBase. + Definition tree_isk_node : tree -> bool := + fun i : tree => match i with + | node _ => true + end. + Definition forest_isk_empty : forest -> bool := + fun i : forest => + match i with + | empty => true + | cons _ _ => false + end. + Definition forest_isk_cons : forest -> bool := + fun i : forest => + match i with + | empty => false + | cons _ _ => true + end. +End MutualIsKExpected. + +Module Type MutualProjKExpected. + Include MutualBase. + Definition tree_getk_node1 : forest -> tree -> forest := + fun (_ : forest) (i : tree) => + match i with + | node f0 => f0 + end. + Definition forest_getk_cons1 : tree -> + forest -> forest -> tree := + fun (t : tree) (_ i : forest) => + match i with + | empty => t + | cons t0 _ => t0 + end. + Definition forest_getk_cons2 : tree -> + forest -> forest -> forest := + fun (_ : tree) (f i : forest) => + match i with + | empty => f + | cons _ f0 => f0 + end. +End MutualProjKExpected. + +Module Type MutualBcongrExpected. + Include MutualProjKExpected. + Parameter tree_bcongr_node : forall (x y : forest) (b : bool), + reflect (x = y) b -> + reflect (node x = node y) b. + Parameter forest_bcongr_empty : reflect (empty = empty) true. + Parameter forest_bcongr_cons : forall (x y : tree) (b : bool), + reflect (x = y) b -> + forall (x0 y0 : forest) (b0 : bool), + reflect (x0 = y0) b0 -> + reflect (cons x x0 = cons y y0) (b && b0). +End MutualBcongrExpected. + +Module Type ParametrizedMutualBase. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). +End ParametrizedMutualBase. + +Module Type ParametrizedMutualMapExpected. + Include ParametrizedMutualBase. + Definition ptree_map : forall A1 A2 : Type, + (A1 -> A2) -> + ptree A1 -> ptree A2 := + fun (A1 A2 : Type) (Af : A1 -> A2) => + fix ptree_map_rec (x : ptree A1) : + ptree A2 := + match x with + | pnode _ x0 f => + pnode A2 (Af x0) (pforest_map_rec f) + end + with pforest_map_rec (x : pforest A1) : + pforest A2 := + match x with + | pempty _ => pempty A2 + | pcons _ t f => + pcons A2 (ptree_map_rec t) (pforest_map_rec f) + end + for + ptree_map_rec. + Definition pforest_map : forall A1 A2 : Type, + (A1 -> A2) -> + pforest A1 -> pforest A2 := + fun (A1 A2 : Type) (Af : A1 -> A2) => + fix ptree_map_rec (x : ptree A1) : + ptree A2 := + match x with + | pnode _ x0 f => + pnode A2 (Af x0) (pforest_map_rec f) + end + with pforest_map_rec (x : pforest A1) : + pforest A2 := + match x with + | pempty _ => pempty A2 + | pcons _ t f => + pcons A2 (ptree_map_rec t) (pforest_map_rec f) + end + for + pforest_map_rec. +End ParametrizedMutualMapExpected. + +Module Type ParametrizedMutualLensExpected. + Include ParametrizedMutualBase. + (* ptree/pforest are not records, so lens derives no Coq definitions. *) +End ParametrizedMutualLensExpected. + +Module Type ParametrizedMutualLensLawsExpected. + Include ParametrizedMutualLensExpected. + (* No lenses means no lens-law constants. *) +End ParametrizedMutualLensLawsExpected. + +Module Type ParametrizedMutualParam1Expected. + Include ParametrizedMutualBase. + Universe is_ptree_u0 is_ptree_u1 is_ptree_u2 is_ptree_u3 is_ptree_u4 is_ptree_u5 is_ptree_u6. + Inductive is_ptree : forall A : Type, (A -> Type@{is_ptree_u0}) -> ptree A -> Type@{is_ptree_u1} := + | is_pnode : forall A (PA : A -> Type@{is_ptree_u2}) (x : A), PA x -> + forall f : pforest A, is_pforest A PA f -> is_ptree A PA (@pnode A x f) + with is_pforest : forall A : Type, (A -> Type@{is_ptree_u3}) -> pforest A -> Type@{is_ptree_u4} := + | is_pempty : forall A (PA : A -> Type@{is_ptree_u5}), is_pforest A PA (@pempty A) + | is_pcons : forall A (PA : A -> Type@{is_ptree_u6}) (t : ptree A), is_ptree A PA t -> + forall f : pforest A, is_pforest A PA f -> + is_pforest A PA (@pcons A t f). + Definition reali_is_ptree : param1.reali_db ptree + is_ptree := + @param1.store_reali _ _ ptree is_ptree. + Definition reali_is_pforest : param1.reali_db pforest + is_pforest := + @param1.store_reali _ _ pforest is_pforest. + Definition reali_is_ptree_pnode : param1.reali_db pnode + is_pnode := + @param1.store_reali _ _ pnode is_pnode. + Definition reali_is_pforest_pempty : param1.reali_db pempty + is_pempty := + @param1.store_reali _ _ pempty is_pempty. + Definition reali_is_pforest_pcons : param1.reali_db pcons + is_pcons := + @param1.store_reali _ _ pcons is_pcons. +End ParametrizedMutualParam1Expected. + +Module Type ParametrizedMutualParam1CongrExpected. + Include ParametrizedMutualParam1Expected. + Definition congr_is_pnode : forall (x : Type) (p : x -> Type) (x0 : x) (p1 p2 : p x0), + p1 = p2 -> + forall (x1 : pforest x) + (p3 p4 : is_pforest x p x1), + p3 = p4 -> + is_pnode x p x0 p1 x1 p3 = + is_pnode x p x0 p2 x1 p4 := + fun (x : Type) (p : x -> Type) (x0 : x) (p1 p2 : p x0) (e : p1 = p2) => + match + e in _ = i + return + (forall (x1 : pforest x) + (p3 p4 : is_pforest x p x1), + p3 = p4 -> + is_pnode x p x0 p1 x1 p3 = + is_pnode x p x0 i x1 p4) + with + | eq_refl => + fun (x1 : pforest x) + (p3 p4 : is_pforest x p x1) + (e0 : p3 = p4) => + match + e0 in _ = i + return + is_pnode x p x0 p1 x1 p3 = + is_pnode x p x0 p1 x1 i + with + | eq_refl => eq_refl + end + end. + Definition congr_is_pempty : forall (x : Type) (p : x -> Type), + is_pempty x p = + is_pempty x p := + fun (x : Type) (p : x -> Type) => eq_refl. + Definition congr_is_pcons : forall (x : Type) (p : x -> Type) + (x0 : ptree x) + (p1 p2 : is_ptree x p x0), + p1 = p2 -> + forall (x1 : pforest x) + (p3 p4 : is_pforest x p x1), + p3 = p4 -> + is_pcons x p x0 p1 x1 p3 = + is_pcons x p x0 p2 x1 p4 := + fun (x : Type) (p : x -> Type) (x0 : ptree x) + (p1 p2 : is_ptree x p x0) + (e : p1 = p2) => + match + e in _ = i + return + (forall (x1 : pforest x) + (p3 p4 : is_pforest x p x1), + p3 = p4 -> + is_pcons x p x0 p1 x1 p3 = + is_pcons x p x0 i x1 p4) + with + | eq_refl => + fun (x1 : pforest x) + (p3 p4 : is_pforest x p x1) + (e0 : p3 = p4) => + match + e0 in _ = i + return + is_pcons x p x0 p1 x1 p3 = + is_pcons x p x0 p1 x1 i + with + | eq_refl => eq_refl + end + end. +End ParametrizedMutualParam1CongrExpected. + +Module Type ParametrizedMutualParam1FunctorExpected. + Include ParametrizedMutualParam1Expected. + Definition is_ptree_functor : forall (A : Type) (PA PB : A -> Type), + (forall x : A, PA x -> PB x) -> + forall x : ptree A, is_ptree A PA x -> is_ptree A PB x := + fun (A : Type) (PA PB : A -> Type) (f : forall x : A, PA x -> PB x) + (x : ptree A) (H : is_ptree A PA x) => + (fix is_ptree_functor_rec (A0 : Type) (PA0 : A0 -> Type) + (x : ptree A0) (Hx : is_ptree A0 PA0 x) {struct Hx} : + forall PB0 : A0 -> Type, + (forall x : A0, PA0 x -> PB0 x) -> is_ptree A0 PB0 x := + match Hx in is_ptree A1 PA1 x0 return + forall PB1 : A1 -> Type, + (forall x : A1, PA1 x -> PB1 x) -> is_ptree A1 PB1 x0 with + | is_pnode A1 PA1 x0 Px p Pf => + fun PB1 f1 => is_pnode A1 PB1 x0 (f1 x0 Px) p + (is_pforest_functor_rec A1 PA1 p Pf PB1 f1) + end + with is_pforest_functor_rec (A0 : Type) (PA0 : A0 -> Type) + (x : pforest A0) (Hx : is_pforest A0 PA0 x) {struct Hx} : + forall PB0 : A0 -> Type, + (forall x : A0, PA0 x -> PB0 x) -> is_pforest A0 PB0 x := + match Hx in is_pforest A1 PA1 x0 return + forall PB1 : A1 -> Type, + (forall x : A1, PA1 x -> PB1 x) -> is_pforest A1 PB1 x0 with + | is_pempty A1 PA1 => fun PB1 _ => is_pempty A1 PB1 + | is_pcons A1 PA1 t Pt p Pf => + fun PB1 f1 => is_pcons A1 PB1 t + (is_ptree_functor_rec A1 PA1 t Pt PB1 f1) p + (is_pforest_functor_rec A1 PA1 p Pf PB1 f1) + end + for is_ptree_functor_rec) A PA x H PB f. + Definition is_pforest_functor : forall (A : Type) (PA PB : A -> Type), + (forall x : A, PA x -> PB x) -> + forall x : pforest A, is_pforest A PA x -> is_pforest A PB x := + fun (A : Type) (PA PB : A -> Type) (f : forall x : A, PA x -> PB x) + (x : pforest A) (H : is_pforest A PA x) => + (fix is_ptree_functor_rec (A0 : Type) (PA0 : A0 -> Type) + (x : ptree A0) (Hx : is_ptree A0 PA0 x) {struct Hx} : + forall PB0 : A0 -> Type, + (forall x : A0, PA0 x -> PB0 x) -> is_ptree A0 PB0 x := + match Hx in is_ptree A1 PA1 x0 return + forall PB1 : A1 -> Type, + (forall x : A1, PA1 x -> PB1 x) -> is_ptree A1 PB1 x0 with + | is_pnode A1 PA1 x0 Px p Pf => + fun PB1 f1 => is_pnode A1 PB1 x0 (f1 x0 Px) p + (is_pforest_functor_rec A1 PA1 p Pf PB1 f1) + end + with is_pforest_functor_rec (A0 : Type) (PA0 : A0 -> Type) + (x : pforest A0) (Hx : is_pforest A0 PA0 x) {struct Hx} : + forall PB0 : A0 -> Type, + (forall x : A0, PA0 x -> PB0 x) -> is_pforest A0 PB0 x := + match Hx in is_pforest A1 PA1 x0 return + forall PB1 : A1 -> Type, + (forall x : A1, PA1 x -> PB1 x) -> is_pforest A1 PB1 x0 with + | is_pempty A1 PA1 => fun PB1 _ => is_pempty A1 PB1 + | is_pcons A1 PA1 t Pt p Pf => + fun PB1 f1 => is_pcons A1 PB1 t + (is_ptree_functor_rec A1 PA1 t Pt PB1 f1) p + (is_pforest_functor_rec A1 PA1 p Pf PB1 f1) + end + for is_pforest_functor_rec) A PA x H PB f. +End ParametrizedMutualParam1FunctorExpected. + +Module Type ParametrizedMutualParam1TrivialExpected. + Include ParametrizedMutualParam1CongrExpected. + Definition is_ptree_inhab : forall (A : Type) (PA : A -> Type), + param1.trivial A PA -> forall x : ptree A, is_ptree A PA x := + fun (A : Type) (PA : A -> Type) (HPA : param1.trivial A PA) + (x : ptree A) => + (fix is_ptree_inhab_rec (A0 : Type) (x : ptree A0) {struct x} : + forall PA0 : A0 -> Type, param1.trivial A0 PA0 -> is_ptree A0 PA0 x := + match x return forall PA1 : A0 -> Type, + param1.trivial A0 PA1 -> is_ptree A0 PA1 x with + | pnode _ x0 f => fun PA1 HPA1 => + is_pnode A0 PA1 x0 (param1.trivial_full A0 PA1 HPA1 x0) f + (is_pforest_inhab_rec A0 f PA1 HPA1) + end + with is_pforest_inhab_rec (A0 : Type) (x : pforest A0) {struct x} : + forall PA0 : A0 -> Type, param1.trivial A0 PA0 -> is_pforest A0 PA0 x := + match x return forall PA1 : A0 -> Type, + param1.trivial A0 PA1 -> is_pforest A0 PA1 x with + | pempty _ => fun PA1 _ => is_pempty A0 PA1 + | pcons _ t f => fun PA1 HPA1 => + is_pcons A0 PA1 t (is_ptree_inhab_rec A0 t PA1 HPA1) f + (is_pforest_inhab_rec A0 f PA1 HPA1) + end + for is_ptree_inhab_rec) A x PA HPA. + Definition is_pforest_inhab : forall (A : Type) (PA : A -> Type), + param1.trivial A PA -> forall x : pforest A, is_pforest A PA x := + fun (A : Type) (PA : A -> Type) (HPA : param1.trivial A PA) + (x : pforest A) => + (fix is_ptree_inhab_rec (A0 : Type) (x : ptree A0) {struct x} : + forall PA0 : A0 -> Type, param1.trivial A0 PA0 -> is_ptree A0 PA0 x := + match x return forall PA1 : A0 -> Type, + param1.trivial A0 PA1 -> is_ptree A0 PA1 x with + | pnode _ x0 f => fun PA1 HPA1 => + is_pnode A0 PA1 x0 (param1.trivial_full A0 PA1 HPA1 x0) f + (is_pforest_inhab_rec A0 f PA1 HPA1) + end + with is_pforest_inhab_rec (A0 : Type) (x : pforest A0) {struct x} : + forall PA0 : A0 -> Type, param1.trivial A0 PA0 -> is_pforest A0 PA0 x := + match x return forall PA1 : A0 -> Type, + param1.trivial A0 PA1 -> is_pforest A0 PA1 x with + | pempty _ => fun PA1 _ => is_pempty A0 PA1 + | pcons _ t f => fun PA1 HPA1 => + is_pcons A0 PA1 t (is_ptree_inhab_rec A0 t PA1 HPA1) f + (is_pforest_inhab_rec A0 f PA1 HPA1) + end + for is_pforest_inhab_rec) A x PA HPA. + Definition is_ptree_trivial : forall (A : Type) (PA : A -> Type), + param1.trivial A PA -> + forall x : ptree A, + {u : is_ptree A PA x & forall v : is_ptree A PA x, u = v} := + fun (A : Type) (PA : A -> Type) (HPA : param1.trivial A PA) (x : ptree A) => + param1.contracts (ptree A) (is_ptree A PA) x (is_ptree_inhab A PA HPA x) + ((fix is_ptree_trivial_rec (A0 : Type) (PA0 : A0 -> Type) + (HPA0 : param1.trivial A0 PA0) (x0 : ptree A0) + (y : is_ptree A0 PA0 x0) {struct y} : + is_ptree_inhab A0 PA0 HPA0 x0 = y := + match y in is_ptree A1 PA1 x1 return + forall HPA1 : param1.trivial A1 PA1, + is_ptree_inhab A1 PA1 HPA1 x1 = y with + | is_pnode A1 PA1 x1 Px f Pf => + fun HPA1 => + match param1.trivial_uniq A1 PA1 HPA1 x1 Px in _ = Px' return + is_pnode A1 PA1 x1 (param1.trivial_full A1 PA1 HPA1 x1) f + (is_pforest_inhab A1 PA1 HPA1 f) = + is_pnode A1 PA1 x1 Px' f Pf with + | eq_refl => + match is_pforest_trivial_rec A1 PA1 HPA1 f Pf in _ = Pf' return + is_pnode A1 PA1 x1 (param1.trivial_full A1 PA1 HPA1 x1) f + (is_pforest_inhab A1 PA1 HPA1 f) = + is_pnode A1 PA1 x1 (param1.trivial_full A1 PA1 HPA1 x1) f Pf' with + | eq_refl => eq_refl + end + end + end HPA0 + with is_pforest_trivial_rec (A0 : Type) (PA0 : A0 -> Type) + (HPA0 : param1.trivial A0 PA0) (x0 : pforest A0) + (y : is_pforest A0 PA0 x0) {struct y} : + is_pforest_inhab A0 PA0 HPA0 x0 = y := + match y in is_pforest A1 PA1 x1 return + forall HPA1 : param1.trivial A1 PA1, + is_pforest_inhab A1 PA1 HPA1 x1 = y with + | is_pempty A1 PA1 => fun _ => eq_refl + | is_pcons A1 PA1 t Pt f Pf => + fun HPA1 => + match is_ptree_trivial_rec A1 PA1 HPA1 t Pt in _ = Pt' return + is_pcons A1 PA1 t (is_ptree_inhab A1 PA1 HPA1 t) f + (is_pforest_inhab A1 PA1 HPA1 f) = + is_pcons A1 PA1 t Pt' f Pf with + | eq_refl => + match is_pforest_trivial_rec A1 PA1 HPA1 f Pf in _ = Pf' return + is_pcons A1 PA1 t (is_ptree_inhab A1 PA1 HPA1 t) f + (is_pforest_inhab A1 PA1 HPA1 f) = + is_pcons A1 PA1 t (is_ptree_inhab A1 PA1 HPA1 t) f Pf' with + | eq_refl => eq_refl + end + end + end HPA0 + for is_ptree_trivial_rec) A PA HPA x). + Definition is_pforest_trivial : forall (A : Type) (PA : A -> Type), + param1.trivial A PA -> + forall x : pforest A, + {u : is_pforest A PA x & forall v : is_pforest A PA x, u = v} := + fun (A : Type) (PA : A -> Type) (HPA : param1.trivial A PA) (x : pforest A) => + param1.contracts (pforest A) (is_pforest A PA) x (is_pforest_inhab A PA HPA x) + ((fix is_ptree_trivial_rec (A0 : Type) (PA0 : A0 -> Type) + (HPA0 : param1.trivial A0 PA0) (x0 : ptree A0) + (y : is_ptree A0 PA0 x0) {struct y} : + is_ptree_inhab A0 PA0 HPA0 x0 = y := + match y in is_ptree A1 PA1 x1 return + forall HPA1 : param1.trivial A1 PA1, + is_ptree_inhab A1 PA1 HPA1 x1 = y with + | is_pnode A1 PA1 x1 Px f Pf => + fun HPA1 => + match param1.trivial_uniq A1 PA1 HPA1 x1 Px in _ = Px' return + is_pnode A1 PA1 x1 (param1.trivial_full A1 PA1 HPA1 x1) f + (is_pforest_inhab A1 PA1 HPA1 f) = + is_pnode A1 PA1 x1 Px' f Pf with + | eq_refl => + match is_pforest_trivial_rec A1 PA1 HPA1 f Pf in _ = Pf' return + is_pnode A1 PA1 x1 (param1.trivial_full A1 PA1 HPA1 x1) f + (is_pforest_inhab A1 PA1 HPA1 f) = + is_pnode A1 PA1 x1 (param1.trivial_full A1 PA1 HPA1 x1) f Pf' with + | eq_refl => eq_refl + end + end + end HPA0 + with is_pforest_trivial_rec (A0 : Type) (PA0 : A0 -> Type) + (HPA0 : param1.trivial A0 PA0) (x0 : pforest A0) + (y : is_pforest A0 PA0 x0) {struct y} : + is_pforest_inhab A0 PA0 HPA0 x0 = y := + match y in is_pforest A1 PA1 x1 return + forall HPA1 : param1.trivial A1 PA1, + is_pforest_inhab A1 PA1 HPA1 x1 = y with + | is_pempty A1 PA1 => fun _ => eq_refl + | is_pcons A1 PA1 t Pt f Pf => + fun HPA1 => + match is_ptree_trivial_rec A1 PA1 HPA1 t Pt in _ = Pt' return + is_pcons A1 PA1 t (is_ptree_inhab A1 PA1 HPA1 t) f + (is_pforest_inhab A1 PA1 HPA1 f) = + is_pcons A1 PA1 t Pt' f Pf with + | eq_refl => + match is_pforest_trivial_rec A1 PA1 HPA1 f Pf in _ = Pf' return + is_pcons A1 PA1 t (is_ptree_inhab A1 PA1 HPA1 t) f + (is_pforest_inhab A1 PA1 HPA1 f) = + is_pcons A1 PA1 t (is_ptree_inhab A1 PA1 HPA1 t) f Pf' with + | eq_refl => eq_refl + end + end + end HPA0 + for is_pforest_trivial_rec) A PA HPA x). +End ParametrizedMutualParam1TrivialExpected. + +Module Type ParametrizedMutualInductionExpected. + Include ParametrizedMutualParam1FunctorExpected. + Definition ptree_induction : forall (A : Type) (PA : A -> Type) + (P : ptree A -> Type) (P0 : pforest A -> Type), + (forall (x : A), PA x -> forall f : pforest A, + is_pforest A PA f -> P0 f -> P (pnode A x f)) -> + P0 (pempty A) -> + (forall t : ptree A, is_ptree A PA t -> P t -> forall f : pforest A, + is_pforest A PA f -> P0 f -> P0 (pcons A t f)) -> + forall s1 : ptree A, is_ptree A PA s1 -> P s1 := + fun (A : Type) (PA : A -> Type) (P : ptree A -> Type) (P0 : pforest A -> Type) + His_pnode His_pempty His_pcons s H => + (fix is_ptree_induction_rec (A0 : Type) (PA0 : A0 -> Type) + (P1 : ptree A0 -> Type) (P2 : pforest A0 -> Type) + (Hnode : forall (x : A0), PA0 x -> forall f : pforest A0, + is_pforest A0 PA0 f -> P2 f -> P1 (pnode A0 x f)) + (Hempty : P2 (pempty A0)) + (Hcons : forall t : ptree A0, is_ptree A0 PA0 t -> P1 t -> forall f : pforest A0, + is_pforest A0 PA0 f -> P2 f -> P2 (pcons A0 t f)) + (s1 : ptree A0) (H1 : is_ptree A0 PA0 s1) {struct H1} : P1 s1 := + match H1 in is_ptree A1 PA1 s2 return + forall (P1' : ptree A1 -> Type) (P2' : pforest A1 -> Type), + (forall (x : A1), PA1 x -> forall f : pforest A1, + is_pforest A1 PA1 f -> P2' f -> P1' (pnode A1 x f)) -> + P2' (pempty A1) -> + (forall t : ptree A1, is_ptree A1 PA1 t -> P1' t -> forall f : pforest A1, + is_pforest A1 PA1 f -> P2' f -> P2' (pcons A1 t f)) -> + P1' s2 with + | is_pnode A1 PA1 x Px f Pf => + fun P1' P2' Hnode' Hempty' Hcons' => + Hnode' x Px f Pf + (is_pforest_induction_rec A1 PA1 P1' P2' Hnode' Hempty' Hcons' f Pf) + end P1 P2 Hnode Hempty Hcons + with is_pforest_induction_rec (A0 : Type) (PA0 : A0 -> Type) + (P1 : ptree A0 -> Type) (P2 : pforest A0 -> Type) + (Hnode : forall (x : A0), PA0 x -> forall f : pforest A0, + is_pforest A0 PA0 f -> P2 f -> P1 (pnode A0 x f)) + (Hempty : P2 (pempty A0)) + (Hcons : forall t : ptree A0, is_ptree A0 PA0 t -> P1 t -> forall f : pforest A0, + is_pforest A0 PA0 f -> P2 f -> P2 (pcons A0 t f)) + (s1 : pforest A0) (H1 : is_pforest A0 PA0 s1) {struct H1} : P2 s1 := + match H1 in is_pforest A1 PA1 s2 return + forall (P1' : ptree A1 -> Type) (P2' : pforest A1 -> Type), + (forall (x : A1), PA1 x -> forall f : pforest A1, + is_pforest A1 PA1 f -> P2' f -> P1' (pnode A1 x f)) -> + P2' (pempty A1) -> + (forall t : ptree A1, is_ptree A1 PA1 t -> P1' t -> forall f : pforest A1, + is_pforest A1 PA1 f -> P2' f -> P2' (pcons A1 t f)) -> + P2' s2 with + | is_pempty A1 PA1 => fun _ P2' _ Hempty' _ => Hempty' + | is_pcons A1 PA1 t Pt f Pf => + fun P1' P2' Hnode' Hempty' Hcons' => + Hcons' t Pt (is_ptree_induction_rec A1 PA1 P1' P2' Hnode' Hempty' Hcons' t Pt) + f Pf (is_pforest_induction_rec A1 PA1 P1' P2' Hnode' Hempty' Hcons' f Pf) + end P1 P2 Hnode Hempty Hcons + for is_ptree_induction_rec) A PA P P0 His_pnode His_pempty His_pcons s H. + Definition pforest_induction : forall (A : Type) (PA : A -> Type) + (P : ptree A -> Type) (P0 : pforest A -> Type), + (forall (x : A), PA x -> forall f : pforest A, + is_pforest A PA f -> P0 f -> P (pnode A x f)) -> + P0 (pempty A) -> + (forall t : ptree A, is_ptree A PA t -> P t -> forall f : pforest A, + is_pforest A PA f -> P0 f -> P0 (pcons A t f)) -> + forall s1 : pforest A, is_pforest A PA s1 -> P0 s1 := + fun (A : Type) (PA : A -> Type) (P : ptree A -> Type) (P0 : pforest A -> Type) + His_pnode His_pempty His_pcons s H => + (fix is_ptree_induction_rec (A0 : Type) (PA0 : A0 -> Type) + (P1 : ptree A0 -> Type) (P2 : pforest A0 -> Type) + (Hnode : forall (x : A0), PA0 x -> forall f : pforest A0, + is_pforest A0 PA0 f -> P2 f -> P1 (pnode A0 x f)) + (Hempty : P2 (pempty A0)) + (Hcons : forall t : ptree A0, is_ptree A0 PA0 t -> P1 t -> forall f : pforest A0, + is_pforest A0 PA0 f -> P2 f -> P2 (pcons A0 t f)) + (s1 : ptree A0) (H1 : is_ptree A0 PA0 s1) {struct H1} : P1 s1 := + match H1 in is_ptree A1 PA1 s2 return + forall (P1' : ptree A1 -> Type) (P2' : pforest A1 -> Type), + (forall (x : A1), PA1 x -> forall f : pforest A1, + is_pforest A1 PA1 f -> P2' f -> P1' (pnode A1 x f)) -> + P2' (pempty A1) -> + (forall t : ptree A1, is_ptree A1 PA1 t -> P1' t -> forall f : pforest A1, + is_pforest A1 PA1 f -> P2' f -> P2' (pcons A1 t f)) -> + P1' s2 with + | is_pnode A1 PA1 x Px f Pf => + fun P1' P2' Hnode' Hempty' Hcons' => + Hnode' x Px f Pf + (is_pforest_induction_rec A1 PA1 P1' P2' Hnode' Hempty' Hcons' f Pf) + end P1 P2 Hnode Hempty Hcons + with is_pforest_induction_rec (A0 : Type) (PA0 : A0 -> Type) + (P1 : ptree A0 -> Type) (P2 : pforest A0 -> Type) + (Hnode : forall (x : A0), PA0 x -> forall f : pforest A0, + is_pforest A0 PA0 f -> P2 f -> P1 (pnode A0 x f)) + (Hempty : P2 (pempty A0)) + (Hcons : forall t : ptree A0, is_ptree A0 PA0 t -> P1 t -> forall f : pforest A0, + is_pforest A0 PA0 f -> P2 f -> P2 (pcons A0 t f)) + (s1 : pforest A0) (H1 : is_pforest A0 PA0 s1) {struct H1} : P2 s1 := + match H1 in is_pforest A1 PA1 s2 return + forall (P1' : ptree A1 -> Type) (P2' : pforest A1 -> Type), + (forall (x : A1), PA1 x -> forall f : pforest A1, + is_pforest A1 PA1 f -> P2' f -> P1' (pnode A1 x f)) -> + P2' (pempty A1) -> + (forall t : ptree A1, is_ptree A1 PA1 t -> P1' t -> forall f : pforest A1, + is_pforest A1 PA1 f -> P2' f -> P2' (pcons A1 t f)) -> + P2' s2 with + | is_pempty A1 PA1 => fun _ P2' _ Hempty' _ => Hempty' + | is_pcons A1 PA1 t Pt f Pf => + fun P1' P2' Hnode' Hempty' Hcons' => + Hcons' t Pt (is_ptree_induction_rec A1 PA1 P1' P2' Hnode' Hempty' Hcons' t Pt) + f Pf (is_pforest_induction_rec A1 PA1 P1' P2' Hnode' Hempty' Hcons' f Pf) + end P1 P2 Hnode Hempty Hcons + for is_pforest_induction_rec) A PA P P0 His_pnode His_pempty His_pcons s H. +End ParametrizedMutualInductionExpected. + +Module Type ParametrizedMutualParam2Expected. + Include ParametrizedMutualBase. + Universe ptree_R_arg_u ptree_R_u0 ptree_R_u1. + Inductive ptree_R : forall A1 A2 : Type@{ptree_R_arg_u}, (A1 -> A2 -> Type@{ptree_R_arg_u}) -> ptree A1 -> ptree A2 -> Type@{ptree_R_u0} := + | pnode_R : forall A1 A2 (A_R : A1 -> A2 -> Type@{ptree_R_arg_u}) (x1 : A1) (x2 : A2), + A_R x1 x2 -> forall (f1 : pforest A1) (f2 : pforest A2), + pforest_R A1 A2 A_R f1 f2 -> + ptree_R A1 A2 A_R (@pnode A1 x1 f1) (@pnode A2 x2 f2) + with pforest_R : forall A1 A2 : Type@{ptree_R_arg_u}, (A1 -> A2 -> Type@{ptree_R_arg_u}) -> pforest A1 -> pforest A2 -> Type@{ptree_R_u1} := + | pempty_R : forall A1 A2 (A_R : A1 -> A2 -> Type@{ptree_R_arg_u}), + pforest_R A1 A2 A_R (@pempty A1) (@pempty A2) + | pcons_R : forall A1 A2 (A_R : A1 -> A2 -> Type@{ptree_R_arg_u}) (t1 : ptree A1) (t2 : ptree A2), + ptree_R A1 A2 A_R t1 t2 -> forall (f1 : pforest A1) (f2 : pforest A2), + pforest_R A1 A2 A_R f1 f2 -> + pforest_R A1 A2 A_R (@pcons A1 t1 f1) (@pcons A2 t2 f2). + Definition param_ptree_R : param2.param_db ptree + ptree ptree_R := + @param2.store_param _ _ _ ptree ptree ptree_R. + Definition param_pforest_R : param2.param_db pforest + pforest pforest_R := + @param2.store_param _ _ _ pforest pforest pforest_R. + Definition param_pnode_R : param2.param_db pnode + pnode pnode_R := + @param2.store_param _ _ _ pnode pnode pnode_R. + Definition param_pempty_R : param2.param_db pempty + pempty pempty_R := + @param2.store_param _ _ _ pempty pempty pempty_R. + Definition param_pcons_R : param2.param_db pcons + pcons pcons_R := + @param2.store_param _ _ _ pcons pcons pcons_R. +End ParametrizedMutualParam2Expected. + +Module Type ParametrizedMutualTagExpected. + Include ParametrizedMutualBase. + Definition ptree_tag : forall A : Type, ptree A -> BinNums.positive := + fun (A : Type) (i : ptree A) => + match i with + | pnode _ _ _ => BinNums.xH + end. + Definition pforest_tag : forall A : Type, pforest A -> BinNums.positive := + fun (A : Type) (i : pforest A) => + match i with + | pempty _ => BinNums.xH + | pcons _ _ _ => BinNums.xO BinNums.xH + end. +End ParametrizedMutualTagExpected. + +Module Type ParametrizedMutualFieldsExpected. + Include ParametrizedMutualTagExpected. + Universe box_ptree_pnode_u box_pforest_pempty_u box_pforest_pcons_u. + Constraint Set < box_ptree_pnode_u. + Constraint Set < box_pforest_pempty_u. + Constraint Set < box_pforest_pcons_u. + Record box_ptree_pnode (A : Type) : Type@{box_ptree_pnode_u} := Box_ptree_pnode { + Box_ptree_pnode_0 : A; + Box_ptree_pnode_1 : pforest A; + }. + Record box_pforest_pempty (A : Type) : Type@{box_pforest_pempty_u} := Box_pforest_pempty {}. + Record box_pforest_pcons (A : Type) : Type@{box_pforest_pcons_u} := Box_pforest_pcons { + Box_pforest_pcons_0 : ptree A; + Box_pforest_pcons_1 : pforest A; + }. + Definition ptree_fields_t : Type -> BinNums.positive -> Type := + fun (p : Type) (_ : BinNums.positive) => + box_ptree_pnode p. + Definition ptree_fields : forall (p : Type) (i : ptree p), + ptree_fields_t p + (ptree_tag p i) := + fun (p : Type) (i : ptree p) => + match + i as i0 + return + ptree_fields_t p + (ptree_tag p i0) + with + | pnode _ x f => + {| + Box_ptree_pnode_0 := x; + Box_ptree_pnode_1 := f + |} + end. + Definition ptree_construct : forall p : Type, + BinNums.positive -> + box_ptree_pnode p -> + option (ptree p) := + fun (p : Type) (_ : BinNums.positive) + (b : box_ptree_pnode p) => + match b with + | {| + Box_ptree_pnode_0 := Box_ptree_pnode_0; + Box_ptree_pnode_1 := Box_ptree_pnode_1 + |} => + Some + (pnode p Box_ptree_pnode_0 Box_ptree_pnode_1) + end. + Parameter ptree_constructP : forall (A : Type) (i : ptree A), + ptree_construct A + (ptree_tag A i) + (ptree_fields A i) = + Some i. + Definition pforest_fields_t : Type -> BinNums.positive -> Type := + fun (p : Type) (p0 : BinNums.positive) => + match p0 with + | BinNums.xI _ => unit + | BinNums.xO _ => box_pforest_pcons p + | BinNums.xH => box_pforest_pempty p + end. + Definition pforest_fields : forall (p : Type) (i : pforest p), + pforest_fields_t p + (pforest_tag p i) := + fun (p : Type) (i : pforest p) => + match + i as i0 + return + pforest_fields_t p + (pforest_tag p i0) + with + | pempty _ => Box_pforest_pempty p + | pcons _ t f => + {| + Box_pforest_pcons_0 := t; + Box_pforest_pcons_1 := f + |} + end. + Definition pforest_construct : forall (p : Type) (p0 : BinNums.positive), + pforest_fields_t p p0 -> + option (pforest p) := + fun (p : Type) (p0 : BinNums.positive) => + match + p0 as i + return + pforest_fields_t p i -> + option (pforest p) + with + | BinNums.xI _ => fun _ : unit => None + | BinNums.xO _ => + fun b : box_pforest_pcons p => + match b with + | {| + Box_pforest_pcons_0 := Box_pforest_pcons_0; + Box_pforest_pcons_1 := Box_pforest_pcons_1 + |} => + Some + (pcons p Box_pforest_pcons_0 + Box_pforest_pcons_1) + end + | BinNums.xH => + fun _ : box_pforest_pempty p => + Some (pempty p) + end. + Parameter pforest_constructP : forall (A : Type) (i : pforest A), + pforest_construct A + (pforest_tag A i) + (pforest_fields A i) = + Some i. +End ParametrizedMutualFieldsExpected. + +Module Type ParametrizedMutualEqbExpected. + Include ParametrizedMutualFieldsExpected. + Definition ptree_eqb : forall a : Type, + (a -> a -> bool) -> + ptree a -> ptree a -> bool := + fun (a : Type) (eqA : a -> a -> bool) => + fix ptree (x1 x2 : ptree a) {struct x1} : bool := + match x1 with + | pnode _ x f => + eqb_core_defs.eqb_body (tagB:=ptree_tag a) + (fields_tA:=fun _ : BinNums.positive => + box_ptree_pnode a) + (fields_tB:=ptree_fields_t a) + (ptree_fields a) + (fun (_ : BinNums.positive) + (a0 b : box_ptree_pnode a) => + match a0 with + | {| + Box_ptree_pnode_0 := Box_ptree_pnode_0; + Box_ptree_pnode_1 := Box_ptree_pnode_1 + |} => + match b with + | {| + Box_ptree_pnode_0 := Box_ptree_pnode_2; + Box_ptree_pnode_1 := Box_ptree_pnode_3 + |} => + (eqA Box_ptree_pnode_0 Box_ptree_pnode_2 && + (pforest Box_ptree_pnode_1 Box_ptree_pnode_3 && true))%bool + end + end) + (t1:=ptree_tag a + (pnode a x f)) + {| + Box_ptree_pnode_0 := x; + Box_ptree_pnode_1 := f + |} x2 + end + with pforest (x1 x2 : pforest a) {struct x1} : bool := + match x1 with + | pempty _ => + eqb_core_defs.eqb_body (tagB:=pforest_tag a) + (fields_tA:=pforest_fields_t a) + (fields_tB:=pforest_fields_t a) + (pforest_fields a) + (fun x : BinNums.positive => + match + x as i + return + pforest_fields_t a i -> + pforest_fields_t a i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a0 b : box_pforest_pcons a => + match a0 with + | {| + Box_pforest_pcons_0 := + Box_pforest_pcons_0; + Box_pforest_pcons_1 := + Box_pforest_pcons_1 + |} => + match b with + | {| + Box_pforest_pcons_0 := + Box_pforest_pcons_2; + Box_pforest_pcons_1 := + Box_pforest_pcons_3 + |} => + (ptree Box_pforest_pcons_0 Box_pforest_pcons_2 && + (pforest Box_pforest_pcons_1 Box_pforest_pcons_3 && + true))%bool + end + end + | BinNums.xH => + fun _ _ : box_pforest_pempty a => true + end) + (t1:=pforest_tag a + (pempty a)) + (Box_pforest_pempty a) x2 + | pcons _ t f => + eqb_core_defs.eqb_body (tagB:=pforest_tag a) + (fields_tA:=pforest_fields_t a) + (fields_tB:=pforest_fields_t a) + (pforest_fields a) + (fun x : BinNums.positive => + match + x as i + return + pforest_fields_t a i -> + pforest_fields_t a i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a0 b : box_pforest_pcons a => + match a0 with + | {| + Box_pforest_pcons_0 := + Box_pforest_pcons_0; + Box_pforest_pcons_1 := + Box_pforest_pcons_1 + |} => + match b with + | {| + Box_pforest_pcons_0 := + Box_pforest_pcons_2; + Box_pforest_pcons_1 := + Box_pforest_pcons_3 + |} => + (ptree Box_pforest_pcons_0 Box_pforest_pcons_2 && + (pforest Box_pforest_pcons_1 Box_pforest_pcons_3 && + true))%bool + end + end + | BinNums.xH => + fun _ _ : box_pforest_pempty a => true + end) + (t1:=pforest_tag a + (pcons a t f)) + {| + Box_pforest_pcons_0 := t; + Box_pforest_pcons_1 := f + |} x2 + end + for + ptree. + Definition pforest_eqb : forall a : Type, + (a -> a -> bool) -> + pforest a -> + pforest a -> bool := + fun (a : Type) (eqA : a -> a -> bool) => + fix ptree (x1 x2 : ptree a) {struct x1} : bool := + match x1 with + | pnode _ x f => + eqb_core_defs.eqb_body (tagB:=ptree_tag a) + (fields_tA:=fun _ : BinNums.positive => + box_ptree_pnode a) + (fields_tB:=ptree_fields_t a) + (ptree_fields a) + (fun (_ : BinNums.positive) + (a0 b : box_ptree_pnode a) => + match a0 with + | {| + Box_ptree_pnode_0 := Box_ptree_pnode_0; + Box_ptree_pnode_1 := Box_ptree_pnode_1 + |} => + match b with + | {| + Box_ptree_pnode_0 := Box_ptree_pnode_2; + Box_ptree_pnode_1 := Box_ptree_pnode_3 + |} => + (eqA Box_ptree_pnode_0 Box_ptree_pnode_2 && + (pforest Box_ptree_pnode_1 Box_ptree_pnode_3 && true))%bool + end + end) + (t1:=ptree_tag a + (pnode a x f)) + {| + Box_ptree_pnode_0 := x; + Box_ptree_pnode_1 := f + |} x2 + end + with pforest (x1 x2 : pforest a) {struct x1} : bool := + match x1 with + | pempty _ => + eqb_core_defs.eqb_body (tagB:=pforest_tag a) + (fields_tA:=pforest_fields_t a) + (fields_tB:=pforest_fields_t a) + (pforest_fields a) + (fun x : BinNums.positive => + match + x as i + return + pforest_fields_t a i -> + pforest_fields_t a i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a0 b : box_pforest_pcons a => + match a0 with + | {| + Box_pforest_pcons_0 := + Box_pforest_pcons_0; + Box_pforest_pcons_1 := + Box_pforest_pcons_1 + |} => + match b with + | {| + Box_pforest_pcons_0 := + Box_pforest_pcons_2; + Box_pforest_pcons_1 := + Box_pforest_pcons_3 + |} => + (ptree Box_pforest_pcons_0 Box_pforest_pcons_2 && + (pforest Box_pforest_pcons_1 Box_pforest_pcons_3 && + true))%bool + end + end + | BinNums.xH => + fun _ _ : box_pforest_pempty a => true + end) + (t1:=pforest_tag a + (pempty a)) + (Box_pforest_pempty a) x2 + | pcons _ t f => + eqb_core_defs.eqb_body (tagB:=pforest_tag a) + (fields_tA:=pforest_fields_t a) + (fields_tB:=pforest_fields_t a) + (pforest_fields a) + (fun x : BinNums.positive => + match + x as i + return + pforest_fields_t a i -> + pforest_fields_t a i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a0 b : box_pforest_pcons a => + match a0 with + | {| + Box_pforest_pcons_0 := + Box_pforest_pcons_0; + Box_pforest_pcons_1 := + Box_pforest_pcons_1 + |} => + match b with + | {| + Box_pforest_pcons_0 := + Box_pforest_pcons_2; + Box_pforest_pcons_1 := + Box_pforest_pcons_3 + |} => + (ptree Box_pforest_pcons_0 Box_pforest_pcons_2 && + (pforest Box_pforest_pcons_1 Box_pforest_pcons_3 && + true))%bool + end + end + | BinNums.xH => + fun _ _ : box_pforest_pempty a => true + end) + (t1:=pforest_tag a + (pcons a t f)) + {| + Box_pforest_pcons_0 := t; + Box_pforest_pcons_1 := f + |} x2 + end + for + pforest. + Definition ptree_eqb_fields : forall p : Type, + (p -> p -> bool) -> + (ptree p -> + ptree p -> bool) -> + BinNums.positive -> + box_ptree_pnode p -> + box_ptree_pnode p -> bool := + fun (p : Type) (eqp : p -> p -> bool) + (_ : ptree p -> ptree p -> bool) + (_ : BinNums.positive) (a b : box_ptree_pnode p) => + match a with + | {| + Box_ptree_pnode_0 := Box_ptree_pnode_0; + Box_ptree_pnode_1 := Box_ptree_pnode_1 + |} => + match b with + | {| + Box_ptree_pnode_0 := Box_ptree_pnode_2; + Box_ptree_pnode_1 := Box_ptree_pnode_3 + |} => + (eqp Box_ptree_pnode_0 Box_ptree_pnode_2 && + (pforest_eqb p eqp Box_ptree_pnode_1 + Box_ptree_pnode_3 && + true))%bool + end + end. + Definition pforest_eqb_fields : forall p : Type, + (p -> p -> bool) -> + (pforest p -> + pforest p -> bool) -> + forall x : BinNums.positive, + pforest_fields_t p x -> + pforest_fields_t p x -> bool := + fun (p : Type) (eqp : p -> p -> bool) + (rec : pforest p -> + pforest p -> bool) + (x : BinNums.positive) => + match + x as i + return + pforest_fields_t p i -> + pforest_fields_t p i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_pforest_pcons p => + match a with + | {| + Box_pforest_pcons_0 := Box_pforest_pcons_0; + Box_pforest_pcons_1 := Box_pforest_pcons_1 + |} => + match b with + | {| + Box_pforest_pcons_0 := Box_pforest_pcons_2; + Box_pforest_pcons_1 := Box_pforest_pcons_3 + |} => + (ptree_eqb p eqp Box_pforest_pcons_0 + Box_pforest_pcons_2 && + (rec Box_pforest_pcons_1 Box_pforest_pcons_3 && true))%bool + end + end + | BinNums.xH => fun _ _ : box_pforest_pempty p => true + end. +End ParametrizedMutualEqbExpected. + +Module Type ParametrizedMutualEqbCorrectExpected. + Include ParametrizedMutualEqbExpected. + Parameter ptree_eqb_correct : forall (A : Type) (eqA : A -> A -> bool), + eqb_core_defs.eqb_correct eqA -> + forall x : ptree A, eqb_core_defs.eqb_correct_on (ptree_eqb A eqA) x. + Parameter pforest_eqb_correct : forall (A : Type) (eqA : A -> A -> bool), + eqb_core_defs.eqb_correct eqA -> + forall x : pforest A, eqb_core_defs.eqb_correct_on (pforest_eqb A eqA) x. + Parameter ptree_eqb_refl : forall (A : Type) (eqA : A -> A -> bool), + eqb_core_defs.eqb_reflexive eqA -> + forall x : ptree A, eqb_core_defs.eqb_refl_on (ptree_eqb A eqA) x. + Parameter pforest_eqb_refl : forall (A : Type) (eqA : A -> A -> bool), + eqb_core_defs.eqb_reflexive eqA -> + forall x : pforest A, eqb_core_defs.eqb_refl_on (pforest_eqb A eqA) x. +End ParametrizedMutualEqbCorrectExpected. + +Module Type ParametrizedMutualEqbOKExpected. + Include ParametrizedMutualEqbCorrectExpected. + Parameter ptree_eqb_OK : forall (A : Type) (eqA : A -> A -> bool), + (forall x y : A, reflect (x = y) (eqA x y)) -> + forall x y : ptree A, reflect (x = y) (ptree_eqb A eqA x y). + Parameter pforest_eqb_OK : forall (A : Type) (eqA : A -> A -> bool), + (forall x y : A, reflect (x = y) (eqA x y)) -> + forall x y : pforest A, reflect (x = y) (pforest_eqb A eqA x y). + Parameter ptree_eqb_OK_sumbool : forall A : Type, + (forall x y : A, {x = y} + {x <> y}) -> + forall x y : ptree A, {x = y} + {x <> y}. + Parameter pforest_eqb_OK_sumbool : forall A : Type, + (forall x y : A, {x = y} + {x <> y}) -> + forall x y : pforest A, {x = y} + {x <> y}. +End ParametrizedMutualEqbOKExpected. + +Module Type ParametrizedMutualIsKExpected. + Include ParametrizedMutualBase. + Definition ptree_isk_pnode : forall A : Type, ptree A -> bool := + fun (A : Type) (i : ptree A) => + match i with + | pnode _ _ _ => true + end. + Definition pforest_isk_pempty : forall A : Type, pforest A -> bool := + fun (A : Type) (i : pforest A) => + match i with + | pempty _ => true + | pcons _ _ _ => false + end. + Definition pforest_isk_pcons : forall A : Type, pforest A -> bool := + fun (A : Type) (i : pforest A) => + match i with + | pempty _ => false + | pcons _ _ _ => true + end. +End ParametrizedMutualIsKExpected. + +Module Type ParametrizedMutualProjKExpected. + Include ParametrizedMutualBase. + Definition ptree_getk_pnode1 : forall A : Type, + A -> + pforest A -> + ptree A -> A := + fun (A : Type) (_ : A) (_ : pforest A) + (i : ptree A) => + match i with + | pnode _ x0 _ => x0 + end. + Definition ptree_getk_pnode2 : forall A : Type, + A -> + pforest A -> + ptree A -> pforest A := + fun (A : Type) (_ : A) (_ : pforest A) + (i : ptree A) => + match i with + | pnode _ _ f0 => f0 + end. + Definition pforest_getk_pcons1 : forall A : Type, + ptree A -> + pforest A -> + pforest A -> ptree A := + fun (A : Type) (t : ptree A) + (_ i : pforest A) => + match i with + | pempty _ => t + | pcons _ t0 _ => t0 + end. + Definition pforest_getk_pcons2 : forall A : Type, + ptree A -> + pforest A -> + pforest A -> pforest A := + fun (A : Type) (_ : ptree A) + (f i : pforest A) => + match i with + | pempty _ => f + | pcons _ _ f0 => f0 + end. +End ParametrizedMutualProjKExpected. + +Module Type ParametrizedMutualBcongrExpected. + Include ParametrizedMutualProjKExpected. + Parameter ptree_bcongr_pnode : forall (A : Type) (x y : A) (b : bool), + reflect (x = y) b -> + forall (x0 y0 : pforest A) (b0 : bool), + reflect (x0 = y0) b0 -> + reflect + (pnode A x x0 = + pnode A y y0) + (b && b0). + Parameter pforest_bcongr_pempty : forall A : Type, + reflect + (pempty A = + pempty A) + true. + Parameter pforest_bcongr_pcons : forall (A : Type) (x y : ptree A) (b : bool), + reflect (x = y) b -> + forall (x0 y0 : pforest A) (b0 : bool), + reflect (x0 = y0) b0 -> + reflect + (pcons A x x0 = + pcons A y y0) + (b && b0). +End ParametrizedMutualBcongrExpected. + +Module Type TripleMutualBase. + Inductive alpha : Type := + | alpha0 + | alpha1 (b : beta) + with beta : Type := + | beta0 + | beta1 (g : gamma) + with gamma : Type := + | gamma0 + | gamma1 (a : alpha) (b : beta). +End TripleMutualBase. + +Module Type TripleMutualMapExpected. + Include TripleMutualBase. + Definition alpha_map : alpha -> alpha := + fun x : alpha => x. + Definition beta_map : beta -> beta := + fun x : beta => x. + Definition gamma_map : gamma -> gamma := + fun x : gamma => x. +End TripleMutualMapExpected. + +Module Type TripleMutualEqbExpected. + Include TripleMutualBase. + Universe box_alpha_alpha0_u box_alpha_alpha1_u box_beta_beta0_u box_beta_beta1_u box_gamma_gamma0_u box_gamma_gamma1_u. + Constraint Set < box_alpha_alpha0_u. + Constraint Set < box_alpha_alpha1_u. + Constraint Set < box_beta_beta0_u. + Constraint Set < box_beta_beta1_u. + Constraint Set < box_gamma_gamma0_u. + Constraint Set < box_gamma_gamma1_u. + Record box_alpha_alpha0 : Type@{box_alpha_alpha0_u} := Box_alpha_alpha0 {}. + Record box_alpha_alpha1 : Type@{box_alpha_alpha1_u} := Box_alpha_alpha1 { + Box_alpha_alpha1_0 : beta; + }. + Record box_beta_beta0 : Type@{box_beta_beta0_u} := Box_beta_beta0 {}. + Record box_beta_beta1 : Type@{box_beta_beta1_u} := Box_beta_beta1 { + Box_beta_beta1_0 : gamma; + }. + Record box_gamma_gamma0 : Type@{box_gamma_gamma0_u} := Box_gamma_gamma0 {}. + Record box_gamma_gamma1 : Type@{box_gamma_gamma1_u} := Box_gamma_gamma1 { + Box_gamma_gamma1_0 : alpha; + Box_gamma_gamma1_1 : beta; + }. + Definition alpha_tag : alpha -> BinNums.positive := + fun i : alpha => + match i with + | alpha0 => BinNums.xH + | alpha1 _ => BinNums.xO BinNums.xH + end. + Definition beta_tag : beta -> BinNums.positive := + fun i : beta => + match i with + | beta0 => BinNums.xH + | beta1 _ => BinNums.xO BinNums.xH + end. + Definition gamma_tag : gamma -> BinNums.positive := + fun i : gamma => + match i with + | gamma0 => BinNums.xH + | gamma1 _ _ => BinNums.xO BinNums.xH + end. + Definition alpha_fields_t : BinNums.positive -> Type := + fun p : BinNums.positive => + match p with + | BinNums.xI _ => unit + | BinNums.xO _ => box_alpha_alpha1 + | BinNums.xH => box_alpha_alpha0 + end. + Definition beta_fields_t : BinNums.positive -> Type := + fun p : BinNums.positive => + match p with + | BinNums.xI _ => unit + | BinNums.xO _ => box_beta_beta1 + | BinNums.xH => box_beta_beta0 + end. + Definition gamma_fields_t : BinNums.positive -> Type := + fun p : BinNums.positive => + match p with + | BinNums.xI _ => unit + | BinNums.xO _ => box_gamma_gamma1 + | BinNums.xH => box_gamma_gamma0 + end. + Definition alpha_fields : forall i : alpha, + alpha_fields_t + (alpha_tag i) := + fun i : alpha => + match + i as i0 + return + alpha_fields_t + (alpha_tag i0) + with + | alpha0 => + Box_alpha_alpha0 + | alpha1 b => + {| Box_alpha_alpha1_0 := b |} + end. + Definition beta_fields : forall i : beta, + beta_fields_t + (beta_tag i) := + fun i : beta => + match + i as i0 + return + beta_fields_t + (beta_tag i0) + with + | beta0 => Box_beta_beta0 + | beta1 g => + {| Box_beta_beta1_0 := g |} + end. + Definition gamma_fields : forall i : gamma, + gamma_fields_t + (gamma_tag i) := + fun i : gamma => + match + i as i0 + return + gamma_fields_t + (gamma_tag i0) + with + | gamma0 => + Box_gamma_gamma0 + | gamma1 a b => + {| + Box_gamma_gamma1_0 := a; + Box_gamma_gamma1_1 := b + |} + end. + Definition alpha_construct : forall p : BinNums.positive, + alpha_fields_t p -> + option alpha := + fun p : BinNums.positive => + match + p as i + return + alpha_fields_t i -> + option alpha + with + | BinNums.xI _ => fun _ : unit => None + | BinNums.xO _ => + fun b : box_alpha_alpha1 => + match b with + | {| Box_alpha_alpha1_0 := Box_alpha_alpha1_0 |} => + Some (alpha1 Box_alpha_alpha1_0) + end + | BinNums.xH => + fun _ : box_alpha_alpha0 => + Some alpha0 + end. + Definition beta_construct : forall p : BinNums.positive, + beta_fields_t p -> + option beta := + fun p : BinNums.positive => + match + p as i + return + beta_fields_t i -> + option beta + with + | BinNums.xI _ => fun _ : unit => None + | BinNums.xO _ => + fun b : box_beta_beta1 => + match b with + | {| Box_beta_beta1_0 := Box_beta_beta1_0 |} => + Some (beta1 Box_beta_beta1_0) + end + | BinNums.xH => + fun _ : box_beta_beta0 => + Some beta0 + end. + Definition gamma_construct : forall p : BinNums.positive, + gamma_fields_t p -> + option gamma := + fun p : BinNums.positive => + match + p as i + return + gamma_fields_t i -> + option gamma + with + | BinNums.xI _ => fun _ : unit => None + | BinNums.xO _ => + fun b : box_gamma_gamma1 => + match b with + | {| + Box_gamma_gamma1_0 := Box_gamma_gamma1_0; + Box_gamma_gamma1_1 := Box_gamma_gamma1_1 + |} => + Some + (gamma1 Box_gamma_gamma1_0 + Box_gamma_gamma1_1) + end + | BinNums.xH => + fun _ : box_gamma_gamma0 => + Some gamma0 + end. + Parameter alpha_constructP : forall i : alpha, + alpha_construct + (alpha_tag i) + (alpha_fields i) = + Some i. + Parameter beta_constructP : forall i : beta, + beta_construct + (beta_tag i) + (beta_fields i) = + Some i. + Parameter gamma_constructP : forall i : gamma, + gamma_construct + (gamma_tag i) + (gamma_fields i) = + Some i. + Definition alpha_eqb : alpha -> alpha -> bool := + fix alpha (x1 x2 : alpha) {struct x1} : bool := + match x1 with + | alpha0 => + eqb_core_defs.eqb_body (tagB:=alpha_tag) + (fields_tA:=alpha_fields_t) + (fields_tB:=alpha_fields_t) + alpha_fields + (fun x : BinNums.positive => + match + x as i + return + alpha_fields_t i -> + alpha_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_alpha_alpha1 => + match a with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_0 + |} => + match b with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_1 + |} => + (beta Box_alpha_alpha1_0 Box_alpha_alpha1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_alpha_alpha0 => true + end) + (t1:=alpha_tag + alpha0) + Box_alpha_alpha0 x2 + | alpha1 b => + eqb_core_defs.eqb_body (tagB:=alpha_tag) + (fields_tA:=alpha_fields_t) + (fields_tB:=alpha_fields_t) + alpha_fields + (fun x : BinNums.positive => + match + x as i + return + alpha_fields_t i -> + alpha_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b0 : box_alpha_alpha1 => + match a with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_0 + |} => + match b0 with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_1 + |} => + (beta Box_alpha_alpha1_0 Box_alpha_alpha1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_alpha_alpha0 => true + end) + (t1:=alpha_tag + (alpha1 b)) + {| Box_alpha_alpha1_0 := b |} x2 + end + with beta (x1 x2 : beta) {struct x1} : bool := + match x1 with + | beta0 => + eqb_core_defs.eqb_body (tagB:=beta_tag) + (fields_tA:=beta_fields_t) + (fields_tB:=beta_fields_t) + beta_fields + (fun x : BinNums.positive => + match + x as i + return + beta_fields_t i -> + beta_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_beta_beta1 => + match a with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_0 + |} => + match b with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_1 + |} => + (gamma Box_beta_beta1_0 Box_beta_beta1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_beta_beta0 => true + end) + (t1:=beta_tag beta0) + Box_beta_beta0 x2 + | beta1 g => + eqb_core_defs.eqb_body (tagB:=beta_tag) + (fields_tA:=beta_fields_t) + (fields_tB:=beta_fields_t) + beta_fields + (fun x : BinNums.positive => + match + x as i + return + beta_fields_t i -> + beta_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_beta_beta1 => + match a with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_0 + |} => + match b with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_1 + |} => + (gamma Box_beta_beta1_0 Box_beta_beta1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_beta_beta0 => true + end) + (t1:=beta_tag + (beta1 g)) + {| Box_beta_beta1_0 := g |} x2 + end + with gamma (x1 x2 : gamma) {struct x1} : bool := + match x1 with + | gamma0 => + eqb_core_defs.eqb_body (tagB:=gamma_tag) + (fields_tA:=gamma_fields_t) + (fields_tB:=gamma_fields_t) + gamma_fields + (fun x : BinNums.positive => + match + x as i + return + gamma_fields_t i -> + gamma_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_gamma_gamma1 => + match a with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_0; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_1 + |} => + match b with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_2; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_3 + |} => + (alpha Box_gamma_gamma1_0 Box_gamma_gamma1_2 && + (beta Box_gamma_gamma1_1 Box_gamma_gamma1_3 && true))%bool + end + end + | BinNums.xH => + fun _ _ : box_gamma_gamma0 => true + end) + (t1:=gamma_tag + gamma0) + Box_gamma_gamma0 x2 + | gamma1 a b => + eqb_core_defs.eqb_body (tagB:=gamma_tag) + (fields_tA:=gamma_fields_t) + (fields_tB:=gamma_fields_t) + gamma_fields + (fun x : BinNums.positive => + match + x as i + return + gamma_fields_t i -> + gamma_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a0 b0 : box_gamma_gamma1 => + match a0 with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_0; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_1 + |} => + match b0 with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_2; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_3 + |} => + (alpha Box_gamma_gamma1_0 Box_gamma_gamma1_2 && + (beta Box_gamma_gamma1_1 Box_gamma_gamma1_3 && true))%bool + end + end + | BinNums.xH => + fun _ _ : box_gamma_gamma0 => true + end) + (t1:=gamma_tag + (gamma1 a b)) + {| + Box_gamma_gamma1_0 := a; + Box_gamma_gamma1_1 := b + |} x2 + end + for + alpha. + Definition beta_eqb : beta -> beta -> bool := + fix alpha (x1 x2 : alpha) {struct x1} : bool := + match x1 with + | alpha0 => + eqb_core_defs.eqb_body (tagB:=alpha_tag) + (fields_tA:=alpha_fields_t) + (fields_tB:=alpha_fields_t) + alpha_fields + (fun x : BinNums.positive => + match + x as i + return + alpha_fields_t i -> + alpha_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_alpha_alpha1 => + match a with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_0 + |} => + match b with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_1 + |} => + (beta Box_alpha_alpha1_0 Box_alpha_alpha1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_alpha_alpha0 => true + end) + (t1:=alpha_tag + alpha0) + Box_alpha_alpha0 x2 + | alpha1 b => + eqb_core_defs.eqb_body (tagB:=alpha_tag) + (fields_tA:=alpha_fields_t) + (fields_tB:=alpha_fields_t) + alpha_fields + (fun x : BinNums.positive => + match + x as i + return + alpha_fields_t i -> + alpha_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b0 : box_alpha_alpha1 => + match a with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_0 + |} => + match b0 with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_1 + |} => + (beta Box_alpha_alpha1_0 Box_alpha_alpha1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_alpha_alpha0 => true + end) + (t1:=alpha_tag + (alpha1 b)) + {| Box_alpha_alpha1_0 := b |} x2 + end + with beta (x1 x2 : beta) {struct x1} : bool := + match x1 with + | beta0 => + eqb_core_defs.eqb_body (tagB:=beta_tag) + (fields_tA:=beta_fields_t) + (fields_tB:=beta_fields_t) + beta_fields + (fun x : BinNums.positive => + match + x as i + return + beta_fields_t i -> + beta_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_beta_beta1 => + match a with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_0 + |} => + match b with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_1 + |} => + (gamma Box_beta_beta1_0 Box_beta_beta1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_beta_beta0 => true + end) + (t1:=beta_tag beta0) + Box_beta_beta0 x2 + | beta1 g => + eqb_core_defs.eqb_body (tagB:=beta_tag) + (fields_tA:=beta_fields_t) + (fields_tB:=beta_fields_t) + beta_fields + (fun x : BinNums.positive => + match + x as i + return + beta_fields_t i -> + beta_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_beta_beta1 => + match a with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_0 + |} => + match b with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_1 + |} => + (gamma Box_beta_beta1_0 Box_beta_beta1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_beta_beta0 => true + end) + (t1:=beta_tag + (beta1 g)) + {| Box_beta_beta1_0 := g |} x2 + end + with gamma (x1 x2 : gamma) {struct x1} : bool := + match x1 with + | gamma0 => + eqb_core_defs.eqb_body (tagB:=gamma_tag) + (fields_tA:=gamma_fields_t) + (fields_tB:=gamma_fields_t) + gamma_fields + (fun x : BinNums.positive => + match + x as i + return + gamma_fields_t i -> + gamma_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_gamma_gamma1 => + match a with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_0; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_1 + |} => + match b with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_2; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_3 + |} => + (alpha Box_gamma_gamma1_0 Box_gamma_gamma1_2 && + (beta Box_gamma_gamma1_1 Box_gamma_gamma1_3 && true))%bool + end + end + | BinNums.xH => + fun _ _ : box_gamma_gamma0 => true + end) + (t1:=gamma_tag + gamma0) + Box_gamma_gamma0 x2 + | gamma1 a b => + eqb_core_defs.eqb_body (tagB:=gamma_tag) + (fields_tA:=gamma_fields_t) + (fields_tB:=gamma_fields_t) + gamma_fields + (fun x : BinNums.positive => + match + x as i + return + gamma_fields_t i -> + gamma_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a0 b0 : box_gamma_gamma1 => + match a0 with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_0; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_1 + |} => + match b0 with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_2; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_3 + |} => + (alpha Box_gamma_gamma1_0 Box_gamma_gamma1_2 && + (beta Box_gamma_gamma1_1 Box_gamma_gamma1_3 && true))%bool + end + end + | BinNums.xH => + fun _ _ : box_gamma_gamma0 => true + end) + (t1:=gamma_tag + (gamma1 a b)) + {| + Box_gamma_gamma1_0 := a; + Box_gamma_gamma1_1 := b + |} x2 + end + for + beta. + Definition gamma_eqb : gamma -> + gamma -> bool := + fix alpha (x1 x2 : alpha) {struct x1} : bool := + match x1 with + | alpha0 => + eqb_core_defs.eqb_body (tagB:=alpha_tag) + (fields_tA:=alpha_fields_t) + (fields_tB:=alpha_fields_t) + alpha_fields + (fun x : BinNums.positive => + match + x as i + return + alpha_fields_t i -> + alpha_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_alpha_alpha1 => + match a with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_0 + |} => + match b with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_1 + |} => + (beta Box_alpha_alpha1_0 Box_alpha_alpha1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_alpha_alpha0 => true + end) + (t1:=alpha_tag + alpha0) + Box_alpha_alpha0 x2 + | alpha1 b => + eqb_core_defs.eqb_body (tagB:=alpha_tag) + (fields_tA:=alpha_fields_t) + (fields_tB:=alpha_fields_t) + alpha_fields + (fun x : BinNums.positive => + match + x as i + return + alpha_fields_t i -> + alpha_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b0 : box_alpha_alpha1 => + match a with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_0 + |} => + match b0 with + | {| + Box_alpha_alpha1_0 := + Box_alpha_alpha1_1 + |} => + (beta Box_alpha_alpha1_0 Box_alpha_alpha1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_alpha_alpha0 => true + end) + (t1:=alpha_tag + (alpha1 b)) + {| Box_alpha_alpha1_0 := b |} x2 + end + with beta (x1 x2 : beta) {struct x1} : bool := + match x1 with + | beta0 => + eqb_core_defs.eqb_body (tagB:=beta_tag) + (fields_tA:=beta_fields_t) + (fields_tB:=beta_fields_t) + beta_fields + (fun x : BinNums.positive => + match + x as i + return + beta_fields_t i -> + beta_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_beta_beta1 => + match a with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_0 + |} => + match b with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_1 + |} => + (gamma Box_beta_beta1_0 Box_beta_beta1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_beta_beta0 => true + end) + (t1:=beta_tag beta0) + Box_beta_beta0 x2 + | beta1 g => + eqb_core_defs.eqb_body (tagB:=beta_tag) + (fields_tA:=beta_fields_t) + (fields_tB:=beta_fields_t) + beta_fields + (fun x : BinNums.positive => + match + x as i + return + beta_fields_t i -> + beta_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_beta_beta1 => + match a with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_0 + |} => + match b with + | {| + Box_beta_beta1_0 := + Box_beta_beta1_1 + |} => + (gamma Box_beta_beta1_0 Box_beta_beta1_1 && true)%bool + end + end + | BinNums.xH => + fun _ _ : box_beta_beta0 => true + end) + (t1:=beta_tag + (beta1 g)) + {| Box_beta_beta1_0 := g |} x2 + end + with gamma (x1 x2 : gamma) {struct x1} : bool := + match x1 with + | gamma0 => + eqb_core_defs.eqb_body (tagB:=gamma_tag) + (fields_tA:=gamma_fields_t) + (fields_tB:=gamma_fields_t) + gamma_fields + (fun x : BinNums.positive => + match + x as i + return + gamma_fields_t i -> + gamma_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_gamma_gamma1 => + match a with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_0; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_1 + |} => + match b with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_2; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_3 + |} => + (alpha Box_gamma_gamma1_0 Box_gamma_gamma1_2 && + (beta Box_gamma_gamma1_1 Box_gamma_gamma1_3 && true))%bool + end + end + | BinNums.xH => + fun _ _ : box_gamma_gamma0 => true + end) + (t1:=gamma_tag + gamma0) + Box_gamma_gamma0 x2 + | gamma1 a b => + eqb_core_defs.eqb_body (tagB:=gamma_tag) + (fields_tA:=gamma_fields_t) + (fields_tB:=gamma_fields_t) + gamma_fields + (fun x : BinNums.positive => + match + x as i + return + gamma_fields_t i -> + gamma_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a0 b0 : box_gamma_gamma1 => + match a0 with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_0; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_1 + |} => + match b0 with + | {| + Box_gamma_gamma1_0 := + Box_gamma_gamma1_2; + Box_gamma_gamma1_1 := + Box_gamma_gamma1_3 + |} => + (alpha Box_gamma_gamma1_0 Box_gamma_gamma1_2 && + (beta Box_gamma_gamma1_1 Box_gamma_gamma1_3 && true))%bool + end + end + | BinNums.xH => + fun _ _ : box_gamma_gamma0 => true + end) + (t1:=gamma_tag + (gamma1 a b)) + {| + Box_gamma_gamma1_0 := a; + Box_gamma_gamma1_1 := b + |} x2 + end + for + gamma. + Definition alpha_eqb_fields : (alpha -> + alpha -> bool) -> + forall x : BinNums.positive, + alpha_fields_t x -> + alpha_fields_t x -> bool := + fun + (_ : alpha -> + alpha -> bool) + (x : BinNums.positive) => + match + x as i + return + alpha_fields_t i -> + alpha_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_alpha_alpha1 => + match a with + | {| Box_alpha_alpha1_0 := Box_alpha_alpha1_0 |} => + match b with + | {| + Box_alpha_alpha1_0 := Box_alpha_alpha1_1 + |} => + (beta_eqb Box_alpha_alpha1_0 + Box_alpha_alpha1_1 && + true)%bool + end + end + | BinNums.xH => fun _ _ : box_alpha_alpha0 => true + end. + Definition beta_eqb_fields : (beta -> + beta -> bool) -> + forall x : BinNums.positive, + beta_fields_t x -> + beta_fields_t x -> bool := + fun + (_ : beta -> beta -> bool) + (x : BinNums.positive) => + match + x as i + return + beta_fields_t i -> + beta_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_beta_beta1 => + match a with + | {| Box_beta_beta1_0 := Box_beta_beta1_0 |} => + match b with + | {| Box_beta_beta1_0 := Box_beta_beta1_1 |} => + (gamma_eqb Box_beta_beta1_0 + Box_beta_beta1_1 && + true)%bool + end + end + | BinNums.xH => fun _ _ : box_beta_beta0 => true + end. + Definition gamma_eqb_fields : (gamma -> + gamma -> bool) -> + forall x : BinNums.positive, + gamma_fields_t x -> + gamma_fields_t x -> bool := + fun + (_ : gamma -> + gamma -> bool) + (x : BinNums.positive) => + match + x as i + return + gamma_fields_t i -> + gamma_fields_t i -> bool + with + | BinNums.xI _ => fun _ _ : unit => true + | BinNums.xO _ => + fun a b : box_gamma_gamma1 => + match a with + | {| + Box_gamma_gamma1_0 := Box_gamma_gamma1_0; + Box_gamma_gamma1_1 := Box_gamma_gamma1_1 + |} => + match b with + | {| + Box_gamma_gamma1_0 := Box_gamma_gamma1_2; + Box_gamma_gamma1_1 := Box_gamma_gamma1_3 + |} => + (alpha_eqb Box_gamma_gamma1_0 + Box_gamma_gamma1_2 && + (beta_eqb Box_gamma_gamma1_1 + Box_gamma_gamma1_3 && + true))%bool + end + end + | BinNums.xH => fun _ _ : box_gamma_gamma0 => true + end. +End TripleMutualEqbExpected. + +Module Type TripleMutualEqbOKExpected. + Include TripleMutualEqbExpected. + Universe alpha_reali_u beta_reali_u gamma_reali_u. + Constraint Set < alpha_reali_u. + Constraint Set < beta_reali_u. + Constraint Set < gamma_reali_u. + Inductive is_alpha : alpha -> Type@{alpha_reali_u} := + | is_alpha0 : is_alpha alpha0 + | is_alpha1 (b : beta) (Pb : is_beta b) : is_alpha (alpha1 b) + with is_beta : beta -> Type@{beta_reali_u} := + | is_beta0 : is_beta beta0 + | is_beta1 (g : gamma) (Pg : is_gamma g) : is_beta (beta1 g) + with is_gamma : gamma -> Type@{gamma_reali_u} := + | is_gamma0 : is_gamma gamma0 + | is_gamma1 (a : alpha) (Pa : is_alpha a) + (b : beta) (Pb : is_beta b) : is_gamma (gamma1 a b). + Definition is_alpha_inhab : forall x : alpha, is_alpha x := + fix is_alpha_inhab_rec (x : alpha) : is_alpha x := + match x as i return is_alpha i with + | alpha0 => is_alpha0 + | alpha1 b => is_alpha1 b (is_beta_inhab_rec b) + end + with is_beta_inhab_rec (x : beta) : is_beta x := + match x as i return is_beta i with + | beta0 => is_beta0 + | beta1 g => is_beta1 g (is_gamma_inhab_rec g) + end + with is_gamma_inhab_rec (x : gamma) : is_gamma x := + match x as i return is_gamma i with + | gamma0 => is_gamma0 + | gamma1 a b => is_gamma1 a (is_alpha_inhab_rec a) b (is_beta_inhab_rec b) + end + for + is_alpha_inhab_rec. + Definition is_beta_inhab : forall x : beta, is_beta x := + fix is_alpha_inhab_rec (x : alpha) : is_alpha x := + match x as i return is_alpha i with + | alpha0 => is_alpha0 + | alpha1 b => is_alpha1 b (is_beta_inhab_rec b) + end + with is_beta_inhab_rec (x : beta) : is_beta x := + match x as i return is_beta i with + | beta0 => is_beta0 + | beta1 g => is_beta1 g (is_gamma_inhab_rec g) + end + with is_gamma_inhab_rec (x : gamma) : is_gamma x := + match x as i return is_gamma i with + | gamma0 => is_gamma0 + | gamma1 a b => is_gamma1 a (is_alpha_inhab_rec a) b (is_beta_inhab_rec b) + end + for + is_beta_inhab_rec. + Definition is_gamma_inhab : forall x : gamma, is_gamma x := + fix is_alpha_inhab_rec (x : alpha) : is_alpha x := + match x as i return is_alpha i with + | alpha0 => is_alpha0 + | alpha1 b => is_alpha1 b (is_beta_inhab_rec b) + end + with is_beta_inhab_rec (x : beta) : is_beta x := + match x as i return is_beta i with + | beta0 => is_beta0 + | beta1 g => is_beta1 g (is_gamma_inhab_rec g) + end + with is_gamma_inhab_rec (x : gamma) : is_gamma x := + match x as i return is_gamma i with + | gamma0 => is_gamma0 + | gamma1 a b => is_gamma1 a (is_alpha_inhab_rec a) b (is_beta_inhab_rec b) + end + for + is_gamma_inhab_rec. + Definition alpha_induction : forall (P : forall _ : alpha, Type) (P0 : forall _ : beta, Type) + (P1 : forall _ : gamma, Type) (_ : P alpha0) + (_ : forall (b : beta) (_ : is_beta b) (_ : P0 b), P (alpha1 b)) + (_ : P0 beta0) + (_ : forall (g : gamma) (_ : is_gamma g) (_ : P1 g), P0 (beta1 g)) + (_ : P1 gamma0) + (_ : forall (a : alpha) (_ : is_alpha a) + (_ : P a) (b : beta) (_ : is_beta b) + (_ : P0 b), + P1 (gamma1 a b)) + (s1 : alpha) (_ : is_alpha s1), + P s1 := + fun (P : forall _ : alpha, Type) (P0 : forall _ : beta, Type) + (P1 : forall _ : gamma, Type) (His_alpha0 : P alpha0) + (His_alpha1 : forall (b : beta) (_ : is_beta b) (_ : P0 b), P (alpha1 b)) + (His_beta0 : P0 beta0) + (His_beta1 : forall (g : gamma) (_ : is_gamma g) (_ : P1 g), P0 (beta1 g)) + (His_gamma0 : P1 gamma0) + (His_gamma1 : forall (a : alpha) (_ : is_alpha a) + (_ : P a) (b : beta) (_ : is_beta b) + (_ : P0 b), + P1 (gamma1 a b)) => + fix is_alpha_induction_rec (s1 : alpha) (H : is_alpha s1) {struct H} : + P s1 := + match H in is_alpha s2 return P s2 with + | is_alpha0 => His_alpha0 + | is_alpha1 b Pb => His_alpha1 b Pb (is_beta_induction_rec b Pb) + end + with is_beta_induction_rec (s1 : beta) (H : is_beta s1) {struct H} : P0 s1 := + match H in is_beta s2 return P0 s2 with + | is_beta0 => His_beta0 + | is_beta1 g Pg => His_beta1 g Pg (is_gamma_induction_rec g Pg) + end + with is_gamma_induction_rec (s1 : gamma) (H : is_gamma s1) {struct H} : + P1 s1 := + match H in is_gamma s2 return P1 s2 with + | is_gamma0 => His_gamma0 + | is_gamma1 a Pa b Pb => + His_gamma1 a Pa (is_alpha_induction_rec a Pa) b Pb + (is_beta_induction_rec b Pb) + end + for + is_alpha_induction_rec. + Definition beta_induction : forall (P : forall _ : alpha, Type) (P0 : forall _ : beta, Type) + (P1 : forall _ : gamma, Type) (_ : P alpha0) + (_ : forall (b : beta) (_ : is_beta b) (_ : P0 b), P (alpha1 b)) + (_ : P0 beta0) + (_ : forall (g : gamma) (_ : is_gamma g) (_ : P1 g), P0 (beta1 g)) + (_ : P1 gamma0) + (_ : forall (a : alpha) (_ : is_alpha a) + (_ : P a) (b : beta) (_ : is_beta b) + (_ : P0 b), + P1 (gamma1 a b)) + (s1 : beta) (_ : is_beta s1), + P0 s1 := + fun (P : forall _ : alpha, Type) (P0 : forall _ : beta, Type) + (P1 : forall _ : gamma, Type) (His_alpha0 : P alpha0) + (His_alpha1 : forall (b : beta) (_ : is_beta b) (_ : P0 b), P (alpha1 b)) + (His_beta0 : P0 beta0) + (His_beta1 : forall (g : gamma) (_ : is_gamma g) (_ : P1 g), P0 (beta1 g)) + (His_gamma0 : P1 gamma0) + (His_gamma1 : forall (a : alpha) (_ : is_alpha a) + (_ : P a) (b : beta) (_ : is_beta b) + (_ : P0 b), + P1 (gamma1 a b)) => + fix is_alpha_induction_rec (s1 : alpha) (H : is_alpha s1) {struct H} : + P s1 := + match H in is_alpha s2 return P s2 with + | is_alpha0 => His_alpha0 + | is_alpha1 b Pb => His_alpha1 b Pb (is_beta_induction_rec b Pb) + end + with is_beta_induction_rec (s1 : beta) (H : is_beta s1) {struct H} : P0 s1 := + match H in is_beta s2 return P0 s2 with + | is_beta0 => His_beta0 + | is_beta1 g Pg => His_beta1 g Pg (is_gamma_induction_rec g Pg) + end + with is_gamma_induction_rec (s1 : gamma) (H : is_gamma s1) {struct H} : + P1 s1 := + match H in is_gamma s2 return P1 s2 with + | is_gamma0 => His_gamma0 + | is_gamma1 a Pa b Pb => + His_gamma1 a Pa (is_alpha_induction_rec a Pa) b Pb + (is_beta_induction_rec b Pb) + end + for + is_beta_induction_rec. + Definition gamma_induction : forall (P : forall _ : alpha, Type) (P0 : forall _ : beta, Type) + (P1 : forall _ : gamma, Type) (_ : P alpha0) + (_ : forall (b : beta) (_ : is_beta b) (_ : P0 b), P (alpha1 b)) + (_ : P0 beta0) + (_ : forall (g : gamma) (_ : is_gamma g) (_ : P1 g), P0 (beta1 g)) + (_ : P1 gamma0) + (_ : forall (a : alpha) (_ : is_alpha a) + (_ : P a) (b : beta) (_ : is_beta b) + (_ : P0 b), + P1 (gamma1 a b)) + (s1 : gamma) (_ : is_gamma s1), + P1 s1 := + fun (P : forall _ : alpha, Type) (P0 : forall _ : beta, Type) + (P1 : forall _ : gamma, Type) (His_alpha0 : P alpha0) + (His_alpha1 : forall (b : beta) (_ : is_beta b) (_ : P0 b), P (alpha1 b)) + (His_beta0 : P0 beta0) + (His_beta1 : forall (g : gamma) (_ : is_gamma g) (_ : P1 g), P0 (beta1 g)) + (His_gamma0 : P1 gamma0) + (His_gamma1 : forall (a : alpha) (_ : is_alpha a) + (_ : P a) (b : beta) (_ : is_beta b) + (_ : P0 b), + P1 (gamma1 a b)) => + fix is_alpha_induction_rec (s1 : alpha) (H : is_alpha s1) {struct H} : + P s1 := + match H in is_alpha s2 return P s2 with + | is_alpha0 => His_alpha0 + | is_alpha1 b Pb => His_alpha1 b Pb (is_beta_induction_rec b Pb) + end + with is_beta_induction_rec (s1 : beta) (H : is_beta s1) {struct H} : P0 s1 := + match H in is_beta s2 return P0 s2 with + | is_beta0 => His_beta0 + | is_beta1 g Pg => His_beta1 g Pg (is_gamma_induction_rec g Pg) + end + with is_gamma_induction_rec (s1 : gamma) (H : is_gamma s1) {struct H} : + P1 s1 := + match H in is_gamma s2 return P1 s2 with + | is_gamma0 => His_gamma0 + | is_gamma1 a Pa b Pb => + His_gamma1 a Pa (is_alpha_induction_rec a Pa) b Pb + (is_beta_induction_rec b Pb) + end + for + is_gamma_induction_rec. + Parameter alpha_eqb_correct : forall x : alpha, @eqb_correct_on alpha alpha_eqb x. + Parameter beta_eqb_correct : forall x : beta, @eqb_correct_on beta beta_eqb x. + Parameter gamma_eqb_correct : forall x : gamma, @eqb_correct_on gamma gamma_eqb x. + Parameter alpha_eqb_refl : forall x : alpha, @eqb_refl_on alpha alpha_eqb x. + Parameter beta_eqb_refl : forall x : beta, @eqb_refl_on beta beta_eqb x. + Parameter gamma_eqb_refl : forall x : gamma, @eqb_refl_on gamma gamma_eqb x. + Parameter alpha_eqb_OK : forall x1 x2 : alpha, reflect (@eq alpha x1 x2) (alpha_eqb x1 x2). + Parameter beta_eqb_OK : forall x1 x2 : beta, reflect (@eq beta x1 x2) (beta_eqb x1 x2). + Parameter gamma_eqb_OK : forall x1 x2 : gamma, reflect (@eq gamma x1 x2) (gamma_eqb x1 x2). + Parameter alpha_eqb_OK_sumbool : forall x y : alpha, sumbool (@eq alpha x y) (not (@eq alpha x y)). + Parameter beta_eqb_OK_sumbool : forall x y : beta, sumbool (@eq beta x y) (not (@eq beta x y)). + Parameter gamma_eqb_OK_sumbool : forall x y : gamma, sumbool (@eq gamma x y) (not (@eq gamma x y)). +End TripleMutualEqbOKExpected. + +Module Type ParametrizedTripleMutualBase. + Inductive palpha (A : Type) : Type := + | palpha0 + | palpha1 (x : A) (b : pbeta A) + with pbeta (A : Type) : Type := + | pbeta0 + | pbeta1 (g : pgamma A) + with pgamma (A : Type) : Type := + | pgamma0 + | pgamma1 (a : palpha A) (b : pbeta A). +End ParametrizedTripleMutualBase. + +Module MutualMap <: MutualMapExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(map)] derive tree. + + Example tree_map_computes : + tree_map (node (cons (node empty) empty)) = node (cons (node empty) empty). + Proof. vm_compute. reflexivity. Qed. + + Example forest_map_computes : + forest_map (cons (node empty) empty) = cons (node empty) empty. + Proof. vm_compute. reflexivity. Qed. +End MutualMap. + +Module MutualLens <: MutualLensExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(lens)] derive tree. +End MutualLens. + +Module MutualLensLaws <: MutualLensLawsExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(lens_laws)] derive tree. +End MutualLensLaws. + +Module MutualParam1 <: MutualParam1Expected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(param1)] derive tree. + + Example is_tree_match_computes : + (match is_node empty is_empty with + | is_node f _ => node f + end) = node empty. + Proof. vm_compute. reflexivity. Qed. + + Example is_forest_match_computes : + (match is_cons (node empty) (is_node empty is_empty) empty is_empty with + | is_empty => empty + | is_cons t _ f _ => cons t f + end) = cons (node empty) empty. + Proof. vm_compute. reflexivity. Qed. +End MutualParam1. + +Module MutualParam1Congr <: MutualParam1CongrExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(param1_congr)] derive tree. + + Example congr_is_node_computes : + congr_is_node empty is_empty is_empty eq_refl = eq_refl. + Proof. vm_compute. reflexivity. Qed. + + Example congr_is_cons_computes : + congr_is_cons (node empty) (is_node empty is_empty) (is_node empty is_empty) + eq_refl empty is_empty is_empty eq_refl = eq_refl. + Proof. vm_compute. reflexivity. Qed. +End MutualParam1Congr. + +Module MutualParam1Trivial <: MutualParam1TrivialExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(param1_trivial)] derive tree. + + Example is_tree_inhab_computes : + is_tree_inhab (node empty) = is_node empty is_empty. + Proof. vm_compute. reflexivity. Qed. + + Example is_forest_inhab_computes : + is_forest_inhab (cons (node empty) empty) = + is_cons (node empty) (is_node empty is_empty) empty is_empty. + Proof. vm_compute. reflexivity. Qed. + + Example is_tree_trivial_witness_computes : + projT1 (is_tree_trivial (node empty)) = is_node empty is_empty. + Proof. vm_compute. reflexivity. Qed. + + Example is_forest_trivial_witness_computes : + projT1 (is_forest_trivial (cons (node empty) empty)) = + is_cons (node empty) (is_node empty is_empty) empty is_empty. + Proof. vm_compute. reflexivity. Qed. +End MutualParam1Trivial. + +Module MutualParam1Functor <: MutualParam1FunctorExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(param1_functor)] derive tree. + + Example is_tree_functor_computes : + is_tree_functor (node empty) (is_node empty is_empty) = is_node empty is_empty. + Proof. vm_compute. reflexivity. Qed. + + Example is_forest_functor_computes : + is_forest_functor (cons (node empty) empty) + (is_cons (node empty) (is_node empty is_empty) empty is_empty) = + is_cons (node empty) (is_node empty is_empty) empty is_empty. + Proof. vm_compute. reflexivity. Qed. +End MutualParam1Functor. + +Module MutualParam2 <: MutualParam2Expected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(param2)] derive tree. + + Example tree_R_match_computes : + (match node_R empty empty empty_R with + | node_R f1 _ _ => node f1 + end) = node empty. + Proof. vm_compute. reflexivity. Qed. + + Example forest_R_match_computes : + (match cons_R (node empty) (node empty) (node_R empty empty empty_R) + empty empty empty_R with + | empty_R => empty + | cons_R t1 _ _ f1 _ _ => cons t1 f1 + end) = cons (node empty) empty. + Proof. vm_compute. reflexivity. Qed. +End MutualParam2. + +Module MutualInduction <: MutualInductionExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(induction)] derive tree. + + Example tree_induction_computes : + tree_induction + (fun _ => nat) (fun _ => nat) + (fun _ _ q => S q) + 0 + (fun _ _ pt _ _ qf => S (pt + qf)) + (node empty) (is_node empty is_empty) = 1. + Proof. vm_compute. reflexivity. Qed. + + Example forest_induction_computes : + forest_induction + (fun _ => nat) (fun _ => nat) + (fun _ _ q => S q) + 0 + (fun _ _ pt _ _ qf => S (pt + qf)) + (cons (node empty) empty) + (is_cons (node empty) (is_node empty is_empty) empty is_empty) = 2. + Proof. vm_compute. reflexivity. Qed. +End MutualInduction. + +Module MutualTag <: MutualTagExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(tag)] derive tree. + + Example tree_tag_computes : tree_tag (node empty) = xH. + Proof. vm_compute. reflexivity. Qed. + + Example forest_tag_empty_computes : forest_tag empty = xH. + Proof. vm_compute. reflexivity. Qed. + + Example forest_tag_cons_computes : forest_tag (cons (node empty) empty) = xO xH. + Proof. vm_compute. reflexivity. Qed. +End MutualTag. + +Module MutualFields <: MutualFieldsExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(fields)] derive tree. + + Example tree_construct_computes : + tree_construct (tree_tag (node empty)) (tree_fields (node empty)) = Some (node empty). + Proof. vm_compute. reflexivity. Qed. + + Example forest_construct_computes : + forest_construct (forest_tag (cons (node empty) empty)) + (forest_fields (cons (node empty) empty)) = Some (cons (node empty) empty). + Proof. vm_compute. reflexivity. Qed. +End MutualFields. + +Module MutualEqb <: MutualEqbExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(eqb)] derive tree. + + Example tree_eqb_computes_equal : + tree_eqb (node empty) (node empty) = true. + Proof. vm_compute. reflexivity. Qed. + + Example tree_eqb_computes_different : + tree_eqb (node empty) (node (cons (node empty) empty)) = false. + Proof. vm_compute. reflexivity. Qed. + + Example forest_eqb_computes_equal : + forest_eqb (cons (node empty) empty) (cons (node empty) empty) = true. + Proof. vm_compute. reflexivity. Qed. + + Example forest_eqb_computes_different : + forest_eqb empty (cons (node empty) empty) = false. + Proof. vm_compute. reflexivity. Qed. +End MutualEqb. + +Module NonRecursiveMutualEqb. + Inductive color : Type := + | red + | blue + with shape : Type := + | circle + | square. + + #[only(eqb)] derive color. + + Example color_eqb_computes_equal : color_eqb red red = true. + Proof. vm_compute. reflexivity. Qed. + + Example color_eqb_computes_different : color_eqb red blue = false. + Proof. vm_compute. reflexivity. Qed. + + Example shape_eqb_computes_equal : shape_eqb circle circle = true. + Proof. vm_compute. reflexivity. Qed. + + Example shape_eqb_computes_different : shape_eqb circle square = false. + Proof. vm_compute. reflexivity. Qed. +End NonRecursiveMutualEqb. + +Module NonRecursiveMutualParam1. + Inductive color : Type := + | red + | blue + with shape : Type := + | circle + | square. + + #[only(param1)] derive color. + + Check is_color : color -> Type. + Check is_shape : shape -> Type. + Check is_red : is_color red. + Check is_circle : is_shape circle. +End NonRecursiveMutualParam1. + +Module NonRecursiveMutualParam2. + Inductive color : Type := + | red + | blue + with shape : Type := + | circle + | square. + + #[only(param2)] derive color. + + Check color_R : color -> color -> Set. + Check shape_R : shape -> shape -> Set. + Check red_R : color_R red red. + Check circle_R : shape_R circle circle. +End NonRecursiveMutualParam2. + +Module Type ValueParamMutualBase. + Inductive a (n : nat) : Type := + | ak (b0 : b n) + with b (n : nat) : Type := + | bk (a0 : a n). +End ValueParamMutualBase. + +Module Type ValueParamMutualEqbExpected. + Include ValueParamMutualBase. + Definition a_tag : forall n : nat, a n -> BinNums.positive := + fun (n : nat) (i : a n) => + match i with + | ak _ _ => BinNums.xH + end. + Definition b_tag : forall n : nat, b n -> BinNums.positive := + fun (n : nat) (i : b n) => + match i with + | bk _ _ => BinNums.xH + end. + Record box_a_ak (n : nat) : Type := Box_a_ak { Box_a_ak_0 : b n }. + Record box_b_bk (n : nat) : Type := Box_b_bk { Box_b_bk_0 : a n }. + Definition a_fields_t : nat -> BinNums.positive -> Type := + fun n _ => box_a_ak n. + Definition b_fields_t : nat -> BinNums.positive -> Type := + fun n _ => box_b_bk n. + Definition a_fields : forall (n : nat) (i : a n), a_fields_t n (a_tag n i) := + fun (n : nat) (i : a n) => + match i as i0 return a_fields_t n (a_tag n i0) with + | ak _ b0 => {| Box_a_ak_0 := b0 |} + end. + Definition b_fields : forall (n : nat) (i : b n), b_fields_t n (b_tag n i) := + fun (n : nat) (i : b n) => + match i as i0 return b_fields_t n (b_tag n i0) with + | bk _ a0 => {| Box_b_bk_0 := a0 |} + end. + Definition a_construct : forall n : nat, BinNums.positive -> a_fields_t n BinNums.xH -> option (a n) := + fun (n : nat) (_ : BinNums.positive) (bx : box_a_ak n) => + match bx with + | {| Box_a_ak_0 := b0 |} => Some (ak n b0) + end. + Definition b_construct : forall n : nat, BinNums.positive -> b_fields_t n BinNums.xH -> option (b n) := + fun (n : nat) (_ : BinNums.positive) (bx : box_b_bk n) => + match bx with + | {| Box_b_bk_0 := a0 |} => Some (bk n a0) + end. + Parameter a_constructP : forall (n : nat) (i : a n), + a_construct n (a_tag n i) (a_fields n i) = Some i. + Parameter b_constructP : forall (n : nat) (i : b n), + b_construct n (b_tag n i) (b_fields n i) = Some i. + Definition a_eqb : forall n m : nat, a n -> a m -> bool := + fix a_eqb_rec (n m : nat) (x : a n) (y : a m) {struct x} : bool := + match x with + | ak _ bx => + match y with + | ak _ by0 => b_eqb_rec n m bx by0 + end + end + with b_eqb_rec (n m : nat) (x : b n) (y : b m) {struct x} : bool := + match x with + | bk _ ax => + match y with + | bk _ ay => a_eqb_rec n m ax ay + end + end + for a_eqb_rec. + Definition b_eqb : forall n m : nat, b n -> b m -> bool := + fix a_eqb_rec (n m : nat) (x : a n) (y : a m) {struct x} : bool := + match x with + | ak _ bx => + match y with + | ak _ by0 => b_eqb_rec n m bx by0 + end + end + with b_eqb_rec (n m : nat) (x : b n) (y : b m) {struct x} : bool := + match x with + | bk _ ax => + match y with + | bk _ ay => a_eqb_rec n m ax ay + end + end + for b_eqb_rec. + Definition a_eqb_fields : forall n m : nat, + (a n -> a m -> bool) -> + BinNums.positive -> box_a_ak n -> box_a_ak m -> bool := + fun (n m : nat) (_ : a n -> a m -> bool) (_ : BinNums.positive) + (x : box_a_ak n) (y : box_a_ak m) => + match x with + | {| Box_a_ak_0 := bx |} => + match y with + | {| Box_a_ak_0 := by0 |} => b_eqb n m bx by0 + end + end. + Definition b_eqb_fields : forall n m : nat, + (b n -> b m -> bool) -> + BinNums.positive -> box_b_bk n -> box_b_bk m -> bool := + fun (n m : nat) (_ : b n -> b m -> bool) (_ : BinNums.positive) + (x : box_b_bk n) (y : box_b_bk m) => + match x with + | {| Box_b_bk_0 := ax |} => + match y with + | {| Box_b_bk_0 := ay |} => a_eqb n m ax ay + end + end. +End ValueParamMutualEqbExpected. + +Module ValueParamMutualEqbUnsupported. + Inductive a (n : nat) : Type := + | ak (b0 : b n) + with b (n : nat) : Type := + | bk (a0 : a n). + + Fail #[only(eqb)] derive a. +End ValueParamMutualEqbUnsupported. + +Module MutualEqbCorrect <: MutualEqbCorrectExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(eqbcorrect)] derive tree. + + Ltac transparent_function c := + let t := eval cbv delta [c] in c in + lazymatch t with + | fun _ => _ => idtac + | _ => fail 1 "expected" c "to unfold to a function" + end. + + Example tree_eqb_refl_is_transparent : True. + Proof. transparent_function tree_eqb_refl. exact I. Qed. + + Example forest_eqb_refl_is_transparent : True. + Proof. transparent_function forest_eqb_refl. exact I. Qed. + + Example tree_eqb_correct_is_transparent : True. + Proof. transparent_function tree_eqb_correct. exact I. Qed. + + Example forest_eqb_correct_is_transparent : True. + Proof. transparent_function forest_eqb_correct. exact I. Qed. +End MutualEqbCorrect. + +Module MutualEqbOK <: MutualEqbOKExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(eqbOK)] derive tree. +End MutualEqbOK. + +Module MutualIsK <: MutualIsKExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(isK)] derive tree. + + Example tree_isk_node_computes : tree_isk_node (node empty) = true. + Proof. vm_compute. reflexivity. Qed. + + Example forest_isk_empty_computes : forest_isk_empty empty = true. + Proof. vm_compute. reflexivity. Qed. + + Example forest_isk_cons_computes : forest_isk_cons (cons (node empty) empty) = true. + Proof. vm_compute. reflexivity. Qed. + + Example forest_isk_empty_rejects_cons : forest_isk_empty (cons (node empty) empty) = false. + Proof. vm_compute. reflexivity. Qed. +End MutualIsK. + +Module MutualProjK <: MutualProjKExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(projK)] derive tree. + + Example tree_getk_node1_computes : + tree_getk_node1 empty (node (cons (node empty) empty)) = cons (node empty) empty. + Proof. vm_compute. reflexivity. Qed. + + Example forest_getk_cons1_computes : + forest_getk_cons1 (node empty) empty (cons (node empty) empty) = node empty. + Proof. vm_compute. reflexivity. Qed. + + Example forest_getk_cons2_computes : + forest_getk_cons2 (node empty) empty (cons (node empty) (cons (node empty) empty)) = + cons (node empty) empty. + Proof. vm_compute. reflexivity. Qed. +End MutualProjK. + +Module MutualBcongr <: MutualBcongrExpected. + Inductive tree : Type := + | node (f : forest) + with forest : Type := + | empty + | cons (t : tree) (f : forest). + + #[only(bcongr)] derive tree. + + Example tree_bcongr_node_works : + reflect (node empty = node empty) true. + Proof. exact (tree_bcongr_node empty empty true (ReflectT _ eq_refl)). Qed. + + Example forest_bcongr_cons_works : + reflect (cons (node empty) empty = cons (node empty) empty) true. + Proof. + exact (forest_bcongr_cons (node empty) (node empty) true (ReflectT _ eq_refl) + empty empty true (ReflectT _ eq_refl)). + Qed. +End MutualBcongr. + +Module ParametrizedMutualMap <: ParametrizedMutualMapExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(map)] derive ptree. + + Example ptree_map_computes : + ptree_map nat bool Nat.even (pnode nat 2 (pempty nat)) = + pnode bool true (pempty bool). + Proof. vm_compute. reflexivity. Qed. + + Example pforest_map_computes : + pforest_map nat bool Nat.even + (pcons nat (pnode nat 3 (pempty nat)) (pempty nat)) = + pcons bool (pnode bool false (pempty bool)) (pempty bool). + Proof. vm_compute. reflexivity. Qed. +End ParametrizedMutualMap. + +Module ParametrizedMutualLens <: ParametrizedMutualLensExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(lens)] derive ptree. +End ParametrizedMutualLens. + +Module ParametrizedMutualLensLaws <: ParametrizedMutualLensLawsExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(lens_laws)] derive ptree. +End ParametrizedMutualLensLaws. + +Module ParametrizedMutualParam1 <: ParametrizedMutualParam1Expected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(param1)] derive ptree. + + Example is_ptree_match_computes : + (match is_pnode nat (fun _ => unit) 2 tt (pempty nat) + (is_pempty nat (fun _ => unit)) + in is_ptree A _ _ return ptree A with + | is_pnode A _ x _ f _ => pnode A x f + end) = pnode nat 2 (pempty nat). + Proof. vm_compute. reflexivity. Qed. + + Example is_pforest_match_computes : + (match is_pcons nat (fun _ => unit) (pnode nat 2 (pempty nat)) + (is_pnode nat (fun _ => unit) 2 tt (pempty nat) + (is_pempty nat (fun _ => unit))) + (pempty nat) (is_pempty nat (fun _ => unit)) + in is_pforest A _ _ return pforest A with + | is_pempty A _ => pempty A + | is_pcons A _ t _ f _ => pcons A t f + end) = pcons nat (pnode nat 2 (pempty nat)) (pempty nat). + Proof. vm_compute. reflexivity. Qed. +End ParametrizedMutualParam1. + +Module ParametrizedMutualParam1Congr <: ParametrizedMutualParam1CongrExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(param1_congr)] derive ptree. + + Example congr_is_pnode_computes : + congr_is_pnode nat (fun _ => unit) 2 tt tt eq_refl + (pempty nat) (is_pempty nat (fun _ => unit)) + (is_pempty nat (fun _ => unit)) eq_refl = eq_refl. + Proof. vm_compute. reflexivity. Qed. + + Example congr_is_pcons_computes : + congr_is_pcons nat (fun _ => unit) (pnode nat 2 (pempty nat)) + (is_pnode nat (fun _ => unit) 2 tt (pempty nat) + (is_pempty nat (fun _ => unit))) + (is_pnode nat (fun _ => unit) 2 tt (pempty nat) + (is_pempty nat (fun _ => unit))) eq_refl + (pempty nat) (is_pempty nat (fun _ => unit)) + (is_pempty nat (fun _ => unit)) eq_refl = eq_refl. + Proof. vm_compute. reflexivity. Qed. +End ParametrizedMutualParam1Congr. + +Module ParametrizedMutualParam1TrivialUnsupported. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + Fail #[only(param1_trivial)] derive ptree. +End ParametrizedMutualParam1TrivialUnsupported. + +Module ParametrizedMutualParam1Functor <: ParametrizedMutualParam1FunctorExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(param1_functor)] derive ptree. +End ParametrizedMutualParam1Functor. + +Module ParametrizedMutualParam2 <: ParametrizedMutualParam2Expected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(param2)] derive ptree. + + Definition nat_eq_relation := fun x y : nat => x = y. + Definition pnode_R_example := + pnode_R nat nat nat_eq_relation 2 2 eq_refl + (pempty nat) (pempty nat) (pempty_R nat nat nat_eq_relation). + + Example ptree_R_match_computes : + (match pnode_R_example in ptree_R A1 _ _ _ _ return ptree A1 with + | pnode_R A1 _ _ x1 _ _ f1 _ _ => pnode A1 x1 f1 + end) = pnode nat 2 (pempty nat). + Proof. vm_compute. reflexivity. Qed. + + Example pforest_R_match_computes : + (match pcons_R nat nat nat_eq_relation + (pnode nat 2 (pempty nat)) (pnode nat 2 (pempty nat)) pnode_R_example + (pempty nat) (pempty nat) (pempty_R nat nat nat_eq_relation) + in pforest_R A1 _ _ _ _ return pforest A1 with + | pempty_R A1 _ _ => pempty A1 + | pcons_R A1 _ _ t1 _ _ f1 _ _ => pcons A1 t1 f1 + end) = pcons nat (pnode nat 2 (pempty nat)) (pempty nat). + Proof. vm_compute. reflexivity. Qed. +End ParametrizedMutualParam2. + +Module ParametrizedMutualInduction <: ParametrizedMutualInductionExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(induction)] derive ptree. +End ParametrizedMutualInduction. + +Module ParametrizedMutualTag <: ParametrizedMutualTagExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(tag)] derive ptree. + + Example ptree_tag_computes : + ptree_tag nat (pnode nat 2 (pempty nat)) = xH. + Proof. vm_compute. reflexivity. Qed. + + Example pforest_tag_empty_computes : pforest_tag nat (pempty nat) = xH. + Proof. vm_compute. reflexivity. Qed. + + Example pforest_tag_cons_computes : + pforest_tag nat (pcons nat (pnode nat 2 (pempty nat)) (pempty nat)) = xO xH. + Proof. vm_compute. reflexivity. Qed. +End ParametrizedMutualTag. + +Module ParametrizedMutualFields <: ParametrizedMutualFieldsExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(fields)] derive ptree. + + Example ptree_construct_computes : + ptree_construct nat (ptree_tag nat (pnode nat 2 (pempty nat))) + (ptree_fields nat (pnode nat 2 (pempty nat))) = Some (pnode nat 2 (pempty nat)). + Proof. vm_compute. reflexivity. Qed. + + Example pforest_construct_computes : + pforest_construct nat + (pforest_tag nat (pcons nat (pnode nat 2 (pempty nat)) (pempty nat))) + (pforest_fields nat (pcons nat (pnode nat 2 (pempty nat)) (pempty nat))) = + Some (pcons nat (pnode nat 2 (pempty nat)) (pempty nat)). + Proof. vm_compute. reflexivity. Qed. +End ParametrizedMutualFields. + +Module ParametrizedMutualEqb <: ParametrizedMutualEqbExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(eqb)] derive ptree. + + Example ptree_eqb_computes_equal : + ptree_eqb nat Nat.eqb (pnode nat 2 (pempty nat)) (pnode nat 2 (pempty nat)) = true. + Proof. vm_compute. reflexivity. Qed. + + Example ptree_eqb_computes_different : + ptree_eqb nat Nat.eqb (pnode nat 2 (pempty nat)) (pnode nat 3 (pempty nat)) = false. + Proof. vm_compute. reflexivity. Qed. + + Example pforest_eqb_computes_equal : + pforest_eqb nat Nat.eqb + (pcons nat (pnode nat 2 (pempty nat)) (pempty nat)) + (pcons nat (pnode nat 2 (pempty nat)) (pempty nat)) = true. + Proof. vm_compute. reflexivity. Qed. + + Example pforest_eqb_computes_different : + pforest_eqb nat Nat.eqb + (pcons nat (pnode nat 2 (pempty nat)) (pempty nat)) + (pcons nat (pnode nat 3 (pempty nat)) (pempty nat)) = false. + Proof. vm_compute. reflexivity. Qed. +End ParametrizedMutualEqb. + +Module ParametrizedMutualEqbCorrect <: ParametrizedMutualEqbCorrectExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(eqbcorrect)] derive ptree. +End ParametrizedMutualEqbCorrect. + +Module ParametrizedMutualEqbOK <: ParametrizedMutualEqbOKExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(eqbOK)] derive ptree. +End ParametrizedMutualEqbOK. + +Module ParametrizedMutualIsK <: ParametrizedMutualIsKExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(isK)] derive ptree. + + Example ptree_isk_pnode_computes : + ptree_isk_pnode nat (pnode nat 2 (pempty nat)) = true. + Proof. vm_compute. reflexivity. Qed. + + Example pforest_isk_pempty_computes : pforest_isk_pempty nat (pempty nat) = true. + Proof. vm_compute. reflexivity. Qed. + + Example pforest_isk_pcons_computes : + pforest_isk_pcons nat (pcons nat (pnode nat 2 (pempty nat)) (pempty nat)) = true. + Proof. vm_compute. reflexivity. Qed. +End ParametrizedMutualIsK. + +Module ParametrizedMutualProjK <: ParametrizedMutualProjKExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(projK)] derive ptree. + + Example ptree_getk_pnode1_computes : + ptree_getk_pnode1 nat 0 (pempty nat) (pnode nat 2 (pempty nat)) = 2. + Proof. vm_compute. reflexivity. Qed. + + Example ptree_getk_pnode2_computes : + ptree_getk_pnode2 nat 0 (pempty nat) (pnode nat 2 (pcons nat (pnode nat 3 (pempty nat)) (pempty nat))) = + pcons nat (pnode nat 3 (pempty nat)) (pempty nat). + Proof. vm_compute. reflexivity. Qed. + + Example pforest_getk_pcons1_computes : + pforest_getk_pcons1 nat (pnode nat 0 (pempty nat)) (pempty nat) + (pcons nat (pnode nat 2 (pempty nat)) (pempty nat)) = pnode nat 2 (pempty nat). + Proof. vm_compute. reflexivity. Qed. + + Example pforest_getk_pcons2_computes : + pforest_getk_pcons2 nat (pnode nat 0 (pempty nat)) (pempty nat) + (pcons nat (pnode nat 2 (pempty nat)) (pcons nat (pnode nat 3 (pempty nat)) (pempty nat))) = + pcons nat (pnode nat 3 (pempty nat)) (pempty nat). + Proof. vm_compute. reflexivity. Qed. +End ParametrizedMutualProjK. + +Module ParametrizedMutualBcongr <: ParametrizedMutualBcongrExpected. + Inductive ptree (A : Type) : Type := + | pnode (x : A) (f : pforest A) + with pforest (A : Type) : Type := + | pempty + | pcons (t : ptree A) (f : pforest A). + + #[only(bcongr)] derive ptree. + + Example ptree_bcongr_pnode_works : + reflect (pnode nat 2 (pempty nat) = pnode nat 2 (pempty nat)) true. + Proof. + exact (ptree_bcongr_pnode nat 2 2 true (ReflectT _ eq_refl) + (pempty nat) (pempty nat) true (ReflectT _ eq_refl)). + Qed. + + Example pforest_bcongr_pcons_works : + reflect (pcons nat (pnode nat 2 (pempty nat)) (pempty nat) = + pcons nat (pnode nat 2 (pempty nat)) (pempty nat)) true. + Proof. + exact (pforest_bcongr_pcons nat + (pnode nat 2 (pempty nat)) (pnode nat 2 (pempty nat)) true (ReflectT _ eq_refl) + (pempty nat) (pempty nat) true (ReflectT _ eq_refl)). + Qed. +End ParametrizedMutualBcongr. + +Module TripleMutualMapFromGamma <: TripleMutualMapExpected. + Inductive alpha : Type := + | alpha0 + | alpha1 (b : beta) + with beta : Type := + | beta0 + | beta1 (g : gamma) + with gamma : Type := + | gamma0 + | gamma1 (a : alpha) (b : beta). + + #[only(map)] derive gamma. + + Example alpha_map_computes : + alpha_map (alpha1 (beta1 gamma0)) = alpha1 (beta1 gamma0). + Proof. vm_compute. reflexivity. Qed. + + Example beta_map_computes : beta_map (beta1 gamma0) = beta1 gamma0. + Proof. vm_compute. reflexivity. Qed. + + Example gamma_map_computes : + gamma_map (gamma1 (alpha1 beta0) beta0) = gamma1 (alpha1 beta0) beta0. + Proof. vm_compute. reflexivity. Qed. +End TripleMutualMapFromGamma. + +Module TripleMutualEqbFromAlpha <: TripleMutualEqbExpected. + Inductive alpha : Type := + | alpha0 + | alpha1 (b : beta) + with beta : Type := + | beta0 + | beta1 (g : gamma) + with gamma : Type := + | gamma0 + | gamma1 (a : alpha) (b : beta). + + #[only(eqb)] derive alpha. +End TripleMutualEqbFromAlpha. + +Module TripleMutualEqbFromBeta <: TripleMutualEqbExpected. + Inductive alpha : Type := + | alpha0 + | alpha1 (b : beta) + with beta : Type := + | beta0 + | beta1 (g : gamma) + with gamma : Type := + | gamma0 + | gamma1 (a : alpha) (b : beta). + + #[only(eqb)] derive beta. +End TripleMutualEqbFromBeta. + +Module TripleMutualEqbFromGamma <: TripleMutualEqbExpected. + Inductive alpha : Type := + | alpha0 + | alpha1 (b : beta) + with beta : Type := + | beta0 + | beta1 (g : gamma) + with gamma : Type := + | gamma0 + | gamma1 (a : alpha) (b : beta). + + #[only(eqb)] derive gamma. +End TripleMutualEqbFromGamma. + +Module TripleMutualEqbOKFromBeta <: TripleMutualEqbOKExpected. + Inductive alpha : Type := + | alpha0 + | alpha1 (b : beta) + with beta : Type := + | beta0 + | beta1 (g : gamma) + with gamma : Type := + | gamma0 + | gamma1 (a : alpha) (b : beta). + + #[only(eqbOK)] derive beta. + + Example alpha_eqb_computes_equal : alpha_eqb (alpha1 beta0) (alpha1 beta0) = true. + Proof. vm_compute. reflexivity. Qed. + + Example alpha_eqb_computes_different : alpha_eqb alpha0 (alpha1 beta0) = false. + Proof. vm_compute. reflexivity. Qed. + + Example beta_eqb_computes_equal : beta_eqb (beta1 gamma0) (beta1 gamma0) = true. + Proof. vm_compute. reflexivity. Qed. + + Example gamma_eqb_computes_different : + gamma_eqb (gamma1 alpha0 beta0) (gamma1 (alpha1 beta0) beta0) = false. + Proof. vm_compute. reflexivity. Qed. +End TripleMutualEqbOKFromBeta. + +Module Type ParametrizedTripleMutualEqbOKExpected. + Include ParametrizedTripleMutualBase. + Definition palpha_tag : forall A : Type, palpha A -> positive := + fun (A : Type) (i : palpha A) => + match i with + | palpha0 _ => xH + | palpha1 _ _ _ => xO xH + end. + Definition pbeta_tag : forall A : Type, pbeta A -> positive := + fun (A : Type) (i : pbeta A) => + match i with + | pbeta0 _ => xH + | pbeta1 _ _ => xO xH + end. + Definition pgamma_tag : forall A : Type, pgamma A -> positive := + fun (A : Type) (i : pgamma A) => + match i with + | pgamma0 _ => xH + | pgamma1 _ _ _ => xO xH + end. + Record box_palpha_palpha0 (A : Type) : Type := Box_palpha_palpha0 {}. + Record box_palpha_palpha1 (A : Type) : Type := Box_palpha_palpha1 { + Box_palpha_palpha1_0 : A; + Box_palpha_palpha1_1 : pbeta A; + }. + Record box_pbeta_pbeta0 (A : Type) : Type := Box_pbeta_pbeta0 {}. + Record box_pbeta_pbeta1 (A : Type) : Type := Box_pbeta_pbeta1 { + Box_pbeta_pbeta1_0 : pgamma A; + }. + Record box_pgamma_pgamma0 (A : Type) : Type := Box_pgamma_pgamma0 {}. + Record box_pgamma_pgamma1 (A : Type) : Type := Box_pgamma_pgamma1 { + Box_pgamma_pgamma1_0 : palpha A; + Box_pgamma_pgamma1_1 : pbeta A; + }. + Definition palpha_fields_t : Type -> positive -> Type := + fun (A : Type) (i : positive) => + match i with + | xI _ => unit + | xO _ => box_palpha_palpha1 A + | xH => box_palpha_palpha0 A + end. + Definition pbeta_fields_t : Type -> positive -> Type := + fun (A : Type) (i : positive) => + match i with + | xI _ => unit + | xO _ => box_pbeta_pbeta1 A + | xH => box_pbeta_pbeta0 A + end. + Definition pgamma_fields_t : Type -> positive -> Type := + fun (A : Type) (i : positive) => + match i with + | xI _ => unit + | xO _ => box_pgamma_pgamma1 A + | xH => box_pgamma_pgamma0 A + end. + Definition palpha_fields : + forall (A : Type) (i : palpha A), palpha_fields_t A (palpha_tag A i) := + fun (A : Type) (i : palpha A) => + match i with + | palpha0 _ => Box_palpha_palpha0 A + | palpha1 _ x b => {| Box_palpha_palpha1_0 := x; Box_palpha_palpha1_1 := b |} + end. + Definition pbeta_fields : + forall (A : Type) (i : pbeta A), pbeta_fields_t A (pbeta_tag A i) := + fun (A : Type) (i : pbeta A) => + match i with + | pbeta0 _ => Box_pbeta_pbeta0 A + | pbeta1 _ g => {| Box_pbeta_pbeta1_0 := g |} + end. + Definition pgamma_fields : + forall (A : Type) (i : pgamma A), pgamma_fields_t A (pgamma_tag A i) := + fun (A : Type) (i : pgamma A) => + match i with + | pgamma0 _ => Box_pgamma_pgamma0 A + | pgamma1 _ a b => {| Box_pgamma_pgamma1_0 := a; Box_pgamma_pgamma1_1 := b |} + end. + Definition palpha_eqb : forall A : Type, + (A -> A -> bool) -> palpha A -> palpha A -> bool := + fun (a : Type) (eqA : a -> a -> bool) => + fix palpha (x1 x2 : palpha a) {struct x1} : bool := + match x1 with + | palpha0 _ => + eqb_body (tagB:=palpha_tag a) + (fields_tA:=palpha_fields_t a) (fields_tB:=palpha_fields_t a) + (palpha_fields a) + (fun x : positive => + match x as i return palpha_fields_t a i -> palpha_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_palpha_palpha1 a => + match a0 with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_0; + Box_palpha_palpha1_1 := Box_palpha_palpha1_1 |} => + match b with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_2; + Box_palpha_palpha1_1 := Box_palpha_palpha1_3 |} => + [&& eqA Box_palpha_palpha1_0 Box_palpha_palpha1_2, + pbeta Box_palpha_palpha1_1 Box_palpha_palpha1_3 & true] + end + end + | xH => fun _ : box_palpha_palpha0 a => xpredT + end) + (t1:=palpha_tag a (palpha0 a)) (Box_palpha_palpha0 a) x2 + | palpha1 _ x b => + eqb_body (tagB:=palpha_tag a) + (fields_tA:=palpha_fields_t a) (fields_tB:=palpha_fields_t a) + (palpha_fields a) + (fun x0 : positive => + match x0 as i return palpha_fields_t a i -> palpha_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b0 : box_palpha_palpha1 a => + match a0 with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_0; + Box_palpha_palpha1_1 := Box_palpha_palpha1_1 |} => + match b0 with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_2; + Box_palpha_palpha1_1 := Box_palpha_palpha1_3 |} => + [&& eqA Box_palpha_palpha1_0 Box_palpha_palpha1_2, + pbeta Box_palpha_palpha1_1 Box_palpha_palpha1_3 & true] + end + end + | xH => fun _ : box_palpha_palpha0 a => xpredT + end) + (t1:=palpha_tag a (palpha1 a x b)) + {| Box_palpha_palpha1_0 := x; Box_palpha_palpha1_1 := b |} x2 + end + with pbeta (x1 x2 : pbeta a) {struct x1} : bool := + match x1 with + | pbeta0 _ => + eqb_body (tagB:=pbeta_tag a) + (fields_tA:=pbeta_fields_t a) (fields_tB:=pbeta_fields_t a) + (pbeta_fields a) + (fun x : positive => + match x as i return pbeta_fields_t a i -> pbeta_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_pbeta_pbeta1 a => + match a0 with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_0 |} => + match b with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_1 |} => + pgamma Box_pbeta_pbeta1_0 Box_pbeta_pbeta1_1 && true + end + end + | xH => fun _ : box_pbeta_pbeta0 a => xpredT + end) + (t1:=pbeta_tag a (pbeta0 a)) (Box_pbeta_pbeta0 a) x2 + | pbeta1 _ g => + eqb_body (tagB:=pbeta_tag a) + (fields_tA:=pbeta_fields_t a) (fields_tB:=pbeta_fields_t a) + (pbeta_fields a) + (fun x : positive => + match x as i return pbeta_fields_t a i -> pbeta_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_pbeta_pbeta1 a => + match a0 with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_0 |} => + match b with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_1 |} => + pgamma Box_pbeta_pbeta1_0 Box_pbeta_pbeta1_1 && true + end + end + | xH => fun _ : box_pbeta_pbeta0 a => xpredT + end) + (t1:=pbeta_tag a (pbeta1 a g)) {| Box_pbeta_pbeta1_0 := g |} x2 + end + with pgamma (x1 x2 : pgamma a) {struct x1} : bool := + match x1 with + | pgamma0 _ => + eqb_body (tagB:=pgamma_tag a) + (fields_tA:=pgamma_fields_t a) (fields_tB:=pgamma_fields_t a) + (pgamma_fields a) + (fun x : positive => + match x as i return pgamma_fields_t a i -> pgamma_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_pgamma_pgamma1 a => + match a0 with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_0; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_1 |} => + match b with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_2; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_3 |} => + [&& palpha Box_pgamma_pgamma1_0 Box_pgamma_pgamma1_2, + pbeta Box_pgamma_pgamma1_1 Box_pgamma_pgamma1_3 & true] + end + end + | xH => fun _ : box_pgamma_pgamma0 a => xpredT + end) + (t1:=pgamma_tag a (pgamma0 a)) (Box_pgamma_pgamma0 a) x2 + | pgamma1 _ a0 b => + eqb_body (tagB:=pgamma_tag a) + (fields_tA:=pgamma_fields_t a) (fields_tB:=pgamma_fields_t a) + (pgamma_fields a) + (fun x : positive => + match x as i return pgamma_fields_t a i -> pgamma_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a1 b0 : box_pgamma_pgamma1 a => + match a1 with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_0; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_1 |} => + match b0 with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_2; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_3 |} => + [&& palpha Box_pgamma_pgamma1_0 Box_pgamma_pgamma1_2, + pbeta Box_pgamma_pgamma1_1 Box_pgamma_pgamma1_3 & true] + end + end + | xH => fun _ : box_pgamma_pgamma0 a => xpredT + end) + (t1:=pgamma_tag a (pgamma1 a a0 b)) + {| Box_pgamma_pgamma1_0 := a0; Box_pgamma_pgamma1_1 := b |} x2 + end + for palpha. + Definition pbeta_eqb : forall A : Type, + (A -> A -> bool) -> pbeta A -> pbeta A -> bool := + fun (a : Type) (eqA : a -> a -> bool) => + fix palpha (x1 x2 : palpha a) {struct x1} : bool := + match x1 with + | palpha0 _ => + eqb_body (tagB:=palpha_tag a) + (fields_tA:=palpha_fields_t a) (fields_tB:=palpha_fields_t a) + (palpha_fields a) + (fun x : positive => + match x as i return palpha_fields_t a i -> palpha_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_palpha_palpha1 a => + match a0 with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_0; + Box_palpha_palpha1_1 := Box_palpha_palpha1_1 |} => + match b with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_2; + Box_palpha_palpha1_1 := Box_palpha_palpha1_3 |} => + [&& eqA Box_palpha_palpha1_0 Box_palpha_palpha1_2, + pbeta Box_palpha_palpha1_1 Box_palpha_palpha1_3 & true] + end + end + | xH => fun _ : box_palpha_palpha0 a => xpredT + end) + (t1:=palpha_tag a (palpha0 a)) (Box_palpha_palpha0 a) x2 + | palpha1 _ x b => + eqb_body (tagB:=palpha_tag a) + (fields_tA:=palpha_fields_t a) (fields_tB:=palpha_fields_t a) + (palpha_fields a) + (fun x0 : positive => + match x0 as i return palpha_fields_t a i -> palpha_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b0 : box_palpha_palpha1 a => + match a0 with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_0; + Box_palpha_palpha1_1 := Box_palpha_palpha1_1 |} => + match b0 with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_2; + Box_palpha_palpha1_1 := Box_palpha_palpha1_3 |} => + [&& eqA Box_palpha_palpha1_0 Box_palpha_palpha1_2, + pbeta Box_palpha_palpha1_1 Box_palpha_palpha1_3 & true] + end + end + | xH => fun _ : box_palpha_palpha0 a => xpredT + end) + (t1:=palpha_tag a (palpha1 a x b)) + {| Box_palpha_palpha1_0 := x; Box_palpha_palpha1_1 := b |} x2 + end + with pbeta (x1 x2 : pbeta a) {struct x1} : bool := + match x1 with + | pbeta0 _ => + eqb_body (tagB:=pbeta_tag a) + (fields_tA:=pbeta_fields_t a) (fields_tB:=pbeta_fields_t a) + (pbeta_fields a) + (fun x : positive => + match x as i return pbeta_fields_t a i -> pbeta_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_pbeta_pbeta1 a => + match a0 with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_0 |} => + match b with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_1 |} => + pgamma Box_pbeta_pbeta1_0 Box_pbeta_pbeta1_1 && true + end + end + | xH => fun _ : box_pbeta_pbeta0 a => xpredT + end) + (t1:=pbeta_tag a (pbeta0 a)) (Box_pbeta_pbeta0 a) x2 + | pbeta1 _ g => + eqb_body (tagB:=pbeta_tag a) + (fields_tA:=pbeta_fields_t a) (fields_tB:=pbeta_fields_t a) + (pbeta_fields a) + (fun x : positive => + match x as i return pbeta_fields_t a i -> pbeta_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_pbeta_pbeta1 a => + match a0 with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_0 |} => + match b with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_1 |} => + pgamma Box_pbeta_pbeta1_0 Box_pbeta_pbeta1_1 && true + end + end + | xH => fun _ : box_pbeta_pbeta0 a => xpredT + end) + (t1:=pbeta_tag a (pbeta1 a g)) {| Box_pbeta_pbeta1_0 := g |} x2 + end + with pgamma (x1 x2 : pgamma a) {struct x1} : bool := + match x1 with + | pgamma0 _ => + eqb_body (tagB:=pgamma_tag a) + (fields_tA:=pgamma_fields_t a) (fields_tB:=pgamma_fields_t a) + (pgamma_fields a) + (fun x : positive => + match x as i return pgamma_fields_t a i -> pgamma_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_pgamma_pgamma1 a => + match a0 with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_0; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_1 |} => + match b with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_2; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_3 |} => + [&& palpha Box_pgamma_pgamma1_0 Box_pgamma_pgamma1_2, + pbeta Box_pgamma_pgamma1_1 Box_pgamma_pgamma1_3 & true] + end + end + | xH => fun _ : box_pgamma_pgamma0 a => xpredT + end) + (t1:=pgamma_tag a (pgamma0 a)) (Box_pgamma_pgamma0 a) x2 + | pgamma1 _ a0 b => + eqb_body (tagB:=pgamma_tag a) + (fields_tA:=pgamma_fields_t a) (fields_tB:=pgamma_fields_t a) + (pgamma_fields a) + (fun x : positive => + match x as i return pgamma_fields_t a i -> pgamma_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a1 b0 : box_pgamma_pgamma1 a => + match a1 with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_0; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_1 |} => + match b0 with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_2; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_3 |} => + [&& palpha Box_pgamma_pgamma1_0 Box_pgamma_pgamma1_2, + pbeta Box_pgamma_pgamma1_1 Box_pgamma_pgamma1_3 & true] + end + end + | xH => fun _ : box_pgamma_pgamma0 a => xpredT + end) + (t1:=pgamma_tag a (pgamma1 a a0 b)) + {| Box_pgamma_pgamma1_0 := a0; Box_pgamma_pgamma1_1 := b |} x2 + end + for pbeta. + Definition pgamma_eqb : forall A : Type, + (A -> A -> bool) -> pgamma A -> pgamma A -> bool := + fun (a : Type) (eqA : a -> a -> bool) => + fix palpha (x1 x2 : palpha a) {struct x1} : bool := + match x1 with + | palpha0 _ => + eqb_body (tagB:=palpha_tag a) + (fields_tA:=palpha_fields_t a) (fields_tB:=palpha_fields_t a) + (palpha_fields a) + (fun x : positive => + match x as i return palpha_fields_t a i -> palpha_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_palpha_palpha1 a => + match a0 with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_0; + Box_palpha_palpha1_1 := Box_palpha_palpha1_1 |} => + match b with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_2; + Box_palpha_palpha1_1 := Box_palpha_palpha1_3 |} => + [&& eqA Box_palpha_palpha1_0 Box_palpha_palpha1_2, + pbeta Box_palpha_palpha1_1 Box_palpha_palpha1_3 & true] + end + end + | xH => fun _ : box_palpha_palpha0 a => xpredT + end) + (t1:=palpha_tag a (palpha0 a)) (Box_palpha_palpha0 a) x2 + | palpha1 _ x b => + eqb_body (tagB:=palpha_tag a) + (fields_tA:=palpha_fields_t a) (fields_tB:=palpha_fields_t a) + (palpha_fields a) + (fun x0 : positive => + match x0 as i return palpha_fields_t a i -> palpha_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b0 : box_palpha_palpha1 a => + match a0 with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_0; + Box_palpha_palpha1_1 := Box_palpha_palpha1_1 |} => + match b0 with + | {| Box_palpha_palpha1_0 := Box_palpha_palpha1_2; + Box_palpha_palpha1_1 := Box_palpha_palpha1_3 |} => + [&& eqA Box_palpha_palpha1_0 Box_palpha_palpha1_2, + pbeta Box_palpha_palpha1_1 Box_palpha_palpha1_3 & true] + end + end + | xH => fun _ : box_palpha_palpha0 a => xpredT + end) + (t1:=palpha_tag a (palpha1 a x b)) + {| Box_palpha_palpha1_0 := x; Box_palpha_palpha1_1 := b |} x2 + end + with pbeta (x1 x2 : pbeta a) {struct x1} : bool := + match x1 with + | pbeta0 _ => + eqb_body (tagB:=pbeta_tag a) + (fields_tA:=pbeta_fields_t a) (fields_tB:=pbeta_fields_t a) + (pbeta_fields a) + (fun x : positive => + match x as i return pbeta_fields_t a i -> pbeta_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_pbeta_pbeta1 a => + match a0 with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_0 |} => + match b with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_1 |} => + pgamma Box_pbeta_pbeta1_0 Box_pbeta_pbeta1_1 && true + end + end + | xH => fun _ : box_pbeta_pbeta0 a => xpredT + end) + (t1:=pbeta_tag a (pbeta0 a)) (Box_pbeta_pbeta0 a) x2 + | pbeta1 _ g => + eqb_body (tagB:=pbeta_tag a) + (fields_tA:=pbeta_fields_t a) (fields_tB:=pbeta_fields_t a) + (pbeta_fields a) + (fun x : positive => + match x as i return pbeta_fields_t a i -> pbeta_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_pbeta_pbeta1 a => + match a0 with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_0 |} => + match b with + | {| Box_pbeta_pbeta1_0 := Box_pbeta_pbeta1_1 |} => + pgamma Box_pbeta_pbeta1_0 Box_pbeta_pbeta1_1 && true + end + end + | xH => fun _ : box_pbeta_pbeta0 a => xpredT + end) + (t1:=pbeta_tag a (pbeta1 a g)) {| Box_pbeta_pbeta1_0 := g |} x2 + end + with pgamma (x1 x2 : pgamma a) {struct x1} : bool := + match x1 with + | pgamma0 _ => + eqb_body (tagB:=pgamma_tag a) + (fields_tA:=pgamma_fields_t a) (fields_tB:=pgamma_fields_t a) + (pgamma_fields a) + (fun x : positive => + match x as i return pgamma_fields_t a i -> pgamma_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a0 b : box_pgamma_pgamma1 a => + match a0 with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_0; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_1 |} => + match b with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_2; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_3 |} => + [&& palpha Box_pgamma_pgamma1_0 Box_pgamma_pgamma1_2, + pbeta Box_pgamma_pgamma1_1 Box_pgamma_pgamma1_3 & true] + end + end + | xH => fun _ : box_pgamma_pgamma0 a => xpredT + end) + (t1:=pgamma_tag a (pgamma0 a)) (Box_pgamma_pgamma0 a) x2 + | pgamma1 _ a0 b => + eqb_body (tagB:=pgamma_tag a) + (fields_tA:=pgamma_fields_t a) (fields_tB:=pgamma_fields_t a) + (pgamma_fields a) + (fun x : positive => + match x as i return pgamma_fields_t a i -> pgamma_fields_t a i -> bool with + | xI _ => fun _ : unit => xpredT + | xO _ => + fun a1 b0 : box_pgamma_pgamma1 a => + match a1 with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_0; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_1 |} => + match b0 with + | {| Box_pgamma_pgamma1_0 := Box_pgamma_pgamma1_2; + Box_pgamma_pgamma1_1 := Box_pgamma_pgamma1_3 |} => + [&& palpha Box_pgamma_pgamma1_0 Box_pgamma_pgamma1_2, + pbeta Box_pgamma_pgamma1_1 Box_pgamma_pgamma1_3 & true] + end + end + | xH => fun _ : box_pgamma_pgamma0 a => xpredT + end) + (t1:=pgamma_tag a (pgamma1 a a0 b)) + {| Box_pgamma_pgamma1_0 := a0; Box_pgamma_pgamma1_1 := b |} x2 + end + for pgamma. + Parameter palpha_eqb_correct : forall (A : Type) (eqA : A -> A -> bool), + eqb_core_defs.eqb_correct eqA -> + forall x : palpha A, eqb_core_defs.eqb_correct_on (palpha_eqb A eqA) x. + Parameter pbeta_eqb_correct : forall (A : Type) (eqA : A -> A -> bool), + eqb_core_defs.eqb_correct eqA -> + forall x : pbeta A, eqb_core_defs.eqb_correct_on (pbeta_eqb A eqA) x. + Parameter pgamma_eqb_correct : forall (A : Type) (eqA : A -> A -> bool), + eqb_core_defs.eqb_correct eqA -> + forall x : pgamma A, eqb_core_defs.eqb_correct_on (pgamma_eqb A eqA) x. + Parameter palpha_eqb_refl : forall (A : Type) (eqA : A -> A -> bool), + eqb_core_defs.eqb_reflexive eqA -> + forall x : palpha A, eqb_core_defs.eqb_refl_on (palpha_eqb A eqA) x. + Parameter pbeta_eqb_refl : forall (A : Type) (eqA : A -> A -> bool), + eqb_core_defs.eqb_reflexive eqA -> + forall x : pbeta A, eqb_core_defs.eqb_refl_on (pbeta_eqb A eqA) x. + Parameter pgamma_eqb_refl : forall (A : Type) (eqA : A -> A -> bool), + eqb_core_defs.eqb_reflexive eqA -> + forall x : pgamma A, eqb_core_defs.eqb_refl_on (pgamma_eqb A eqA) x. + Parameter palpha_eqb_OK : forall (A : Type) (eqA : A -> A -> bool), + (forall x y : A, reflect (x = y) (eqA x y)) -> + forall x y : palpha A, reflect (x = y) (palpha_eqb A eqA x y). + Parameter pbeta_eqb_OK : forall (A : Type) (eqA : A -> A -> bool), + (forall x y : A, reflect (x = y) (eqA x y)) -> + forall x y : pbeta A, reflect (x = y) (pbeta_eqb A eqA x y). + Parameter pgamma_eqb_OK : forall (A : Type) (eqA : A -> A -> bool), + (forall x y : A, reflect (x = y) (eqA x y)) -> + forall x y : pgamma A, reflect (x = y) (pgamma_eqb A eqA x y). + Parameter palpha_eqb_OK_sumbool : forall A : Type, + (forall x y : A, {x = y} + {x <> y}) -> + forall x y : palpha A, {x = y} + {x <> y}. + Parameter pbeta_eqb_OK_sumbool : forall A : Type, + (forall x y : A, {x = y} + {x <> y}) -> + forall x y : pbeta A, {x = y} + {x <> y}. + Parameter pgamma_eqb_OK_sumbool : forall A : Type, + (forall x y : A, {x = y} + {x <> y}) -> + forall x y : pgamma A, {x = y} + {x <> y}. +End ParametrizedTripleMutualEqbOKExpected. + +Module ParametrizedTripleMutualEqbOKFromBeta <: ParametrizedTripleMutualEqbOKExpected. + Inductive palpha (A : Type) : Type := + | palpha0 + | palpha1 (x : A) (b : pbeta A) + with pbeta (A : Type) : Type := + | pbeta0 + | pbeta1 (g : pgamma A) + with pgamma (A : Type) : Type := + | pgamma0 + | pgamma1 (a : palpha A) (b : pbeta A). + + #[only(eqbOK)] derive pbeta. +End ParametrizedTripleMutualEqbOKFromBeta. diff --git a/apps/derive/tests/test_derive_mutual_indexed.v b/apps/derive/tests/test_derive_mutual_indexed.v new file mode 100644 index 000000000..704d254c9 --- /dev/null +++ b/apps/derive/tests/test_derive_mutual_indexed.v @@ -0,0 +1,133 @@ +From Corelib Require Import Nat BinNums. +Definition bool_is_true := is_true. +From elpi.apps Require Import + derive + derive.tag + derive.isK + derive.projK + derive.map + derive.param1 + derive.param1_congr + derive.param1_functor + derive.param2 + derive.induction. + +Module StandaloneTagIsKProjK. + Inductive itree (A : Type) : nat -> Type := + | ileaf : A -> itree A 0 + | inode : forall n, iforest A n -> itree A (S n) + with iforest (A : Type) : nat -> Type := + | inil : iforest A 0 + | icons : forall n, itree A n -> iforest A n -> iforest A (S n). + + Elpi derive.tag itree. + Redirect "tmp" Check itree_tag : forall A n, itree A n -> positive. + Redirect "tmp" Check iforest_tag : forall A n, iforest A n -> positive. + + Elpi derive.isK itree. + Redirect "tmp" Check itree_is_ileaf : forall A n, itree A n -> bool. + Redirect "tmp" Check itree_is_inode : forall A n, itree A n -> bool. + Redirect "tmp" Check iforest_is_inil : forall A n, iforest A n -> bool. + Redirect "tmp" Check iforest_is_icons : forall A n, iforest A n -> bool. + + Elpi derive.projK itree. + Redirect "tmp" Check projileaf1. + Redirect "tmp" Check projinode1. + Redirect "tmp" Check projinode2. + Redirect "tmp" Check iforest_getk_icons1. + Redirect "tmp" Check iforest_getk_icons2. +End StandaloneTagIsKProjK. + +Module StandaloneMap. + Inductive itree (A : Type) : nat -> Type := + | ileaf : A -> itree A 0 + | inode : forall n, iforest A n -> itree A (S n) + with iforest (A : Type) : nat -> Type := + | inil : iforest A 0 + | icons : forall n, itree A n -> iforest A n -> iforest A (S n). + + Elpi derive.map itree. + Redirect "tmp" Check itree_map : forall A B, (A -> B) -> forall n, itree A n -> itree B n. + Redirect "tmp" Check iforest_map : forall A B, (A -> B) -> forall n, iforest A n -> iforest B n. + + Example itree_map_computes : + itree_map nat bool Nat.even 0 (ileaf nat 2) = ileaf bool true. + Proof. vm_compute. reflexivity. Qed. +End StandaloneMap. + +Module StandaloneParam1Param2. + Inductive itree (A : Type) : nat -> Type := + | ileaf : A -> itree A 0 + | inode : forall n, iforest A n -> itree A (S n) + with iforest (A : Type) : nat -> Type := + | inil : iforest A 0 + | icons : forall n, itree A n -> iforest A n -> iforest A (S n). + + Elpi derive.param1 nat. + Elpi derive.param1 itree. + Redirect "tmp" Check is_itree : forall A, (A -> Type) -> forall n, is_nat n -> itree A n -> Type. + Redirect "tmp" Check is_iforest : forall A, (A -> Type) -> forall n, is_nat n -> iforest A n -> Type. + + Elpi derive.param2 nat. + Elpi derive.param2 itree. + Redirect "tmp" Check itree_R : + forall A1 A2, (A1 -> A2 -> Type) -> + forall n1 n2, nat_R n1 n2 -> itree A1 n1 -> itree A2 n2 -> Type. + Redirect "tmp" Check iforest_R : + forall A1 A2, (A1 -> A2 -> Type) -> + forall n1 n2, nat_R n1 n2 -> iforest A1 n1 -> iforest A2 n2 -> Type. +End StandaloneParam1Param2. + +Module StandaloneParam1CongrFunctorInduction. + Inductive itree (A : Type) : nat -> Type := + | ileaf : A -> itree A 0 + | inode : forall n, iforest A n -> itree A (S n) + with iforest (A : Type) : nat -> Type := + | inil : iforest A 0 + | icons : forall n, itree A n -> iforest A n -> iforest A (S n). + + Elpi derive.param1 nat. + Elpi derive.param1 itree. + Elpi derive.param1.congr is_itree. + Redirect "tmp" Check congr_is_ileaf. + Redirect "tmp" Check congr_is_inil. + + Elpi derive.param1.functor is_itree. + Redirect "tmp" Check is_itree_functor : forall A (PA PB : A -> Type), + (forall x, PA x -> PB x) -> forall n pn x, is_itree A PA n pn x -> is_itree A PB n pn x. + Redirect "tmp" Check is_iforest_functor : forall A (PA PB : A -> Type), + (forall x, PA x -> PB x) -> forall n pn x, is_iforest A PA n pn x -> is_iforest A PB n pn x. + + Elpi derive.induction itree. + Redirect "tmp" Check itree_induction. + Redirect "tmp" Check iforest_induction. +End StandaloneParam1CongrFunctorInduction. + +Module HookMap. + Inductive itree (A : Type) : nat -> Type := + | ileaf : A -> itree A 0 + | inode : forall n, iforest A n -> itree A (S n) + with iforest (A : Type) : nat -> Type := + | inil : iforest A 0 + | icons : forall n, itree A n -> iforest A n -> iforest A (S n). + + #[only(map)] derive itree. + Redirect "tmp" Check itree_map : forall A B, (A -> B) -> forall n, itree A n -> itree B n. + Redirect "tmp" Check iforest_map : forall A B, (A -> B) -> forall n, iforest A n -> iforest B n. +End HookMap. + +Module HookInduction. + Inductive itree (A : Type) : nat -> Type := + | ileaf : A -> itree A 0 + | inode : forall n, iforest A n -> itree A (S n) + with iforest (A : Type) : nat -> Type := + | inil : iforest A 0 + | icons : forall n, itree A n -> iforest A n -> iforest A (S n). + + Elpi derive.param1 nat. + #[only(induction)] derive itree. + Redirect "tmp" Check is_itree_functor : forall A (PA PB : A -> Type), + (forall x, PA x -> PB x) -> forall n pn x, is_itree A PA n pn x -> is_itree A PB n pn x. + Redirect "tmp" Check itree_induction. + Redirect "tmp" Check iforest_induction. +End HookInduction. diff --git a/apps/derive/theories/derive.v b/apps/derive/theories/derive.v index 0dab5fa92..ca8959302 100644 --- a/apps/derive/theories/derive.v +++ b/apps/derive/theories/derive.v @@ -80,6 +80,7 @@ Elpi Accumulate lp:{{ pred get_name i:indt-decl, o:string. get_name (parameter _ _ _ F) N :- pi p\ get_name (F p) N. get_name (inductive N _ _ _) N. + get_name (minductive N _ _ _) N. get_name (record N _ _ _) N. }}. diff --git a/apps/derive/theories/derive/bcongr.v b/apps/derive/theories/derive/bcongr.v index 52b5fd12c..61c34ed4e 100644 --- a/apps/derive/theories/derive/bcongr.v +++ b/apps/derive/theories/derive/bcongr.v @@ -69,7 +69,18 @@ dep1 "bcongr" "projK". }}. Elpi Accumulate derive lp:{{ + +func derive.bcongr.prefix inductive, string, inductive -> string. +derive.bcongr.prefix First Prefix T Prefix :- First = T, !. +derive.bcongr.prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_". + +func derive.bcongr.derive-main inductive, string -> list prop. +derive.bcongr.derive-main T Prefix C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + std.map TS (t\c\ sigma p\ derive.bcongr.prefix T Prefix t p, derive.bcongr.main t p c) CS, + std.flatten CS C. +derive.bcongr.derive-main T Prefix C :- derive.bcongr.main T Prefix C. -derivation (indt T) N ff (derive "bcongr" (derive.bcongr.main T N) (derive.exists-indc T (K\bcongr-db K _))). +derivation (indt T) N ff (derive "bcongr" (derive.bcongr.derive-main T N) (derive.exists-indc T (K\bcongr-db K _))). }}. diff --git a/apps/derive/theories/derive/eqType_ast.v b/apps/derive/theories/derive/eqType_ast.v index c70afb75b..92f387608 100644 --- a/apps/derive/theories/derive/eqType_ast.v +++ b/apps/derive/theories/derive/eqType_ast.v @@ -64,6 +64,12 @@ Elpi Accumulate derive File eqType. Elpi Accumulate derive lp:{{ -derivation (indt T) _ ff (derive "eqType_ast" (derive.eqType.ast.main T) (eqType (indt T) _)). +func derive.eqType.ast.derive-main inductive -> list prop. +derive.eqType.ast.derive-main T C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + derive.eqType.ast.main-mutual TS C. +derive.eqType.ast.derive-main T C :- derive.eqType.ast.main T C. + +derivation (indt T) _ ff (derive "eqType_ast" (derive.eqType.ast.derive-main T) (eqType (indt T) _)). }}. diff --git a/apps/derive/theories/derive/eqb.v b/apps/derive/theories/derive/eqb.v index 1685dfa92..f763a0003 100644 --- a/apps/derive/theories/derive/eqb.v +++ b/apps/derive/theories/derive/eqb.v @@ -79,7 +79,13 @@ dep1 "eqb" "fields". Elpi Accumulate derive lp:{{ -derivation (indt T) Prefix ff (derive "eqb" (derive.eqb.main (indt T) Prefix) (eqb-done (indt T))). -derivation (const C) Prefix ff (derive "eqb_alias" (derive.eqb.main (const C) Prefix) (eqb-done (const C))). +func derive.eqb.derive-main gref, string -> list prop. +derive.eqb.derive-main (indt T) Prefix C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + derive.eqb.mutual.main T TS Prefix C. +derive.eqb.derive-main T Prefix C :- derive.eqb.main T Prefix C. + +derivation (indt T) Prefix ff (derive "eqb" (derive.eqb.derive-main (indt T) Prefix) (eqb-done (indt T))). +derivation (const C) Prefix ff (derive "eqb_alias" (derive.eqb.derive-main (const C) Prefix) (eqb-done (const C))). }}. diff --git a/apps/derive/theories/derive/eqbOK.v b/apps/derive/theories/derive/eqbOK.v index 4135e2aa4..bd4a0c099 100644 --- a/apps/derive/theories/derive/eqbOK.v +++ b/apps/derive/theories/derive/eqbOK.v @@ -78,8 +78,19 @@ dep1 "eqbOK_alias" "eqbcorrect_alias". Elpi Accumulate derive lp:{{ -derivation (indt T) Prefix ff (derive "eqbOK" (derive.eqbOK.main (indt T) Prefix) (eqbok-for (indt T) _)). -derivation (const T) Prefix ff (derive "eqbOK_alias" (derive.eqbOK.main (const T) Prefix) (eqbok-for (const T) _)). +func derive.eqbOK.prefix inductive, string, inductive -> string. +derive.eqbOK.prefix First Prefix T Prefix :- First = T, !. +derive.eqbOK.prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_". + +func derive.eqbOK.derive-main gref, string -> list prop. +derive.eqbOK.derive-main (indt T) Prefix C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + std.map TS (t\c\ sigma p\ derive.eqbOK.prefix T Prefix t p, derive.eqbOK.main (indt t) p c) CS, + std.flatten CS C. +derive.eqbOK.derive-main T Prefix C :- derive.eqbOK.main T Prefix C. + +derivation (indt T) Prefix ff (derive "eqbOK" (derive.eqbOK.derive-main (indt T) Prefix) (eqbok-for (indt T) _)). +derivation (const T) Prefix ff (derive "eqbOK_alias" (derive.eqbOK.derive-main (const T) Prefix) (eqbok-for (const T) _)). }}. diff --git a/apps/derive/theories/derive/eqbcorrect.v b/apps/derive/theories/derive/eqbcorrect.v index 4e3fddfa5..f92c91d70 100644 --- a/apps/derive/theories/derive/eqbcorrect.v +++ b/apps/derive/theories/derive/eqbcorrect.v @@ -128,7 +128,13 @@ dep1 "eqbcorrect_alias" "eqb_alias". Elpi Accumulate derive lp:{{ -derivation (indt T) Prefix ff (derive "eqbcorrect" (derive.eqbcorrect.main (indt T) Prefix) (eqcorrect-for (indt T) _ _)). -derivation (const C) Prefix ff (derive "eqbcorrect_alias" (derive.eqbcorrect.main (const C) Prefix) (eqcorrect-for (const C) _ _)). +func derive.eqbcorrect.derive-main gref, string -> list prop. +derive.eqbcorrect.derive-main (indt T) Prefix C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + derive.eqbcorrect.mutual.main T TS Prefix C. +derive.eqbcorrect.derive-main T Prefix C :- derive.eqbcorrect.main T Prefix C. + +derivation (indt T) Prefix ff (derive "eqbcorrect" (derive.eqbcorrect.derive-main (indt T) Prefix) (eqcorrect-for (indt T) _ _)). +derivation (const C) Prefix ff (derive "eqbcorrect_alias" (derive.eqbcorrect.derive-main (const C) Prefix) (eqcorrect-for (const C) _ _)). }}. diff --git a/apps/derive/theories/derive/fields.v b/apps/derive/theories/derive/fields.v index 5f2021e01..7d1b5ba67 100644 --- a/apps/derive/theories/derive/fields.v +++ b/apps/derive/theories/derive/fields.v @@ -67,6 +67,17 @@ dep1 "fields" "eqType_ast". Elpi Accumulate derive lp:{{ -derivation (indt T) Prefix ff (derive "fields" (derive.fields.main T Prefix) (fields-for T _ _ _ _)). +func derive.fields.prefix inductive, string, inductive -> string. +derive.fields.prefix First Prefix T Prefix :- First = T, !. +derive.fields.prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_". + +func derive.fields.derive-main inductive, string -> list prop. +derive.fields.derive-main T Prefix C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + std.map TS (t\c\ sigma p\ derive.fields.prefix T Prefix t p, derive.fields.main t p c) CS, + std.flatten CS C. +derive.fields.derive-main T Prefix C :- derive.fields.main T Prefix C. + +derivation (indt T) Prefix ff (derive "fields" (derive.fields.derive-main T Prefix) (fields-for T _ _ _ _)). }}. diff --git a/apps/derive/theories/derive/induction.v b/apps/derive/theories/derive/induction.v index 6433b5534..ec989cf03 100644 --- a/apps/derive/theories/derive/induction.v +++ b/apps/derive/theories/derive/induction.v @@ -34,9 +34,15 @@ Elpi Accumulate Db derive.param1.functor.db. Elpi Accumulate Db derive.induction.db. Elpi Accumulate File induction. Elpi Accumulate lp:{{ + func derive.induction.standalone-main inductive, string -> list prop. + derive.induction.standalone-main T Prefix C :- + coq.env.mutual-inductives T TS, std.length TS N, N > 1, !, + derive.induction.main-mutual T TS Prefix C. + derive.induction.standalone-main T Prefix C :- derive.induction.main T Prefix C. + main [str I] :- !, coq.locate I (indt GR), Name is {coq.gref->id (indt GR)} ^ "_", - derive.induction.main GR Name _. + derive.induction.standalone-main GR Name _. main _ :- usage. usage :- @@ -58,6 +64,12 @@ dep1 "induction" "param1_functor". Elpi Accumulate derive lp:{{ -derivation (indt T) N ff (derive "induction" (derive.induction.main T N) (induction-db T _)). +func derive.induction.derive-main inductive, string -> list prop. +derive.induction.derive-main T N C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + derive.induction.main-mutual T TS N C. +derive.induction.derive-main T N C :- derive.induction.main T N C. + +derivation (indt T) N ff (derive "induction" (derive.induction.derive-main T N) (induction-db T _)). }}. diff --git a/apps/derive/theories/derive/isK.v b/apps/derive/theories/derive/isK.v index 96af83dfa..e6ddcfd36 100644 --- a/apps/derive/theories/derive/isK.v +++ b/apps/derive/theories/derive/isK.v @@ -28,11 +28,22 @@ Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.isK.db. Elpi Accumulate File isK. Elpi Accumulate lp:{{ - main [str I,str O] :- !, coq.locate I (indt GR), derive.isK.main GR O _. + func derive.isK.standalone-prefix inductive, string, inductive -> string. + derive.isK.standalone-prefix First Prefix T Prefix :- First = T, !. + derive.isK.standalone-prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_is_". + + func derive.isK.standalone-main inductive, string -> list prop. + derive.isK.standalone-main T Prefix C :- + coq.env.mutual-inductives T TS, std.length TS N, N > 1, !, + std.map TS (t\c\ sigma p\ derive.isK.standalone-prefix T Prefix t p, derive.isK.main t p c) CS, + std.flatten CS C. + derive.isK.standalone-main T Prefix C :- derive.isK.main T Prefix C. + + main [str I,str O] :- !, coq.locate I (indt GR), derive.isK.standalone-main GR O _. main [str I] :- !, coq.locate I (indt GR), Prefix is {coq.gref->id (indt GR)} ^ "_is_", - derive.isK.main GR Prefix _. + derive.isK.standalone-main GR Prefix _. main _ :- usage. usage :- @@ -49,7 +60,18 @@ Elpi Accumulate derive File isK. }}. Elpi Accumulate derive lp:{{ + +func derive.isK.prefix inductive, string, inductive -> string. +derive.isK.prefix First Prefix T Prefix :- First = T, !. +derive.isK.prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_". + +func derive.isK.derive-main inductive, string -> list prop. +derive.isK.derive-main T Prefix C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + std.map TS (t\c\ sigma p n\ derive.isK.prefix T Prefix t p, n is p ^ "isk_", derive.isK.main t n c) CS, + std.flatten CS C. +derive.isK.derive-main T Prefix C :- N is Prefix ^ "isk_", derive.isK.main T N C. -derivation (indt T) Prefix ff (derive "isK" (derive.isK.main T N) (derive.exists-indc T (K\ isK-db K _))) :- N is Prefix ^ "isk_". +derivation (indt T) Prefix ff (derive "isK" (derive.isK.derive-main T Prefix) (derive.exists-indc T (K\ isK-db K _))). }}. diff --git a/apps/derive/theories/derive/lens.v b/apps/derive/theories/derive/lens.v index 431ad70ae..4e9053e10 100644 --- a/apps/derive/theories/derive/lens.v +++ b/apps/derive/theories/derive/lens.v @@ -58,5 +58,9 @@ Elpi Accumulate derive File lens. }}. Elpi Accumulate derive lp:{{ - derivation (indt T) Prefix ff (derive "lens" (derive.lens.main T N) (lens-db T _ _)) :- N is Prefix ^ "_". + func derive.lens.derive-main inductive, string -> list prop. + derive.lens.derive-main T _ [] :- derive.mutual-inductive T, !. + derive.lens.derive-main T N C :- derive.lens.main T N C. + + derivation (indt T) Prefix ff (derive "lens" (derive.lens.derive-main T N) (lens-db T _ _)) :- N is Prefix ^ "_". }}. diff --git a/apps/derive/theories/derive/map.v b/apps/derive/theories/derive/map.v index 75108a8ef..f891549d3 100644 --- a/apps/derive/theories/derive/map.v +++ b/apps/derive/theories/derive/map.v @@ -23,9 +23,15 @@ Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.map.db. Elpi Accumulate File map. Elpi Accumulate lp:{{ + func derive.map.standalone-main inductive, string -> list prop. + derive.map.standalone-main T Prefix C :- + coq.env.mutual-inductives T TS, std.length TS N, N > 1, !, + derive.map.main-mutual T TS Prefix C. + derive.map.standalone-main T Prefix C :- derive.map.main T Prefix C. + main [str I] :- !, coq.locate I (indt GR), O is {coq.gref->id (indt GR)} ^ "_", - derive.map.main GR O _. + derive.map.standalone-main GR O _. main _ :- usage. usage :- coq.error "Usage: derive.map ". @@ -41,5 +47,11 @@ Elpi Accumulate derive File map. }}. Elpi Accumulate derive lp:{{ - derivation (indt T) N ff (derive "map" (derive.map.main T N) (map-done T)). + func derive.map.derive-main inductive, string -> list prop. + derive.map.derive-main T N C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + derive.map.main-mutual T TS N C. + derive.map.derive-main T N C :- derive.map.main T N C. + + derivation (indt T) N ff (derive "map" (derive.map.derive-main T N) (map-done T)). }}. diff --git a/apps/derive/theories/derive/param1_congr.v b/apps/derive/theories/derive/param1_congr.v index 27105d2c6..4e4007613 100644 --- a/apps/derive/theories/derive/param1_congr.v +++ b/apps/derive/theories/derive/param1_congr.v @@ -25,16 +25,26 @@ Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.congr.db. Elpi Accumulate File param1_congr. Elpi Accumulate lp:{{ + func derive.param1.congr.standalone-main inductive, inductive, string -> list prop. + derive.param1.congr.standalone-main GR _IsGR Prefix C :- + coq.env.mutual-inductives GR TS, std.length TS N, N > 1, !, + std.map TS (t\c\ sigma IsT\ + reali (global (indt t)) (global (indt IsT)), + derive.param1.congr.main (indt t) (indt IsT) Prefix c) CS, + std.flatten CS C. + derive.param1.congr.standalone-main GR IsGR Prefix C :- + derive.param1.congr.main (indt GR) (indt IsGR) Prefix C. + main [str I, str O] :- !, coq.locate I (indt IsGR), realiR T {coq.env.global (indt IsGR)}, coq.env.global (indt GR) T, - derive.param1.congr.main (indt GR) (indt IsGR) O _. + derive.param1.congr.standalone-main GR IsGR O _. main [str I] :- !, coq.locate I (indt IsGR), realiR T {coq.env.global (indt IsGR)}, coq.env.global (indt GR) T, - derive.param1.congr.main (indt GR) (indt IsGR) "congr_" _. + derive.param1.congr.standalone-main GR IsGR "congr_" _. main _ :- usage. usage :- @@ -56,6 +66,13 @@ dep1 "param1_congr" "param1". Elpi Accumulate derive lp:{{ -derivation T _ ff (derive "param1_congr" (derive.on_param1 T derive.param1.congr.main "congr_") (derive.on_param1 T (_\T\_\_\param1-congr-done T) _ _)). +func derive.param1.congr.derive-main gref -> list prop. +derive.param1.congr.derive-main (indt T) C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + std.map TS (t\c\ derive.on_param1 (indt t) derive.param1.congr.main "congr_" c) CS, + std.flatten CS C. +derive.param1.congr.derive-main T C :- derive.on_param1 T derive.param1.congr.main "congr_" C. + +derivation T _ ff (derive "param1_congr" (derive.param1.congr.derive-main T) (derive.on_param1 T (_\T\_\_\param1-congr-done T) _ _)). }}. diff --git a/apps/derive/theories/derive/param1_functor.v b/apps/derive/theories/derive/param1_functor.v index 7b990dd00..f55d9861c 100644 --- a/apps/derive/theories/derive/param1_functor.v +++ b/apps/derive/theories/derive/param1_functor.v @@ -24,16 +24,23 @@ Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.functor.db. Elpi Accumulate File param1_functor. Elpi Accumulate lp:{{ + func derive.param1.functor.standalone-main inductive, inductive, string -> list prop. + derive.param1.functor.standalone-main GR _IsGR Suffix C :- + coq.env.mutual-inductives GR TS, std.length TS N, N > 1, !, + derive.param1.functor.main-mutual TS Suffix C. + derive.param1.functor.standalone-main GR IsGR Suffix C :- + derive.param1.functor.main (indt GR) (indt IsGR) Suffix C. + main [str I, str O] :- !, coq.locate I (indt IsGR), realiR T {coq.env.global (indt IsGR)}, coq.env.global (indt GR) T, - derive.param1.functor.main (indt GR) (indt IsGR) O _. + derive.param1.functor.standalone-main GR IsGR O _. main [str I] :- !, coq.locate I (indt IsGR), realiR T {coq.env.global (indt IsGR)}, coq.env.global (indt GR) T, - derive.param1.functor.main (indt GR) (indt IsGR) "_functor" _. + derive.param1.functor.standalone-main GR IsGR "_functor" _. main _ :- usage. usage :- coq.error "Usage: derive.param1.functor []". @@ -54,6 +61,12 @@ dep1 "param1_functor" "param1". Elpi Accumulate derive lp:{{ -derivation (indt T) _ ff (derive "param1_functor" (derive.on_param1 (indt T) derive.param1.functor.main "_functor") (derive.on_param1 (indt T) (_\T\_\_\sigma I\ T = indt I, param1-functor-for I _ _) _ _)). +func derive.param1.functor.derive-main inductive -> list prop. +derive.param1.functor.derive-main T C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + derive.param1.functor.main-mutual TS "_functor" C. +derive.param1.functor.derive-main T C :- derive.on_param1 (indt T) derive.param1.functor.main "_functor" C. + +derivation (indt T) _ ff (derive "param1_functor" (derive.param1.functor.derive-main T) (derive.on_param1 (indt T) (_\T\_\_\sigma I\ T = indt I, param1-functor-for I _ _) _ _)). }}. diff --git a/apps/derive/theories/derive/param1_trivial.v b/apps/derive/theories/derive/param1_trivial.v index 3ef82fd0b..0b44ac499 100644 --- a/apps/derive/theories/derive/param1_trivial.v +++ b/apps/derive/theories/derive/param1_trivial.v @@ -266,7 +266,19 @@ dep1 "param1_inhab" "param1". Elpi Accumulate derive lp:{{ -derivation T _ ff (derive "param1_inhab" (derive.on_param1 T derive.param1.inhab.main "_inhab") (derive.on_param1 T (_\T\_\_\param1-inhab-done T) _ _)). -derivation T _ ff (derive "param1_trivial" (derive.on_param1 T derive.param1.trivial.main "_trivial") (derive.on_param1 T (_\T\_\_\param1-trivial-done T) _ _)). +func derive.param1.inhab.derive-main gref -> list prop. +derive.param1.inhab.derive-main (indt T) C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + derive.param1.inhab.main-mutual TS "_inhab" C. +derive.param1.inhab.derive-main T C :- derive.on_param1 T derive.param1.inhab.main "_inhab" C. + +func derive.param1.trivial.derive-main gref -> list prop. +derive.param1.trivial.derive-main (indt T) C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + derive.param1.trivial.main-mutual TS "_trivial" C. +derive.param1.trivial.derive-main T C :- derive.on_param1 T derive.param1.trivial.main "_trivial" C. + +derivation T _ ff (derive "param1_inhab" (derive.param1.inhab.derive-main T) (derive.on_param1 T (_\T\_\_\param1-inhab-done T) _ _)). +derivation T _ ff (derive "param1_trivial" (derive.param1.trivial.derive-main T) (derive.on_param1 T (_\T\_\_\param1-trivial-done T) _ _)). }}. diff --git a/apps/derive/theories/derive/param2.v b/apps/derive/theories/derive/param2.v index df5201386..f4280ce60 100644 --- a/apps/derive/theories/derive/param2.v +++ b/apps/derive/theories/derive/param2.v @@ -110,6 +110,11 @@ Elpi Accumulate derive Db derive.param2.db. Elpi Accumulate derive lp:{{ -derivation T N ff (derive "param2" (derive.param2.main T N) (param-done T)). +func derive.param2.derive-main gref, string -> list prop. +derive.param2.derive-main T N C :- derive.param2.main T N C. + +derivation (indt T) N ff (derive "param2" (derive.param2.derive-main (indt T) N) (param-done (indt T))). +derivation (const T) N ff (derive "param2" (derive.param2.derive-main (const T) N) (param-done (const T))). +derivation (indc T) N ff (derive "param2" (derive.param2.derive-main (indc T) N) (param-done (indc T))). }}. diff --git a/apps/derive/theories/derive/projK.v b/apps/derive/theories/derive/projK.v index 36df2de54..807dc9865 100644 --- a/apps/derive/theories/derive/projK.v +++ b/apps/derive/theories/derive/projK.v @@ -29,8 +29,19 @@ Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.projK.db. Elpi Accumulate File projK. Elpi Accumulate lp:{{ - main [str I, str O] :- !, coq.locate I (indt GR), derive.projK.main GR O _. - main [str I] :- !, coq.locate I (indt GR), derive.projK.main GR "proj" _. + func derive.projK.standalone-prefix inductive, string, inductive -> string. + derive.projK.standalone-prefix First Prefix T Prefix :- First = T, !. + derive.projK.standalone-prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_getk_". + + func derive.projK.standalone-main inductive, string -> list prop. + derive.projK.standalone-main T Prefix C :- + coq.env.mutual-inductives T TS, std.length TS N, N > 1, !, + std.map TS (t\c\ sigma p\ derive.projK.standalone-prefix T Prefix t p, derive.projK.main t p c) CS, + std.flatten CS C. + derive.projK.standalone-main T Prefix C :- derive.projK.main T Prefix C. + + main [str I, str O] :- !, coq.locate I (indt GR), derive.projK.standalone-main GR O _. + main [str I] :- !, coq.locate I (indt GR), derive.projK.standalone-main GR "proj" _. main _ :- usage. usage :- @@ -48,7 +59,18 @@ Elpi Accumulate derive File projK. }}. Elpi Accumulate derive lp:{{ + +func derive.projK.prefix inductive, string, inductive -> string. +derive.projK.prefix First Prefix T Prefix :- First = T, !. +derive.projK.prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_". + +func derive.projK.derive-main inductive, string -> list prop. +derive.projK.derive-main T Prefix C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + std.map TS (t\c\ sigma p n\ derive.projK.prefix T Prefix t p, n is p ^ "getk_", derive.projK.main t n c) CS, + std.flatten CS C. +derive.projK.derive-main T Prefix C :- N is Prefix ^ "getk_", derive.projK.main T N C. -derivation (indt T) Prefix ff (derive "projK" (derive.projK.main T N) (derive.exists-indc T (K\ projK-db K _ _))) :- N is Prefix ^ "getk_". +derivation (indt T) Prefix ff (derive "projK" (derive.projK.derive-main T Prefix) (derive.exists-indc T (K\ projK-db K _ _))). }}. diff --git a/apps/derive/theories/derive/tag.v b/apps/derive/theories/derive/tag.v index 9f854cecb..1ab83d69a 100644 --- a/apps/derive/theories/derive/tag.v +++ b/apps/derive/theories/derive/tag.v @@ -25,11 +25,22 @@ Elpi Accumulate File tag. Elpi Accumulate Db derive.tag.db. Elpi Accumulate lp:{{ + func derive.tag.standalone-prefix inductive, string, inductive -> string. + derive.tag.standalone-prefix First Prefix T Prefix :- First = T, !. + derive.tag.standalone-prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_". + + func derive.tag.standalone-main inductive, string -> list prop. + derive.tag.standalone-main T Prefix C :- + coq.env.mutual-inductives T TS, std.length TS N, N > 1, !, + std.map TS (t\c\ sigma p\ derive.tag.standalone-prefix T Prefix t p, derive.tag.main t p c) CS, + std.flatten CS C. + derive.tag.standalone-main T Prefix C :- derive.tag.main T Prefix C. + main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, Prefix is Tname ^ "_", - derive.tag.main GR Prefix _. + derive.tag.standalone-main GR Prefix _. main _ :- usage. @@ -47,7 +58,18 @@ Elpi Accumulate derive File tag. }}. Elpi Accumulate derive lp:{{ + +func derive.tag.prefix inductive, string, inductive -> string. +derive.tag.prefix First Prefix T Prefix :- First = T, !. +derive.tag.prefix _ _ T P :- P is {coq.gref->id (indt T)} ^ "_". + +func derive.tag.derive-main inductive, string -> list prop. +derive.tag.derive-main T Prefix C :- derive.mutual-inductive T, !, + derive.mutual-inductives T TS, + std.map TS (t\c\ sigma p\ derive.tag.prefix T Prefix t p, derive.tag.main t p c) CS, + std.flatten CS C. +derive.tag.derive-main T Prefix C :- derive.tag.main T Prefix C. -derivation (indt T) Prefix ff (derive "tag" (derive.tag.main T Prefix) (tag-for T _)). +derivation (indt T) Prefix ff (derive "tag" (derive.tag.derive-main T Prefix) (tag-for T _)). }}. diff --git a/builtin-doc/coq-builtin-synterp.elpi b/builtin-doc/coq-builtin-synterp.elpi index 470e9d843..842bfc79c 100644 --- a/builtin-doc/coq-builtin-synterp.elpi +++ b/builtin-doc/coq-builtin-synterp.elpi @@ -155,6 +155,8 @@ external symbol arity : term -> arity. external symbol parameter : id -> implicit_kind -> term -> (term -> indt-decl) -> indt-decl = "2". external symbol inductive : id -> bool -> arity -> (term -> list indc-decl) -> indt-decl. % tt means inductive, ff coinductive +external symbol minductive : id -> bool -> arity -> (term -> indt-decl) -> indt-decl. % one type of a mutual block +external symbol mblock : list (list indc-decl) -> indt-decl. % constructor blocks for minductive declarations external symbol record : id -> term -> id -> record-decl -> indt-decl. external symbol constructor : id -> arity -> indc-decl. diff --git a/builtin-doc/coq-builtin.elpi b/builtin-doc/coq-builtin.elpi index a82a58ebd..cabf66b05 100644 --- a/builtin-doc/coq-builtin.elpi +++ b/builtin-doc/coq-builtin.elpi @@ -128,6 +128,8 @@ external symbol arity : term -> arity. external symbol parameter : id -> implicit_kind -> term -> (term -> indt-decl) -> indt-decl = "2". external symbol inductive : id -> bool -> arity -> (term -> list indc-decl) -> indt-decl. % tt means inductive, ff coinductive +external symbol minductive : id -> bool -> arity -> (term -> indt-decl) -> indt-decl. % one type of a mutual block +external symbol mblock : list (list indc-decl) -> indt-decl. % constructor blocks for minductive declarations external symbol record : id -> term -> id -> record-decl -> indt-decl. external symbol constructor : id -> arity -> indc-decl. @@ -692,6 +694,10 @@ external func coq.env.indt-decl % reads the inductive type declaration for the e -> indt-decl. % HOAS description of the inductive type +% [coq.env.mutual-inductives reference to an inductive type Inductives] +% lists all inductive types in the same mutual block, in declaration order +external func coq.env.mutual-inductives inductive -> list inductive. + % [coq.env.indc->indt K I N] finds the inductive I to which constructor K % belongs and its position N among the other constructors external func coq.env.indc->indt constructor -> inductive, int. diff --git a/elpi/coq-arg-HOAS.elpi b/elpi/coq-arg-HOAS.elpi index 30870fe41..ea42461c7 100644 --- a/elpi/coq-arg-HOAS.elpi +++ b/elpi/coq-arg-HOAS.elpi @@ -113,6 +113,8 @@ external symbol arity : term -> arity. external symbol parameter : id -> implicit_kind -> term -> (term -> indt-decl) -> indt-decl = "2". external symbol inductive : id -> bool -> arity -> (term -> list indc-decl) -> indt-decl. % tt means inductive, ff coinductive +external symbol minductive : id -> bool -> arity -> (term -> indt-decl) -> indt-decl. % one type of a mutual block +external symbol mblock : list (list indc-decl) -> indt-decl. % constructor blocks for minductive declarations external symbol record : id -> term -> id -> record-decl -> indt-decl. external symbol constructor : id -> arity -> indc-decl. diff --git a/elpi/coq-lib.elpi b/elpi/coq-lib.elpi index 1c06acfcb..4770f318f 100644 --- a/elpi/coq-lib.elpi +++ b/elpi/coq-lib.elpi @@ -133,10 +133,17 @@ copy-indt-decl (parameter ID I Ty D) (parameter ID I Ty1 D1) :- copy-indt-decl (inductive ID CO A D) (inductive ID CO A1 D1) :- copy-arity A A1, @pi-inductive ID A1 i\ std.map (D i) copy-constructor (D1 i). +copy-indt-decl (minductive ID CO A D) (minductive ID CO A1 D1) :- + copy-arity A A1, + @pi-inductive ID A1 i\ copy-indt-decl (D i) (D1 i). +copy-indt-decl (mblock Bs) (mblock Bs1) :- map Bs copy-constructor-block Bs1. copy-indt-decl (record ID T IDK F) (record ID T1 IDK F1) :- copy T T1, copy-fields F F1. +func copy-constructor-block list indc-decl -> list indc-decl. +copy-constructor-block Ks Ks1 :- map Ks copy-constructor Ks1. + func copy-fields record-decl -> record-decl. copy-fields end-record end-record. copy-fields (field Att ID T F) (field Att ID T1 F1) :- @@ -214,6 +221,9 @@ coq.upoly-decl-cumul.complete-constraints.aux (covariant V) CS :- coq.univ.varia coq.upoly-decl-cumul.complete-constraints.aux (invariant V) CS :- coq.univ.variable.constraints V CS. coq.upoly-decl-cumul.complete-constraints.aux (irrelevant V) CS :- coq.univ.variable.constraints V CS. +kind coq.mindt-spec type. +type coq.mindt-spec inductive -> id -> bool -> term -> list (pair constructor id) -> list term -> coq.mindt-spec. + :index (1) func coq.build-indt-decl (pair inductive id), bool, int, int, term, list (pair constructor id), list term -> indt-decl. @@ -221,6 +231,10 @@ func coq.build-indt-decl coq.build-indt-decl GR IsInd Pno UPno Arity Kns Ktys Decl :- coq.build-indt-decl-aux GR IsInd Pno UPno Arity Kns Ktys [] Decl. +func coq.build-mindt-decl list coq.mindt-spec, int, int -> indt-decl. +coq.build-mindt-decl Specs Pno UPno Decl :- + coq.build-mindt-decl-aux Specs Pno UPno [] Decl. + func coq.build-indt-decl-aux pair inductive id, bool, int, int, term, list (pair constructor id), list term, list term -> indt-decl. coq.build-indt-decl-aux (pr GR I) IsInd NUPno 0 Ty Kns KtysNu Params (inductive I IsInd Arity Ks) :- !, @@ -301,6 +315,55 @@ coq.indt-unif->indt-nonunif (inductive _ _ _ _ as I) I. coq.indt-unif->indt-nonunif (record _ _ _ _) _ :- coq.error "coq.indt-unif->indt-nonunif does not support record types". +func coq.build-mindt-decl-aux list coq.mindt-spec, int, int, list term -> indt-decl. +coq.build-mindt-decl-aux Specs 0 0 Params Decl :- !, + rev Params ParamsR, + coq.build-mindt-decl-binders Specs Specs ParamsR [] Decl. +coq.build-mindt-decl-aux ([coq.mindt-spec _ _ _ (prod N S _) _ _|_] as Specs) Pno UPno Params (parameter NS explicit S Res) :- Pno > 0, UPno > 0, !, + coq.name->id N NS, + Pno1 is Pno - 1, + UPno1 is UPno - 1, + pi p\ + std.map Specs (coq.build-mindt-decl-subst-param p) Specs1, + coq.build-mindt-decl-aux Specs1 Pno1 UPno1 [p|Params] (Res p). +:name "coq.build-mindt-decl-aux:fail" +coq.build-mindt-decl-aux _ _ _ _ _ :- !, + fatal-error "coq.build-mindt-decl-aux: invalid mutual declaration". + +func coq.build-mindt-decl-subst-param term, coq.mindt-spec -> coq.mindt-spec. +coq.build-mindt-decl-subst-param P (coq.mindt-spec GR ID IsInd (prod _ _ T) Kns Ktys) (coq.mindt-spec GR ID IsInd (T P) Kns Ktys1) :- !, + std.map Ktys (coq.subst-prod [P]) Ktys1. +coq.build-mindt-decl-subst-param _ _ _ :- !, + fatal-error "coq.build-mindt-decl-subst-param: parameter mismatch". + +func coq.build-mindt-decl-binders list coq.mindt-spec, list coq.mindt-spec, list term, list (pair inductive term) -> indt-decl. +coq.build-mindt-decl-binders All [] ParamsR Acc (mblock Blocks) :- !, + rev Acc Pairs, + std.map All (coq.build-mindt-decl-block Pairs ParamsR) Blocks. +coq.build-mindt-decl-binders All [coq.mindt-spec GR ID IsInd Ty _ _|Rest] ParamsR Acc (minductive ID IsInd Arity More) :- !, + coq.term->arity Ty 0 Arity, + @pi-inductive ID Arity i\ + coq.build-mindt-decl-binders All Rest ParamsR [pr GR i|Acc] (More i). + +func coq.build-mindt-decl-block list (pair inductive term), list term, coq.mindt-spec -> list indc-decl. +coq.build-mindt-decl-block Pairs ParamsR (coq.mindt-spec _ _ _ _ Kns Ktys) Block :- + coq.build-mindt-decl-copy-clauses Pairs ParamsR Sub, + std.map2 Kns Ktys (gr_name\ ty\ res\ sigma tmp name ar\ + (Sub ==> copy ty tmp), + coq.term->arity tmp 0 ar, + gr_name = pr _ name, + res = constructor name ar) Block. + +func coq.build-mindt-decl-copy-clauses list (pair inductive term), list term -> list prop. +coq.build-mindt-decl-copy-clauses [] _ []. +coq.build-mindt-decl-copy-clauses [pr GR I|Rest] ParamsR [ + (pi l rest r\ copy (app[global (indt GR)|l]) r :- !, std.append ParamsR rest l, coq.mk-app I rest r, !), + (pi l rest r ui\ copy (app[pglobal (indt GR) ui|l]) r :- !, std.append ParamsR rest l, coq.mk-app I rest r, !), + (copy (global (indt GR)) I :- !), + (pi ui\ copy (pglobal (indt GR) ui) I :- !) + | More] :- + coq.build-mindt-decl-copy-clauses Rest ParamsR More. + :index (_ 1) func coq.rename-arity (func id -> id), @@ -331,10 +394,26 @@ coq.rename-indt-decl RP RI RK (inductive ID Ind A In) (inductive ID1 Ind A1 Out) coq.arity->term A TY, @pi-decl Name TY i\ std.map (In i) (coq.rename-indt-decl.aux RP RI RK) (Out i). +coq.rename-indt-decl RP RI RK (minductive ID Ind A In) (minductive ID1 Ind A1 Out) :- + RI ID ID1, + coq.rename-arity RP A A1, + coq.id->name ID Name, + coq.arity->term A TY, + @pi-decl Name TY i\ + coq.rename-indt-decl RP RI RK (In i) (Out i). +coq.rename-indt-decl RP RI RK (mblock Blocks) (mblock Blocks1) :- + map Blocks (coq.rename-indt-decl.block RP RI RK) Blocks1. coq.rename-indt-decl _ RI RK (record ID A KID F) (record ID1 A KID1 F) :- RI ID ID1, RK KID KID1. +func coq.rename-indt-decl.block + (func id -> id), + (func id -> id), + (func id -> id), + list indc-decl -> list indc-decl. +coq.rename-indt-decl.block RP RI RK Ks Ks1 :- map Ks (coq.rename-indt-decl.aux RP RI RK) Ks1. + func coq.rename-indt-decl.aux (func id -> id), (func id -> id), @@ -378,6 +457,10 @@ coq.typecheck-indt-decl (inductive ID _ Arity KDecl) Diag :- do-ok! Diag [ coq.typecheck-indt-arity Arity A NUPNO, d\ @pi-parameter ID A i\ forall-ok (KDecl i) (coq.typecheck-indt-decl-c i A NUPNO) d ]. +coq.typecheck-indt-decl (minductive ID _ Arity Rest) Diag :- do-ok! Diag [ + coq.typecheck-indt-arity Arity A NUPNO, + d\ @pi-parameter ID A i\ coq.typecheck-indt-decl-mutual [pr i (pr A NUPNO)] (Rest i) d +]. coq.typecheck-indt-decl (record ID A _IDK FDecl) Diag :- do-ok! Diag [ coq.typecheck-ty A _, d\ @pi-parameter ID A i\ do-ok! d [ @@ -386,6 +469,24 @@ coq.typecheck-indt-decl (record ID A _IDK FDecl) Diag :- do-ok! Diag [ ] ]. +func coq.typecheck-indt-decl-mutual list (pair term (pair term int)), indt-decl -> diagnostic. +coq.typecheck-indt-decl-mutual Acc (minductive ID _ Arity Rest) Diag :- !, do-ok! Diag [ + coq.typecheck-indt-arity Arity A NUPNO, + d\ @pi-parameter ID A i\ coq.typecheck-indt-decl-mutual [pr i (pr A NUPNO)|Acc] (Rest i) d +]. +coq.typecheck-indt-decl-mutual Acc (mblock Blocks) Diag :- !, + rev Acc Infos, + coq.typecheck-indt-decl-blocks Infos Blocks Diag. +coq.typecheck-indt-decl-mutual _ _ (error "minductive/mblock expected") :- !. + +func coq.typecheck-indt-decl-blocks list (pair term (pair term int)), list (list indc-decl) -> diagnostic. +coq.typecheck-indt-decl-blocks [] [] ok :- !. +coq.typecheck-indt-decl-blocks [pr I (pr A NUPNO)|Infos] [Ks|Blocks] Diag :- !, do-ok! Diag [ + forall-ok Ks (coq.typecheck-indt-decl-c I A NUPNO), + d\ coq.typecheck-indt-decl-blocks Infos Blocks d +]. +coq.typecheck-indt-decl-blocks _ _ (error "mblock constructor block count mismatch") :- !. + func coq.typecheck-indc-arity arity, int -> term, sort, diagnostic. coq.typecheck-indc-arity A 0 T S Diag :- !, coq.arity->term A T, @@ -439,12 +540,43 @@ coq.elaborate-indt-decl-skeleton (inductive ID I Arity KDecl) (inductive ID I Ar d\ @pi-parameter ID A1 i\ map-ok (KDecl i) (coq.elaborate-indt-decl-skeleton-c i Arity1 NUPNO) (KDecl1 i) d ] ]. +coq.elaborate-indt-decl-skeleton (minductive ID I Arity Rest) (minductive ID I Arity1 Rest1) Diag :- do-ok! Diag [ + coq.elaborate-arity-skeleton Arity _ Arity1, + lift-ok (coq.arity->nparams Arity1 NUPNO) "", + d\ coq.arity->term Arity1 A1, do-ok! d [ + coq.typecheck-indt-decl.heuristic-var-type A1, + d\ @pi-parameter ID A1 i\ coq.elaborate-indt-decl-skeleton-mutual [pr i (pr Arity1 NUPNO)] (Rest i) (Rest1 i) d + ] +]. coq.elaborate-indt-decl-skeleton (record ID A IDK FDecl) (record ID A1 IDK FDecl1) Diag :- do-ok! Diag [ coq.elaborate-ty-skeleton A _ A1, lift-ok (A1 = sort U) "record type is not a sort", d\ @pi-parameter ID A1 i\ coq.elaborate-indt-decl-skeleton-fields U FDecl FDecl1 d ]. +:index (_ 1) +func coq.elaborate-indt-decl-skeleton-mutual list (pair term (pair arity int)), indt-decl -> indt-decl, diagnostic. +coq.elaborate-indt-decl-skeleton-mutual Acc (minductive ID I Arity Rest) (minductive ID I Arity1 Rest1) Diag :- !, do-ok! Diag [ + coq.elaborate-arity-skeleton Arity _ Arity1, + lift-ok (coq.arity->nparams Arity1 NUPNO) "", + d\ coq.arity->term Arity1 A1, do-ok! d [ + coq.typecheck-indt-decl.heuristic-var-type A1, + d\ @pi-parameter ID A1 i\ coq.elaborate-indt-decl-skeleton-mutual [pr i (pr Arity1 NUPNO)|Acc] (Rest i) (Rest1 i) d + ] +]. +coq.elaborate-indt-decl-skeleton-mutual Acc (mblock Blocks) (mblock Blocks1) Diag :- !, + rev Acc Infos, + coq.elaborate-indt-decl-skeleton-blocks Infos Blocks Blocks1 Diag. +coq.elaborate-indt-decl-skeleton-mutual _ _ _ (error "minductive/mblock expected") :- !. + +func coq.elaborate-indt-decl-skeleton-blocks list (pair term (pair arity int)), list (list indc-decl) -> list (list indc-decl), diagnostic. +coq.elaborate-indt-decl-skeleton-blocks [] [] [] ok :- !. +coq.elaborate-indt-decl-skeleton-blocks [pr I (pr Arity NUPNO)|Infos] [Ks|Blocks] [Ks1|Blocks1] Diag :- !, do-ok! Diag [ + map-ok Ks (coq.elaborate-indt-decl-skeleton-c I Arity NUPNO) Ks1, + d\ coq.elaborate-indt-decl-skeleton-blocks Infos Blocks Blocks1 d +]. +coq.elaborate-indt-decl-skeleton-blocks _ _ _ (error "mblock constructor block count mismatch") :- !. + :index (_ 1) func coq.elaborate-indt-decl-skeleton-fields sort, record-decl -> record-decl, diagnostic. coq.elaborate-indt-decl-skeleton-fields _ end-record end-record ok. @@ -542,16 +674,31 @@ coq.arity->implicits (parameter Id I Ty F) [I|Is] :- @pi-parameter Id Ty x\ coq.arity->implicits (F x) Is. coq.arity->implicits (arity _) []. -% Get impargs setting from an indt-decl -func coq.indt-decl->implicits indt-decl -> list implicit_kind, list (list implicit_kind). -coq.indt-decl->implicits (parameter Id I Ty F) [I|Is] R :- - @pi-parameter Id Ty x\ coq.indt-decl->implicits (F x) Is R1, - std.map R1 (l\r\r = [I|l]) R. -coq.indt-decl->implicits (record _ _ _ _) [] [[]]. -coq.indt-decl->implicits (inductive Id _ A Ks) Is R :- +func coq.constructor-block->implicits list indc-decl -> list (list implicit_kind). +coq.constructor-block->implicits Ks R :- + std.map Ks (c\i\sigma a\ c = constructor _ a, coq.arity->implicits a i) R. + +% Get impargs settings from all inductives in an indt-decl, and from their +% constructor blocks, in declaration order. +func coq.indt-decl->implicits-all indt-decl -> list (list implicit_kind), list (list (list implicit_kind)). +coq.indt-decl->implicits-all (parameter Id I Ty F) Inds1 Ks1 :- + @pi-parameter Id Ty x\ coq.indt-decl->implicits-all (F x) Inds Ks, + std.map Inds (l\r\ r = [I|l]) Inds1, + std.map Ks (b\r\ std.map b (l\r\ r = [I|l]) r) Ks1. +coq.indt-decl->implicits-all (record _ _ _ _) [[]] [[[]]]. +coq.indt-decl->implicits-all (inductive Id _ A Ks) [Is] [R] :- + coq.arity->implicits A Is, + @pi-inductive Id A x\ coq.constructor-block->implicits (Ks x) R. +coq.indt-decl->implicits-all (minductive Id _ A Rest) [Is|Inds] Ks :- coq.arity->implicits A Is, - @pi-inductive Id A x\ - std.map (Ks x) (c\i\sigma a\c = constructor _ a,coq.arity->implicits a i) R. + @pi-inductive Id A x\ coq.indt-decl->implicits-all (Rest x) Inds Ks. +coq.indt-decl->implicits-all (mblock Ks) [] R :- + std.map Ks coq.constructor-block->implicits R. + +% Get impargs setting from the first inductive in an indt-decl. +func coq.indt-decl->implicits indt-decl -> list implicit_kind, list (list implicit_kind). +coq.indt-decl->implicits D Is Ks :- + coq.indt-decl->implicits-all D [Is|_] [Ks|_]. % Check if some implicits are set func coq.any-implicit? list implicit_kind ->. diff --git a/src/rocq_elpi_HOAS.ml b/src/rocq_elpi_HOAS.ml index 0fdbb2bee..44498ff0b 100644 --- a/src/rocq_elpi_HOAS.ml +++ b/src/rocq_elpi_HOAS.ml @@ -3153,6 +3153,8 @@ let inductive_parameterc = E.Constants.declare_global_symbol ~variant:2 "paramet let arityc = E.Constants.declare_global_symbol "arity" let constructorc = E.Constants.declare_global_symbol "constructor" let inductivec = E.Constants.declare_global_symbol "inductive" +let minductivec = E.Constants.declare_global_symbol "minductive" +let mblockc = E.Constants.declare_global_symbol "mblock" let recordc = E.Constants.declare_global_symbol "record" let fieldc = E.Constants.declare_global_symbol "field" let end_recordc = E.Constants.declare_global_symbol "end-record" @@ -3190,6 +3192,14 @@ let in_elpi_indtdecl_inductive state find id arity constructors = let coind = not (Declarations.CoFinite = find) in E.mkApp inductivec (in_elpi_id id) [in_elpi_bool state coind; arity;E.mkLam @@ U.list_to_lp_list constructors] +let in_elpi_indtdecl_minductive state find id arity rest = + let coind = not (Declarations.CoFinite = find) in + E.mkApp minductivec (in_elpi_id id) [in_elpi_bool state coind; arity;E.mkLam rest] + +let in_elpi_indtdecl_mblock constructor_blocks = + let constructor_blocks = List.map U.list_to_lp_list constructor_blocks in + E.mkApp mblockc (U.list_to_lp_list constructor_blocks) [] + let in_elpi_indtdecl_constructor id ty = E.mkApp constructorc (in_elpi_id id) [ty] @@ -3303,7 +3313,7 @@ let poly_cumul_udecl_variance_of_options state options = Array.of_list variance [%%if coq = "9.0"] -let comInductive_interp_mutual_inductive_constr ~cumulative ~poly ~template ~finite = +let comInductive_interp_mutual_inductive_constr ~cumulative ~poly ~template ~finite ~indnames = let flags = { ComInductive.poly; cumulative; @@ -3312,9 +3322,11 @@ let comInductive_interp_mutual_inductive_constr ~cumulative ~poly ~template ~fin mode = None; } in - ComInductive.interp_mutual_inductive_constr ~arities_explicit:[true] ~template_syntax:[SyntaxAllowsTemplatePoly] ~flags + let arities_explicit = List.map (fun _ -> true) indnames in + let template_syntax = List.map (fun _ -> ComInductive.SyntaxAllowsTemplatePoly) indnames in + ComInductive.interp_mutual_inductive_constr ~indnames ~arities_explicit ~template_syntax ~flags [%%elif coq = "9.1"] -let comInductive_interp_mutual_inductive_constr ~cumulative ~poly ~template ~finite ~ctx_params ~env_ar_params = +let comInductive_interp_mutual_inductive_constr ~cumulative ~poly ~template ~finite ~ctx_params ~env_ar_params ~indnames = let flags = { ComInductive.poly; cumulative; @@ -3323,10 +3335,12 @@ let comInductive_interp_mutual_inductive_constr ~cumulative ~poly ~template ~fin mode = None; } in + let arities_explicit = List.map (fun _ -> true) indnames in + let template_syntax = List.map (fun _ -> ComInductive.SyntaxAllowsTemplatePoly) indnames in let env_ar = Environ.pop_rel_context (List.length ctx_params) env_ar_params in - ComInductive.interp_mutual_inductive_constr ~arities_explicit:[true] ~template_syntax:[SyntaxAllowsTemplatePoly] ~flags ~env_ar ~ctx_params + ComInductive.interp_mutual_inductive_constr ~indnames ~arities_explicit ~template_syntax ~flags ~env_ar ~ctx_params [%%else] -let comInductive_interp_mutual_inductive_constr ~cumulative ~poly ~template ~finite ~ctx_params ~env_ar_params = +let comInductive_interp_mutual_inductive_constr ~cumulative ~poly ~template ~finite ~ctx_params ~env_ar_params ~indnames = let flags = { ComInductive.poly = PolyFlags.make ~univ_poly:poly ~cumulative ~collapse_sort_variables:true; template = Some false; @@ -3335,8 +3349,10 @@ let comInductive_interp_mutual_inductive_constr ~cumulative ~poly ~template ~fin schemes = Default; } in + let arities_explicit = List.map (fun _ -> true) indnames in + let template_syntax = List.map (fun _ -> ComInductive.SyntaxAllowsTemplatePoly) indnames in let env_ar = Environ.pop_rel_context (List.length ctx_params) env_ar_params in - ComInductive.interp_mutual_inductive_constr ~arities_explicit:[true] ~template_syntax:[SyntaxAllowsTemplatePoly] ~flags ~env_ar ~ctx_params + ComInductive.interp_mutual_inductive_constr ~indnames ~arities_explicit ~template_syntax ~flags ~env_ar ~ctx_params [%%endif] @@ -3453,14 +3469,14 @@ let lp2inductive_entry ~depth coq_ctx constraints state t = ~udecl ~variances ~ctx_params:(nuparams @ params) - ~indnames:[itname] ~arities:[arity] ~constructors:[knames, ktypes] ~env_ar_params ~cumulative ~poly ~private_ind - ~finite:finiteness |> comInductive_interp_mutual_inductive_constr_post + ~finite:finiteness + ~indnames:[itname] |> comInductive_interp_mutual_inductive_constr_post in let mind = { mind with Entries.mind_entry_record = @@ -3492,6 +3508,111 @@ let lp2inductive_entry ~depth coq_ctx constraints state t = str (pp2string P.(term depth) fields)) in + let constructor_blocks_of_lp ~depth blocks = + U.lp_list_to_list ~depth blocks |> + List.map (fun block -> U.lp_list_to_list ~depth block) + in + + let relocate_mutual_constructor_type ~paramsno ~ninds t = + let subst = CList.init (paramsno + ninds) (fun i -> + let rel = i + 1 in + if rel <= ninds then + let ind = EC.mkRel (paramsno + rel) in + if paramsno = 0 then ind + else + let ps = CArray.init paramsno (fun i -> EC.mkRel (paramsno - i)) in + EC.mkApp (ind, ps) + else EC.mkRel (rel - ninds)) in + EC.Vars.substl subst t + in + + let aux_mutual_constructors coq_ctx ~depth (params,impls) inds state constructor_blocks = + let params = force_name_ctx params in + let paramsno = List.length params in + let ninds = List.length inds in + if List.length constructor_blocks <> ninds then + err Pp.(str"mblock: expected " ++ int ninds ++ str" constructor blocks, got " ++ + int (List.length constructor_blocks)); + let state, constructor_infos, gls_rev = + List.fold_left2 (fun (state, infos, gls_acc) (name, nuparams, nuimpls, arity, _kind) ks -> + if nuparams <> [] then nYI "non-uniform parameters in mutual inductives"; + let (state, gls_rev), names_ktypes_impls = + CList.fold_left_map (fun (state, extra) t -> + match E.look ~depth t with + | E.App(c,kname,[ty]) when c == constructorc -> + begin match E.look ~depth kname with + | E.CData kname when CD.is_string kname -> + let kname = Id.of_string (CD.to_string kname) in + let state, kparams, kimpls, ty, gls = readback_arity ~depth coq_ctx constraints state ty in + let ty = check_consistency_and_drop_nuparams (get_sigma state) nuparams kname kparams ty in + let ty = relocate_mutual_constructor_type ~paramsno ~ninds ty in + (state, gls :: extra), (kname, ty, impls @ (List.rev nuimpls) @ kimpls) + | _ -> err Pp.(str"@gref expected: " ++ str (pp2string P.(term depth) kname)) + end + | _ -> err Pp.(str"constructor expected: " ++ str (pp2string P.(term depth) t))) + (state,[]) ks in + let knames, ktypes, kimpls = CList.split3 names_ktypes_impls in + state, (name, arity, knames, ktypes, impls @ List.rev nuimpls, kimpls) :: infos, gls_rev @ gls_acc) + (state, [], []) inds constructor_blocks in + let constructor_infos = List.rev constructor_infos in + let indnames = List.map (fun (name, _, _, _, _, _) -> name) constructor_infos in + let arities = List.map (fun (_, arity, _, _, _, _) -> arity) constructor_infos in + let constructors = List.map (fun (_, _, knames, ktypes, _, _) -> knames, ktypes) constructor_infos in + let ind_impls = List.map (fun (_, _, _, _, i_impls, k_impls) -> i_impls, k_impls) constructor_infos in + let finiteness = + match inds with + | [] -> err Pp.(str"mblock: empty mutual inductive block") + | (_, _, _, _, kind) :: rest -> + if List.for_all (fun (_, _, _, _, kind') -> kind = kind') rest then kind + else err Pp.(str"mblock: cannot mix inductive and coinductive declarations") in + let state, (melims, mind, ubinders, uctx) = + let private_ind = false in + let state, poly, cumulative, udecl, variances = + poly_cumul_udecl_variance_of_options state coq_ctx.options in + let ind_types = + List.mapi (fun i (name, arity) -> + let ty = EConstr.it_mkProd_or_LetIn arity params in + Context.Rel.Declaration.LocalAssum(nameR name, EConstr.Vars.lift i ty)) + (List.combine indnames arities) in + let env_ar_params = + let env_ar = List.fold_left (fun env ind_type -> EC.push_rel ind_type env) (Global.env ()) ind_types in + EC.push_rel_context params env_ar in + let state = minimize_universes state in + let used = + List.fold_left (fun acc t -> + Univ.Level.Set.union acc (universes_of_term state t)) + Univ.Level.Set.empty arities in + let used = + List.fold_left (fun acc (_, ktypes) -> + List.fold_left (fun acc t -> Univ.Level.Set.union acc (universes_of_term state t)) acc ktypes) + used constructors in + let used = + let open Context.Rel.Declaration in + List.fold_left (fun acc -> function + | LocalDef(_,t,b) -> + Univ.Level.Set.union acc + (Univ.Level.Set.union (universes_of_term state t) (universes_of_term state b)) + | LocalAssum(_,t) -> Univ.Level.Set.union acc (universes_of_term state t)) + used params in + let sigma = restricted_sigma_of used state in + state, comInductive_interp_mutual_inductive_constr + ~sigma + ~template:(Some false) + ~udecl + ~variances + ~ctx_params:params + ~arities + ~constructors + ~env_ar_params + ~cumulative + ~poly + ~private_ind + ~finite:finiteness + ~indnames |> comInductive_interp_mutual_inductive_constr_post + in + state, (melims, mind, uctx, ubinders, None, ind_impls), List.concat (List.rev gls_rev) + in + let rec aux_decl coq_ctx ~depth params impls state extra t = @@ -3502,6 +3623,17 @@ let lp2inductive_entry ~depth coq_ctx constraints state t = let state, ty, gls = lp2constr coq_ctx ~depth state ty in let e = Context.Rel.Declaration.LocalAssum(name,ty) in aux_lam e coq_ctx ~depth (e :: params) (manual_implicit_of_binding_kind (Context.binder_name name) imp :: impls) state (gls :: extra) decl + | E.App(c,id,[fin;arity;rest]) + when c == minductivec -> + let name = in_coq_annot ~depth id in + if Name.is_anonymous (Context.binder_name name) then + err Pp.(str"id expected, got: "++ str (pp2string P.(term depth) id)); + let fin = if in_coq_bool ~depth state ~default:true fin then Declarations.Finite else Declarations.CoFinite in + let state, nuparams, nuimpls, arity, gl1 = readback_arity ~depth coq_ctx constraints state arity in + let iname = + match Context.binder_name name with Name x -> x | _ -> assert false in + let e = Context.Rel.Declaration.LocalAssum(name,arity) in + aux_mind_lam e coq_ctx ~depth params impls [(iname, nuparams, List.rev nuimpls, arity, fin)] state (gl1 :: extra) rest | E.App(c,id,[fin;arity;ks]) when c == inductivec -> let name = in_coq_annot ~depth id in @@ -3554,6 +3686,28 @@ let lp2inductive_entry ~depth coq_ctx constraints state t = | E.Lam t -> aux_decl (push_coq_ctx_local depth e coq_ctx) ~depth:(depth+1) params impls state extra t | _ -> err Pp.(str"lambda expected: " ++ str (pp2string P.(term depth) t)) + and aux_mind_decl coq_ctx ~depth params impls inds state extra t = + match E.look ~depth t with + | E.App(c,id,[fin;arity;rest]) when c == minductivec -> + let name = in_coq_annot ~depth id in + if Name.is_anonymous (Context.binder_name name) then + err Pp.(str"id expected, got: "++ str (pp2string P.(term depth) id)); + let fin = if in_coq_bool ~depth state ~default:true fin then Declarations.Finite else Declarations.CoFinite in + let state, nuparams, nuimpls, arity, gl1 = readback_arity ~depth coq_ctx constraints state arity in + let iname = + match Context.binder_name name with Name x -> x | _ -> assert false in + let e = Context.Rel.Declaration.LocalAssum(name,arity) in + aux_mind_lam e coq_ctx ~depth params impls ((iname, nuparams, List.rev nuimpls, arity, fin) :: inds) state (gl1 :: extra) rest + | E.App(c,blocks,[]) when c == mblockc -> + let inds = List.rev inds in + let constructor_blocks = constructor_blocks_of_lp ~depth blocks in + let state, res, gl2 = aux_mutual_constructors coq_ctx ~depth (params,List.rev impls) inds state constructor_blocks in + state, res, List.(concat (rev (gl2 :: extra))) + | _ -> err Pp.(str"minductive/mblock expected: " ++ str (pp2string P.(term depth) t)) + and aux_mind_lam e coq_ctx ~depth params impls inds state extra t = + match E.look ~depth t with + | E.Lam t -> aux_mind_decl (push_coq_ctx_local depth e coq_ctx) ~depth:(depth+1) params impls inds state extra t + | _ -> err Pp.(str"lambda expected: " ++ str (pp2string P.(term depth) t)) in aux_decl coq_ctx ~depth [] [] state [] t ;; @@ -3577,21 +3731,24 @@ let safe_combine2_impls l1 l2 ~default2 = (* convention: nuparams are also in each constructor *) type 'a ctx_entry = { id : Id.t; typ : EConstr.t; extra : 'a } -type constructor = { id : Id.t; arity : Glob_term.binding_kind ctx_entry list; typ : EConstr.t } +type constructor = { id : Id.t; arity : Glob_term.binding_kind ctx_entry list; typ : EConstr.t } +type inductive_decl = { + id : Id.t; + nuparams : Glob_term.binding_kind ctx_entry list; + typ : EConstr.t; + constructors : constructor list; + kind : Declarations.recursivity_kind; +} +type record_decl = { + id : Id.t; + kid : Id.t; + typ : EConstr.t; + fields : record_field_att list ctx_entry list; +} type ind_decl = - | Inductive of { - id : Id.t; - nuparams : Glob_term.binding_kind ctx_entry list; - typ : EConstr.t; - constructors : constructor list; - kind : Declarations.recursivity_kind; - } - | Record of { - id : Id.t; - kid : Id.t; - typ : EConstr.t; - fields : record_field_att list ctx_entry list; - } + | Inductive of inductive_decl + | Record of record_decl + | Mutual of ind_decl list type hoas_ind = { params : Glob_term.binding_kind ctx_entry list; decl : ind_decl; @@ -3710,6 +3867,51 @@ let hoas_ind2lp ~depth coq_ctx state { params; decl } = let state, ks, gls2 = API.Utils.map_acc embed_constructor state constructors in state, in_elpi_indtdecl_inductive state kind (Name id) arity ks, List.flatten [gls1 ; gls2] + | Mutual decls -> + let inds = List.map (function + | Inductive i -> i + | Record _ | Mutual _ -> nYI "records inside mutual inductive blocks") decls in + let ninds = List.length inds in + if ninds < 2 then nYI "ill-formed mutual inductive block"; + let sigma = get_sigma state in + let paramsno = List.length params in + let rec iter n acc f = + if n = 0 then acc + else iter (n-1) (f acc) f in + let subst arityno = CList.init (arityno + paramsno + ninds) (fun i -> + let i = i + 1 in + if i <= arityno then EC.mkRel i + else if i <= arityno + paramsno then EC.mkRel (i + ninds) + else + let indno = i - arityno - paramsno in + let ind = EC.mkRel (arityno + indno) in + iter paramsno ind (fun x -> EConstr.mkLambda (anonR,EConstr.mkProp,EConstr.Vars.lift 1 x))) in + let reloc ctx_len t = + let t = EC.Vars.substl (subst ctx_len) t in + Reductionops.nf_beta (Global.env()) sigma t in + let rec embed_arities coq_ctx depth state = function + | [] -> state, [], coq_ctx, depth, [] + | { id; nuparams; typ; _ } :: rest -> + let state, arity, gls = embed_arity ~depth coq_ctx state (nuparams,typ) in + let coq_ctx = push_coq_ctx_local depth (Context.Rel.Declaration.LocalAssum(anonR,EConstr.mkProp)) coq_ctx in + let state, arities, coq_ctx, depth, gls_rest = embed_arities coq_ctx (depth+1) state rest in + state, arity :: arities, coq_ctx, depth, gls @ gls_rest in + let state, arities, coq_ctx, depth, gls1 = embed_arities coq_ctx depth state inds in + let embed_constructor state { id; arity; typ } = + let alen = List.length arity in + let kctx = List.mapi (fun i ({ extra; typ } as x) -> { x with typ = reloc (alen - i -1) typ }) arity in + let state, karity, gl = embed_arity ~depth coq_ctx state (kctx,reloc alen typ) in + state, in_elpi_indtdecl_constructor (Name id) karity, gl in + let embed_constructor_block state { constructors; _ } = + API.Utils.map_acc embed_constructor state constructors in + let state, constructor_blocks, gls2 = + API.Utils.map_acc embed_constructor_block state inds in + let body = in_elpi_indtdecl_mblock constructor_blocks in + let body = + List.fold_right2 (fun { id; kind; _ } arity body -> + in_elpi_indtdecl_minductive state kind (Name id) arity body) + inds arities body in + state, body, List.flatten [gls1; gls2] | Record { id; kid; typ; fields } -> let embed_record_constructor state fields = under_coq2elpi_relctx ~calldepth:depth state fields @@ -3767,7 +3969,7 @@ let get_template_instance mind uinst = match mind.Declarations.mind_template wit | Some templ -> templ.template_defaults [%%endif] -let inductive_decl2lp ~depth coq_ctx constraints state (mutind,uinst,(mind,ind),(i_impls,k_impls)) = +let inductive_decl2lp ~depth coq_ctx constraints state (mutind,uinst,mind,(i_impls,k_impls)) = let { Declarations.mind_params_ctxt; mind_finite = kind; mind_nparams = allparamsno; @@ -3777,27 +3979,39 @@ let inductive_decl2lp ~depth coq_ctx constraints state (mutind,uinst,(mind,ind), let ntyps = Array.length mind.mind_packets in let mind_params_ctxt = Vars.subst_instance_context t_uinst mind_params_ctxt in let allparams = List.map EConstr.of_rel_decl mind_params_ctxt in - let allparams = safe_combine2_impls allparams i_impls ~default2:Glob_term.Explicit |> param2ctx in + let i_impls0 = match i_impls with [] -> [] | x :: _ -> x in + let allparams = safe_combine2_impls allparams i_impls0 ~default2:Glob_term.Explicit |> param2ctx in let nuparamsno = allparamsno - paramsno in let nuparams, params = CList.chop nuparamsno allparams in - let { Declarations.mind_consnames = constructor_names; - mind_typename = id; - mind_nf_lc = constructor_types; - } = ind in - let mind_record = mind_record (mind,ind) in - let constructor_types = constructor_types |> Array.map (fun (ctx,ty) -> Vars.subst_instance_context t_uinst ctx, Vars.subst_instance_constr t_uinst ty) in - let arity_w_params = Inductive.type_of_inductive ((mind,ind),uinst) in + let sigma = get_sigma state in let drop_nparams_from_term n x = let x = EConstr.of_constr x in let ctx, sort = EConstr.decompose_prod_decls sigma x in let ctx = drop_nparams_from_ctx n ctx in EConstr.it_mkProd_or_LetIn sort ctx in - let decl = + let one_inductive_decl ind_index ind _i_impls k_impls = + let { Declarations.mind_consnames = constructor_names; + mind_typename = id; + mind_nf_lc = constructor_types; + } = ind in + let mind_record = mind_record (mind,ind) in + let constructor_types = + constructor_types |> Array.map (fun (ctx,ty) -> + Vars.subst_instance_context t_uinst ctx, Vars.subst_instance_constr t_uinst ty) in + let arity_w_params = Inductive.type_of_inductive ((mind,ind),uinst) in if mind_record = Declarations.NotRecord then let typ = drop_nparams_from_term allparamsno arity_w_params in + let constructor_names = Array.to_list constructor_names in + let constructor_types = Array.to_list constructor_types in + if List.length constructor_names <> List.length constructor_types || + List.length k_impls > List.length constructor_names then + err Pp.(str"ill-shaped mutual inductive constructor metadata for " ++ Id.print id ++ + str": names=" ++ int (List.length constructor_names) ++ + str" types=" ++ int (List.length constructor_types) ++ + str" implicits=" ++ int (List.length k_impls)); let constructors = - safe_combine3 (Array.to_list constructor_names) (Array.to_list constructor_types) k_impls ~default3:[] |> + safe_combine3 constructor_names constructor_types k_impls ~default3:[] |> List.map (fun (id,(ctx,x),impls) -> let x = Term.it_mkProd_or_LetIn x ctx |> @@ -3810,11 +4024,12 @@ let inductive_decl2lp ~depth coq_ctx constraints state (mutind,uinst,(mind,ind), let arity = drop_nparams_from_ctx paramsno ctx |> param2ctx in { id; arity; typ }) in Inductive { nuparams; id; typ; kind; constructors } - else + else begin + if ntyps <> 1 then nYI "mutual records"; let kid = constructor_names.(0) in if (nuparamsno != 0) then nYI "record with non uniform paramters"; let env = get_global_env state in - let projections = (find_structure env (mutind,0)).Structures.Structure.projections in + let projections = (find_structure env (mutind,ind_index)).Structures.Structure.projections in let fieldsno = List.length projections in let kctx, _ = constructor_types.(0) in let kctx = EConstr.of_rel_context kctx in @@ -3842,11 +4057,26 @@ let inductive_decl2lp ~depth coq_ctx constraints state (mutind,uinst,(mind,ind), | LocalDef _, _ -> nYI "let-in in record fields parameters") l in let fields = List.combine kctx fields_atts |> param2field in Record { id; kid; typ; fields } - in + end + in + let packets = Array.to_list mind.mind_packets in + let rec pad_impls xs ys default = + match xs, ys with + | [], _ -> [] + | _ :: xs, y :: ys -> y :: pad_impls xs ys default + | _ :: xs, [] -> default :: pad_impls xs [] default in + let i_impls = pad_impls packets i_impls [] in + let k_impls = pad_impls packets k_impls [] in + let decls = List.mapi (fun i ind -> + let i_impls_i = List.nth i_impls i in + let k_impls_i = List.nth k_impls i in + one_inductive_decl i ind i_impls_i k_impls_i) packets in + let decl = match decls with + | [decl] -> decl + | decls -> Mutual decls in let ind = { params; decl } in hoas_ind2lp ~depth coq_ctx state ind ;; - let upoly_decl_of ~depth state ~loose_udecl mie = let open Entries in match mie.mind_entry_universes with @@ -3882,16 +4112,13 @@ let inductive_entry2lp ~depth coq_ctx constraints state ~loose_udecl e = let open ComInductive.Mind_decl in let open Entries in let { mie; nuparams; univ_binders; implicits; uctx } = e in - let i_impls, k_impls = match implicits with - | [i,k] -> + let i_impls, k_impls = + List.map (fun (i,k) -> List.map binding_kind_of_manual_implicit i, - List.map (List.map binding_kind_of_manual_implicit) k - | _ -> nYI "mutual inductives" in - let ind = match mie.mind_entry_inds with - | [ x ] -> x - | _ -> nYI "mutual inductives" in - let indno = 1 in - let state = + List.map (List.map binding_kind_of_manual_implicit) k) implicits + |> List.split in + let indno = List.length mie.mind_entry_inds in + let state = S.update engine state (fun e -> { e with sigma = merge_universe_context_set UState.univ_flexible e.sigma uctx}) in let state = match mie.mind_entry_universes with @@ -3913,16 +4140,30 @@ let inductive_entry2lp ~depth coq_ctx constraints state ~loose_udecl e = | Finite | CoFinite -> if (allparams <> []) then inference_nonuniform_params_off (); 0 in + let i_impls0 = match i_impls with [] -> [] | x :: _ -> x in let allparams = EConstr.of_rel_context allparams in - let allparams = safe_combine2_impls allparams i_impls ~default2:Glob_term.Explicit |> param2ctx in + let allparams = safe_combine2_impls allparams i_impls0 ~default2:Glob_term.Explicit |> param2ctx in let nuparams, params = CList.chop nuparamsno allparams in - let id = ind.mind_entry_typename in - let typ = EConstr.of_constr ind.mind_entry_arity in - let constructors = List.combine ind.mind_entry_consnames ind.mind_entry_lc in - let constructors = List.map (fun (id,typ) -> - (* FIXME, arity could be longer *) - { id; arity = nuparams; typ = EConstr.of_constr typ }) constructors in - let ind = { params; decl = Inductive { id; nuparams; typ; kind; constructors } } in + let one_ind ind k_impls = + let id = ind.mind_entry_typename in + let typ = EConstr.of_constr ind.mind_entry_arity in + let constructors = List.combine ind.mind_entry_consnames ind.mind_entry_lc in + let constructors = safe_combine2_impls constructors k_impls ~default2:[] |> + List.map (fun ((id,typ),_impls) -> + (* FIXME, arity could be longer *) + { id; arity = nuparams; typ = EConstr.of_constr typ }) in + Inductive { nuparams; id; typ; kind; constructors } in + let rec pad_impls xs ys default = + match xs, ys with + | [], _ -> [] + | _ :: xs, y :: ys -> y :: pad_impls xs ys default + | _ :: xs, [] -> default :: pad_impls xs [] default in + let k_impls = pad_impls mie.mind_entry_inds k_impls [] in + let decls = List.map2 one_ind mie.mind_entry_inds k_impls in + let decl = match decls with + | [decl] -> decl + | decls -> Mutual decls in + let ind = { params; decl } in let state, i, gls = hoas_ind2lp ~depth coq_ctx state ind in state, upoly_decl_of i, gls @ upoly_decl_gls ;; diff --git a/src/rocq_elpi_HOAS.mli b/src/rocq_elpi_HOAS.mli index 05d2ec4b4..46b0f72f7 100644 --- a/src/rocq_elpi_HOAS.mli +++ b/src/rocq_elpi_HOAS.mli @@ -141,7 +141,7 @@ val lp2record_field_spec : record_field_spec -> Name.t * Record.Data.projection_ [%%endif] val inductive_decl2lp : - depth:int -> empty conv_context -> constraints -> State.t -> (Names.MutInd.t * UVars.Instance.t * (Declarations.mutual_inductive_body * Declarations.one_inductive_body) * (Glob_term.binding_kind list * Glob_term.binding_kind list list)) -> + depth:int -> empty conv_context -> constraints -> State.t -> (Names.MutInd.t * UVars.Instance.t * Declarations.mutual_inductive_body * (Glob_term.binding_kind list list * Glob_term.binding_kind list list list)) -> State.t * term * Conversion.extra_goals val inductive_entry2lp : diff --git a/src/rocq_elpi_builtins.ml b/src/rocq_elpi_builtins.ml index 5632e407d..794d24655 100644 --- a/src/rocq_elpi_builtins.ml +++ b/src/rocq_elpi_builtins.ml @@ -2093,7 +2093,7 @@ Supported attributes: Inductive.type_of_inductive (ind,uinst) |> EConstr.of_constr) in let knames = if_keep knames (fun () -> - CList.(init Declarations.(indbo.mind_nb_constant + indbo.mind_nb_args) (fun k -> i,k+1))) in + CList.(init (Array.length Declarations.(indbo.mind_consnames)) (fun k -> i,k+1))) in let ktypes = if_keep ktypes (fun () -> Inductive.type_of_constructors (i,uinst) ind |> CArray.map_to_list EConstr.of_constr) in @@ -2108,17 +2108,28 @@ Supported attributes: % Supported attributes: % - @uinstance! I (default: fresh instance I)|}))), (fun i _ ~depth { env; options } _ state -> - let mind, indbo = lookup_inductive env i in + let mind, _indbo = lookup_inductive env i in let uinst, state, extra_goals = handle_uinst_option_for_inductive ~depth options i state in - let knames = CList.(init Declarations.(indbo.mind_nb_constant + indbo.mind_nb_args) (fun k -> GlobRef.ConstructRef(i,k+1))) in - let k_impls = List.map (fun x -> Impargs.extract_impargs_data (Impargs.implicits_of_global x)) knames in let hd x = match x with [] -> [] | (_,x) :: _ -> List.map implicit_kind_of_status x in - let k_impls = List.map hd k_impls in - let i_impls = Impargs.extract_impargs_data @@ Impargs.implicits_of_global (GlobRef.IndRef i) in - let i_impls = hd i_impls in - state, !: (fst i, uinst, (mind,indbo), (i_impls,k_impls)), extra_goals)), + let packets = Array.to_list mind.Declarations.mind_packets in + let i_impls = List.mapi (fun indno _ -> + Impargs.extract_impargs_data (Impargs.implicits_of_global (GlobRef.IndRef (fst i, indno))) |> hd) packets in + let k_impls = List.mapi (fun indno indbo -> + let ind = (fst i, indno) in + let knames = CList.(init (Array.length Declarations.(indbo.mind_consnames)) (fun k -> GlobRef.ConstructRef(ind,k+1))) in + List.map (fun x -> Impargs.extract_impargs_data (Impargs.implicits_of_global x) |> hd) knames) packets in + state, !: (fst i, uinst, mind, (i_impls,k_impls)), extra_goals)), DocNext); + MLCode(Pred("coq.env.mutual-inductives", + In(inductive, "reference to an inductive type", + Out(list inductive, "Inductives", + Read(global, "lists all inductive types in the same mutual block, in declaration order"))), + (fun i _ ~depth { env } _ _state -> + let mind, _indbo = lookup_inductive env i in + !: CList.(init (Array.length Declarations.(mind.mind_packets)) (fun k -> fst i, k)))), + DocAbove); + MLCode(Pred("coq.env.indc->indt", In(constructor,"K", Out(inductive,"I", @@ -2202,12 +2213,9 @@ regarded as not non-informative).|})), In(inductive, "Ind", Read(global, "checks if Ind is recursive")), (fun i ~depth {env} _ state -> - let mind, indbo = Inductive.lookup_mind_specif env i in - match mind.Declarations.mind_packets with - | [| mip |] -> - if mis_is_recursive mip then () - else raise No_clause - | _ -> assert false + let _, indbo = Inductive.lookup_mind_specif env i in + if mis_is_recursive indbo then () + else raise No_clause )), DocAbove); @@ -2619,16 +2627,17 @@ Supported attributes: let univ_binders = univ_binder_compat_820 (uentry', ubinders) univ_binders in declare_mutual_inductive_with_eliminations ~primitive_expected ~default_dep_elim me univ_binders ind_impls in let ind = mind, 0 in - let id, cids = match me.Entries.mind_entry_inds with - | [ { Entries.mind_entry_typename = id; mind_entry_consnames = cids }] -> id, cids - | _ -> assert false - in let lid_of id = CAst.make ~loc:(to_coq_loc @@ State.get Rocq_elpi_builtins_synterp.invocation_site_loc state) id in begin match record_info with | None -> (* regular inductive *) - Dumpglob.dump_definition (lid_of id) false "ind"; - List.iter (fun x -> Dumpglob.dump_definition (lid_of x) false "constr") cids + List.iter (fun { Entries.mind_entry_typename = id; mind_entry_consnames = cids; _ } -> + Dumpglob.dump_definition (lid_of id) false "ind"; + List.iter (fun x -> Dumpglob.dump_definition (lid_of x) false "constr") cids) + me.Entries.mind_entry_inds | Some (primitive,field_specs) -> (* record: projection... *) + let id = match me.Entries.mind_entry_inds with + | [ { Entries.mind_entry_typename = id; _ } ] -> id + | _ -> assert false in let names, flags = List.(split (map lp2record_field_spec field_specs)) in diff --git a/src/rocq_elpi_utils.ml b/src/rocq_elpi_utils.ml index 050a88f9f..1980cdea1 100644 --- a/src/rocq_elpi_utils.ml +++ b/src/rocq_elpi_utils.ml @@ -205,9 +205,7 @@ let binding_kind_of_manual_implicit x = let manual_implicit_of_gdecl (name, _, bk, _, _) = manual_implicit_of_binding_kind name bk let lookup_inductive env i = - let mind, indbo = Inductive.lookup_mind_specif env i in - if Array.length mind.Declarations.mind_packets <> 1 then nYI "API(env) mutual inductive"; - (mind, indbo) + Inductive.lookup_mind_specif env i [%%if coq = "9.0" || coq = "9.1"] let abbreviation_find_interp = Abbreviation.search_abbreviation diff --git a/tests/test_mutind.v b/tests/test_mutind.v new file mode 100644 index 000000000..ccf28f2ae --- /dev/null +++ b/tests/test_mutind.v @@ -0,0 +1,95 @@ +From elpi Require Import elpi. + +Inductive tree : Type := +| node (f : forest) +with forest : Type := +| empty +| cons (t : tree) (f : forest). + +Inductive ptree (A : Type) : Type := +| pnode (x : A) (f : pforest A) +with pforest (A : Type) : Type := +| pempty +| pcons (t : ptree A) (f : pforest A). + +Inductive even : nat -> Type := +| evenO : even 0 +| evenS n : odd n -> even (S n) +with odd : nat -> Type := +| oddS n : even n -> odd (S n). + +Elpi Command test_mutind. +Elpi Accumulate lp:{{ +main _ :- + coq.locate "tree" (indt Tree), + coq.env.indt-decl Tree TreeDecl, + std.assert-ok! (coq.typecheck-indt-decl TreeDecl) "tree declaration illtyped", + + coq.locate "ptree" (indt PTree), + coq.env.indt-decl PTree PTreeDecl, + std.assert-ok! (coq.typecheck-indt-decl PTreeDecl) "ptree declaration illtyped", + + coq.locate "even" (indt Even), + coq.env.indt-decl Even EvenDecl, + std.assert-ok! (coq.typecheck-indt-decl EvenDecl) "even declaration illtyped", + + Tree2Decl = (minductive "tree2" tt (arity {{ Type }}) t\ + (minductive "forest2" tt (arity {{ Type }}) f\ + (mblock [ + [constructor "node2" (arity {{ lp:f -> lp:t }})], + [constructor "empty2" (arity f), + constructor "cons2" (arity {{ lp:t -> lp:f -> lp:f }})] + ]))), + std.assert-ok! (coq.typecheck-indt-decl Tree2Decl) "tree2 declaration illtyped", + coq.env.add-indt Tree2Decl _, + + PTree2Decl = (parameter "A" explicit {{ Type }} a\ + (minductive "ptree2" tt (arity {{ Type }}) t\ + (minductive "pforest2" tt (arity {{ Type }}) f\ + (mblock [ + [constructor "pnode2" (arity {{ lp:a -> lp:f -> lp:t }})], + [constructor "pempty2" (arity f), + constructor "pcons2" (arity {{ lp:t -> lp:f -> lp:f }})] + ])))), + std.assert-ok! (coq.typecheck-indt-decl PTree2Decl) "ptree2 declaration illtyped", + coq.env.add-indt PTree2Decl _, + + Even2Decl = (minductive "even2" tt (arity {{ nat -> Type }}) even\ + (minductive "odd2" tt (arity {{ nat -> Type }}) odd\ + (mblock [ + [constructor "evenO2" (arity {{ lp:even 0 }}), + constructor "evenS2" (parameter "n" explicit {{ nat }} n\ + arity {{ lp:odd lp:n -> lp:even (S lp:n) }})], + [constructor "oddS2" (parameter "n" explicit {{ nat }} n\ + arity {{ lp:even lp:n -> lp:odd (S lp:n) }})] + ]))), + std.assert-ok! (coq.typecheck-indt-decl Even2Decl) "even2 declaration illtyped", + coq.env.add-indt Even2Decl _. +}}. +Module Generated. + Elpi test_mutind. +End Generated. + +Universe tree2_u ptree2_arg_u ptree2_u even2_u. + +Module Type GeneratedMutualInductives. + Inductive tree2 : Type@{tree2_u} := + | node2 (f : forest2) + with forest2 : Type@{tree2_u} := + | empty2 + | cons2 (t : tree2) (f : forest2). + + Inductive ptree2 (A : Type@{ptree2_arg_u}) : Type@{ptree2_u} := + | pnode2 (x : A) (f : pforest2 A) + with pforest2 (A : Type@{ptree2_arg_u}) : Type@{ptree2_u} := + | pempty2 + | pcons2 (t : ptree2 A) (f : pforest2 A). + + Inductive even2 : nat -> Type@{even2_u} := + | evenO2 : even2 0 + | evenS2 n : odd2 n -> even2 (S n) + with odd2 : nat -> Type@{even2_u} := + | oddS2 n : even2 n -> odd2 (S n). +End GeneratedMutualInductives. + +Module GeneratedMatches <: GeneratedMutualInductives := Generated.