From c41654b8e3f8da3b8f7ae9b8b1efbb6c8140e0c1 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Fri, 6 Jun 2025 17:28:31 +0200 Subject: [PATCH 01/42] inhab + examples for irrelevance algorithm design collecting projectors partially generating the type of the injection lemma partially generating the type of injection lemmas + params deriving injection lemmas type correcting use of is injection terms + definitions adding injection lemmas to the db --- generic/demo.v | 272 ++++++ generic/exec_bool.v | 1498 +++++++++++++++++++++++++++++++++ generic/injection_lemmas.elpi | 184 ++++ generic/injection_lemmas.v | 105 +++ generic/param2_inhab.elpi | 134 +++ generic/param2_inhab.v | 556 ++++++++++++ generic/param2_trivial.elpi | 130 +++ generic/test_param2_inhab.v | 67 ++ 8 files changed, 2946 insertions(+) create mode 100644 generic/demo.v create mode 100644 generic/exec_bool.v create mode 100644 generic/injection_lemmas.elpi create mode 100644 generic/injection_lemmas.v create mode 100644 generic/param2_inhab.elpi create mode 100644 generic/param2_inhab.v create mode 100644 generic/param2_trivial.elpi create mode 100644 generic/test_param2_inhab.v diff --git a/generic/demo.v b/generic/demo.v new file mode 100644 index 00000000..6be2659b --- /dev/null +++ b/generic/demo.v @@ -0,0 +1,272 @@ +From HB Require Import structures. +From Coq Require Import ssreflect ssrfun ssrbool. +From mathcomp Require Import eqtype. +Require Import HoTT_additions Hierarchy. +From elpi.apps Require Import derive.std. + +Require Import param2_inhab. + +Set Universe Polymorphism. +Unset Universe Minimization ToSet. + +Section rel_uniq_refl. + + Variable A : eqType. + + Variable AR : A -> A -> Type. + Hypothesis AR_refl : forall a : A, AR a a. + Hypothesis AR_eqb : forall a1 a2 : A, AR a1 a2 -> eq_op a1 a2. + Hypothesis rel_refl_uniq : forall (a : A) (r1 : AR a a), r1 = (AR_refl a). + + Lemma eqb_AR (a1 a2 : A) : eq_op a1 a2 -> AR a1 a2. + Proof. by move=> /eqP->; apply AR_refl. Qed. + + Lemma AR_irrel : forall (a1 a2 : A) (r1 r2 : AR a1 a2), r1 = r2. + Proof. + move=> a1 a2 r. + have e : a1 = a2 by apply /eqP; apply AR_eqb. + move: r; rewrite {}e=> r1 r2. + by rewrite (rel_refl_uniq _ r1) (rel_refl_uniq _ r2). + Qed. + + Definition mapR : A -> A := idmap. + + Lemma mR : forall a1 a2 : A, mapR a1 = a2 -> AR a1 a2. + Proof. by move=> a1 a2; by rewrite /mapR=> ->; apply AR_refl. Qed. + + Lemma Rm : forall a1 a2 : A, AR a1 a2 -> idmap a1 = a2. + Proof. by move=> /= a1 a2 /AR_eqb /eqP ->. Qed. + + Lemma mRRmK : forall (a1 a2 : A) (r : AR a1 a2), mR a1 a2 (Rm a1 a2 r) = r. + Proof. by move=> a1 a2 r; apply AR_irrel. Qed. + + Lemma Map4_AR : Map4.Has AR. + Proof. + unshelve econstructor. + by apply mapR. + by apply mR. + by apply Rm. + by apply mRRmK. + Qed. + + Lemma AR_sym : forall a1 a2, AR a1 a2 -> AR a2 a1. + Proof. by move=> a1 a2 /AR_eqb/eqP ->; apply AR_refl. Qed. + + Lemma AR_sym_R : forall (a1 a2 : A), sym_rel AR a1 a2 <->> AR a1 a2. + Proof. + intros a1 a2; unshelve eexists _,_ . + - by apply AR_sym. + - by apply AR_sym. + - by move=> r; apply AR_irrel. + Qed. + + Lemma Param44_AR : Param44.Rel A A. + Proof. + unshelve econstructor. + - exact AR. + - exact Map4_AR. + - apply (fun e => @eq_Map4 _ _ (sym_rel AR) AR e Map4_AR). + apply AR_sym_R. + Qed. + +End rel_uniq_refl. + +Unset Universe Polymorphism. +Require Import Coq.Program.Equality. + +Inductive Bool := FF | TT. +Elpi derive Bool. +Elpi derive.param2.inhab Bool_R. + +HB.instance Definition _ := hasDecEq.Build Bool Bool_eqb_OK. + + Lemma Param44_Bool : Param44.Rel Bool Bool. + Proof. + unshelve eapply (@Param44_AR Bool Bool_R). + + exact: Bool_R_inhab. + + by move=> a1 a2 []. + + by move=> a r1 /=; dependent destruction r1. + Qed. + +(* Require Import test_param. *) + Module tests. + + Inductive empty := . + Elpi derive empty. + Elpi derive.param2.inhab empty_R. + + + HB.instance Definition _ := hasDecEq.Build empty empty_eqb_OK. + + Lemma Param44_empty : Param44.Rel empty empty. + Proof. + unshelve eapply (@Param44_AR empty empty_R). + + exact: empty_R_inhab. + + by move=> a1 a2 []. + + by move=> a r1 /=; dependent destruction r1. + Qed. + + Inductive peano := Zero | Succ (n : peano). + Elpi derive peano. + Elpi derive.param2.inhab peano_R. + HB.instance Definition _ := hasDecEq.Build peano peano_eqb_OK. + + + Lemma peano_R_irrel n1 n2 (r1 r2 : peano_R n1 n2) : r1 = r2. + Proof. by dependent induction r1=> [//|/=]; f_equal; dependent destruction r2=> //; f_equal; apply IHr1. Qed. + Lemma Param44_peano : Param44.Rel peano peano. + Proof. + unshelve eapply (@Param44_AR peano peano_R). + + exact: peano_R_inhab. + + by move=> a1 a2; elim=> [//| n1 n2 r'] /eqP->. + + by move=> a r1; apply peano_R_irrel. + Qed. + + (* Inductive option A := None | Some (_ : A). *) + + (* Inductive pair A B := Comma (a : A) (b : B). *) + + (* Inductive seq A := Nil | Cons (x : A) (xs : seq A). *) + + Inductive box_peano := Box (n:peano). + Elpi derive box_peano. + Elpi derive.param2.inhab box_peano_R. + HB.instance Definition _ := hasDecEq.Build box_peano box_peano_eqb_OK. + + Lemma Param44_box_peano : Param44.Rel box_peano box_peano. + Proof. + unshelve eapply (@Param44_AR box_peano box_peano_R). + + exact: box_peano_R_inhab. + + by move=> a1 a2; elim=> [n1 n2 r']; apply/eqP; f_equal; elim: r'=> [//| n1' n2' r''] ->. + + move=> a /= r1; dependent destruction r1=> []. + dependent destruction n_R=> [//|]; rewrite /=; f_equal. + by apply peano_R_irrel. + Qed. + + (* Inductive rose (A : Type) := Leaf (a : A) | Node (sib : seq (rose A)). *) + + (* Inductive rose_p (A B : Type) := Leafp (p : pair A B) | Nodep (sib : pair (rose_p A B) (rose_p A B)). *) + + (* Inductive rose_o (A : Type) := Leafo (a : A) | Nodeo (x: pair (rose A) (rose A)) (sib : option (seq (rose A))). *) + + (* Inductive nest A := NilN | ConsN (x : A) (xs : nest (pair A A)). *) + + (* Fail Inductive bush A := BNil | BCons (x : A) (xs : bush (bush A)). *) + + (* Inductive w A := via (f : A -> w A). *) + + (* Inductive vect A : peano -> Type := VNil : vect A Zero | VCons (x : A) n (xs : vect A n) : vect A (Succ n). *) + + (* Inductive dyn := box (T : Type) (t : T). *) + + (* Inductive zeta Sender (Receiver := Sender) := Envelope (a : Sender) (ReplyTo := a) (c : Receiver). *) + + (* Inductive beta (A : (fun x : Type => x) Type) := Redex (a : (fun x : Type => x) A). *) + + Inductive iota := Why n (a : match n in peano return Type with Zero => peano | Succ _ => unit end). + (* Check iota. *) + + Inductive large := + | K1 (_ : unit) + | K2 (_ : unit) (_ : unit) + | K3 (_ : unit) (_ : unit) (_ : unit) + | K4 (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K5 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K6 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K7 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K8 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K9 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K10(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K11(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K12(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K13(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K14(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K15(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K16(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K17(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K18(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K19(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K20(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K21(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K22(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K23(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K24(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K25(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) + | K26(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit). + + Inductive prim_int := PI (i : PrimInt63.int). + Inductive prim_float := PF (f : PrimFloat.float). + (* Inductive prim_string := PS (s : lib:elpi.pstring). *) + + Record fo_record := { f1 : peano; f2 : unit; }. + + (* Record pa_record A := { f3 : peano; f4 : A; }. *) + + (* Set Primitive Projections. *) + (* Record pr_record A := { pf3 : peano; pf4 : A; }. *) + (* Unset Primitive Projections. *) + + (* Record dep_record := { f5 : peano; f6 : vect unit f5; }. *) + + Variant enum := E1 | E2 | E3. + + + (* Record sigma_bool := { depn : peano; depeq : is_zero depn = true }. *) + + (* Record sigma_bool2 := { depn2 : peano; depeq2 : lib:elpi.is_true (is_zero depn2) }. *) + + Fixpoint is_leq (n m:peano) : bool := + match n, m with + | Zero, _ => true + | Succ n, Succ m => is_leq n m + | _, _ => false + end. + + Inductive ord (p : peano) := mkOrd (n : peano) (l : is_leq n p = true). + + Inductive ord2 (p : peano) := mkOrd2 (o1 o2 : ord p). + + Inductive val := V (p : peano) (oo : ord p). + + (* to make the coverage cound correct +Inductive eq := ... +Inductive bool := ... +we don't have a copy here because some DBs have special rules*) + + End tests. + + Elpi derive Inductive Peano := Zero | Succ (p : Peano). + + Section tests. + + Lemma RBool_refl (b : Bool) : BoolR b b. + Proof. by case b; constructor. Defined. + + Require Import Coq.Program.Equality. + + Lemma RBool_uniq : forall b (bR : BoolR b b), bR = RBool_refl b. + Proof. + move=> b bR. + by dependent induction bR. + Qed. + + Lemma BoolRcorrect_another (b b' : Bool) (r : BoolR b b') : eqb_bool b b'. + Proof. by apply BoolRcorrect. Defined. + + Lemma bool_eqDec : forall b1 b2, reflect (b1 = b2) (eqb_bool b1 b2). + Proof. + move=> b1 b2; apply (iffP idP). + + by case: b1; case: b2. + + by move=> ->; case: b2. + Qed. + + Lemma Param44_Bool_another : Param44.Rel Bool Bool. + Proof. + eapply (Param44_AR Bool eqb_bool BoolR). + - by apply BoolRcorrect_another. + - by apply bool_eqDec. + - exact RBool_uniq. + Qed. + + +End tests. diff --git a/generic/exec_bool.v b/generic/exec_bool.v new file mode 100644 index 00000000..b3e0d50e --- /dev/null +++ b/generic/exec_bool.v @@ -0,0 +1,1498 @@ + +(*****************************************************************************) +(* * Trocq *) +(* _______ * Copyright (C) 2023 Inria & MERCE *) +(* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) +(* | |_ __ ___ ___ __ _ * Cyril Cohen *) +(* | | '__/ _ \ / __/ _` | * Enzo Crance *) +(* | | | | (_) | (_| (_| | * Assia Mahboubi *) +(* |_|_| \___/ \___\__, | ************************************************) +(* | | * This file is distributed under the terms of *) +(* |_| * GNU Lesser General Public License Version 3 *) +(* * see LICENSE file for the text of the license *) +(*****************************************************************************) + +From Coq Require Import ssreflect. +From elpi.apps.derive Require Import eqb_core_defs derive.std derive.legacy. +Require Import HoTT_additions Hierarchy. +Unset Uniform Inductive Parameters. +Unset Universe Polymorphism. + +Definition eqnn := @eq_ind_r_nP. +(* Inductive nums := *) +(* | ZZZ | NNN : nums -> nums. *) + +(* Inductive OhOh := *) +(* | C : (forall A, A -> A) -> OhOh. *) + +(* Elpi derive nums. *) +(* Elpi derive OhOh. *) + +(* Check OhOh_induction. *) + +(* Set Universe Polymorphism. *) +Unset Universe Minimization ToSet. + +Notation Unit := unit. + +Inductive UnitR : Unit -> Unit -> Type := + | ttR : UnitR tt tt. + +Definition m_unit : unit -> unit := idmap. +Definition mR_Unit (u1 u2 : Unit) : m_unit u1 = u2 -> UnitR u1 u2. +Proof. +refine (fun e => + match u1 with + | tt => match u2 with + | tt => ttR + end end +). +Defined. + +Definition Rm_Unit (u1 u2 : Unit) : UnitR u1 u2 -> m_unit u1 = u2. +Proof. +refine (fun r => + match r with + | ttR => 1 + end +). +Defined. + +Definition mRRmK_Unit (u1 u2 : Unit) (r1 : UnitR u1 u2) : mR_Unit u1 u2 (Rm_Unit u1 u2 r1) = r1. +Proof. +by elim: r1. +Qed. + +Notation Bool := bool. + +Inductive BoolR : Bool -> Bool -> Type := + | falseR : BoolR false false + | trueR : BoolR true true. + +Definition map_Bool : Bool -> Bool := id. + +Definition exF : forall T, true = false -> T := +fun T e => + match e in _ = t return + match t with + | false => T + | true => unit + end + with eq_refl => tt end. + +Definition exF' : forall T, false = true -> T := +fun T e => + match e in _ = t return + match t with + | true => T + | false => unit + end + with eq_refl => tt end. + + +Definition mR_Bool : forall (b b' : Bool) (e : map_Bool b = b'), BoolR b b' := + fun b b' => + match b as bb with + | true => match b' as bb' with + | true => fun e => trueR + | false => fun e => exF _ e + end + | false => match b' with + | true => fun e => exF' _ e + | false => fun e => falseR + end + end. + +Definition Rm_Bool : forall (b b' : Bool) (bR: BoolR b b'), (map_Bool b = b') := +fun b b' bR => + match bR with + | trueR => idpath + | falseR => idpath + end. + +Definition mRRmKBool : forall (b b' : Bool) (bR : BoolR b b'), + mR_Bool b b' (Rm_Bool b b' bR) = bR. +Proof. +move=> b b' []//=. +Qed. + +Inductive enum := +| K1 : unit -> enum +| K2 : Bool -> enum. + +Definition m_enum : enum -> enum := idmap. +Inductive enumR : enum -> enum -> Type := + | K1R : forall u1 u2, UnitR u1 u2 -> enumR (K1 u1) (K1 u2) + | K2R : forall b1 b2, BoolR b1 b2 -> enumR (K2 b1) (K2 b2). + +Definition K1_proj1 : forall u : unit, enum -> unit := +fun u e => match e with K1 u => u | K2 _ => u end. + + +Lemma K1_inj (u1 u2 : unit) : K1 u1 = K1 u2 -> u1 = u2. +Proof. +move=> e. +exact (ap (K1_proj1 u1) e). +Defined. + +Lemma K1_inj' (u1 u2 : unit) : K1 u1 = K1 u2 -> u1 = u2. +Proof. +by case. +Defined. + +Definition K1_inj'' (u1 u2 : unit) : K1 u1 = K1 u2 -> u1 = u2 := +let p := fun u e => match e with K1 u => u | K2 _ => u end in +fun e => ap (p u1) e. + + +Definition K2_proj1 : forall b : bool, enum -> bool := +fun b e => match e with K2 b => b | K1 _ => b end. + +Lemma K2_inj (b1 b2 : bool) : K2 b1 = K2 b2 -> b1 = b2. +Proof. +move=> e. exact (ap (K2_proj1 b1) e). +Defined. + +Lemma K1_K2_discr (T : Type) (u1 : unit)(b1 : bool) : K1 u1 = K2 b1 -> T. +Proof. + move=> e. +refine (match e in _ = t return + match t with + | K1 _ => unit + | K2 _ => T end + + with eq_refl => tt end + ). +Defined. + +Lemma K2_K1_discr (T : Type) (b : bool) (u : unit): K2 b = K1 u -> T. +Proof. +move=> e. +refine ( match e in _ = t return + match t with + | K1 _ => T + | K2 _ => unit + end + with eq_refl => tt end ). +Defined. + +Definition mR_enum : forall (e1 e2 : enum), m_enum e1 = e2 -> enumR e1 e2. +Proof. +move=> e1 e2. +elim: e1=> [u1|b1]; elim: e2=> [u2|b2]. +- move=> /K1_inj e; apply (K1R _ _ (mR_Unit _ _ e)). +- move=> /K1_K2_discr => /(_ False) []. +- move=> /K2_K1_discr => /(_ False) []. +- move=> /K2_inj e; apply (K2R _ _ (mR_Bool _ _ e)). +Defined. + +Print mR_enum. + +Definition mR_enum' : forall (e1 e2 : enum), m_enum e1 = e2 -> enumR e1 e2. +Proof. +refine (fun e1 e2 => + match e1 with + | K1 u1 => match e2 with + | K1 u2 => fun e => K1R _ _ (mR_Unit _ _ (K1_inj _ _ e)) + | K2 b2 => fun e => K1_K2_discr _ u1 b2 e + end + | K2 b1 => match e2 with + | K1 u2 => fun e => K2_K1_discr _ b1 u2 e + | K2 b2 => fun e => K2R _ _ (mR_Bool _ _ (K2_inj _ _ e)) + end + end +). +Defined. + +Definition Rm_enum : forall (e1 e2 : enum) (eR: enumR e1 e2), (m_enum e1 = e2). +Proof. +refine ( +fun e1 e2 eR => + match eR with + | K1R u1 u2 uR => (ap K1 (Rm_Unit _ _ uR)) (* match uR with ttR => idpath end *) + | K2R b1 b2 bR => (ap K2 (Rm_Bool _ _ bR)) + end). +Defined. + +Fixpoint eq_ind_r_n (T : tlist) : p_type T -> p_type T -> Prop := + match T return p_type T -> p_type T -> Prop with + | tnil => fun p q => p -> q + | tcons T Ts => fun p q => forall (x y : T), x = y -> @eq_ind_r_n Ts (p x) (q y) + end. + +Lemma eq_ind_r_nP (T : tlist) (p : p_type T) : @eq_ind_r_n T p p. +Proof. elim: T p => //= T Ts hrec f a1 a2 ->; apply hrec. Defined. + +Lemma eq_ind_r_nP' : forall (T : tlist) (p : p_type T), @eq_ind_r_n T p p. +Proof. +elim. +- refine (fun p H=> H). +- simpl. move=> T TS IH p x y e. +elim: (ap p e). +apply IH. +Defined. +Print eq_ind_r_nP'. +(* Lemma eq_ind_r_nP'' : forall (T : tlist) (p : p_type T), @eq_ind_r_n T p p. +refine (fix IH => fun T match T with + | tnil => _ + | tcons _ _ => _ + end). + +elim. +- move=> p. exact id. +- move=> T Ts hrec f a1 a2. + elim. apply hrec. +Defined. *) + +Definition eqnn_transp := @eq_ind_r_nP'. + +Definition Rm_enum' : forall (e1 e2 : enum) (eR: enumR e1 e2), (m_enum e1 = e2) := +fun e1 e2 eR => + match eR with + | K1R u1 u2 uR => + eqnn (tcons Unit tnil) (fun u1' => K1 u1 = K1 u1' ) _ _ (Rm_Unit _ _ uR) eq_refl + | K2R u1 u2 uR => + eqnn (tcons Bool tnil) (fun u1' => K2 u1 = K2 u1' ) _ _ (Rm_Bool _ _ uR) eq_refl + end. + +Definition Rm_enum'' : forall (e1 e2 : enum) (eR: enumR e1 e2), (m_enum e1 = e2) := +fun e1 e2 eR => + match eR with + | K1R u1 u2 uR => + eqnn_transp (tcons Unit tnil) (fun u1' => K1 u1 = K1 u1' ) _ _ (Rm_Unit _ _ uR) eq_refl + | K2R u1 u2 uR => + eqnn_transp (tcons Bool tnil) (fun u1' => K2 u1 = K2 u1' ) _ _ (Rm_Bool _ _ uR) eq_refl + end. + +Lemma inj_projK (u1 u2 : unit) (e : m_unit u1 = u2) : +(K1_inj u1 u2 (ap K1 e)) = e. +Proof. +by rewrite /K1_inj -ap_compose /= ap_idmap. Qed. + +Definition mRRmKEnum : forall (e1 e2 : enum) (eR : enumR e1 e2), + mR_enum _ _ (Rm_enum _ _ eR) = eR. +Proof. +move=> e1 e2 []//=. +- move=> u1 u2 uR. + by rewrite /K1_inj -ap_compose /= ap_idmap mRRmK_Unit. +- move=> b1 b2 bR. + by rewrite /K2_inj -ap_compose /= ap_idmap mRRmKBool. +Defined. + +Definition mRRmKEnum' : forall (e1 e2 : enum) (eR : enumR e1 e2), + mR_enum' _ _ (Rm_enum _ _ eR) = eR. +Proof. +move=> e1 e2 []//=. +- move=> u1 u2 uR. + by rewrite /K1_inj -ap_compose /= ap_idmap mRRmK_Unit. +- move=> b1 b2 bR. + by rewrite /K2_inj -ap_compose /= ap_idmap mRRmKBool. +Defined. +Print mRRmKEnum. + +Inductive enum3 := +| KK1 : unit -> unit -> enum3 +| KK2 : bool -> bool -> enum3. + +Inductive enum3R : enum3 -> enum3 -> Type := +| KK1R : forall (u1 u2 : unit), UnitR u1 u2 + -> forall (u3 u4 : unit), UnitR u3 u4 + -> enum3R (KK1 u1 u3) (KK1 u2 u4) +| KK2R : forall (b1 b2 : bool), BoolR b1 b2 + -> forall (b3 b4 : bool), BoolR b3 b4 + -> enum3R (KK2 b1 b3) (KK2 b2 b4). + +(* Elpi derive.map "pp". *) +Elpi derive.map "unit". +Elpi derive.map "bool". +Elpi derive.map "list". +Elpi derive.projK enum. +Print projK11. +Print projK21. +Elpi derive.projK list. +Print projcons1. +Print projcons2. + + +Elpi derive.projK enum3. +Print projKK11. + +Definition KK1_proj1 (u1 : unit) : enum3 -> unit:= + fun e => match e with KK1 u1 _ => u1 | _ => u1 end. + +Definition KK1_proj2 (u1 : unit) : enum3 -> unit:= + fun e => match e with KK1 _ u1 => u1 | _ => u1 end. + +Definition KK2_proj1 (b1 : bool) : enum3 -> bool:= + fun e => match e with KK2 b1 _ => b1 | _ => b1 end. + +Definition KK2_proj2 (b1 : bool) : enum3 -> bool:= + fun e => match e with KK2 _ b1 => b1 | _ => b1 end. + +Definition tr_ap {A : Type} {B : A -> Type} {C : Type} {D : C -> Type} + (f : A -> C) (g : forall (x : A) , B x -> D (f x)) + {x y : A} (p : x = y) (z : B x) : + transport D (ap f p) (g x z) = g y (transport B p z). +Proof. +exact (match p with eq_refl => eq_refl end). +Defined. + +Definition KK1_inj1 (u1 u2 u3 u4 : unit) : KK1 u1 u2 = KK1 u3 u4 -> u1 = u3. +Proof. + (* by refine (fun e => match e with eq_refl => eq_refl end). *) + move=> e. + (* sol1 *) + (* apply (ap (fun x=> KK1 x u4)). *) + exact: (ap (KK1_proj1 u1) e). + + (* eo sol1 *) + (* sol2 *) + (* have@ e' := (ap (KK1_proj2 u2) e) : u2 = u4. *) + (* have@ e'' := (ap (KK1_proj1 u1) e) : u1 = u3. *) + (* have@ e''' : KK1 u1 u4 = KK1 u3 u4. *) + (* have@ aux_transp1 : KK1 u1 u2 = KK1 u3 u2. *) + (* by apply (ap ( ( fun x => (KK1 x u2) ) ) e''). *) + (* (* by apply (ap ( ( fun x => (KK1 x u2) ) o (KK1_proj1 u1) ) e). *) *) + (* by have@ aux := (transport (fun x=> KK1 u1 x = KK1 u3 x) e' aux_transp1). *) + (* exact: (ap (KK1_proj1 u1) e'''). *) + (* Show Proof. *) + (* eo sol2 *) +Defined. + +Definition KK1_inj2 (u1 u2 u3 u4 : unit) : KK1 u1 u2 = KK1 u3 u4 -> u2 = u4. +exact: (fun e => (ap (KK1_proj2 u2) e)). +(* by refine (fun e => match e with eq_refl => eq_refl end). *) +Defined. + +Definition KK2_inj1 (u1 u2 u3 u4 : bool) : KK2 u1 u2 = KK2 u3 u4 -> u1 = u3. +exact: (fun e => (ap (KK2_proj1 _) e)). +Defined. + +Definition KK2_inj2 (u1 u2 u3 u4 : bool) : KK2 u1 u2 = KK2 u3 u4 -> u2 = u4. +exact: (fun e => (ap (KK2_proj2 u2) e)). +Defined. + +(* Definition KK2_inj1 (b1 b2 b3 b4 : bool) : KK2 b1 b2 = KK2 b3 b4 -> b1 = b3. *) +(* Proof. *) +(* by refine (fun e => match e with eq_refl => eq_refl end). *) +(* Defined. *) + +(* Definition KK2_inj2 (b1 b2 b3 b4 : bool) : KK2 b1 b2 = KK2 b3 b4 -> b2 = b4. *) +(* by refine (fun e => match e with eq_refl => eq_refl end). *) +(* Defined. *) + +Definition KK1_KK2 (T : Type) (u1 u2 : unit) (b1 b2 : bool) : + KK1 u1 u2 = KK2 b1 b2 -> T. +Proof. +refine (fun e => match e in _ = t return + match t with + | KK1 _ _ => unit + | KK2 _ _ => T end + with eq_refl => tt end). +Defined. + +Definition KK2_KK1 (T : Type) (b1 b2 : bool) (u1 u2 : unit) : + KK2 b1 b2 = KK1 u1 u2 -> T. +Proof. +refine (fun e => match e in _ = t return + match t with + | KK1 _ _ => T + | KK2 _ _ => unit end + with eq_refl => tt end). +Defined. + +Definition mR_enum3 (e1 e2 : enum3) : e1 = e2 -> enum3R e1 e2. +Proof. +refine ( +match e1 with +| KK1 u1 u2 => match e2 with + | KK1 u3 u4 => fun e => KK1R _ _ (mR_Unit _ _ (KK1_inj1 u1 u2 u3 u4 e)) _ _ (mR_Unit _ _ (KK1_inj2 u1 u2 u3 u4 e)) + | KK2 b1 b2 => fun e => KK1_KK2 _ _ _ _ _ e + end +| KK2 b1 b2 => match e2 with + | KK1 u1 u2 => fun e => KK2_KK1 _ _ _ _ _ e + | KK2 b3 b4 => fun e => KK2R _ _ (mR_Bool _ _ (KK2_inj1 _ _ _ _ e)) + _ _ (mR_Bool _ _ (KK2_inj2 _ _ _ _ e)) + end +end +). +Defined. + +Lemma KK1_curry : forall u1 u2, KK1 u1 u2 = (uncurry KK1) (u1,u2). +Proof. +reflexivity. +Defined. + +Definition Rm_enum3 (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2. +Proof. +elim. +- move=> u1 u2 uR1 u3 u4 uR2. + (* rewrite !KK1_curry. *) + (* apply ap. *) + (* apply ap. + pose F := uncurry KK1. *) + elim: (Rm_Unit _ _ uR1). + (* apply ap. *) + elim: (Rm_Unit _ _ uR2). + reflexivity. + (* by apply ap. *) +- move=> b1 b2 bR1 b3 b4 bR2. + elim: (Rm_Bool _ _ bR1). + elim: (Rm_Bool _ _ bR2). + by apply ap. +Defined. +Print Rm_enum3. +Print f_equal2. +(* Definition Rm_enum3' (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2. +Proof. +elim. +- move=> u1 u2 uR1 u3 u4 uR2. + apply (ap (KK1 u1) (Rm_Unit _ _ uR1)). + elim: (Rm_Unit _ _ uR1). + elim: (Rm_Unit _ _ uR2). + by apply ap. +- move=> b1 b2 bR1 b3 b4 bR2. + elim: (Rm_Bool _ _ bR1). + elim: (Rm_Bool _ _ bR2). + by apply ap. +Defined. *) + +Definition Rm_enum3' (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2. +Proof. +elim. +- move=> u1 u2 uR1 u3 u4 uR2. + by apply (eqnn (tcons Unit (tcons Unit tnil)) (fun u1' u2' => KK1 u1 u3 = KK1 u1' u2') u1 u2 (Rm_Unit u1 u2 uR1) u3 u4 (Rm_Unit u3 u4 uR2) ). +- move=> u1 u2 uR1 u3 u4 uR2. + by apply (eqnn (tcons Bool (tcons Bool tnil)) (fun u1' u2' => KK2 u1 u3 = KK2 u1' u2') u1 u2 (Rm_Bool u1 u2 uR1) u3 u4 (Rm_Bool u3 u4 uR2) ). +Defined. + +Definition Rm_enum3''' (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2. +Proof. + elim. + - move=> u1 u2 uR1 u3 u4 uR2. + (* have e := ap (fun u => KK1 u u3) (Rm_Unit _ _ uR1). *) + (* have e' := ap (fun u => KK1 u2 u) (Rm_Unit _ _ uR2). *) + (* exact: (e @ e'). *) + exact: (ap (fun u => KK1 u u3) (Rm_Unit _ _ uR1) @ ap (fun u => KK1 u2 u) (Rm_Unit _ _ uR2)). + - move=> u1 u2 uR1 u3 u4 uR2. + (* have e := ap (fun u => KK2 u u3) (Rm_Bool _ _ uR1). *) + (* have e' := ap (fun u => KK2 u2 u) (Rm_Bool _ _ uR2). *) + (* exact: (e @ e'). *) + exact: (ap (fun u => KK2 u u3) (Rm_Bool _ _ uR1) @ ap (fun u => KK2 u2 u) (Rm_Bool _ _ uR2)). +Defined. + +Definition Rm_enum3'''' (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2. +Proof. + elim. + - move=> u1 u2 uR1 u3 u4 uR2. + (* have e'' := ap (fun u => KK1 u1 u) (Rm_Unit _ _ uR2). *) + (* have e''' := ap (fun u => KK1 u u4) (Rm_Unit _ _ uR1). *) + (* exact: (e'' @ e'''). *) + exact: ( (ap (fun u => KK1 u1 u) (Rm_Unit _ _ uR2)) @ (ap (fun u => KK1 u u4) (Rm_Unit _ _ uR1))). + - move=> u1 u2 uR1 u3 u4 uR2. + (* have e := ap (fun u => KK2 u u3) (Rm_Bool _ _ uR1). *) + (* have e' := ap (fun u => KK2 u2 u) (Rm_Bool _ _ uR2). *) + (* exact: (e @ e'). *) + exact: ( (ap (fun u => KK2 u1 u) (Rm_Bool _ _ uR2)) @ (ap (fun u => KK2 u u4) (Rm_Bool _ _ uR1))). +Defined. + +Definition Rm_enum3'' (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2 := +fun eR => +match eR with +| KK1R u1 u2 uR1 u3 u4 uR2 => + (eqnn (tcons Unit (tcons Unit tnil)) + (fun u1' u2' => KK1 u1 u3 = KK1 u1' u2') + u1 u2 (Rm_Unit u1 u2 uR1) u3 u4 (Rm_Unit u3 u4 uR2) + eq_refl) +| KK2R u1 u2 uR1 u3 u4 uR2 => + (eqnn (tcons Bool (tcons Bool tnil)) + (fun u1' u2' => KK2 u1 u3 = KK2 u1' u2') + u1 u2 (Rm_Bool u1 u2 uR1) u3 u4 (Rm_Bool u3 u4 uR2) + eq_refl) +end. +Print f_equal. +Search f_equal f_equal2. + +Definition tr_id {A : Type} {B : A -> Type} {a : A} + (f : forall (x : A), a = x -> B x) + (x : A) (p : a = x) : f x p = transport B p (f a eq_refl). +Proof. + exact: (match p with eq_refl => eq_refl end). +Defined. + +Definition preserves_tr {I : Type} {A : I -> Type} {B : I -> Type} (f : forall (i : I), A i -> B i) + {i j : I} (p : i = j) (x : A i) : + f j (transport A p x) = transport B p (f i x). +Proof. + exact: (match p with eq_refl => eq_refl end). +Defined. + +Definition compute_preserves_tr {I : Type} {A : I -> Type} {B : I -> Type} + (f : forall (i : I), A i -> B i) + {i j : I} (p : i = j) (x : A i) : + preserves_tr _ p x = + (tr_ap id f p x)^ @ ap (fun q => transport B q (f i x)) (ap_idmap p). +Proof. + exact: (match p with eq_refl => eq_refl end). +Defined. + +Definition substitution_law_tr {X : Type} {A : Type} (B : A -> Type) (f : X -> A) + {x y : X} (p : x = y) {x' : B (f x)} : + transport B (ap f p) x' = transport (B o f) p x'. +Proof. + apply (tr_ap f (fun _ => idmap) p x'). +Defined. + +Definition tr_Id_left {A : Type} {a b c : A} (q : b = c) (p : b = a) : + transport (fun x => x = a) q p = q^ @ p. +Proof. + refine ((match q with eq_refl => _ end)). + by rewrite transport1 concat_1p. +Defined. + +Definition tr_Id_right {A : Type} {a b c : A} (q : b = c) (p : a = b) : + transport (fun x => a = x) q p = p @ q. +Proof. + refine ((match q with eq_refl => _ end)). + by rewrite transport1 concat_p1. +Defined. + +Definition KK1_proj1K : forall u1 u2 (p1 : u1 = u2) u3 u4 (p2 : u3 = u4), + (ap (KK1_proj1 u1) + (ap (fun u : Unit => KK1 u u3) p1 @ + ap (fun u : Unit => KK1 u2 u) p2)) = p1. +Proof. + refine (fun u1 u2 p1 => match p1 as p0 in _ = t + return + forall u3 u4 p2, (ap (KK1_proj1 u1) + (ap (fun u : Unit => KK1 u u3) p0 @ + ap (fun u : Unit => KK1 t u) p2)) = p0 + with eq_refl => _ end + + ). + refine (fun u3 u4 p2 => match p2 as p0 in _ = t + return + (ap (KK1_proj1 u1) + (ap (fun u : Unit => KK1 u u3) 1 @ + ap (fun u : Unit => KK1 u1 u) p0)) = 1 + with eq_refl => eq_refl end + ). +Defined. + +Definition KK1_proj2K : forall u1 u2 (p1 : u1 = u2) u3 u4 (p2 : u3 = u4), + (ap (KK1_proj2 u3) + (ap (fun u : Unit => KK1 u u3) p1 @ + ap (fun u : Unit => KK1 u2 u) p2)) = p2. +Proof. + refine (fun u1 u2 p1 => match p1 as p0 in _ = t + return + forall u3 u4 p2, (ap (KK1_proj2 u3) + (ap (fun u : Unit => KK1 u u3) p0 @ + ap (fun u : Unit => KK1 t u) p2)) = p2 + with eq_refl => _ end + + ). + refine (fun u3 u4 p2 => match p2 as p0 in _ = t + return + (ap (KK1_proj2 u3) + (ap (fun u : Unit => KK1 u u3) 1 @ + ap (fun u : Unit => KK1 u1 u) p0)) = p0 + with eq_refl => eq_refl end + ). +Defined. + +Definition KK2_proj1K : forall b1 b2 (p1 : b1 = b2), + forall b3 b4 (p2 : b3 = b4), + + (ap (KK2_proj1 b4) + (ap (fun u : Bool => KK2 u b3) p1 @ + ap (fun u : Bool => KK2 b2 u) p2)) = p1. +Proof. + refine ( + fun b1 b2 p1 => + match p1 as p0 in _ = t + return + forall b3 b4 p2, (ap (KK2_proj1 b4) + (ap (fun u : Bool => KK2 u b3) p0 @ + ap (fun u : Bool => KK2 t u) p2)) = p0 + with eq_refl => _ end + ). + refine ( + + fun b3 b4 p2 => + match p2 as p0 in _ = t + return + (ap (KK2_proj1 t) + (ap (fun u : Bool => KK2 u b3) 1 @ + ap (fun u : Bool => KK2 b1 u) p0)) = 1 + with eq_refl => eq_refl end + ). +Defined. + +Definition KK2_proj2K : forall b1 b2 (p1 : b1 = b2), + forall b3 b4 (p2 : b3 = b4), + (* (ap (KK2_proj2 b4) *) + KK2_inj2 b1 b3 b2 b4 ( + (ap (fun u : Bool => KK2 u b3) p1 @ + ap (fun u : Bool => KK2 b2 u) p2)) = p2. +Proof. + refine ( + fun b1 b2 p1 => + match p1 as p0 in _ = t + return + forall b3 b4 p2, + KK2_inj2 b1 b3 t b4 + ((ap (fun u : Bool => KK2 u b3) p0) @ (ap (fun u : Bool => KK2 t u) p2)) = p2 + with eq_refl => _ end + ). + refine ( + fun b3 b4 p2 => + match p2 as p0 in _ = t + return + KK2_inj2 b1 b3 b1 t + ((ap (fun u : Bool => KK2 u b3) 1 @ + ap (fun u : Bool => KK2 b1 u) p0)) = p0 + with eq_refl => eq_refl end + ). +Defined. + +Lemma mRRmK_enum3' (e1 e2 : enum3) (eR : enum3R e1 e2) : mR_enum3 _ _ (Rm_enum3''' _ _ eR) = eR. +Proof. + elim: eR=> /=. + - move=> u1 u2 uR1 u3 u4 uR2 /=. + by rewrite /KK1_inj1 KK1_proj1K /KK1_inj2 KK1_proj2K !mRRmK_Unit. + - move=> b1 b2 bR1 b3 b4 bR2 /=. + by rewrite /KK2_inj1 KK2_proj1K KK2_proj2K !mRRmKBool. +Defined. + +Inductive pp := +| Z +| S : pp -> pp. + +Inductive ppR : pp -> pp -> Type := +| ZR : ppR Z Z +| SR : forall pp1 pp2, ppR pp1 pp2 -> ppR (S pp1) (S pp2). + +Definition map_pp : pp -> pp := id. + +Fixpoint map_pp' (p : pp) : pp := + match p with + | Z => Z + | S p' => S (map_pp' p') + end. + +Definition S_proj (dflt : pp) (p1 : pp) : pp := +match p1 with +| Z => dflt +| S p1' => p1' +end. + +Definition S_inj (p1 p2 : pp) : (S p1) = S p2 -> p1 = p2. +by move=> /(ap (S_proj p1)). +Defined. + +Definition S_inj' (p1 p2 : pp) : map_pp (S p1) = S p2 -> map_pp p1 = p2. +by case. +Defined. + +Definition map_S_e (p1 p2 : pp) : p1 = p2 -> (S p1) = (S p2). +by apply (ap S). +Defined. + +Definition map_S_e' (p1 p2 : pp) : map_pp p1 = p2 -> map_pp (S p1) = (S p2). +by elim. +Defined. + +Definition inj_projK_pp (p1 p2 : pp) (e : p1 = p2): S_inj p1 p2 (map_S_e p1 p2 e) = e. +Proof. +by rewrite /S_inj/map_S_e -ap_compose ap_idmap. +Defined. + +Definition inj_projK_pp' (p1 p2 : pp) (e : p1 = p2): S_inj p1 p2 (ap S e) = e. +Proof. +by refine ( + match e as p0 in _ = t + return S_inj p1 t (ap S p0) = p0 + with eq_refl => eq_refl end + ). +Defined. + +Definition ex_falso_Z_pp (T : Type) (p1 : pp) : map_pp Z = S p1 -> T. +refine ( +fun e => match e in _ = t return + match t with + | Z => Unit + | S _ => T end + with eq_refl => tt end + +). +Defined. + +Definition ex_falso_pp_ZZ (T : Type) (p1 : pp) : map_pp (S p1) = Z -> T. +refine ( +fun e => match e in _ = t return + match t with + | Z => T + | S _ => Unit end + with eq_refl => tt end + +). +Defined. + +Definition mR_pp : forall p1 p2, (map_pp p1) = p2 -> ppR p1 p2. +elim=> [|p1' IHn]. +- case=> [|p2']. + + move=> e; exact: ZR. + + move=> /ex_falso_Z_pp contr; apply contr. +- case=> [|p2']. + + move=> /ex_falso_pp_ZZ contr; apply contr. + + move=> /S_inj e; exact: SR _ _ (IHn _ e). +Defined. + +Definition mR_pp' : forall p1 p2, (map_pp' p1) = p2 -> ppR p1 p2. +elim=> [|p1' IHn]. +- case=> [|p2']. + + move=> e; exact: ZR. + + move=> /ex_falso_Z_pp contr; apply contr. +- case=> [|p2']. + + move=> /ex_falso_pp_ZZ contr; apply contr. + + move=> /S_inj e; exact: SR _ _ (IHn _ e). +Defined. + +Print ppR_ind. +Definition Rm_pp : forall p1 p2, ppR p1 p2 -> map_pp p1 = p2. +move=> p1 p2 eR. +elim : eR => [| p1' p2' hR rec]. +- exact: idpath. +- by apply map_S_e. +Defined. + +Definition Rm_pp'' : forall p1 p2, ppR p1 p2 -> map_pp' p1 = p2. + move=> p1 p2 eR. + elim : eR => [| p1' p2' hR rec]. + - exact: idpath. + - by apply (ap S rec). +Defined. + +Definition Rm_pp' : forall p1 p2, ppR p1 p2 -> map_pp p1 = p2. +move=> p1 p2. +fix IH 1. +elim. +- exact: idpath. +- by move=> p1' p2' ppR' rec; apply: map_S_e. +Defined. + +Definition mRRmK_pp : forall p1 p2 (pR : ppR p1 p2), mR_pp _ _ (Rm_pp _ _ pR) = pR. +Proof. +move=> p1 p2; elim. +- reflexivity. +- move=> p1' p2' eR' rec. + move=> /=. apply ap. by rewrite inj_projK_pp rec. +Defined. + +(* with map <> id *) +Definition mRRmK_pp': forall p1 p2 (pR : ppR p1 p2), mR_pp' _ _ (Rm_pp'' _ _ pR) = pR. +Proof. + move=> p1 p2; elim. + - reflexivity. + - move=> p1' p2' eR' rec. + rewrite /=. + by rewrite inj_projK_pp' rec. +Defined. + +Module i. + Inductive issue (A B C : Type) := + | K1 : unit -> enum -> pp -> issue A B C + | K2 : A -> B -> C -> issue A B C + (* | K3 : A -> pp -> issue A *) + | K4 : issue A B C -> issue A B C -> issue A B C -> issue A B C. + +Elpi derive.map "issue". +Elpi derive.projK issue. +Print issue_map. +Print projK11. +Inductive issueR + (A A' : Type) (AR : A -> A' -> Type) + (B B' : Type) (BR : B -> B' -> Type) + (C C' : Type) (CR : C -> C' -> Type) + : issue A B C -> issue A' B' C' -> Type := +| K1R : + forall u1 u2 (uR : UnitR u1 u2), + forall e1 e2 (eR : enumR e1 e2), + forall p1 p2 (pR : ppR p1 p2), + issueR A A' AR B B' BR C C' CR (K1 A B C u1 e1 p1) (K1 A' B' C' u2 e2 p2) +| K2R : + forall a1 a2 (aR : AR a1 a2), + forall b1 b2 (bR : BR b1 b2), + forall c1 c2 (cR : CR c1 c2), + issueR A A' AR B B' BR C C' CR (K2 A B C a1 b1 c1) (K2 A' B' C' a2 b2 c2) +| K4R : + forall i1 i2 (iR1 : issueR A A' AR B B' BR C C' CR i1 i2), + forall i3 i4 (iR2 : issueR A A' AR B B' BR C C' CR i3 i4), + forall i5 i6 (iR3 : issueR A A' AR B B' BR C C' CR i5 i6), + issueR A A' AR B B' BR C C' CR (K4 A B C i1 i3 i5) (K4 A' B' C' i2 i4 i6). + +(* Definition issue_map *) +(* (A A' : Type) (AR : Param10.Rel A A') *) +(* (B B' : Type) (BR : Param10.Rel B B') *) +(* (C C' : Type) (CR : Param10.Rel C C') *) +(* : issue A B C -> issue A' B' C' := *) +(* let fix im (ia : issue A B C) {struct ia} : issue A' B' C' := *) +(* match ia with *) +(* | K1 _ _ _ u e p => K1 A' B' C' u e p *) +(* | K2 _ _ _ a b c => K2 A' B' C' (map AR a) (map BR b) (map CR c) *) +(* (* | K3 _ a pp => K3 A' (map AR a) pp *) *) +(* | K4 _ _ _ ia1 ia2 ia3 => K4 A' B' C' (im ia1) (im ia2) (im ia3) end in *) +(* fun ia => im ia. *) + +Fixpoint issue_map_fix + (A A' : Type) (AR : Param10.Rel A A') + (B B' : Type) (BR : Param10.Rel B B') + (C C' : Type) (CR : Param10.Rel C C') + (ia : issue A B C) : issue A' B' C' := + match ia with + | K1 _ _ _ u e p => K1 A' B' C' u e p + | K2 _ _ _ a b c => K2 A' B' C' (map AR a) (map BR b) (map CR c) + | K4 _ _ _ ia1 ia2 ia3 => K4 A' B' C' + (issue_map_fix A A' AR B B' BR C C' CR ia1) + (issue_map_fix A A' AR B B' BR C C' CR ia2) + (issue_map_fix A A' AR B B' BR C C' CR ia3) end. + +(* Definition issue_map_fix2 : *) +(* forall (A A' : Type) (AR : Param10.Rel A A') *) +(* (B B' : Type) (BR : Param10.Rel B B') *) +(* (C C' : Type) (CR : Param10.Rel C C') *) +(* (ia : issue A B C), issue A' B' C' := *) +(* let fix F A A' AR B B' BR C C' CR ia {struct ia} := *) +(* match ia with *) +(* | K1 _ _ _ u e p => K1 A' B' C' u e p *) +(* | K2 _ _ _ a b c => K2 A' B' C' (map AR a) (map BR b) (map CR c) *) +(* | K4 _ _ _ ia1 ia2 ia3 => K4 A' B' C' *) +(* (F A A' AR B B' BR C C' CR ia1) *) +(* (F A A' AR B B' BR C C' CR ia2) *) +(* (F A A' AR B B' BR C C' CR ia3) end in *) +(* fun A A' AR B B' BR C C' CR ia => F A A' AR B B' BR C C' CR ia. *) +(* Definition issue_mapE *) +(* (A A' : Type) (AR : Param10.Rel A A') *) +(* (B B' : Type) (BR : Param10.Rel B B') *) +(* (C C' : Type) (CR : Param10.Rel C C') *) +(* ia : *) +(* issue_map A A' AR *) +(* B B' BR *) +(* C C' CR *) +(* ia = ((fix im (ia0 : issue A B C) : issue A' B' C' := *) +(* match ia0 with *) +(* | K1 _ _ _ u e p => K1 A' B' C' u e p *) +(* | K2 _ _ _ a b c => K2 A' B' C' (map AR a) (map BR b) (map CR c) *) +(* | K4 _ _ _ ia7 ia8 ia9 => K4 A' B' C' (im ia7) (im ia8) (im ia9) *) +(* end) ia). *) +(* Proof. by []. Qed. *) + +Definition issue_k1_proj1 : forall (A B C : Type) (u : unit), issue A B C -> unit := +fun A B C u ia => + match ia with + | K1 _ _ _ u _ _ => u + | _ => u end. + +Definition issue_k1_proj2 : forall (A B C: Type) (e : enum), issue A B C -> enum := +fun A B C e ia => + match ia with + | K1 _ _ _ _ e _ => e + | _ => e end. + +Definition issue_k1_proj3 : forall (A B C: Type) (p : pp), issue A B C -> pp := +fun A B C p ia => + match ia with + | K1 _ _ _ _ _ p => p + | _ => p end. + +Definition issue_k2_proj1 : forall (A B C : Type) (a : A), issue A B C -> A := +fun A B C a ia => + match ia with + | K2 _ _ _ a _ _ => a + | _ => a end. + +Definition issue_k2_proj2 : forall (A B C : Type) (b : B), issue A B C -> B := +fun A B C b ia => + match ia with + | K2 _ _ _ _ b _ => b + | _ => b end. + +Definition issue_k2_proj3 : forall (A B C : Type) (c : C), issue A B C -> C := +fun A B C c ia => + match ia with + | K2 _ _ _ _ _ c => c + | _ => c end. + +Definition issue_k4_proj1 : forall (A B C : Type) (ia : issue A B C), issue A B C -> issue A B C := +fun A B C ia' ia => + match ia with + | K4 _ _ _ ia' _ _ => ia' + | _ => ia' end. + +Definition issue_k4_proj2 : forall (A B C : Type) (ia : issue A B C), issue A B C -> issue A B C := +fun A B C ia' ia => + match ia with + | K4 _ _ _ _ ia' _ => ia' + | _ => ia' end. + +Definition issue_k4_proj3 : forall (A B C : Type) (ia : issue A B C), issue A B C -> issue A B C := +fun A B C ia' ia => + match ia with + | K4 _ _ _ _ _ ia' => ia' + | _ => ia' end. + +Definition issue_k1_inj1 : forall (A B C : Type) (u1 u2 : unit) (e1 e2 : enum) (p1 p2 : pp), K1 A B C u1 e1 p1 = K1 A B C u2 e2 p2 -> u1 = u2. + move=> A B C u1 u2 e1 e2 p1 p2 E. + injection E. + Show Proof. + move=> P1 P2 P3; exact: P3. + Show Proof. + Defined. + (* fun A B C u1 u2 e1 e2 p1 p2 E => ap (issue_k1_proj1 A B C u1) E. *) + +Definition issue_k1_inj2 : forall (A B C : Type) (u1 u2 : unit) (e1 e2 : enum) (p1 p2 : pp), K1 A B C u1 e1 p1 = K1 A B C u2 e2 p2 -> e1 = e2 := + fun A B C u1 u2 e1 e2 p1 p2 E => ap (issue_k1_proj2 A B C e1) E. + +Definition issue_k1_inj3 : forall (A B C : Type) (u1 u2 : unit) (e1 e2 : enum) (p1 p2 : pp), K1 A B C u1 e1 p1 = K1 A B C u2 e2 p2 -> p1 = p2 := + fun A B C u1 u2 e1 e2 p1 p2 E => ap (issue_k1_proj3 A B C p1) E. + +Definition issue_k2_inj1 : forall (A B C : Type) (a1 a2 : A) (b1 b2 : B) (c1 c2 : C), K2 A B C a1 b1 c1= K2 A B C a2 b2 c2 -> a1 = a2 := + fun A B C a1 a2 b1 b2 c1 c2 E => ap (issue_k2_proj1 A B C a1) E. + +Definition issue_k2_inj2 : forall (A B C : Type) (a1 a2 : A) (b1 b2 : B) (c1 c2 : C), K2 A B C a1 b1 c1= K2 A B C a2 b2 c2 -> b1 = b2 := + fun A B C a1 a2 b1 b2 c1 c2 E => ap (issue_k2_proj2 A B C b1) E. + +Definition issue_k2_inj3 : forall (A B C : Type) (a1 a2 : A) (b1 b2 : B) (c1 c2 : C), K2 A B C a1 b1 c1= K2 A B C a2 b2 c2 -> c1 = c2 := + fun A B C a1 a2 b1 b2 c1 c2 E => ap (issue_k2_proj3 A B C c1) E. + +Definition issue_k4_inj1 : forall (A B C : Type) (ia1 ia2 : issue A B C) (ia3 ia4 : issue A B C) (ia5 ia6 : issue A B C), K4 A B C ia1 ia3 ia5 = K4 A B C ia2 ia4 ia6 -> ia1 = ia2 := + fun A B C ia1 ia2 ia3 ia4 ia5 ia6 E => ap (issue_k4_proj1 A B C ia1) E. + +Definition issue_k4_inj2 : forall (A B C : Type) (ia1 ia2 : issue A B C) (ia3 ia4 : issue A B C) (ia5 ia6 : issue A B C), K4 A B C ia1 ia3 ia5 = K4 A B C ia2 ia4 ia6 -> ia3 = ia4 := + fun A B C ia1 ia2 ia3 ia4 ia5 ia6 E => ap (issue_k4_proj2 A B C ia3) E. + +Definition issue_k4_inj3 : forall (A B C : Type) (ia1 ia2 : issue A B C) (ia3 ia4 : issue A B C) (ia5 ia6 : issue A B C), K4 A B C ia1 ia3 ia5 = K4 A B C ia2 ia4 ia6 -> ia5 = ia6 := + fun A B C ia1 ia2 ia3 ia4 ia5 ia6 E => ap (issue_k4_proj3 A B C ia5) E. + +Definition issue_ex_falso_k1_k2 : forall (A B C A' : Type) u1 e1 p1 a2 b2 c2, + K1 A B C u1 e1 p1 = K2 A B C a2 b2 c2 -> A' := + fun A B C A' u1 e1 p1 a2 b2 c2 e => + match e in _ = t return + match t with + | K2 _ _ _ _ _ _ => A' + | _ => Unit end + with eq_refl => tt end. + +Definition issue_ex_falso_k1_k4 : forall (A B C A' : Type) u1 e1 p1 ia2 ia4 ia6 , K1 A B C u1 e1 p1 = K4 A B C ia2 ia4 ia6 -> A' := + fun A B C A' u1 e1 p1 ia2 ia4 ia6 e => + match e in _ = t return + match t with + | K4 _ _ _ _ _ _ => A' + | _ => Unit end + with eq_refl => tt end. + +Definition issue_ex_falso_k2_k1 : forall (A B C A' : Type) a1 b1 c1 u2 e2 p2, K2 A B C a1 b1 c1 = K1 A B C u2 e2 p2 -> A' := + fun A B C A' a1 b1 c1 u1 e1 p1 e => + match e in _ = t return + match t with + | K1 _ _ _ _ _ _ => A' + | _ => Unit end + with eq_refl => tt end. + +Definition issue_ex_falso_k2_k4 : forall (A B C A' : Type) a1 b1 c1 ia2 ia4 ia6 , K2 A B C a1 b1 c1 = K4 A B C ia2 ia4 ia6 -> A' := + fun A B C A' a1 b1 c1 ia2 ia4 ia6 e => + match e in _ = t return + match t with + | K4 _ _ _ _ _ _ => A' + | _ => Unit end + with eq_refl => tt end. + +Definition issue_ex_falso_k4_k1 : forall (A B C A' : Type) ia1 ia3 ia5 u2 e2 p2 , K4 A B C ia1 ia3 ia5 = K1 A B C u2 e2 p2 -> A' := + fun A B C A' ia1 ia3 ia5 u1 e1 p1 e => + match e in _ = t return + match t with + | K1 _ _ _ _ _ _ => A' + | _ => Unit end + with eq_refl => tt end. + +Definition issue_ex_falso_k4_k2 : forall (A B C A' : Type) ia1 ia3 ia5 a2 b2 c2 , K4 A B C ia1 ia3 ia5 = K2 A B C a2 b2 c2 -> A' := + fun A B C A' ia1 ia3 ia5 a2 b2 c2 e => + match e in _ = t return + match t with + | K2 _ _ _ _ _ _ => A' + | _ => Unit end + with eq_refl => tt end. + +Fixpoint issue_mR + (A A' : Type) (AR : Param2a0.Rel A A') + (B B' : Type) (BR : Param2a0.Rel B B') + (C C' : Type) (CR : Param2a0.Rel C C') + + ia {struct ia} : forall ia', issue_map_fix A A' AR B B' BR C C' CR ia = ia' -> issueR A A' AR B B' BR C C' CR ia ia'. +Proof. + (* fix F 1. *) + case: ia => [u1 e1 p1 | a1 b1 c1 | ia1 ia3 ia5 ]; case=> [u2 e2 p2 | a2 b2 c2 | ia2 ia4 ia6] e. + (* Set Printing All. *) + (* rewrite /= in e. *) + + by apply (K1R _ _ _ _ _ _ _ _ _ + _ _ (mR_Unit _ _ (issue_k1_inj1 _ _ _ _ _ _ _ _ _ e)) + _ _ (mR_enum _ _ (issue_k1_inj2 _ _ _ _ _ _ _ _ _ e)) + _ _ (mR_pp _ _ (issue_k1_inj3 _ _ _ _ _ _ _ _ _ e))). + + by apply (issue_ex_falso_k1_k2 A' B' C' _ u1 e1 p1 a2 b2 c2). + + by apply (issue_ex_falso_k1_k4 A' B' C' _ u1 e1 p1 ia2 ia4 ia6). + + + by apply (issue_ex_falso_k2_k1 A' B' C' _ (map AR a1) (map BR b1) (map CR c1) u2 e2 p2). + + + (* simpl [issue_map]in e. *) + by apply (K2R _ _ _ _ _ _ _ _ _ + + _ _ (map_in_R AR _ _ (issue_k2_inj1 _ _ _ _ _ _ _ _ _ e)) + _ _ (map_in_R BR _ _ (issue_k2_inj2 _ _ _ _ _ _ _ _ _ e)) + _ _ (map_in_R CR _ _ (issue_k2_inj3 _ _ _ _ _ _ _ _ _ e))). + + by apply (issue_ex_falso_k2_k4 A' B' C' _(map AR a1) (map BR b1) (map CR c1) ia2 ia4 ia6). + + + by apply (issue_ex_falso_k4_k1 A' B' C' _ + (issue_map_fix A A' AR B B' BR C C' CR ia1) + (issue_map_fix A A' AR B B' BR C C' CR ia3) + (issue_map_fix A A' AR B B' BR C C' CR ia5) u2 e2 p2). + + by apply (issue_ex_falso_k4_k2 A' B' C' _ + (issue_map_fix A A' AR B B' BR C C' CR ia1) + (issue_map_fix A A' AR B B' BR C C' CR ia3) + (issue_map_fix A A' AR B B' BR C C' CR ia5) a2 b2 c2). + + by apply (K4R _ _ _ _ _ _ _ _ _ + _ _ (issue_mR _ _ AR _ _ BR _ _ CR ia1 ia2 (issue_k4_inj1 _ _ _ _ _ _ _ _ _ e)) + _ _ (issue_mR _ _ AR _ _ BR _ _ CR ia3 ia4 (issue_k4_inj2 _ _ _ _ _ _ _ _ _ e)) + _ _ (issue_mR _ _ AR _ _ BR _ _ CR ia5 ia6 (issue_k4_inj3 _ _ _ _ _ _ _ _ _ e))). +Defined. + +Fixpoint issue_Rm + (A A' : Type) (AR : Param2b0.Rel A A') + (B B' : Type) (BR : Param2b0.Rel B B') + (C C' : Type) (CR : Param2b0.Rel C C') + ia ia' (iaR : issueR A A' AR B B' BR C C' CR ia ia') {struct iaR}: issue_map_fix A A' AR B B' BR C C' CR ia = ia'. +Proof. + (* move: iaR. *) + (* Set Printing All. *) + (* rewrite /=. *) + (* move=> iaR; *) + (* elim: iaR. *) + (* move: ia. *) + (* refine (fun ia ia' => _). *) + elim: iaR=> [u1 u2 uR e1 e2 eR p1 p2 pR | a1 a2 aR b1 b2 bR c1 c2 cR | ia1 ia2 iaR1 iaRm1 ia3 ia4 iaR2 iaRm2 ia5 ia6 iaR3 iaRm3 ]. + + + rewrite /=. + (* have E' := (ap (fun x => K1 A' B' C' x e1 p1) (Rm_Unit u1 u2 uR)). *) + (* have E'' := (ap (fun x => K1 A' B' C' u2 x p1) (Rm_enum e1 e2 eR)). *) + (* have E''' := (ap (fun x => K1 A' B' C' u2 e2 x) (Rm_pp p1 p2 pR)). *) + (* exact: (E' @ E'' @ E'''). *) + exact: ((ap (fun x => K1 A' B' C' x e1 p1) (Rm_Unit u1 u2 uR))@ + (ap (fun x => K1 A' B' C' u2 x p1) (Rm_enum e1 e2 eR))@ + (ap (fun x => K1 A' B' C' u2 e2 x) (Rm_pp p1 p2 pR))). + + + (* rewrite /=. *) + (* have E' := (ap (fun x => K2 A' B' C' x (map BR b1) (map CR c1)) (R_in_map AR a1 a2 aR)). *) + (* have E'' := (ap (fun x => K2 A' B' C' a2 x (map CR c1)) (R_in_map BR b1 b2 bR)). *) + (* have E''' := (ap (fun x => K2 A' B' C' a2 b2 x) (R_in_map CR c1 c2 cR)). *) + (* exact: (E' @ E'' @ E'''). *) + exact ((ap (fun x => K2 A' B' C' x (map BR b1) (map CR c1)) (R_in_map AR a1 a2 aR)) @ + (ap (fun x => K2 A' B' C' a2 x (map CR c1)) (R_in_map BR b1 b2 bR)) @ + (ap (fun x => K2 A' B' C' a2 b2 x) (R_in_map CR c1 c2 cR))). + + (* rewrite /=. *) + (* have /= E' := (ap (fun x => K4 A' B' C' x (issue_map A A' AR B B' BR C C' CR ia3) (issue_map A A' AR B B' BR C C' CR ia5)) (F _ _ iaR1)). *) + (* have /= E'' := (ap (fun x => K4 A' B' C' ia2 x (issue_map A A' AR B B' BR C C' CR ia5)) (F _ _ iaR2)). *) + (* have /= E''' := (ap (fun x => K4 A' B' C' ia2 ia4 x) (F _ _ iaR3)). *) + + exact ((ap (fun x => K4 A' B' C' x (issue_map_fix A A' AR B B' BR C C' CR ia3) (issue_map_fix A A' AR B B' BR C C' CR ia5)) (issue_Rm A A' AR B B' BR C C' CR _ _ iaR1)) @ + (ap (fun x => K4 A' B' C' ia2 x (issue_map_fix A A' AR B B' BR C C' CR ia5)) (issue_Rm A A' AR B B' BR C C' CR _ _ iaR2)) @ + (ap (fun x => K4 A' B' C' ia2 ia4 x) (issue_Rm A A' AR B B' BR C C' CR _ _ iaR3))). + Defined. + +(* Lemma HH A' B' C' u1 u2 e1 e2 p1 p2 E E' : *) +(* (issue_k1_inj1 A' B' C' u1 u2 e1 e2 p1 p2 *) +(* ((ap (fun x : Unit => K1 A' B' C' x e1 p1) E @ *) +(* E'))) = E. *) +(* Proof. *) +(* move: u1 u2 E E'. *) +(* refine (fun u1 u2 E => match E as p0 in _ = t return *) +(* forall E', issue_k1_inj1 A' B' C' u1 t e1 e2 p1 p2 (ap (fun x : Unit => K1 A' B' C' x e1 p1) p0 @ E') = p0 *) +(* with eq_refl => _ end *) +(* ). *) +(* refine( fun E' => match E' as p0 in _ = t return *) +(* issue_k1_inj1 A' B' C' u1 u1 e1 e1 p1 p1 (ap (fun x : Unit => K1 A' B' C' x e1 p1) 1 @ p0) = 1 *) +(* with eq_refl => _ end *) +(* ). *) +(* rewrite /issue_k1_inj1. *) +(* (* rewrite /issue_k1_proj1. *) *) +(* rewrite ap_pp. *) +(* (* rewrite -ap_compose /= ap_idmap. *) *) +(* (* (* move: E; elim: u1. elim: u2. *) *) *) + +Definition issue_k1_inj1K : forall A' B' C' u1 u2 (p1 : u1 = u2) e1 e2 (p2 : e1 = e2) pp1 pp2 (p3 : pp1 = pp2), + issue_k1_inj1 A' B' C' u1 u2 e1 e2 pp1 pp2 + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p1 @ + ap (fun x : enum => K1 A' B' C' u2 x pp1) p2) @ + ap (fun x : pp => K1 A' B' C' u2 e2 x) p3) = p1 . +Proof. + move=> A' B' C'. + refine (fun u1 u2 p1 => match p1 as p0 in _ = t return + forall (e1 e2 : enum) (p2 : e1 = e2) (pp1 pp2 : pp) (p3 : pp1 = pp2), + issue_k1_inj1 A' B' C' u1 t e1 e2 pp1 pp2 + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p0 @ ap (fun x : enum => K1 A' B' C' t x pp1) p2) @ + ap (fun x : pp => K1 A' B' C' t e2 x) p3) = p0 + with eq_refl => _ end + ). + refine (fun e1 e2 p2 => match p2 as p0 in _ = t return + forall (pp1 pp2 : pp) (p3 : pp1 = pp2), + issue_k1_inj1 A' B' C' u1 u1 e1 t pp1 pp2 + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 + @ ap (fun x : enum => K1 A' B' C' u1 x pp1) p0) @ + ap (fun x : pp => K1 A' B' C' u1 t x) p3) = 1 + with eq_refl => _ end + ). + refine (fun pp1 pp2 p3 => match p3 as p0 in _ = t return + issue_k1_inj1 A' B' C' u1 u1 e1 e1 pp1 t + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 + @ ap (fun x : enum => K1 A' B' C' u1 x pp1) 1) @ + ap (fun x : pp => K1 A' B' C' u1 e1 x) p0) = 1 + with eq_refl => eq_refl end + ). +Defined. + +Definition issue_k1_inj2K : forall A' B' C' u1 u2 (p1 : u1 = u2) e1 e2 (p2 : e1 = e2) pp1 pp2 (p3 : pp1 = pp2), + (issue_k1_inj2 A' B' C' u1 u2 e1 e2 pp1 pp2 + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p1 @ + ap (fun x : enum => K1 A' B' C' u2 x pp1) p2) @ + ap (fun x : pp => K1 A' B' C' u2 e2 x) p3)) = p2. +Proof. +move=> A' B' C'. +refine (fun u1 u2 p1 => match p1 as p0 in _ = t + return + forall (e1 e2 : enum) (p2 : e1 = e2) + (pp1 pp2 : pp) (p3 : pp1 = pp2), + issue_k1_inj2 A' B' C' u1 t e1 e2 pp1 pp2 + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p0 @ ap (fun x : enum => K1 A' B' C' t x pp1) p2) @ + ap (fun x : pp => K1 A' B' C' t e2 x) p3) = p2 + with eq_refl => _ end + ). +refine (fun e1 e2 p2 => match p2 as p0 in _ = t + return + forall (pp1 pp2 : pp) (p3 : pp1 = pp2), + issue_k1_inj2 A' B' C' u1 u1 e1 t pp1 pp2 + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 @ ap (fun x : enum => K1 A' B' C' u1 x pp1) p0) @ + ap (fun x : pp => K1 A' B' C' u1 t x) p3) = p0 + with eq_refl => _ end + ). +refine (fun pp1 pp2 p3 => match p3 as p0 in _ = t + return + issue_k1_inj2 A' B' C' u1 u1 e1 e1 pp1 t + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 @ ap (fun x : enum => K1 A' B' C' u1 x pp1) 1) @ + ap (fun x : pp => K1 A' B' C' u1 e1 x) p0) = 1 + with eq_refl => eq_refl end + ). +Defined. + +Definition issue_k1_inj3K : forall A' B' C' u1 u2 (p1 : u1 = u2) e1 e2 (p2 : e1 = e2) pp1 pp2 (p3 : pp1 = pp2), + (issue_k1_inj3 A' B' C' u1 u2 e1 e2 pp1 pp2 + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p1 @ + ap (fun x : enum => K1 A' B' C' u2 x pp1) p2) @ + ap (fun x : pp => K1 A' B' C' u2 e2 x) p3)) = p3. +Proof. + move=> A' B' C'. + refine ( + fun u1 u2 p1 => match p1 as p0 in _ = t return + forall e1 e2 p2 pp1 pp2 p3, + (issue_k1_inj3 A' B' C' u1 t e1 e2 pp1 pp2 + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p0 @ + ap (fun x : enum => K1 A' B' C' t x pp1) p2) @ + ap (fun x : pp => K1 A' B' C' t e2 x) p3)) = p3 + with eq_refl => _ end ). + refine ( + fun e1 e2 p2 => match p2 as p0 in _ = t return + forall pp1 pp2 p3, + (issue_k1_inj3 A' B' C' u1 u1 e1 t pp1 pp2 + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 @ + ap (fun x : enum => K1 A' B' C' u1 x pp1) p0) @ + ap (fun x : pp => K1 A' B' C' u1 t x) p3)) = p3 + with eq_refl => _ end ). + refine ( + fun pp1 pp2 p3 => match p3 as p0 in _ = t return + (issue_k1_inj3 A' B' C' u1 u1 e1 e1 pp1 t + ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 @ + ap (fun x : enum => K1 A' B' C' u1 x pp1) 1) @ + ap (fun x : pp => K1 A' B' C' u1 e1 x) p0)) = p0 + with eq_refl => eq_refl end ). + Defined. + +Definition issue_k2_inj1K : + forall A' B' C' + a1 a2 (p1 : a1 = a2) b1 b2 (p2 : b1 = b2) c1 c2 (p3 : c1 = c2), + (issue_k2_inj1 A' B' C' a1 a2 b1 b2 c1 c2 + ((ap (fun x : A' => K2 A' B' C' x b1 c1) p1 @ + ap (fun x : B' => K2 A' B' C' a2 x c1) p2) @ + ap (fun x : C' => K2 A' B' C' a2 b2 x) p3)) = p1 . +Proof. +move=> A' B' C'. +refine (fun a1 a2 p1 => match p1 as p0 in _ = t return +forall (b1 b2 : B') (p2 : b1 = b2) (c1 c2 : C') (p3 : c1 = c2), + issue_k2_inj1 A' B' C' a1 t b1 b2 c1 c2 + ((ap (fun x : A' => K2 A' B' C' x b1 c1) p0 @ ap (fun x : B' => K2 A' B' C' t x c1) p2) @ + ap (fun x : C' => K2 A' B' C' t b2 x) p3) = p0 + with eq_refl => _ end). +refine (fun b1 b2 p2 => match p2 as p0 in _ = t return +forall (c1 c2 : C') (p3 : c1 = c2), + issue_k2_inj1 A' B' C' a1 a1 b1 t c1 c2 + ((ap (fun x : A' => K2 A' B' C' x b1 c1) 1 @ ap (fun x : B' => K2 A' B' C' a1 x c1) p0) @ + ap (fun x : C' => K2 A' B' C' a1 t x) p3) = 1 + with eq_refl => _ end). +refine (fun c1 c2 p3 => match p3 as p0 in _ = t return + issue_k2_inj1 A' B' C' a1 a1 b1 b1 c1 t + ((ap (fun x : A' => K2 A' B' C' x b1 c1) 1 @ ap (fun x : B' => K2 A' B' C' a1 x c1) 1) @ + ap (fun x : C' => K2 A' B' C' a1 b1 x) p0) = 1 + with eq_refl => eq_refl end). +Defined. + + +Definition issue_k2_inj2K : + forall A' B' C' + a1 a2 (p1 : a1 = a2) b1 b2 (p2 : b1 = b2) c1 c2 (p3 : c1 = c2), + (issue_k2_inj2 A' B' C' (a1) a2 (b1) b2 (c1) c2 + ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) p1 @ + ap (fun x : B' => K2 A' B' C' a2 x (c1)) p2) @ + ap (fun x : C' => K2 A' B' C' a2 b2 x) p3)) = p2. + move=> A' B' C'. + refine ( + fun a1 a2 (p1 : a1 = a2)=> match p1 as p0 in _ = t return + forall b1 b2 (p2 : b1 = b2) c1 c2 (p3 : c1 = c2), +(issue_k2_inj2 A' B' C' (a1) t (b1) b2 (c1) c2 + ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) p0 @ + ap (fun x : B' => K2 A' B' C' t x (c1)) p2) @ + ap (fun x : C' => K2 A' B' C' t b2 x) p3)) = p2 + with eq_refl => _ end + ). + refine ( + fun b1 b2 (p2 : b1 = b2)=> match p2 as p0 in _ = t return + forall c1 c2 (p3 : c1 = c2), +(issue_k2_inj2 A' B' C' (a1) (a1) (b1) t (c1) c2 + ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) 1 @ + ap (fun x : B' => K2 A' B' C' (a1) x (c1)) p0) @ + ap (fun x : C' => K2 A' B' C' (a1) t x) p3)) = p0 + with eq_refl => _ end + ). + refine ( + fun c1 c2 (p3 : c1 = c2)=> match p3 as p0 in _ = t return +(issue_k2_inj2 A' B' C' (a1) (a1) (b1) (b1) (c1) t + ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) 1 @ + ap (fun x : B' => K2 A' B' C' (a1) x (c1)) 1) @ + ap (fun x : C' => K2 A' B' C' (a1) (b1) x) p0)) = 1 + with eq_refl => eq_refl end + ). +Defined. + +Definition issue_k2_inj3K : + forall A' B' C' + a1 a2 (p1 : a1 = a2) b1 b2 (p2 : b1 = b2) c1 c2 (p3 : c1 = c2), + (issue_k2_inj3 A' B' C' (a1) a2 (b1) b2 (c1) c2 + ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) p1 @ + ap (fun x : B' => K2 A' B' C' a2 x (c1)) p2) @ + ap (fun x : C' => K2 A' B' C' a2 b2 x) p3)) = p3. + move=> A' B' C'. + refine ( + fun a1 a2 (p1 : a1 = a2)=> match p1 as p0 in _ = t return + forall b1 b2 (p2 : b1 = b2) c1 c2 (p3 : c1 = c2), +(issue_k2_inj3 A' B' C' (a1) t (b1) b2 (c1) c2 + ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) p0 @ + ap (fun x : B' => K2 A' B' C' t x (c1)) p2) @ + ap (fun x : C' => K2 A' B' C' t b2 x) p3)) = p3 + with eq_refl => _ end + ). + refine ( + fun b1 b2 (p2 : b1 = b2)=> match p2 as p0 in _ = t return + forall c1 c2 (p3 : c1 = c2), +(issue_k2_inj3 A' B' C' (a1) (a1) (b1) t (c1) c2 + ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) 1 @ + ap (fun x : B' => K2 A' B' C' (a1) x (c1)) p0) @ + ap (fun x : C' => K2 A' B' C' (a1) t x) p3)) = p3 + with eq_refl => _ end + ). + refine ( + fun c1 c2 (p3 : c1 = c2)=> match p3 as p0 in _ = t return +(issue_k2_inj3 A' B' C' (a1) (a1) (b1) (b1) (c1) t + ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) 1 @ + ap (fun x : B' => K2 A' B' C' (a1) x (c1)) 1) @ + ap (fun x : C' => K2 A' B' C' (a1) (b1) x) p0)) = p0 + with eq_refl => eq_refl end + ). + Defined. + +Definition issue_k4_inj1K : + forall A' B' C', + forall ia1 ia2 (p1 : ia1 = ia2) ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), + (issue_k4_inj1 A' B' C' ( ia1) ia2 ( ia3) ia4 ( ia5) ia6 + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + p1 @ + ap (fun x : issue A' B' C' => K4 A' B' C' ia2 x (ia5)) + p2) @ + ap (fun x : issue A' B' C' => K4 A' B' C' ia2 ia4 x) p3)) = p1. +Proof. + move=> A' B' C'. + refine (fun ia1 ia2 p1 => match p1 as p0 in _ = t return + forall ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), + (issue_k4_inj1 A' B' C' ( ia1) t ( ia3) ia4 ( ia5) ia6 + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + p0 @ + ap (fun x : issue A' B' C' => K4 A' B' C' t x (ia5)) + p2) @ + ap (fun x : issue A' B' C' => K4 A' B' C' t ia4 x) p3)) = p0 + with eq_refl => _ end + ). + refine (fun ia3 ia4 p2 => match p2 as p0 in _ = t return + forall ia5 ia6 (p3 : ia5 = ia6), + (issue_k4_inj1 A' B' C' ( ia1) ( ia1) ( ia3) t ( ia5) ia6 + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + 1 @ + ap (fun x : issue A' B' C' => K4 A' B' C' ( ia1) x (ia5)) + p0) @ + ap (fun x : issue A' B' C' => K4 A' B' C' ( ia1) t x) p3)) = 1 + with eq_refl => _ end + ). + refine (fun ia5 ia6 p3 => match p3 as p0 in _ = t return + (issue_k4_inj1 A' B' C' ( ia1) ( ia1) ( ia3) ( ia3) ( ia5) t + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + 1 @ + ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) x (ia5)) + 1) @ + ap (fun x : issue A' B' C' => K4 A' B' C' ( ia1) ( ia3) x) p0)) = 1 + with eq_refl => eq_refl end + ). +Defined. + +Definition issue_k4_inj2K : forall A' B' C', + forall ia1 ia2 (p1 : ia1 = ia2) ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), + (issue_k4_inj2 A' B' C' (ia1) ia2 (ia3) ia4 (ia5) ia6 + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + p1 @ + ap (fun x : issue A' B' C' => K4 A' B' C' ia2 x (ia5)) + p2) @ + ap (fun x : issue A' B' C' => K4 A' B' C' ia2 ia4 x) p3)) = p2. +Proof. + move=> A' B' C'. + refine (fun ia1 ia2 p1 => match p1 as p0 in _ = t return + forall ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), + (issue_k4_inj2 A' B' C' (ia1) t (ia3) ia4 (ia5) ia6 + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + p0 @ + ap (fun x : issue A' B' C' => K4 A' B' C' t x (ia5)) + p2) @ + ap (fun x : issue A' B' C' => K4 A' B' C' t ia4 x) p3)) = p2 + with eq_refl => _ end + ). + refine (fun ia3 ia4 p2 => match p2 as p0 in _ = t return + forall ia5 ia6 (p3 : ia5 = ia6), + (issue_k4_inj2 A' B' C' (ia1) (ia1) (ia3) t (ia5) ia6 + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + 1 @ + ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) x (ia5)) + p0) @ + ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) t x) p3)) = p0 + with eq_refl => _ end + ). + refine (fun ia5 ia6 p3 => match p3 as p0 in _ = t return + (issue_k4_inj2 A' B' C' (ia1) (ia1) (ia3) (ia3) (ia5) t + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + 1 @ + ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) x (ia5)) + 1) @ + ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) (ia3) x) p0)) = 1 + with eq_refl => eq_refl end + ). +Defined. + +Definition issue_k4_inj3K : forall A' B' C', + forall ia1 ia2 (p1 : ia1 = ia2) ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), + (issue_k4_inj3 A' B' C' (ia1) ia2 (ia3) ia4 (ia5) ia6 + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + p1 @ + ap (fun x : issue A' B' C' => K4 A' B' C' ia2 x (ia5)) + p2) @ + ap (fun x : issue A' B' C' => K4 A' B' C' ia2 ia4 x) p3)) = p3. +Proof. + move=> A' B' C'. + refine (fun ia1 ia2 p1 => match p1 as p0 in _ = t return + forall ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), + (issue_k4_inj3 A' B' C' (ia1) t (ia3) ia4 (ia5) ia6 + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + p0 @ + ap (fun x : issue A' B' C' => K4 A' B' C' t x (ia5)) + p2) @ + ap (fun x : issue A' B' C' => K4 A' B' C' t ia4 x) p3)) = p3 + with eq_refl => _ end + ). + refine (fun ia3 ia4 p2 => match p2 as p0 in _ = t return + forall ia5 ia6 (p3 : ia5 = ia6), + (issue_k4_inj3 A' B' C' (ia1) (ia1) (ia3) t (ia5) ia6 + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + 1 @ + ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) x (ia5)) + p0) @ + ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) t x) p3)) = p3 + with eq_refl => _ end + ). + refine (fun ia5 ia6 p3 => match p3 as p0 in _ = t return + (issue_k4_inj3 A' B' C' (ia1) (ia1) (ia3) (ia3) (ia5) t + ((ap + (fun x : issue A' B' C' => + K4 A' B' C' x (ia3) (ia5)) + 1 @ + ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) x (ia5)) + 1) @ + ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) (ia3) x) p0)) = p0 + with eq_refl => eq_refl end + ). + Defined. + +Definition mRRmKIssue + (A A' : Type) (AR : Param40.Rel A A') + (B B' : Type) (BR : Param40.Rel B B') + (C C' : Type) (CR : Param40.Rel C C') + : forall ia ia' (iaR : issueR A A' AR B B' BR C C' CR ia ia'), + issue_mR A A' AR B B' BR C C' CR _ _ (issue_Rm A A' AR B B' BR C C' CR _ _ iaR) = iaR. +Proof. + move=> ia ia'. + elim=> [u1 u2 uR e1 e2 eR p1 p2 pR /= | a1 a2 aR b1 b2 bR c1 c2 cR /= | ia1 ia2 iaR1 IH1 ia3 ia4 iaR2 IH2 ia5 ia6 iaR3 IH3 /=]. + + rewrite issue_k1_inj1K issue_k1_inj2K issue_k1_inj3K. + by rewrite mRRmK_Unit mRRmKEnum mRRmK_pp. + + rewrite issue_k2_inj1K issue_k2_inj2K issue_k2_inj3K. + by rewrite !R_in_mapK. + + rewrite issue_k4_inj1K issue_k4_inj2K issue_k4_inj3K. + by rewrite IH1 IH2 IH3. + Qed. +Inductive enum3R : enum3 -> enum3 -> Type := +| KK1R : forall (u1 u2 : unit), UnitR u1 u2 + -> forall (u3 u4 : unit), UnitR u3 u4 + -> enum3R (KK1 u1 u3) (KK1 u2 u4) +| KK2R : forall (b1 b2 : bool), BoolR b1 b2 + -> forall (b3 b4 : bool), BoolR b3 b4 + -> enum3R (KK2 b1 b3) (KK2 b2 b4). diff --git a/generic/injection_lemmas.elpi b/generic/injection_lemmas.elpi new file mode 100644 index 00000000..017772a1 --- /dev/null +++ b/generic/injection_lemmas.elpi @@ -0,0 +1,184 @@ +namespace derive.injections { + +/* for all projectors of type forall Args T, ret +generate + +forall Args1-> Args2-> (e : Kj args->1 = Kj args->2) argj + +Take an inductive Ind, +take its constructors global references, +for each global reference GRK, +Compute the number of arguments J for each GRK, +for each ArgNumber in 1 to J+1, +get the Projector GRK ArgNumber, +Get the type ProjType, forall ArgTys Args Ind, ret +Return the processed Types */ + + +% Returns the list of projectors of a constructor. +pred get-projectors i:constructor, i:int, i:int, o:list term. +get-projectors _ Max Max [] :- !. +get-projectors GRK J Max [P|PJs] :- + I is J + 1, + projK-db GRK I P, + get-projectors GRK I Max PJs. + +% for a list of constructors returns a list with all the projectors of that construct +pred for-K-get-projectors i:int, i:list constructor, i:list term, o: list int, o:list (list term). +for-K-get-projectors _ [] [] [] []:- !. +for-K-get-projectors TyParamNo [Kn|KNs] [KTy|KTys] [ArgsNo|ArgsNos] [R|RS]:- + coq.count-prods KTy ArgsParamNo, + ArgsNo is ArgsParamNo - TyParamNo, + get-projectors Kn 0 ArgsNo R, + for-K-get-projectors TyParamNo KNs KTys ArgsNos RS. + +func names12 name -> name, name. +names12 N N1 N2 :- !, + coq.name-suffix N 1 N1, coq.name-suffix N 2 N2. + +% given TyParam ArgNo and T, +% duplicate-argument skips TyParam lambdas, +% then for the first ArgNo lambda adds another lambda expecting an argument of the same Type, +% after all lambdas are processed returns the body unchanged +% Returns a list with the original variables, and a list with the added ones +pred duplicate-arguments i:int, i:int, i:term, o:term. +duplicate-arguments 0 0 T T :- !. +duplicate-arguments 0 O (prod N TyA T) (prod Arg1 TyA a1\ (prod Arg2 TyA a2\ (S a1 a2))) :- + O > 0, + P is O - 1, + names12 N Arg1 Arg2, + (pi a1 a2\ duplicate-arguments 0 P (T a1) (S a1 a2)). +duplicate-arguments N O (prod TyName TyArg T) (prod TyName TyArg S) :- !, + N > 0, + M is N - 1, + pi a1\ duplicate-arguments M O (T a1) (S a1). + + +% TyParam, ArgNo, F, Type of the equality, Left HS, Right HS +% F is of type forall (Typarams : Type) ((Arg1 : A1) (Arg2 : A2) ...), Ret +% Ret is discarded and replaced by Left = Right +pred craft-eq i:int, i:int, i:int, i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, o:term. +craft-eq 0 0 _ _ _ EqTy Left Right ConclEqTy ConclL ConclR R:- !, + coq.mk-app {{lib:@elpi.eq}} [EqTy, Left, Right] AETy, + coq.mk-app {{lib:@elpi.eq}} [ConclEqTy, ConclL, ConclR] C, + R = {{ forall (e : lp:AETy), lp:C }}. + +craft-eq 0 ArgNo J Max (prod N1 T x\ prod N2 T y\ (Bo x y)) EqTy Left Right ConclEq ConclL ConclR (prod N1 T x\ prod N2 T y\ (S x y)) :- !, + M is ArgNo - 1, + J? is Max - ArgNo + 1, + @pi-decl N1 T x\ + @pi-decl N2 T y\ + sigma NewLeft NewRight NewConclEq NewConclL NewConclR\ + (if (J? = J) + (NewConclEq = T, + NewConclL = x, + NewConclR = y) + (NewConclEq = ConclEq, + NewConclL = ConclL, + NewConclR = ConclR)), + coq.mk-app Left [x] NewLeft, + coq.mk-app Right [y] NewRight, + craft-eq 0 M J Max (Bo x y) EqTy NewLeft NewRight NewConclEq NewConclL NewConclR (S x y). + +craft-eq TyParam ArgNo J Max (prod N T Bo) EqTy Left Right CE CL CR (prod N T x\ S x) :- !, + M is TyParam - 1, + @pi-decl N T x\ + sigma NewEqTy NewLeft NewRight\ + coq.mk-app EqTy [x] NewEqTy, + coq.mk-app Left [x] NewLeft, + coq.mk-app Right [x] NewRight, + craft-eq M ArgNo J Max (Bo x) NewEqTy NewLeft NewRight CE CL CR (S x). + +pred build-type-K-injector i:int, i:int, i:inductive, i:constructor, i:int, i:term, i:list term, o:list term. +build-type-K-injector _ _ _ _ _ _ [] [] :- !. +build-type-K-injector TyParamNo J GR Kn ArgNo KTy [PJ|PJs] [Eq|RS] :- std.do! [ + Jn is J + 1, + duplicate-arguments TyParamNo ArgNo PJ S, + std.spy (craft-eq TyParamNo ArgNo J ArgNo S (global (indt GR)) (global (indc Kn)) (global (indc Kn)) {{tt}} {{tt}} {{tt}} Eq), + coq.typecheck Eq _ ok, + build-type-K-injector TyParamNo Jn GR Kn ArgNo KTy PJs RS]. + +pred build-types-injectors i:int, i: inductive, i:list constructor, i: list int, i:list (term), i:list (list term), o:list (list term). +build-types-injectors _ _ [] [] [] [] [] :- !. +build-types-injectors TyParamNo GR [Kn|KNs] [ArgNo|ArgsNos] [KTy|KTys] [PJs|PJss] [R|RS] :- + build-type-K-injector TyParamNo 1 GR Kn ArgNo KTy PJs R, + build-types-injectors TyParamNo GR KNs ArgsNos KTys PJss RS. + % build-types-injectors Kn PJs R, + +pred name-injector i:string, i:int, i:int, i:inductive, i:constructor, i:list term, o:list prop. +name-injector _ _ _ _ _ [] []. +name-injector FName I J GR Kn [InjTy|InjTyss] [Clause|Clauses] :- + Jn is J + 1, + NameIJ is {std.any->string FName} ^ {std.any->string I} ^ {std.any->string J}, + coq.env.add-const NameIJ InjTy _ _ C, + % Clause = (injections-db Kn J (global (const C)) :- !), + Clause = (injections-db Kn J (global (const C))), + name-injector FName I Jn GR Kn InjTyss Clauses. + +pred name-injectors i:string, i:int, i:inductive, i:list constructor, i:list (list term), o:list (list prop). +name-injectors _ _ _ [] [] []. +name-injectors FName I GR [Kn | KNs] [InjTys | InjTyss] [Clauses | Clausess] :- + In is I + 1, + name-injector FName I 1 GR Kn InjTys Clauses, + name-injectors FName In GR KNs InjTyss Clausess. + + +pred implement-K-injector-J i:int, i:int, i:int, i:int, i:term, o:term. + % implement-K-injector-J _ _ _ _ T T. +implement-K-injector-J 0 J 0 TyParam (prod E Ty _) R :- !, + I is J - 1, + R = {{ fun e:(lp:Ty) => lp:(PL e) }}, + @pi-decl E Ty e\ + sigma GR TyArgs GRK KArgs A B\ + ltac.injection? Ty GR TyArgs GRK KArgs A B, + ltac.injection.arg-i I J {{lib:@elpi.derive.eq_f}} GR TyArgs TyParam GRK KArgs A B e [(PL e)]. + +implement-K-injector-J 0 J ArgNo TyParam (prod ArgN1 ArgTy a\ (prod ArgN2 ArgTy b\ (Bo a b))) (fun ArgN1 ArgTy a\ fun ArgN2 ArgTy b\ (R a b) ) :- !, + ArgNon is ArgNo - 1, + @pi-decl ArgN1 ArgTy a\ + @pi-decl ArgN2 ArgTy b\ + implement-K-injector-J 0 J ArgNon TyParam (Bo a b) (R a b). + +implement-K-injector-J ParamNo J ArgNo TyParam (prod TyArg T t\ (Bo t)) (fun TyArg T t\ (R t) ) :- !, + ParamNon is ParamNo - 1, + @pi-decl TyArg T t\ + implement-K-injector-J ParamNon J ArgNo TyParam (Bo t) (R t). + +pred implement-K-injectors i:int, i:int, i:int, i:list term, o:list term. +implement-K-injectors _ _ _ [] []. +implement-K-injectors TyParam J ArgNo [InjTy | InjTys] [R | RS] :- + Jn is J + 1, + std.spy (implement-K-injector-J TyParam J ArgNo TyParam InjTy R), + coq.typecheck R InjTy ok, + implement-K-injectors TyParam Jn ArgNo InjTys RS. + +pred implement-injectors i:int, i:list int, i:list (list term), o:list (list term). +implement-injectors _ _ [] []. +implement-injectors TyParam [ArgNo | ArgNos] [InjTys | InjTyss] [R | RS ] :- + implement-K-injectors TyParam 1 ArgNo InjTys R, + implement-injectors TyParam ArgNos InjTyss RS. + +pred main i:inductive, i:string, o:list prop. +main GR Prefix Clauses :- std.do! [ + Name is Prefix ^ "injections", + coq.ensure-fresh-global-id Name FName, + coq.env.indt GR _ TyParamNo _ _ KNs KTys, + for-K-get-projectors TyParamNo KNs KTys ArgsNos PJss, + std.map PJss (x\ r\ sigma R\ (std.map x (y\ r\ sigma Ty\ coq.typecheck y Ty _, r = Ty) R), r = R) PJTyss, + build-types-injectors TyParamNo GR KNs ArgsNos KTys PJTyss InjTyss, + implement-injectors TyParamNo ArgsNos InjTyss Injss, + name-injectors FName 1 GR KNs Injss Clausess, +% TTT is {{lib:@elpi.derive.eq_f}}, +% coq.say TTT, +% std.forall Clauses (x\ +% coq.elpi.accumulate _ "derive.injections.db" (clause _ _ x) +% ), +% coq.env.add-const FName Body Type _ C, + std.flatten Clausess Clauses, + ClausesFin = [injections-done GR | Clauses], %[injections-done GR, injections GR (const C)], + std.forall ClausesFin (x\ + coq.elpi.accumulate _ "derive.injections.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/generic/injection_lemmas.v b/generic/injection_lemmas.v new file mode 100644 index 00000000..38331cf5 --- /dev/null +++ b/generic/injection_lemmas.v @@ -0,0 +1,105 @@ +From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. +From Trocq Extra Dependency "injection_lemmas.elpi" as injections. + +From elpi Require Import elpi. +From elpi.apps Require Import derive.legacy. +From elpi.apps Require Import projK. +Unset Uniform Inductive Parameters. +Elpi Db derive.injections.db lp:{{ + + % [injections I K ILs] links I, + % constructor inductive type, + % and K, + % a natural number > 0 (representing the constructor number) + % with the list of injection lemmas for that constructor + pred injections-db i:constructor, i:int, o:term. + + % [injections-done T K] means T K was already derived + pred injections-done o:inductive. +}}. + +Elpi Command derive.injections. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.projK.db. +Elpi Accumulate Db derive.projK.db. +Elpi Accumulate File injection. +Elpi Accumulate Db derive.injections.db. +Elpi Accumulate File injections. +Elpi Accumulate lp:{{ + + main [str I] :- !, + coq.locate I (indt GR), + % Ind is (indt GR) + coq.gref->id (indt GR) Tname, + Suffix is Tname ^ "_", + derive.injections.main GR Suffix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.injections ". +}}. +Elpi Trace Browser. + +Inductive Wrap : Type := +| W : unit -> Wrap. +Elpi derive.projK Wrap. +Print projW1. +Elpi derive.injections Wrap. +Print Wrap_injections11. + +Elpi derive.projK nat. +Elpi derive.injections nat. +Print nat_injections21. + +Elpi derive.projK option. +Print projSome1. +Elpi derive.injections option. +Print option_injections11. + +Inductive enum : Type := +| Constructor : unit -> bool -> enum. + +Elpi derive.projK enum. +Print projConstructor1. +Print projConstructor2. +Elpi derive.injections enum. +Print enum_injections11. +Print enum_injections12. + +Inductive enum2 : Type := +| Nol : enum2 +| Constructor2 : unit -> bool -> enum2. + +Elpi derive.projK enum2. +Print projConstructor21. +Print projConstructor22. +Elpi derive.injections enum2. +Print enum2_injections21. +Print enum2_injections22. + +Inductive Losts (T : Prop) : Prop := +| Conse : Losts T -> Losts T . + +Elpi derive.projK Losts. +Print projConse1. +Elpi derive.injections Losts. +Print Losts_injections11. + +Elpi derive.projK list. +Print projcons1. +Print projcons2. +Elpi derive.injections list. +Print list_injections21. +Print list_injections22. +Elpi Query lp:{{ + std.findall (injections-db _ _ _) Rules. + std.findall (injections-done _) Rules. + std.findall (projK-db _ _ _) Rules. +}}. +Goal (forall (A : Type) (_1 _2 : A) (H1 H2 : list A), +(_1 :: H1)%list = (_2 :: H2)%list -> H1 = H2). +Proof. +exact list_injections22. +Qed. diff --git a/generic/param2_inhab.elpi b/generic/param2_inhab.elpi new file mode 100644 index 00000000..eefd8139 --- /dev/null +++ b/generic/param2_inhab.elpi @@ -0,0 +1,134 @@ +/* param2 holds on the full type */ +/* license: GNU Lesser General Public License Version 2.1 or later */ +/* ------------------------------------------------------------------------- */ + +shorten std.{zip, assert!, do!, map, map2, rev}. + +namespace derive.param2.inhab { + +% local data base to map a constructor K of T (applied to params) to +% the pair isK and its type, eg ({{Zero}} `-> pr {{isZero}} {{isNat Zero}})) +type (`->) term -> pair term term -> prop. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +pred search i:term, i:term, o:term. % given T and isT it builds a proof forall x:T, isT x + +search _ Goal P :- + std.assert! (param2-inhab-db Goal P) "derive.param2_inhab: cannot prove inhabitation". + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +pred prove-args % for each (K x ..) we must produce (isK x x_isX ..) + i:list term, % the variables (x in the example above) + i:term, % the type of isK + o:list term. % x and x_isX +prove-args [] _ []. +prove-args [V|VS] (prod _ T x\ (prod _ T y\ (prod _ _ (pxy\ F x y pxy)))) [V,V,PV | RS] :- + param T T TR, !, % out of the type of x we get isX + search T TR PT, % PT is a proof that forall x, isX x + PV = app[PT,V], % PV is the x_isX above + param V V PV => prove-args VS (F V V PV) RS. + +pred oty i:(term -> term), i:term, i:list term, i:list term, o:term. +oty F _ V _ R :- rev V [X|_], R = F X. + +% MkBranch: Constructor ConstructorTyUnderLams LamBoundVars TheirTypes Result +pred body i:term, i:term, i:list term, i:list term, o:term. +body K _ V _ R :- + coq.safe-dest-app K Kname _, + Kname `-> (pr KR KRT), + coq.say V, + prove-args V KRT Args, + coq.mk-app KR Args R. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +pred body-params + i:int, % number of params left + i:term, % inductive type applied to parameters treated so far + i:term, % inductive type arity to process + i:list term, % construcors applied to parameters treated so far + i:list term, % construcor's types instantiated to parameters treated so far + o:term. + +body-params 0 IsT (prod _ T _\ prod _ T _\ sort _) K KT R :- coq.safe-dest-app T (global (indt GR)) _, coq.env.recursive? GR, !, + RT = (x\ {coq.mk-app IsT [x,x]}), + R = {{ fix IH (x : lp:T) {struct x} : lp:(RT x) := lp:(Bo IH x) }}, + coq.env.indt GR _ _ _ _ KX _, + map2 KX {zip K KT} (a\b\r\ r = (global (indc a)) `-> b) K2KR, + K2KR => % K `-> (pr isK isKtype) + @pi-decl `IH` (prod `x` T x\ RT x) f\ + @pi-decl `x` T x\ + param2-inhab-db IsT f => + coq.build-match x T + (oty RT) + body + (Bo f x). + +body-params 0 IsT (prod _ T _\ prod _ T _\ sort _) K KT R :- !, + RT = (x\ {coq.mk-app IsT [x,x]}), + R = {{ fun (x : lp:T) => lp:(Bo x) }}, + coq.safe-dest-app T (global (indt GR)) _, + coq.env.indt GR _ _ _ _ KX _, + map2 KX {zip K KT} (a\b\r\ r = (global (indc a)) `-> b) K2KR, + K2KR => % K `-> (pr isK isKtype) + @pi-decl `x` T x\ + coq.build-match x T (oty RT) body (Bo x). + +% param1 have the form : isT A (P : A -> Type) .. , so we process two +% param2 have the form : isT A B (P : A -> B -> Type) .. , so we process three ... +% binders at a time and we assume (H : trivial P) for each A and P +% binders at a time and we assume (H : full2self P) for each A and P +body-params N IsT (prod A TA a\ (prod _ _ b\ (prod P (TP a b) (F a b)))) K KT R :- N > 0, coq.sort? TA, !, + M is N - 3, + R = (fun A TA a\ + %fun B TA b\ + fun P (TP a a) p\ + fun _ {{ lib:elpi.derive.full2self lp:a lp:p }} pf\ Bo a p pf), + @pi-decl A TA a\ + %@pi-decl B TA b\ + @pi-decl P (TP a a) p\ + @pi-decl _ {{ lib:elpi.derive.full2self lp:a lp:p }} pf\ + sigma KAP KTAP\ + map K (k\ coq.mk-app k [a,a,p]) KAP, + map KT (coq.subst-prod [a,a,p]) KTAP, + param a a p => + param2-inhab-db p pf => % to prove (P x) use (H x) + body-params M {coq.mk-app IsT [a,a,p]} (F a a p) KAP KTAP (Bo a p pf). +body-params N IsT (prod A TA a\ (prod _ _ b\ prod P (TP a b) (F a b))) K KT R :- N > 0, !, + M is N - 3, + R = (fun A TA a\ + %fun B TA b\ + fun P (TP a a) p\ + Bo a a p), + @pi-decl A TA a\ + %@pi-decl A TA b\ + @pi-decl P (TP a a) p\ + sigma KAP KTAP\ + map K (k\ coq.mk-app k [a,a,p]) KAP, + map KT (coq.subst-prod [a,a,p]) KTAP, + param a a p => + body-params M {coq.mk-app IsT [a,a,p]} (F a a p) KAP KTAP (Bo a a p). + +body-params _ IsT _ _ _ _ :- + M is "derive.param2_inhab: wrong shape " ^ {coq.term->string IsT} ^ + ". It does not look like a unary parametricity translation of an inductive with no indexes.", + stop M. + +pred main i:inductive, i:string, o:list prop. +main GR Suffix [ClauseW, param2-inhab-done GR] :- std.spy-do! [ + + coq.env.indt GR Ind Lno Luno Arity K KT, + assert! (Ind = tt) "derive.param2_inhab: Coinductive types are not supported", + assert! (Lno = Luno) "derive.param2_inhab: Non-uniform parameters not supported", + body-params Lno (global (indt GR)) Arity {std.map K (k\r\ r = global (indc k))} KT RSkel, + coq.say {coq.term->string R}, + std.assert-ok! (coq.elaborate-skeleton RSkel RT R) "derive.param2_inhab generates illtyped term", + + Name is {coq.gref->id (indt GR)} ^ Suffix, + coq.env.add-const Name R RT @transparent! Witness, + + ClauseW = (param2-inhab-db (global (indt GR)) (global (const Witness))), + coq.elpi.accumulate _ "derive.param2.trivial.db" (clause _ _ ClauseW), + coq.elpi.accumulate _ "derive.param2.trivial.db" (clause _ _ (param2-inhab-done GR)), +]. + +} \ No newline at end of file diff --git a/generic/param2_inhab.v b/generic/param2_inhab.v new file mode 100644 index 00000000..077f0a6d --- /dev/null +++ b/generic/param2_inhab.v @@ -0,0 +1,556 @@ +(* Given an inductive type I and its unary parametricity translation is_ it + generates a proof of + forall i : I, is_U i + and then a proof of + forall i : I, { p : is_I i & forall q, p = q }. + + license: GNU Lesser General Public License Version 2.1 or later + ------------------------------------------------------------------------- *) +From elpi.apps.derive.elpi Extra Dependency "paramX_lib.elpi" as paramX. +From elpi.apps.derive.elpi Extra Dependency "param2.elpi" as param2. +(* From elpi.apps.derive.elpi Extra Dependency "param1_inhab.elpi" as param1_inhab. *) +From Trocq Extra Dependency "param2_inhab.elpi" as param2_inhab. +From Trocq Extra Dependency "param2_trivial.elpi" as param2_trivial. +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. + +From elpi Require Import elpi. +From elpi.apps Require Import derive.param1 derive.param2 derive.param1_trivial. + +Definition full2 T1 T2 P := forall (x : T1)(y : T2), P x y. +Register full2 as elpi.derive.full2. + +Definition full2self T P := forall (x : T), P x x. +Register full2self as elpi.derive.full2self. + +Definition contracts2self T P (x : T) w u := (@existT (P x x) (fun u : P x x=> forall v : P x x,@eq (P x x) u v) w u). +About contracts2self. +Register contracts2self as elpi.derive.contracts2self. + + Elpi Db derive.param2.trivial.db lp:{{ + + pred param2-trivial-done i:inductive. + type param2-trivial-db term -> term -> prop. + type param2-trivial-db-args list term -> list term -> prop. + + pred param2-inhab-done i:inductive. + type param2-inhab-db term -> term -> prop. + type param2-inhab-db-args list term -> list term -> prop. + +}}. +#[superglobal] Elpi Accumulate derive.param2.trivial.db File derive.lib. +#[superglobal] Elpi Accumulate derive.param2.trivial.db Db Header derive.param2.db. +#[superglobal] Elpi Accumulate derive.param2.trivial.db lp:{{ + + :name "param2:inhab:start" + param2-inhab-db + (fun `f` (prod `_` S _\ T) f\ + prod `x` S x\ prod `px` (RS x) _) + (fun `f` (prod `_` S _\ T) f\ + fun `x` S x\ + fun `px` (RS x) _\ P f x) :- + pi f x\ + param T T R, + param2-inhab-db R PT, + coq.mk-app PT [{coq.mk-app f [x]}] (P f x). + + param2-inhab-db (app [Hd|Args]) (app[P|PArgs]) :- + param2-inhab-db Hd P, !, + param2-inhab-db-args Args PArgs. + + param2-inhab-db-args [] []. + param2-inhab-db-args [T,P|Args] R :- + std.assert-ok! (coq.typecheck T Ty) "param2-inhab-db: cannot work illtyped term", + if (coq.sort? Ty) + (param2-inhab-db P Q, R = [T,P,Q|PArgs], param2-inhab-db-args Args PArgs) + (R = [T,P|PArgs], param2-inhab-db-args Args PArgs). + + :name "param2:trivial:start" + param2-trivial-db (fun `f` (prod `_` S _\ T) f\ + prod `x` S x\ prod `px` (RS x) _) + (fun `f` (prod `_` S _\ T) f\ + fun `x` S x\ + fun `px` (RS x) _\ P f x) :- + pi f x\ + param T T R, + param2-trivial-db R PT, + coq.mk-app PT [{coq.mk-app f [x]}] (P f x). + + param2-trivial-db (app [Hd|Args]) (app[P|PArgs]) :- + param2-trivial-db Hd P, !, + param2-trivial-db-args Args PArgs. + + param2-trivial-db-args [] []. + param2-trivial-db-args [T,P|Args] R :- + std.assert-ok! (coq.typecheck T Ty) "param2-trivial-db: cannot work on illtyped term", + if (coq.sort? Ty) + (param2-trivial-db P Q, R = [T,P,Q|PArgs], param2-trivial-db-args Args PArgs) + (R = [T,P|PArgs], param2-trivial-db-args Args PArgs). + +}}. + + +(* standalone *) +Elpi Command derive.param2.trivial. +Elpi Accumulate File derive_hook. +Elpi Accumulate File paramX. +Elpi Accumulate File param2. +Elpi Accumulate Db derive.param2.db. +(* Elpi Accumulate Db derive.param2.congr.db. *) +Elpi Accumulate Db derive.param2.trivial.db. +Elpi Accumulate File param2_inhab. +Elpi Accumulate File param2_trivial. +Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), + derive.param2.inhab.main GR "_inhab" CL, + CL => derive.param2.trivial.main GR "_trivial" _. + main _ :- usage. + + usage :- + coq.error "Usage: derive.param2.trivial ". +}}. + + +Elpi Command derive.param2.inhab. +Elpi Accumulate File derive_hook. +Elpi Accumulate File paramX. +Elpi Accumulate File param2. +Elpi Accumulate Db derive.param2.db. +(* Elpi Accumulate Db derive.param1.congr.db. *) +Elpi Accumulate Db derive.param2.trivial.db. +Elpi Accumulate File param2_inhab. +Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), + derive.param2.inhab.main GR "_inhab" _. + main _ :- usage. + + usage :- + coq.error "Usage: derive.param2.inhab ". +}}. + +(* ad-hoc rules for primitive data, eq and is_true *) + +(* Module Export exports. +Elpi derive.param2.trivial is_bool. +End exports. *) + +Definition is_uint63_inhab x : is_uint63 x. Proof. constructor. Defined. +Register is_uint63_inhab as elpi.derive.is_uint63_inhab. + +Definition is_float64_inhab x : is_float64 x. Proof. constructor. Defined. +Register is_float64_inhab as elpi.derive.is_float64_inhab. + +Definition is_pstring_inhab s : is_pstring s. Proof. constructor. Defined. +Register is_pstring_inhab as elpi.derive.is_pstring_inhab. + +Definition is_eq_inhab + A (PA : A -> Type) (HA : trivial A PA) (x : A) (px: PA x) y (py : PA y) (eq_xy : x = y) : + is_eq A PA x px y py eq_xy. +Proof. + revert py. + case eq_xy; clear eq_xy y. + intro py. + rewrite <- (trivial_uniq A PA HA x px); clear px. + rewrite <- (trivial_uniq A PA HA x py); clear py. + apply (is_eq_refl A PA x (trivial_full A PA HA x)). +Defined. +Register is_eq_inhab as elpi.derive.is_eq_inhab. + +(* Definition is_true_inhab b (H : is_bool b) p : is_is_true b H p := + is_eq_inhab bool is_bool is_bool_trivial b H true is_true p. +Register is_true_inhab as elpi.derive.is_true_inhab. *) + + +(* Elpi Accumulate derive.param2.trivial.db lp:{{ + + :before "param2:inhab:start" + param2-inhab-db {{ lib:elpi.derive.is_uint63 }} {{ lib:elpi.derive.is_uint63_inhab }}. + :before "param2:inhab:start" + param2-inhab-db {{ lib:elpi.derive.is_float64 }} {{ lib:elpi.derive.is_float64_inhab }}. + :before "param2:inhab:start" + param2-inhab-db {{ lib:elpi.derive.is_pstring }} {{ lib:elpi.derive.is_pstring_inhab }}. + :before "param2:inhab:start" + param2-inhab-db {{ lib:elpi.derive.is_eq }} {{ lib:elpi.derive.is_eq_inhab }}. + :before "param2:inhab:start" + param2-inhab-db {{ lib:elpi.derive.is_true }} {{ lib:elpi.derive.is_true_inhab }}. + + + :before "param2:inhab:start" + param2-inhab-db + {{ lib:elpi.derive.is_eq lp:A lp:PA lp:X lp:PX lp:Y lp:PY }} + {{ lib:elpi.derive.is_eq_inhab lp:A lp:PA lp:QA lp:X lp:PX lp:Y lp:PY }} :- !, + param2-trivial-db PA QA. + + :before "param2:inhab:start" + param2-inhab-db {{ lib:elpi.derive.is_is_true lp:B lp:PB }} R :- !, + param2-inhab-db {{ lib:elpi.derive.is_eq lib:elpi.bool lib:elpi.derive.is_bool lp:B lp:PB lib:elpi.true lib:elpi.derive.is_true }} R. + +}}. *) + + +Definition is_uint63_trivial : trivial PrimInt63.int is_uint63 := + fun x => contracts _ is_uint63 x (is_uint63_inhab x) + (fun y => match y with uint63 i => eq_refl end). +Register is_uint63_trivial as elpi.derive.is_uint63_trivial. + +Definition is_float64_trivial : trivial PrimFloat.float is_float64 := + fun x => contracts _ is_float64 x (is_float64_inhab x) + (fun y => match y with float64 i => eq_refl end). +Register is_float64_trivial as elpi.derive.is_float64_trivial. + +(* Definition is_pstring_trivial : trivial lib:elpi.pstring is_pstring := + fun x => contracts _ is_pstring x (is_pstring_inhab x) + (fun y => match y with pstring i => eq_refl end). +Register is_pstring_trivial as elpi.derive.is_pstring_trivial. *) + +Lemma is_eq_trivial A (PA : A -> Type) (HA : trivial A PA) (x : A) (px: PA x) + y (py : PA y) + : trivial (x = y) (is_eq A PA x px y py). +Proof. + intro p. + apply (contracts (x = y) (is_eq A PA x px y py) p (is_eq_inhab A PA HA x px y py p)). + revert py. + case p; clear p y. + rewrite <- (trivial_uniq _ _ HA x px). clear px. + intros py. + rewrite <- (trivial_uniq _ _ HA x py). clear py. + intro v; case v; clear v. + unfold is_eq_inhab. + unfold trivial_full. + unfold trivial_uniq. + case (HA x); intros it def_it; compute. + case (def_it it). + reflexivity. +Defined. +Register is_eq_trivial as elpi.derive.is_eq_trivial. + +(* Definition is_true_trivial b (H : is_bool b) : trivial (lib:elpi.is_true b) (is_is_true b H) := + is_eq_trivial bool is_bool is_bool_trivial b H true is_true. +Register is_true_trivial as elpi.derive.is_true_trivial. *) + + +Elpi Accumulate derive.param2.trivial.db lp:{{ + + :before "param2:trivial:start" + param2-trivial-db {{ lib:elpi.derive.is_uint63 }} {{ lib:elpi.derive.is_uint63_trivial }}. + :before "param2:trivial:start" + param2-trivial-db {{ lib:elpi.derive.is_float64 }} {{ lib:elpi.derive.is_float64_trivial }}. + %:before "param2:trivial:start" + %param2-trivial-db {{ lib:elpi.derive.is_pstring }} {{ lib:elpi.derive.is_pstring_trivial }}. + :before "param2:trivial:start" + param2-trivial-db {{ lib:elpi.derive.is_eq }} {{ lib:elpi.derive.is_eq_trivial }}. + %:before "param2:trivial:start" + %param2-trivial-db {{ lib:elpi.derive.is_true }} {{ lib:elpi.derive.is_true_trivial }}. + + + :before "param2:trivial:start" + param2-trivial-db + {{ lib:elpi.derive.is_eq lp:A lp:PA lp:X lp:PX lp:Y lp:PY }} + {{ lib:elpi.derive.is_eq_trivial lp:A lp:PA lp:QA lp:X lp:PX lp:Y lp:PY }} :- + param2-trivial-db PA QA. + + :before "param2:trivial:start" + param2-trivial-db {{ lib:elpi.derive.is_is_true lp:B lp:PB }} R :- !, + param2-trivial-db {{ lib:elpi.derive.is_eq lib:elpi.bool lib:elpi.derive.is_bool lp:B lp:PB lib:elpi.true lib:elpi.derive.is_true }} R. + +}}. + +(* hook into derive *) +Elpi Accumulate derive Db derive.param2.trivial.db. +Elpi Accumulate derive File param2_inhab. +(* Elpi Accumulate derive File param2_trivial. *) + +#[phases="both"] Elpi Accumulate derive lp:{{ +%dep1 "param2_trivial" "param2_inhab". +%dep1 "param2_trivial" "param2_congr". +dep1 "param2_inhab" "param2". +}}. + +#[synterp] Elpi Accumulate derive lp:{{ + derivation _ _ (derive "param2_inhab" (cl\ cl = []) true). + %derivation _ _ (derive "param2_trivial" (cl\ cl = []) true). +}}. + +Elpi Accumulate derive lp:{{ + +derivation (indt T) _ ff (derive "param2_inhab" (derive.on_param1 T derive.param2.inhab.main "_inhab") (derive.on_param1 T (T\_\_\param2-inhab-done T) _ _)). +%derivation (indt T) _ ff (derive "param2_trivial" (derive.on_param1 T derive.param2.trivial.main "_trivial") (derive.on_param1 T (T\_\_\param2-trivial-done T) _ _)). + +}}. + +Elpi Export derive.param2.inhab. + +Module tests. +(* ========= *) +(* ENUM *) +(* ========= *) +Inductive empty :=. +Elpi derive.param1 empty. +Elpi derive.param2 empty. +Elpi derive.param1.trivial is_empty. +Print is_empty_trivial. +Definition wish : forall x : empty, {u : is_empty x & forall v : is_empty x, u = v}. +intros x. +refine (contracts empty is_empty x (is_empty_inhab x) _). +fix IH 1. +intros v. +refine (match v as i in (is_empty s1) return (is_empty_inhab s1 = i) with end). +Defined. +Elpi Trace Browser. +Fail Elpi derive.param2.trivial empty_R. +Print is_empty_trivial. +Elpi derive.param2.inhab empty_R. +Check empty_R_inhab : forall x : empty, empty_R x x. +Print empty_R_inhab. + +Elpi derive.param2 unit. +Elpi derive.param2.inhab unit_R. +Check unit_R_inhab : forall x : unit, unit_R x x. +Print unit_R_inhab. +Elpi derive.param1 unit. +Elpi derive.param1.trivial is_unit. +Print is_unit_trivial. +Definition wish2 : forall (x : unit), {u : is_unit x & forall v : is_unit x, u = v}. +Proof. +intros x. +refine (contracts unit is_unit x (is_unit_inhab x) _). +fix IH 1. +intros v. +refine (match v as i in (is_unit s1) + return (is_unit_inhab s1 = i) + with | is_tt => eq_refl + end). +Defined. +Print wish2. +Elpi derive.param1 nat. +Elpi derive.param1.trivial is_nat. +Import EqNotations. +Print EqNotations. +Definition wish3 : forall (x : unit), {u : unit_R x x & forall v : unit_R x x, u = v}. +Proof. +intros x. +refine (contracts2self unit unit_R x (unit_R_inhab x) _). +(* induction x. *) +fix IH 1. +intros v. +(* refine match v with (tt_R ) => _ end. *) +Show Proof. +refine ((match v as i in (unit_R s1 s2) + return (forall (e : s2 = s1), (unit_R_inhab s1 = rew e in i)) + with | tt_R => fun e => match e with eq_refl => _ end + end) eq_refl). +Show Proof. +reflexivity. +Defined. +(* Unset Printing Notations. *) +(* Print wish3. *) + +Elpi derive.param2 nat. +Elpi derive.param2.inhab nat_R. +Print is_nat_trivial. +Print trivial_uniq. + +Definition wish4 : forall (x : nat), {u : nat_R x x & forall v : nat_R x x, u = v}. +Proof. +intros x. +refine (contracts2self nat nat_R x (nat_R_inhab x) _). +(* induction x. *) +generalize x. +fix IH 2. +intros x' v. +refine ((match v as i in (nat_R s1 s2) + return (forall (e : s2 = s1), (nat_R_inhab s1 = rew e in i)) + with | O_R => fun e => match e with eq_refl => _ end + | S_R y y' IH => fun e => match e with eq_refl => _ end + end) eq_refl). + Show Proof. ++ exact IDProp. +(* False. *) +Unshelve. +exact e. +assumption. ++ cbn. + rewrite (Eqdep_dec.UIP_refl_nat _ e); + reflexivity. + Show Proof. ++ exact IDProp. ++ +(* Unset Printing Notations. *) +simpl. +assert( y' = y ). + injection e; intros; assumption. +subst; cbn; rewrite (Eqdep_dec.UIP_refl_nat _ e); simpl. +f_equal; apply IH0. +Qed. + +Axiom todo : forall {T}, T. +Definition wish5 : forall (x : nat), {u : nat_R x x & forall v : nat_R x x, u = v}. +Proof. +intros x. +refine (contracts2self nat nat_R x (nat_R_inhab x) _). +(* induction x. *) +generalize x. +fix IH 2. +intros x' v. +unshelve refine ((match v as i in (nat_R s1 s2) + return (forall (e : s2 = s1), (nat_R_inhab s1 = rew e in i)) + with | O_R => fun e => match e as e0 in (_ = n) + return (match n with + | O => nat_R_inhab 0 = rew [nat_R 0] e in O_R + | S n => IDProp end) + with eq_refl => _ end + | S_R y y' IH => fun e => match e with eq_refl => _ end + end) eq_refl). + ++ rewrite (Eqdep_dec.UIP_refl_nat _ e); cbn; reflexivity. ++ assert( y' = y ). + injection e; intros; assumption. + Show Proof. +subst. +Show Proof. + rewrite H in e, IH. +(* cbn; rewrite (Eqdep_dec.UIP_refl_nat _ e); simpl. *) + cbn; rewrite (Eqdep_dec.UIP_refl_nat _ e); simpl. +f_equal; apply IH0. + + +Definition wish6 : forall (x : unit), {u : unit_R x x & forall v : unit_R x x, u = v}. +Proof. +intros x. +refine (contracts2self unit unit_R x (unit_R_inhab x) _). +(* induction x. *) +fix IH 1. +intros v. +(* refine match v with (tt_R ) => _ end. *) +Show Proof. +Fail refine ((match v as i in (unit_R s1 s2) + return (forall (e : s2 = s1), unit_R_inhab s1 = i) + with | tt_R => fun e => match e with eq_refl => _ end + end) eq_refl). +Abort. +(* Show Proof. +reflexivity. +Defined. *) + +Elpi derive.param2 bool. +(* Elpi derive.param2.inhab bool_R. *) +Elpi derive.param1.trivial is_bool. +Elpi derive.param2.inhab bool_R. + + +Definition wish6 : forall (x : bool), {u : bool_R x x & forall v : bool_R x x, u = v}. +Proof. +intros x. +refine (contracts2self bool bool_R x (bool_R_inhab x) _). +(* induction x. *) +fix IH 1. +intros v. +(* refine match v with (tt_R ) => _ end. *) +Show Proof. +refine ((match v as i in (bool_R s1 s2) + return (forall (e : s2 = s1), bool_R_inhab s1 = rew [bool_R s1] e in i) + with | true_R => fun e => match e with eq_refl => _ end + | false_R => fun e => match e with eq_refl => _ end + end) eq_refl). +Show Proof. +simpl. +reflexivity. +reflexivity. +Qed. + + +Inductive bool2 := +| ATrue : unit -> bool2 +| AFalse : unit -> bool2. + +Elpi derive.param2 bool2. +Elpi derive.param1 bool2. +(* Elpi derive.param2.inhab bool_R. *) +Elpi derive.param1.trivial is_bool2. +Elpi derive.param2.inhab bool2_R. + +Definition wish7 : forall (x : bool2), {u : bool2_R x x & forall v : bool2_R x x, u = v}. +Proof. +intros x. +refine (contracts2self bool2 bool2_R x (bool2_R_inhab x) _). +fix IH 1. +intros v. +Show Proof. +refine ((match v as i in (bool2_R s1 s2) + return (forall (e : s2 = s1), bool2_R_inhab s1 = rew [bool2_R s1] e in i) + with | ATrue_R u u' uR => fun e => match e with eq_refl => _ end + | AFalse_R u u' uR => fun e => match e with eq_refl => _ end + end) eq_refl). +Show Proof. +Abort. + + +Inductive bool3 := +| ATrue3 : unit -> bool3 +| AFalse3 : bool -> bool3. + +Elpi derive.param2 bool3. +Elpi derive.param1 bool3. +(* Elpi derive.param2.inhab bool_R. *) +Elpi derive.param1.trivial is_bool3. +Elpi derive.param2.inhab bool3_R. + +Definition wish7 : forall (x : bool3), {u : bool3_R x x & forall v : bool3_R x x, u = v}. +Proof. +intros x. +refine (contracts2self bool3 bool3_R x (bool3_R_inhab x) _). +fix IH 1. +intros v. +Show Proof. +refine ((match v as i in (bool3_R s1 s2) + return (forall (e : s2 = s1), bool3_R_inhab s1 = rew [bool3_R s1] e in i) + with | ATrue3_R u u' uR => fun e => match e with eq_refl => _ end + | AFalse3_R b b' bR => fun e => match e with eq_refl => _ end + end) eq_refl). +Show Proof. +simpl. +reflexivity. +reflexivity. +Qed. +(* ========= *) +(* Mentioning other inductives *) +(* ========= *) +Inductive box_unit := B : unit -> box_unit. +Elpi derive.param2 box_unit. +Elpi derive.param2.inhab box_unit_R. +Check box_unit_R_inhab : forall x : box_unit, box_unit_R x x. +Print box_unit_R_inhab. + +(* ========= *) +(* RECURSIVE *) +(* ========= *) + +(* Elpi derive.param2 nat. *) +Elpi derive.param2.inhab nat_R. +Check nat_R_inhab : forall x, nat_R x x. +Print nat_R_inhab. + +(* ========= *) +(* Parametric *) +(* ========= *) +Inductive wrap (A : Type) := W : A -> wrap. +Elpi derive.param2 wrap. +Elpi derive.param2.inhab wrap_R. +Check wrap_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : wrap A), wrap_R A A R x x. +Print wrap_R_inhab. + + +Inductive option (A : Type) := None | Some : A -> option. +Elpi derive.param2 option. +Elpi derive.param2.inhab option_R. +Check option_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : option A), option_R A A R x x. +Print option_R_inhab. + + +Inductive list (A : Type) := Nil | Cons : A -> list. +Elpi derive.param2 list. +Elpi derive.param2.inhab list_R. +Check list_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : list A), list_R A A R x x. +Print list_R_inhab. + +End tests. diff --git a/generic/param2_trivial.elpi b/generic/param2_trivial.elpi new file mode 100644 index 00000000..912bf4e7 --- /dev/null +++ b/generic/param2_trivial.elpi @@ -0,0 +1,130 @@ +/* param2 holds on the full type */ +/* license: GNU Lesser General Public License Version 2.1 or later */ +/* ------------------------------------------------------------------------- */ + +shorten std.{assert!, do!, drop-last}. + +namespace derive.param2.trivial { + +pred prove-args i:list term, i:list term, o:list term. +prove-args [] [] []. +prove-args [X,PX|Rest] [TX,TPX_X|TRest] [X,P1,PX,P2|PRest] :- + coq.safe-dest-app TPX_X HD ARGS, + drop-last 1 ARGS ARG, + coq.mk-app HD ARG TPX, + param2-trivial-db TPX P, !, + P1 = {{ lib:elpi.derive.trivial_full lp:TX lp:TPX lp:P lp:X }}, + P2 = {{ lib:elpi.derive.trivial_uniq lp:TX lp:TPX lp:P lp:X lp:PX }}, + prove-args Rest TRest PRest. + +pred oty i:term, i:term, i:term, i:list term, i:list term, o:term. +oty IsT W _ [Idx,V] _ {{ lib:@elpi.eq lp:Ty lp:Wx lp:V }} :- + Ty = app[IsT,Idx], Wx = app[W,Idx]. + +pred body i:term, i:term, i:term, i:term, i:list term, i:list term, o:term. +body _ _ K (app _) V VT R :- std.do! [ + /* + coq.safe-dest-app K (global (indc Kname)) Params, + + prove-args V VT P, + assert! (param2-congr-db Kname CongrK) "run derive.param2.congr first", + coq.mk-app CongrK Params Rhd, + coq.mk-app Rhd P R,*/ + trivialize-param2 V VT Triv, + do-args {std.rev V} {std.rev VT} {std.rev Triv} [] K R, +]. + +pred trivialize-param2 i:list term, i:list term, o:list term. +trivialize-param2 [] [] []. +trivialize-param2 [_,_|XS] [_,TPX|PS] [TPX1,T|TS] :- std.do! [ + coq.safe-dest-app TPX HD ARGS, + drop-last 1 ARGS ARG, + coq.mk-app HD ARG TPX1, + param2-trivial-db TPX1 T, + trivialize-param2 XS PS TS, +]. + +pred do-args i:list term, i:list term, i:list term, i:list term, i:term, o:term. +do-args [] [] [] _ _ {{ lib:@elpi.erefl _ _ }}. +do-args [PX,X|XS] [_,TX|PS] [Triv,P|Trivs] Old K R :- std.do! [ + Q = {{ lib:elpi.derive.trivial_uniq lp:TX lp:P lp:Triv lp:X lp:PX }}, + F = {{ lib:elpi.derive.trivial_full lp:TX lp:P lp:Triv lp:X }}, + std.assert-ok! (coq.typecheck Q TQ) "wtf", + (pi v\ + coq.mk-app K {std.rev {std.append {std.append Old [v,X]} XS}} (K1 v)), + std.append Old [F,X] Old1, + coq.build-match Q TQ (do-oty K1 PX) (do-body XS PS Trivs Old1 K) R, +]. + +pred do-oty i:(term -> term), i:term, i:term, i:list term, i:list term, o:term. +do-oty K E _ [V,_] _ {{ lib:@elpi.eq _ _ lp:KV }} :- copy E V => copy (K V) KV. + +pred do-body i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term, i:list term, i:list term, o:term. +do-body XS PS Trivs Old K _ _ _ _ R :- do-args XS PS Trivs Old K R. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +pred body-params + i:int, % number of params left + i:term, % inductive type applied to parameters treated so far + i:term, % inductive type arity to process + o:term. + +body-params 0 IsT (prod _ T _\ prod _ T _\ sort _) R :- !, std.do! [ + std.assert! (param2-inhab-db IsT W) "www", + R = {{ fun x : lp:T => + lib:elpi.derive.contracts2self lp:T lp:IsT x (lp:W x) + ((fix IH (x : lp:T) (y : lp:IsT x x) {struct y} : + lib:@elpi.eq (lp:IsT x x) (lp:W x x) y := lp:{{ { + + param2-trivial-db IsT {{ fun x : lp:T => + lib:elpi.derive.contracts2self lp:T lp:IsT x (lp:W x x) (IH x) }} => + coq.build-match {{y}} {{lp:IsT x x}} (oty IsT W) (body IsT W) + } }} + ) x) }}, +]. + +% param1 have the form : isT A (P : A -> Type) .. , so we process two +% param2 have the form : isT A B (P : A -> B -> Type) .. , so we process two +% binders at a time and we assume (H : trivial P) for each A and P +body-params N T (prod A TA a\ prod P (TP a) (F a)) R :- N > 0, 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\ { + decl a A TA => + decl p P (TP a) => + decl pf `_` {{ lib:elpi.derive.trivial lp:a lp:p }} => + param a a p => + param2-trivial-db p pf => % to prove (P x) use (H x) + param2-inhab-db p {{ lib:elpi.derive.trivial_full lp:a lp:p lp:pf }} => % to prove (P x) use (H x) + body-params M {coq.mk-app T [a,p]} + (F a p)}). +body-params N T (prod A TA a\ prod P (TP a) (F a)) R :- N > 0, !, + M is N - 2, + R = (fun A TA a\ + fun P (TP a) p\ { + decl a A TA => + decl p P (TP a) => + param a a p => + body-params M {coq.mk-app T [a,p]} (F a p)}). + +body-params _ T _ _ :- + coq.say "derive.param2_trivial: wrong shape " {coq.term->string T} + ". It does not look like a unary parametricity translation of an inductive with no indexes.", + fail. + +pred main i:inductive, i:string, o:list prop. +main GR Suffix [Clause,param2-trivial-done GR] :- do! [ + coq.env.indt GR _ Lno _ Arity _ _, + body-params Lno (global (indt GR)) Arity R, + % coq.say {coq.term->string R}, + std.assert-ok! (coq.typecheck R RT) "derive.param2_trivial generates illtyped term", + + Name is {coq.gref->id (indt GR)} ^ Suffix, + coq.env.add-const Name R RT @transparent! Cst, + Clause = (param2-trivial-db (global (indt GR)) (global (const Cst))), + coq.elpi.accumulate _ "derive.param2.trivial.db" (clause _ _ Clause), + coq.elpi.accumulate _ "derive.param2.trivial.db" (clause _ _ (param2-trivial-done GR)), +]. + +} \ No newline at end of file diff --git a/generic/test_param2_inhab.v b/generic/test_param2_inhab.v new file mode 100644 index 00000000..abbbbb1d --- /dev/null +++ b/generic/test_param2_inhab.v @@ -0,0 +1,67 @@ + +(* From elpi.apps Require Import derive.std. *) +From elpi.apps Require Import derive.param2. +Require Import param2_inhab. + + +(* ========= *) +(* ENUM *) +(* ========= *) +Inductive empty :=. +Elpi derive.param2 empty. +Elpi derive.param2.inhab empty_R. +Check empty_R_inhab : forall x : empty, empty_R x x. +Print empty_R_inhab. + +Elpi derive.param2 unit. +Elpi derive.param2.inhab unit_R. +Check unit_R_inhab : forall x : unit, unit_R x x. +Print unit_R_inhab. + +Elpi derive.param2 bool. +Elpi derive.param2.inhab bool_R. +Check bool_R_inhab : forall x : bool, bool_R x x. +Print bool_R_inhab. + + +(* ========= *) +(* Mentioning other inductives *) +(* ========= *) +Inductive box_unit := B : unit -> box_unit. +Elpi derive.param2 box_unit. +Elpi derive.param2.inhab box_unit_R. +Check box_unit_R_inhab : forall x : box_unit, box_unit_R x x. +Print box_unit_R_inhab. + +(* ========= *) +(* RECURSIVE *) +(* ========= *) + +Elpi derive.param2 nat. +Elpi Trace Browser. +About nat_R. +Elpi derive.param2.inhab nat_R. +Check nat_R_inhab : forall x, nat_R x x. +Print nat_R_inhab. + +(* ========= *) +(* Parametric *) +(* ========= *) +Inductive wrap (A : Type) := W : A -> wrap. +Elpi derive.param2 wrap. +Elpi derive.param2.inhab wrap_R. +Check wrap_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : wrap A), wrap_R A A R x x. +Print wrap_R_inhab. + + +Inductive option (A : Type) := None | Some : A -> option. +Elpi derive.param2 option. +Elpi derive.param2.inhab option_R. +Check option_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : option A), option_R A A R x x. +Print option_R_inhab. + +Inductive list (A : Type) := Nil | Cons : A -> list. +Elpi derive.param2 list. +Elpi derive.param2.inhab list_R. +Check list_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : list A), list_R A A R x x. +Print list_R_inhab. \ No newline at end of file From d61ecb76d9dd9b6685f040dd1bd25f48132ce7ec Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Tue, 29 Jul 2025 10:43:57 +0200 Subject: [PATCH 02/42] generating maps with relation10 instead of function --- generic/mymap.elpi | 222 +++++++++++++++++++++++++++++++++++++++++++++ generic/mymap.v | 69 ++++++++++++++ 2 files changed, 291 insertions(+) create mode 100644 generic/mymap.elpi create mode 100644 generic/mymap.v diff --git a/generic/mymap.elpi b/generic/mymap.elpi new file mode 100644 index 00000000..449f03fd --- /dev/null +++ b/generic/mymap.elpi @@ -0,0 +1,222 @@ +/* map over a container */ +/* license: GNU Lesser General Public License Version 2.1 or later */ +/* ------------------------------------------------------------------------- */ + +shorten std.{split-at, length, rev, append, do!, drop-last, assert!}. + +mymap-db (app[global (indt GR1)|A1]) (app[global (indt GR2)|A2]) R :- + coq.env.indt GR1 _ Lno1 _ _ _ _, + coq.env.indt GR2 _ Lno2 _ _ _ _, + {length A1} > Lno1, {length A2} > Lno2, + split-at Lno1 A1 Args1 Points1, + split-at Lno2 A2 Args2 Points2, + Points1 = Points2, !, + mymap-db {coq.mk-app (global (indt GR1)) Args1} {coq.mk-app (global (indt GR2)) Args2} F, + coq.mk-app F Points1 R. + +namespace derive.mymap { + +% Building the body %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +pred bo-idx + i:term, % inductive arity (input) + i:term, % inductive type (input) applied to params & idx handled so far + i:term, % inductive type (output) applied to params & idx handled so far + i:int, % current index no + o:int, % Recno + i:list term, % rev list of (output) parameters + o:term, % body + o:term. % type + +bo-idx (prod _ S1 T1) Ity1 Ity2 N M Ps (fun `x` S1 Bo) (prod `x` S1 Ty) :- !, + pi x\ sigma Ity1x Ity2x\ + coq.mk-app Ity1 [x] Ity1x, + coq.mk-app Ity2 [x] Ity2x, + N1 is N + 1, + decl x `x` S1 => bo-idx (T1 x) Ity1x Ity2x N1 M Ps (Bo x) (Ty x). + +bo-idx (sort _) Ity1 Ity2 N N Ps (fun `x` Ity1 Bo) (prod `_` Ity1 _\ Ity2) :- !, + @pi-decl `x` Ity1 x\ + coq.build-match x Ity1 (bo-idx-rty Ps Ity2) (bo-k-args Ps) (Bo x). + +bo-idx X Ity1 Ity2 N M Ps R1 R2 :- whd1 X X1, !, + bo-idx X1 Ity1 Ity2 N M Ps R1 R2. + +pred bo-idx-rty i:list term, i:term, i:term, i:list term, i:list term, o:term. +bo-idx-rty Ps ItyArgs _ Vs _ R :- + rev Vs [_|IdxsRev], + rev IdxsRev Idxs, + coq.safe-dest-app ItyArgs HD _, + coq.mk-app HD {append {rev Ps} Idxs} R. + +pred bo-k-args i:list term, i:term, i:term, i:list term, i:list term, o:term. +bo-k-args ParamsRev K _ Args Tys R :- + rev ParamsRev Params, + coq.safe-dest-app K (global (indc GR)) _, + coq.env.typeof (indc GR) T, coq.subst-prod Params T KT, + (bo-k-args.aux {coq.mk-app (global (indc GR)) Params} Args Tys KT R), + !. % the first combination that typechecks + +% pred map.aux i:term, o:term. +% map.aux (prod T N B) (prod T N B). +% map.aux FRel R :- +% coq.mk-app {{ map }} [FRel] R. + +bo-k-args.aux R [] [] _ R :- coq.typecheck R _ ok. +bo-k-args.aux K [A|As] [T|Ts] (prod _ S Ty) R :- + mymap-db T S FRel, + % map.aux FRel F, + coq.mk-app {{ map }} [FRel] 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 :- + mymap-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] [_|Ts] (prod _ _ Ty) R :- !, + bo-k-args.aux {coq.mk-app K [A]} As Ts (Ty A) R. +bo-k-args.aux K As Ts X R :- whd1 X X1, !, + bo-k-args.aux K As Ts X1 R. + + +% Take in input a mapping function for each parameter +% and then do the fixpoint + +pred bo-params + i:int, % current parameter + i:int, % number of parameters + i:term, % inductive type (input) applied to parameters handled so far + i:term, % inductive type (output) applied to parameters handled so far + i:term, % inductive arity (input) + i:term, % inductive arity (output) + i:list term, % output parameters so far + o:term. % map function + +bo-params Lno Lno Ity1 Ity2 A1 _ Ps (fix `f` Recno Fty Bo) :- + coq.safe-dest-app Ity1 (global (indt I)) _, coq.env.recursive? I, !, + @pi-decl `rec` Fty f\ + mymap-db Ity1 Ity2 f => + bo-idx A1 Ity1 Ity2 0 Recno Ps (Bo f) Fty. +bo-params Lno Lno Ity1 Ity2 A1 _ Ps Bo :- + bo-idx A1 Ity1 Ity2 0 _ Ps Bo _. + +bo-params N Lno Ity1 Ity2 (prod A Sty1 Rty1) (prod _ Sty2 Rty2) Ps R :- + coq.name-suffix A 1 A1, + coq.name-suffix A 2 A2, + coq.name-suffix A "f" Af, + N1 is N + 1, + std.spy! (pi a b f \ mk-map-ty a Sty1 b Sty2 (FAB a b) f _ (Clause a b f)), + R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Af (FAB a b) f\ Bo a b f), + pi a b f\ sigma Ity1A Ity2A \ + coq.mk-app Ity1 [a] Ity1A, + coq.mk-app Ity2 [b] Ity2A, + Clause a b f => + decl a A1 Sty1 => + decl b A2 Sty2 => + decl f Af (FAB a b) => + bo-params N1 Lno Ity1A Ity2A (Rty1 a) (Rty2 b) [b|Ps] (Bo a b f). + +bo-params N Lno Ity1 Ity2 T OT Ps R :- + whd1 T T1, whd1 OT OT1, !, + bo-params N Lno Ity1 Ity2 T1 OT1 Ps R. + +bo-params _ _ _ _ _ _ _ _ :- + stop "derive.map: Indexed data types not supported". + +pred map-pi i:any, o:list prop. +map-pi (x\ []) []. +map-pi (x\ [X x| XS x]) [pi x\ X x | YS] :- map-pi XS YS. + +pred mk-map-ty + i:term, % input variable + i:term, % and its type + i:term, % output variable + i:term, % an its type + o:term, % type of a mapping function from input to output + i:term, % map function (having the type above) + o:int, % arity of the predicate + o:list prop. % mymap-db clause for map function +mk-map-ty A (prod _ SA T1) B (prod _ SB T2) (prod `x` SA x\ R x) F N C1 :- + mymap-db SA SB Fa, !, + (pi x\ sigma Ax Fx BFx \ + coq.mk-app A [x] Ax, coq.mk-app Fa [x] Fx, coq.mk-app B [Fx] BFx, + mk-map-ty Ax (T1 x) BFx (T2 BFx) (R x) {coq.mk-app F [x]} M (C x), + N is M + 1), + map-pi C C1. +mk-map-ty A (prod _ S1 T1) B (prod _ _ T2) (prod `x` S1 x\ R x) F N C1 :- + (pi x\ sigma Ax Bx \ coq.mk-app A [x] Ax, coq.mk-app B [x] Bx, + mk-map-ty Ax (T1 x) Bx (T2 x) (R x) {coq.mk-app F [x]} M (C x), + N is M + 1), + map-pi C C1. +% mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ {{ Param10.Rel lp:A lp:B }} (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- +mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ (prod `x` A _\ B) (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- + drop-last 1 XS LA, + drop-last 1 YS LB, + drop-last 1 GS LF, + coq.mk-app X LA PLA, + coq.mk-app Y LB PLB, + coq.mk-app G LF PLF. +mk-map-ty A _ B _ {{ Param10.Rel lp:A lp:B }} F 0 [mymap-db A B F]. +% mk-map-ty A _ B _ (prod `x` A _\ B) F 0 [mymap-db A B F]. + +% Build a clause %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +pred mk-clause + i:int, % current parameter + i:int, % number of parameters + i:term, % inductive type (input) + i:term, % inductive type (output) + i:term, % arity of the inductive + i:list prop, % premises of the clause + i:term, % map function + o:prop. % clause for mymap-db +mk-clause N N Ity1 Ity2 _ Todo Map (mymap-db Ity1 Ity2 Map :- Todo). +mk-clause N Lno Ity1 Ity2 (prod _ _ T) Todo Map (pi x y f\ C x y f) :- !, + N1 is N + 1, + pi x y f\ sigma Ity1x Ity2y Mapf\ + coq.mk-app Ity1 [x] Ity1x, + coq.mk-app Ity2 [y] Ity2y, + coq.mk-app Map [x,y,f] Mapf, + mk-clause N1 Lno Ity1x Ity2y (T x) [mymap-db x y f|Todo] Mapf (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. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +pred main i:inductive, i:string, o:list prop. +main GR Prefix C :- do! [ + T = global (indt GR), + coq.env.indt GR _Ind Lno Luno Arity _ _, + assert! (Lno = Luno) "derive.map: Non-uniform parameters not supported", + + % generate map and add to the env + std.spy! (bo-params 0 Lno T T Arity Arity [] RSkel), + std.assert-ok! (coq.elaborate-skeleton RSkel Rty R) "derive.mymap generates illtyped term", + Name is Prefix ^ "mymap", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName R Rty @transparent! Funct, + + % generate clause and add to the db + mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause, + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ Clause), + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-done GR)), + C = [mymap-done GR,Clause] +]. + +} +/* +namespace derive.mymap { + + pred main i:inductive, i:string, o:list prop. + main GR Prefix Clauses :- std.do! [ + %... % synthesize Body and Type + Name is Prefix ^ "myconcept", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName Body Type _ C, + Clauses = [mymap-done GR, mymap-db GR (const C)], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ x) + ), + ]. + +} +*/ \ No newline at end of file diff --git a/generic/mymap.v b/generic/mymap.v new file mode 100644 index 00000000..90e7aa83 --- /dev/null +++ b/generic/mymap.v @@ -0,0 +1,69 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From Trocq Extra Dependency "mymap.elpi" as mymap. + +From elpi Require Import elpi. +From elpi.apps Require Import derive. +From Trocq Require Import Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi Db derive.mymap.db lp:{{ + % [mymap T1 T2 D] for T1 and T2 brings a map D from T1 to T2. + pred mymap-db i:term, i:term, o:term. + + % [mymap-done T] mean T was already derived + pred mymap-done o:inductive. +}}. + +Elpi Command derive.mymap. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate File mymap. +Elpi Accumulate lp:{{ + main [str I] :- !, + coq.locate I (indt GR), + coq.gref->id (indt GR) Tname, + Prefix is Tname ^ "_", + %derive.mymap.main GR Prefix _. + + % derive.mymap.mk-map-ty A _ B _ {{ Param10.Rel lp:A lp:B }} F 0 [mymap-db A B F] => + % (derive.mymap.bo-k-args.aux K [A|As] [T|Ts] (prod _ S Ty) R :- + % mymap-db T S FRel, + % coq.mk-app {{ map }} [FRel] F, + % coq.mk-app F [A] FA, + % bo-k-args.aux {coq.mk-app K [FA]} As Ts (Ty FA) R) => + + derive.mymap.main GR Prefix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.mymap ". +}}. + +Elpi derive.mymap option. +Print option_mymap. + +Elpi derive.mymap list. +Print list_mymap. + +Elpi derive.mymap prod. +Print prod_mymap. + +Elpi derive.mymap nat. +Print nat_mymap. + +Inductive ThreeTypes (A B C : Type) := +| C1 : A -> ThreeTypes A B C +| C2 : B -> ThreeTypes A B C +| C3 : C -> ThreeTypes A B C. + +Elpi derive.mymap ThreeTypes. +Print ThreeTypes_mymap. + +Elpi Query lp:{{ + %std.findall (mymap-db {{ option nat }} {{ option nat }} _) Rules. % non empty + %std.findall (mymap-db {{ nat }} {{ nat }} _) Rules. % non empty + std.findall (mymap-db {{ nat }} B C) Rules. % empty + std.findall (mymap-db A B C) Rules. % empty + std.findall (mymap-done _) Rules. % empty + +}}. From 49b9ed6bd6a6239e99235150278dd7927c03a542 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Tue, 29 Jul 2025 17:19:24 +0200 Subject: [PATCH 03/42] generating type of mR | modifications in mymap to get map definition given an inductive implementing mR for unit + bool extending mR for enum containers 0+ constructors with 0+ arguments mR for recursive non parametric inductives Enum + Recursive no TyParam + TyParam no Recursive mR working for recursive inductives with type parameters --- generic/DetailedmR.v | 221 +++++++++++++++++++++++++++++++++++++++++++ generic/mR.elpi | 210 ++++++++++++++++++++++++++++++++++++++++ generic/mR.v | 170 +++++++++++++++++++++++++++++++++ generic/mymap.elpi | 3 +- generic/mymap.v | 5 + 5 files changed, 608 insertions(+), 1 deletion(-) create mode 100644 generic/DetailedmR.v create mode 100644 generic/mR.elpi create mode 100644 generic/mR.v diff --git a/generic/DetailedmR.v b/generic/DetailedmR.v new file mode 100644 index 00000000..542d5b47 --- /dev/null +++ b/generic/DetailedmR.v @@ -0,0 +1,221 @@ +From Coq Require Import ssreflect. +From elpi.apps.derive Require Import derive derive.param2. +From Trocq Require Import mymap injection_lemmas. +Require Import HoTT_additions Hierarchy. +Unset Uniform Inductive Parameters. +Unset Universe Polymorphism. +Unset Universe Minimization ToSet. + +Definition Unit := unit. + +Elpi derive.param2 unit. +Definition UnitR := unit_R. +(* Inductive UnitR : Unit -> Unit -> Type := + | tt_R : UnitR tt tt. *) + +Elpi derive.mymap unit. +Definition unit_map : unit -> unit := unit_mymap. +Definition Unit_mR : forall (u1 u2 : Unit), unit_map u1 = u2 -> UnitR u1 u2. +Proof. +refine (fun u1 => match u1 as u return + forall u2 : Unit, unit_map u = u2 -> UnitR u u2 + with + | tt => _ end + ). +refine (fun u2 => match u2 as u return + unit_map tt = u -> UnitR tt u + with + | tt => _ end). +refine (fun e => tt_R). +Defined. + +Definition Bool := bool. +Elpi derive.param2 bool. + +Definition BoolR := bool_R. +(* Inductive BoolR : Bool -> Bool -> Type := +| true_R : BoolR true true +| false_R : BoolR false false. *) + +Elpi derive.mymap bool. +Definition bool_map : Bool -> Bool := bool_mymap. +Definition Bool_mR : forall (u1 u2 : Bool), bool_map u1 = u2 -> BoolR u1 u2. +Proof. +refine (fun u1 : Bool => match u1 as u return + forall u2 : Bool, bool_map u = u2 -> BoolR u u2 + with + | true => _ + | false => _ + end + ). ++ refine (fun u2 : Bool => match u2 as u return + bool_map true = u -> BoolR true u + with + | true => _ + | false => _ + end + ). + - (* true true *) + refine (fun e => true_R). + - (* true false *) intros e; discriminate e. ++ refine (fun u2 : Bool => match u2 as u return + bool_map false = u -> BoolR false u + with + | true => _ + | false => _ + end + ). + - (* false true *) intros e; discriminate e. + - (* false false *) refine (fun e => false_R). +Defined. + +Inductive Wrap : Type := +| KWrap1 : unit -> Wrap. + +Elpi derive.param2 Wrap. +Definition WrapR := Wrap_R. +Elpi derive.mymap Wrap. + +Definition wrap_map := Wrap_mymap. +Elpi derive.projK Wrap. +Elpi derive.injections Wrap. +Definition wrap_mR : forall w1 w2, wrap_map w1 = w2 -> WrapR w1 w2. +Proof. +refine (fun w1=> match w1 as w return + forall w2, wrap_map w = w2 -> WrapR w w2 + with + | KWrap1 u1 => _ end). +- refine (fun w2=> match w2 as w return + wrap_map (KWrap1 u1) = w -> WrapR (KWrap1 u1) w + with + | KWrap1 u2 => _ end). + refine (fun e => KWrap1_R u1 u2 (Unit_mR u1 u2 (Wrap_injections11 (unit_map u1) u2 e))). +Defined. + +Definition Nat := nat. +Elpi derive.param2 nat. +Definition NatR := nat_R. + +Elpi derive.mymap nat. +Definition nat_map := nat_mymap. +Elpi derive.injections nat. +Print nat_injections21. + +Definition nat_mR : forall n1 n2, nat_map n1 = n2 -> NatR n1 n2. +Proof. +fix F 1. +refine (fun n1 => match n1 as n return + forall n2, nat_map n = n2 -> NatR n n2 + with + | O => _ + | S n1' => _ end). ++ (* O *) + refine (fun n2 => match n2 as n return + nat_map 0 = n -> NatR 0 n + with + | O => _ + | S n2' => _ end). + - (* O O *) + refine (fun e => O_R). + - (* O S n2' *) intros e; discriminate e. ++ (* S n' *) + refine (fun n2 => match n2 as n return + nat_map (S n1') = n -> NatR (S n1') n + with + | O => _ + | S n2' => _ end). + - (* S n1' O *) intros e; discriminate e. + - (* S n1' S n2' *) + refine (fun e => S_R n1' n2' (F n1' n2' (nat_injections21 (nat_map n1') n2' e))). +Defined. + +Definition Option (A : Type) : Type := option A. + +Elpi derive.param2 option. +Definition OptionR := option_R. +(* Inductive OptionR (A1 A2 : Type) (AR : A1 -> A2 -> Type) : option A1 -> option A2 -> Type := +| SomeR : forall a1 a2 (aR : AR a1 a2), OptionR A1 A2 AR (Some a1) (Some a2) +| NoneR : OptionR A1 A2 AR None None. *) + +Elpi derive.mymap option. +Definition option_map := option_mymap. +(* Definition option_map (A1 A2 : Type) (AR : Param10.Rel A1 A2) : option A1 -> option A2 := +fun oa => + match oa with + | Some a => Some (map AR a) + | None => None + end. *) + +(* Elpi derive.injections option. *) +(* Print option_injections11. *) + +Definition option_mR : forall (A1 A2 : Type) (AR : Param2a0.Rel A1 A2) oa1 oa2, option_map A1 A2 AR oa1 = oa2 -> OptionR A1 A2 AR oa1 oa2. +Proof. +refine (fun A1 A2 AR => _). +refine (fun oa1 => match oa1 as oa +return forall oa2, option_map A1 A2 AR oa = oa2 -> OptionR A1 A2 AR oa oa2 +with + | Some a1 => _ + | None => _ end). ++ (* Some *) + refine (fun oa2 => match oa2 as oa + return option_map A1 A2 AR (Some a1) = oa -> OptionR A1 A2 AR (Some a1) oa + with + | Some a2 => _ + | None => _ end). + - (* Some Some *) + refine (fun e => Some_R A1 A2 AR a1 a2 (map_in_R AR a1 a2 (option_injections11 A2 (map AR a1) a2 e))). + - (* Some None *) intros e; discriminate e. ++ (* None *) + refine (fun oa2 => match oa2 as oa + return option_map A1 A2 AR None = oa -> OptionR A1 A2 AR None oa + with + | Some a2 => _ + | None => _ end). + - (* None Some *) intros e; discriminate e. + - refine (fun e => None_R A1 A2 AR). +Defined. + +Definition List (A : Type) := list A. +Elpi derive.param2 list. + +Definition ListR := list_R. +Elpi derive.mymap list. + +Definition list_map := list_mymap. + +Elpi derive.injections list. +Print list_injections21. + +Print cons_R. +Definition list_mR : forall (A1 A2 : Type) (AR : Param2a0.Rel A1 A2) l1 l2, list_map A1 A2 AR l1 = l2 -> ListR A1 A2 AR l1 l2. +Proof. +refine (fun A1 A2 AR=> _). +fix F 1. +refine (fun l1 => match l1 as l + return forall l2, list_map A1 A2 AR l = l2 + -> ListR A1 A2 AR l l2 + with + | nil => _ + | cons a1 l1' => _ end). ++ (* nil *) + refine (fun l2 => match l2 as l + return list_map A1 A2 AR nil = l -> ListR A1 A2 AR nil l + with + | nil => _ + | cons a2 l2' => _ end). + - (* nil nil *) + refine (fun e => nil_R A1 A2 AR). + - intros e; discriminate e. ++ (* cons *) + refine (fun l2 => match l2 as l + return list_map A1 A2 AR (cons a1 l1') = l -> ListR A1 A2 AR (cons a1 l1') l + with + | nil => _ + | cons a2 l2' => _ end). + - intros e; discriminate e. + - refine (fun e => cons_R A1 A2 AR + a1 a2 (map_in_R AR a1 a2 (list_injections21 A2 (map AR a1) a2 (list_map A1 A2 AR l1') l2' e)) + l1' l2' (F l1' l2' (list_injections22 A2 (map AR a1) a2 (list_map A1 A2 AR l1') l2' e))). +Defined. + \ No newline at end of file diff --git a/generic/mR.elpi b/generic/mR.elpi new file mode 100644 index 00000000..3c940e80 --- /dev/null +++ b/generic/mR.elpi @@ -0,0 +1,210 @@ +namespace derive.mR { + +% The number of Type parameters in T +% Type of inductive T, +% Type of bin parametricity translation TR, +% ML LHS of map equality +% MR RHS of map equality +% Rel type of TR applied to arguments +% Returns the type of map in R for T +% X is the first inductive, Y is the second inductive. +pred mk-mR-type i:int, i:term, i:term, i:term, i:term, o:term. +% Reached a sort, return map L = R -> IR. +mk-mR-type 0 (sort _) ML MR Rel (prod `_` {{ lp:ML = lp:MR }} _\ Rel). +% Introducing X and Y. +% The RHS of the equality is Y. +mk-mR-type 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (Bo x y)) ML _ Rel + (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- + pi x y\ + sigma NewML NewMR NewRel\ + coq.mk-app ML [x] NewML, + NewMR = y, + coq.mk-app Rel [x,y] NewRel, + mk-mR-type 0 (Bo x y) NewML NewMR NewRel (R x y). +% Process two type parameters + 1 relation at a time. +% Apply these parameters to the LHS of the equation. +mk-mR-type N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel + (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ Param2a0.Rel lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- + M is N - 1, + pi a1 a2 ar\ + sigma NewML NewMR NewRel\ + coq.mk-app ML [a1, a2, ar] NewML, + NewMR = a2, + coq.mk-app Rel [a1,a2,ar] NewRel, + mk-mR-type M (Bo a1 a2 ar) NewML NewMR NewRel (R a1 a2 ar). + +% Given Y and Bo: x\ y\ RT. The return type of the match on X is: substituting the binder of X in the match. +pred rty-1 i:(term -> term -> term), i:term , i:term, i: list term, i: list term, o:term. +rty-1 Bo Y _ Ts _ R :- + std.last Ts X, + R = Bo X Y. + +% Given X and Bo: x\ y\ RT. The return type of the match on Y is: substituting the binder of Y in the match. +pred rty-2 i:(term -> term -> term), i:term , i:term, i: list term, i: list term, o:term. +rty-2 Bo X _ Ts _ R :- + std.last Ts Y, + R = Bo X Y. + +pred sub-branch i:int, i: term, i:list term, i:list term, i:term, i:list term, i:list term, + i:(term -> term -> term), o:term. +sub-branch TyParamNo K1 Args1 ArgTys1 K2 Args2 ArgTys2 Bo (fun `e` ETy e\ (R e)):- + coq.mk-app K1 Args1 X, + coq.mk-app K2 Args2 Y, + BoXY = Bo X Y, + coq.elaborate-skeleton BoXY _ BoXYE _, + BoXYE = prod _ ETy G, + whd K1 [] Constr1 TypeArgs1, + whd K2 [] Constr2 TypeArgs2, + @pi-decl `e` ETy e\ + matrix TyParamNo Constr1 TypeArgs1 Args1 ArgTys1 Constr2 TypeArgs2 Args2 ArgTys2 e ETy (G e) (R e). + +% Each branch matches on Y as Y0, returning a term of type (Bo (K KArgs) Y0) given by matrix. +pred mkBranch i:int, i:(term -> term -> term), i:term, i:term, i:term, i:term, i:list term, i:list term, o:term. +mkBranch TyParamNo Bo Y YTy K _ Ts TYs R :- + coq.mk-app K Ts X, + coq.build-match Y YTy (rty-2 Bo X) + (k2\ _\ ts\ tys\ + sub-branch TyParamNo K Ts TYs k2 ts tys Bo) + R. + +pred build-mRA-ty-args i:list term, i:list term, i:term, o:term. +build-mRA-ty-args [] [] R R. +build-mRA-ty-args [ATy1| ArgsTy1] [ATy2| ArgsTy2] MR R :- + ar-db ATy1 ATy2 AR, + coq.mk-app MR [ATy1, ATy2, AR] NewMR, + build-mRA-ty-args ArgsTy1 ArgsTy2 NewMR R. + +% TODO update: this considers that type arguments come in Ts, they don't come in there. +pred build-mRA i:term, i:term, i:term, o:term. +build-mRA ATy1 ATy2 Ind R :- + whd ATy1 [] ITy ArgsTy1, + whd ATy2 [] _ ArgsTy2, + coq.typecheck Ind IndTy _, + mR-db ITy MR, + % TODO: change following line to implement non uniform parameters + definition of the fix. + if (ATy = IndTy) + (R = MR) + (build-mRA-ty-args ArgsTy1 ArgsTy2 MR R). + +pred build-injEKJ-args i:int, i:list term, i:list term, + i:term, i:term, o:term. +% applies TyParamNo time the Type parameter of the return Inductive. +build-injEKJ-args 0 Args1 Args2 InjKJ E R :- + app-interleave InjKJ Args1 Args2 InjKJArgs, + coq.mk-app InjKJArgs [E] R. +build-injEKJ-args N [_ | ATys1] [ATy2|ATys2] InjKJ E R :- + M is N - 1, + coq.mk-app InjKJ [ATy2] InjKJA, + build-injEKJ-args M ATys1 ATys2 InjKJA E R. + +pred app-interleave i:term, i:list term, i:list term, o:term. +app-interleave R [] [] R. +app-interleave F [A|Args1] [B|Args2] R :- + coq.mk-app F [A, B] NewF, + app-interleave NewF Args1 Args2 R. + +pred build-injEKJ i:int, i:term, i:term, i:term, i:int o: term. +build-injEKJ TyParamNo E ETy K J R :- + injections-db K J InjKJ, + whd ETy [] {{lib:@elpi.eq}} [_,A,B], + whd A [] (global (indc _)) ArgsL, + whd B [] (global (indc _)) ArgsR, + build-injEKJ-args TyParamNo ArgsL ArgsR InjKJ E InjEKJ, + coq.elaborate-skeleton InjEKJ _ R _. + +% TODO: for processing params extend with an int of param no + db Type Type AR. +% TODO: for processing contained types, lookup mR-db apply arg1 arg2 + the ith constructor injection of the equality. +pred apply-indR i:int, i:int, i:term, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term, i:term, i:int, o: term. +% N J K KR K1Args K1Tys K2Args K2Tys X Y E TyParamNo +apply-indR 0 _ _ KR [] [] [] [] [] [] _ _ _ _ _ KR. +% for the jth argument provide A1 A2 AR12 +% For AR12 we bring mR_ATy ATyArgs1 ATyArgs2 ARs +% For the equality we bring injectionKJ TyArgs2 (Args1 of the eq) (Args2 of the eq) +apply-indR 0 J K KR [] [A1|Args1] [ATy1|ArgTys1] [] [A2|Args2] [ATy2| ArgTys2] LHS RHS E ETy TyParamNo R :- + Jn is J + 1, + build-mRA ATy1 ATy2 LHS MRA, + build-injEKJ TyParamNo E ETy K J InjEKJ, + coq.mk-app MRA [A1,A2,InjEKJ] A12R, + coq.mk-app KR [A1,A2, A12R] KA12AR, + apply-indR 0 Jn K KA12AR [] Args1 ArgTys1 [] Args2 ArgTys2 LHS RHS E ETy TyParamNo R. +apply-indR N J K KR [Ty1|TyArgs1] Args1 ArgTys1 [Ty2|TyArgs2] Args2 ArgTys2 LHS RHS E ETy TyParamNo R :- + M is N - 1, + ar-db Ty1 Ty2 AR, + coq.mk-app KR [Ty1, Ty2, AR] NewKR, + apply-indR M J K NewKR TyArgs1 Args1 ArgTys1 TyArgs2 Args2 ArgTys2 LHS RHS E ETy TyParamNo R. + +% On the diagonal return KR a1 a2 ... +% Outside the diagonal discriminate +pred matrix + i:int, i: term, i:list term, i:list term, i:list term, i:term, i:list term, i:list term, i:list term, + i:term, i:term, i:term, o:term. +matrix TyParamNo K1 TyArgs1 KArgs1 ArgTys1 K1 TyArgs2 KArgs2 ArgTys2 E ETy _ R :- + !, + param K1 K1 KR, + coq.mk-app K1 {std.append TyArgs1 KArgs1} LHS, + coq.mk-app K1 {std.append TyArgs2 KArgs2} RHS, + apply-indR TyParamNo 1 K1 KR TyArgs1 KArgs1 ArgTys1 TyArgs2 KArgs2 ArgTys2 LHS RHS E ETy TyParamNo R. + +matrix _ _ _ _ _ _ _ _ _ E ETy G R :- !, + ltac.discriminate E ETy G R. + +pred implement-mR i:int, i:int, i:term, o:term. +% all TyParams processed, +% remains forall (i1: I Args1) (i2 : I Args2), map -> IR +% Bo is i1\ i2\ mapI Args1 Args2 ARs i1 = i2 -> IR Args1i Args2i ARsi i1 i2. +% todo: Carry the list of TyArgs, needed for apply-ind params. +implement-mR 0 TyParamNo (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)) (fix `f` 0 RT f\ fun I1 I1Ty i1\ fun I2 I2Ty i2\ (R f i1 i2)) :- + Ind = (global (indt GR)), + coq.safe-dest-app I1Ty Ind _, + coq.env.recursive? GR, !, + RT = (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)), + @pi-decl `f` RT f\ + @pi-decl I1 I1Ty i1\ + @pi-decl I2 I2Ty i2\ + mR-db Ind f => + coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R f i1 i2). +implement-mR 0 TyParamNo (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)) (fun I1 I1Ty i1\ fun I2 I2Ty i2\ (R i1 i2)) :- + @pi-decl I1 I1Ty i1\ + @pi-decl I2 I2Ty i2\ + coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R i1 i2). +implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) ar\ (Bo a1 a2 ar)) (fun A1 A1Ty a1\ fun A2 A2Ty a2\ fun AR (ARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, + @pi-decl A1 A1Ty a1\ + @pi-decl A2 A2Ty a2\ + @pi-decl AR (ARTy a1 a2) ar\ + Map = {{ @Trocq.Hierarchy.map }}, + coq.mk-app Map [a1,a2,ar] (PMapA a1 a2 ar), + % insert coercions + coq.elaborate-skeleton (PMapA a1 a2 ar) _ (MapA a1 a2 ar) ok, + MR = {{ @Trocq.Hierarchy.map_in_R }}, + coq.mk-app MR [a1,a2,ar] (PMR a1 a2 ar), + % PMR should not need elaboration coq.elaborate-skeleton PMR _ MRA ok, + MRA = PMR, + mymap-def A1Ty (MapA a1 a2 ar) ==> + mR-db a1 (MRA a1 a2 ar) ==> + ar-db a1 a2 ar ==> + implement-mR M TyParamNo (Bo a1 a2 ar) (R a1 a2 ar). + + +pred main i:inductive, i:string, o:list prop. +main GR Prefix Clauses :- std.do! [ + Name is Prefix ^ "mR", + coq.env.indt GR _ UnifParamNo _ _ _ _, + Ind = (global (indt GR)), + param Ind Ind TR, + coq.typecheck TR TRTy _, + mymap-def Ind IndMap, + mk-mR-type UnifParamNo TRTy IndMap {{ Type }} TR MRTy, + coq.elaborate-skeleton MRTy _ MRTyE ok, + std.spy! (implement-mR UnifParamNo UnifParamNo MRTyE T), + coq.elaborate-skeleton T MRTyE TE ok, + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName TE MRTyE _ C, + I = global (indt GR), + Clauses = [mR-done I, mR-db I (global (const C))], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.mR.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/generic/mR.v b/generic/mR.v new file mode 100644 index 00000000..ace0a42b --- /dev/null +++ b/generic/mR.v @@ -0,0 +1,170 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From elpi.apps.derive.elpi Extra Dependency "param2.elpi" as param2. +From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. +From Trocq Extra Dependency "mR.elpi" as mR. +From Trocq Require Import mymap injection_lemmas. + +From elpi Require Import elpi. +From elpi.apps Require Import derive.param2 derive.isK. +From elpi.apps Require Import derive.bcongr (* for eq_f register *) + derive.eqK (*for bool_discr *) + derive.isK. (* for isK db required by discriminate *) +From elpi.apps Require Import map. + +From Trocq Require Import Hierarchy. +Unset Uniform Inductive Parameters. +(* Unset Universe Polymorphism. + +Inductive PU (A : Type) : Type := +| AB : A -> unit -> PU A +| AC : A -> bool -> PU A. + +Inductive PP (A : Type): Type := +| ABC : A -> unit -> PP A. *) + +(* Elpi derive.param2 unit. *) +(* Elpi derive.mymap PU. *) +(* Elpi derive.mymap unit. +Elpi derive.map PU. +Elpi derive.map PP. +Elpi derive.mymap PP. +Elpi derive.mymap PU. *) + +Elpi Db derive.mR.db lp:{{ + % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. + pred ar-db i:term, i:term, o:term. + % [mR-db T D] links a type T to its corresponding map in R. + pred mR-db i:term, o:term. + + % [mR-done T] mean T was already derived + pred mR-done o:term. +}}. + +Elpi Command derive.mR. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate File param2. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate File discr. +Elpi Accumulate Db derive.isK.db. +Elpi Accumulate Db derive.injections.db. +Elpi Accumulate Db derive.mR.db. +Elpi Accumulate File mR. +Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), + coq.gref->id (indt GR) Tname, + Prefix is Tname ^ "_", + derive.mR.main GR Prefix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.mR ". +}}. + +Elpi derive list. +(* Print list_R. *) +Goal forall (A B : Type) (R : Param10.Rel A B), A -> B. +intros A B R. Fail exact R. exact (map R). Abort. + + + +Inductive False : Prop :=. +Elpi derive.param2 False. +Elpi derive.mymap False. +Elpi derive.projK False. +Elpi derive.injections False. +Elpi derive.isK False. +Elpi derive.mR False. + +Elpi derive.param2 unit. +Elpi derive.mymap unit. +Elpi derive.projK unit. +Elpi derive.injections unit. +Elpi derive.isK unit. +Elpi derive.mR unit. + +Elpi derive.param2 bool. +Elpi derive.mymap bool. +Elpi derive.isK bool. +Elpi derive.mR bool. +Print bool_mR. + +Inductive Wrap : Type := +| KWrap1 : unit -> Wrap. + +Elpi derive.param2 Wrap. +Elpi derive.mymap Wrap. +Elpi derive.projK Wrap. +Elpi derive.injections Wrap. +Elpi derive.mR Wrap. +Print Wrap_mR. + +Inductive WrapMore : Type := +| KWrap : unit -> bool -> WrapMore +| KWrapWrap : Wrap -> WrapMore +| F : unit -> unit -> unit -> WrapMore. + +Elpi derive.param2 WrapMore. +Elpi derive.mymap WrapMore. +Elpi derive.projK WrapMore. +Elpi derive.injections WrapMore. +Elpi derive.isK WrapMore. +Elpi derive.mR WrapMore. +Print WrapMore_mR. + +Elpi derive.param2 nat. +Elpi derive.mymap nat. +Elpi derive.isK nat. +Elpi derive.mR nat. + +Inductive Box (A : Type) := +| B : A -> Box A. + +Elpi derive.param2 Box. +Elpi derive.mymap Box. +Elpi derive.projK Box. +Elpi derive.injections Box. +Elpi derive.isK Box. +Elpi derive.mR Box. + +Elpi derive.param2 option. +Elpi derive.mymap option. +Elpi derive.projK option. +Elpi derive.injections option. +Elpi derive.isK option. +Elpi derive.mR option. +Print option_mR. + +Elpi derive.param2 prod. +Elpi derive.mymap prod. +Elpi derive.projK prod. +Elpi derive.injections prod. +Elpi derive.isK prod. +Elpi derive.mR prod. +Print prod_mR. + + +Fail Elpi derive.param2 list. +Elpi derive.mymap list. +Elpi derive.projK list. +Elpi derive.injections list. +Elpi derive.isK list. +Elpi Trace Browser. + +Elpi derive.mR list. +Print list_mR. + +Elpi Query lp:{{ + F = {{ fun (A : Type) (l : list A) => match l with nil => unit | cons a l => Prop end }}. + %coq.elaborate-skeleton F Ty FE ok, + coq.typecheck F Ty ok. + coq.say F. + %F = {{ fun b : bool => match b with true => unit | false => Prop end }}. + %std.findall (param {{ option }} {{ option }} T ) Rules, + %std.findall (param {{ list }} {{ list }} T ) Rules, + %std.findall (mymap-db {{ option nat }} {{ option nat }} C ) Rules, + %coq.typecheck T Ty _, + coq.say Rules. + +}}. diff --git a/generic/mymap.elpi b/generic/mymap.elpi index 449f03fd..24a80c26 100644 --- a/generic/mymap.elpi +++ b/generic/mymap.elpi @@ -197,9 +197,10 @@ main GR Prefix C :- do! [ % generate clause and add to the db mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause, + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-def GR (global (const Funct)))), coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ Clause), coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-done GR)), - C = [mymap-done GR,Clause] + C = [mymap-done GR,Clause, (mymap-def GR (global (const Funct)))] ]. } diff --git a/generic/mymap.v b/generic/mymap.v index 90e7aa83..0aeeab6e 100644 --- a/generic/mymap.v +++ b/generic/mymap.v @@ -7,6 +7,9 @@ From Trocq Require Import Hierarchy. Unset Uniform Inductive Parameters. Elpi Db derive.mymap.db lp:{{ + % [mymap-def I C] brings the constant defined for mapping inductive I. + pred mymap-def i:inductive, o:term. + % [mymap T1 T2 D] for T1 and T2 brings a map D from T1 to T2. pred mymap-db i:term, i:term, o:term. @@ -60,6 +63,8 @@ Elpi derive.mymap ThreeTypes. Print ThreeTypes_mymap. Elpi Query lp:{{ + coq.locate "option" (indt Option), + std.findall (mymap-def Option _) Rules. % empty %std.findall (mymap-db {{ option nat }} {{ option nat }} _) Rules. % non empty %std.findall (mymap-db {{ nat }} {{ nat }} _) Rules. % non empty std.findall (mymap-db {{ nat }} B C) Rules. % empty From 01643db666dfbf6cd78d5d3c500e33f663adf15d Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Thu, 7 Aug 2025 17:12:28 +0200 Subject: [PATCH 04/42] common + change of interface + preparing Rm --- generic/common_algo.elpi | 43 +++++++++++++++++++++++++++++++++++ generic/injection_lemmas.elpi | 4 ++-- generic/injection_lemmas.v | 4 ++-- generic/mR.elpi | 38 ++++--------------------------- generic/mR.v | 4 ++-- generic/mymap.elpi | 4 ++-- generic/mymap.v | 5 ++-- 7 files changed, 58 insertions(+), 44 deletions(-) create mode 100644 generic/common_algo.elpi diff --git a/generic/common_algo.elpi b/generic/common_algo.elpi new file mode 100644 index 00000000..f93edd1d --- /dev/null +++ b/generic/common_algo.elpi @@ -0,0 +1,43 @@ + +namespace derive.common-algo { + +pred swap i:term, i:term, i:bool, o:term, o:term. +swap A B tt B A. +swap A B ff A B. +% The number of Type parameters in T +% Type of inductive T, +% Type of bin parametricity translation TR, +% ML LHS of map equality +% MR RHS of map equality +% Rel type of TR applied to arguments +% Returns the type of map in R for T +% X is the first inductive, Y is the second inductive. +pred mk-mR-type i:int, i:term, i:term, i:term, i:term, i:bool, o:term. +% Reached a sort, return map L = R -> IR. +mk-mR-type 0 (sort _) ML MR Rel Swap R :- + Map = {{ lp:ML = lp:MR }}, + swap Map Rel Swap First Second, + R = prod `_` First _\ Second. +% Introducing X and Y. +% The RHS of the equality is Y. +mk-mR-type 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (Bo x y)) ML _ Rel Swap + (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- + pi x y\ + sigma NewML NewMR NewRel\ + coq.mk-app ML [x] NewML, + NewMR = y, + coq.mk-app Rel [x,y] NewRel, + mk-mR-type 0 (Bo x y) NewML NewMR NewRel Swap (R x y). +% Process two type parameters + 1 relation at a time. +% Apply these parameters to the LHS of the equation. +mk-mR-type N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel Swap + (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ Param2a0.Rel lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- + M is N - 1, + pi a1 a2 ar\ + sigma NewML NewMR NewRel\ + coq.mk-app ML [a1, a2, ar] NewML, + NewMR = a2, + coq.mk-app Rel [a1,a2,ar] NewRel, + mk-mR-type M (Bo a1 a2 ar) NewML NewMR NewRel Swap (R a1 a2 ar). + +} \ No newline at end of file diff --git a/generic/injection_lemmas.elpi b/generic/injection_lemmas.elpi index 017772a1..ffe9f268 100644 --- a/generic/injection_lemmas.elpi +++ b/generic/injection_lemmas.elpi @@ -112,7 +112,7 @@ name-injector FName I J GR Kn [InjTy|InjTyss] [Clause|Clauses] :- NameIJ is {std.any->string FName} ^ {std.any->string I} ^ {std.any->string J}, coq.env.add-const NameIJ InjTy _ _ C, % Clause = (injections-db Kn J (global (const C)) :- !), - Clause = (injections-db Kn J (global (const C))), + Clause = (injections-db (global (indc Kn)) J (global (const C))), name-injector FName I Jn GR Kn InjTyss Clauses. pred name-injectors i:string, i:int, i:inductive, i:list constructor, i:list (list term), o:list (list prop). @@ -175,7 +175,7 @@ main GR Prefix Clauses :- std.do! [ % ), % coq.env.add-const FName Body Type _ C, std.flatten Clausess Clauses, - ClausesFin = [injections-done GR | Clauses], %[injections-done GR, injections GR (const C)], + ClausesFin = [injections-done (global (indt GR)) | Clauses], %[injections-done GR, injections GR (const C)], std.forall ClausesFin (x\ coq.elpi.accumulate _ "derive.injections.db" (clause _ _ x) ), diff --git a/generic/injection_lemmas.v b/generic/injection_lemmas.v index 38331cf5..b4cbc8c4 100644 --- a/generic/injection_lemmas.v +++ b/generic/injection_lemmas.v @@ -14,10 +14,10 @@ Elpi Db derive.injections.db lp:{{ % and K, % a natural number > 0 (representing the constructor number) % with the list of injection lemmas for that constructor - pred injections-db i:constructor, i:int, o:term. + pred injections-db i:term, i:int, o:term. % [injections-done T K] means T K was already derived - pred injections-done o:inductive. + pred injections-done o:term. }}. Elpi Command derive.injections. diff --git a/generic/mR.elpi b/generic/mR.elpi index 3c940e80..883a4610 100644 --- a/generic/mR.elpi +++ b/generic/mR.elpi @@ -1,37 +1,7 @@ -namespace derive.mR { -% The number of Type parameters in T -% Type of inductive T, -% Type of bin parametricity translation TR, -% ML LHS of map equality -% MR RHS of map equality -% Rel type of TR applied to arguments -% Returns the type of map in R for T -% X is the first inductive, Y is the second inductive. -pred mk-mR-type i:int, i:term, i:term, i:term, i:term, o:term. -% Reached a sort, return map L = R -> IR. -mk-mR-type 0 (sort _) ML MR Rel (prod `_` {{ lp:ML = lp:MR }} _\ Rel). -% Introducing X and Y. -% The RHS of the equality is Y. -mk-mR-type 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (Bo x y)) ML _ Rel - (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- - pi x y\ - sigma NewML NewMR NewRel\ - coq.mk-app ML [x] NewML, - NewMR = y, - coq.mk-app Rel [x,y] NewRel, - mk-mR-type 0 (Bo x y) NewML NewMR NewRel (R x y). -% Process two type parameters + 1 relation at a time. -% Apply these parameters to the LHS of the equation. -mk-mR-type N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel - (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ Param2a0.Rel lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- - M is N - 1, - pi a1 a2 ar\ - sigma NewML NewMR NewRel\ - coq.mk-app ML [a1, a2, ar] NewML, - NewMR = a2, - coq.mk-app Rel [a1,a2,ar] NewRel, - mk-mR-type M (Bo a1 a2 ar) NewML NewMR NewRel (R a1 a2 ar). +shorten derive.common-algo.{mk-mR-type}. + +namespace derive.mR { % Given Y and Bo: x\ y\ RT. The return type of the match on X is: substituting the binder of X in the match. pred rty-1 i:(term -> term -> term), i:term , i:term, i: list term, i: list term, o:term. @@ -194,7 +164,7 @@ main GR Prefix Clauses :- std.do! [ param Ind Ind TR, coq.typecheck TR TRTy _, mymap-def Ind IndMap, - mk-mR-type UnifParamNo TRTy IndMap {{ Type }} TR MRTy, + mk-mR-type UnifParamNo TRTy IndMap {{ Type }} TR ff MRTy, coq.elaborate-skeleton MRTy _ MRTyE ok, std.spy! (implement-mR UnifParamNo UnifParamNo MRTyE T), coq.elaborate-skeleton T MRTyE TE ok, diff --git a/generic/mR.v b/generic/mR.v index ace0a42b..58b888e1 100644 --- a/generic/mR.v +++ b/generic/mR.v @@ -1,6 +1,6 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From elpi.apps.derive.elpi Extra Dependency "param2.elpi" as param2. From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. +From Trocq Extra Dependency "common_algo.elpi" as common. From Trocq Extra Dependency "mR.elpi" as mR. From Trocq Require Import mymap injection_lemmas. @@ -43,12 +43,12 @@ Elpi Db derive.mR.db lp:{{ Elpi Command derive.mR. Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate File param2. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.mymap.db. Elpi Accumulate File discr. Elpi Accumulate Db derive.isK.db. Elpi Accumulate Db derive.injections.db. +Elpi Accumulate File common. Elpi Accumulate Db derive.mR.db. Elpi Accumulate File mR. Elpi Accumulate lp:{{ diff --git a/generic/mymap.elpi b/generic/mymap.elpi index 24a80c26..b401a8bd 100644 --- a/generic/mymap.elpi +++ b/generic/mymap.elpi @@ -197,10 +197,10 @@ main GR Prefix C :- do! [ % generate clause and add to the db mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause, - coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-def GR (global (const Funct)))), + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-def (global (indt GR)) (global (const Funct)))), coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ Clause), coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-done GR)), - C = [mymap-done GR,Clause, (mymap-def GR (global (const Funct)))] + C = [mymap-done GR,Clause, (mymap-def (global (indt GR)) (global (const Funct)))] ]. } diff --git a/generic/mymap.v b/generic/mymap.v index 0aeeab6e..3a1721cb 100644 --- a/generic/mymap.v +++ b/generic/mymap.v @@ -8,7 +8,7 @@ Unset Uniform Inductive Parameters. Elpi Db derive.mymap.db lp:{{ % [mymap-def I C] brings the constant defined for mapping inductive I. - pred mymap-def i:inductive, o:term. + pred mymap-def i:term, o:term. % [mymap T1 T2 D] for T1 and T2 brings a map D from T1 to T2. pred mymap-db i:term, i:term, o:term. @@ -62,9 +62,10 @@ Inductive ThreeTypes (A B C : Type) := Elpi derive.mymap ThreeTypes. Print ThreeTypes_mymap. + Elpi Query lp:{{ coq.locate "option" (indt Option), - std.findall (mymap-def Option _) Rules. % empty + std.findall (mymap-def (global (indt Option)) _) Rules. % empty %std.findall (mymap-db {{ option nat }} {{ option nat }} _) Rules. % non empty %std.findall (mymap-db {{ nat }} {{ nat }} _) Rules. % non empty std.findall (mymap-db {{ nat }} B C) Rules. % empty From 9a0d2dc3f833a7d3f96f49d5c8571df69906cae6 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Thu, 7 Aug 2025 17:12:56 +0200 Subject: [PATCH 05/42] init Rm deriving type of Rm Rm for non inductive parameters, constructors without arguments Rm for non parametric inductives, constructors with 0+ arguments Rm for non parametric recursive arguments using KR to get arguments for IR_ind Rm for type parameters Rm for type parameters + recursion --- generic/Rm.elpi | 207 +++++++++++++++++++++++++++++++++++++++ generic/Rm.v | 140 ++++++++++++++++++++++++++ generic/common_algo.elpi | 7 +- generic/mR.v | 16 --- 4 files changed, 353 insertions(+), 17 deletions(-) create mode 100644 generic/Rm.elpi create mode 100644 generic/Rm.v diff --git a/generic/Rm.elpi b/generic/Rm.elpi new file mode 100644 index 00000000..96758847 --- /dev/null +++ b/generic/Rm.elpi @@ -0,0 +1,207 @@ +shorten derive.common-algo.{mk-mR-type}. + +namespace derive.Rm { + +pred mk-ith-eta i:int, i:list term, i:list term, i:list term, i:term, o:term. +mk-ith-eta I MArgs DestArgs Tys K FR :- + J is I - 1, + std.take J DestArgs Done, % list of args already processed. + std.drop I MArgs MTODO, % list of args to yet process + std.nth J Tys CurrTy, + (pi curr\ + coq.mk-app K {std.append Done [curr|MTODO]} (KArgs curr)), + FR = fun `R` CurrTy (r\ (KArgs r)). + +pred mk-etas i:list term, i:list term, i:list term, i:int, i:int, i: term, o:list term. +mk-etas _ _ _ M N _ [] :- M > N. +mk-etas SrcArgs DestArgs Tys I N KDest [R| RS] :- + J is I + 1, + mk-ith-eta I SrcArgs DestArgs Tys KDest R, + mk-etas SrcArgs DestArgs Tys J N KDest RS. + +pred compose-path i:list term, i:term, i:term o: term. +compose-path [] End _ End. +compose-path [Argk|Args] End ITy {{ @eq_trans lp:ITy _ _ _ lp:Argk lp:R }} :- + compose-path Args End ITy R. + +pred whds i:term, o:term. +whds T R :- + whd T [] HD ARGS, + unwind HD ARGS R. + +pred build-Rm-args i:list term, i:list term, i:term, o:term. +build-Rm-args [] _ T T. +build-Rm-args [A1|Args1] [A2|Args2] T R :- + ar-db A1 A2 AR, + coq.mk-app T [A1, A2, AR] TAR, + build-Rm-args Args1 Args2 TAR R. + + +pred build-Rm i:term, i:term, i:term, o:term. +build-Rm STy DTy ITyTy R :- + coq.safe-dest-app STy Ind Args1, + coq.safe-dest-app ITyTy Ind2 Args2, + rm-db Ind RM, + if (Ind = Ind2) + (R = RM) + (build-Rm-args Args1 Args2 RM RSkel, + coq.elaborate-skeleton RSkel _ R ok). + % build-mRA-ty-args ArgsTy1 ArgsTy2 MR R). + % rm-db STy RM, + + + +% given list of etas, list of src type, list of dest type, +% Dest iTyTy, list mapped args, list dest args, returns list of ap tyDest ITyty eta Marg DestArg (e : Marg = DestArg) +pred mk-aps-etas i:list term, i:list term, i:list term, i:term, i:list term, i:list term, o:list term. +mk-aps-etas [] [] [] _ [] [] []. +mk-aps-etas [Eta|Etas] [STy| SrcTys] [DTy|DestTys] ITyTy [MA|MArgs] [DA|Dargs] [RE|RS] :- + Ap = {{ eq_f }}, + param DA A AR, + build-Rm STy DTy ITyTy RM, + coq.typecheck RM RmTy ok, + coq.typecheck AR ARTy ok, + coq.mk-app RM [A, DA, AR] EqADA, + coq.mk-app Ap [DTy,ITyTy,Eta,MA,DA,EqADA] R, + coq.elaborate-skeleton R _ RE E, + mk-aps-etas Etas SrcTys DestTys ITyTy MArgs Dargs RS. + +% Ksource, Kdest, remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, +pred process-args i:term, i:term, i:int, i:int, i:term, i:term, i:list term, i:list term, i:term, o:term. +process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest _ITyTy R:- + coq.mk-app Goal [Ksrc, Kdest, {{ Type }}] EqTy, %discards the relation between Ksrc and Kdest, we want the equality. + whd EqTy [] {{lib:@elpi.eq}} [T,MapA,B], + whd MapA [] (global (indc _)) TySrcMappedArgs, + whd B [] KDest TyDestArgs, + std.drop TyArgsNo TySrcMappedArgs SrcMappedArgs, + std.drop TyArgsNo TyDestArgs DestArgs, + coq.mk-app KDest {std.take TyArgsNo TyDestArgs} KAppTyArgs, + mk-etas SrcMappedArgs DestArgs TyDest 1 {std.length DestArgs} KAppTyArgs REtas, + mk-aps-etas REtas TySrc TyDest T SrcMappedArgs DestArgs Raps, + compose-path Raps {{ @eq_refl lp:T lp:B }} T Rpath, + coq.elaborate-skeleton Rpath EqTy R E. +process-args Ksrc Kdest N TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal TySrc TyDest ITyTy + (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- + M is N - 1, + @pi-decl AN1 A1Ty a1\ + @pi-decl AN2 A2Ty a2\ + @pi-decl ARN (ARTy a1 a2) ar\ + coq.mk-app Ksrc [a1] (NewKS a1), + coq.mk-app Kdest [a2] (NewKD a2), + (param a2 a1 ar => + process-args (NewKS a1) (NewKD a2) M TyArgsNo (Bo a1 a2 ar) Goal TySrc TyDest ITyTy (R a1 a2 ar)), + % if the type of the argument is an instance of the inductive type add an induction hypothesis + whd ITyTy _ Ind _, + whd A2Ty _ IndD _, + if (Ind = IndD) + (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), + (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) + (RF = R). + + +pred type-of-args i:term, i:int, o:list term, o:list term. +type-of-args _ 0 [] []. +type-of-args (prod _AN1 ATy1 a1\ prod _AN2 ATy2 a2\ prod _ _ ar\ (Bo a1 a2 ar)) N [ATy1| SR] [ATy2 | DR] :- + M is N - 1, + pi a1 a2 ar\ + type-of-args (Bo a1 a2 ar) M SR DR. + +% invariant: all type arguments were already processed. +% Constructor src, Constructor dest, Constructor dest Type, Arguments to process, ConstructorR constructorR Type, i2, type of i2, i1 i2 iR => goal. +pred mkBranch i:term, i:term, i:term, i:int, i:term, i:term, i:term, i:term, i:term, o:term. +mkBranch KS KD KTy N KR KTyR _ITy ITyTy Goal Eq:- + type-of-args KTyR N SrcArgs DestArgs, + whd ITyTy [] _ TyArgs, + process-args KS KD N {std.length TyArgs} KTyR Goal SrcArgs DestArgs ITyTy Eq. + +pred mkBranches i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term o:list term. +mkBranches [] [] [] [] [] _ _ _ []. +mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KR|KRs] [KTyR|KTyRs] ITy ITyTy Goal [R|Rs] :- + mkBranch KS KD KTy {coq.count-prods KTy} KR KTyR ITy ITyTy Goal R, + mkBranches KsS KsD KTys KRs KTyRs ITy ITyTy Goal Rs. + +pred implement-Rm i:int, i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, o:term. +% Pred comes with Type parameters applied +% RInd comes with Type parameters applied +implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KRs KTyRs Pred RInd + (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- + coq.safe-dest-app ITy1 Ind _, + Ind = (global (indt GR)), + coq.env.recursive? GR, !, + RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), + coq.mk-app RInd [Pred] RIndP, + @pi-decl `f` RT f\ + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + @pi-decl ARN (ARTy i1 i2) ar\ + (rm-db Ind f => + mkBranches KsS KsD KTys KRs KTyRs i2 ITy2 Pred (Brs f i2)), + std.append (Brs f i2) [i1,i2,ar] (IndArgs f i1 i2 ar), + coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). +implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KRs KTyRs Pred RInd + (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- + coq.mk-app RInd [Pred] RIndP, + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + @pi-decl ARN (ARTy i1 i2) ar\ + mkBranches KsS KsD KTys KRs KTyRs i2 ITy2 Pred (Brs i2), + std.append (Brs i2) [i1,i2,ar] (IndArgs i1 i2 ar), + coq.mk-app RIndP (IndArgs i1 i2 ar) (R i1 i2 ar). +implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KTys KRs KTyRs Pred RInd + (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, + @pi-decl AN1 ATy1 a1\ %A1 : Type + @pi-decl AN2 ATy2 a2\ %A2 : Type + @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param2b0.Rel A1 A2 + coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), + + (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, + coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, + + coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), + coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, + + std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), + std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), + std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), + std.map KRs (x\ r\ sigma TMP\ coq.mk-app x [a1,a2,(RelAR a1 a2 ar)] TMP, r = TMP) (NewKRs a1 a2 ar), + std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), + Rm = {{ @Trocq.Hierarchy.R_in_map }}, + coq.mk-app Rm [a1, a2, ar] (RMS a1 a2 ar), + coq.elaborate-skeleton (RMS a1 a2 ar) (RTy a1 a2 ar) (RM a1 a2 ar) E, + ar-db a1 a2 ar ==> + rm-db a1 (RMS a1 a2 ar) ==> + implement-Rm M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKRs a1 a2 ar) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). + + +pred main i:inductive, i:string, o:list prop. +main GR Prefix Clauses :- std.do! [ + + coq.env.indt GR _ TyParamNo _ _ KNs KTys, + Ind = (global (indt GR)), + param Ind Ind TR, + coq.typecheck TR TRTy _, + mymap-def Ind IndMap, + mk-mR-type TyParamNo TRTy IndMap {{ Type }} TR tt MRTy, + coq.elaborate-skeleton MRTy _ MRTyE ok, + TR = global (indt GRR), + coq.gref->id (indt GRR) Rname, + RInductionName is Rname ^ "_ind", + coq.locate RInductionName RInd, + coq.prod->fun MRTyE Pred, + coq.env.indt GRR _ _ _ _ KNRs KTyRs, + std.map KNs (x\ r\ r = (global (indc x))) Ks, + std.map KNRs (x\ r\ r = (global (indc x))) KRs, + implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KRs KTyRs Pred (global RInd) R, + coq.elaborate-skeleton R MRTyE Re ok, + Name is Prefix ^ "Rm", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName Re MRTyE _ C, + I = global (indt GR), + Clauses = [rm-done I, rm-db I (global (const C))], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.Rm.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/generic/Rm.v b/generic/Rm.v new file mode 100644 index 00000000..d1b47a4b --- /dev/null +++ b/generic/Rm.v @@ -0,0 +1,140 @@ +From Coq Require Import ssreflect. +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From Trocq Extra Dependency "Rm.elpi" as Rm. +From Trocq Extra Dependency "common_algo.elpi" as common. + +From elpi Require Import elpi. +From elpi.apps Require Import derive.param2. +From elpi.apps Require Import derive.bcongr. (* for eq_f register *) +From Trocq Require Import mymap. +From elpi.apps Require Import derive.induction. +From Trocq Require Import HoTT_additions Hierarchy. +Unset Uniform Inductive Parameters. + +Inductive False :=. +Elpi derive.param2 False. + +From elpi.apps Require Import derive.param1 derive.param1_functor param1_trivial. +From Coq Require Import ssreflect ssrfun ssrbool. + +Elpi derive.param1 False. +Elpi derive.param1 False_R. + +Elpi derive.induction False_R. +Elpi derive.param1.trivial is_False. +(* Elpi derive.param1.trivial is_False_R. *) + +(* Elpi derive.param1 unit. +Elpi derive.param2 unit. +Elpi derive.param1 unit_R. +Elpi derive.induction unit_R. +Print unit_R_induction. *) + +Elpi Db derive.Rm.db lp:{{ + % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. + pred ar-db i:term, i:term, o:term. + + % [Rm-db T D] links a type T to its corresponding R in map. + pred rm-db i:term, o:term. + + % [Rm-done T] mean T was already derived + pred rm-done o:term. +}}. + +(* Definition eq_trans_impl {A : Type} {x y z : A} : x = y -> y = z -> x = z. +by apply eq_trans. Defined. *) + +Elpi Command derive.Rm. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate File common. +Elpi Accumulate Db derive.Rm.db. +Elpi Accumulate File Rm. +Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), + coq.gref->id (indt GR) Tname, + Prefix is Tname ^ "_", + derive.Rm.main GR Prefix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.Rm ". +}}. + +(* Inductive False : Prop :=. +Elpi derive.param2 False. +Elpi derive.mymap False. +Elpi derive.Rm False. +Print False_Rm. *) + +Elpi derive.param2 unit. +Elpi derive.mymap unit. + +Elpi derive.Rm unit. +Print unit_Rm. + +Elpi derive.param2 bool. +Elpi derive.mymap bool. +Elpi derive.Rm bool. +Print bool_Rm. + +Inductive Wrap : Type := +| KWrap1 : unit -> Wrap. + +Elpi derive.param2 Wrap. +Elpi derive.mymap Wrap. +Elpi derive.Rm Wrap. +Print Wrap_Rm. + +Inductive WrapMore : Type := +| KWrap : unit -> bool -> WrapMore +| KWrapWrap : Wrap -> WrapMore +| F : unit -> unit -> unit -> WrapMore. + +Elpi derive.param2 WrapMore. +Elpi derive.mymap WrapMore. +Elpi derive.Rm WrapMore. +Print WrapMore_Rm. + +Elpi derive.param2 nat. +Elpi derive.mymap nat. +Elpi derive.Rm nat. +Print nat_Rm. + +Inductive DoubleRec : Type := +| Base +| Double : DoubleRec -> DoubleRec -> DoubleRec. +Elpi derive.param2 DoubleRec. +Elpi derive.mymap DoubleRec. +Elpi derive.Rm DoubleRec. +Print DoubleRec_Rm. + +Inductive Box (A : Type) := +| B : A -> Box A. + +Elpi derive.param2 Box. +Elpi derive.mymap Box. +Set Printing All. +About R_in_map. +Print B_R. +Print Box_R_ind. +Elpi derive.Rm Box. +Print Box_Rm. + +Elpi derive.param2 option. +Elpi derive.mymap option. +Elpi derive.Rm option. +Print option_Rm. + +Elpi derive.param2 prod. +Elpi derive.mymap prod. +Elpi derive.Rm prod. +Print prod_Rm. + + +Elpi derive.param2 list. +Elpi derive.mymap list. +Elpi derive.Rm list. +Print list_Rm. diff --git a/generic/common_algo.elpi b/generic/common_algo.elpi index f93edd1d..d9200b44 100644 --- a/generic/common_algo.elpi +++ b/generic/common_algo.elpi @@ -1,6 +1,10 @@ namespace derive.common-algo { +pred rel-mode i:bool o:term. +rel-mode ff {{ Param2a0.Rel }}. +rel-mode tt {{ Param2b0.Rel }}. + pred swap i:term, i:term, i:bool, o:term, o:term. swap A B tt B A. swap A B ff A B. @@ -31,8 +35,9 @@ mk-mR-type 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (Bo x y)) ML _ Rel Swap % Process two type parameters + 1 relation at a time. % Apply these parameters to the LHS of the equation. mk-mR-type N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel Swap - (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ Param2a0.Rel lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- + (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ lp:AR lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- M is N - 1, + rel-mode Swap AR, pi a1 a2 ar\ sigma NewML NewMR NewRel\ coq.mk-app ML [a1, a2, ar] NewML, diff --git a/generic/mR.v b/generic/mR.v index 58b888e1..29dc57c3 100644 --- a/generic/mR.v +++ b/generic/mR.v @@ -13,22 +13,6 @@ From elpi.apps Require Import map. From Trocq Require Import Hierarchy. Unset Uniform Inductive Parameters. -(* Unset Universe Polymorphism. - -Inductive PU (A : Type) : Type := -| AB : A -> unit -> PU A -| AC : A -> bool -> PU A. - -Inductive PP (A : Type): Type := -| ABC : A -> unit -> PP A. *) - -(* Elpi derive.param2 unit. *) -(* Elpi derive.mymap PU. *) -(* Elpi derive.mymap unit. -Elpi derive.map PU. -Elpi derive.map PP. -Elpi derive.mymap PP. -Elpi derive.mymap PU. *) Elpi Db derive.mR.db lp:{{ % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. From b86f989019b9fa49c60ad1b7236d936b2a0fc180 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Tue, 19 Aug 2025 10:53:01 +0200 Subject: [PATCH 06/42] structuring fix _Coqproject --- algo/Rm.elpi | 207 +++++++++++++++++++++++++++ algo/Rm.v | 41 ++++++ algo/common_algo.elpi | 55 ++++++++ algo/injection_lemmas.elpi | 184 ++++++++++++++++++++++++ algo/injection_lemmas.v | 101 ++++++++++++++ algo/mR.elpi | 180 ++++++++++++++++++++++++ algo/mR.v | 62 ++++++++ algo/mymap.elpi | 223 +++++++++++++++++++++++++++++ algo/mymap.v | 55 ++++++++ detailed/DetailedRm.v | 207 +++++++++++++++++++++++++++ detailed/Detailed_injijK.v | 7 + detailed/DetailedmR.v | 256 ++++++++++++++++++++++++++++++++++ generic/DetailedmR.v | 39 +++++- generic/Rm.v | 34 +---- generic/common_algo.elpi | 25 ++-- generic/injection_lemmas.elpi | 4 +- generic/injection_lemmas.v | 10 +- generic/mR.elpi | 10 +- generic/mymap.elpi | 4 +- generic/mymap.v | 22 +-- tests/coverage.v | 39 ++++++ tests/test_Rm.v | 48 +++++++ tests/test_injection_lemmas.v | 36 +++++ tests/test_mR.v | 78 +++++++++++ tests/test_mymap.v | 16 +++ 25 files changed, 1864 insertions(+), 79 deletions(-) create mode 100644 algo/Rm.elpi create mode 100644 algo/Rm.v create mode 100644 algo/common_algo.elpi create mode 100644 algo/injection_lemmas.elpi create mode 100644 algo/injection_lemmas.v create mode 100644 algo/mR.elpi create mode 100644 algo/mR.v create mode 100644 algo/mymap.elpi create mode 100644 algo/mymap.v create mode 100644 detailed/DetailedRm.v create mode 100644 detailed/Detailed_injijK.v create mode 100644 detailed/DetailedmR.v create mode 100644 tests/coverage.v create mode 100644 tests/test_Rm.v create mode 100644 tests/test_injection_lemmas.v create mode 100644 tests/test_mR.v create mode 100644 tests/test_mymap.v diff --git a/algo/Rm.elpi b/algo/Rm.elpi new file mode 100644 index 00000000..96758847 --- /dev/null +++ b/algo/Rm.elpi @@ -0,0 +1,207 @@ +shorten derive.common-algo.{mk-mR-type}. + +namespace derive.Rm { + +pred mk-ith-eta i:int, i:list term, i:list term, i:list term, i:term, o:term. +mk-ith-eta I MArgs DestArgs Tys K FR :- + J is I - 1, + std.take J DestArgs Done, % list of args already processed. + std.drop I MArgs MTODO, % list of args to yet process + std.nth J Tys CurrTy, + (pi curr\ + coq.mk-app K {std.append Done [curr|MTODO]} (KArgs curr)), + FR = fun `R` CurrTy (r\ (KArgs r)). + +pred mk-etas i:list term, i:list term, i:list term, i:int, i:int, i: term, o:list term. +mk-etas _ _ _ M N _ [] :- M > N. +mk-etas SrcArgs DestArgs Tys I N KDest [R| RS] :- + J is I + 1, + mk-ith-eta I SrcArgs DestArgs Tys KDest R, + mk-etas SrcArgs DestArgs Tys J N KDest RS. + +pred compose-path i:list term, i:term, i:term o: term. +compose-path [] End _ End. +compose-path [Argk|Args] End ITy {{ @eq_trans lp:ITy _ _ _ lp:Argk lp:R }} :- + compose-path Args End ITy R. + +pred whds i:term, o:term. +whds T R :- + whd T [] HD ARGS, + unwind HD ARGS R. + +pred build-Rm-args i:list term, i:list term, i:term, o:term. +build-Rm-args [] _ T T. +build-Rm-args [A1|Args1] [A2|Args2] T R :- + ar-db A1 A2 AR, + coq.mk-app T [A1, A2, AR] TAR, + build-Rm-args Args1 Args2 TAR R. + + +pred build-Rm i:term, i:term, i:term, o:term. +build-Rm STy DTy ITyTy R :- + coq.safe-dest-app STy Ind Args1, + coq.safe-dest-app ITyTy Ind2 Args2, + rm-db Ind RM, + if (Ind = Ind2) + (R = RM) + (build-Rm-args Args1 Args2 RM RSkel, + coq.elaborate-skeleton RSkel _ R ok). + % build-mRA-ty-args ArgsTy1 ArgsTy2 MR R). + % rm-db STy RM, + + + +% given list of etas, list of src type, list of dest type, +% Dest iTyTy, list mapped args, list dest args, returns list of ap tyDest ITyty eta Marg DestArg (e : Marg = DestArg) +pred mk-aps-etas i:list term, i:list term, i:list term, i:term, i:list term, i:list term, o:list term. +mk-aps-etas [] [] [] _ [] [] []. +mk-aps-etas [Eta|Etas] [STy| SrcTys] [DTy|DestTys] ITyTy [MA|MArgs] [DA|Dargs] [RE|RS] :- + Ap = {{ eq_f }}, + param DA A AR, + build-Rm STy DTy ITyTy RM, + coq.typecheck RM RmTy ok, + coq.typecheck AR ARTy ok, + coq.mk-app RM [A, DA, AR] EqADA, + coq.mk-app Ap [DTy,ITyTy,Eta,MA,DA,EqADA] R, + coq.elaborate-skeleton R _ RE E, + mk-aps-etas Etas SrcTys DestTys ITyTy MArgs Dargs RS. + +% Ksource, Kdest, remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, +pred process-args i:term, i:term, i:int, i:int, i:term, i:term, i:list term, i:list term, i:term, o:term. +process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest _ITyTy R:- + coq.mk-app Goal [Ksrc, Kdest, {{ Type }}] EqTy, %discards the relation between Ksrc and Kdest, we want the equality. + whd EqTy [] {{lib:@elpi.eq}} [T,MapA,B], + whd MapA [] (global (indc _)) TySrcMappedArgs, + whd B [] KDest TyDestArgs, + std.drop TyArgsNo TySrcMappedArgs SrcMappedArgs, + std.drop TyArgsNo TyDestArgs DestArgs, + coq.mk-app KDest {std.take TyArgsNo TyDestArgs} KAppTyArgs, + mk-etas SrcMappedArgs DestArgs TyDest 1 {std.length DestArgs} KAppTyArgs REtas, + mk-aps-etas REtas TySrc TyDest T SrcMappedArgs DestArgs Raps, + compose-path Raps {{ @eq_refl lp:T lp:B }} T Rpath, + coq.elaborate-skeleton Rpath EqTy R E. +process-args Ksrc Kdest N TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal TySrc TyDest ITyTy + (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- + M is N - 1, + @pi-decl AN1 A1Ty a1\ + @pi-decl AN2 A2Ty a2\ + @pi-decl ARN (ARTy a1 a2) ar\ + coq.mk-app Ksrc [a1] (NewKS a1), + coq.mk-app Kdest [a2] (NewKD a2), + (param a2 a1 ar => + process-args (NewKS a1) (NewKD a2) M TyArgsNo (Bo a1 a2 ar) Goal TySrc TyDest ITyTy (R a1 a2 ar)), + % if the type of the argument is an instance of the inductive type add an induction hypothesis + whd ITyTy _ Ind _, + whd A2Ty _ IndD _, + if (Ind = IndD) + (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), + (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) + (RF = R). + + +pred type-of-args i:term, i:int, o:list term, o:list term. +type-of-args _ 0 [] []. +type-of-args (prod _AN1 ATy1 a1\ prod _AN2 ATy2 a2\ prod _ _ ar\ (Bo a1 a2 ar)) N [ATy1| SR] [ATy2 | DR] :- + M is N - 1, + pi a1 a2 ar\ + type-of-args (Bo a1 a2 ar) M SR DR. + +% invariant: all type arguments were already processed. +% Constructor src, Constructor dest, Constructor dest Type, Arguments to process, ConstructorR constructorR Type, i2, type of i2, i1 i2 iR => goal. +pred mkBranch i:term, i:term, i:term, i:int, i:term, i:term, i:term, i:term, i:term, o:term. +mkBranch KS KD KTy N KR KTyR _ITy ITyTy Goal Eq:- + type-of-args KTyR N SrcArgs DestArgs, + whd ITyTy [] _ TyArgs, + process-args KS KD N {std.length TyArgs} KTyR Goal SrcArgs DestArgs ITyTy Eq. + +pred mkBranches i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term o:list term. +mkBranches [] [] [] [] [] _ _ _ []. +mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KR|KRs] [KTyR|KTyRs] ITy ITyTy Goal [R|Rs] :- + mkBranch KS KD KTy {coq.count-prods KTy} KR KTyR ITy ITyTy Goal R, + mkBranches KsS KsD KTys KRs KTyRs ITy ITyTy Goal Rs. + +pred implement-Rm i:int, i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, o:term. +% Pred comes with Type parameters applied +% RInd comes with Type parameters applied +implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KRs KTyRs Pred RInd + (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- + coq.safe-dest-app ITy1 Ind _, + Ind = (global (indt GR)), + coq.env.recursive? GR, !, + RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), + coq.mk-app RInd [Pred] RIndP, + @pi-decl `f` RT f\ + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + @pi-decl ARN (ARTy i1 i2) ar\ + (rm-db Ind f => + mkBranches KsS KsD KTys KRs KTyRs i2 ITy2 Pred (Brs f i2)), + std.append (Brs f i2) [i1,i2,ar] (IndArgs f i1 i2 ar), + coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). +implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KRs KTyRs Pred RInd + (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- + coq.mk-app RInd [Pred] RIndP, + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + @pi-decl ARN (ARTy i1 i2) ar\ + mkBranches KsS KsD KTys KRs KTyRs i2 ITy2 Pred (Brs i2), + std.append (Brs i2) [i1,i2,ar] (IndArgs i1 i2 ar), + coq.mk-app RIndP (IndArgs i1 i2 ar) (R i1 i2 ar). +implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KTys KRs KTyRs Pred RInd + (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, + @pi-decl AN1 ATy1 a1\ %A1 : Type + @pi-decl AN2 ATy2 a2\ %A2 : Type + @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param2b0.Rel A1 A2 + coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), + + (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, + coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, + + coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), + coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, + + std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), + std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), + std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), + std.map KRs (x\ r\ sigma TMP\ coq.mk-app x [a1,a2,(RelAR a1 a2 ar)] TMP, r = TMP) (NewKRs a1 a2 ar), + std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), + Rm = {{ @Trocq.Hierarchy.R_in_map }}, + coq.mk-app Rm [a1, a2, ar] (RMS a1 a2 ar), + coq.elaborate-skeleton (RMS a1 a2 ar) (RTy a1 a2 ar) (RM a1 a2 ar) E, + ar-db a1 a2 ar ==> + rm-db a1 (RMS a1 a2 ar) ==> + implement-Rm M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKRs a1 a2 ar) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). + + +pred main i:inductive, i:string, o:list prop. +main GR Prefix Clauses :- std.do! [ + + coq.env.indt GR _ TyParamNo _ _ KNs KTys, + Ind = (global (indt GR)), + param Ind Ind TR, + coq.typecheck TR TRTy _, + mymap-def Ind IndMap, + mk-mR-type TyParamNo TRTy IndMap {{ Type }} TR tt MRTy, + coq.elaborate-skeleton MRTy _ MRTyE ok, + TR = global (indt GRR), + coq.gref->id (indt GRR) Rname, + RInductionName is Rname ^ "_ind", + coq.locate RInductionName RInd, + coq.prod->fun MRTyE Pred, + coq.env.indt GRR _ _ _ _ KNRs KTyRs, + std.map KNs (x\ r\ r = (global (indc x))) Ks, + std.map KNRs (x\ r\ r = (global (indc x))) KRs, + implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KRs KTyRs Pred (global RInd) R, + coq.elaborate-skeleton R MRTyE Re ok, + Name is Prefix ^ "Rm", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName Re MRTyE _ C, + I = global (indt GR), + Clauses = [rm-done I, rm-db I (global (const C))], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.Rm.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/algo/Rm.v b/algo/Rm.v new file mode 100644 index 00000000..1890db90 --- /dev/null +++ b/algo/Rm.v @@ -0,0 +1,41 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From Trocq.Algo Extra Dependency "Rm.elpi" as Rm. +From Trocq.Algo Extra Dependency "common_algo.elpi" as common. + +From elpi Require Import elpi. +From elpi.apps Require Import derive.param2. +From elpi.apps Require Import derive.bcongr. (* for eq_f register *) +From Trocq.Algo Require Import mymap. +From elpi.apps Require Import derive.induction. +From Trocq Require Import HoTT_additions Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi Db derive.Rm.db lp:{{ + % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. + pred ar-db i:term, i:term, o:term. + + % [Rm-db T D] links a type T to its corresponding R in map. + pred rm-db i:term, o:term. + + % [Rm-done T] mean T was already derived + pred rm-done o:term. +}}. + +Elpi Command derive.Rm. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate File common. +Elpi Accumulate Db derive.Rm.db. +Elpi Accumulate File Rm. +Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), + coq.gref->id (indt GR) Tname, + Prefix is Tname ^ "_", + derive.Rm.main GR Prefix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.Rm ". +}}. diff --git a/algo/common_algo.elpi b/algo/common_algo.elpi new file mode 100644 index 00000000..1e63b9e9 --- /dev/null +++ b/algo/common_algo.elpi @@ -0,0 +1,55 @@ + +namespace derive.common-algo { + +pred rel-mode i:bool o:term. +rel-mode ff {{ Param2a0.Rel }}. +rel-mode tt {{ Param2b0.Rel }}. + +pred swap i:term, i:term, i:bool, o:term, o:term. +swap A B tt B A. +swap A B ff A B. + +% Reached a sort, return map L = R -> IR. +pred mk-return i:term, i:term, i:term, i:bool, i:term, o:term. +mk-return ML MR Rel Swap ITyTy2 R :- + Map = {{ @eq lp:ITyTy2 lp:ML lp:MR }}, + swap Map Rel Swap First Second, + R = prod `_` First _\ Second. + + +% The number of Type parameters in T +% Type of inductive T, +% Type of bin parametricity translation TR, +% ML LHS of map equality +% MR RHS of map equality +% Rel type of TR applied to arguments +% Returns the type of map in R for T +% X is the first inductive, Y is the second inductive. +pred mk-mR-type i:int, i:term, i:term, i:term, i:term, i:bool, o:term. +% Introducing X and Y. +% The RHS of the equality is Y. +mk-mR-type 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap + (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- + @pi-decl IN1 ITyTy x\ + @pi-decl IN2 ITyTy2 y\ + sigma NewML NewMR NewRel\ + coq.mk-app ML [x] NewML, + NewMR = y, + coq.mk-app Rel [x,y] NewRel, + mk-return NewML NewMR NewRel Swap ITyTy2 (R x y). + % mk-mR-type 0 (Bo x y) NewML NewMR NewRel Swap (R x y). +% Process two type parameters + 1 relation at a time. +% Apply these parameters to the LHS of the equation. +mk-mR-type N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel Swap + (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ lp:AR lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- + M is N - 1, + rel-mode Swap ARSkel, + coq.elaborate-skeleton ARSkel _ AR ok, + pi a1 a2 ar\ + sigma NewML NewMR NewRel\ + coq.mk-app ML [a1, a2, ar] NewML, + NewMR = a2, + coq.mk-app Rel [a1,a2,ar] NewRel, + mk-mR-type M (Bo a1 a2 ar) NewML NewMR NewRel Swap (R a1 a2 ar). + +} \ No newline at end of file diff --git a/algo/injection_lemmas.elpi b/algo/injection_lemmas.elpi new file mode 100644 index 00000000..a96569d8 --- /dev/null +++ b/algo/injection_lemmas.elpi @@ -0,0 +1,184 @@ +namespace derive.injections { + +/* for all projectors of type forall Args T, ret +generate + +forall Args1-> Args2-> (e : Kj args->1 = Kj args->2) argj + +Take an inductive Ind, +take its constructors global references, +for each global reference GRK, +Compute the number of arguments J for each GRK, +for each ArgNumber in 1 to J+1, +get the Projector GRK ArgNumber, +Get the type ProjType, forall ArgTys Args Ind, ret +Return the processed Types */ + + +% Returns the list of projectors of a constructor. +pred get-projectors i:constructor, i:int, i:int, o:list term. +get-projectors _ Max Max [] :- !. +get-projectors GRK J Max [P|PJs] :- + I is J + 1, + projK-db GRK I P, + get-projectors GRK I Max PJs. + +% for a list of constructors returns a list with all the projectors of that construct +pred for-K-get-projectors i:int, i:list constructor, i:list term, o: list int, o:list (list term). +for-K-get-projectors _ [] [] [] []:- !. +for-K-get-projectors TyParamNo [Kn|KNs] [KTy|KTys] [ArgsNo|ArgsNos] [R|RS]:- + coq.count-prods KTy ArgsParamNo, + ArgsNo is ArgsParamNo - TyParamNo, + get-projectors Kn 0 ArgsNo R, + for-K-get-projectors TyParamNo KNs KTys ArgsNos RS. + +func names12 name -> name, name. +names12 N N1 N2 :- !, + coq.name-suffix N 1 N1, coq.name-suffix N 2 N2. + +% given TyParam ArgNo and T, +% duplicate-argument skips TyParam lambdas, +% then for the first ArgNo lambda adds another lambda expecting an argument of the same Type, +% after all lambdas are processed returns the body unchanged +% Returns a list with the original variables, and a list with the added ones +pred duplicate-arguments i:int, i:int, i:term, o:term. +duplicate-arguments 0 0 T T :- !. +duplicate-arguments 0 O (prod N TyA T) (prod Arg1 TyA a1\ (prod Arg2 TyA a2\ (S a1 a2))) :- + O > 0, + P is O - 1, + names12 N Arg1 Arg2, + (pi a1 a2\ duplicate-arguments 0 P (T a1) (S a1 a2)). +duplicate-arguments N O (prod TyName TyArg T) (prod TyName TyArg S) :- !, + N > 0, + M is N - 1, + pi a1\ duplicate-arguments M O (T a1) (S a1). + + +% TyParam, ArgNo, F, Type of the equality, Left HS, Right HS +% F is of type forall (Typarams : Type) ((Arg1 : A1) (Arg2 : A2) ...), Ret +% Ret is discarded and replaced by Left = Right +pred craft-eq i:int, i:int, i:int, i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, o:term. +craft-eq 0 0 _ _ _ EqTy Left Right ConclEqTy ConclL ConclR R:- !, + coq.mk-app {{lib:@elpi.eq}} [EqTy, Left, Right] AETy, + coq.mk-app {{lib:@elpi.eq}} [ConclEqTy, ConclL, ConclR] C, + R = {{ forall (e : lp:AETy), lp:C }}. + +craft-eq 0 ArgNo J Max (prod N1 T x\ prod N2 T y\ (Bo x y)) EqTy Left Right ConclEq ConclL ConclR (prod N1 T x\ prod N2 T y\ (S x y)) :- !, + M is ArgNo - 1, + J? is Max - ArgNo + 1, + @pi-decl N1 T x\ + @pi-decl N2 T y\ + sigma NewLeft NewRight NewConclEq NewConclL NewConclR\ + (if (J? = J) + (NewConclEq = T, + NewConclL = x, + NewConclR = y) + (NewConclEq = ConclEq, + NewConclL = ConclL, + NewConclR = ConclR)), + coq.mk-app Left [x] NewLeft, + coq.mk-app Right [y] NewRight, + craft-eq 0 M J Max (Bo x y) EqTy NewLeft NewRight NewConclEq NewConclL NewConclR (S x y). + +craft-eq TyParam ArgNo J Max (prod N T Bo) EqTy Left Right CE CL CR (prod N T x\ S x) :- !, + M is TyParam - 1, + @pi-decl N T x\ + sigma NewEqTy NewLeft NewRight\ + coq.mk-app EqTy [x] NewEqTy, + coq.mk-app Left [x] NewLeft, + coq.mk-app Right [x] NewRight, + craft-eq M ArgNo J Max (Bo x) NewEqTy NewLeft NewRight CE CL CR (S x). + +pred build-type-K-injector i:int, i:int, i:inductive, i:constructor, i:int, i:term, i:list term, o:list term. +build-type-K-injector _ _ _ _ _ _ [] [] :- !. +build-type-K-injector TyParamNo J GR Kn ArgNo KTy [PJ|PJs] [Eq|RS] :- std.do! [ + Jn is J + 1, + duplicate-arguments TyParamNo ArgNo PJ S, + (craft-eq TyParamNo ArgNo J ArgNo S (global (indt GR)) (global (indc Kn)) (global (indc Kn)) {{tt}} {{tt}} {{tt}} Eq), + coq.typecheck Eq _ ok, + build-type-K-injector TyParamNo Jn GR Kn ArgNo KTy PJs RS]. + +pred build-types-injectors i:int, i: inductive, i:list constructor, i: list int, i:list (term), i:list (list term), o:list (list term). +build-types-injectors _ _ [] [] [] [] [] :- !. +build-types-injectors TyParamNo GR [Kn|KNs] [ArgNo|ArgsNos] [KTy|KTys] [PJs|PJss] [R|RS] :- + build-type-K-injector TyParamNo 1 GR Kn ArgNo KTy PJs R, + build-types-injectors TyParamNo GR KNs ArgsNos KTys PJss RS. + % build-types-injectors Kn PJs R, + +pred name-injector i:string, i:int, i:int, i:inductive, i:constructor, i:list term, o:list prop. +name-injector _ _ _ _ _ [] []. +name-injector FName I J GR Kn [InjTy|InjTyss] [Clause|Clauses] :- + Jn is J + 1, + NameIJ is {std.any->string FName} ^ {std.any->string I} ^ {std.any->string J}, + coq.env.add-const NameIJ InjTy _ _ C, + % Clause = (injections-db Kn J (global (const C)) :- !), + Clause = (injections-db (global (indc Kn)) J (global (const C))), + name-injector FName I Jn GR Kn InjTyss Clauses. + +pred name-injectors i:string, i:int, i:inductive, i:list constructor, i:list (list term), o:list (list prop). +name-injectors _ _ _ [] [] []. +name-injectors FName I GR [Kn | KNs] [InjTys | InjTyss] [Clauses | Clausess] :- + In is I + 1, + name-injector FName I 1 GR Kn InjTys Clauses, + name-injectors FName In GR KNs InjTyss Clausess. + + +pred implement-K-injector-J i:int, i:int, i:int, i:int, i:term, o:term. + % implement-K-injector-J _ _ _ _ T T. +implement-K-injector-J 0 J 0 TyParam (prod E Ty _) R :- !, + I is J - 1, + R = {{ fun e:(lp:Ty) => lp:(PL e) }}, + @pi-decl E Ty e\ + sigma GR TyArgs GRK KArgs A B\ + ltac.injection? Ty GR TyArgs GRK KArgs A B, + ltac.injection.arg-i I J {{lib:@elpi.derive.eq_f}} GR TyArgs TyParam GRK KArgs A B e [(PL e)]. + +implement-K-injector-J 0 J ArgNo TyParam (prod ArgN1 ArgTy a\ (prod ArgN2 ArgTy b\ (Bo a b))) (fun ArgN1 ArgTy a\ fun ArgN2 ArgTy b\ (R a b) ) :- !, + ArgNon is ArgNo - 1, + @pi-decl ArgN1 ArgTy a\ + @pi-decl ArgN2 ArgTy b\ + implement-K-injector-J 0 J ArgNon TyParam (Bo a b) (R a b). + +implement-K-injector-J ParamNo J ArgNo TyParam (prod TyArg T t\ (Bo t)) (fun TyArg T t\ (R t) ) :- !, + ParamNon is ParamNo - 1, + @pi-decl TyArg T t\ + implement-K-injector-J ParamNon J ArgNo TyParam (Bo t) (R t). + +pred implement-K-injectors i:int, i:int, i:int, i:list term, o:list term. +implement-K-injectors _ _ _ [] []. +implement-K-injectors TyParam J ArgNo [InjTy | InjTys] [R | RS] :- + Jn is J + 1, + (implement-K-injector-J TyParam J ArgNo TyParam InjTy R), + coq.typecheck R InjTy ok, + implement-K-injectors TyParam Jn ArgNo InjTys RS. + +pred implement-injectors i:int, i:list int, i:list (list term), o:list (list term). +implement-injectors _ _ [] []. +implement-injectors TyParam [ArgNo | ArgNos] [InjTys | InjTyss] [R | RS ] :- + implement-K-injectors TyParam 1 ArgNo InjTys R, + implement-injectors TyParam ArgNos InjTyss RS. + +pred main i:inductive, i:string, o:list prop. +main GR Prefix Clauses :- std.do! [ + Name is Prefix ^ "injections", + coq.ensure-fresh-global-id Name FName, + coq.env.indt GR _ TyParamNo _ _ KNs KTys, + for-K-get-projectors TyParamNo KNs KTys ArgsNos PJss, + std.map PJss (x\ r\ sigma R\ (std.map x (y\ r\ sigma Ty\ coq.typecheck y Ty _, r = Ty) R), r = R) PJTyss, + build-types-injectors TyParamNo GR KNs ArgsNos KTys PJTyss InjTyss, + implement-injectors TyParamNo ArgsNos InjTyss Injss, + name-injectors FName 1 GR KNs Injss Clausess, +% TTT is {{lib:@elpi.derive.eq_f}}, +% coq.say TTT, +% std.forall Clauses (x\ +% coq.elpi.accumulate _ "derive.injections.db" (clause _ _ x) +% ), +% coq.env.add-const FName Body Type _ C, + std.flatten Clausess Clauses, + ClausesFin = [injections-done (global (indt GR)) | Clauses], %[injections-done GR, injections GR (const C)], + std.forall ClausesFin (x\ + coq.elpi.accumulate _ "derive.injections.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/algo/injection_lemmas.v b/algo/injection_lemmas.v new file mode 100644 index 00000000..d8656292 --- /dev/null +++ b/algo/injection_lemmas.v @@ -0,0 +1,101 @@ +From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. +From Trocq.Algo Extra Dependency "injection_lemmas.elpi" as injections. + +From elpi Require Import elpi. +From elpi.apps Require Import derive.bcongr. (* for eq_f register *) +From elpi.apps Require Import projK. +Unset Uniform Inductive Parameters. +Elpi Db derive.injections.db lp:{{ + + % [injections I K ILs] links I, + % constructor inductive type, + % and K, + % a natural number > 0 (representing the constructor number) + % with the list of injection lemmas for that constructor + pred injections-db i:term, i:int, o:term. + + % [injections-done T K] means T K was already derived + pred injections-done o:term. +}}. + +Elpi Command derive.injections. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.projK.db. +Elpi Accumulate Db derive.projK.db. +Elpi Accumulate File injection. +Elpi Accumulate Db derive.injections.db. +Elpi Accumulate File injections. +Elpi Accumulate lp:{{ + + main [str I] :- !, + coq.locate I (indt GR), + % Ind is (indt GR) + coq.gref->id (indt GR) Tname, + Suffix is Tname ^ "_", + derive.injections.main GR Suffix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.injections ". +}}. +Elpi Trace Browser. + +Inductive Wrap : Type := +| W : unit -> Wrap. +Elpi derive.projK Wrap. +Print projW1. +Elpi derive.injections Wrap. +Print Wrap_injections11. + +Elpi derive.projK nat. +Elpi derive.injections nat. +Print nat_injections21. + +Elpi derive.projK option. +Print projSome1. +Elpi derive.injections option. +Print option_injections11. + +Inductive enum : Type := +| Constructor : unit -> bool -> enum. + +Elpi derive.projK enum. +Print projConstructor1. +Print projConstructor2. +Elpi derive.injections enum. +Print enum_injections11. +Print enum_injections12. + +Inductive enum2 : Type := +| Nol : enum2 +| Constructor2 : unit -> bool -> enum2. + +Elpi derive.projK enum2. +Print projConstructor21. +Print projConstructor22. +Elpi derive.injections enum2. +Print enum2_injections21. +Print enum2_injections22. + +Inductive Losts (T : Prop) : Prop := +| Conse : Losts T -> Losts T . + +Elpi derive.projK Losts. +Print projConse1. +Elpi derive.injections Losts. +Print Losts_injections11. + +Elpi derive.projK list. +Print projcons1. +Print projcons2. +Elpi derive.injections list. +Print list_injections21. +Print list_injections22. + +Elpi Query lp:{{ + std.findall (injections-db _ _ _) Rules. + std.findall (injections-done _) Rules. + std.findall (projK-db _ _ _) Rules. +}}. diff --git a/algo/mR.elpi b/algo/mR.elpi new file mode 100644 index 00000000..02488c95 --- /dev/null +++ b/algo/mR.elpi @@ -0,0 +1,180 @@ + +shorten derive.common-algo.{mk-mR-type}. + +namespace derive.mR { + +% Given Y and Bo: x\ y\ RT. The return type of the match on X is: substituting the binder of X in the match. +pred rty-1 i:(term -> term -> term), i:term , i:term, i: list term, i: list term, o:term. +rty-1 Bo Y _ Ts _ R :- + std.last Ts X, + R = Bo X Y. + +% Given X and Bo: x\ y\ RT. The return type of the match on Y is: substituting the binder of Y in the match. +pred rty-2 i:(term -> term -> term), i:term , i:term, i: list term, i: list term, o:term. +rty-2 Bo X _ Ts _ R :- + std.last Ts Y, + R = Bo X Y. + +pred sub-branch i:int, i: term, i:list term, i:list term, i:term, i:list term, i:list term, + i:(term -> term -> term), o:term. +sub-branch TyParamNo K1 Args1 ArgTys1 K2 Args2 ArgTys2 Bo (fun `e` ETy e\ (R e)):- + coq.mk-app K1 Args1 X, + coq.mk-app K2 Args2 Y, + BoXY = Bo X Y, + coq.elaborate-skeleton BoXY _ BoXYE _, + BoXYE = prod _ ETy G, + whd K1 [] Constr1 TypeArgs1, + whd K2 [] Constr2 TypeArgs2, + @pi-decl `e` ETy e\ + matrix TyParamNo Constr1 TypeArgs1 Args1 ArgTys1 Constr2 TypeArgs2 Args2 ArgTys2 e ETy (G e) (R e). + +% Each branch matches on Y as Y0, returning a term of type (Bo (K KArgs) Y0) given by matrix. +pred mkBranch i:int, i:(term -> term -> term), i:term, i:term, i:term, i:term, i:list term, i:list term, o:term. +mkBranch TyParamNo Bo Y YTy K _ Ts TYs R :- + coq.mk-app K Ts X, + coq.build-match Y YTy (rty-2 Bo X) + (k2\ _\ ts\ tys\ + sub-branch TyParamNo K Ts TYs k2 ts tys Bo) + R. + +pred build-mRA-ty-args i:list term, i:list term, i:term, o:term. +build-mRA-ty-args [] [] R R. +build-mRA-ty-args [ATy1| ArgsTy1] [ATy2| ArgsTy2] MR R :- + ar-db ATy1 ATy2 AR, + coq.mk-app MR [ATy1, ATy2, AR] NewMR, + build-mRA-ty-args ArgsTy1 ArgsTy2 NewMR R. + +% TODO update: this considers that type arguments come in Ts, they don't come in there. +pred build-mRA i:term, i:term, i:term, o:term. +build-mRA ATy1 ATy2 Ind R :- + whd ATy1 [] ITy ArgsTy1, + whd ATy2 [] _ ArgsTy2, + coq.typecheck Ind IndTy _, + mR-db ITy MR, + % TODO: change following line to implement non uniform parameters + definition of the fix. + if (ATy1 = IndTy) + (R = MR) + (build-mRA-ty-args ArgsTy1 ArgsTy2 MR R). + +pred build-injEKJ-args i:int, i:list term, i:list term, + i:term, i:term, o:term. +% applies TyParamNo time the Type parameter of the return Inductive. +build-injEKJ-args 0 Args1 Args2 InjKJ E R :- + app-interleave InjKJ Args1 Args2 InjKJArgs, + coq.mk-app InjKJArgs [E] R. +build-injEKJ-args N [_ | ATys1] [ATy2|ATys2] InjKJ E R :- + M is N - 1, + coq.mk-app InjKJ [ATy2] InjKJA, + build-injEKJ-args M ATys1 ATys2 InjKJA E R. + +pred app-interleave i:term, i:list term, i:list term, o:term. +app-interleave R [] [] R. +app-interleave F [A|Args1] [B|Args2] R :- + coq.mk-app F [A, B] NewF, + app-interleave NewF Args1 Args2 R. + +pred build-injEKJ i:int, i:term, i:term, i:term, i:int o: term. +build-injEKJ TyParamNo E ETy K J R :- + injections-db K J InjKJ, + whd ETy [] {{lib:@elpi.eq}} [_,A,B], + whd A [] (global (indc _)) ArgsL, + whd B [] (global (indc _)) ArgsR, + build-injEKJ-args TyParamNo ArgsL ArgsR InjKJ E InjEKJ, + coq.elaborate-skeleton InjEKJ _ R _. + +% TODO: for processing params extend with an int of param no + db Type Type AR. +% TODO: for processing contained types, lookup mR-db apply arg1 arg2 + the ith constructor injection of the equality. +pred apply-indR i:int, i:int, i:term, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term, i:term, i:int, o: term. +% N J K KR K1Args K1Tys K2Args K2Tys X Y E TyParamNo +apply-indR 0 _ _ KR [] [] [] [] [] [] _ _ _ _ _ KR. +% for the jth argument provide A1 A2 AR12 +% For AR12 we bring mR_ATy ATyArgs1 ATyArgs2 ARs +% For the equality we bring injectionKJ TyArgs2 (Args1 of the eq) (Args2 of the eq) +apply-indR 0 J K KR [] [A1|Args1] [ATy1|ArgTys1] [] [A2|Args2] [ATy2| ArgTys2] LHS RHS E ETy TyParamNo R :- + Jn is J + 1, + build-mRA ATy1 ATy2 LHS MRA, + build-injEKJ TyParamNo E ETy K J InjEKJ, + coq.mk-app MRA [A1,A2,InjEKJ] A12R, + coq.mk-app KR [A1,A2, A12R] KA12AR, + apply-indR 0 Jn K KA12AR [] Args1 ArgTys1 [] Args2 ArgTys2 LHS RHS E ETy TyParamNo R. +apply-indR N J K KR [Ty1|TyArgs1] Args1 ArgTys1 [Ty2|TyArgs2] Args2 ArgTys2 LHS RHS E ETy TyParamNo R :- + M is N - 1, + ar-db Ty1 Ty2 AR, + coq.mk-app KR [Ty1, Ty2, AR] NewKR, + apply-indR M J K NewKR TyArgs1 Args1 ArgTys1 TyArgs2 Args2 ArgTys2 LHS RHS E ETy TyParamNo R. + +% On the diagonal return KR a1 a2 ... +% Outside the diagonal discriminate +pred matrix + i:int, i: term, i:list term, i:list term, i:list term, i:term, i:list term, i:list term, i:list term, + i:term, i:term, i:term, o:term. +matrix TyParamNo K1 TyArgs1 KArgs1 ArgTys1 K1 TyArgs2 KArgs2 ArgTys2 E ETy _ R :- + !, + param K1 K1 KR, + coq.mk-app K1 {std.append TyArgs1 KArgs1} LHS, + coq.mk-app K1 {std.append TyArgs2 KArgs2} RHS, + apply-indR TyParamNo 1 K1 KR TyArgs1 KArgs1 ArgTys1 TyArgs2 KArgs2 ArgTys2 LHS RHS E ETy TyParamNo R. + +matrix _ _ _ _ _ _ _ _ _ E ETy G R :- !, + ltac.discriminate E ETy G R. + +pred implement-mR i:int, i:int, i:term, o:term. +% all TyParams processed, +% remains forall (i1: I Args1) (i2 : I Args2), map -> IR +% Bo is i1\ i2\ mapI Args1 Args2 ARs i1 = i2 -> IR Args1i Args2i ARsi i1 i2. +% todo: Carry the list of TyArgs, needed for apply-ind params. +implement-mR 0 TyParamNo (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)) (fix `f` 0 RT f\ fun I1 I1Ty i1\ fun I2 I2Ty i2\ (R f i1 i2)) :- + Ind = (global (indt GR)), + coq.safe-dest-app I1Ty Ind _, + coq.env.recursive? GR, !, + RT = (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)), + @pi-decl `f` RT f\ + @pi-decl I1 I1Ty i1\ + @pi-decl I2 I2Ty i2\ + mR-db Ind f => + coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R f i1 i2). +implement-mR 0 TyParamNo (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)) (fun I1 I1Ty i1\ fun I2 I2Ty i2\ (R i1 i2)) :- + @pi-decl I1 I1Ty i1\ + @pi-decl I2 I2Ty i2\ + coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R i1 i2). +implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) ar\ (Bo a1 a2 ar)) + (fun A1 A1Ty a1\ fun A2 A2Ty a2\ fun AR (ARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, + @pi-decl A1 A1Ty a1\ + @pi-decl A2 A2Ty a2\ + @pi-decl AR (ARTy a1 a2) ar\ + Map = {{ @Trocq.Hierarchy.map }}, + coq.mk-app Map [a1,a2,ar] (PMapA a1 a2 ar), + % insert coercions + coq.elaborate-skeleton (PMapA a1 a2 ar) _ (MapA a1 a2 ar) ok, + MR = {{ @Trocq.Hierarchy.map_in_R }}, + coq.mk-app MR [a1,a2,ar] (PMR a1 a2 ar), + coq.elaborate-skeleton (PMR a1 a2 ar) _ (MRA a1 a2 ar) ok, + mymap-def A1Ty (MapA a1 a2 ar) ==> + mR-db a1 (MRA a1 a2 ar) ==> + ar-db a1 a2 ar ==> + implement-mR M TyParamNo (Bo a1 a2 ar) (R a1 a2 ar). + + +pred main i:inductive, i:string, o:list prop. +main GR Prefix Clauses :- std.do! [ + Name is Prefix ^ "mR", + coq.env.indt GR _ UnifParamNo _ _ _ _, + Ind = (global (indt GR)), + param Ind Ind TR, + coq.typecheck TR TRTy _, + mymap-def Ind IndMap, + mk-mR-type UnifParamNo TRTy IndMap {{ Type }} TR ff MRTy, + coq.elaborate-skeleton MRTy _ MRTyE ok, + implement-mR UnifParamNo UnifParamNo MRTyE T, + coq.elaborate-skeleton T MRTyE TE ok, + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName TE MRTyE _ C, + I = global (indt GR), + Clauses = [mR-done I, mR-db I (global (const C))], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.mR.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/algo/mR.v b/algo/mR.v new file mode 100644 index 00000000..415fbeb6 --- /dev/null +++ b/algo/mR.v @@ -0,0 +1,62 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. +From Trocq.Algo Extra Dependency "common_algo.elpi" as common. +From Trocq.Algo Extra Dependency "mR.elpi" as mR. +From Trocq.Algo Require Import mymap injection_lemmas. + +From elpi Require Import elpi. +From elpi.apps Require Import derive.param2 derive.isK. +From elpi.apps Require Import derive.bcongr (* for eq_f register *) + derive.eqK (*for bool_discr *) + derive.isK. (* for isK db required by discriminate *) +(* From elpi.apps Require Import map. *) + +From Trocq Require Import Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi Db derive.mR.db lp:{{ + % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. + pred ar-db i:term, i:term, o:term. + % [mR-db T D] links a type T to its corresponding map in R. + pred mR-db i:term, o:term. + + % [mR-done T] mean T was already derived + pred mR-done o:term. +}}. + +Elpi Command derive.mR. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate File discr. +Elpi Accumulate Db derive.isK.db. +Elpi Accumulate Db derive.injections.db. +Elpi Accumulate File common. +Elpi Accumulate Db derive.mR.db. +Elpi Accumulate File mR. +Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), + coq.gref->id (indt GR) Tname, + Prefix is Tname ^ "_", + derive.mR.main GR Prefix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.mR ". +}}. + + +Elpi Query lp:{{ + F = {{ fun (A : Type) (l : list A) => match l with nil => unit | cons a l => Prop end }}. + %coq.elaborate-skeleton F Ty FE ok, + coq.typecheck F Ty ok. + coq.say F. + %F = {{ fun b : bool => match b with true => unit | false => Prop end }}. + %std.findall (param {{ option }} {{ option }} T ) Rules, + %std.findall (param {{ list }} {{ list }} T ) Rules, + %std.findall (mymap-db {{ option nat }} {{ option nat }} C ) Rules, + %coq.typecheck T Ty _, + coq.say Rules. + +}}. diff --git a/algo/mymap.elpi b/algo/mymap.elpi new file mode 100644 index 00000000..bc32c541 --- /dev/null +++ b/algo/mymap.elpi @@ -0,0 +1,223 @@ +/* map over a container */ +/* license: GNU Lesser General Public License Version 2.1 or later */ +/* ------------------------------------------------------------------------- */ + +shorten std.{split-at, length, rev, append, do!, drop-last, assert!}. + +mymap-db (app[global (indt GR1)|A1]) (app[global (indt GR2)|A2]) R :- + coq.env.indt GR1 _ Lno1 _ _ _ _, + coq.env.indt GR2 _ Lno2 _ _ _ _, + {length A1} > Lno1, {length A2} > Lno2, + split-at Lno1 A1 Args1 Points1, + split-at Lno2 A2 Args2 Points2, + Points1 = Points2, !, + mymap-db {coq.mk-app (global (indt GR1)) Args1} {coq.mk-app (global (indt GR2)) Args2} F, + coq.mk-app F Points1 R. + +namespace derive.mymap { + +% Building the body %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +pred bo-idx + i:term, % inductive arity (input) + i:term, % inductive type (input) applied to params & idx handled so far + i:term, % inductive type (output) applied to params & idx handled so far + i:int, % current index no + o:int, % Recno + i:list term, % rev list of (output) parameters + o:term, % body + o:term. % type + +bo-idx (prod _ S1 T1) Ity1 Ity2 N M Ps (fun `x` S1 Bo) (prod `x` S1 Ty) :- !, + pi x\ sigma Ity1x Ity2x\ + coq.mk-app Ity1 [x] Ity1x, + coq.mk-app Ity2 [x] Ity2x, + N1 is N + 1, + decl x `x` S1 => bo-idx (T1 x) Ity1x Ity2x N1 M Ps (Bo x) (Ty x). + +bo-idx (sort _) Ity1 Ity2 N N Ps (fun `x` Ity1 Bo) (prod `_` Ity1 _\ Ity2) :- !, + @pi-decl `x` Ity1 x\ + coq.build-match x Ity1 (bo-idx-rty Ps Ity2) (bo-k-args Ps) (Bo x). + +bo-idx X Ity1 Ity2 N M Ps R1 R2 :- whd1 X X1, !, + bo-idx X1 Ity1 Ity2 N M Ps R1 R2. + +pred bo-idx-rty i:list term, i:term, i:term, i:list term, i:list term, o:term. +bo-idx-rty Ps ItyArgs _ Vs _ R :- + rev Vs [_|IdxsRev], + rev IdxsRev Idxs, + coq.safe-dest-app ItyArgs HD _, + coq.mk-app HD {append {rev Ps} Idxs} R. + +pred bo-k-args i:list term, i:term, i:term, i:list term, i:list term, o:term. +bo-k-args ParamsRev K _ Args Tys R :- + rev ParamsRev Params, + coq.safe-dest-app K (global (indc GR)) _, + coq.env.typeof (indc GR) T, coq.subst-prod Params T KT, + (bo-k-args.aux {coq.mk-app (global (indc GR)) Params} Args Tys KT R), + !. % the first combination that typechecks + +% pred map.aux i:term, o:term. +% map.aux (prod T N B) (prod T N B). +% map.aux FRel R :- +% coq.mk-app {{ map }} [FRel] R. + +bo-k-args.aux R [] [] _ R :- coq.typecheck R _ ok. +bo-k-args.aux K [A|As] [T|Ts] (prod _ S Ty) R :- + mymap-db T S FRel, + % map.aux FRel F, + coq.mk-app {{ map }} [FRel] 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 :- + mymap-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] [_|Ts] (prod _ _ Ty) R :- !, + bo-k-args.aux {coq.mk-app K [A]} As Ts (Ty A) R. +bo-k-args.aux K As Ts X R :- whd1 X X1, !, + bo-k-args.aux K As Ts X1 R. + + +% Take in input a mapping function for each parameter +% and then do the fixpoint + +pred bo-params + i:int, % current parameter + i:int, % number of parameters + i:term, % inductive type (input) applied to parameters handled so far + i:term, % inductive type (output) applied to parameters handled so far + i:term, % inductive arity (input) + i:term, % inductive arity (output) + i:list term, % output parameters so far + o:term. % map function + +bo-params Lno Lno Ity1 Ity2 A1 _ Ps (fix `f` Recno Fty Bo) :- + coq.safe-dest-app Ity1 (global (indt I)) _, coq.env.recursive? I, !, + @pi-decl `rec` Fty f\ + mymap-db Ity1 Ity2 f => + bo-idx A1 Ity1 Ity2 0 Recno Ps (Bo f) Fty. +bo-params Lno Lno Ity1 Ity2 A1 _ Ps Bo :- + bo-idx A1 Ity1 Ity2 0 _ Ps Bo _. + +bo-params N Lno Ity1 Ity2 (prod A Sty1 Rty1) (prod _ Sty2 Rty2) Ps R :- + 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 \ mk-map-ty a Sty1 b Sty2 (FAB a b) f _ (Clause a b f)), + R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Af (FAB a b) f\ Bo a b f), + pi a b f\ sigma Ity1A Ity2A \ + coq.mk-app Ity1 [a] Ity1A, + coq.mk-app Ity2 [b] Ity2A, + Clause a b f => + decl a A1 Sty1 => + decl b A2 Sty2 => + decl f Af (FAB a b) => + bo-params N1 Lno Ity1A Ity2A (Rty1 a) (Rty2 b) [b|Ps] (Bo a b f). + +bo-params N Lno Ity1 Ity2 T OT Ps R :- + whd1 T T1, whd1 OT OT1, !, + bo-params N Lno Ity1 Ity2 T1 OT1 Ps R. + +bo-params _ _ _ _ _ _ _ _ :- + stop "derive.map: Indexed data types not supported". + +pred map-pi i:any, o:list prop. +map-pi (x\ []) []. +map-pi (x\ [X x| XS x]) [pi x\ X x | YS] :- map-pi XS YS. + +pred mk-map-ty + i:term, % input variable + i:term, % and its type + i:term, % output variable + i:term, % an its type + o:term, % type of a mapping function from input to output + i:term, % map function (having the type above) + o:int, % arity of the predicate + o:list prop. % mymap-db clause for map function +mk-map-ty A (prod _ SA T1) B (prod _ SB T2) (prod `x` SA x\ R x) F N C1 :- + mymap-db SA SB Fa, !, + (pi x\ sigma Ax Fx BFx \ + coq.mk-app A [x] Ax, coq.mk-app Fa [x] Fx, coq.mk-app B [Fx] BFx, + mk-map-ty Ax (T1 x) BFx (T2 BFx) (R x) {coq.mk-app F [x]} M (C x), + N is M + 1), + map-pi C C1. +mk-map-ty A (prod _ S1 T1) B (prod _ _ T2) (prod `x` S1 x\ R x) F N C1 :- + (pi x\ sigma Ax Bx \ coq.mk-app A [x] Ax, coq.mk-app B [x] Bx, + mk-map-ty Ax (T1 x) Bx (T2 x) (R x) {coq.mk-app F [x]} M (C x), + N is M + 1), + map-pi C C1. +% mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ {{ Param10.Rel lp:A lp:B }} (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- +mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ (prod `x` A _\ B) (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- + drop-last 1 XS LA, + drop-last 1 YS LB, + drop-last 1 GS LF, + coq.mk-app X LA PLA, + coq.mk-app Y LB PLB, + coq.mk-app G LF PLF. +mk-map-ty A _ B _ {{ Param10.Rel lp:A lp:B }} F 0 [mymap-db A B F]. +% mk-map-ty A _ B _ (prod `x` A _\ B) F 0 [mymap-db A B F]. + +% Build a clause %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +pred mk-clause + i:int, % current parameter + i:int, % number of parameters + i:term, % inductive type (input) + i:term, % inductive type (output) + i:term, % arity of the inductive + i:list prop, % premises of the clause + i:term, % map function + o:prop. % clause for mymap-db +mk-clause N N Ity1 Ity2 _ Todo Map (mymap-db Ity1 Ity2 Map :- Todo). +mk-clause N Lno Ity1 Ity2 (prod _ _ T) Todo Map (pi x y f\ C x y f) :- !, + N1 is N + 1, + pi x y f\ sigma Ity1x Ity2y Mapf\ + coq.mk-app Ity1 [x] Ity1x, + coq.mk-app Ity2 [y] Ity2y, + coq.mk-app Map [x,y,f] Mapf, + mk-clause N1 Lno Ity1x Ity2y (T x) [mymap-db x y f|Todo] Mapf (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. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +pred main i:inductive, i:string, o:list prop. +main GR Prefix C :- do! [ + T = global (indt GR), + coq.env.indt GR _Ind Lno Luno Arity _ _, + assert! (Lno = Luno) "derive.map: Non-uniform parameters not supported", + + % generate map and add to the env + (bo-params 0 Lno T T Arity Arity [] RSkel), + std.assert-ok! (coq.elaborate-skeleton RSkel Rty R) "derive.mymap generates illtyped term", + Name is Prefix ^ "mymap", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName R Rty @transparent! Funct, + + % generate clause and add to the db + mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause, + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-def (global (indt GR)) (global (const Funct)))), + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ Clause), + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-done GR)), + C = [mymap-done GR,Clause, (mymap-def (global (indt GR)) (global (const Funct)))] +]. + +} +/* +namespace derive.mymap { + + pred main i:inductive, i:string, o:list prop. + main GR Prefix Clauses :- std.do! [ + %... % synthesize Body and Type + Name is Prefix ^ "myconcept", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName Body Type _ C, + Clauses = [mymap-done GR, mymap-db GR (const C)], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ x) + ), + ]. + +} +*/ \ No newline at end of file diff --git a/algo/mymap.v b/algo/mymap.v new file mode 100644 index 00000000..99aa99c3 --- /dev/null +++ b/algo/mymap.v @@ -0,0 +1,55 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From Trocq.Algo Extra Dependency "mymap.elpi" as mymap. + +From elpi Require Import elpi. +From elpi.apps Require Import derive. +From Trocq Require Import Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi Db derive.mymap.db lp:{{ + % [mymap-def I C] brings the constant defined for mapping inductive I. + pred mymap-def i:term, o:term. + + % [mymap T1 T2 D] for T1 and T2 brings a map D from T1 to T2. + pred mymap-db i:term, i:term, o:term. + + % [mymap-done T] mean T was already derived + pred mymap-done o:inductive. +}}. + +Elpi Command derive.mymap. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate File mymap. +Elpi Accumulate lp:{{ + main [str I] :- !, + coq.locate I (indt GR), + coq.gref->id (indt GR) Tname, + Prefix is Tname ^ "_", + %derive.mymap.main GR Prefix _. + + % derive.mymap.mk-map-ty A _ B _ {{ Param10.Rel lp:A lp:B }} F 0 [mymap-db A B F] => + % (derive.mymap.bo-k-args.aux K [A|As] [T|Ts] (prod _ S Ty) R :- + % mymap-db T S FRel, + % coq.mk-app {{ map }} [FRel] F, + % coq.mk-app F [A] FA, + % bo-k-args.aux {coq.mk-app K [FA]} As Ts (Ty FA) R) => + + derive.mymap.main GR Prefix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.mymap ". +}}. + + +Elpi Query lp:{{ + coq.locate "option" (indt Option), + std.findall (mymap-def (global (indt Option)) _) Rules. % empty + %std.findall (mymap-db {{ option nat }} {{ option nat }} _) Rules. % non empty + %std.findall (mymap-db {{ nat }} {{ nat }} _) Rules. % non empty + std.findall (mymap-db {{ nat }} B C) Rules. % empty + std.findall (mymap-db A B C) Rules. % empty + std.findall (mymap-done _) Rules. % empty + +}}. diff --git a/detailed/DetailedRm.v b/detailed/DetailedRm.v new file mode 100644 index 00000000..3b2b3438 --- /dev/null +++ b/detailed/DetailedRm.v @@ -0,0 +1,207 @@ +From Coq Require Import ssreflect. +From elpi.apps.derive Require Import derive derive.param2. +From Trocq Require Import mymap. + (* injection_lemmas. *) +Require Import HoTT_additions Hierarchy. +Unset Uniform Inductive Parameters. +(* Unset Universe Minimization ToSet. *) + +Inductive False :=. +Elpi derive.param2 False. +Elpi derive.mymap False. +Definition false_Rm : forall (f1 f2 : False), False_R f1 f2 -> False_mymap f1 = f2. +Proof. +(* refine (fun f1 f2 fR=> False_R_ind (fun (f1 f2 : False) => (False_R f1 f2) -> False_mymap f1 = f2) f1 f2 fR fR). *) +refine (fun f1 f2 fR=> False_R_ind (fun (f1 f2 : False) => False_mymap f1 = f2) f1 f2 fR). +Defined. + +Definition Unit := unit. + +Elpi derive.param2 unit. +Definition UnitR := unit_R. +(* Inductive UnitR : Unit -> Unit -> Type := + | tt_R : UnitR tt tt. *) + +Elpi derive.mymap unit. +Definition unit_map : unit -> unit := unit_mymap. + +Definition Pred := fun (s1 s2: unit) (RR : unit_R s1 s2)=> unit_map s1 = s2 . +Definition unit_Rm : forall (u1 u2 : Unit), UnitR u1 u2-> unit_map u1 = u2 . +Proof. +refine (fun u1 u2 uR=> unit_R_ind Pred eq_refl u1 u2 uR). +Defined. + +Definition Bool := bool. +Elpi derive.param2 bool. + +Definition BoolR := bool_R. +(* Inductive BoolR : Bool -> Bool -> Type := +| true_R : BoolR true true +| false_R : BoolR false false. *) + +Elpi derive.mymap bool. +Definition bool_map : Bool -> Bool := bool_mymap. + +Definition Pred_bool := (fun (s1 s2: bool) (RR : bool_R s1 s2)=> bool_map s1 = s2). +Definition bool_Rm : forall (u1 u2 : Bool), BoolR u1 u2 -> bool_map u1 = u2. +Proof. +refine (fun b1 b2 bR=> bool_R_ind Pred_bool _ _ b1 b2 bR). ++ exact (@eq_refl Bool true). ++ exact (@eq_refl Bool false). +Defined. + +Inductive Wrap : Type := +| KWrap1 : unit -> Wrap. + +Elpi derive.param2 Wrap. +Definition WrapR := Wrap_R. +Elpi derive.mymap Wrap. + +Definition wrap_map := Wrap_mymap. +About concat. +Notation Pred_wrap := (fun (w1 w2 : Wrap ) (wR : Wrap_R w1 w2) => wrap_map w1 = w2) (only parsing). +Definition wrap_Rm : forall w1 w2, WrapR w1 w2 -> wrap_map w1 = w2. +Proof. +refine (fun w1 w2 wR => Wrap_R_ind Pred_wrap _ w1 w2 wR). ++ set eta1 := (fun R=> KWrap1 R). + refine (fun u1 u2 uR=> _). + set e1 := @ap unit Wrap eta1 (unit_map u1) u2 (unit_Rm u1 u2 uR). + set end_ := @eq_refl Wrap (KWrap1 u2). + exact (@eq_trans Wrap _ _ _ e1 end_). +Defined. + +Inductive FArgsK : Type := +| C1 : unit -> bool -> Wrap -> bool -> FArgsK. + +Elpi derive.param2 FArgsK. +Elpi derive.mymap FArgsK. +Notation Pred_fargsk := (fun (f1 f2 : FArgsK)(fR : FArgsK_R f1 f2)=> FArgsK_mymap f1 = f2) (only parsing). +Definition Rm_fargsk : forall f1 f2 (fR : FArgsK_R f1 f2), FArgsK_mymap f1 = f2. +Proof. +refine (fun f1 f2 fR=> FArgsK_R_ind Pred_fargsk _ f1 f2 fR). +refine (fun u1 u2 uR=> _). +refine (fun b1 b2 bR=> _). +refine (fun w1 w2 wR=> _). +refine (fun b1' b2' bR'=> _). +set goal := FArgsK_mymap (C1 u1 b1 w1 b1') = C1 u2 b2 w2 b2'. +simpl in goal. +(* set start := @eq_refl FArgsK (FArgsK_mymap (C1 u1 b1 w1 b1')). *) +(* set start := @eq_refl FArgsK (C1 (unit_map u1) (bool_mymap b1) (Wrap_mymap w1) (bool_mymap b1')). *) +set eta1 := (fun R:unit => C1 R (bool_mymap b1) (Wrap_mymap w1) (bool_mymap b1')). +set eta2 := (fun R2:bool => C1 u2 R2 (Wrap_mymap w1) (bool_mymap b1')). +set eta3 := (fun R3:Wrap => C1 u2 b2 R3 (bool_mymap b1')). +set eta4 := (fun R4:bool => C1 u2 b2 w2 R4). +set e1 := @ap unit FArgsK eta1 (unit_map u1) u2 (unit_Rm u1 u2 uR). +set e2 := @ap bool FArgsK eta2 (bool_map b1) b2 (bool_Rm b1 b2 bR). +set e3 := @ap Wrap FArgsK eta3 (wrap_map w1) w2 (wrap_Rm w1 w2 wR). +set e4 := @ap bool FArgsK eta4 (bool_map b1') b2' (bool_Rm b1' b2' bR'). +set end_ := @eq_refl FArgsK (C1 u2 b2 w2 b2'). +exact (e1 @ e2 @ e3 @ e4 @ end_). +Defined. + +Definition Nat := nat. +Elpi derive.param2 nat. + +Definition NatR := nat_R. + +Elpi derive.mymap nat. +Definition nat_map := nat_mymap. +Notation Pred_nat := (fun (n1 n2: nat) (nR : nat_R n1 n2) => nat_map n1 = n2) (only parsing). +Definition nat_Rm : forall n1 n2, NatR n1 n2 -> nat_map n1 = n2. +Proof. +fix F 3. +refine (fun n1 n2 nR=> nat_R_ind Pred_nat _ _ n1 n2 nR). ++ exact (@eq_refl nat O). ++ refine (fun n1' n2' nR' e=> _). + set eta1 := fun R => S R. + have E1 := @ap nat nat S (nat_map n1') n2' (F n1' n2' nR'). + have end_ := @eq_refl nat (S n2'). + exact (E1 @ end_). + Defined. + +Inductive Box (A : Type) : Type := B : A -> Box A. +Elpi derive.param2 Box. +Elpi derive.mymap Box. +Print Box_R. + + +Print Box_R_ind. +(* The term "__R" has type "A_R _1 _2" while it is expected to have type + "@Hierarchy.rel A1 A2 (forget_10_00 A1 A2 (forget_2b0_10 A1 A2 A_R)) _1 _2". *) +Notation Pred_Box := (fun A1 A2 (AR : Param2b0.Rel A1 A2) => (fun (b1 : Box A1) (b2 : Box A2) (bR : Box_R A1 A2 AR b1 b2)=> Box_mymap A1 A2 AR b1 = b2)) (only parsing). + +(* Goal forall A1 A2 (AR: Param2b0.Rel A1 A2) b1 b2, Box_R A1 A2 AR b1 b2 -> Box_mymap A1 A2 AR b1 = b2. +simpl. *) + +Definition box_Rm : +(* forall (A1 A2 : Type) (AR : Param2b0.Rel A1 A2) (b1 : Box A1) (b2 : Box A2) +(_ : Box_R A1 A2 (@rel A1 A2 (forget_10_00 A1 A2 (forget_2b0_10 A1 A2 AR))) b1 b2), +@eq (Box A2) (Box_mymap A1 A2 (forget_2b0_10 A1 A2 AR) b1) b2. *) +forall A1 A2 (AR: Param2b0.Rel A1 A2) b1 b2, Box_R A1 A2 AR b1 b2 -> Box_mymap A1 A2 AR b1 = b2. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun b1 b2 bR=> Box_R_ind A1 A2 AR (Pred_Box A1 A2 AR) _ b1 b2 bR). +refine (fun a1 a2 aR=> _). + set eta1 := fun R => @B A2 R. + have E1 := @ap A2 (@Box A2) eta1 (map AR a1) a2 (R_in_map AR a1 a2 aR). + have end_ := @eq_refl (@Box A2) (@B A2 a2). + exact: (E1 @ end_). +Defined. + +Definition Option (A : Type) : Type := option A. + +Elpi derive.param2 option. +Definition OptionR := option_R. +(* Inductive OptionR (A1 A2 : Type) (AR : A1 -> A2 -> Type) : option A1 -> option A2 -> Type := +| SomeR : forall a1 a2 (aR : AR a1 a2), OptionR A1 A2 AR (Some a1) (Some a2) +| NoneR : OptionR A1 A2 AR None None. *) + +Elpi derive.mymap option. +Definition option_map := option_mymap. +(* Definition option_map (A1 A2 : Type) (AR : Param10.Rel A1 A2) : option A1 -> option A2 := +fun oa => + match oa with + | Some a => Some (map AR a) + | None => None + end. *) + +(* Elpi derive.injections option. *) +(* Print option_injections11. *) +Definition Pred_option := (fun A1 A2 (AR : Param2b0.Rel A1 A2)=> (fun (oa1 : option A1) (oa2 : option A2) (oaR : option_R A1 A2 AR oa1 oa2) => option_map A1 A2 AR oa1 = oa2)). +Definition option_Rm : forall (A1 A2 : Type) (AR : Param2b0.Rel A1 A2) oa1 oa2, OptionR A1 A2 AR oa1 oa2 -> option_map A1 A2 AR oa1 = oa2. +Proof. +refine (fun A1 A2 AR => _). +refine (fun oa1 oa2 oaR => option_R_ind A1 A2 AR (Pred_option A1 A2 AR) _ _ oa1 oa2 oaR). ++ refine (fun a1 a2 aR=> _). + set eta1 := fun R => @Some A2 R. + have E1 := @ap A2 (@option A2) eta1 (map AR a1) a2 (R_in_map AR a1 a2 aR). + have end_ := @eq_refl (@option A2) (@Some A2 a2). + exact (E1 @ end_). ++ exact: @eq_refl (@option A2) (@None A2). +Defined. + +Definition List (A : Type) := list A. +Elpi derive.param2 list. + +Definition ListR := list_R. +Elpi derive.mymap list. + +Definition list_map := list_mymap. +Definition Pred_list := fun A1 A2 (AR : Param2b0.Rel A1 A2)=> (fun (l1: list A1) (l2: list A2) (lR : list_R A1 A2 AR l1 l2)=> list_map A1 A2 AR l1 = l2). + +Definition list_Rm : forall (A1 A2 : Type) (AR : Param2b0.Rel A1 A2) l1 l2, ListR A1 A2 AR l1 l2 -> list_map A1 A2 AR l1 = l2. +Proof. +refine (fun A1 A2 AR=> _). +fix F 3. +refine (fun l1 l2 lR => list_R_ind A1 A2 AR (Pred_list A1 A2 AR) _ _ l1 l2 lR). ++ exact: (@eq_refl (@list A2) (@nil A2)). ++ refine (fun a1 a2 aR => _). + refine (fun l1' l2' lR' e => _). + set eta1 := fun R => @cons A2 R (list_map A1 A2 AR l1'). + set eta2 := fun R => @cons A2 a2 R. + have E1 := @ap A2 (@list A2) eta1 (map AR a1) a2 (R_in_map AR a1 a2 aR). + have E2 := @ap (@list A2) (@list A2) eta2 (list_map A1 A2 AR l1') l2' (F l1' l2' lR'). + have end_ := (@eq_refl (@list A2) (@cons A2 a2 l2')). + exact (E1 @ E2 @ end_). +Defined. + diff --git a/detailed/Detailed_injijK.v b/detailed/Detailed_injijK.v new file mode 100644 index 00000000..00410ed0 --- /dev/null +++ b/detailed/Detailed_injijK.v @@ -0,0 +1,7 @@ +From Trocq Require Import mR Rm. + +Elpi Command test. +Print Wrap_mR. +Print Wrap_Rm. + +Goal forall (w1 w2 : Wrap) (wR : Wrap_R w1 w2), Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. \ No newline at end of file diff --git a/detailed/DetailedmR.v b/detailed/DetailedmR.v new file mode 100644 index 00000000..f4a887f2 --- /dev/null +++ b/detailed/DetailedmR.v @@ -0,0 +1,256 @@ +From Coq Require Import ssreflect. +From elpi.apps.derive Require Import derive derive.param2. +From Trocq Require Import mymap injection_lemmas. +Require Import HoTT_additions Hierarchy. +Unset Uniform Inductive Parameters. +(* Unset Universe Polymorphism. *) +Unset Universe Minimization ToSet. + +Definition Unit := unit. + +Elpi derive.param2 unit. +Definition UnitR := unit_R. +(* Inductive UnitR : Unit -> Unit -> Type := + | tt_R : UnitR tt tt. *) + +Elpi derive.mymap unit. +Definition unit_map : unit -> unit := unit_mymap. +Definition Unit_mR : forall (u1 u2 : Unit), unit_map u1 = u2 -> UnitR u1 u2. +Proof. +refine (fun u1 => match u1 as u return + forall u2 : Unit, unit_map u = u2 -> UnitR u u2 + with + | tt => _ end + ). +refine (fun u2 => match u2 as u return + unit_map tt = u -> UnitR tt u + with + | tt => _ end). +refine (fun e => tt_R). +Defined. + +Definition Bool := bool. +Elpi derive.param2 bool. + +Definition BoolR := bool_R. +(* Inductive BoolR : Bool -> Bool -> Type := +| true_R : BoolR true true +| false_R : BoolR false false. *) + +Elpi derive.mymap bool. +Definition bool_map : Bool -> Bool := bool_mymap. +Definition Bool_mR : forall (u1 u2 : Bool), bool_map u1 = u2 -> BoolR u1 u2. +Proof. +refine (fun u1 : Bool => match u1 as u return + forall u2 : Bool, bool_map u = u2 -> BoolR u u2 + with + | true => _ + | false => _ + end + ). ++ refine (fun u2 : Bool => match u2 as u return + bool_map true = u -> BoolR true u + with + | true => _ + | false => _ + end + ). + - (* true true *) + refine (fun e => true_R). + - (* true false *) intros e; discriminate e. ++ refine (fun u2 : Bool => match u2 as u return + bool_map false = u -> BoolR false u + with + | true => _ + | false => _ + end + ). + - (* false true *) intros e; discriminate e. + - (* false false *) refine (fun e => false_R). +Defined. + +Inductive Wrap : Type := +| KWrap1 : unit -> Wrap. + +Elpi derive.param2 Wrap. +Definition WrapR := Wrap_R. +Elpi derive.mymap Wrap. + +Definition wrap_map := Wrap_mymap. +Elpi derive.projK Wrap. +Elpi derive.injections Wrap. +Definition wrap_mR : forall w1 w2, wrap_map w1 = w2 -> WrapR w1 w2. +Proof. +refine (fun w1=> match w1 as w return + forall w2, wrap_map w = w2 -> WrapR w w2 + with + | KWrap1 u1 => _ end). +- refine (fun w2=> match w2 as w return + wrap_map (KWrap1 u1) = w -> WrapR (KWrap1 u1) w + with + | KWrap1 u2 => _ end). + refine (fun e => KWrap1_R u1 u2 (Unit_mR u1 u2 (Wrap_injections11 (unit_map u1) u2 e))). +Defined. + +Definition Nat := nat. +Elpi derive.param2 nat. +Definition NatR := nat_R. + +Elpi derive.mymap nat. +Definition nat_map := nat_mymap. +Elpi derive.injections nat. +Print nat_injections21. + +Definition nat_mR : forall n1 n2, nat_map n1 = n2 -> NatR n1 n2. +Proof. +fix F 1. +refine (fun n1 => match n1 as n return + forall n2, nat_map n = n2 -> NatR n n2 + with + | O => _ + | S n1' => _ end). ++ (* O *) + refine (fun n2 => match n2 as n return + nat_map 0 = n -> NatR 0 n + with + | O => _ + | S n2' => _ end). + - (* O O *) + refine (fun e => O_R). + - (* O S n2' *) intros e; discriminate e. ++ (* S n' *) + refine (fun n2 => match n2 as n return + nat_map (S n1') = n -> NatR (S n1') n + with + | O => _ + | S n2' => _ end). + - (* S n1' O *) intros e; discriminate e. + - (* S n1' S n2' *) + refine (fun e => S_R n1' n2' (F n1' n2' (nat_injections21 (nat_map n1') n2' e))). +Defined. + +Inductive Box (A : Type) : Type := B : A -> Box A. +Elpi derive.param2 Box. +Elpi derive.mymap Box. +Elpi derive.projK Box. +Elpi derive.injections Box. +Elpi derive.isK Box. +Check @Trocq.Hierarchy.map. +Definition box_mR : forall A1 A2 (AR: Param2a0.Rel A1 A2) b1 b2, Box_mymap A1 A2 AR b1 = b2 -> Box_R A1 A2 AR b1 b2. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun b1 b2=> _). +refine (match b1 as b0 return Box_mymap A1 A2 AR b0 = b2 -> Box_R A1 A2 AR b0 b2 + with B _ a1 => _ end). + Set Printing All. +refine (match b2 as b0 return Box_mymap A1 A2 AR (B A1 a1) = b0 -> Box_R A1 A2 AR (B A1 a1) b0 + with B _ a2 => _ end). +refine (fun e => _). +simpl in e. +exact (B_R A1 A2 AR a1 a2 ((map_in_R AR) a1 a2 (Box_injections11 A2 ((map AR) a1) a2 e))). +Defined. + +Definition Option (A : Type) : Type := option A. + +Elpi derive.param2 option. +Definition OptionR := option_R. +(* Inductive OptionR (A1 A2 : Type) (AR : A1 -> A2 -> Type) : option A1 -> option A2 -> Type := +| SomeR : forall a1 a2 (aR : AR a1 a2), OptionR A1 A2 AR (Some a1) (Some a2) +| NoneR : OptionR A1 A2 AR None None. *) + +Elpi derive.mymap option. +Definition option_map := option_mymap. +(* Definition option_map (A1 A2 : Type) (AR : Param10.Rel A1 A2) : option A1 -> option A2 := +fun oa => + match oa with + | Some a => Some (map AR a) + | None => None + end. *) + +(* Elpi derive.injections option. *) +(* Print option_injections11. *) + +Definition option_mR : forall (A1 A2 : Type) (AR : Param2a0.Rel A1 A2) oa1 oa2, option_map A1 A2 AR oa1 = oa2 -> OptionR A1 A2 AR oa1 oa2. +Proof. +refine (fun A1 A2 AR => _). +refine (fun oa1 => match oa1 as oa +return forall oa2, option_map A1 A2 AR oa = oa2 -> OptionR A1 A2 AR oa oa2 +with + | Some a1 => _ + | None => _ end). ++ (* Some *) + refine (fun oa2 => match oa2 as oa + return option_map A1 A2 AR (Some a1) = oa -> OptionR A1 A2 AR (Some a1) oa + with + | Some a2 => _ + | None => _ end). + - (* Some Some *) + refine (fun e => Some_R A1 A2 AR a1 a2 (map_in_R AR a1 a2 (option_injections11 A2 (map AR a1) a2 e))). + - (* Some None *) intros e; discriminate e. ++ (* None *) + refine (fun oa2 => match oa2 as oa + return option_map A1 A2 AR None = oa -> OptionR A1 A2 AR None oa + with + | Some a2 => _ + | None => _ end). + - (* None Some *) intros e; discriminate e. + - refine (fun e => None_R A1 A2 AR). +Defined. + +Definition List (A : Type) := list A. +Elpi derive.param2 list. + +Definition ListR := list_R. +Elpi derive.mymap list. + +Definition list_map := list_mymap. + +Elpi derive.injections list. +Print list_injections21. + +Print cons_R. +Definition list_mR : forall (A1 A2 : Type) (AR : Param2a0.Rel A1 A2) l1 l2, list_map A1 A2 AR l1 = l2 -> ListR A1 A2 AR l1 l2. +Proof. +refine (fun A1 A2 AR=> _). +fix F 1. +refine (fun l1 => match l1 as l + return forall l2, list_map A1 A2 AR l = l2 + -> ListR A1 A2 AR l l2 + with + | nil => _ + | cons a1 l1' => _ end). ++ (* nil *) + refine (fun l2 => match l2 as l + return list_map A1 A2 AR nil = l -> ListR A1 A2 AR nil l + with + | nil => _ + | cons a2 l2' => _ end). + - (* nil nil *) + refine (fun e => nil_R A1 A2 AR). + - intros e; discriminate e. ++ (* cons *) + refine (fun l2 => match l2 as l + return list_map A1 A2 AR (cons a1 l1') = l -> ListR A1 A2 AR (cons a1 l1') l + with + | nil => _ + | cons a2 l2' => _ end). + - intros e; discriminate e. + - refine (fun e => cons_R A1 A2 AR + a1 a2 (map_in_R AR a1 a2 (list_injections21 A2 (map AR a1) a2 (list_map A1 A2 AR l1') l2' e)) + l1' l2' (F l1' l2' (list_injections22 A2 (map AR a1) a2 (list_map A1 A2 AR l1') l2' e))). +Defined. + +Inductive ParamWrap (A : Type) := +(* | PH : unit -> ParamWrap A *) +| SomeW : option A -> ParamWrap A. + +Elpi derive.param2 ParamWrap. +Definition ParamWrapR := ParamWrap_R. + +Fail Elpi derive.mymap ParamWrap. +Fail Elpi derive.map ParamWrap. + +(* Definition list_map := list_mymap. *) +Elpi derive.projK ParamWrap. +Elpi derive.injections ParamWrap. + diff --git a/generic/DetailedmR.v b/generic/DetailedmR.v index 542d5b47..f4a887f2 100644 --- a/generic/DetailedmR.v +++ b/generic/DetailedmR.v @@ -3,7 +3,7 @@ From elpi.apps.derive Require Import derive derive.param2. From Trocq Require Import mymap injection_lemmas. Require Import HoTT_additions Hierarchy. Unset Uniform Inductive Parameters. -Unset Universe Polymorphism. +(* Unset Universe Polymorphism. *) Unset Universe Minimization ToSet. Definition Unit := unit. @@ -129,6 +129,27 @@ refine (fun n1 => match n1 as n return refine (fun e => S_R n1' n2' (F n1' n2' (nat_injections21 (nat_map n1') n2' e))). Defined. +Inductive Box (A : Type) : Type := B : A -> Box A. +Elpi derive.param2 Box. +Elpi derive.mymap Box. +Elpi derive.projK Box. +Elpi derive.injections Box. +Elpi derive.isK Box. +Check @Trocq.Hierarchy.map. +Definition box_mR : forall A1 A2 (AR: Param2a0.Rel A1 A2) b1 b2, Box_mymap A1 A2 AR b1 = b2 -> Box_R A1 A2 AR b1 b2. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun b1 b2=> _). +refine (match b1 as b0 return Box_mymap A1 A2 AR b0 = b2 -> Box_R A1 A2 AR b0 b2 + with B _ a1 => _ end). + Set Printing All. +refine (match b2 as b0 return Box_mymap A1 A2 AR (B A1 a1) = b0 -> Box_R A1 A2 AR (B A1 a1) b0 + with B _ a2 => _ end). +refine (fun e => _). +simpl in e. +exact (B_R A1 A2 AR a1 a2 ((map_in_R AR) a1 a2 (Box_injections11 A2 ((map AR) a1) a2 e))). +Defined. + Definition Option (A : Type) : Type := option A. Elpi derive.param2 option. @@ -218,4 +239,18 @@ refine (fun l1 => match l1 as l a1 a2 (map_in_R AR a1 a2 (list_injections21 A2 (map AR a1) a2 (list_map A1 A2 AR l1') l2' e)) l1' l2' (F l1' l2' (list_injections22 A2 (map AR a1) a2 (list_map A1 A2 AR l1') l2' e))). Defined. - \ No newline at end of file + +Inductive ParamWrap (A : Type) := +(* | PH : unit -> ParamWrap A *) +| SomeW : option A -> ParamWrap A. + +Elpi derive.param2 ParamWrap. +Definition ParamWrapR := ParamWrap_R. + +Fail Elpi derive.mymap ParamWrap. +Fail Elpi derive.map ParamWrap. + +(* Definition list_map := list_mymap. *) +Elpi derive.projK ParamWrap. +Elpi derive.injections ParamWrap. + diff --git a/generic/Rm.v b/generic/Rm.v index d1b47a4b..8a7b58d0 100644 --- a/generic/Rm.v +++ b/generic/Rm.v @@ -1,35 +1,15 @@ -From Coq Require Import ssreflect. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq Extra Dependency "Rm.elpi" as Rm. -From Trocq Extra Dependency "common_algo.elpi" as common. +From Trocq.Algo Extra Dependency "Rm.elpi" as Rm. +From Trocq.Algo Extra Dependency "common_algo.elpi" as common. From elpi Require Import elpi. From elpi.apps Require Import derive.param2. From elpi.apps Require Import derive.bcongr. (* for eq_f register *) -From Trocq Require Import mymap. +From Trocq.Algo Require Import mymap. From elpi.apps Require Import derive.induction. From Trocq Require Import HoTT_additions Hierarchy. Unset Uniform Inductive Parameters. -Inductive False :=. -Elpi derive.param2 False. - -From elpi.apps Require Import derive.param1 derive.param1_functor param1_trivial. -From Coq Require Import ssreflect ssrfun ssrbool. - -Elpi derive.param1 False. -Elpi derive.param1 False_R. - -Elpi derive.induction False_R. -Elpi derive.param1.trivial is_False. -(* Elpi derive.param1.trivial is_False_R. *) - -(* Elpi derive.param1 unit. -Elpi derive.param2 unit. -Elpi derive.param1 unit_R. -Elpi derive.induction unit_R. -Print unit_R_induction. *) - Elpi Db derive.Rm.db lp:{{ % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. pred ar-db i:term, i:term, o:term. @@ -41,9 +21,6 @@ Elpi Db derive.Rm.db lp:{{ pred rm-done o:term. }}. -(* Definition eq_trans_impl {A : Type} {x y z : A} : x = y -> y = z -> x = z. -by apply eq_trans. Defined. *) - Elpi Command derive.Rm. Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. @@ -63,11 +40,6 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.Rm ". }}. -(* Inductive False : Prop :=. -Elpi derive.param2 False. -Elpi derive.mymap False. -Elpi derive.Rm False. -Print False_Rm. *) Elpi derive.param2 unit. Elpi derive.mymap unit. diff --git a/generic/common_algo.elpi b/generic/common_algo.elpi index d9200b44..1e63b9e9 100644 --- a/generic/common_algo.elpi +++ b/generic/common_algo.elpi @@ -8,6 +8,15 @@ rel-mode tt {{ Param2b0.Rel }}. pred swap i:term, i:term, i:bool, o:term, o:term. swap A B tt B A. swap A B ff A B. + +% Reached a sort, return map L = R -> IR. +pred mk-return i:term, i:term, i:term, i:bool, i:term, o:term. +mk-return ML MR Rel Swap ITyTy2 R :- + Map = {{ @eq lp:ITyTy2 lp:ML lp:MR }}, + swap Map Rel Swap First Second, + R = prod `_` First _\ Second. + + % The number of Type parameters in T % Type of inductive T, % Type of bin parametricity translation TR, @@ -17,27 +26,25 @@ swap A B ff A B. % Returns the type of map in R for T % X is the first inductive, Y is the second inductive. pred mk-mR-type i:int, i:term, i:term, i:term, i:term, i:bool, o:term. -% Reached a sort, return map L = R -> IR. -mk-mR-type 0 (sort _) ML MR Rel Swap R :- - Map = {{ lp:ML = lp:MR }}, - swap Map Rel Swap First Second, - R = prod `_` First _\ Second. % Introducing X and Y. % The RHS of the equality is Y. -mk-mR-type 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (Bo x y)) ML _ Rel Swap +mk-mR-type 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- - pi x y\ + @pi-decl IN1 ITyTy x\ + @pi-decl IN2 ITyTy2 y\ sigma NewML NewMR NewRel\ coq.mk-app ML [x] NewML, NewMR = y, coq.mk-app Rel [x,y] NewRel, - mk-mR-type 0 (Bo x y) NewML NewMR NewRel Swap (R x y). + mk-return NewML NewMR NewRel Swap ITyTy2 (R x y). + % mk-mR-type 0 (Bo x y) NewML NewMR NewRel Swap (R x y). % Process two type parameters + 1 relation at a time. % Apply these parameters to the LHS of the equation. mk-mR-type N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel Swap (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ lp:AR lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- M is N - 1, - rel-mode Swap AR, + rel-mode Swap ARSkel, + coq.elaborate-skeleton ARSkel _ AR ok, pi a1 a2 ar\ sigma NewML NewMR NewRel\ coq.mk-app ML [a1, a2, ar] NewML, diff --git a/generic/injection_lemmas.elpi b/generic/injection_lemmas.elpi index ffe9f268..a96569d8 100644 --- a/generic/injection_lemmas.elpi +++ b/generic/injection_lemmas.elpi @@ -94,7 +94,7 @@ build-type-K-injector _ _ _ _ _ _ [] [] :- !. build-type-K-injector TyParamNo J GR Kn ArgNo KTy [PJ|PJs] [Eq|RS] :- std.do! [ Jn is J + 1, duplicate-arguments TyParamNo ArgNo PJ S, - std.spy (craft-eq TyParamNo ArgNo J ArgNo S (global (indt GR)) (global (indc Kn)) (global (indc Kn)) {{tt}} {{tt}} {{tt}} Eq), + (craft-eq TyParamNo ArgNo J ArgNo S (global (indt GR)) (global (indc Kn)) (global (indc Kn)) {{tt}} {{tt}} {{tt}} Eq), coq.typecheck Eq _ ok, build-type-K-injector TyParamNo Jn GR Kn ArgNo KTy PJs RS]. @@ -148,7 +148,7 @@ pred implement-K-injectors i:int, i:int, i:int, i:list term, o:list term. implement-K-injectors _ _ _ [] []. implement-K-injectors TyParam J ArgNo [InjTy | InjTys] [R | RS] :- Jn is J + 1, - std.spy (implement-K-injector-J TyParam J ArgNo TyParam InjTy R), + (implement-K-injector-J TyParam J ArgNo TyParam InjTy R), coq.typecheck R InjTy ok, implement-K-injectors TyParam Jn ArgNo InjTys RS. diff --git a/generic/injection_lemmas.v b/generic/injection_lemmas.v index b4cbc8c4..d8656292 100644 --- a/generic/injection_lemmas.v +++ b/generic/injection_lemmas.v @@ -1,10 +1,10 @@ From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq Extra Dependency "injection_lemmas.elpi" as injections. +From Trocq.Algo Extra Dependency "injection_lemmas.elpi" as injections. From elpi Require Import elpi. -From elpi.apps Require Import derive.legacy. +From elpi.apps Require Import derive.bcongr. (* for eq_f register *) From elpi.apps Require Import projK. Unset Uniform Inductive Parameters. Elpi Db derive.injections.db lp:{{ @@ -93,13 +93,9 @@ Print projcons2. Elpi derive.injections list. Print list_injections21. Print list_injections22. + Elpi Query lp:{{ std.findall (injections-db _ _ _) Rules. std.findall (injections-done _) Rules. std.findall (projK-db _ _ _) Rules. }}. -Goal (forall (A : Type) (_1 _2 : A) (H1 H2 : list A), -(_1 :: H1)%list = (_2 :: H2)%list -> H1 = H2). -Proof. -exact list_injections22. -Qed. diff --git a/generic/mR.elpi b/generic/mR.elpi index 883a4610..02488c95 100644 --- a/generic/mR.elpi +++ b/generic/mR.elpi @@ -52,7 +52,7 @@ build-mRA ATy1 ATy2 Ind R :- coq.typecheck Ind IndTy _, mR-db ITy MR, % TODO: change following line to implement non uniform parameters + definition of the fix. - if (ATy = IndTy) + if (ATy1 = IndTy) (R = MR) (build-mRA-ty-args ArgsTy1 ArgsTy2 MR R). @@ -137,7 +137,8 @@ implement-mR 0 TyParamNo (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)) (fun I1 @pi-decl I1 I1Ty i1\ @pi-decl I2 I2Ty i2\ coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R i1 i2). -implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) ar\ (Bo a1 a2 ar)) (fun A1 A1Ty a1\ fun A2 A2Ty a2\ fun AR (ARTy a1 a2) ar\ (R a1 a2 ar)) :- +implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) ar\ (Bo a1 a2 ar)) + (fun A1 A1Ty a1\ fun A2 A2Ty a2\ fun AR (ARTy a1 a2) ar\ (R a1 a2 ar)) :- M is N - 1, @pi-decl A1 A1Ty a1\ @pi-decl A2 A2Ty a2\ @@ -148,8 +149,7 @@ implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) coq.elaborate-skeleton (PMapA a1 a2 ar) _ (MapA a1 a2 ar) ok, MR = {{ @Trocq.Hierarchy.map_in_R }}, coq.mk-app MR [a1,a2,ar] (PMR a1 a2 ar), - % PMR should not need elaboration coq.elaborate-skeleton PMR _ MRA ok, - MRA = PMR, + coq.elaborate-skeleton (PMR a1 a2 ar) _ (MRA a1 a2 ar) ok, mymap-def A1Ty (MapA a1 a2 ar) ==> mR-db a1 (MRA a1 a2 ar) ==> ar-db a1 a2 ar ==> @@ -166,7 +166,7 @@ main GR Prefix Clauses :- std.do! [ mymap-def Ind IndMap, mk-mR-type UnifParamNo TRTy IndMap {{ Type }} TR ff MRTy, coq.elaborate-skeleton MRTy _ MRTyE ok, - std.spy! (implement-mR UnifParamNo UnifParamNo MRTyE T), + implement-mR UnifParamNo UnifParamNo MRTyE T, coq.elaborate-skeleton T MRTyE TE ok, coq.ensure-fresh-global-id Name FName, coq.env.add-const FName TE MRTyE _ C, diff --git a/generic/mymap.elpi b/generic/mymap.elpi index b401a8bd..bc32c541 100644 --- a/generic/mymap.elpi +++ b/generic/mymap.elpi @@ -105,7 +105,7 @@ bo-params N Lno Ity1 Ity2 (prod A Sty1 Rty1) (prod _ Sty2 Rty2) Ps R :- coq.name-suffix A 2 A2, coq.name-suffix A "f" Af, N1 is N + 1, - std.spy! (pi a b f \ mk-map-ty a Sty1 b Sty2 (FAB a b) f _ (Clause a b f)), + (pi a b f \ mk-map-ty a Sty1 b Sty2 (FAB a b) f _ (Clause a b f)), R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Af (FAB a b) f\ Bo a b f), pi a b f\ sigma Ity1A Ity2A \ coq.mk-app Ity1 [a] Ity1A, @@ -189,7 +189,7 @@ main GR Prefix C :- do! [ assert! (Lno = Luno) "derive.map: Non-uniform parameters not supported", % generate map and add to the env - std.spy! (bo-params 0 Lno T T Arity Arity [] RSkel), + (bo-params 0 Lno T T Arity Arity [] RSkel), std.assert-ok! (coq.elaborate-skeleton RSkel Rty R) "derive.mymap generates illtyped term", Name is Prefix ^ "mymap", coq.ensure-fresh-global-id Name FName, diff --git a/generic/mymap.v b/generic/mymap.v index 3a1721cb..99aa99c3 100644 --- a/generic/mymap.v +++ b/generic/mymap.v @@ -1,5 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq Extra Dependency "mymap.elpi" as mymap. +From Trocq.Algo Extra Dependency "mymap.elpi" as mymap. From elpi Require Import elpi. From elpi.apps Require Import derive. @@ -42,26 +42,6 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.mymap ". }}. -Elpi derive.mymap option. -Print option_mymap. - -Elpi derive.mymap list. -Print list_mymap. - -Elpi derive.mymap prod. -Print prod_mymap. - -Elpi derive.mymap nat. -Print nat_mymap. - -Inductive ThreeTypes (A B C : Type) := -| C1 : A -> ThreeTypes A B C -| C2 : B -> ThreeTypes A B C -| C3 : C -> ThreeTypes A B C. - -Elpi derive.mymap ThreeTypes. -Print ThreeTypes_mymap. - Elpi Query lp:{{ coq.locate "option" (indt Option), diff --git a/tests/coverage.v b/tests/coverage.v new file mode 100644 index 00000000..9d069448 --- /dev/null +++ b/tests/coverage.v @@ -0,0 +1,39 @@ +Inductive False : Set :=. + +Inductive Unit : Set := +| TT : Unit. + +Inductive Bool : Set := +| Falseb +| Trueb. + +Inductive Wrap : Set := +| KWrap1 : Unit -> Wrap. + +Inductive WrapMore : Set := +| KWrap : Unit -> Bool -> WrapMore +| KWrapWrap : Wrap -> WrapMore +| F : Unit -> Unit -> Unit -> WrapMore. + +Inductive Nat : Set := +| O' +| S' : Nat -> Nat. + +Inductive Box (A : Type) : Type := +| B : A -> Box A. + +Inductive Option (A : Type) : Type := +| None' : Option A +| Some' : A -> Option A. + +Inductive Prod (A B : Type) : Type := +| PR : A -> B -> Prod A B. + +Inductive ThreeTypes (A B C : Type) := +| C1 : A -> ThreeTypes A B C +| C2 : B -> ThreeTypes A B C +| C3 : C -> ThreeTypes A B C. + +Inductive List (A : Type) : Type := +| Nil : List A +| Cons : A -> List A -> List A. diff --git a/tests/test_Rm.v b/tests/test_Rm.v new file mode 100644 index 00000000..4a7c0fb2 --- /dev/null +++ b/tests/test_Rm.v @@ -0,0 +1,48 @@ +From Trocq.Algo Require Import Rm. +From Trocq.Tests Require Import coverage. +From Trocq Require Import Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi derive.param2 False. +Elpi derive.mymap False. +Elpi derive.Rm False. + +Elpi derive.param2 Unit. +Elpi derive.mymap Unit. +Elpi derive.Rm Unit. + +Elpi derive.param2 Bool. +Elpi derive.mymap Bool. +Elpi derive.Rm Bool. + +Elpi derive.param2 Wrap. +Elpi derive.mymap Wrap. +Elpi derive.Rm Wrap. + +Elpi derive.param2 WrapMore. +Elpi derive.mymap WrapMore. +Elpi derive.Rm WrapMore. + +Elpi derive.param2 Nat. +Elpi derive.mymap Nat. +Elpi derive.Rm Nat. + +Elpi derive.param2 Box. +Elpi derive.mymap Box. +Elpi derive.Rm Box. + +Elpi derive.param2 Option. +Elpi derive.mymap Option. +Elpi derive.Rm Option. + +Elpi derive.param2 Prod. +Elpi derive.mymap Prod. +Elpi derive.Rm Prod. + +Elpi derive.param2 ThreeTypes. +Elpi derive.mymap ThreeTypes. +Elpi derive.Rm ThreeTypes. + +Elpi derive.param2 List. +Elpi derive.mymap List. +Elpi derive.Rm List. \ No newline at end of file diff --git a/tests/test_injection_lemmas.v b/tests/test_injection_lemmas.v new file mode 100644 index 00000000..4bd289f8 --- /dev/null +++ b/tests/test_injection_lemmas.v @@ -0,0 +1,36 @@ +From Trocq.Algo Require Import injection_lemmas. +From Trocq.Tests Require Import coverage. +Unset Uniform Inductive Parameters. + +Elpi derive.projK False. +Elpi derive.injections False. + +Elpi derive.projK Unit. +Elpi derive.injections Unit. + +Elpi derive.projK Bool. +Elpi derive.injections Bool. + +Elpi derive.projK Wrap. +Elpi derive.injections Wrap. + +Elpi derive.projK WrapMore. +Elpi derive.injections WrapMore. + +Elpi derive.projK Nat. +Elpi derive.injections Nat. + +Elpi derive.projK Box. +Elpi derive.injections Box. + +Elpi derive.projK Option. +Elpi derive.injections Option. + +Elpi derive.projK Prod. +Elpi derive.injections Prod. + +Elpi derive.projK ThreeTypes. +Elpi derive.injections ThreeTypes. + +Elpi derive.projK List. +Elpi derive.injections List. \ No newline at end of file diff --git a/tests/test_mR.v b/tests/test_mR.v new file mode 100644 index 00000000..56d125dc --- /dev/null +++ b/tests/test_mR.v @@ -0,0 +1,78 @@ +From Trocq.Algo Require Import mR. +From Trocq.Tests Require Import coverage. +From Trocq Require Import Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi derive.param2 False. +Elpi derive.mymap False. +Elpi derive.projK False. +Elpi derive.injections False. +Elpi derive.isK False. +Elpi derive.mR False. + +Elpi derive.param2 Unit. +Elpi derive.mymap Unit. +Elpi derive.projK Unit. +Elpi derive.injections Unit. +Elpi derive.isK Unit. +Elpi derive.mR Unit. + +Elpi derive.param2 Bool. +Elpi derive.mymap Bool. +Elpi derive.isK Bool. +Elpi derive.mR Bool. + +Elpi derive.param2 Wrap. +Elpi derive.mymap Wrap. +Elpi derive.projK Wrap. +Elpi derive.injections Wrap. +Elpi derive.mR Wrap. + +Elpi derive.param2 WrapMore. +Elpi derive.mymap WrapMore. +Elpi derive.projK WrapMore. +Elpi derive.injections WrapMore. +Elpi derive.isK WrapMore. +Elpi derive.mR WrapMore. + +Elpi derive.param2 Nat. +Elpi derive.mymap Nat. +Elpi derive.projK Nat. +Elpi derive.injections Nat. +Elpi derive.isK Nat. +Elpi derive.mR Nat. + +Elpi derive.param2 Box. +Elpi derive.mymap Box. +Elpi derive.projK Box. +Elpi derive.injections Box. +Elpi derive.isK Box. +Elpi derive.mR Box. + +Elpi derive.param2 Option. +Elpi derive.mymap Option. +Elpi derive.projK Option. +Elpi derive.injections Option. +Elpi derive.isK Option. +Elpi derive.mR Option. + +Elpi derive.param2 Prod. +Elpi derive.mymap Prod. +Elpi derive.projK Prod. +Elpi derive.injections Prod. +Elpi derive.isK Prod. +Elpi derive.mR Prod. + +Elpi derive.param2 ThreeTypes. +Elpi derive.mymap ThreeTypes. +Elpi derive.projK ThreeTypes. +Elpi derive.injections ThreeTypes. +Elpi derive.isK ThreeTypes. +Elpi derive.mR ThreeTypes. + +Elpi derive.param2 List. +Elpi derive.mymap List. +Elpi derive.projK List. +Elpi derive.injections List. +Elpi derive.isK List. +Elpi derive.mR List. \ No newline at end of file diff --git a/tests/test_mymap.v b/tests/test_mymap.v new file mode 100644 index 00000000..12aa9fef --- /dev/null +++ b/tests/test_mymap.v @@ -0,0 +1,16 @@ +From Trocq.Tests Require Import coverage. +From elpi Require Import elpi. +From Trocq.Algo Require Import mymap. +From Trocq Require Import Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi derive.mymap False. +Elpi derive.mymap Unit. +Elpi derive.mymap Bool. +Elpi derive.mymap Wrap. +Elpi derive.mymap WrapMore. +Elpi derive.mymap Box. +Elpi derive.mymap Option. +Elpi derive.mymap Prod. +Elpi derive.mymap ThreeTypes. +Elpi derive.mymap List. From dcc7b2f4781e3b820ac400ae674f0f84958a4488 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 20 Aug 2025 15:04:56 +0200 Subject: [PATCH 07/42] details on injijK injK init refactoring some code wip injK type cleaning refactoring + cleaning moving some functions to utils wip injK adding type conlusion refactoring + generating injK types body of injKij tests for injK --- algo/Rm.elpi | 106 +++++-------- algo/Rm.v | 2 + algo/injK.elpi | 214 +++++++++++++++++++++++++++ algo/injK.v | 64 ++++++++ algo/injection_lemmas.elpi | 56 +------ algo/injection_lemmas.v | 60 +------- algo/mR.v | 14 -- algo/utils.elpi | 99 +++++++++++++ detailed/Detailed_injijK.v | 295 ++++++++++++++++++++++++++++++++++++- tests/test_injK.v | 48 ++++++ 10 files changed, 759 insertions(+), 199 deletions(-) create mode 100644 algo/injK.elpi create mode 100644 algo/injK.v create mode 100644 algo/utils.elpi create mode 100644 tests/test_injK.v diff --git a/algo/Rm.elpi b/algo/Rm.elpi index 96758847..220243ec 100644 --- a/algo/Rm.elpi +++ b/algo/Rm.elpi @@ -1,29 +1,8 @@ shorten derive.common-algo.{mk-mR-type}. +shorten derive.algo-utils.{mk-chain}. namespace derive.Rm { -pred mk-ith-eta i:int, i:list term, i:list term, i:list term, i:term, o:term. -mk-ith-eta I MArgs DestArgs Tys K FR :- - J is I - 1, - std.take J DestArgs Done, % list of args already processed. - std.drop I MArgs MTODO, % list of args to yet process - std.nth J Tys CurrTy, - (pi curr\ - coq.mk-app K {std.append Done [curr|MTODO]} (KArgs curr)), - FR = fun `R` CurrTy (r\ (KArgs r)). - -pred mk-etas i:list term, i:list term, i:list term, i:int, i:int, i: term, o:list term. -mk-etas _ _ _ M N _ [] :- M > N. -mk-etas SrcArgs DestArgs Tys I N KDest [R| RS] :- - J is I + 1, - mk-ith-eta I SrcArgs DestArgs Tys KDest R, - mk-etas SrcArgs DestArgs Tys J N KDest RS. - -pred compose-path i:list term, i:term, i:term o: term. -compose-path [] End _ End. -compose-path [Argk|Args] End ITy {{ @eq_trans lp:ITy _ _ _ lp:Argk lp:R }} :- - compose-path Args End ITy R. - pred whds i:term, o:term. whds T R :- whd T [] HD ARGS, @@ -36,9 +15,8 @@ build-Rm-args [A1|Args1] [A2|Args2] T R :- coq.mk-app T [A1, A2, AR] TAR, build-Rm-args Args1 Args2 TAR R. - -pred build-Rm i:term, i:term, i:term, o:term. -build-Rm STy DTy ITyTy R :- +pred build-Rm i:term, i:term, o:term. +build-Rm STy ITyTy R :- coq.safe-dest-app STy Ind Args1, coq.safe-dest-app ITyTy Ind2 Args2, rm-db Ind RM, @@ -46,40 +24,27 @@ build-Rm STy DTy ITyTy R :- (R = RM) (build-Rm-args Args1 Args2 RM RSkel, coq.elaborate-skeleton RSkel _ R ok). - % build-mRA-ty-args ArgsTy1 ArgsTy2 MR R). - % rm-db STy RM, - - -% given list of etas, list of src type, list of dest type, -% Dest iTyTy, list mapped args, list dest args, returns list of ap tyDest ITyty eta Marg DestArg (e : Marg = DestArg) -pred mk-aps-etas i:list term, i:list term, i:list term, i:term, i:list term, i:list term, o:list term. -mk-aps-etas [] [] [] _ [] [] []. -mk-aps-etas [Eta|Etas] [STy| SrcTys] [DTy|DestTys] ITyTy [MA|MArgs] [DA|Dargs] [RE|RS] :- - Ap = {{ eq_f }}, +pred mk-equalities i:list term, i:term, i: list term, o:list term. +mk-equalities [] _ [] []. +mk-equalities [STy| SrcTys] ITyTy [DA|Dargs] [R|RS] :- param DA A AR, - build-Rm STy DTy ITyTy RM, - coq.typecheck RM RmTy ok, - coq.typecheck AR ARTy ok, - coq.mk-app RM [A, DA, AR] EqADA, - coq.mk-app Ap [DTy,ITyTy,Eta,MA,DA,EqADA] R, - coq.elaborate-skeleton R _ RE E, - mk-aps-etas Etas SrcTys DestTys ITyTy MArgs Dargs RS. + build-Rm STy ITyTy RM, + coq.mk-app RM [A, DA, AR] R, + mk-equalities SrcTys ITyTy Dargs RS. % Ksource, Kdest, remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, pred process-args i:term, i:term, i:int, i:int, i:term, i:term, i:list term, i:list term, i:term, o:term. -process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest _ITyTy R:- +process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest ITyTy R:- coq.mk-app Goal [Ksrc, Kdest, {{ Type }}] EqTy, %discards the relation between Ksrc and Kdest, we want the equality. - whd EqTy [] {{lib:@elpi.eq}} [T,MapA,B], + whd EqTy [] {{lib:@elpi.eq}} [ITyTy,MapA,B], whd MapA [] (global (indc _)) TySrcMappedArgs, whd B [] KDest TyDestArgs, - std.drop TyArgsNo TySrcMappedArgs SrcMappedArgs, + std.drop TyArgsNo TySrcMappedArgs SrcArgs, std.drop TyArgsNo TyDestArgs DestArgs, coq.mk-app KDest {std.take TyArgsNo TyDestArgs} KAppTyArgs, - mk-etas SrcMappedArgs DestArgs TyDest 1 {std.length DestArgs} KAppTyArgs REtas, - mk-aps-etas REtas TySrc TyDest T SrcMappedArgs DestArgs Raps, - compose-path Raps {{ @eq_refl lp:T lp:B }} T Rpath, - coq.elaborate-skeleton Rpath EqTy R E. + mk-equalities TySrc ITyTy DestArgs Eqs, + mk-chain SrcArgs DestArgs TyDest KAppTyArgs Eqs ITyTy B R. process-args Ksrc Kdest N TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal TySrc TyDest ITyTy (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- M is N - 1, @@ -107,23 +72,24 @@ type-of-args (prod _AN1 ATy1 a1\ prod _AN2 ATy2 a2\ prod _ _ ar\ (Bo a1 a2 ar)) type-of-args (Bo a1 a2 ar) M SR DR. % invariant: all type arguments were already processed. -% Constructor src, Constructor dest, Constructor dest Type, Arguments to process, ConstructorR constructorR Type, i2, type of i2, i1 i2 iR => goal. -pred mkBranch i:term, i:term, i:term, i:int, i:term, i:term, i:term, i:term, i:term, o:term. -mkBranch KS KD KTy N KR KTyR _ITy ITyTy Goal Eq:- +% Constructor src, Constructor dest, Constructor dest Type, No of Arguments to process, +% constructorR Type, type of i2, something of type : i1 i2 iR => goal. +pred mkBranch i:term, i:term, i:int, i:term, i:term, i:term, o:term. +mkBranch KS KD N KTyR ITyTy Goal Eq:- type-of-args KTyR N SrcArgs DestArgs, whd ITyTy [] _ TyArgs, process-args KS KD N {std.length TyArgs} KTyR Goal SrcArgs DestArgs ITyTy Eq. -pred mkBranches i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term o:list term. -mkBranches [] [] [] [] [] _ _ _ []. -mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KR|KRs] [KTyR|KTyRs] ITy ITyTy Goal [R|Rs] :- - mkBranch KS KD KTy {coq.count-prods KTy} KR KTyR ITy ITyTy Goal R, - mkBranches KsS KsD KTys KRs KTyRs ITy ITyTy Goal Rs. +pred mkBranches i:list term, i:list term, i:list term, i:list term, i:term, i:term o:list term. +mkBranches [] [] [] [] _ _ []. +mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KTyR|KTyRs] ITyTy Goal [R|Rs] :- + mkBranch KS KD {coq.count-prods KTy} KTyR ITyTy Goal R, + mkBranches KsS KsD KTys KTyRs ITyTy Goal Rs. -pred implement-Rm i:int, i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, o:term. +pred implement-Rm i:int, i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, o:term. % Pred comes with Type parameters applied % RInd comes with Type parameters applied -implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KRs KTyRs Pred RInd +implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KTyRs Pred RInd (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- coq.safe-dest-app ITy1 Ind _, Ind = (global (indt GR)), @@ -135,19 +101,19 @@ implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 @pi-decl IN2 ITy2 i2\ @pi-decl ARN (ARTy i1 i2) ar\ (rm-db Ind f => - mkBranches KsS KsD KTys KRs KTyRs i2 ITy2 Pred (Brs f i2)), - std.append (Brs f i2) [i1,i2,ar] (IndArgs f i1 i2 ar), + mkBranches KsS KsD KTys KTyRs ITy2 Pred (Brs f)), + std.append (Brs f) [i1,i2,ar] (IndArgs f i1 i2 ar), coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). -implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KRs KTyRs Pred RInd +implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) _) KsS KsD KTys KTyRs Pred RInd (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- coq.mk-app RInd [Pred] RIndP, @pi-decl IN1 ITy1 i1\ @pi-decl IN2 ITy2 i2\ @pi-decl ARN (ARTy i1 i2) ar\ - mkBranches KsS KsD KTys KRs KTyRs i2 ITy2 Pred (Brs i2), - std.append (Brs i2) [i1,i2,ar] (IndArgs i1 i2 ar), + mkBranches KsS KsD KTys KTyRs ITy2 Pred Brs, + std.append Brs [i1,i2,ar] (IndArgs i1 i2 ar), coq.mk-app RIndP (IndArgs i1 i2 ar) (R i1 i2 ar). -implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KTys KRs KTyRs Pred RInd +implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KTys KTyRs Pred RInd (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- M is N - 1, @pi-decl AN1 ATy1 a1\ %A1 : Type @@ -164,14 +130,13 @@ implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), - std.map KRs (x\ r\ sigma TMP\ coq.mk-app x [a1,a2,(RelAR a1 a2 ar)] TMP, r = TMP) (NewKRs a1 a2 ar), std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), Rm = {{ @Trocq.Hierarchy.R_in_map }}, coq.mk-app Rm [a1, a2, ar] (RMS a1 a2 ar), - coq.elaborate-skeleton (RMS a1 a2 ar) (RTy a1 a2 ar) (RM a1 a2 ar) E, + % coq.elaborate-skeleton (RMS a1 a2 ar) _ (RM a1 a2 ar) ok, ar-db a1 a2 ar ==> rm-db a1 (RMS a1 a2 ar) ==> - implement-Rm M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKRs a1 a2 ar) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). + implement-Rm M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). pred main i:inductive, i:string, o:list prop. @@ -189,10 +154,9 @@ main GR Prefix Clauses :- std.do! [ RInductionName is Rname ^ "_ind", coq.locate RInductionName RInd, coq.prod->fun MRTyE Pred, - coq.env.indt GRR _ _ _ _ KNRs KTyRs, + coq.env.indt GRR _ _ _ _ _ KTyRs, std.map KNs (x\ r\ r = (global (indc x))) Ks, - std.map KNRs (x\ r\ r = (global (indc x))) KRs, - implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KRs KTyRs Pred (global RInd) R, + implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KTyRs Pred (global RInd) R, coq.elaborate-skeleton R MRTyE Re ok, Name is Prefix ^ "Rm", coq.ensure-fresh-global-id Name FName, diff --git a/algo/Rm.v b/algo/Rm.v index 1890db90..484b2bfb 100644 --- a/algo/Rm.v +++ b/algo/Rm.v @@ -1,6 +1,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From Trocq.Algo Extra Dependency "Rm.elpi" as Rm. From Trocq.Algo Extra Dependency "common_algo.elpi" as common. +From Trocq.Algo Extra Dependency "utils.elpi" as algo_utils. From elpi Require Import elpi. From elpi.apps Require Import derive.param2. @@ -27,6 +28,7 @@ Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.mymap.db. Elpi Accumulate File common. +Elpi Accumulate File algo_utils. Elpi Accumulate Db derive.Rm.db. Elpi Accumulate File Rm. Elpi Accumulate lp:{{ diff --git a/algo/injK.elpi b/algo/injK.elpi new file mode 100644 index 00000000..c2ea6855 --- /dev/null +++ b/algo/injK.elpi @@ -0,0 +1,214 @@ +shorten derive.algo-utils.{duplicate-arguments,count-args, name-prefix, mk-chain, name-ijs}. + +namespace derive.injK { + +pred add-equalities i:int, i:int, i:term, o:term. +add-equalities 0 0 T T. +add-equalities 0 M (prod AN1 ATy a1\ prod AN2 ATy a2\ (Bo a1 a2)) + (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (EqTy a1 a2) e\ (R a1 a2)) :- + O is M - 1, + name-prefix AN1 "p_" EN, + pi a1 a2\ + coq.mk-app {{lib:@elpi.eq}} [ATy, a1, a2] (EqTy a1 a2), + add-equalities 0 O (Bo a1 a2) (R a1 a2). +add-equalities N M (prod AN1 ATy a1\ (Bo a1)) + (prod AN1 ATy a1\ (R a1)) :- + O is N - 1, + pi a1\ + add-equalities O M (Bo a1) (R a1). + +pred get-injectors i:list term, i: list int, o: list (list term), o:list (list int). +get-injectors [] [] [] []. +get-injectors [K|Ks] [ArgNo|ArgNos] [R|RS] [Tmp|Tmps]:- + std.iota ArgNo Tmp, + std.map Tmp (x\r\ sigma Add1\ Add1 is x + 1, r = Add1) Add1, + std.map Add1 (x\r\ sigma R\ injections-db K x R, r = R) R, + get-injectors Ks ArgNos RS Tmps. + +% TyParam, ArgNo, type of duplicated args + eq, injector, dest path no, RHS path (dflt dummy). +% +pred add-concl i:int, i:int, i:int, i:term, i:term, i:int, i:term, i:term, i:list term, i:list term, i: list term, o:term. +add-concl 0 ArgNo ArgNo _ Injtor _ RHS K SrcArgs_R DestArgs_R Eqs_R R :- + % M > ArgNo, + !, + std.rev SrcArgs_R SrcArgs, + std.rev DestArgs_R DestArgs, + std.rev Eqs_R Eqs, + std.map DestArgs (x\r\ sigma R\ coq.typecheck x R ok, r = R) DestArgsTy, + coq.mk-app K DestArgs Ind, + coq.typecheck Ind ITyTy ok, + mk-chain SrcArgs DestArgs DestArgsTy K Eqs ITyTy Ind Chain, + coq.mk-app Injtor [Chain] LHS, + coq.mk-app {{lib:@elpi.eq}} [{{ _ }}, LHS, RHS] RSkel, + coq.elaborate-skeleton RSkel _ R ok. +add-concl 0 M ArgNo (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (ETy a1 a2) e\ (Bo a1 a2 e)) Injtor DestPathNo RHS K SrcArgs DestArgs Eqs + (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (ETy a1 a2) e\ (R a1 a2 e)) :- + !, + O is M + 1, + @pi-decl AN1 ATy a1\ + @pi-decl AN2 ATy a2\ + @pi-decl EN (ETy a1 a2) e\ + coq.mk-app Injtor [a1, a2] (NewInjtor a1 a2), + if (M = DestPathNo) + ((NewRHS e) = e) + ((NewRHS e) = RHS), + add-concl 0 O ArgNo (Bo a1 a2 e) (NewInjtor a1 a2) DestPathNo (NewRHS e) K [a1 | SrcArgs] [a2| DestArgs] [e | Eqs] (R a1 a2 e). + +add-concl N 0 ArgNo (prod AN1 ATy a1\ (Bo a1)) Injtor DestPathNo RHS K SrcArgs DestArgs Eqs + (prod AN1 ATy a1\ (R a1)) :- + M is N - 1, + @pi-decl AN1 ATy a1\ + coq.mk-app Injtor [a1] (NewInjtor a1), + coq.mk-app K [a1] (NewK a1), + add-concl M 0 ArgNo (Bo a1) (NewInjtor a1) DestPathNo RHS (NewK a1) SrcArgs DestArgs Eqs (R a1). + +% type of duplicated arguments + eq, list of injectors, list of dest path number. +% todo: add K applied to typaram +pred add-conclss i:list term, i:list term, i:int, i:list int, i:list (list term), i:list (list int), o: list (list term). +add-conclss [] [] _ [] [] [] []. +add-conclss [PTy|PTys] [K|Ks] TyParamNo [ArgNo|ArgNos] [Injs|Injss] [DestNos|DestNoss] [InjTys|InjTyss] :- + std.map2 Injs DestNos (x\y\r\ sigma R\ add-concl TyParamNo 0 ArgNo PTy x y {{Type}} K [] [] [] R, r = R) InjTys, + add-conclss PTys Ks TyParamNo ArgNos Injss DestNoss InjTyss. + +%TyParamNo, constructors, type of constructors, output. +% for every constructor, +% collects its injectors and build the corresponding type for every injector +pred mk-injK-types i:int, i: list constructor, i:list term, o:list (list term), o:list int, o:list (list int). +mk-injK-types TyParamNo KNs KTys InjTyss ArgNos DestNoss :- + std.map KTys (x\ r\ sigma R\ count-args TyParamNo x R, r = R) ArgNos, + std.map2 KTys ArgNos + (x\ y\ r\ sigma ArgNo R1 R2\ + duplicate-arguments TyParamNo y x R1, + add-equalities TyParamNo y R1 R2, + r = R2) PTy, + std.map KNs (x\ r\ r = global (indc x)) Ks, + get-injectors Ks ArgNos Injss DestNoss, + add-conclss PTy Ks TyParamNo ArgNos Injss DestNoss InjTyss. + +% rm argno +pred mk-pred i:int, i:int, i:int, i:term, i:term, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, o:term. +mk-pred _ _ _ Pred _ _ [] [] [] [] [] Pred. +mk-pred Curr I ArgNo Pred T P [A1|Args1] [_A2|Args2] [A2Ty|TyArgs2] [_Path|Paths] [_PathTy|TyPaths] R :- + Curr < I, + !, + J is Curr + 1, + coq.mk-app Pred [A1,A1,{{ @eq_refl lp:A2Ty lp:A1}}] NewPred, + mk-pred J I ArgNo NewPred T P Args1 Args2 TyArgs2 Paths TyPaths R. + +mk-pred I I ArgNo Pred T P [A1|Args1] [_A2|Args2] [_A2Ty|TyArgs2] [_Path|Paths] [_PathTy|TyPaths] R :- + !, + J is I + 1, + coq.mk-app Pred [A1,T,P] NewPred, + mk-pred J I ArgNo NewPred T P Args1 Args2 TyArgs2 Paths TyPaths R. + +mk-pred Curr I ArgNo Pred T P [A1|Args1] [A2|Args2] [_A2Ty|TyArgs2] [Path|Paths] [_PathTy|TyPaths] R :- + coq.mk-app Pred [A1,A2,Path] NewPred, + mk-pred Curr I ArgNo NewPred T P Args1 Args2 TyArgs2 Paths TyPaths R. + +pred mk-preds i:int, i:int, i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, o:list term. +mk-preds _ _ [] _ _ _ _ _ []. +mk-preds I ArgNo [P|Preds] Args1 Args2 TyArgs2 Paths TyPaths [ fun `t` Ty t\ fun `p` (PatTy t) p\ (R t p) | RS ] :- + J is I + 1, + std.nth I TyArgs2 Ty, + std.nth I TyPaths PTy, + whd PTy [] {{lib:@elpi.eq}} [T,A,_], + @pi-decl `t` Ty t\ + coq.mk-app {{lib:@elpi.eq}} [T,A,t] (PatTy t), + @pi-decl `p` (PatTy t) p\ + mk-pred 0 I ArgNo P t p Args1 Args2 TyArgs2 Paths TyPaths (R t p), + mk-preds J ArgNo Preds Args1 Args2 TyArgs2 Paths TyPaths RS. + +pred iter-convs i:list term, i:list term, i:list term, i:list term, i:list term, i:term, o:term. +iter-convs [] [] [] [] [] End End. +iter-convs [Ty|Tys] [A1|Args1] [A2|Args2] [Path|Paths] [Pred|Preds] End R :- + Conv = {{lib:@elpi.derive.conv}}, + iter-convs Tys Args1 Args2 Paths Preds End P0, + coq.mk-app Conv [ Ty, A1, A2, Path, Pred, P0] R. + + +pred implement-injK i:int, i:int, i:int, i:int, i:term, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, o:term. +implement-injK 0 0 ArgNo DestNo _ Pred TyParamsR Args1R Args2R TyArgs2R PathsR TyPathsR R :- + std.rev TyParamsR TyParams, + std.rev Args1R Args1, + std.rev Args2R Args2, + std.rev TyArgs2R TyArgs2, + std.rev PathsR Paths, + std.rev TyPathsR TyPaths, + coq.mk-app Pred TyParams PredT, + std.iota ArgNo Tmp, + std.map Tmp (x\r\ r = PredT) Preds, + mk-preds 0 ArgNo Preds Args1 Args2 TyArgs2 Paths TyPaths RPreds, + + std.nth DestNo Args1 A1, + std.nth DestNo TyArgs2 Ty, + EndArg = {{ @eq_refl lp:Ty lp:A1}}, + coq.typecheck EndArg EndTy ok, + End = {{@eq_refl lp:EndTy lp:EndArg}}, + iter-convs TyArgs2 Args1 Args2 Paths RPreds End RSkel, + coq.elaborate-skeleton RSkel _ R ok. + +% build the stuff. +% reverse args +implement-injK 0 N ArgNo DestNo (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (EqTy a1 a2) e\ (Bo a1 a2 e)) + Pred TyParams Args1 Args2 TyArgs2 Paths TyPaths (fun AN1 ATy a1\ fun AN2 ATy a2\ fun EN (EqTy a1 a2) e\ (R a1 a2 e)) :- + M is N - 1, + @pi-decl AN1 ATy a1\ + @pi-decl AN2 ATy a2\ + @pi-decl EN (EqTy a1 a2) e\ + implement-injK 0 M ArgNo DestNo (Bo a1 a2 e) Pred TyParams [a1|Args1] [a2|Args2] [ATy|TyArgs2] [e|Paths] [(EqTy a1 a2)|TyPaths] (R a1 a2 e). + +implement-injK M N ArgNo DestNo (prod AN1 ATy a1\ (Bo a1)) Pred TyParams Args1 Args2 TyArgs2 Paths TyPaths (fun AN1 ATy a1\ (R a1)) :- + O is M - 1, + @pi-decl AN1 ATy a1\ + implement-injK O N ArgNo DestNo (Bo a1) Pred [a1|TyParams] Args1 Args2 TyArgs2 Paths TyPaths (R a1). + +% todo rm constructor as arg +pred implement-injKs i:int, i:constructor, i:int, i:list term, i:list int, o:list term. +implement-injKs _ _ _ [] [] []. +implement-injKs TyParamNo _ ArgNo [InjKTy|InjKTys] [DestNo | DestNos] [R| RS] :- + coq.prod->fun InjKTy Pred, + implement-injK TyParamNo ArgNo ArgNo DestNo InjKTy Pred [] [] [] [] [] [] R, + implement-injKs TyParamNo _ ArgNo InjKTys DestNos RS. + +% todo rm constructors as arg +pred implement-injK-types i:int, i: list constructor, i:list int, i:list (list term), i:list (list int), o:list (list term). +implement-injK-types _ [] [] [] [] []. +implement-injK-types TyParamNo [Kn|KNs] [ArgNo|ArgNos] [InjKTys|InjKTyss] [DestNos| DestNoss] [R|RS] :- + implement-injKs TyParamNo Kn ArgNo InjKTys DestNos R, + implement-injK-types TyParamNo KNs ArgNos InjKTyss DestNoss RS. + + +pred main i:inductive, i:string, o:list prop. +main GR Prefix Clauses :- std.do! [ + + Name is Prefix ^ "injK", + coq.ensure-fresh-global-id Name FName, + coq.env.indt GR _ TyParamNo _ _ KNs KTys, + % Ind = (global (indt GR)), + mk-injK-types TyParamNo KNs KTys RTys ArgNos DestNos, + Register = (k\j\c\ (injectionsK-db (global (indc k)) j (global (const c)))), + implement-injK-types TyParamNo KNs ArgNos RTys DestNos RS, + name-ijs FName 1 GR KNs RS Register Clausess, + std.flatten Clausess Clauses, + ClausesFin = [injectionsK-done (global (indt GR)) | Clauses], + std.forall ClausesFin (x\ + coq.elpi.accumulate _ "derive.injectionsK.db" (clause _ _ x) + ), + % coq.elaborate-skeleton MRTy _ MRTyE ok, + % TR = global (indt GRR), + % coq.gref->id (indt GRR) Rname, + % RInductionName is Rname ^ "_ind", + % coq.locate RInductionName RInd, + % coq.prod->fun MRTyE Pred, + % coq.env.indt GRR _ _ _ _ KNRs KTyRs, + % std.map KNs (x\ r\ r = (global (indc x))) Ks, + % std.map KNRs (x\ r\ r = (global (indc x))) KRs, + % implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KRs KTyRs Pred (global RInd) R, + % coq.elaborate-skeleton R MRTyE Re ok, + % Name is Prefix ^ "Rm", + % coq.ensure-fresh-global-id Name FName, + % coq.env.add-const FName Re MRTyE _ C, + % I = global (indt GR), +]. + +} \ No newline at end of file diff --git a/algo/injK.v b/algo/injK.v new file mode 100644 index 00000000..f5bafa14 --- /dev/null +++ b/algo/injK.v @@ -0,0 +1,64 @@ + +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From Trocq.Algo Extra Dependency "injK.elpi" as injK. +From Trocq.Algo Extra Dependency "utils.elpi" as algo_utils. +From Trocq.Algo Require Import injection_lemmas. + +From elpi Require Import elpi. +From elpi.apps Require Import derive.bcongr. (* for eq_f register *) +(* From elpi.apps Require Import projK. *) + +From Trocq Require Import HoTT_additions Hierarchy. +Unset Uniform Inductive Parameters. + +Definition conv (A : Type) (x y : A) (p: x = y) + (P : forall x0 : A, x = x0 -> Prop) (P0 : P x eq_refl) := + match p as p0 in _ = t return (P t p0) + with eq_refl => P0 end. + +Register conv as elpi.derive.conv. + +Elpi Db derive.injectionsK.db lp:{{ + + % [injectionsK-db I K ILs] links I, + % constructor inductive type, + % and K, + % a natural number > 0 (representing the constructor number) + % with the list of injectionK lemmas for that constructor + pred injectionsK-db i:term, i:int, o:term. + + % [injectionsK-done T K] means T K was already derived + pred injectionsK-done o:term. +}}. + +Elpi Command derive.injectionsK. +Elpi Accumulate File derive_hook. +Elpi Accumulate File algo_utils. +Elpi Accumulate Db derive.injectionsK.db. +Elpi Accumulate Db derive.injections.db. +Elpi Accumulate File injK. +(* Elpi Query lp:{{ + %std.nth 0 {std.iota 5} L. + R = {{lib:@elpi.derive.conv}}. +}}. *) +Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), + coq.gref->id (indt GR) Tname, + Prefix is Tname ^ "_", + derive.injK.main GR Prefix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.Rm ". +}}. + +From Trocq.Tests Require Import coverage. +Elpi derive.projK Box. +Elpi derive.injections Box. +Elpi derive.injectionsK Box. +Elpi derive.projK WrapMore. +Elpi derive.injections WrapMore. +Elpi derive.injectionsK WrapMore. +Elpi derive.projK List. +Elpi derive.injections List. +Elpi derive.injectionsK List. \ No newline at end of file diff --git a/algo/injection_lemmas.elpi b/algo/injection_lemmas.elpi index a96569d8..0b0a347d 100644 --- a/algo/injection_lemmas.elpi +++ b/algo/injection_lemmas.elpi @@ -1,3 +1,5 @@ +shorten derive.algo-utils.{duplicate-arguments, count-args, name-ijs}. + namespace derive.injections { /* for all projectors of type forall Args T, ret @@ -27,33 +29,10 @@ get-projectors GRK J Max [P|PJs] :- pred for-K-get-projectors i:int, i:list constructor, i:list term, o: list int, o:list (list term). for-K-get-projectors _ [] [] [] []:- !. for-K-get-projectors TyParamNo [Kn|KNs] [KTy|KTys] [ArgsNo|ArgsNos] [R|RS]:- - coq.count-prods KTy ArgsParamNo, - ArgsNo is ArgsParamNo - TyParamNo, + count-args TyParamNo KTy ArgsNo, get-projectors Kn 0 ArgsNo R, for-K-get-projectors TyParamNo KNs KTys ArgsNos RS. -func names12 name -> name, name. -names12 N N1 N2 :- !, - coq.name-suffix N 1 N1, coq.name-suffix N 2 N2. - -% given TyParam ArgNo and T, -% duplicate-argument skips TyParam lambdas, -% then for the first ArgNo lambda adds another lambda expecting an argument of the same Type, -% after all lambdas are processed returns the body unchanged -% Returns a list with the original variables, and a list with the added ones -pred duplicate-arguments i:int, i:int, i:term, o:term. -duplicate-arguments 0 0 T T :- !. -duplicate-arguments 0 O (prod N TyA T) (prod Arg1 TyA a1\ (prod Arg2 TyA a2\ (S a1 a2))) :- - O > 0, - P is O - 1, - names12 N Arg1 Arg2, - (pi a1 a2\ duplicate-arguments 0 P (T a1) (S a1 a2)). -duplicate-arguments N O (prod TyName TyArg T) (prod TyName TyArg S) :- !, - N > 0, - M is N - 1, - pi a1\ duplicate-arguments M O (T a1) (S a1). - - % TyParam, ArgNo, F, Type of the equality, Left HS, Right HS % F is of type forall (Typarams : Type) ((Arg1 : A1) (Arg2 : A2) ...), Ret % Ret is discarded and replaced by Left = Right @@ -103,28 +82,8 @@ build-types-injectors _ _ [] [] [] [] [] :- !. build-types-injectors TyParamNo GR [Kn|KNs] [ArgNo|ArgsNos] [KTy|KTys] [PJs|PJss] [R|RS] :- build-type-K-injector TyParamNo 1 GR Kn ArgNo KTy PJs R, build-types-injectors TyParamNo GR KNs ArgsNos KTys PJss RS. - % build-types-injectors Kn PJs R, -pred name-injector i:string, i:int, i:int, i:inductive, i:constructor, i:list term, o:list prop. -name-injector _ _ _ _ _ [] []. -name-injector FName I J GR Kn [InjTy|InjTyss] [Clause|Clauses] :- - Jn is J + 1, - NameIJ is {std.any->string FName} ^ {std.any->string I} ^ {std.any->string J}, - coq.env.add-const NameIJ InjTy _ _ C, - % Clause = (injections-db Kn J (global (const C)) :- !), - Clause = (injections-db (global (indc Kn)) J (global (const C))), - name-injector FName I Jn GR Kn InjTyss Clauses. - -pred name-injectors i:string, i:int, i:inductive, i:list constructor, i:list (list term), o:list (list prop). -name-injectors _ _ _ [] [] []. -name-injectors FName I GR [Kn | KNs] [InjTys | InjTyss] [Clauses | Clausess] :- - In is I + 1, - name-injector FName I 1 GR Kn InjTys Clauses, - name-injectors FName In GR KNs InjTyss Clausess. - - pred implement-K-injector-J i:int, i:int, i:int, i:int, i:term, o:term. - % implement-K-injector-J _ _ _ _ T T. implement-K-injector-J 0 J 0 TyParam (prod E Ty _) R :- !, I is J - 1, R = {{ fun e:(lp:Ty) => lp:(PL e) }}, @@ -167,13 +126,8 @@ main GR Prefix Clauses :- std.do! [ std.map PJss (x\ r\ sigma R\ (std.map x (y\ r\ sigma Ty\ coq.typecheck y Ty _, r = Ty) R), r = R) PJTyss, build-types-injectors TyParamNo GR KNs ArgsNos KTys PJTyss InjTyss, implement-injectors TyParamNo ArgsNos InjTyss Injss, - name-injectors FName 1 GR KNs Injss Clausess, -% TTT is {{lib:@elpi.derive.eq_f}}, -% coq.say TTT, -% std.forall Clauses (x\ -% coq.elpi.accumulate _ "derive.injections.db" (clause _ _ x) -% ), -% coq.env.add-const FName Body Type _ C, + Register = (k\j\c\ (injections-db (global (indc k)) j (global (const c)))), + name-ijs FName 1 GR KNs Injss Register Clausess, std.flatten Clausess Clauses, ClausesFin = [injections-done (global (indt GR)) | Clauses], %[injections-done GR, injections GR (const C)], std.forall ClausesFin (x\ diff --git a/algo/injection_lemmas.v b/algo/injection_lemmas.v index d8656292..cc5c06c5 100644 --- a/algo/injection_lemmas.v +++ b/algo/injection_lemmas.v @@ -2,6 +2,7 @@ From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From Trocq.Algo Extra Dependency "injection_lemmas.elpi" as injections. +From Trocq.Algo Extra Dependency "utils.elpi" as algo_utils. From elpi Require Import elpi. From elpi.apps Require Import derive.bcongr. (* for eq_f register *) @@ -26,6 +27,7 @@ Elpi Accumulate Db Header derive.projK.db. Elpi Accumulate Db derive.projK.db. Elpi Accumulate File injection. Elpi Accumulate Db derive.injections.db. +Elpi Accumulate File algo_utils. Elpi Accumulate File injections. Elpi Accumulate lp:{{ @@ -40,62 +42,4 @@ Elpi Accumulate lp:{{ pred usage. usage :- coq.error "Usage: derive.injections ". }}. -Elpi Trace Browser. -Inductive Wrap : Type := -| W : unit -> Wrap. -Elpi derive.projK Wrap. -Print projW1. -Elpi derive.injections Wrap. -Print Wrap_injections11. - -Elpi derive.projK nat. -Elpi derive.injections nat. -Print nat_injections21. - -Elpi derive.projK option. -Print projSome1. -Elpi derive.injections option. -Print option_injections11. - -Inductive enum : Type := -| Constructor : unit -> bool -> enum. - -Elpi derive.projK enum. -Print projConstructor1. -Print projConstructor2. -Elpi derive.injections enum. -Print enum_injections11. -Print enum_injections12. - -Inductive enum2 : Type := -| Nol : enum2 -| Constructor2 : unit -> bool -> enum2. - -Elpi derive.projK enum2. -Print projConstructor21. -Print projConstructor22. -Elpi derive.injections enum2. -Print enum2_injections21. -Print enum2_injections22. - -Inductive Losts (T : Prop) : Prop := -| Conse : Losts T -> Losts T . - -Elpi derive.projK Losts. -Print projConse1. -Elpi derive.injections Losts. -Print Losts_injections11. - -Elpi derive.projK list. -Print projcons1. -Print projcons2. -Elpi derive.injections list. -Print list_injections21. -Print list_injections22. - -Elpi Query lp:{{ - std.findall (injections-db _ _ _) Rules. - std.findall (injections-done _) Rules. - std.findall (projK-db _ _ _) Rules. -}}. diff --git a/algo/mR.v b/algo/mR.v index 415fbeb6..71cd3225 100644 --- a/algo/mR.v +++ b/algo/mR.v @@ -46,17 +46,3 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.mR ". }}. - -Elpi Query lp:{{ - F = {{ fun (A : Type) (l : list A) => match l with nil => unit | cons a l => Prop end }}. - %coq.elaborate-skeleton F Ty FE ok, - coq.typecheck F Ty ok. - coq.say F. - %F = {{ fun b : bool => match b with true => unit | false => Prop end }}. - %std.findall (param {{ option }} {{ option }} T ) Rules, - %std.findall (param {{ list }} {{ list }} T ) Rules, - %std.findall (mymap-db {{ option nat }} {{ option nat }} C ) Rules, - %coq.typecheck T Ty _, - coq.say Rules. - -}}. diff --git a/algo/utils.elpi b/algo/utils.elpi new file mode 100644 index 00000000..b48a2c40 --- /dev/null +++ b/algo/utils.elpi @@ -0,0 +1,99 @@ +namespace derive.algo-utils { + +func names12 name -> name, name. +names12 N N1 N2 :- !, + coq.name-suffix N 1 N1, coq.name-suffix N 2 N2. + +pred name-prefix i: name, i:string, o:name. +name-prefix N P R :- + coq.name->id N NS, + S is P ^ NS, + coq.string->name S R. + +% given TyParam ArgNo and T, +% duplicate-argument skips TyParam products, +% then for the first ArgNo products adds another product expecting an argument of the same Type, +% after all lambdas are processed returns the body unchanged +pred duplicate-arguments i:int, i:int, i:term, o:term. +duplicate-arguments 0 0 T T :- !. +duplicate-arguments 0 O (prod N TyA T) (prod Arg1 TyA a1\ (prod Arg2 TyA a2\ (S a1 a2))) :- + O > 0, + P is O - 1, + names12 N Arg1 Arg2, + (pi a1 a2\ duplicate-arguments 0 P (T a1) (S a1 a2)). +duplicate-arguments N O (prod TyName TyArg T) (prod TyName TyArg S) :- !, + N > 0, + M is N - 1, + pi a1\ duplicate-arguments M O (T a1) (S a1). + +pred count-args i:int, i:term, o:int. +count-args N T R :- + coq.count-prods T M, + R is M - N. + +% given list eta-src type, eta-RT, list of etas, list of src, list of dest, list of src = dest, +% builds the corresponding ap. +pred mk-aps-etas i:list term, i:term, i:list term, i:list term, i:list term, i:list term, o:list term. +mk-aps-etas [] _ [] [] [] [] []. +mk-aps-etas [DTy|DestTys] ITyTy [Eta|Etas] [SA|SrcArgs] [DA|DestArgs] [Eq|Eqs] [RE | RS] :- + Ap = {{ eq_f }}, + coq.mk-app Ap [DTy,ITyTy,Eta,SA,DA,Eq] R, + coq.elaborate-skeleton R _ RE ok, + mk-aps-etas DestTys ITyTy Etas SrcArgs DestArgs Eqs RS. + +% K comes with type arguments already applied. +pred mk-ith-eta i:int, i:list term, i:list term, i:list term, i:term, o:term. +mk-ith-eta I MArgs DestArgs DestTys K FR :- + J is I - 1, + std.take J DestArgs Done, % list of args already processed. + std.drop I MArgs MTODO, % list of args to yet process + std.nth J DestTys CurrTy, + (pi curr\ + coq.mk-app K {std.append Done [curr|MTODO]} (KArgs curr)), + FR = fun `R` CurrTy (r\ (KArgs r)). + + +% KDest comes with the type arguments already applied. +pred mk-etas-priv i:list term, i:list term, i:list term, i:int, i:int, i: term, o:list term. +mk-etas-priv _ _ _ M N _ [] :- M > N. +mk-etas-priv SrcArgs DestArgs DestTys I N KDest [R| RS] :- + J is I + 1, + mk-ith-eta I SrcArgs DestArgs DestTys KDest R, + mk-etas-priv SrcArgs DestArgs DestTys J N KDest RS. + +pred mk-etas i:list term, i:list term, i:list term, i: term, o:list term. +mk-etas SrcArgs DestArgs TyDest KAppTyArgs REtas :- + mk-etas-priv SrcArgs DestArgs TyDest 1 {std.length DestArgs} KAppTyArgs REtas. + +pred compose-path i:list term, i:term, i:term o: term. +compose-path [] End _ End. +compose-path [Argk|Args] End ITy {{ @eq_trans lp:ITy _ _ _ lp:Argk lp:R }} :- + compose-path Args End ITy R. + +% List of src args, list of dest args and their types, K applied to type parameters, equalities src = dest, type of K TyParam Dest. +% returns (ap eta1 s1 d1 e1) @ ... @ ap etan sn dn en. +pred mk-chain i:list term, i:list term, i:list term, i:term, i:list term, i:term, i:term, o:term. +mk-chain SrcArgs DestArgs DestArgsTy K Eqs ITyTy RHS R :- + mk-etas SrcArgs DestArgs DestArgsTy K REtas, + mk-aps-etas DestArgsTy ITyTy REtas SrcArgs DestArgs Eqs Raps, + compose-path Raps {{ @eq_refl lp:ITyTy lp:RHS }} ITyTy RSkel, + coq.elaborate-skeleton RSkel _ R ok. + +pred name-ij i:string, i:int, i:int, i:inductive, i:constructor, i:list term, i: constructor -> int -> constant -> prop, o:list prop. +name-ij _ _ _ _ _ [] _ []. +name-ij FName I J GR Kn [InjTy|InjTyss] F [Clause|Clauses] :- + Jn is J + 1, + NameIJ is {std.any->string FName} ^ {std.any->string I} ^ {std.any->string J}, + coq.env.add-const NameIJ InjTy _ _ C, + Clause = (F Kn J C), + name-ij FName I Jn GR Kn InjTyss F Clauses. + +% Prefix, current constructor, an inductive, its constructors, list of list of terms to name +pred name-ijs i:string, i:int, i:inductive, i:list constructor, i:list (list term), i: constructor -> int -> constant -> prop, o:list (list prop). +name-ijs _ _ _ [] [] _ []. +name-ijs FName I GR [Kn | KNs] [InjTys | InjTyss] F [Clauses | Clausess] :- + In is I + 1, + name-ij FName I 1 GR Kn InjTys F Clauses, + name-ijs FName In GR KNs InjTyss F Clausess. + +} \ No newline at end of file diff --git a/detailed/Detailed_injijK.v b/detailed/Detailed_injijK.v index 00410ed0..946702a7 100644 --- a/detailed/Detailed_injijK.v +++ b/detailed/Detailed_injijK.v @@ -1,7 +1,292 @@ -From Trocq Require Import mR Rm. +From Coq Require Import ssreflect ssrfun ssrbool. +From Trocq.Algo Require Import mR Rm. +From Trocq.Tests Require Import coverage. +From Trocq Require Import HoTT_additions Hierarchy. +Unset Uniform Inductive Parameters. -Elpi Command test. -Print Wrap_mR. -Print Wrap_Rm. +Elpi derive.param2 False. +Elpi derive.mymap False. +Elpi derive.projK False. +Elpi derive.injections False. +Elpi derive.isK False. +Elpi derive.mR False. +Elpi derive.Rm False. + +Notation False_Pred := (fun w1 w2 wR => False_mR w1 w2 (False_Rm w1 w2 wR) = wR) (only parsing). +Definition False_mRRmK : forall (w1 w2 : False) (wR : False_R w1 w2), False_mR w1 w2 (False_Rm w1 w2 wR) = wR. +Proof. +refine (fun f1 f2 fR => _). +exact (False_R_ind False_Pred f1 f2 fR). +Defined. + +Elpi derive.param2 Unit. +Elpi derive.mymap Unit. +Elpi derive.projK Unit. +Elpi derive.injections Unit. +Elpi derive.isK Unit. +Elpi derive.mR Unit. +Elpi derive.Rm Unit. + +Notation Unit_Pred := (fun u1 u2 uR => Unit_mR u1 u2 (Unit_Rm u1 u2 uR) = uR). +Definition Unit_mRRmK : forall (w1 w2 : Unit) (wR : Unit_R w1 w2), Unit_mR w1 w2 (Unit_Rm w1 w2 wR) = wR. +Proof. +refine (fun u1 u2 uR=> _). +refine (Unit_R_ind Unit_Pred _ u1 u2 uR). +- exact (@eq_refl (Unit_R TT TT) TT_R). +Defined. + +Elpi derive.param2 Bool. +Elpi derive.mymap Bool. +Elpi derive.isK Bool. +Elpi derive.mR Bool. +Elpi derive.Rm Bool. + +Notation Bool_Pred := (fun b1 b2 bR => Bool_mR b1 b2 (Bool_Rm b1 b2 bR) = bR). +Definition Bool_mRRmK : forall (w1 w2 : Bool) (wR : Bool_R w1 w2), Bool_mR w1 w2 (Bool_Rm w1 w2 wR) = wR. +Proof. +refine (fun b1 b2 bR=> _). +refine (Bool_R_ind Bool_Pred _ _ b1 b2 bR). +- exact (@eq_refl (Bool_R Falseb Falseb) Falseb_R). +- exact (@eq_refl (Bool_R Trueb Trueb) Trueb_R). +Defined. + +Elpi derive.param2 Wrap. +Elpi derive.mymap Wrap. +Elpi derive.projK Wrap. +Elpi derive.injections Wrap. +Elpi derive.mR Wrap. +Elpi derive.Rm Wrap. + +Definition conv (A : Type) (x y : A) (p: x = y) + (P : forall x0 : A, x = x0 -> Prop) (P0 : P x eq_refl) := + match p as p0 in _ = t return (P t p0) + with eq_refl => P0 end. + + +Notation Wrap_Pred_inj11K := (fun (u1 u2 :Unit) (p : u1 = u2) => +(Wrap_injections11 u1 u2 + (bcongr.eq_f Unit Wrap (fun R : Unit => KWrap1 R) u1 u2 p) = p)) (only parsing). +Definition Wrap_inj11K : + forall (u1 u2 : Unit) (p : u1 = u2), + Wrap_Pred_inj11K u1 u2 p. +Proof. +refine (fun u1 u2 p1=> _). +refine (conv _ u1 u2 p1 (Wrap_Pred_inj11K u1) _). +exact (@eq_refl (@eq Unit u1 u1) (@eq_refl Unit u1)). +Defined. + +Notation Wrap_Pred := (fun w1 w2 wR => Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR). +Definition Wrap_mRRmK : forall (w1 w2 : Wrap) (wR : Wrap_R w1 w2), + Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. +Proof. +refine (fun w1 w2 wR=> _). +refine (Wrap_R_ind Wrap_Pred _ w1 w2 wR). +- refine (fun u1 u2 uR => _). +refine (@eq_ind_r _ (Unit_Rm u1 u2 uR) (fun t=> KWrap1_R u1 u2 (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR) _ _ (Wrap_inj11K (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))). +refine (@eq_ind_r _ uR (fun t => KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR) _ _ (Unit_mRRmK u1 u2 uR)). +exact (@eq_refl (Wrap_R (KWrap1 u1) (KWrap1 u2)) (KWrap1_R u1 u2 uR)). +Defined. + +Elpi derive.param2 WrapMore. +Elpi derive.mymap WrapMore. +Elpi derive.projK WrapMore. +Elpi derive.injections WrapMore. +Elpi derive.isK WrapMore. +Elpi derive.mR WrapMore. +Elpi derive.Rm WrapMore. + +Notation WrapMore_Pred_inj1K := + (fun (u1 u2 :Unit) (p : u1 = u2) (b1 b2 : Bool)(p2 : b1 = b2) f => + (f u1 u2 b1 b2 + ((bcongr.eq_f Unit WrapMore (fun R : Unit => KWrap R b1) u1 u2 p) @ (bcongr.eq_f Bool WrapMore (fun R : Bool => KWrap u2 R) b1 b2 p2)))) (only parsing). + +Notation WrapMore_Pred_inj11K := + (fun (u1 u2 :Unit) (p : u1 = u2) (b1 b2 : Bool)(p2 : b1 = b2)=> + (WrapMore_Pred_inj1K u1 u2 p b1 b2 p2 WrapMore_injections11) = p) (only parsing). + +Notation WrapMore_Pred_inj12K := + (fun (u1 u2 :Unit) (p : u1 = u2) (b1 b2 : Bool)(p2 : b1 = b2)=> + (WrapMore_Pred_inj1K u1 u2 p b1 b2 p2 WrapMore_injections12) = p2) (only parsing). + +Definition WrapMore_inj11K : + forall (u1 u2 : Unit) (p : u1 = u2), + forall (b1 b2 : Bool) (p2 : b1 = b2), +WrapMore_Pred_inj11K u1 u2 p b1 b2 p2. +Proof. +refine (fun u1 u2 p1=> _). +refine (fun b1 b2 p2=> _). +refine (conv _ u1 u2 p1 (fun (t : Unit) (p : u1 = t) => (WrapMore_Pred_inj11K u1 t p b1 b2 p2)) _). +refine (conv _ b1 b2 p2 (fun (t : Bool) (p : b1 = t) => (WrapMore_Pred_inj11K u1 u1 1 b1 t p)) _). +exact (@eq_refl (@eq Unit u1 u1) (@eq_refl Unit u1)). +Defined. + +Definition WrapMore_inj12K : + forall (u1 u2 : Unit) (p : u1 = u2), + forall (b1 b2 : Bool) (p2 : b1 = b2), + WrapMore_Pred_inj12K u1 u2 p b1 b2 p2. +Proof. +refine (fun u1 u2 p1=> _). +refine (fun b1 b2 p2=> _). +refine (conv _ u1 u2 p1 (fun (t : Unit) (p : u1 = t) => (WrapMore_Pred_inj12K u1 t p b1 b2 p2)) _). +refine (conv _ b1 b2 p2 (fun (t : Bool) (p : b1 = t) => (WrapMore_Pred_inj12K u1 u1 1 b1 t p)) _). +exact (@eq_refl (@eq Bool b1 b1) (@eq_refl Bool b1)). +Defined. + +Notation WrapMore_Pred_inj2K := + (fun (w1 w2 :Wrap) (p : w1 = w2) f => + (f w1 w2 + (bcongr.eq_f Wrap WrapMore (fun R : Wrap => KWrapWrap R) w1 w2 p))) (only parsing). + +Notation WrapMore_Pred_inj21K := + (fun (w1 w2 :Wrap) (p : w1 = w2) => + WrapMore_Pred_inj2K w1 w2 p WrapMore_injections21 = p) (only parsing). + +Definition WrapMore_inj21K : + forall (w1 w2 : Wrap) (p : w1 = w2), + WrapMore_Pred_inj21K w1 w2 p. +Proof. +refine (fun w1 w2 p=> _). +refine (conv _ w1 w2 p (fun t p => WrapMore_Pred_inj21K w1 t p) _). +exact (@eq_refl (@eq Wrap w1 w1) (@eq_refl Wrap w1)). +Defined. + +Notation WrapMore_Pred_inj3K := + (fun (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6) f => + (f u1 u2 u3 u4 u5 u6 + ((bcongr.eq_f Unit WrapMore (fun R : Unit => F R u3 u5) u1 u2 p) + @ (bcongr.eq_f Unit WrapMore (fun R : Unit => F u2 R u5) u3 u4 p2) + @ (bcongr.eq_f Unit WrapMore (fun R : Unit => F u2 u4 R) u5 u6 p3)))) (only parsing). + +Notation WrapMore_Pred_inj31K := + (fun (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6) => + WrapMore_Pred_inj3K u1 u2 p u3 u4 p2 u5 u6 p3 WrapMore_injections31 = p )(only parsing). + +Notation WrapMore_Pred_inj32K := + (fun (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6) => + WrapMore_Pred_inj3K u1 u2 p u3 u4 p2 u5 u6 p3 WrapMore_injections32 = p2 )(only parsing). + +Notation WrapMore_Pred_inj33K := + (fun (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6) => + WrapMore_Pred_inj3K u1 u2 p u3 u4 p2 u5 u6 p3 WrapMore_injections33 = p3 )(only parsing). + +Definition WrapMore_inj31K : + forall (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6), + WrapMore_Pred_inj31K u1 u2 p u3 u4 p2 u5 u6 p3. +Proof. +refine (fun u1 u2 p=> _). +refine (fun u3 u4 p2=> _). +refine (fun u5 u6 p3=> _). +refine (conv _ u1 u2 p (fun t p => WrapMore_Pred_inj31K u1 t p u3 u4 p2 u5 u6 p3) _). +refine (conv _ u3 u4 p2 (fun t p => WrapMore_Pred_inj31K u1 u1 1 u3 t p u5 u6 p3) _). +refine (conv _ u5 u6 p3 (fun t p => WrapMore_Pred_inj31K u1 u1 1 u3 u3 1 u5 t p) _). +refine (@eq_refl (@eq Unit u1 u1) (@eq_refl Unit u1)). +Defined. + +Definition WrapMore_inj32K : + forall (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6), + WrapMore_Pred_inj32K u1 u2 p u3 u4 p2 u5 u6 p3. +Proof. +refine (fun u1 u2 p=> _). +refine (fun u3 u4 p2=> _). +refine (fun u5 u6 p3=> _). +refine (conv _ u1 u2 p ((fun t p => WrapMore_Pred_inj32K u1 t p u3 u4 p2 u5 u6 p3)) _). +refine (conv _ u3 u4 p2 ((fun t p => WrapMore_Pred_inj32K u1 u1 1 u3 t p u5 u6 p3)) _). +refine (conv _ u5 u6 p3 ((fun t p => WrapMore_Pred_inj32K u1 u1 1 u3 u3 1 u5 t p) ) _). +refine (@eq_refl (@eq Unit u3 u3) (@eq_refl Unit u3)). +Defined. + +Definition WrapMore_inj33K : + forall (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6), + WrapMore_Pred_inj33K u1 u2 p u3 u4 p2 u5 u6 p3. +Proof. +refine (fun u1 u2 p=> _). +refine (fun u3 u4 p2=> _). +refine (fun u5 u6 p3=> _). +refine (conv _ u1 u2 p (fun t p => WrapMore_Pred_inj33K u1 t p u3 u4 p2 u5 u6 p3) _). +refine (conv _ u3 u4 p2 (fun t p => WrapMore_Pred_inj33K u1 u1 1 u3 t p u5 u6 p3) _). +refine (conv _ u5 u6 p3 (fun t p => WrapMore_Pred_inj33K u1 u1 1 u3 u3 1 u5 t p) _). +refine (@eq_refl (@eq Unit u5 u5) (@eq_refl Unit u5)). +Defined. + +Elpi derive.param2 Nat. +Elpi derive.mymap Nat. +Elpi derive.projK Nat. +Elpi derive.injections Nat. +Elpi derive.isK Nat. +Elpi derive.mR Nat. +Elpi derive.Rm Nat. + +Notation nat_Pred_inj2K := + (fun (n1 n2 : Nat) (p : n1 = n2) f => + f n1 n2 (bcongr.eq_f Nat Nat (fun R => S' R) n1 n2 p)) (only parsing). +Notation nat_Pred_inj21K := + (fun (n1 n2 : Nat) (p : n1 = n2) => + nat_Pred_inj2K n1 n2 p Nat_injections21 = p) (only parsing). + +Definition nat_inj21K : + forall (n1 n2 : Nat) (p : n1 = n2), + nat_Pred_inj21K n1 n2 p. +Proof. +refine (fun n1 n2 p=> _). +refine (conv _ n1 n2 p (fun t p => nat_Pred_inj21K n1 t p) _). +refine (@eq_refl (@eq Nat n1 n1) (@eq_refl Nat n1)). +Defined. + +Elpi derive.param2 Box. +Elpi derive.mymap Box. +Elpi derive.projK Box. +Elpi derive.injections Box. +Elpi derive.isK Box. +Elpi derive.mR Box. +Elpi derive.Rm Box. + +Notation Box_Pred_inj1K := + (fun (A2: Type) (a1 a2 : A2) (p : a1 = a2) f => + f A2 a1 a2 (bcongr.eq_f A2 (@Box A2) (fun R => @B A2 R) a1 a2 p)) (only parsing). + +Notation Box_Pred_inj11K := + (fun (A2: Type) (a1 a2 : A2) (p : a1 = a2) => + Box_Pred_inj1K A2 a1 a2 p Box_injections11 = p) (only parsing). + +Definition Box_inj11K : + forall (A2: Type) (a1 a2 : A2) (p : a1 = a2), + Box_Pred_inj11K A2 a1 a2 p. +Proof. +refine (fun A2=> _). +refine (fun a1 a2 p=> _). +refine (conv A2 a1 a2 p (fun t p => Box_Pred_inj11K A2 a1 t p) _). +refine (@eq_refl (@eq A2 a1 a1) (@eq_refl A2 a1)). +Defined. + +Elpi derive.param2 Option. +Elpi derive.mymap Option. +Elpi derive.projK Option. +Elpi derive.injections Option. +Elpi derive.isK Option. +Elpi derive.mR Option. +Elpi derive.Rm Option. + +Elpi derive.param2 Prod. +Elpi derive.mymap Prod. +Elpi derive.projK Prod. +Elpi derive.injections Prod. +Elpi derive.isK Prod. +Elpi derive.mR Prod. +Elpi derive.Rm Prod. + +Elpi derive.param2 ThreeTypes. +Elpi derive.mymap ThreeTypes. +Elpi derive.projK ThreeTypes. +Elpi derive.injections ThreeTypes. +Elpi derive.isK ThreeTypes. +Elpi derive.mR ThreeTypes. +Elpi derive.Rm ThreeTypes. + +Elpi derive.param2 List. +Elpi derive.mymap List. +Elpi derive.projK List. +Elpi derive.injections List. +Elpi derive.isK List. +Elpi derive.mR List. +Elpi derive.Rm List. -Goal forall (w1 w2 : Wrap) (wR : Wrap_R w1 w2), Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. \ No newline at end of file diff --git a/tests/test_injK.v b/tests/test_injK.v new file mode 100644 index 00000000..cb6c578c --- /dev/null +++ b/tests/test_injK.v @@ -0,0 +1,48 @@ +From Trocq.Algo Require Import injK. +From Trocq.Tests Require Import coverage. +From Trocq Require Import Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi derive.projK False. +Elpi derive.injections False. +Elpi derive.injectionsK False. + +Elpi derive.projK Unit. +Elpi derive.injections Unit. +Elpi derive.injectionsK Unit. + +Elpi derive.projK Bool. +Elpi derive.injections Bool. +Elpi derive.injectionsK Bool. + +Elpi derive.projK Wrap. +Elpi derive.injections Wrap. +Elpi derive.injectionsK Wrap. + +Elpi derive.projK WrapMore. +Elpi derive.injections WrapMore. +Elpi derive.injectionsK WrapMore. + +Elpi derive.projK Nat. +Elpi derive.injections Nat. +Elpi derive.injectionsK Nat. + +Elpi derive.projK Box. +Elpi derive.injections Box. +Elpi derive.injectionsK Box. + +Elpi derive.projK Option. +Elpi derive.injections Option. +Elpi derive.injectionsK Option. + +Elpi derive.projK Prod. +Elpi derive.injections Prod. +Elpi derive.injectionsK Prod. + +Elpi derive.projK ThreeTypes. +Elpi derive.injections ThreeTypes. +Elpi derive.injectionsK ThreeTypes. + +Elpi derive.projK List. +Elpi derive.injections List. +Elpi derive.injectionsK List. \ No newline at end of file From 9f02a9fc5ac6ca999503ce9d9404c612899cbc55 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Tue, 2 Sep 2025 13:52:48 +0200 Subject: [PATCH 08/42] type of mRRmK mRRmK of False mRRmK body, many constructors 0 args. Unit, Bool, etc fixing imports + porting to elpi 3 --- algo/Rm.elpi | 8 +- algo/Rm.v | 4 +- algo/common_algo.elpi | 84 +++++++++--- algo/injK.v | 18 +-- algo/mR.elpi | 4 +- algo/mRRmK.elpi | 166 ++++++++++++++++++++++++ algo/mRRmK.v | 52 ++++++++ algo/mymap.elpi | 1 + algo/utils.elpi | 6 +- detailed/Detailed_injijK.v | 36 ------ detailed/Detailed_mRRmK.v | 258 +++++++++++++++++++++++++++++++++++++ std/_CoqProject | 17 +++ tests/test_mRRmK.v | 104 +++++++++++++++ 13 files changed, 679 insertions(+), 79 deletions(-) create mode 100644 algo/mRRmK.elpi create mode 100644 algo/mRRmK.v create mode 100644 detailed/Detailed_mRRmK.v create mode 100644 tests/test_mRRmK.v diff --git a/algo/Rm.elpi b/algo/Rm.elpi index 220243ec..ca905f69 100644 --- a/algo/Rm.elpi +++ b/algo/Rm.elpi @@ -1,4 +1,4 @@ -shorten derive.common-algo.{mk-mR-type}. +shorten derive.common-algo.{mk-mR-type-Rm}. shorten derive.algo-utils.{mk-chain}. namespace derive.Rm { @@ -53,7 +53,7 @@ process-args Ksrc Kdest N TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN @pi-decl ARN (ARTy a1 a2) ar\ coq.mk-app Ksrc [a1] (NewKS a1), coq.mk-app Kdest [a2] (NewKD a2), - (param a2 a1 ar => + (param a2 a1 ar =!=> process-args (NewKS a1) (NewKD a2) M TyArgsNo (Bo a1 a2 ar) Goal TySrc TyDest ITyTy (R a1 a2 ar)), % if the type of the argument is an instance of the inductive type add an induction hypothesis whd ITyTy _ Ind _, @@ -147,7 +147,7 @@ main GR Prefix Clauses :- std.do! [ param Ind Ind TR, coq.typecheck TR TRTy _, mymap-def Ind IndMap, - mk-mR-type TyParamNo TRTy IndMap {{ Type }} TR tt MRTy, + mk-mR-type-Rm TyParamNo TRTy IndMap {{ Type }} TR MRTy, coq.elaborate-skeleton MRTy _ MRTyE ok, TR = global (indt GRR), coq.gref->id (indt GRR) Rname, @@ -157,7 +157,7 @@ main GR Prefix Clauses :- std.do! [ coq.env.indt GRR _ _ _ _ _ KTyRs, std.map KNs (x\ r\ r = (global (indc x))) Ks, implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KTyRs Pred (global RInd) R, - coq.elaborate-skeleton R MRTyE Re ok, + coq.elaborate-skeleton R MRTyE Re E, Name is Prefix ^ "Rm", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName Re MRTyE _ C, diff --git a/algo/Rm.v b/algo/Rm.v index 484b2bfb..e06b7686 100644 --- a/algo/Rm.v +++ b/algo/Rm.v @@ -8,7 +8,8 @@ From elpi.apps Require Import derive.param2. From elpi.apps Require Import derive.bcongr. (* for eq_f register *) From Trocq.Algo Require Import mymap. From elpi.apps Require Import derive.induction. -From Trocq Require Import HoTT_additions Hierarchy. +(* From Trocq Require Import HoTT_additions Hierarchy. *) +From Trocq Require Import Hierarchy. Unset Uniform Inductive Parameters. Elpi Db derive.Rm.db lp:{{ @@ -29,6 +30,7 @@ Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.mymap.db. Elpi Accumulate File common. Elpi Accumulate File algo_utils. +Elpi Accumulate Db Header derive.Rm.db. Elpi Accumulate Db derive.Rm.db. Elpi Accumulate File Rm. Elpi Accumulate lp:{{ diff --git a/algo/common_algo.elpi b/algo/common_algo.elpi index 1e63b9e9..a67dfadd 100644 --- a/algo/common_algo.elpi +++ b/algo/common_algo.elpi @@ -1,21 +1,31 @@ namespace derive.common-algo { -pred rel-mode i:bool o:term. -rel-mode ff {{ Param2a0.Rel }}. -rel-mode tt {{ Param2b0.Rel }}. +pred rel-mode i:int o:term. +rel-mode 0 {{ Param2a0.Rel }}. +rel-mode 1 {{ Param2b0.Rel }}. +rel-mode 2 {{ Param40.Rel }}. pred swap i:term, i:term, i:bool, o:term, o:term. swap A B tt B A. swap A B ff A B. % Reached a sort, return map L = R -> IR. -pred mk-return i:term, i:term, i:term, i:bool, i:term, o:term. -mk-return ML MR Rel Swap ITyTy2 R :- +pred mk-impl-return i:term, i:term, i:term, i:bool, i:term, o:term. +mk-impl-return ML MR Rel SwapB ITyTy2 R :- Map = {{ @eq lp:ITyTy2 lp:ML lp:MR }}, - swap Map Rel Swap First Second, + swap Map Rel SwapB First Second, R = prod `_` First _\ Second. +% 0 is mR +% 1 is Rm +% 2 is mRRmK +pred mk-return i:term, i:term, i:term, i:int, i:term, o:term. +mk-return ML MR Rel 0 ITyTy2 R :- + mk-impl-return ML MR Rel ff ITyTy2 R. +mk-return ML MR Rel 1 ITyTy2 R :- + mk-impl-return ML MR Rel tt ITyTy2 R. +% mk-return ML MR Rel % The number of Type parameters in T % Type of inductive T, @@ -25,31 +35,69 @@ mk-return ML MR Rel Swap ITyTy2 R :- % Rel type of TR applied to arguments % Returns the type of map in R for T % X is the first inductive, Y is the second inductive. -pred mk-mR-type i:int, i:term, i:term, i:term, i:term, i:bool, o:term. +pred mk-mR-type-priv i:int, i:term, i:term, i:term, i:term, i:int, i:list term, i: (pred i:term, o:term), i: (pred i:term, o:term), o:term. % Introducing X and Y. % The RHS of the equality is Y. -mk-mR-type 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- + (Swap = 0 ; Swap = 1), @pi-decl IN1 ITyTy x\ @pi-decl IN2 ITyTy2 y\ - sigma NewML NewMR NewRel\ - coq.mk-app ML [x] NewML, + sigma NewML NewMR NewRel L\ + std.rev LRev L, + coq.mk-app ML {std.append L [x]} NewML, NewMR = y, - coq.mk-app Rel [x,y] NewRel, + coq.mk-app Rel {std.append L [x,y]} NewRel, mk-return NewML NewMR NewRel Swap ITyTy2 (R x y). - % mk-mR-type 0 (Bo x y) NewML NewMR NewRel Swap (R x y). +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel Swap LRev MR-DB RM-DB + (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ prod `IR` (RelTy x y) iR\ (R x y iR)) :- + Swap = 2, + std.rev LRev L, + @pi-decl IN1 ITyTy x\ + @pi-decl IN2 ITyTy2 y\ + coq.mk-app Rel {std.append L [x,y]} (RelTy x y), + @pi-decl `IR` (RelTy x y) iR\ + % sigma NewML NewMR NewRel L\ + whd ITyTy2 [] Ind _, + RM-DB Ind RInMap, + coq.mk-app RInMap {std.append L [x,y,iR]} (Rm x y iR), + MR-DB Ind MapInR, + coq.mk-app MapInR {std.append L [x,y,(Rm x y iR)]} (MRRM x y iR), + (R x y iR) = {{ @eq _ lp:{{MRRM x y iR}} lp:iR }}. % Process two type parameters + 1 relation at a time. % Apply these parameters to the LHS of the equation. -mk-mR-type N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel Swap +mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ lp:AR lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- M is N - 1, rel-mode Swap ARSkel, coq.elaborate-skeleton ARSkel _ AR ok, pi a1 a2 ar\ - sigma NewML NewMR NewRel\ - coq.mk-app ML [a1, a2, ar] NewML, - NewMR = a2, - coq.mk-app Rel [a1,a2,ar] NewRel, - mk-mR-type M (Bo a1 a2 ar) NewML NewMR NewRel Swap (R a1 a2 ar). + sigma NewL\ + std.append [ar,a2,a1] L NewL, + mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR-DB RM-DB (R a1 a2 ar). %dummy newMR + +pred mk-mR-type-mR i:int, i:term, i:term, i:term, i:term, o:term. +mk-mR-type-mR N T ML MR Rel RTy :- + + % (mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ + % (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- + % (Swap = 0 ; Swap = 1), + % @pi-decl IN1 ITyTy x\ + % @pi-decl IN2 ITyTy2 y\ + % sigma NewML NewMR NewRel L\ + % std.rev LRev L, + % coq.mk-app ML {std.append L [x]} NewML, + % NewMR = y, + % coq.mk-app Rel {std.append L [x,y]} NewRel, + % mk-return NewML NewMR NewRel Swap ITyTy2 (R x y)) => + mk-mR-type-priv N T ML MR Rel 0 [] Dummy Dummy RTy. + +pred mk-mR-type-Rm i:int, i:term, i:term, i:term, i:term, o:term. +mk-mR-type-Rm N T ML MR Rel R :- + mk-mR-type-priv N T ML MR Rel 1 [] Dummy Dummy R. +pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:term, i:(pred i:term, o:term) , i: (pred i:term, o:term), o:term. +% pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:term, i:(term -> term -> prop), i: (term -> term -> prop), o:term. +mk-mR-type-mRRmK N T ML MR Rel MR-DB RM-DB R :- + mk-mR-type-priv N T ML MR Rel 2 [] MR-DB RM-DB R. } \ No newline at end of file diff --git a/algo/injK.v b/algo/injK.v index f5bafa14..e7b46922 100644 --- a/algo/injK.v +++ b/algo/injK.v @@ -8,7 +8,8 @@ From elpi Require Import elpi. From elpi.apps Require Import derive.bcongr. (* for eq_f register *) (* From elpi.apps Require Import projK. *) -From Trocq Require Import HoTT_additions Hierarchy. +From Trocq Require Import Hierarchy. +(* From Trocq Require Import HoTT_additions Hierarchy. *) Unset Uniform Inductive Parameters. Definition conv (A : Type) (x y : A) (p: x = y) @@ -37,10 +38,6 @@ Elpi Accumulate File algo_utils. Elpi Accumulate Db derive.injectionsK.db. Elpi Accumulate Db derive.injections.db. Elpi Accumulate File injK. -(* Elpi Query lp:{{ - %std.nth 0 {std.iota 5} L. - R = {{lib:@elpi.derive.conv}}. -}}. *) Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, @@ -51,14 +48,3 @@ Elpi Accumulate lp:{{ pred usage. usage :- coq.error "Usage: derive.Rm ". }}. - -From Trocq.Tests Require Import coverage. -Elpi derive.projK Box. -Elpi derive.injections Box. -Elpi derive.injectionsK Box. -Elpi derive.projK WrapMore. -Elpi derive.injections WrapMore. -Elpi derive.injectionsK WrapMore. -Elpi derive.projK List. -Elpi derive.injections List. -Elpi derive.injectionsK List. \ No newline at end of file diff --git a/algo/mR.elpi b/algo/mR.elpi index 02488c95..beed9083 100644 --- a/algo/mR.elpi +++ b/algo/mR.elpi @@ -1,5 +1,5 @@ -shorten derive.common-algo.{mk-mR-type}. +shorten derive.common-algo.{mk-mR-type-mR}. namespace derive.mR { @@ -164,7 +164,7 @@ main GR Prefix Clauses :- std.do! [ param Ind Ind TR, coq.typecheck TR TRTy _, mymap-def Ind IndMap, - mk-mR-type UnifParamNo TRTy IndMap {{ Type }} TR ff MRTy, + mk-mR-type-mR UnifParamNo TRTy IndMap {{ Type }} TR MRTy, coq.elaborate-skeleton MRTy _ MRTyE ok, implement-mR UnifParamNo UnifParamNo MRTyE T, coq.elaborate-skeleton T MRTyE TE ok, diff --git a/algo/mRRmK.elpi b/algo/mRRmK.elpi new file mode 100644 index 00000000..802bbf5a --- /dev/null +++ b/algo/mRRmK.elpi @@ -0,0 +1,166 @@ +shorten derive.common-algo.{mk-mR-type-mRRmK}. +shorten derive.algo-utils.{mk-chain}. + +namespace derive.mRRmK { + +% Ksource, Kdest, remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, +% todo add KR to other cases +pred process-args i:term, i:term, i:int, i:int, i:term, i:term, i:list term, i:list term, i:term, i:term, o:term. +% zero more arguments to process +process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest ITyTy KR R:- + coq.mk-app Goal [Ksrc, Kdest, KR] EqTy, + %EqTy is the following type ImR i1 i2 (IRm i1 i2 ir) = ir for this specific branch + whd EqTy [] {{lib:@elpi.eq}} [IRTy,MRRM,IR], + + % whd MapA [] (global (indc _)) TySrcMappedArgs, + % whd B [] KDest TyDestArgs, + % std.drop TyArgsNo TySrcMappedArgs SrcArgs, + % std.drop TyArgsNo TyDestArgs DestArgs, + % coq.mk-app KDest {std.take TyArgsNo TyDestArgs} KAppTyArgs, + % mk-equalities TySrc ITyTy DestArgs Eqs, + + + % mk-rewrites SrcArgs DestArgs TyDest KAppTyArgs Eqs ITyTy B R, + % for every argument, rewrite under injKi and then the respective mRRmK + R = {{ eq_refl }}. + + % mk-chain SrcArgs DestArgs TyDest KAppTyArgs Eqs ITyTy B R. +% still have to process an arg +% process-args Ksrc Kdest N TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal TySrc TyDest ITyTy +% (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- +% M is N - 1, +% @pi-decl AN1 A1Ty a1\ +% @pi-decl AN2 A2Ty a2\ +% @pi-decl ARN (ARTy a1 a2) ar\ +% coq.mk-app Ksrc [a1] (NewKS a1), +% coq.mk-app Kdest [a2] (NewKD a2), +% (param a2 a1 ar => +% process-args (NewKS a1) (NewKD a2) M TyArgsNo (Bo a1 a2 ar) Goal TySrc TyDest ITyTy (R a1 a2 ar)), +% % if the type of the argument is an instance of the inductive type add an induction hypothesis +% whd ITyTy _ Ind _, +% whd A2Ty _ IndD _, +% if (Ind = IndD) +% (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), +% (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) +% (RF = R). + + +% todo: move to utils +% todo: document +pred type-of-args i:term, i:int, o:list term, o:list term. +type-of-args _ 0 [] []. +type-of-args (prod _AN1 ATy1 a1\ prod _AN2 ATy2 a2\ prod _ _ ar\ (Bo a1 a2 ar)) N [ATy1| SR] [ATy2 | DR] :- + M is N - 1, + pi a1 a2 ar\ + type-of-args (Bo a1 a2 ar) M SR DR. + +% todo: perhaps unify with Rm +% invariant: all type arguments were already processed. +% Constructor src, Constructor dest, Constructor dest Type, No of Arguments to process, +% constructorR Type, type of i2, something of type : i1 i2 iR => goal. +pred mkBranch i:term, i:term, i:int, i:term, i:term, i:term, i:term, o:term. +mkBranch KS KD N KTyR ITyTy Goal KR Eq:- + type-of-args KTyR N SrcArgs DestArgs, + whd ITyTy [] _ TyArgs, + process-args KS KD N {std.length TyArgs} KTyR Goal SrcArgs DestArgs ITyTy KR Eq. + + + +% todo perhaps unify with Rm mkBranches +pred mkBranches i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:list term, o:list term. +mkBranches [] [] [] [] _ _ [] []. +mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KTyR|KTyRs] ITyTy Goal [KR|KRs] [R|Rs] :- + mkBranch KS KD {coq.count-prods KTy} KTyR ITyTy Goal KR R, + mkBranches KsS KsD KTys KTyRs ITyTy Goal KRs Rs. + +% todo: perhaps unify with implement-Rm +% todo add KRs to other cases +pred implement-mRRmK i:int, i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:list term, o:term. +% Pred comes with Type parameters applied +% RInd comes with Type parameters applied +% implement-mRRmK 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KTyRs Pred RInd +% (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- +% coq.safe-dest-app ITy1 Ind _, +% Ind = (global (indt GR)), +% coq.env.recursive? GR, !, +% RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), +% coq.mk-app RInd [Pred] RIndP, +% @pi-decl `f` RT f\ +% @pi-decl IN1 ITy1 i1\ +% @pi-decl IN2 ITy2 i2\ +% @pi-decl ARN (ARTy i1 i2) ar\ +% (rm-db Ind f => +% mkBranches KsS KsD KTys KTyRs ITy2 Pred (Brs f)), +% std.append (Brs f) [i1,i2,ar] (IndArgs f i1 i2 ar), +% coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). +implement-mRRmK 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ir\ (EQ i1 i2 ir)) KsS KsD KTys KTyRs Pred RInd KRs + (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- + coq.mk-app RInd [Pred] RIndP, + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + @pi-decl ARN (ARTy i1 i2) ar\ + mkBranches KsS KsD KTys KTyRs ITy2 Pred KRs Brs, + std.append Brs [i1,i2,ar] (IndArgs i1 i2 ar), + coq.mk-app RIndP (IndArgs i1 i2 ar) (R i1 i2 ar). +% implement-mRRmK N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KTys KTyRs Pred RInd +% (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- +% M is N - 1, +% @pi-decl AN1 ATy1 a1\ %A1 : Type +% @pi-decl AN2 ATy2 a2\ %A2 : Type +% @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param2b0.Rel A1 A2 +% coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), + +% (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, +% coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, + +% coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), +% coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, + +% std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), +% std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), +% std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), +% std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), +% Rm = {{ @Trocq.Hierarchy.R_in_map }}, +% coq.mk-app Rm [a1, a2, ar] (RMS a1 a2 ar), +% % coq.elaborate-skeleton (RMS a1 a2 ar) _ (RM a1 a2 ar) ok, +% ar-db a1 a2 ar ==> +% rm-db a1 (RMS a1 a2 ar) ==> +% implement-mRRmK M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). + + + +pred main i:inductive, i:string, o:list prop. +main GR Prefix Clauses :- std.do! [ + + coq.env.indt GR _ TyParamNo _ _ KNs KTys, + Ind = (global (indt GR)), + param Ind Ind TR, + coq.typecheck TR TRTy _, + mymap-def Ind IndMap, + mk-mR-type-mRRmK TyParamNo TRTy IndMap {{ Type }} TR mR-db rm-db MRTy, + coq.elaborate-skeleton MRTy _ MRTyE ok, + % coq.say "MRTyE" MRTyE, + TR = global (indt GRR), + coq.gref->id (indt GRR) Rname, + RInductionName is Rname ^ "_ind", + coq.locate RInductionName RInd, + coq.prod->fun MRTyE Pred, + coq.env.indt GRR _ _ _ _ KNRs KTyRs, + std.map KNs (x\ r\ r = (global (indc x))) Ks, + std.map KNRs (x\ r\ r = (global (indc x))) KRs, + implement-mRRmK TyParamNo TyParamNo MRTyE Ks Ks KTys KTyRs Pred (global RInd) KRs R, + coq.say "Implemented mRRmK " R, + coq.elaborate-skeleton R MRTyE Re E, + coq.say "Erroring mRRmK E" E, + Name is Prefix ^ "mRRmK", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName Re MRTyE _ C, + I = global (indt GR), + Clauses = [], +% Clauses = [rm-done I, rm-db I (global (const C))], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.Rm.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/algo/mRRmK.v b/algo/mRRmK.v new file mode 100644 index 00000000..7af8af21 --- /dev/null +++ b/algo/mRRmK.v @@ -0,0 +1,52 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From Trocq.Algo Extra Dependency "mRRmK.elpi" as mRRmK. +From Trocq.Algo Require Import injK mR Rm. +From Trocq.Algo Extra Dependency "common_algo.elpi" as common. +(* From Trocq.Algo Extra Dependency "utils.elpi" as algo_utils. *) + +From elpi Require Import elpi. +From elpi.apps Require Import derive.param2. +(* From elpi.apps Require Import derive.bcongr. for eq_f register *) +(* From Trocq.Algo Require Import mymap. *) +(* From elpi.apps Require Import derive.induction. *) +From Trocq Require Import Hierarchy. +(* From Trocq Require Import HoTT_additions Hierarchy. *) +Unset Uniform Inductive Parameters. + +Elpi Db derive.mRRmK.db lp:{{ + % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. + pred ar-db i:term, i:term, o:term. + + % [mRRm-db T D] links a type T to its corresponding R in map. + pred rm-db i:term, o:term. + + % [mRRm-done T] mean T was already derived + pred rm-done o:term. +}}. + +Elpi Command derive.mRRmK. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate File common. +(* Elpi Accumulate File algo_utils. *) +Elpi Accumulate Db Header derive.injectionsK.db. +Elpi Accumulate Db derive.injectionsK.db. +Elpi Accumulate Db Header derive.mR.db. +Elpi Accumulate Db derive.mR.db. +Elpi Accumulate Db Header derive.Rm.db. +Elpi Accumulate Db derive.Rm.db. + +Elpi Accumulate Db derive.mRRmK.db. +Elpi Accumulate File mRRmK. +Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), + coq.gref->id (indt GR) Tname, + Prefix is Tname ^ "_", + derive.mRRmK.main GR Prefix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.mRRmK ". +}}. diff --git a/algo/mymap.elpi b/algo/mymap.elpi index bc32c541..036ec953 100644 --- a/algo/mymap.elpi +++ b/algo/mymap.elpi @@ -62,6 +62,7 @@ bo-k-args ParamsRev K _ Args Tys R :- % map.aux FRel R :- % coq.mk-app {{ map }} [FRel] 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 :- mymap-db T S FRel, diff --git a/algo/utils.elpi b/algo/utils.elpi index b48a2c40..4f4547fd 100644 --- a/algo/utils.elpi +++ b/algo/utils.elpi @@ -79,7 +79,8 @@ mk-chain SrcArgs DestArgs DestArgsTy K Eqs ITyTy RHS R :- compose-path Raps {{ @eq_refl lp:ITyTy lp:RHS }} ITyTy RSkel, coq.elaborate-skeleton RSkel _ R ok. -pred name-ij i:string, i:int, i:int, i:inductive, i:constructor, i:list term, i: constructor -> int -> constant -> prop, o:list prop. +% pred name-ij i:string, i:int, i:int, i:inductive, i:constructor, i:list term, i: constructor -> int -> constant -> prop, o:list prop. +pred name-ij i:string, i:int, i:int, i:inductive, i:constructor, i:list term, i: (pred i:constructor, i:int, o:constant), o:list prop. name-ij _ _ _ _ _ [] _ []. name-ij FName I J GR Kn [InjTy|InjTyss] F [Clause|Clauses] :- Jn is J + 1, @@ -89,7 +90,8 @@ name-ij FName I J GR Kn [InjTy|InjTyss] F [Clause|Clauses] :- name-ij FName I Jn GR Kn InjTyss F Clauses. % Prefix, current constructor, an inductive, its constructors, list of list of terms to name -pred name-ijs i:string, i:int, i:inductive, i:list constructor, i:list (list term), i: constructor -> int -> constant -> prop, o:list (list prop). +pred name-ijs i:string, i:int, i:inductive, i:list constructor, i:list (list term), i: (pred i:constructor, i:int, o:constant), o:list (list prop). +% pred name-ijs i:string, i:int, i:inductive, i:list constructor, i:list (list term), i: constructor -> int -> constant -> prop, o:list (list prop). name-ijs _ _ _ [] [] _ []. name-ijs FName I GR [Kn | KNs] [InjTys | InjTyss] F [Clauses | Clausess] :- In is I + 1, diff --git a/detailed/Detailed_injijK.v b/detailed/Detailed_injijK.v index 946702a7..7a25d544 100644 --- a/detailed/Detailed_injijK.v +++ b/detailed/Detailed_injijK.v @@ -12,13 +12,6 @@ Elpi derive.isK False. Elpi derive.mR False. Elpi derive.Rm False. -Notation False_Pred := (fun w1 w2 wR => False_mR w1 w2 (False_Rm w1 w2 wR) = wR) (only parsing). -Definition False_mRRmK : forall (w1 w2 : False) (wR : False_R w1 w2), False_mR w1 w2 (False_Rm w1 w2 wR) = wR. -Proof. -refine (fun f1 f2 fR => _). -exact (False_R_ind False_Pred f1 f2 fR). -Defined. - Elpi derive.param2 Unit. Elpi derive.mymap Unit. Elpi derive.projK Unit. @@ -27,29 +20,12 @@ Elpi derive.isK Unit. Elpi derive.mR Unit. Elpi derive.Rm Unit. -Notation Unit_Pred := (fun u1 u2 uR => Unit_mR u1 u2 (Unit_Rm u1 u2 uR) = uR). -Definition Unit_mRRmK : forall (w1 w2 : Unit) (wR : Unit_R w1 w2), Unit_mR w1 w2 (Unit_Rm w1 w2 wR) = wR. -Proof. -refine (fun u1 u2 uR=> _). -refine (Unit_R_ind Unit_Pred _ u1 u2 uR). -- exact (@eq_refl (Unit_R TT TT) TT_R). -Defined. - Elpi derive.param2 Bool. Elpi derive.mymap Bool. Elpi derive.isK Bool. Elpi derive.mR Bool. Elpi derive.Rm Bool. -Notation Bool_Pred := (fun b1 b2 bR => Bool_mR b1 b2 (Bool_Rm b1 b2 bR) = bR). -Definition Bool_mRRmK : forall (w1 w2 : Bool) (wR : Bool_R w1 w2), Bool_mR w1 w2 (Bool_Rm w1 w2 wR) = wR. -Proof. -refine (fun b1 b2 bR=> _). -refine (Bool_R_ind Bool_Pred _ _ b1 b2 bR). -- exact (@eq_refl (Bool_R Falseb Falseb) Falseb_R). -- exact (@eq_refl (Bool_R Trueb Trueb) Trueb_R). -Defined. - Elpi derive.param2 Wrap. Elpi derive.mymap Wrap. Elpi derive.projK Wrap. @@ -75,18 +51,6 @@ refine (conv _ u1 u2 p1 (Wrap_Pred_inj11K u1) _). exact (@eq_refl (@eq Unit u1 u1) (@eq_refl Unit u1)). Defined. -Notation Wrap_Pred := (fun w1 w2 wR => Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR). -Definition Wrap_mRRmK : forall (w1 w2 : Wrap) (wR : Wrap_R w1 w2), - Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. -Proof. -refine (fun w1 w2 wR=> _). -refine (Wrap_R_ind Wrap_Pred _ w1 w2 wR). -- refine (fun u1 u2 uR => _). -refine (@eq_ind_r _ (Unit_Rm u1 u2 uR) (fun t=> KWrap1_R u1 u2 (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR) _ _ (Wrap_inj11K (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))). -refine (@eq_ind_r _ uR (fun t => KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR) _ _ (Unit_mRRmK u1 u2 uR)). -exact (@eq_refl (Wrap_R (KWrap1 u1) (KWrap1 u2)) (KWrap1_R u1 u2 uR)). -Defined. - Elpi derive.param2 WrapMore. Elpi derive.mymap WrapMore. Elpi derive.projK WrapMore. diff --git a/detailed/Detailed_mRRmK.v b/detailed/Detailed_mRRmK.v new file mode 100644 index 00000000..a2204c2d --- /dev/null +++ b/detailed/Detailed_mRRmK.v @@ -0,0 +1,258 @@ +From Coq Require Import ssreflect ssrfun ssrbool. +From Trocq.Algo Require Import mR Rm injK. +From Trocq.Tests Require Import coverage. +From Trocq Require Import HoTT_additions Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi derive.param2 False. +Elpi derive.mymap False. +Elpi derive.projK False. +Elpi derive.injections False. +Elpi derive.isK False. +Elpi derive.mR False. +Elpi derive.Rm False. +Elpi derive.injectionsK False. + +Notation False_Pred := (fun w1 w2 wR => False_mR w1 w2 (False_Rm w1 w2 wR) = wR) (only parsing). +Definition False_mRRmK : forall (w1 w2 : False) (wR : False_R w1 w2), False_mR w1 w2 (False_Rm w1 w2 wR) = wR. +Proof. +refine (fun f1 f2 fR => _). +exact (False_R_ind False_Pred f1 f2 fR). +Defined. + +Elpi derive.param2 Unit. +Elpi derive.mymap Unit. +Elpi derive.projK Unit. +Elpi derive.injections Unit. +Elpi derive.isK Unit. +Elpi derive.mR Unit. +Elpi derive.Rm Unit. + +Notation Unit_Pred := (fun u1 u2 uR => Unit_mR u1 u2 (Unit_Rm u1 u2 uR) = uR). +Definition Unit_mRRmK : forall (w1 w2 : Unit) (wR : Unit_R w1 w2), Unit_mR w1 w2 (Unit_Rm w1 w2 wR) = wR. +Proof. +refine (fun u1 u2 uR=> _). +refine (Unit_R_ind Unit_Pred _ u1 u2 uR). +- exact (@eq_refl (Unit_R TT TT) TT_R). +Defined. + +Elpi derive.param2 Bool. +Elpi derive.mymap Bool. +Elpi derive.isK Bool. +Elpi derive.mR Bool. +Elpi derive.Rm Bool. + +Notation Bool_Pred := (fun b1 b2 bR => Bool_mR b1 b2 (Bool_Rm b1 b2 bR) = bR). +Definition Bool_mRRmK : forall (w1 w2 : Bool) (wR : Bool_R w1 w2), Bool_mR w1 w2 (Bool_Rm w1 w2 wR) = wR. +Proof. +refine (fun b1 b2 bR=> _). +refine (Bool_R_ind Bool_Pred _ _ b1 b2 bR). +- exact (@eq_refl (Bool_R Falseb Falseb) Falseb_R). +- exact (@eq_refl (Bool_R Trueb Trueb) Trueb_R). +Defined. + +Elpi derive.param2 Wrap. +Elpi derive.mymap Wrap. +Elpi derive.projK Wrap. +Elpi derive.injections Wrap. +Elpi derive.mR Wrap. +Elpi derive.Rm Wrap. +Elpi derive.injectionsK Wrap. + +Notation Wrap_Pred := (fun w1 w2 wR => Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR) (only parsing). +Definition Wrap_mRRmK : forall (w1 w2 : Wrap) (wR : Wrap_R w1 w2), + Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. +Proof. +refine (fun w1 w2 wR=> _). +refine (Wrap_R_ind Wrap_Pred _ w1 w2 wR). +- refine (fun u1 u2 uR => _). +refine (@eq_ind_r _ (Unit_Rm u1 u2 uR) (fun t=> KWrap1_R u1 u2 (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR) _ _ (Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))). +refine (@eq_ind_r _ uR (fun t => KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR) _ _ (Unit_mRRmK u1 u2 uR)). +exact (@eq_refl (Wrap_R (KWrap1 u1) (KWrap1 u2)) (KWrap1_R u1 u2 uR)). +Defined. + +Definition Wrap_mRRmK' : forall (w1 w2 : Wrap) (wR : Wrap_R w1 w2), + Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. +Proof. +refine (fun w1 w2 wR=> _). +refine (Wrap_R_ind Wrap_Pred _ w1 w2 wR). +- refine (fun u1 u2 uR => _). +refine (match +(Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))^ in _ = t +return KWrap1_R u1 u2 (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR +with eq_refl => _ end +). +refine (match (Unit_mRRmK u1 u2 uR)^ in _ = t +return KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR +with eq_refl => eq_refl end +). +Defined. + +Elpi derive.param2 WrapMore. +Elpi derive.mymap WrapMore. +Elpi derive.projK WrapMore. +Elpi derive.injections WrapMore. +Elpi derive.isK WrapMore. +Elpi derive.mR WrapMore. +Elpi derive.Rm WrapMore. +Elpi derive.injectionsK WrapMore. + +(* From elpi.apps Require Import eltac.rewrite. + +Axiom add_comm : forall x y, x + y = y + x. +Axiom mul_comm : forall x y, x * y = y * x. + +Goal (forall x : nat, 1 + x = x + 1) -> + forall y, 2 * ((y+y) + 1) = ((y + y)+1) * 2. +Proof. + intro H. + intro x. + eltac.rewrite H. + Show Proof. + eltac.rewrite mul_comm. + Show Proof. + exact eq_refl. +Defined. *) + +Notation WrapMore_Pred := (fun w1 w2 wR => WrapMore_mR w1 w2 (WrapMore_Rm w1 w2 wR) = wR) (only parsing). + +Definition WrapMore_mRRmK : + forall (w1 w2 : WrapMore) (wR: WrapMore_R w1 w2), + WrapMore_mR w1 w2 (WrapMore_Rm w1 w2 wR) = wR. +Proof. +refine (fun w1 w2 wR => _). +refine (WrapMore_R_ind WrapMore_Pred _ _ _ w1 w2 wR). +- refine (fun u1 u2 uR => _). + refine (fun b1 b2 bR => _). + refine (match (WrapMore_injK11 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^ in _ = t + return +KWrap_R u1 u2 (Unit_mR u1 u2 t) b1 b2 +(Bool_mR b1 b2 +(WrapMore_injections12 +(Unit_mymap u1) u2 (Bool_mymap b1) +b2 +(bcongr.eq_f Unit WrapMore +(KWrap^~ (Bool_mymap b1)) +(Unit_mymap u1) u2 +(Unit_Rm u1 u2 uR) @ +bcongr.eq_f Bool WrapMore +[eta KWrap u2] (Bool_mymap b1) b2 +(Bool_Rm b1 b2 bR)))) = +KWrap_R u1 u2 uR b1 b2 bR +with eq_refl => _ end). + refine (match (Unit_mRRmK _ _ uR)^ in _ = t return + KWrap_R u1 u2 t b1 b2 +(Bool_mR b1 b2 +(WrapMore_injections12 +(Unit_mymap u1) u2 (Bool_mymap b1) +b2 +(bcongr.eq_f Unit WrapMore +(KWrap^~ (Bool_mymap b1)) +(Unit_mymap u1) u2 +(Unit_Rm u1 u2 uR) @ +bcongr.eq_f Bool WrapMore +[eta KWrap u2] (Bool_mymap b1) b2 +(Bool_Rm b1 b2 bR)))) = +KWrap_R u1 u2 uR b1 b2 bR +with eq_refl => _ end). +refine (match (WrapMore_injK12 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^ in _ = t +return +KWrap_R u1 u2 uR b1 b2 +(Bool_mR b1 b2 t) = +KWrap_R u1 u2 uR b1 b2 bR +with eq_refl => _ end +). +refine (match (Bool_mRRmK _ _ bR)^ in _ = t return +KWrap_R u1 u2 uR b1 b2 t = +KWrap_R u1 u2 uR b1 b2 bR +with eq_refl => eq_refl end +). +- move=> wr1 wr2 wrR. +simpl. +by rewrite WrapMore_injK21 Wrap_mRRmK. +- move=> ? ? ? ? ? ? ? ? ?. + by rewrite /= WrapMore_injK31 WrapMore_injK32 WrapMore_injK33 !Unit_mRRmK. +Defined. + +Elpi derive.param2 Nat. +Elpi derive.mymap Nat. +Elpi derive.projK Nat. +Elpi derive.injections Nat. +Elpi derive.isK Nat. +Elpi derive.mR Nat. +Elpi derive.Rm Nat. +Elpi derive.injectionsK Nat. + +Notation Nat_Pred := (fun n1 n2 nR => Nat_mR n1 n2 (Nat_Rm n1 n2 nR) = nR) (only parsing). + +Definition Nat_mRRmK : + forall (n1 n2 : Nat ) (nR: Nat_R n1 n2), + Nat_mR n1 n2 (Nat_Rm n1 n2 nR) = nR. +Proof. + fix f 3. +refine (fun n1 n2 nR => _). +refine (Nat_R_ind Nat_Pred _ _ n1 n2 nR). +- exact eq_refl. +- refine (fun n1' n2' nR' Hrec=> _ ). +simpl. +by rewrite Nat_injK21 f. +Defined. + +Elpi derive.param2 Box. +Elpi derive.mymap Box. +Elpi derive.projK Box. +Elpi derive.injections Box. +Elpi derive.isK Box. +Elpi derive.mR Box. +Elpi derive.Rm Box. +Elpi derive.injectionsK Box. + +Notation Box_Pred := (fun A1 A2 (AR : Param40.Rel A1 A2) => fun b1 b2 bR => Box_mR A1 A2 AR b1 b2 (Box_Rm A1 A2 AR b1 b2 bR) = bR) (only parsing). + +Definition Box_mRRmK : +forall (A1 A2 : Type) (AR : Param40.Rel A1 A2), + forall (b1 : Box A1) (b2 : Box A2) (bR: Box_R A1 A2 AR b1 b2), + Box_mR A1 A2 AR b1 b2 (Box_Rm A1 A2 AR b1 b2 bR) = bR. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun b1 b2 bR=> Box_R_ind A1 A2 AR (Box_Pred A1 A2 AR) _ b1 b2 bR). +refine (fun a1 a2 aR=> _). +simpl. +by rewrite Box_injK11 (R_in_mapK AR a1 a2 aR). +Defined. + +Elpi derive.param2 Option. +Elpi derive.mymap Option. +Elpi derive.projK Option. +Elpi derive.injections Option. +Elpi derive.isK Option. +Elpi derive.mR Option. +Elpi derive.Rm Option. +Elpi derive.injectionsK Option. + +Elpi derive.param2 Prod. +Elpi derive.mymap Prod. +Elpi derive.projK Prod. +Elpi derive.injections Prod. +Elpi derive.isK Prod. +Elpi derive.mR Prod. +Elpi derive.Rm Prod. +Elpi derive.injectionsK Prod. + +Elpi derive.param2 ThreeTypes. +Elpi derive.mymap ThreeTypes. +Elpi derive.projK ThreeTypes. +Elpi derive.injections ThreeTypes. +Elpi derive.isK ThreeTypes. +Elpi derive.mR ThreeTypes. +Elpi derive.Rm ThreeTypes. +Elpi derive.injectionsK ThreeTypes. + +Elpi derive.param2 List. +Elpi derive.mymap List. +Elpi derive.projK List. +Elpi derive.injections List. +Elpi derive.isK List. +Elpi derive.mR List. +Elpi derive.Rm List. +Elpi derive.injectionsK List. diff --git a/std/_CoqProject b/std/_CoqProject index b88b3df3..7d445fba 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -28,3 +28,20 @@ generic/Param_trans.v generic/Param_vector.v generic/Trocq.v generic/Vernac.v + +-R ../algo Trocq.Algo +-R ../tests Trocq.Tests + +../tests/coverage.v +../algo/mymap.v +../tests/test_mymap.v +../algo/injection_lemmas.v +../tests/test_injection_lemmas.v +../algo/mR.v +../tests/test_mR.v +../algo/Rm.v +../tests/test_Rm.v +../algo/injK.v +../tests/test_injK.v +../algo/mRRmK.v +../tests/test_mRRmK.v \ No newline at end of file diff --git a/tests/test_mRRmK.v b/tests/test_mRRmK.v new file mode 100644 index 00000000..b329789f --- /dev/null +++ b/tests/test_mRRmK.v @@ -0,0 +1,104 @@ +From Trocq.Algo Require Import mR Rm injK mRRmK. +From Trocq.Tests Require Import coverage. +From Trocq Require Import Hierarchy. +Unset Uniform Inductive Parameters. + + +Elpi derive.param2 False. +Elpi derive.mymap False. +Elpi derive.projK False. +Elpi derive.injections False. +Elpi derive.isK False. +Elpi derive.mR False. +Elpi derive.Rm False. +Elpi derive.mRRmK False. + +Elpi derive.param2 Unit. +Elpi derive.mymap Unit. +Elpi derive.projK Unit. +Elpi derive.injections Unit. +Elpi derive.isK Unit. +Elpi derive.mR Unit. +Elpi derive.Rm Unit. +Elpi derive.mRRmK Unit. + +Elpi derive.param2 Bool. +Elpi derive.mymap Bool. +Elpi derive.projK Bool. +Elpi derive.injections Bool. +Elpi derive.isK Bool. +Elpi derive.mR Bool. +Elpi derive.Rm Bool. +Elpi derive.mRRmK Bool. + +Elpi derive.param2 Wrap. +Elpi derive.mymap Wrap. +Elpi derive.projK Wrap. +Elpi derive.injections Wrap. +Elpi derive.isK Wrap. +Elpi derive.mR Wrap. +Elpi derive.Rm Wrap. +Elpi derive.mRRmK Wrap. + +Elpi derive.param2 WrapMore. +Elpi derive.mymap WrapMore. +Elpi derive.projK WrapMore. +Elpi derive.injections WrapMore. +Elpi derive.isK WrapMore. +Elpi derive.mR WrapMore. +Elpi derive.Rm WrapMore. +Elpi derive.mRRmK WrapMore. + +Elpi derive.param2 Nat. +Elpi derive.mymap Nat. +Elpi derive.projK Nat. +Elpi derive.injections Nat. +Elpi derive.isK Nat. +Elpi derive.mR Nat. +Elpi derive.Rm Nat. +Elpi derive.mRRmK Nat. + +Elpi derive.param2 Box. +Elpi derive.mymap Box. +Elpi derive.projK Box. +Elpi derive.injections Box. +Elpi derive.isK Box. +Elpi derive.mR Box. +Elpi derive.Rm Box. +Elpi derive.mRRmK Box. + +Elpi derive.param2 Option. +Elpi derive.mymap Option. +Elpi derive.projK Option. +Elpi derive.injections Option. +Elpi derive.isK Option. +Elpi derive.mR Option. +Elpi derive.Rm Option. +Elpi derive.mRRmK Option. + +Elpi derive.param2 Prod. +Elpi derive.mymap Prod. +Elpi derive.projK Prod. +Elpi derive.injections Prod. +Elpi derive.isK Prod. +Elpi derive.mR Prod. +Elpi derive.Rm Prod. +Elpi derive.mRRmK Prod. + +Elpi derive.param2 ThreeTypes. +Elpi derive.mymap ThreeTypes. +Elpi derive.projK ThreeTypes. +Elpi derive.injections ThreeTypes. +Elpi derive.isK ThreeTypes. +Elpi derive.mR ThreeTypes. +Elpi derive.Rm ThreeTypes. +Elpi derive.mRRmK ThreeTypes. + +Elpi derive.param2 List. +Elpi derive.mymap List. +Elpi derive.projK List. +Elpi derive.injections List. +Elpi derive.isK List. +Elpi derive.mR List. +Elpi derive.Rm List. +Elpi derive.mRRmK List. \ No newline at end of file From db3bd6b78e1f857767df5b887229c960068737be Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 7 Jan 2026 22:34:31 +0100 Subject: [PATCH 09/42] changing structure fixing some duplicated files after the rebase --- algo/mymap.v | 55 -- generic/DetailedmR.v | 256 -------- generic/Rm.elpi | 207 ------- generic/Rm.v | 112 ---- generic/common_algo.elpi | 55 -- generic/injection_lemmas.elpi | 184 ------ generic/injection_lemmas.v | 101 ---- generic/mR.elpi | 180 ------ generic/mR.v | 154 ----- generic/mymap.elpi | 223 ------- generic/param2_inhab.elpi | 134 ----- generic/param2_inhab.v | 556 ------------------ generic/param2_trivial.elpi | 130 ---- generic/test_param2_inhab.v | 67 --- std/_CoqProject | 29 +- {detailed => std/algo/detailed}/DetailedRm.v | 3 +- .../algo/detailed}/Detailed_injijK.v | 7 +- .../algo/detailed}/Detailed_mRRmK.v | 35 +- {detailed => std/algo/detailed}/DetailedmR.v | 3 +- {algo => std/algo/elpi}/Rm.elpi | 0 {algo => std/algo/elpi}/common_algo.elpi | 0 {algo => std/algo/elpi}/injK.elpi | 0 {algo => std/algo/elpi}/injection_lemmas.elpi | 0 {algo => std/algo/elpi}/mR.elpi | 0 {algo => std/algo/elpi}/mRRmK.elpi | 0 {algo => std/algo/elpi}/mymap.elpi | 0 {algo => std/algo/elpi}/utils.elpi | 0 {tests => std/algo/tests}/coverage.v | 0 {tests => std/algo/tests}/test_Rm.v | 4 +- {tests => std/algo/tests}/test_injK.v | 4 +- .../algo/tests}/test_injection_lemmas.v | 4 +- {tests => std/algo/tests}/test_mR.v | 4 +- {tests => std/algo/tests}/test_mRRmK.v | 20 +- {tests => std/algo/tests}/test_mymap.v | 4 +- {algo => std/algo/theories}/Rm.v | 8 +- {algo => std/algo/theories}/injK.v | 6 +- .../algo/theories}/injection_lemmas.v | 4 +- {algo => std/algo/theories}/mR.v | 6 +- {algo => std/algo/theories}/mRRmK.v | 6 +- {generic => std/algo/theories}/mymap.v | 2 +- 40 files changed, 85 insertions(+), 2478 deletions(-) delete mode 100644 algo/mymap.v delete mode 100644 generic/DetailedmR.v delete mode 100644 generic/Rm.elpi delete mode 100644 generic/Rm.v delete mode 100644 generic/common_algo.elpi delete mode 100644 generic/injection_lemmas.elpi delete mode 100644 generic/injection_lemmas.v delete mode 100644 generic/mR.elpi delete mode 100644 generic/mR.v delete mode 100644 generic/mymap.elpi delete mode 100644 generic/param2_inhab.elpi delete mode 100644 generic/param2_inhab.v delete mode 100644 generic/param2_trivial.elpi delete mode 100644 generic/test_param2_inhab.v rename {detailed => std/algo/detailed}/DetailedRm.v (99%) rename {detailed => std/algo/detailed}/Detailed_injijK.v (98%) rename {detailed => std/algo/detailed}/Detailed_mRRmK.v (88%) rename {detailed => std/algo/detailed}/DetailedmR.v (99%) rename {algo => std/algo/elpi}/Rm.elpi (100%) rename {algo => std/algo/elpi}/common_algo.elpi (100%) rename {algo => std/algo/elpi}/injK.elpi (100%) rename {algo => std/algo/elpi}/injection_lemmas.elpi (100%) rename {algo => std/algo/elpi}/mR.elpi (100%) rename {algo => std/algo/elpi}/mRRmK.elpi (100%) rename {algo => std/algo/elpi}/mymap.elpi (100%) rename {algo => std/algo/elpi}/utils.elpi (100%) rename {tests => std/algo/tests}/coverage.v (100%) rename {tests => std/algo/tests}/test_Rm.v (92%) rename {tests => std/algo/tests}/test_injK.v (92%) rename {tests => std/algo/tests}/test_injection_lemmas.v (87%) rename {tests => std/algo/tests}/test_mR.v (95%) rename {tests => std/algo/tests}/test_mRRmK.v (86%) rename {tests => std/algo/tests}/test_mymap.v (81%) rename {algo => std/algo/theories}/Rm.v (85%) rename {algo => std/algo/theories}/injK.v (89%) rename {algo => std/algo/theories}/injection_lemmas.v (90%) rename {algo => std/algo/theories}/mR.v (89%) rename {algo => std/algo/theories}/mRRmK.v (90%) rename {generic => std/algo/theories}/mymap.v (96%) diff --git a/algo/mymap.v b/algo/mymap.v deleted file mode 100644 index 99aa99c3..00000000 --- a/algo/mymap.v +++ /dev/null @@ -1,55 +0,0 @@ -From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Algo Extra Dependency "mymap.elpi" as mymap. - -From elpi Require Import elpi. -From elpi.apps Require Import derive. -From Trocq Require Import Hierarchy. -Unset Uniform Inductive Parameters. - -Elpi Db derive.mymap.db lp:{{ - % [mymap-def I C] brings the constant defined for mapping inductive I. - pred mymap-def i:term, o:term. - - % [mymap T1 T2 D] for T1 and T2 brings a map D from T1 to T2. - pred mymap-db i:term, i:term, o:term. - - % [mymap-done T] mean T was already derived - pred mymap-done o:inductive. -}}. - -Elpi Command derive.mymap. -Elpi Accumulate File derive_hook. -Elpi Accumulate Db derive.mymap.db. -Elpi Accumulate File mymap. -Elpi Accumulate lp:{{ - main [str I] :- !, - coq.locate I (indt GR), - coq.gref->id (indt GR) Tname, - Prefix is Tname ^ "_", - %derive.mymap.main GR Prefix _. - - % derive.mymap.mk-map-ty A _ B _ {{ Param10.Rel lp:A lp:B }} F 0 [mymap-db A B F] => - % (derive.mymap.bo-k-args.aux K [A|As] [T|Ts] (prod _ S Ty) R :- - % mymap-db T S FRel, - % coq.mk-app {{ map }} [FRel] F, - % coq.mk-app F [A] FA, - % bo-k-args.aux {coq.mk-app K [FA]} As Ts (Ty FA) R) => - - derive.mymap.main GR Prefix _. - main _ :- usage. - - pred usage. - usage :- coq.error "Usage: derive.mymap ". -}}. - - -Elpi Query lp:{{ - coq.locate "option" (indt Option), - std.findall (mymap-def (global (indt Option)) _) Rules. % empty - %std.findall (mymap-db {{ option nat }} {{ option nat }} _) Rules. % non empty - %std.findall (mymap-db {{ nat }} {{ nat }} _) Rules. % non empty - std.findall (mymap-db {{ nat }} B C) Rules. % empty - std.findall (mymap-db A B C) Rules. % empty - std.findall (mymap-done _) Rules. % empty - -}}. diff --git a/generic/DetailedmR.v b/generic/DetailedmR.v deleted file mode 100644 index f4a887f2..00000000 --- a/generic/DetailedmR.v +++ /dev/null @@ -1,256 +0,0 @@ -From Coq Require Import ssreflect. -From elpi.apps.derive Require Import derive derive.param2. -From Trocq Require Import mymap injection_lemmas. -Require Import HoTT_additions Hierarchy. -Unset Uniform Inductive Parameters. -(* Unset Universe Polymorphism. *) -Unset Universe Minimization ToSet. - -Definition Unit := unit. - -Elpi derive.param2 unit. -Definition UnitR := unit_R. -(* Inductive UnitR : Unit -> Unit -> Type := - | tt_R : UnitR tt tt. *) - -Elpi derive.mymap unit. -Definition unit_map : unit -> unit := unit_mymap. -Definition Unit_mR : forall (u1 u2 : Unit), unit_map u1 = u2 -> UnitR u1 u2. -Proof. -refine (fun u1 => match u1 as u return - forall u2 : Unit, unit_map u = u2 -> UnitR u u2 - with - | tt => _ end - ). -refine (fun u2 => match u2 as u return - unit_map tt = u -> UnitR tt u - with - | tt => _ end). -refine (fun e => tt_R). -Defined. - -Definition Bool := bool. -Elpi derive.param2 bool. - -Definition BoolR := bool_R. -(* Inductive BoolR : Bool -> Bool -> Type := -| true_R : BoolR true true -| false_R : BoolR false false. *) - -Elpi derive.mymap bool. -Definition bool_map : Bool -> Bool := bool_mymap. -Definition Bool_mR : forall (u1 u2 : Bool), bool_map u1 = u2 -> BoolR u1 u2. -Proof. -refine (fun u1 : Bool => match u1 as u return - forall u2 : Bool, bool_map u = u2 -> BoolR u u2 - with - | true => _ - | false => _ - end - ). -+ refine (fun u2 : Bool => match u2 as u return - bool_map true = u -> BoolR true u - with - | true => _ - | false => _ - end - ). - - (* true true *) - refine (fun e => true_R). - - (* true false *) intros e; discriminate e. -+ refine (fun u2 : Bool => match u2 as u return - bool_map false = u -> BoolR false u - with - | true => _ - | false => _ - end - ). - - (* false true *) intros e; discriminate e. - - (* false false *) refine (fun e => false_R). -Defined. - -Inductive Wrap : Type := -| KWrap1 : unit -> Wrap. - -Elpi derive.param2 Wrap. -Definition WrapR := Wrap_R. -Elpi derive.mymap Wrap. - -Definition wrap_map := Wrap_mymap. -Elpi derive.projK Wrap. -Elpi derive.injections Wrap. -Definition wrap_mR : forall w1 w2, wrap_map w1 = w2 -> WrapR w1 w2. -Proof. -refine (fun w1=> match w1 as w return - forall w2, wrap_map w = w2 -> WrapR w w2 - with - | KWrap1 u1 => _ end). -- refine (fun w2=> match w2 as w return - wrap_map (KWrap1 u1) = w -> WrapR (KWrap1 u1) w - with - | KWrap1 u2 => _ end). - refine (fun e => KWrap1_R u1 u2 (Unit_mR u1 u2 (Wrap_injections11 (unit_map u1) u2 e))). -Defined. - -Definition Nat := nat. -Elpi derive.param2 nat. -Definition NatR := nat_R. - -Elpi derive.mymap nat. -Definition nat_map := nat_mymap. -Elpi derive.injections nat. -Print nat_injections21. - -Definition nat_mR : forall n1 n2, nat_map n1 = n2 -> NatR n1 n2. -Proof. -fix F 1. -refine (fun n1 => match n1 as n return - forall n2, nat_map n = n2 -> NatR n n2 - with - | O => _ - | S n1' => _ end). -+ (* O *) - refine (fun n2 => match n2 as n return - nat_map 0 = n -> NatR 0 n - with - | O => _ - | S n2' => _ end). - - (* O O *) - refine (fun e => O_R). - - (* O S n2' *) intros e; discriminate e. -+ (* S n' *) - refine (fun n2 => match n2 as n return - nat_map (S n1') = n -> NatR (S n1') n - with - | O => _ - | S n2' => _ end). - - (* S n1' O *) intros e; discriminate e. - - (* S n1' S n2' *) - refine (fun e => S_R n1' n2' (F n1' n2' (nat_injections21 (nat_map n1') n2' e))). -Defined. - -Inductive Box (A : Type) : Type := B : A -> Box A. -Elpi derive.param2 Box. -Elpi derive.mymap Box. -Elpi derive.projK Box. -Elpi derive.injections Box. -Elpi derive.isK Box. -Check @Trocq.Hierarchy.map. -Definition box_mR : forall A1 A2 (AR: Param2a0.Rel A1 A2) b1 b2, Box_mymap A1 A2 AR b1 = b2 -> Box_R A1 A2 AR b1 b2. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun b1 b2=> _). -refine (match b1 as b0 return Box_mymap A1 A2 AR b0 = b2 -> Box_R A1 A2 AR b0 b2 - with B _ a1 => _ end). - Set Printing All. -refine (match b2 as b0 return Box_mymap A1 A2 AR (B A1 a1) = b0 -> Box_R A1 A2 AR (B A1 a1) b0 - with B _ a2 => _ end). -refine (fun e => _). -simpl in e. -exact (B_R A1 A2 AR a1 a2 ((map_in_R AR) a1 a2 (Box_injections11 A2 ((map AR) a1) a2 e))). -Defined. - -Definition Option (A : Type) : Type := option A. - -Elpi derive.param2 option. -Definition OptionR := option_R. -(* Inductive OptionR (A1 A2 : Type) (AR : A1 -> A2 -> Type) : option A1 -> option A2 -> Type := -| SomeR : forall a1 a2 (aR : AR a1 a2), OptionR A1 A2 AR (Some a1) (Some a2) -| NoneR : OptionR A1 A2 AR None None. *) - -Elpi derive.mymap option. -Definition option_map := option_mymap. -(* Definition option_map (A1 A2 : Type) (AR : Param10.Rel A1 A2) : option A1 -> option A2 := -fun oa => - match oa with - | Some a => Some (map AR a) - | None => None - end. *) - -(* Elpi derive.injections option. *) -(* Print option_injections11. *) - -Definition option_mR : forall (A1 A2 : Type) (AR : Param2a0.Rel A1 A2) oa1 oa2, option_map A1 A2 AR oa1 = oa2 -> OptionR A1 A2 AR oa1 oa2. -Proof. -refine (fun A1 A2 AR => _). -refine (fun oa1 => match oa1 as oa -return forall oa2, option_map A1 A2 AR oa = oa2 -> OptionR A1 A2 AR oa oa2 -with - | Some a1 => _ - | None => _ end). -+ (* Some *) - refine (fun oa2 => match oa2 as oa - return option_map A1 A2 AR (Some a1) = oa -> OptionR A1 A2 AR (Some a1) oa - with - | Some a2 => _ - | None => _ end). - - (* Some Some *) - refine (fun e => Some_R A1 A2 AR a1 a2 (map_in_R AR a1 a2 (option_injections11 A2 (map AR a1) a2 e))). - - (* Some None *) intros e; discriminate e. -+ (* None *) - refine (fun oa2 => match oa2 as oa - return option_map A1 A2 AR None = oa -> OptionR A1 A2 AR None oa - with - | Some a2 => _ - | None => _ end). - - (* None Some *) intros e; discriminate e. - - refine (fun e => None_R A1 A2 AR). -Defined. - -Definition List (A : Type) := list A. -Elpi derive.param2 list. - -Definition ListR := list_R. -Elpi derive.mymap list. - -Definition list_map := list_mymap. - -Elpi derive.injections list. -Print list_injections21. - -Print cons_R. -Definition list_mR : forall (A1 A2 : Type) (AR : Param2a0.Rel A1 A2) l1 l2, list_map A1 A2 AR l1 = l2 -> ListR A1 A2 AR l1 l2. -Proof. -refine (fun A1 A2 AR=> _). -fix F 1. -refine (fun l1 => match l1 as l - return forall l2, list_map A1 A2 AR l = l2 - -> ListR A1 A2 AR l l2 - with - | nil => _ - | cons a1 l1' => _ end). -+ (* nil *) - refine (fun l2 => match l2 as l - return list_map A1 A2 AR nil = l -> ListR A1 A2 AR nil l - with - | nil => _ - | cons a2 l2' => _ end). - - (* nil nil *) - refine (fun e => nil_R A1 A2 AR). - - intros e; discriminate e. -+ (* cons *) - refine (fun l2 => match l2 as l - return list_map A1 A2 AR (cons a1 l1') = l -> ListR A1 A2 AR (cons a1 l1') l - with - | nil => _ - | cons a2 l2' => _ end). - - intros e; discriminate e. - - refine (fun e => cons_R A1 A2 AR - a1 a2 (map_in_R AR a1 a2 (list_injections21 A2 (map AR a1) a2 (list_map A1 A2 AR l1') l2' e)) - l1' l2' (F l1' l2' (list_injections22 A2 (map AR a1) a2 (list_map A1 A2 AR l1') l2' e))). -Defined. - -Inductive ParamWrap (A : Type) := -(* | PH : unit -> ParamWrap A *) -| SomeW : option A -> ParamWrap A. - -Elpi derive.param2 ParamWrap. -Definition ParamWrapR := ParamWrap_R. - -Fail Elpi derive.mymap ParamWrap. -Fail Elpi derive.map ParamWrap. - -(* Definition list_map := list_mymap. *) -Elpi derive.projK ParamWrap. -Elpi derive.injections ParamWrap. - diff --git a/generic/Rm.elpi b/generic/Rm.elpi deleted file mode 100644 index 96758847..00000000 --- a/generic/Rm.elpi +++ /dev/null @@ -1,207 +0,0 @@ -shorten derive.common-algo.{mk-mR-type}. - -namespace derive.Rm { - -pred mk-ith-eta i:int, i:list term, i:list term, i:list term, i:term, o:term. -mk-ith-eta I MArgs DestArgs Tys K FR :- - J is I - 1, - std.take J DestArgs Done, % list of args already processed. - std.drop I MArgs MTODO, % list of args to yet process - std.nth J Tys CurrTy, - (pi curr\ - coq.mk-app K {std.append Done [curr|MTODO]} (KArgs curr)), - FR = fun `R` CurrTy (r\ (KArgs r)). - -pred mk-etas i:list term, i:list term, i:list term, i:int, i:int, i: term, o:list term. -mk-etas _ _ _ M N _ [] :- M > N. -mk-etas SrcArgs DestArgs Tys I N KDest [R| RS] :- - J is I + 1, - mk-ith-eta I SrcArgs DestArgs Tys KDest R, - mk-etas SrcArgs DestArgs Tys J N KDest RS. - -pred compose-path i:list term, i:term, i:term o: term. -compose-path [] End _ End. -compose-path [Argk|Args] End ITy {{ @eq_trans lp:ITy _ _ _ lp:Argk lp:R }} :- - compose-path Args End ITy R. - -pred whds i:term, o:term. -whds T R :- - whd T [] HD ARGS, - unwind HD ARGS R. - -pred build-Rm-args i:list term, i:list term, i:term, o:term. -build-Rm-args [] _ T T. -build-Rm-args [A1|Args1] [A2|Args2] T R :- - ar-db A1 A2 AR, - coq.mk-app T [A1, A2, AR] TAR, - build-Rm-args Args1 Args2 TAR R. - - -pred build-Rm i:term, i:term, i:term, o:term. -build-Rm STy DTy ITyTy R :- - coq.safe-dest-app STy Ind Args1, - coq.safe-dest-app ITyTy Ind2 Args2, - rm-db Ind RM, - if (Ind = Ind2) - (R = RM) - (build-Rm-args Args1 Args2 RM RSkel, - coq.elaborate-skeleton RSkel _ R ok). - % build-mRA-ty-args ArgsTy1 ArgsTy2 MR R). - % rm-db STy RM, - - - -% given list of etas, list of src type, list of dest type, -% Dest iTyTy, list mapped args, list dest args, returns list of ap tyDest ITyty eta Marg DestArg (e : Marg = DestArg) -pred mk-aps-etas i:list term, i:list term, i:list term, i:term, i:list term, i:list term, o:list term. -mk-aps-etas [] [] [] _ [] [] []. -mk-aps-etas [Eta|Etas] [STy| SrcTys] [DTy|DestTys] ITyTy [MA|MArgs] [DA|Dargs] [RE|RS] :- - Ap = {{ eq_f }}, - param DA A AR, - build-Rm STy DTy ITyTy RM, - coq.typecheck RM RmTy ok, - coq.typecheck AR ARTy ok, - coq.mk-app RM [A, DA, AR] EqADA, - coq.mk-app Ap [DTy,ITyTy,Eta,MA,DA,EqADA] R, - coq.elaborate-skeleton R _ RE E, - mk-aps-etas Etas SrcTys DestTys ITyTy MArgs Dargs RS. - -% Ksource, Kdest, remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, -pred process-args i:term, i:term, i:int, i:int, i:term, i:term, i:list term, i:list term, i:term, o:term. -process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest _ITyTy R:- - coq.mk-app Goal [Ksrc, Kdest, {{ Type }}] EqTy, %discards the relation between Ksrc and Kdest, we want the equality. - whd EqTy [] {{lib:@elpi.eq}} [T,MapA,B], - whd MapA [] (global (indc _)) TySrcMappedArgs, - whd B [] KDest TyDestArgs, - std.drop TyArgsNo TySrcMappedArgs SrcMappedArgs, - std.drop TyArgsNo TyDestArgs DestArgs, - coq.mk-app KDest {std.take TyArgsNo TyDestArgs} KAppTyArgs, - mk-etas SrcMappedArgs DestArgs TyDest 1 {std.length DestArgs} KAppTyArgs REtas, - mk-aps-etas REtas TySrc TyDest T SrcMappedArgs DestArgs Raps, - compose-path Raps {{ @eq_refl lp:T lp:B }} T Rpath, - coq.elaborate-skeleton Rpath EqTy R E. -process-args Ksrc Kdest N TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal TySrc TyDest ITyTy - (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- - M is N - 1, - @pi-decl AN1 A1Ty a1\ - @pi-decl AN2 A2Ty a2\ - @pi-decl ARN (ARTy a1 a2) ar\ - coq.mk-app Ksrc [a1] (NewKS a1), - coq.mk-app Kdest [a2] (NewKD a2), - (param a2 a1 ar => - process-args (NewKS a1) (NewKD a2) M TyArgsNo (Bo a1 a2 ar) Goal TySrc TyDest ITyTy (R a1 a2 ar)), - % if the type of the argument is an instance of the inductive type add an induction hypothesis - whd ITyTy _ Ind _, - whd A2Ty _ IndD _, - if (Ind = IndD) - (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), - (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) - (RF = R). - - -pred type-of-args i:term, i:int, o:list term, o:list term. -type-of-args _ 0 [] []. -type-of-args (prod _AN1 ATy1 a1\ prod _AN2 ATy2 a2\ prod _ _ ar\ (Bo a1 a2 ar)) N [ATy1| SR] [ATy2 | DR] :- - M is N - 1, - pi a1 a2 ar\ - type-of-args (Bo a1 a2 ar) M SR DR. - -% invariant: all type arguments were already processed. -% Constructor src, Constructor dest, Constructor dest Type, Arguments to process, ConstructorR constructorR Type, i2, type of i2, i1 i2 iR => goal. -pred mkBranch i:term, i:term, i:term, i:int, i:term, i:term, i:term, i:term, i:term, o:term. -mkBranch KS KD KTy N KR KTyR _ITy ITyTy Goal Eq:- - type-of-args KTyR N SrcArgs DestArgs, - whd ITyTy [] _ TyArgs, - process-args KS KD N {std.length TyArgs} KTyR Goal SrcArgs DestArgs ITyTy Eq. - -pred mkBranches i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term o:list term. -mkBranches [] [] [] [] [] _ _ _ []. -mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KR|KRs] [KTyR|KTyRs] ITy ITyTy Goal [R|Rs] :- - mkBranch KS KD KTy {coq.count-prods KTy} KR KTyR ITy ITyTy Goal R, - mkBranches KsS KsD KTys KRs KTyRs ITy ITyTy Goal Rs. - -pred implement-Rm i:int, i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, o:term. -% Pred comes with Type parameters applied -% RInd comes with Type parameters applied -implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KRs KTyRs Pred RInd - (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- - coq.safe-dest-app ITy1 Ind _, - Ind = (global (indt GR)), - coq.env.recursive? GR, !, - RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), - coq.mk-app RInd [Pred] RIndP, - @pi-decl `f` RT f\ - @pi-decl IN1 ITy1 i1\ - @pi-decl IN2 ITy2 i2\ - @pi-decl ARN (ARTy i1 i2) ar\ - (rm-db Ind f => - mkBranches KsS KsD KTys KRs KTyRs i2 ITy2 Pred (Brs f i2)), - std.append (Brs f i2) [i1,i2,ar] (IndArgs f i1 i2 ar), - coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). -implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KRs KTyRs Pred RInd - (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- - coq.mk-app RInd [Pred] RIndP, - @pi-decl IN1 ITy1 i1\ - @pi-decl IN2 ITy2 i2\ - @pi-decl ARN (ARTy i1 i2) ar\ - mkBranches KsS KsD KTys KRs KTyRs i2 ITy2 Pred (Brs i2), - std.append (Brs i2) [i1,i2,ar] (IndArgs i1 i2 ar), - coq.mk-app RIndP (IndArgs i1 i2 ar) (R i1 i2 ar). -implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KTys KRs KTyRs Pred RInd - (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- - M is N - 1, - @pi-decl AN1 ATy1 a1\ %A1 : Type - @pi-decl AN2 ATy2 a2\ %A2 : Type - @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param2b0.Rel A1 A2 - coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), - - (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, - coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, - - coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), - coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, - - std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), - std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), - std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), - std.map KRs (x\ r\ sigma TMP\ coq.mk-app x [a1,a2,(RelAR a1 a2 ar)] TMP, r = TMP) (NewKRs a1 a2 ar), - std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), - Rm = {{ @Trocq.Hierarchy.R_in_map }}, - coq.mk-app Rm [a1, a2, ar] (RMS a1 a2 ar), - coq.elaborate-skeleton (RMS a1 a2 ar) (RTy a1 a2 ar) (RM a1 a2 ar) E, - ar-db a1 a2 ar ==> - rm-db a1 (RMS a1 a2 ar) ==> - implement-Rm M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKRs a1 a2 ar) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). - - -pred main i:inductive, i:string, o:list prop. -main GR Prefix Clauses :- std.do! [ - - coq.env.indt GR _ TyParamNo _ _ KNs KTys, - Ind = (global (indt GR)), - param Ind Ind TR, - coq.typecheck TR TRTy _, - mymap-def Ind IndMap, - mk-mR-type TyParamNo TRTy IndMap {{ Type }} TR tt MRTy, - coq.elaborate-skeleton MRTy _ MRTyE ok, - TR = global (indt GRR), - coq.gref->id (indt GRR) Rname, - RInductionName is Rname ^ "_ind", - coq.locate RInductionName RInd, - coq.prod->fun MRTyE Pred, - coq.env.indt GRR _ _ _ _ KNRs KTyRs, - std.map KNs (x\ r\ r = (global (indc x))) Ks, - std.map KNRs (x\ r\ r = (global (indc x))) KRs, - implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KRs KTyRs Pred (global RInd) R, - coq.elaborate-skeleton R MRTyE Re ok, - Name is Prefix ^ "Rm", - coq.ensure-fresh-global-id Name FName, - coq.env.add-const FName Re MRTyE _ C, - I = global (indt GR), - Clauses = [rm-done I, rm-db I (global (const C))], - std.forall Clauses (x\ - coq.elpi.accumulate _ "derive.Rm.db" (clause _ _ x) - ), -]. - -} \ No newline at end of file diff --git a/generic/Rm.v b/generic/Rm.v deleted file mode 100644 index 8a7b58d0..00000000 --- a/generic/Rm.v +++ /dev/null @@ -1,112 +0,0 @@ -From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Algo Extra Dependency "Rm.elpi" as Rm. -From Trocq.Algo Extra Dependency "common_algo.elpi" as common. - -From elpi Require Import elpi. -From elpi.apps Require Import derive.param2. -From elpi.apps Require Import derive.bcongr. (* for eq_f register *) -From Trocq.Algo Require Import mymap. -From elpi.apps Require Import derive.induction. -From Trocq Require Import HoTT_additions Hierarchy. -Unset Uniform Inductive Parameters. - -Elpi Db derive.Rm.db lp:{{ - % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. - pred ar-db i:term, i:term, o:term. - - % [Rm-db T D] links a type T to its corresponding R in map. - pred rm-db i:term, o:term. - - % [Rm-done T] mean T was already derived - pred rm-done o:term. -}}. - -Elpi Command derive.Rm. -Elpi Accumulate File derive_hook. -Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate Db derive.param2.db. -Elpi Accumulate Db derive.mymap.db. -Elpi Accumulate File common. -Elpi Accumulate Db derive.Rm.db. -Elpi Accumulate File Rm. -Elpi Accumulate lp:{{ - main [str I] :- !, coq.locate I (indt GR), - coq.gref->id (indt GR) Tname, - Prefix is Tname ^ "_", - derive.Rm.main GR Prefix _. - main _ :- usage. - - pred usage. - usage :- coq.error "Usage: derive.Rm ". -}}. - - -Elpi derive.param2 unit. -Elpi derive.mymap unit. - -Elpi derive.Rm unit. -Print unit_Rm. - -Elpi derive.param2 bool. -Elpi derive.mymap bool. -Elpi derive.Rm bool. -Print bool_Rm. - -Inductive Wrap : Type := -| KWrap1 : unit -> Wrap. - -Elpi derive.param2 Wrap. -Elpi derive.mymap Wrap. -Elpi derive.Rm Wrap. -Print Wrap_Rm. - -Inductive WrapMore : Type := -| KWrap : unit -> bool -> WrapMore -| KWrapWrap : Wrap -> WrapMore -| F : unit -> unit -> unit -> WrapMore. - -Elpi derive.param2 WrapMore. -Elpi derive.mymap WrapMore. -Elpi derive.Rm WrapMore. -Print WrapMore_Rm. - -Elpi derive.param2 nat. -Elpi derive.mymap nat. -Elpi derive.Rm nat. -Print nat_Rm. - -Inductive DoubleRec : Type := -| Base -| Double : DoubleRec -> DoubleRec -> DoubleRec. -Elpi derive.param2 DoubleRec. -Elpi derive.mymap DoubleRec. -Elpi derive.Rm DoubleRec. -Print DoubleRec_Rm. - -Inductive Box (A : Type) := -| B : A -> Box A. - -Elpi derive.param2 Box. -Elpi derive.mymap Box. -Set Printing All. -About R_in_map. -Print B_R. -Print Box_R_ind. -Elpi derive.Rm Box. -Print Box_Rm. - -Elpi derive.param2 option. -Elpi derive.mymap option. -Elpi derive.Rm option. -Print option_Rm. - -Elpi derive.param2 prod. -Elpi derive.mymap prod. -Elpi derive.Rm prod. -Print prod_Rm. - - -Elpi derive.param2 list. -Elpi derive.mymap list. -Elpi derive.Rm list. -Print list_Rm. diff --git a/generic/common_algo.elpi b/generic/common_algo.elpi deleted file mode 100644 index 1e63b9e9..00000000 --- a/generic/common_algo.elpi +++ /dev/null @@ -1,55 +0,0 @@ - -namespace derive.common-algo { - -pred rel-mode i:bool o:term. -rel-mode ff {{ Param2a0.Rel }}. -rel-mode tt {{ Param2b0.Rel }}. - -pred swap i:term, i:term, i:bool, o:term, o:term. -swap A B tt B A. -swap A B ff A B. - -% Reached a sort, return map L = R -> IR. -pred mk-return i:term, i:term, i:term, i:bool, i:term, o:term. -mk-return ML MR Rel Swap ITyTy2 R :- - Map = {{ @eq lp:ITyTy2 lp:ML lp:MR }}, - swap Map Rel Swap First Second, - R = prod `_` First _\ Second. - - -% The number of Type parameters in T -% Type of inductive T, -% Type of bin parametricity translation TR, -% ML LHS of map equality -% MR RHS of map equality -% Rel type of TR applied to arguments -% Returns the type of map in R for T -% X is the first inductive, Y is the second inductive. -pred mk-mR-type i:int, i:term, i:term, i:term, i:term, i:bool, o:term. -% Introducing X and Y. -% The RHS of the equality is Y. -mk-mR-type 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap - (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- - @pi-decl IN1 ITyTy x\ - @pi-decl IN2 ITyTy2 y\ - sigma NewML NewMR NewRel\ - coq.mk-app ML [x] NewML, - NewMR = y, - coq.mk-app Rel [x,y] NewRel, - mk-return NewML NewMR NewRel Swap ITyTy2 (R x y). - % mk-mR-type 0 (Bo x y) NewML NewMR NewRel Swap (R x y). -% Process two type parameters + 1 relation at a time. -% Apply these parameters to the LHS of the equation. -mk-mR-type N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel Swap - (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ lp:AR lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- - M is N - 1, - rel-mode Swap ARSkel, - coq.elaborate-skeleton ARSkel _ AR ok, - pi a1 a2 ar\ - sigma NewML NewMR NewRel\ - coq.mk-app ML [a1, a2, ar] NewML, - NewMR = a2, - coq.mk-app Rel [a1,a2,ar] NewRel, - mk-mR-type M (Bo a1 a2 ar) NewML NewMR NewRel Swap (R a1 a2 ar). - -} \ No newline at end of file diff --git a/generic/injection_lemmas.elpi b/generic/injection_lemmas.elpi deleted file mode 100644 index a96569d8..00000000 --- a/generic/injection_lemmas.elpi +++ /dev/null @@ -1,184 +0,0 @@ -namespace derive.injections { - -/* for all projectors of type forall Args T, ret -generate - -forall Args1-> Args2-> (e : Kj args->1 = Kj args->2) argj - -Take an inductive Ind, -take its constructors global references, -for each global reference GRK, -Compute the number of arguments J for each GRK, -for each ArgNumber in 1 to J+1, -get the Projector GRK ArgNumber, -Get the type ProjType, forall ArgTys Args Ind, ret -Return the processed Types */ - - -% Returns the list of projectors of a constructor. -pred get-projectors i:constructor, i:int, i:int, o:list term. -get-projectors _ Max Max [] :- !. -get-projectors GRK J Max [P|PJs] :- - I is J + 1, - projK-db GRK I P, - get-projectors GRK I Max PJs. - -% for a list of constructors returns a list with all the projectors of that construct -pred for-K-get-projectors i:int, i:list constructor, i:list term, o: list int, o:list (list term). -for-K-get-projectors _ [] [] [] []:- !. -for-K-get-projectors TyParamNo [Kn|KNs] [KTy|KTys] [ArgsNo|ArgsNos] [R|RS]:- - coq.count-prods KTy ArgsParamNo, - ArgsNo is ArgsParamNo - TyParamNo, - get-projectors Kn 0 ArgsNo R, - for-K-get-projectors TyParamNo KNs KTys ArgsNos RS. - -func names12 name -> name, name. -names12 N N1 N2 :- !, - coq.name-suffix N 1 N1, coq.name-suffix N 2 N2. - -% given TyParam ArgNo and T, -% duplicate-argument skips TyParam lambdas, -% then for the first ArgNo lambda adds another lambda expecting an argument of the same Type, -% after all lambdas are processed returns the body unchanged -% Returns a list with the original variables, and a list with the added ones -pred duplicate-arguments i:int, i:int, i:term, o:term. -duplicate-arguments 0 0 T T :- !. -duplicate-arguments 0 O (prod N TyA T) (prod Arg1 TyA a1\ (prod Arg2 TyA a2\ (S a1 a2))) :- - O > 0, - P is O - 1, - names12 N Arg1 Arg2, - (pi a1 a2\ duplicate-arguments 0 P (T a1) (S a1 a2)). -duplicate-arguments N O (prod TyName TyArg T) (prod TyName TyArg S) :- !, - N > 0, - M is N - 1, - pi a1\ duplicate-arguments M O (T a1) (S a1). - - -% TyParam, ArgNo, F, Type of the equality, Left HS, Right HS -% F is of type forall (Typarams : Type) ((Arg1 : A1) (Arg2 : A2) ...), Ret -% Ret is discarded and replaced by Left = Right -pred craft-eq i:int, i:int, i:int, i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, o:term. -craft-eq 0 0 _ _ _ EqTy Left Right ConclEqTy ConclL ConclR R:- !, - coq.mk-app {{lib:@elpi.eq}} [EqTy, Left, Right] AETy, - coq.mk-app {{lib:@elpi.eq}} [ConclEqTy, ConclL, ConclR] C, - R = {{ forall (e : lp:AETy), lp:C }}. - -craft-eq 0 ArgNo J Max (prod N1 T x\ prod N2 T y\ (Bo x y)) EqTy Left Right ConclEq ConclL ConclR (prod N1 T x\ prod N2 T y\ (S x y)) :- !, - M is ArgNo - 1, - J? is Max - ArgNo + 1, - @pi-decl N1 T x\ - @pi-decl N2 T y\ - sigma NewLeft NewRight NewConclEq NewConclL NewConclR\ - (if (J? = J) - (NewConclEq = T, - NewConclL = x, - NewConclR = y) - (NewConclEq = ConclEq, - NewConclL = ConclL, - NewConclR = ConclR)), - coq.mk-app Left [x] NewLeft, - coq.mk-app Right [y] NewRight, - craft-eq 0 M J Max (Bo x y) EqTy NewLeft NewRight NewConclEq NewConclL NewConclR (S x y). - -craft-eq TyParam ArgNo J Max (prod N T Bo) EqTy Left Right CE CL CR (prod N T x\ S x) :- !, - M is TyParam - 1, - @pi-decl N T x\ - sigma NewEqTy NewLeft NewRight\ - coq.mk-app EqTy [x] NewEqTy, - coq.mk-app Left [x] NewLeft, - coq.mk-app Right [x] NewRight, - craft-eq M ArgNo J Max (Bo x) NewEqTy NewLeft NewRight CE CL CR (S x). - -pred build-type-K-injector i:int, i:int, i:inductive, i:constructor, i:int, i:term, i:list term, o:list term. -build-type-K-injector _ _ _ _ _ _ [] [] :- !. -build-type-K-injector TyParamNo J GR Kn ArgNo KTy [PJ|PJs] [Eq|RS] :- std.do! [ - Jn is J + 1, - duplicate-arguments TyParamNo ArgNo PJ S, - (craft-eq TyParamNo ArgNo J ArgNo S (global (indt GR)) (global (indc Kn)) (global (indc Kn)) {{tt}} {{tt}} {{tt}} Eq), - coq.typecheck Eq _ ok, - build-type-K-injector TyParamNo Jn GR Kn ArgNo KTy PJs RS]. - -pred build-types-injectors i:int, i: inductive, i:list constructor, i: list int, i:list (term), i:list (list term), o:list (list term). -build-types-injectors _ _ [] [] [] [] [] :- !. -build-types-injectors TyParamNo GR [Kn|KNs] [ArgNo|ArgsNos] [KTy|KTys] [PJs|PJss] [R|RS] :- - build-type-K-injector TyParamNo 1 GR Kn ArgNo KTy PJs R, - build-types-injectors TyParamNo GR KNs ArgsNos KTys PJss RS. - % build-types-injectors Kn PJs R, - -pred name-injector i:string, i:int, i:int, i:inductive, i:constructor, i:list term, o:list prop. -name-injector _ _ _ _ _ [] []. -name-injector FName I J GR Kn [InjTy|InjTyss] [Clause|Clauses] :- - Jn is J + 1, - NameIJ is {std.any->string FName} ^ {std.any->string I} ^ {std.any->string J}, - coq.env.add-const NameIJ InjTy _ _ C, - % Clause = (injections-db Kn J (global (const C)) :- !), - Clause = (injections-db (global (indc Kn)) J (global (const C))), - name-injector FName I Jn GR Kn InjTyss Clauses. - -pred name-injectors i:string, i:int, i:inductive, i:list constructor, i:list (list term), o:list (list prop). -name-injectors _ _ _ [] [] []. -name-injectors FName I GR [Kn | KNs] [InjTys | InjTyss] [Clauses | Clausess] :- - In is I + 1, - name-injector FName I 1 GR Kn InjTys Clauses, - name-injectors FName In GR KNs InjTyss Clausess. - - -pred implement-K-injector-J i:int, i:int, i:int, i:int, i:term, o:term. - % implement-K-injector-J _ _ _ _ T T. -implement-K-injector-J 0 J 0 TyParam (prod E Ty _) R :- !, - I is J - 1, - R = {{ fun e:(lp:Ty) => lp:(PL e) }}, - @pi-decl E Ty e\ - sigma GR TyArgs GRK KArgs A B\ - ltac.injection? Ty GR TyArgs GRK KArgs A B, - ltac.injection.arg-i I J {{lib:@elpi.derive.eq_f}} GR TyArgs TyParam GRK KArgs A B e [(PL e)]. - -implement-K-injector-J 0 J ArgNo TyParam (prod ArgN1 ArgTy a\ (prod ArgN2 ArgTy b\ (Bo a b))) (fun ArgN1 ArgTy a\ fun ArgN2 ArgTy b\ (R a b) ) :- !, - ArgNon is ArgNo - 1, - @pi-decl ArgN1 ArgTy a\ - @pi-decl ArgN2 ArgTy b\ - implement-K-injector-J 0 J ArgNon TyParam (Bo a b) (R a b). - -implement-K-injector-J ParamNo J ArgNo TyParam (prod TyArg T t\ (Bo t)) (fun TyArg T t\ (R t) ) :- !, - ParamNon is ParamNo - 1, - @pi-decl TyArg T t\ - implement-K-injector-J ParamNon J ArgNo TyParam (Bo t) (R t). - -pred implement-K-injectors i:int, i:int, i:int, i:list term, o:list term. -implement-K-injectors _ _ _ [] []. -implement-K-injectors TyParam J ArgNo [InjTy | InjTys] [R | RS] :- - Jn is J + 1, - (implement-K-injector-J TyParam J ArgNo TyParam InjTy R), - coq.typecheck R InjTy ok, - implement-K-injectors TyParam Jn ArgNo InjTys RS. - -pred implement-injectors i:int, i:list int, i:list (list term), o:list (list term). -implement-injectors _ _ [] []. -implement-injectors TyParam [ArgNo | ArgNos] [InjTys | InjTyss] [R | RS ] :- - implement-K-injectors TyParam 1 ArgNo InjTys R, - implement-injectors TyParam ArgNos InjTyss RS. - -pred main i:inductive, i:string, o:list prop. -main GR Prefix Clauses :- std.do! [ - Name is Prefix ^ "injections", - coq.ensure-fresh-global-id Name FName, - coq.env.indt GR _ TyParamNo _ _ KNs KTys, - for-K-get-projectors TyParamNo KNs KTys ArgsNos PJss, - std.map PJss (x\ r\ sigma R\ (std.map x (y\ r\ sigma Ty\ coq.typecheck y Ty _, r = Ty) R), r = R) PJTyss, - build-types-injectors TyParamNo GR KNs ArgsNos KTys PJTyss InjTyss, - implement-injectors TyParamNo ArgsNos InjTyss Injss, - name-injectors FName 1 GR KNs Injss Clausess, -% TTT is {{lib:@elpi.derive.eq_f}}, -% coq.say TTT, -% std.forall Clauses (x\ -% coq.elpi.accumulate _ "derive.injections.db" (clause _ _ x) -% ), -% coq.env.add-const FName Body Type _ C, - std.flatten Clausess Clauses, - ClausesFin = [injections-done (global (indt GR)) | Clauses], %[injections-done GR, injections GR (const C)], - std.forall ClausesFin (x\ - coq.elpi.accumulate _ "derive.injections.db" (clause _ _ x) - ), -]. - -} \ No newline at end of file diff --git a/generic/injection_lemmas.v b/generic/injection_lemmas.v deleted file mode 100644 index d8656292..00000000 --- a/generic/injection_lemmas.v +++ /dev/null @@ -1,101 +0,0 @@ -From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. -From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Algo Extra Dependency "injection_lemmas.elpi" as injections. - -From elpi Require Import elpi. -From elpi.apps Require Import derive.bcongr. (* for eq_f register *) -From elpi.apps Require Import projK. -Unset Uniform Inductive Parameters. -Elpi Db derive.injections.db lp:{{ - - % [injections I K ILs] links I, - % constructor inductive type, - % and K, - % a natural number > 0 (representing the constructor number) - % with the list of injection lemmas for that constructor - pred injections-db i:term, i:int, o:term. - - % [injections-done T K] means T K was already derived - pred injections-done o:term. -}}. - -Elpi Command derive.injections. -Elpi Accumulate File derive_hook. -Elpi Accumulate Db Header derive.projK.db. -Elpi Accumulate Db derive.projK.db. -Elpi Accumulate File injection. -Elpi Accumulate Db derive.injections.db. -Elpi Accumulate File injections. -Elpi Accumulate lp:{{ - - main [str I] :- !, - coq.locate I (indt GR), - % Ind is (indt GR) - coq.gref->id (indt GR) Tname, - Suffix is Tname ^ "_", - derive.injections.main GR Suffix _. - main _ :- usage. - - pred usage. - usage :- coq.error "Usage: derive.injections ". -}}. -Elpi Trace Browser. - -Inductive Wrap : Type := -| W : unit -> Wrap. -Elpi derive.projK Wrap. -Print projW1. -Elpi derive.injections Wrap. -Print Wrap_injections11. - -Elpi derive.projK nat. -Elpi derive.injections nat. -Print nat_injections21. - -Elpi derive.projK option. -Print projSome1. -Elpi derive.injections option. -Print option_injections11. - -Inductive enum : Type := -| Constructor : unit -> bool -> enum. - -Elpi derive.projK enum. -Print projConstructor1. -Print projConstructor2. -Elpi derive.injections enum. -Print enum_injections11. -Print enum_injections12. - -Inductive enum2 : Type := -| Nol : enum2 -| Constructor2 : unit -> bool -> enum2. - -Elpi derive.projK enum2. -Print projConstructor21. -Print projConstructor22. -Elpi derive.injections enum2. -Print enum2_injections21. -Print enum2_injections22. - -Inductive Losts (T : Prop) : Prop := -| Conse : Losts T -> Losts T . - -Elpi derive.projK Losts. -Print projConse1. -Elpi derive.injections Losts. -Print Losts_injections11. - -Elpi derive.projK list. -Print projcons1. -Print projcons2. -Elpi derive.injections list. -Print list_injections21. -Print list_injections22. - -Elpi Query lp:{{ - std.findall (injections-db _ _ _) Rules. - std.findall (injections-done _) Rules. - std.findall (projK-db _ _ _) Rules. -}}. diff --git a/generic/mR.elpi b/generic/mR.elpi deleted file mode 100644 index 02488c95..00000000 --- a/generic/mR.elpi +++ /dev/null @@ -1,180 +0,0 @@ - -shorten derive.common-algo.{mk-mR-type}. - -namespace derive.mR { - -% Given Y and Bo: x\ y\ RT. The return type of the match on X is: substituting the binder of X in the match. -pred rty-1 i:(term -> term -> term), i:term , i:term, i: list term, i: list term, o:term. -rty-1 Bo Y _ Ts _ R :- - std.last Ts X, - R = Bo X Y. - -% Given X and Bo: x\ y\ RT. The return type of the match on Y is: substituting the binder of Y in the match. -pred rty-2 i:(term -> term -> term), i:term , i:term, i: list term, i: list term, o:term. -rty-2 Bo X _ Ts _ R :- - std.last Ts Y, - R = Bo X Y. - -pred sub-branch i:int, i: term, i:list term, i:list term, i:term, i:list term, i:list term, - i:(term -> term -> term), o:term. -sub-branch TyParamNo K1 Args1 ArgTys1 K2 Args2 ArgTys2 Bo (fun `e` ETy e\ (R e)):- - coq.mk-app K1 Args1 X, - coq.mk-app K2 Args2 Y, - BoXY = Bo X Y, - coq.elaborate-skeleton BoXY _ BoXYE _, - BoXYE = prod _ ETy G, - whd K1 [] Constr1 TypeArgs1, - whd K2 [] Constr2 TypeArgs2, - @pi-decl `e` ETy e\ - matrix TyParamNo Constr1 TypeArgs1 Args1 ArgTys1 Constr2 TypeArgs2 Args2 ArgTys2 e ETy (G e) (R e). - -% Each branch matches on Y as Y0, returning a term of type (Bo (K KArgs) Y0) given by matrix. -pred mkBranch i:int, i:(term -> term -> term), i:term, i:term, i:term, i:term, i:list term, i:list term, o:term. -mkBranch TyParamNo Bo Y YTy K _ Ts TYs R :- - coq.mk-app K Ts X, - coq.build-match Y YTy (rty-2 Bo X) - (k2\ _\ ts\ tys\ - sub-branch TyParamNo K Ts TYs k2 ts tys Bo) - R. - -pred build-mRA-ty-args i:list term, i:list term, i:term, o:term. -build-mRA-ty-args [] [] R R. -build-mRA-ty-args [ATy1| ArgsTy1] [ATy2| ArgsTy2] MR R :- - ar-db ATy1 ATy2 AR, - coq.mk-app MR [ATy1, ATy2, AR] NewMR, - build-mRA-ty-args ArgsTy1 ArgsTy2 NewMR R. - -% TODO update: this considers that type arguments come in Ts, they don't come in there. -pred build-mRA i:term, i:term, i:term, o:term. -build-mRA ATy1 ATy2 Ind R :- - whd ATy1 [] ITy ArgsTy1, - whd ATy2 [] _ ArgsTy2, - coq.typecheck Ind IndTy _, - mR-db ITy MR, - % TODO: change following line to implement non uniform parameters + definition of the fix. - if (ATy1 = IndTy) - (R = MR) - (build-mRA-ty-args ArgsTy1 ArgsTy2 MR R). - -pred build-injEKJ-args i:int, i:list term, i:list term, - i:term, i:term, o:term. -% applies TyParamNo time the Type parameter of the return Inductive. -build-injEKJ-args 0 Args1 Args2 InjKJ E R :- - app-interleave InjKJ Args1 Args2 InjKJArgs, - coq.mk-app InjKJArgs [E] R. -build-injEKJ-args N [_ | ATys1] [ATy2|ATys2] InjKJ E R :- - M is N - 1, - coq.mk-app InjKJ [ATy2] InjKJA, - build-injEKJ-args M ATys1 ATys2 InjKJA E R. - -pred app-interleave i:term, i:list term, i:list term, o:term. -app-interleave R [] [] R. -app-interleave F [A|Args1] [B|Args2] R :- - coq.mk-app F [A, B] NewF, - app-interleave NewF Args1 Args2 R. - -pred build-injEKJ i:int, i:term, i:term, i:term, i:int o: term. -build-injEKJ TyParamNo E ETy K J R :- - injections-db K J InjKJ, - whd ETy [] {{lib:@elpi.eq}} [_,A,B], - whd A [] (global (indc _)) ArgsL, - whd B [] (global (indc _)) ArgsR, - build-injEKJ-args TyParamNo ArgsL ArgsR InjKJ E InjEKJ, - coq.elaborate-skeleton InjEKJ _ R _. - -% TODO: for processing params extend with an int of param no + db Type Type AR. -% TODO: for processing contained types, lookup mR-db apply arg1 arg2 + the ith constructor injection of the equality. -pred apply-indR i:int, i:int, i:term, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term, i:term, i:int, o: term. -% N J K KR K1Args K1Tys K2Args K2Tys X Y E TyParamNo -apply-indR 0 _ _ KR [] [] [] [] [] [] _ _ _ _ _ KR. -% for the jth argument provide A1 A2 AR12 -% For AR12 we bring mR_ATy ATyArgs1 ATyArgs2 ARs -% For the equality we bring injectionKJ TyArgs2 (Args1 of the eq) (Args2 of the eq) -apply-indR 0 J K KR [] [A1|Args1] [ATy1|ArgTys1] [] [A2|Args2] [ATy2| ArgTys2] LHS RHS E ETy TyParamNo R :- - Jn is J + 1, - build-mRA ATy1 ATy2 LHS MRA, - build-injEKJ TyParamNo E ETy K J InjEKJ, - coq.mk-app MRA [A1,A2,InjEKJ] A12R, - coq.mk-app KR [A1,A2, A12R] KA12AR, - apply-indR 0 Jn K KA12AR [] Args1 ArgTys1 [] Args2 ArgTys2 LHS RHS E ETy TyParamNo R. -apply-indR N J K KR [Ty1|TyArgs1] Args1 ArgTys1 [Ty2|TyArgs2] Args2 ArgTys2 LHS RHS E ETy TyParamNo R :- - M is N - 1, - ar-db Ty1 Ty2 AR, - coq.mk-app KR [Ty1, Ty2, AR] NewKR, - apply-indR M J K NewKR TyArgs1 Args1 ArgTys1 TyArgs2 Args2 ArgTys2 LHS RHS E ETy TyParamNo R. - -% On the diagonal return KR a1 a2 ... -% Outside the diagonal discriminate -pred matrix - i:int, i: term, i:list term, i:list term, i:list term, i:term, i:list term, i:list term, i:list term, - i:term, i:term, i:term, o:term. -matrix TyParamNo K1 TyArgs1 KArgs1 ArgTys1 K1 TyArgs2 KArgs2 ArgTys2 E ETy _ R :- - !, - param K1 K1 KR, - coq.mk-app K1 {std.append TyArgs1 KArgs1} LHS, - coq.mk-app K1 {std.append TyArgs2 KArgs2} RHS, - apply-indR TyParamNo 1 K1 KR TyArgs1 KArgs1 ArgTys1 TyArgs2 KArgs2 ArgTys2 LHS RHS E ETy TyParamNo R. - -matrix _ _ _ _ _ _ _ _ _ E ETy G R :- !, - ltac.discriminate E ETy G R. - -pred implement-mR i:int, i:int, i:term, o:term. -% all TyParams processed, -% remains forall (i1: I Args1) (i2 : I Args2), map -> IR -% Bo is i1\ i2\ mapI Args1 Args2 ARs i1 = i2 -> IR Args1i Args2i ARsi i1 i2. -% todo: Carry the list of TyArgs, needed for apply-ind params. -implement-mR 0 TyParamNo (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)) (fix `f` 0 RT f\ fun I1 I1Ty i1\ fun I2 I2Ty i2\ (R f i1 i2)) :- - Ind = (global (indt GR)), - coq.safe-dest-app I1Ty Ind _, - coq.env.recursive? GR, !, - RT = (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)), - @pi-decl `f` RT f\ - @pi-decl I1 I1Ty i1\ - @pi-decl I2 I2Ty i2\ - mR-db Ind f => - coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R f i1 i2). -implement-mR 0 TyParamNo (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)) (fun I1 I1Ty i1\ fun I2 I2Ty i2\ (R i1 i2)) :- - @pi-decl I1 I1Ty i1\ - @pi-decl I2 I2Ty i2\ - coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R i1 i2). -implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) ar\ (Bo a1 a2 ar)) - (fun A1 A1Ty a1\ fun A2 A2Ty a2\ fun AR (ARTy a1 a2) ar\ (R a1 a2 ar)) :- - M is N - 1, - @pi-decl A1 A1Ty a1\ - @pi-decl A2 A2Ty a2\ - @pi-decl AR (ARTy a1 a2) ar\ - Map = {{ @Trocq.Hierarchy.map }}, - coq.mk-app Map [a1,a2,ar] (PMapA a1 a2 ar), - % insert coercions - coq.elaborate-skeleton (PMapA a1 a2 ar) _ (MapA a1 a2 ar) ok, - MR = {{ @Trocq.Hierarchy.map_in_R }}, - coq.mk-app MR [a1,a2,ar] (PMR a1 a2 ar), - coq.elaborate-skeleton (PMR a1 a2 ar) _ (MRA a1 a2 ar) ok, - mymap-def A1Ty (MapA a1 a2 ar) ==> - mR-db a1 (MRA a1 a2 ar) ==> - ar-db a1 a2 ar ==> - implement-mR M TyParamNo (Bo a1 a2 ar) (R a1 a2 ar). - - -pred main i:inductive, i:string, o:list prop. -main GR Prefix Clauses :- std.do! [ - Name is Prefix ^ "mR", - coq.env.indt GR _ UnifParamNo _ _ _ _, - Ind = (global (indt GR)), - param Ind Ind TR, - coq.typecheck TR TRTy _, - mymap-def Ind IndMap, - mk-mR-type UnifParamNo TRTy IndMap {{ Type }} TR ff MRTy, - coq.elaborate-skeleton MRTy _ MRTyE ok, - implement-mR UnifParamNo UnifParamNo MRTyE T, - coq.elaborate-skeleton T MRTyE TE ok, - coq.ensure-fresh-global-id Name FName, - coq.env.add-const FName TE MRTyE _ C, - I = global (indt GR), - Clauses = [mR-done I, mR-db I (global (const C))], - std.forall Clauses (x\ - coq.elpi.accumulate _ "derive.mR.db" (clause _ _ x) - ), -]. - -} \ No newline at end of file diff --git a/generic/mR.v b/generic/mR.v deleted file mode 100644 index 29dc57c3..00000000 --- a/generic/mR.v +++ /dev/null @@ -1,154 +0,0 @@ -From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. -From Trocq Extra Dependency "common_algo.elpi" as common. -From Trocq Extra Dependency "mR.elpi" as mR. -From Trocq Require Import mymap injection_lemmas. - -From elpi Require Import elpi. -From elpi.apps Require Import derive.param2 derive.isK. -From elpi.apps Require Import derive.bcongr (* for eq_f register *) - derive.eqK (*for bool_discr *) - derive.isK. (* for isK db required by discriminate *) -From elpi.apps Require Import map. - -From Trocq Require Import Hierarchy. -Unset Uniform Inductive Parameters. - -Elpi Db derive.mR.db lp:{{ - % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. - pred ar-db i:term, i:term, o:term. - % [mR-db T D] links a type T to its corresponding map in R. - pred mR-db i:term, o:term. - - % [mR-done T] mean T was already derived - pred mR-done o:term. -}}. - -Elpi Command derive.mR. -Elpi Accumulate File derive_hook. -Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate Db derive.param2.db. -Elpi Accumulate Db derive.mymap.db. -Elpi Accumulate File discr. -Elpi Accumulate Db derive.isK.db. -Elpi Accumulate Db derive.injections.db. -Elpi Accumulate File common. -Elpi Accumulate Db derive.mR.db. -Elpi Accumulate File mR. -Elpi Accumulate lp:{{ - main [str I] :- !, coq.locate I (indt GR), - coq.gref->id (indt GR) Tname, - Prefix is Tname ^ "_", - derive.mR.main GR Prefix _. - main _ :- usage. - - pred usage. - usage :- coq.error "Usage: derive.mR ". -}}. - -Elpi derive list. -(* Print list_R. *) -Goal forall (A B : Type) (R : Param10.Rel A B), A -> B. -intros A B R. Fail exact R. exact (map R). Abort. - - - -Inductive False : Prop :=. -Elpi derive.param2 False. -Elpi derive.mymap False. -Elpi derive.projK False. -Elpi derive.injections False. -Elpi derive.isK False. -Elpi derive.mR False. - -Elpi derive.param2 unit. -Elpi derive.mymap unit. -Elpi derive.projK unit. -Elpi derive.injections unit. -Elpi derive.isK unit. -Elpi derive.mR unit. - -Elpi derive.param2 bool. -Elpi derive.mymap bool. -Elpi derive.isK bool. -Elpi derive.mR bool. -Print bool_mR. - -Inductive Wrap : Type := -| KWrap1 : unit -> Wrap. - -Elpi derive.param2 Wrap. -Elpi derive.mymap Wrap. -Elpi derive.projK Wrap. -Elpi derive.injections Wrap. -Elpi derive.mR Wrap. -Print Wrap_mR. - -Inductive WrapMore : Type := -| KWrap : unit -> bool -> WrapMore -| KWrapWrap : Wrap -> WrapMore -| F : unit -> unit -> unit -> WrapMore. - -Elpi derive.param2 WrapMore. -Elpi derive.mymap WrapMore. -Elpi derive.projK WrapMore. -Elpi derive.injections WrapMore. -Elpi derive.isK WrapMore. -Elpi derive.mR WrapMore. -Print WrapMore_mR. - -Elpi derive.param2 nat. -Elpi derive.mymap nat. -Elpi derive.isK nat. -Elpi derive.mR nat. - -Inductive Box (A : Type) := -| B : A -> Box A. - -Elpi derive.param2 Box. -Elpi derive.mymap Box. -Elpi derive.projK Box. -Elpi derive.injections Box. -Elpi derive.isK Box. -Elpi derive.mR Box. - -Elpi derive.param2 option. -Elpi derive.mymap option. -Elpi derive.projK option. -Elpi derive.injections option. -Elpi derive.isK option. -Elpi derive.mR option. -Print option_mR. - -Elpi derive.param2 prod. -Elpi derive.mymap prod. -Elpi derive.projK prod. -Elpi derive.injections prod. -Elpi derive.isK prod. -Elpi derive.mR prod. -Print prod_mR. - - -Fail Elpi derive.param2 list. -Elpi derive.mymap list. -Elpi derive.projK list. -Elpi derive.injections list. -Elpi derive.isK list. -Elpi Trace Browser. - -Elpi derive.mR list. -Print list_mR. - -Elpi Query lp:{{ - F = {{ fun (A : Type) (l : list A) => match l with nil => unit | cons a l => Prop end }}. - %coq.elaborate-skeleton F Ty FE ok, - coq.typecheck F Ty ok. - coq.say F. - %F = {{ fun b : bool => match b with true => unit | false => Prop end }}. - %std.findall (param {{ option }} {{ option }} T ) Rules, - %std.findall (param {{ list }} {{ list }} T ) Rules, - %std.findall (mymap-db {{ option nat }} {{ option nat }} C ) Rules, - %coq.typecheck T Ty _, - coq.say Rules. - -}}. diff --git a/generic/mymap.elpi b/generic/mymap.elpi deleted file mode 100644 index bc32c541..00000000 --- a/generic/mymap.elpi +++ /dev/null @@ -1,223 +0,0 @@ -/* map over a container */ -/* license: GNU Lesser General Public License Version 2.1 or later */ -/* ------------------------------------------------------------------------- */ - -shorten std.{split-at, length, rev, append, do!, drop-last, assert!}. - -mymap-db (app[global (indt GR1)|A1]) (app[global (indt GR2)|A2]) R :- - coq.env.indt GR1 _ Lno1 _ _ _ _, - coq.env.indt GR2 _ Lno2 _ _ _ _, - {length A1} > Lno1, {length A2} > Lno2, - split-at Lno1 A1 Args1 Points1, - split-at Lno2 A2 Args2 Points2, - Points1 = Points2, !, - mymap-db {coq.mk-app (global (indt GR1)) Args1} {coq.mk-app (global (indt GR2)) Args2} F, - coq.mk-app F Points1 R. - -namespace derive.mymap { - -% Building the body %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -pred bo-idx - i:term, % inductive arity (input) - i:term, % inductive type (input) applied to params & idx handled so far - i:term, % inductive type (output) applied to params & idx handled so far - i:int, % current index no - o:int, % Recno - i:list term, % rev list of (output) parameters - o:term, % body - o:term. % type - -bo-idx (prod _ S1 T1) Ity1 Ity2 N M Ps (fun `x` S1 Bo) (prod `x` S1 Ty) :- !, - pi x\ sigma Ity1x Ity2x\ - coq.mk-app Ity1 [x] Ity1x, - coq.mk-app Ity2 [x] Ity2x, - N1 is N + 1, - decl x `x` S1 => bo-idx (T1 x) Ity1x Ity2x N1 M Ps (Bo x) (Ty x). - -bo-idx (sort _) Ity1 Ity2 N N Ps (fun `x` Ity1 Bo) (prod `_` Ity1 _\ Ity2) :- !, - @pi-decl `x` Ity1 x\ - coq.build-match x Ity1 (bo-idx-rty Ps Ity2) (bo-k-args Ps) (Bo x). - -bo-idx X Ity1 Ity2 N M Ps R1 R2 :- whd1 X X1, !, - bo-idx X1 Ity1 Ity2 N M Ps R1 R2. - -pred bo-idx-rty i:list term, i:term, i:term, i:list term, i:list term, o:term. -bo-idx-rty Ps ItyArgs _ Vs _ R :- - rev Vs [_|IdxsRev], - rev IdxsRev Idxs, - coq.safe-dest-app ItyArgs HD _, - coq.mk-app HD {append {rev Ps} Idxs} R. - -pred bo-k-args i:list term, i:term, i:term, i:list term, i:list term, o:term. -bo-k-args ParamsRev K _ Args Tys R :- - rev ParamsRev Params, - coq.safe-dest-app K (global (indc GR)) _, - coq.env.typeof (indc GR) T, coq.subst-prod Params T KT, - (bo-k-args.aux {coq.mk-app (global (indc GR)) Params} Args Tys KT R), - !. % the first combination that typechecks - -% pred map.aux i:term, o:term. -% map.aux (prod T N B) (prod T N B). -% map.aux FRel R :- -% coq.mk-app {{ map }} [FRel] R. - -bo-k-args.aux R [] [] _ R :- coq.typecheck R _ ok. -bo-k-args.aux K [A|As] [T|Ts] (prod _ S Ty) R :- - mymap-db T S FRel, - % map.aux FRel F, - coq.mk-app {{ map }} [FRel] 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 :- - mymap-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] [_|Ts] (prod _ _ Ty) R :- !, - bo-k-args.aux {coq.mk-app K [A]} As Ts (Ty A) R. -bo-k-args.aux K As Ts X R :- whd1 X X1, !, - bo-k-args.aux K As Ts X1 R. - - -% Take in input a mapping function for each parameter -% and then do the fixpoint - -pred bo-params - i:int, % current parameter - i:int, % number of parameters - i:term, % inductive type (input) applied to parameters handled so far - i:term, % inductive type (output) applied to parameters handled so far - i:term, % inductive arity (input) - i:term, % inductive arity (output) - i:list term, % output parameters so far - o:term. % map function - -bo-params Lno Lno Ity1 Ity2 A1 _ Ps (fix `f` Recno Fty Bo) :- - coq.safe-dest-app Ity1 (global (indt I)) _, coq.env.recursive? I, !, - @pi-decl `rec` Fty f\ - mymap-db Ity1 Ity2 f => - bo-idx A1 Ity1 Ity2 0 Recno Ps (Bo f) Fty. -bo-params Lno Lno Ity1 Ity2 A1 _ Ps Bo :- - bo-idx A1 Ity1 Ity2 0 _ Ps Bo _. - -bo-params N Lno Ity1 Ity2 (prod A Sty1 Rty1) (prod _ Sty2 Rty2) Ps R :- - 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 \ mk-map-ty a Sty1 b Sty2 (FAB a b) f _ (Clause a b f)), - R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Af (FAB a b) f\ Bo a b f), - pi a b f\ sigma Ity1A Ity2A \ - coq.mk-app Ity1 [a] Ity1A, - coq.mk-app Ity2 [b] Ity2A, - Clause a b f => - decl a A1 Sty1 => - decl b A2 Sty2 => - decl f Af (FAB a b) => - bo-params N1 Lno Ity1A Ity2A (Rty1 a) (Rty2 b) [b|Ps] (Bo a b f). - -bo-params N Lno Ity1 Ity2 T OT Ps R :- - whd1 T T1, whd1 OT OT1, !, - bo-params N Lno Ity1 Ity2 T1 OT1 Ps R. - -bo-params _ _ _ _ _ _ _ _ :- - stop "derive.map: Indexed data types not supported". - -pred map-pi i:any, o:list prop. -map-pi (x\ []) []. -map-pi (x\ [X x| XS x]) [pi x\ X x | YS] :- map-pi XS YS. - -pred mk-map-ty - i:term, % input variable - i:term, % and its type - i:term, % output variable - i:term, % an its type - o:term, % type of a mapping function from input to output - i:term, % map function (having the type above) - o:int, % arity of the predicate - o:list prop. % mymap-db clause for map function -mk-map-ty A (prod _ SA T1) B (prod _ SB T2) (prod `x` SA x\ R x) F N C1 :- - mymap-db SA SB Fa, !, - (pi x\ sigma Ax Fx BFx \ - coq.mk-app A [x] Ax, coq.mk-app Fa [x] Fx, coq.mk-app B [Fx] BFx, - mk-map-ty Ax (T1 x) BFx (T2 BFx) (R x) {coq.mk-app F [x]} M (C x), - N is M + 1), - map-pi C C1. -mk-map-ty A (prod _ S1 T1) B (prod _ _ T2) (prod `x` S1 x\ R x) F N C1 :- - (pi x\ sigma Ax Bx \ coq.mk-app A [x] Ax, coq.mk-app B [x] Bx, - mk-map-ty Ax (T1 x) Bx (T2 x) (R x) {coq.mk-app F [x]} M (C x), - N is M + 1), - map-pi C C1. -% mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ {{ Param10.Rel lp:A lp:B }} (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- -mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ (prod `x` A _\ B) (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- - drop-last 1 XS LA, - drop-last 1 YS LB, - drop-last 1 GS LF, - coq.mk-app X LA PLA, - coq.mk-app Y LB PLB, - coq.mk-app G LF PLF. -mk-map-ty A _ B _ {{ Param10.Rel lp:A lp:B }} F 0 [mymap-db A B F]. -% mk-map-ty A _ B _ (prod `x` A _\ B) F 0 [mymap-db A B F]. - -% Build a clause %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -pred mk-clause - i:int, % current parameter - i:int, % number of parameters - i:term, % inductive type (input) - i:term, % inductive type (output) - i:term, % arity of the inductive - i:list prop, % premises of the clause - i:term, % map function - o:prop. % clause for mymap-db -mk-clause N N Ity1 Ity2 _ Todo Map (mymap-db Ity1 Ity2 Map :- Todo). -mk-clause N Lno Ity1 Ity2 (prod _ _ T) Todo Map (pi x y f\ C x y f) :- !, - N1 is N + 1, - pi x y f\ sigma Ity1x Ity2y Mapf\ - coq.mk-app Ity1 [x] Ity1x, - coq.mk-app Ity2 [y] Ity2y, - coq.mk-app Map [x,y,f] Mapf, - mk-clause N1 Lno Ity1x Ity2y (T x) [mymap-db x y f|Todo] Mapf (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. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -pred main i:inductive, i:string, o:list prop. -main GR Prefix C :- do! [ - T = global (indt GR), - coq.env.indt GR _Ind Lno Luno Arity _ _, - assert! (Lno = Luno) "derive.map: Non-uniform parameters not supported", - - % generate map and add to the env - (bo-params 0 Lno T T Arity Arity [] RSkel), - std.assert-ok! (coq.elaborate-skeleton RSkel Rty R) "derive.mymap generates illtyped term", - Name is Prefix ^ "mymap", - coq.ensure-fresh-global-id Name FName, - coq.env.add-const FName R Rty @transparent! Funct, - - % generate clause and add to the db - mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause, - coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-def (global (indt GR)) (global (const Funct)))), - coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ Clause), - coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-done GR)), - C = [mymap-done GR,Clause, (mymap-def (global (indt GR)) (global (const Funct)))] -]. - -} -/* -namespace derive.mymap { - - pred main i:inductive, i:string, o:list prop. - main GR Prefix Clauses :- std.do! [ - %... % synthesize Body and Type - Name is Prefix ^ "myconcept", - coq.ensure-fresh-global-id Name FName, - coq.env.add-const FName Body Type _ C, - Clauses = [mymap-done GR, mymap-db GR (const C)], - std.forall Clauses (x\ - coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ x) - ), - ]. - -} -*/ \ No newline at end of file diff --git a/generic/param2_inhab.elpi b/generic/param2_inhab.elpi deleted file mode 100644 index eefd8139..00000000 --- a/generic/param2_inhab.elpi +++ /dev/null @@ -1,134 +0,0 @@ -/* param2 holds on the full type */ -/* license: GNU Lesser General Public License Version 2.1 or later */ -/* ------------------------------------------------------------------------- */ - -shorten std.{zip, assert!, do!, map, map2, rev}. - -namespace derive.param2.inhab { - -% local data base to map a constructor K of T (applied to params) to -% the pair isK and its type, eg ({{Zero}} `-> pr {{isZero}} {{isNat Zero}})) -type (`->) term -> pair term term -> prop. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -pred search i:term, i:term, o:term. % given T and isT it builds a proof forall x:T, isT x - -search _ Goal P :- - std.assert! (param2-inhab-db Goal P) "derive.param2_inhab: cannot prove inhabitation". - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -pred prove-args % for each (K x ..) we must produce (isK x x_isX ..) - i:list term, % the variables (x in the example above) - i:term, % the type of isK - o:list term. % x and x_isX -prove-args [] _ []. -prove-args [V|VS] (prod _ T x\ (prod _ T y\ (prod _ _ (pxy\ F x y pxy)))) [V,V,PV | RS] :- - param T T TR, !, % out of the type of x we get isX - search T TR PT, % PT is a proof that forall x, isX x - PV = app[PT,V], % PV is the x_isX above - param V V PV => prove-args VS (F V V PV) RS. - -pred oty i:(term -> term), i:term, i:list term, i:list term, o:term. -oty F _ V _ R :- rev V [X|_], R = F X. - -% MkBranch: Constructor ConstructorTyUnderLams LamBoundVars TheirTypes Result -pred body i:term, i:term, i:list term, i:list term, o:term. -body K _ V _ R :- - coq.safe-dest-app K Kname _, - Kname `-> (pr KR KRT), - coq.say V, - prove-args V KRT Args, - coq.mk-app KR Args R. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -pred body-params - i:int, % number of params left - i:term, % inductive type applied to parameters treated so far - i:term, % inductive type arity to process - i:list term, % construcors applied to parameters treated so far - i:list term, % construcor's types instantiated to parameters treated so far - o:term. - -body-params 0 IsT (prod _ T _\ prod _ T _\ sort _) K KT R :- coq.safe-dest-app T (global (indt GR)) _, coq.env.recursive? GR, !, - RT = (x\ {coq.mk-app IsT [x,x]}), - R = {{ fix IH (x : lp:T) {struct x} : lp:(RT x) := lp:(Bo IH x) }}, - coq.env.indt GR _ _ _ _ KX _, - map2 KX {zip K KT} (a\b\r\ r = (global (indc a)) `-> b) K2KR, - K2KR => % K `-> (pr isK isKtype) - @pi-decl `IH` (prod `x` T x\ RT x) f\ - @pi-decl `x` T x\ - param2-inhab-db IsT f => - coq.build-match x T - (oty RT) - body - (Bo f x). - -body-params 0 IsT (prod _ T _\ prod _ T _\ sort _) K KT R :- !, - RT = (x\ {coq.mk-app IsT [x,x]}), - R = {{ fun (x : lp:T) => lp:(Bo x) }}, - coq.safe-dest-app T (global (indt GR)) _, - coq.env.indt GR _ _ _ _ KX _, - map2 KX {zip K KT} (a\b\r\ r = (global (indc a)) `-> b) K2KR, - K2KR => % K `-> (pr isK isKtype) - @pi-decl `x` T x\ - coq.build-match x T (oty RT) body (Bo x). - -% param1 have the form : isT A (P : A -> Type) .. , so we process two -% param2 have the form : isT A B (P : A -> B -> Type) .. , so we process three ... -% binders at a time and we assume (H : trivial P) for each A and P -% binders at a time and we assume (H : full2self P) for each A and P -body-params N IsT (prod A TA a\ (prod _ _ b\ (prod P (TP a b) (F a b)))) K KT R :- N > 0, coq.sort? TA, !, - M is N - 3, - R = (fun A TA a\ - %fun B TA b\ - fun P (TP a a) p\ - fun _ {{ lib:elpi.derive.full2self lp:a lp:p }} pf\ Bo a p pf), - @pi-decl A TA a\ - %@pi-decl B TA b\ - @pi-decl P (TP a a) p\ - @pi-decl _ {{ lib:elpi.derive.full2self lp:a lp:p }} pf\ - sigma KAP KTAP\ - map K (k\ coq.mk-app k [a,a,p]) KAP, - map KT (coq.subst-prod [a,a,p]) KTAP, - param a a p => - param2-inhab-db p pf => % to prove (P x) use (H x) - body-params M {coq.mk-app IsT [a,a,p]} (F a a p) KAP KTAP (Bo a p pf). -body-params N IsT (prod A TA a\ (prod _ _ b\ prod P (TP a b) (F a b))) K KT R :- N > 0, !, - M is N - 3, - R = (fun A TA a\ - %fun B TA b\ - fun P (TP a a) p\ - Bo a a p), - @pi-decl A TA a\ - %@pi-decl A TA b\ - @pi-decl P (TP a a) p\ - sigma KAP KTAP\ - map K (k\ coq.mk-app k [a,a,p]) KAP, - map KT (coq.subst-prod [a,a,p]) KTAP, - param a a p => - body-params M {coq.mk-app IsT [a,a,p]} (F a a p) KAP KTAP (Bo a a p). - -body-params _ IsT _ _ _ _ :- - M is "derive.param2_inhab: wrong shape " ^ {coq.term->string IsT} ^ - ". It does not look like a unary parametricity translation of an inductive with no indexes.", - stop M. - -pred main i:inductive, i:string, o:list prop. -main GR Suffix [ClauseW, param2-inhab-done GR] :- std.spy-do! [ - - coq.env.indt GR Ind Lno Luno Arity K KT, - assert! (Ind = tt) "derive.param2_inhab: Coinductive types are not supported", - assert! (Lno = Luno) "derive.param2_inhab: Non-uniform parameters not supported", - body-params Lno (global (indt GR)) Arity {std.map K (k\r\ r = global (indc k))} KT RSkel, - coq.say {coq.term->string R}, - std.assert-ok! (coq.elaborate-skeleton RSkel RT R) "derive.param2_inhab generates illtyped term", - - Name is {coq.gref->id (indt GR)} ^ Suffix, - coq.env.add-const Name R RT @transparent! Witness, - - ClauseW = (param2-inhab-db (global (indt GR)) (global (const Witness))), - coq.elpi.accumulate _ "derive.param2.trivial.db" (clause _ _ ClauseW), - coq.elpi.accumulate _ "derive.param2.trivial.db" (clause _ _ (param2-inhab-done GR)), -]. - -} \ No newline at end of file diff --git a/generic/param2_inhab.v b/generic/param2_inhab.v deleted file mode 100644 index 077f0a6d..00000000 --- a/generic/param2_inhab.v +++ /dev/null @@ -1,556 +0,0 @@ -(* Given an inductive type I and its unary parametricity translation is_ it - generates a proof of - forall i : I, is_U i - and then a proof of - forall i : I, { p : is_I i & forall q, p = q }. - - license: GNU Lesser General Public License Version 2.1 or later - ------------------------------------------------------------------------- *) -From elpi.apps.derive.elpi Extra Dependency "paramX_lib.elpi" as paramX. -From elpi.apps.derive.elpi Extra Dependency "param2.elpi" as param2. -(* From elpi.apps.derive.elpi Extra Dependency "param1_inhab.elpi" as param1_inhab. *) -From Trocq Extra Dependency "param2_inhab.elpi" as param2_inhab. -From Trocq Extra Dependency "param2_trivial.elpi" as param2_trivial. -From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. - -From elpi Require Import elpi. -From elpi.apps Require Import derive.param1 derive.param2 derive.param1_trivial. - -Definition full2 T1 T2 P := forall (x : T1)(y : T2), P x y. -Register full2 as elpi.derive.full2. - -Definition full2self T P := forall (x : T), P x x. -Register full2self as elpi.derive.full2self. - -Definition contracts2self T P (x : T) w u := (@existT (P x x) (fun u : P x x=> forall v : P x x,@eq (P x x) u v) w u). -About contracts2self. -Register contracts2self as elpi.derive.contracts2self. - - Elpi Db derive.param2.trivial.db lp:{{ - - pred param2-trivial-done i:inductive. - type param2-trivial-db term -> term -> prop. - type param2-trivial-db-args list term -> list term -> prop. - - pred param2-inhab-done i:inductive. - type param2-inhab-db term -> term -> prop. - type param2-inhab-db-args list term -> list term -> prop. - -}}. -#[superglobal] Elpi Accumulate derive.param2.trivial.db File derive.lib. -#[superglobal] Elpi Accumulate derive.param2.trivial.db Db Header derive.param2.db. -#[superglobal] Elpi Accumulate derive.param2.trivial.db lp:{{ - - :name "param2:inhab:start" - param2-inhab-db - (fun `f` (prod `_` S _\ T) f\ - prod `x` S x\ prod `px` (RS x) _) - (fun `f` (prod `_` S _\ T) f\ - fun `x` S x\ - fun `px` (RS x) _\ P f x) :- - pi f x\ - param T T R, - param2-inhab-db R PT, - coq.mk-app PT [{coq.mk-app f [x]}] (P f x). - - param2-inhab-db (app [Hd|Args]) (app[P|PArgs]) :- - param2-inhab-db Hd P, !, - param2-inhab-db-args Args PArgs. - - param2-inhab-db-args [] []. - param2-inhab-db-args [T,P|Args] R :- - std.assert-ok! (coq.typecheck T Ty) "param2-inhab-db: cannot work illtyped term", - if (coq.sort? Ty) - (param2-inhab-db P Q, R = [T,P,Q|PArgs], param2-inhab-db-args Args PArgs) - (R = [T,P|PArgs], param2-inhab-db-args Args PArgs). - - :name "param2:trivial:start" - param2-trivial-db (fun `f` (prod `_` S _\ T) f\ - prod `x` S x\ prod `px` (RS x) _) - (fun `f` (prod `_` S _\ T) f\ - fun `x` S x\ - fun `px` (RS x) _\ P f x) :- - pi f x\ - param T T R, - param2-trivial-db R PT, - coq.mk-app PT [{coq.mk-app f [x]}] (P f x). - - param2-trivial-db (app [Hd|Args]) (app[P|PArgs]) :- - param2-trivial-db Hd P, !, - param2-trivial-db-args Args PArgs. - - param2-trivial-db-args [] []. - param2-trivial-db-args [T,P|Args] R :- - std.assert-ok! (coq.typecheck T Ty) "param2-trivial-db: cannot work on illtyped term", - if (coq.sort? Ty) - (param2-trivial-db P Q, R = [T,P,Q|PArgs], param2-trivial-db-args Args PArgs) - (R = [T,P|PArgs], param2-trivial-db-args Args PArgs). - -}}. - - -(* standalone *) -Elpi Command derive.param2.trivial. -Elpi Accumulate File derive_hook. -Elpi Accumulate File paramX. -Elpi Accumulate File param2. -Elpi Accumulate Db derive.param2.db. -(* Elpi Accumulate Db derive.param2.congr.db. *) -Elpi Accumulate Db derive.param2.trivial.db. -Elpi Accumulate File param2_inhab. -Elpi Accumulate File param2_trivial. -Elpi Accumulate lp:{{ - main [str I] :- !, coq.locate I (indt GR), - derive.param2.inhab.main GR "_inhab" CL, - CL => derive.param2.trivial.main GR "_trivial" _. - main _ :- usage. - - usage :- - coq.error "Usage: derive.param2.trivial ". -}}. - - -Elpi Command derive.param2.inhab. -Elpi Accumulate File derive_hook. -Elpi Accumulate File paramX. -Elpi Accumulate File param2. -Elpi Accumulate Db derive.param2.db. -(* Elpi Accumulate Db derive.param1.congr.db. *) -Elpi Accumulate Db derive.param2.trivial.db. -Elpi Accumulate File param2_inhab. -Elpi Accumulate lp:{{ - main [str I] :- !, coq.locate I (indt GR), - derive.param2.inhab.main GR "_inhab" _. - main _ :- usage. - - usage :- - coq.error "Usage: derive.param2.inhab ". -}}. - -(* ad-hoc rules for primitive data, eq and is_true *) - -(* Module Export exports. -Elpi derive.param2.trivial is_bool. -End exports. *) - -Definition is_uint63_inhab x : is_uint63 x. Proof. constructor. Defined. -Register is_uint63_inhab as elpi.derive.is_uint63_inhab. - -Definition is_float64_inhab x : is_float64 x. Proof. constructor. Defined. -Register is_float64_inhab as elpi.derive.is_float64_inhab. - -Definition is_pstring_inhab s : is_pstring s. Proof. constructor. Defined. -Register is_pstring_inhab as elpi.derive.is_pstring_inhab. - -Definition is_eq_inhab - A (PA : A -> Type) (HA : trivial A PA) (x : A) (px: PA x) y (py : PA y) (eq_xy : x = y) : - is_eq A PA x px y py eq_xy. -Proof. - revert py. - case eq_xy; clear eq_xy y. - intro py. - rewrite <- (trivial_uniq A PA HA x px); clear px. - rewrite <- (trivial_uniq A PA HA x py); clear py. - apply (is_eq_refl A PA x (trivial_full A PA HA x)). -Defined. -Register is_eq_inhab as elpi.derive.is_eq_inhab. - -(* Definition is_true_inhab b (H : is_bool b) p : is_is_true b H p := - is_eq_inhab bool is_bool is_bool_trivial b H true is_true p. -Register is_true_inhab as elpi.derive.is_true_inhab. *) - - -(* Elpi Accumulate derive.param2.trivial.db lp:{{ - - :before "param2:inhab:start" - param2-inhab-db {{ lib:elpi.derive.is_uint63 }} {{ lib:elpi.derive.is_uint63_inhab }}. - :before "param2:inhab:start" - param2-inhab-db {{ lib:elpi.derive.is_float64 }} {{ lib:elpi.derive.is_float64_inhab }}. - :before "param2:inhab:start" - param2-inhab-db {{ lib:elpi.derive.is_pstring }} {{ lib:elpi.derive.is_pstring_inhab }}. - :before "param2:inhab:start" - param2-inhab-db {{ lib:elpi.derive.is_eq }} {{ lib:elpi.derive.is_eq_inhab }}. - :before "param2:inhab:start" - param2-inhab-db {{ lib:elpi.derive.is_true }} {{ lib:elpi.derive.is_true_inhab }}. - - - :before "param2:inhab:start" - param2-inhab-db - {{ lib:elpi.derive.is_eq lp:A lp:PA lp:X lp:PX lp:Y lp:PY }} - {{ lib:elpi.derive.is_eq_inhab lp:A lp:PA lp:QA lp:X lp:PX lp:Y lp:PY }} :- !, - param2-trivial-db PA QA. - - :before "param2:inhab:start" - param2-inhab-db {{ lib:elpi.derive.is_is_true lp:B lp:PB }} R :- !, - param2-inhab-db {{ lib:elpi.derive.is_eq lib:elpi.bool lib:elpi.derive.is_bool lp:B lp:PB lib:elpi.true lib:elpi.derive.is_true }} R. - -}}. *) - - -Definition is_uint63_trivial : trivial PrimInt63.int is_uint63 := - fun x => contracts _ is_uint63 x (is_uint63_inhab x) - (fun y => match y with uint63 i => eq_refl end). -Register is_uint63_trivial as elpi.derive.is_uint63_trivial. - -Definition is_float64_trivial : trivial PrimFloat.float is_float64 := - fun x => contracts _ is_float64 x (is_float64_inhab x) - (fun y => match y with float64 i => eq_refl end). -Register is_float64_trivial as elpi.derive.is_float64_trivial. - -(* Definition is_pstring_trivial : trivial lib:elpi.pstring is_pstring := - fun x => contracts _ is_pstring x (is_pstring_inhab x) - (fun y => match y with pstring i => eq_refl end). -Register is_pstring_trivial as elpi.derive.is_pstring_trivial. *) - -Lemma is_eq_trivial A (PA : A -> Type) (HA : trivial A PA) (x : A) (px: PA x) - y (py : PA y) - : trivial (x = y) (is_eq A PA x px y py). -Proof. - intro p. - apply (contracts (x = y) (is_eq A PA x px y py) p (is_eq_inhab A PA HA x px y py p)). - revert py. - case p; clear p y. - rewrite <- (trivial_uniq _ _ HA x px). clear px. - intros py. - rewrite <- (trivial_uniq _ _ HA x py). clear py. - intro v; case v; clear v. - unfold is_eq_inhab. - unfold trivial_full. - unfold trivial_uniq. - case (HA x); intros it def_it; compute. - case (def_it it). - reflexivity. -Defined. -Register is_eq_trivial as elpi.derive.is_eq_trivial. - -(* Definition is_true_trivial b (H : is_bool b) : trivial (lib:elpi.is_true b) (is_is_true b H) := - is_eq_trivial bool is_bool is_bool_trivial b H true is_true. -Register is_true_trivial as elpi.derive.is_true_trivial. *) - - -Elpi Accumulate derive.param2.trivial.db lp:{{ - - :before "param2:trivial:start" - param2-trivial-db {{ lib:elpi.derive.is_uint63 }} {{ lib:elpi.derive.is_uint63_trivial }}. - :before "param2:trivial:start" - param2-trivial-db {{ lib:elpi.derive.is_float64 }} {{ lib:elpi.derive.is_float64_trivial }}. - %:before "param2:trivial:start" - %param2-trivial-db {{ lib:elpi.derive.is_pstring }} {{ lib:elpi.derive.is_pstring_trivial }}. - :before "param2:trivial:start" - param2-trivial-db {{ lib:elpi.derive.is_eq }} {{ lib:elpi.derive.is_eq_trivial }}. - %:before "param2:trivial:start" - %param2-trivial-db {{ lib:elpi.derive.is_true }} {{ lib:elpi.derive.is_true_trivial }}. - - - :before "param2:trivial:start" - param2-trivial-db - {{ lib:elpi.derive.is_eq lp:A lp:PA lp:X lp:PX lp:Y lp:PY }} - {{ lib:elpi.derive.is_eq_trivial lp:A lp:PA lp:QA lp:X lp:PX lp:Y lp:PY }} :- - param2-trivial-db PA QA. - - :before "param2:trivial:start" - param2-trivial-db {{ lib:elpi.derive.is_is_true lp:B lp:PB }} R :- !, - param2-trivial-db {{ lib:elpi.derive.is_eq lib:elpi.bool lib:elpi.derive.is_bool lp:B lp:PB lib:elpi.true lib:elpi.derive.is_true }} R. - -}}. - -(* hook into derive *) -Elpi Accumulate derive Db derive.param2.trivial.db. -Elpi Accumulate derive File param2_inhab. -(* Elpi Accumulate derive File param2_trivial. *) - -#[phases="both"] Elpi Accumulate derive lp:{{ -%dep1 "param2_trivial" "param2_inhab". -%dep1 "param2_trivial" "param2_congr". -dep1 "param2_inhab" "param2". -}}. - -#[synterp] Elpi Accumulate derive lp:{{ - derivation _ _ (derive "param2_inhab" (cl\ cl = []) true). - %derivation _ _ (derive "param2_trivial" (cl\ cl = []) true). -}}. - -Elpi Accumulate derive lp:{{ - -derivation (indt T) _ ff (derive "param2_inhab" (derive.on_param1 T derive.param2.inhab.main "_inhab") (derive.on_param1 T (T\_\_\param2-inhab-done T) _ _)). -%derivation (indt T) _ ff (derive "param2_trivial" (derive.on_param1 T derive.param2.trivial.main "_trivial") (derive.on_param1 T (T\_\_\param2-trivial-done T) _ _)). - -}}. - -Elpi Export derive.param2.inhab. - -Module tests. -(* ========= *) -(* ENUM *) -(* ========= *) -Inductive empty :=. -Elpi derive.param1 empty. -Elpi derive.param2 empty. -Elpi derive.param1.trivial is_empty. -Print is_empty_trivial. -Definition wish : forall x : empty, {u : is_empty x & forall v : is_empty x, u = v}. -intros x. -refine (contracts empty is_empty x (is_empty_inhab x) _). -fix IH 1. -intros v. -refine (match v as i in (is_empty s1) return (is_empty_inhab s1 = i) with end). -Defined. -Elpi Trace Browser. -Fail Elpi derive.param2.trivial empty_R. -Print is_empty_trivial. -Elpi derive.param2.inhab empty_R. -Check empty_R_inhab : forall x : empty, empty_R x x. -Print empty_R_inhab. - -Elpi derive.param2 unit. -Elpi derive.param2.inhab unit_R. -Check unit_R_inhab : forall x : unit, unit_R x x. -Print unit_R_inhab. -Elpi derive.param1 unit. -Elpi derive.param1.trivial is_unit. -Print is_unit_trivial. -Definition wish2 : forall (x : unit), {u : is_unit x & forall v : is_unit x, u = v}. -Proof. -intros x. -refine (contracts unit is_unit x (is_unit_inhab x) _). -fix IH 1. -intros v. -refine (match v as i in (is_unit s1) - return (is_unit_inhab s1 = i) - with | is_tt => eq_refl - end). -Defined. -Print wish2. -Elpi derive.param1 nat. -Elpi derive.param1.trivial is_nat. -Import EqNotations. -Print EqNotations. -Definition wish3 : forall (x : unit), {u : unit_R x x & forall v : unit_R x x, u = v}. -Proof. -intros x. -refine (contracts2self unit unit_R x (unit_R_inhab x) _). -(* induction x. *) -fix IH 1. -intros v. -(* refine match v with (tt_R ) => _ end. *) -Show Proof. -refine ((match v as i in (unit_R s1 s2) - return (forall (e : s2 = s1), (unit_R_inhab s1 = rew e in i)) - with | tt_R => fun e => match e with eq_refl => _ end - end) eq_refl). -Show Proof. -reflexivity. -Defined. -(* Unset Printing Notations. *) -(* Print wish3. *) - -Elpi derive.param2 nat. -Elpi derive.param2.inhab nat_R. -Print is_nat_trivial. -Print trivial_uniq. - -Definition wish4 : forall (x : nat), {u : nat_R x x & forall v : nat_R x x, u = v}. -Proof. -intros x. -refine (contracts2self nat nat_R x (nat_R_inhab x) _). -(* induction x. *) -generalize x. -fix IH 2. -intros x' v. -refine ((match v as i in (nat_R s1 s2) - return (forall (e : s2 = s1), (nat_R_inhab s1 = rew e in i)) - with | O_R => fun e => match e with eq_refl => _ end - | S_R y y' IH => fun e => match e with eq_refl => _ end - end) eq_refl). - Show Proof. -+ exact IDProp. -(* False. *) -Unshelve. -exact e. -assumption. -+ cbn. - rewrite (Eqdep_dec.UIP_refl_nat _ e); - reflexivity. - Show Proof. -+ exact IDProp. -+ -(* Unset Printing Notations. *) -simpl. -assert( y' = y ). - injection e; intros; assumption. -subst; cbn; rewrite (Eqdep_dec.UIP_refl_nat _ e); simpl. -f_equal; apply IH0. -Qed. - -Axiom todo : forall {T}, T. -Definition wish5 : forall (x : nat), {u : nat_R x x & forall v : nat_R x x, u = v}. -Proof. -intros x. -refine (contracts2self nat nat_R x (nat_R_inhab x) _). -(* induction x. *) -generalize x. -fix IH 2. -intros x' v. -unshelve refine ((match v as i in (nat_R s1 s2) - return (forall (e : s2 = s1), (nat_R_inhab s1 = rew e in i)) - with | O_R => fun e => match e as e0 in (_ = n) - return (match n with - | O => nat_R_inhab 0 = rew [nat_R 0] e in O_R - | S n => IDProp end) - with eq_refl => _ end - | S_R y y' IH => fun e => match e with eq_refl => _ end - end) eq_refl). - -+ rewrite (Eqdep_dec.UIP_refl_nat _ e); cbn; reflexivity. -+ assert( y' = y ). - injection e; intros; assumption. - Show Proof. -subst. -Show Proof. - rewrite H in e, IH. -(* cbn; rewrite (Eqdep_dec.UIP_refl_nat _ e); simpl. *) - cbn; rewrite (Eqdep_dec.UIP_refl_nat _ e); simpl. -f_equal; apply IH0. - - -Definition wish6 : forall (x : unit), {u : unit_R x x & forall v : unit_R x x, u = v}. -Proof. -intros x. -refine (contracts2self unit unit_R x (unit_R_inhab x) _). -(* induction x. *) -fix IH 1. -intros v. -(* refine match v with (tt_R ) => _ end. *) -Show Proof. -Fail refine ((match v as i in (unit_R s1 s2) - return (forall (e : s2 = s1), unit_R_inhab s1 = i) - with | tt_R => fun e => match e with eq_refl => _ end - end) eq_refl). -Abort. -(* Show Proof. -reflexivity. -Defined. *) - -Elpi derive.param2 bool. -(* Elpi derive.param2.inhab bool_R. *) -Elpi derive.param1.trivial is_bool. -Elpi derive.param2.inhab bool_R. - - -Definition wish6 : forall (x : bool), {u : bool_R x x & forall v : bool_R x x, u = v}. -Proof. -intros x. -refine (contracts2self bool bool_R x (bool_R_inhab x) _). -(* induction x. *) -fix IH 1. -intros v. -(* refine match v with (tt_R ) => _ end. *) -Show Proof. -refine ((match v as i in (bool_R s1 s2) - return (forall (e : s2 = s1), bool_R_inhab s1 = rew [bool_R s1] e in i) - with | true_R => fun e => match e with eq_refl => _ end - | false_R => fun e => match e with eq_refl => _ end - end) eq_refl). -Show Proof. -simpl. -reflexivity. -reflexivity. -Qed. - - -Inductive bool2 := -| ATrue : unit -> bool2 -| AFalse : unit -> bool2. - -Elpi derive.param2 bool2. -Elpi derive.param1 bool2. -(* Elpi derive.param2.inhab bool_R. *) -Elpi derive.param1.trivial is_bool2. -Elpi derive.param2.inhab bool2_R. - -Definition wish7 : forall (x : bool2), {u : bool2_R x x & forall v : bool2_R x x, u = v}. -Proof. -intros x. -refine (contracts2self bool2 bool2_R x (bool2_R_inhab x) _). -fix IH 1. -intros v. -Show Proof. -refine ((match v as i in (bool2_R s1 s2) - return (forall (e : s2 = s1), bool2_R_inhab s1 = rew [bool2_R s1] e in i) - with | ATrue_R u u' uR => fun e => match e with eq_refl => _ end - | AFalse_R u u' uR => fun e => match e with eq_refl => _ end - end) eq_refl). -Show Proof. -Abort. - - -Inductive bool3 := -| ATrue3 : unit -> bool3 -| AFalse3 : bool -> bool3. - -Elpi derive.param2 bool3. -Elpi derive.param1 bool3. -(* Elpi derive.param2.inhab bool_R. *) -Elpi derive.param1.trivial is_bool3. -Elpi derive.param2.inhab bool3_R. - -Definition wish7 : forall (x : bool3), {u : bool3_R x x & forall v : bool3_R x x, u = v}. -Proof. -intros x. -refine (contracts2self bool3 bool3_R x (bool3_R_inhab x) _). -fix IH 1. -intros v. -Show Proof. -refine ((match v as i in (bool3_R s1 s2) - return (forall (e : s2 = s1), bool3_R_inhab s1 = rew [bool3_R s1] e in i) - with | ATrue3_R u u' uR => fun e => match e with eq_refl => _ end - | AFalse3_R b b' bR => fun e => match e with eq_refl => _ end - end) eq_refl). -Show Proof. -simpl. -reflexivity. -reflexivity. -Qed. -(* ========= *) -(* Mentioning other inductives *) -(* ========= *) -Inductive box_unit := B : unit -> box_unit. -Elpi derive.param2 box_unit. -Elpi derive.param2.inhab box_unit_R. -Check box_unit_R_inhab : forall x : box_unit, box_unit_R x x. -Print box_unit_R_inhab. - -(* ========= *) -(* RECURSIVE *) -(* ========= *) - -(* Elpi derive.param2 nat. *) -Elpi derive.param2.inhab nat_R. -Check nat_R_inhab : forall x, nat_R x x. -Print nat_R_inhab. - -(* ========= *) -(* Parametric *) -(* ========= *) -Inductive wrap (A : Type) := W : A -> wrap. -Elpi derive.param2 wrap. -Elpi derive.param2.inhab wrap_R. -Check wrap_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : wrap A), wrap_R A A R x x. -Print wrap_R_inhab. - - -Inductive option (A : Type) := None | Some : A -> option. -Elpi derive.param2 option. -Elpi derive.param2.inhab option_R. -Check option_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : option A), option_R A A R x x. -Print option_R_inhab. - - -Inductive list (A : Type) := Nil | Cons : A -> list. -Elpi derive.param2 list. -Elpi derive.param2.inhab list_R. -Check list_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : list A), list_R A A R x x. -Print list_R_inhab. - -End tests. diff --git a/generic/param2_trivial.elpi b/generic/param2_trivial.elpi deleted file mode 100644 index 912bf4e7..00000000 --- a/generic/param2_trivial.elpi +++ /dev/null @@ -1,130 +0,0 @@ -/* param2 holds on the full type */ -/* license: GNU Lesser General Public License Version 2.1 or later */ -/* ------------------------------------------------------------------------- */ - -shorten std.{assert!, do!, drop-last}. - -namespace derive.param2.trivial { - -pred prove-args i:list term, i:list term, o:list term. -prove-args [] [] []. -prove-args [X,PX|Rest] [TX,TPX_X|TRest] [X,P1,PX,P2|PRest] :- - coq.safe-dest-app TPX_X HD ARGS, - drop-last 1 ARGS ARG, - coq.mk-app HD ARG TPX, - param2-trivial-db TPX P, !, - P1 = {{ lib:elpi.derive.trivial_full lp:TX lp:TPX lp:P lp:X }}, - P2 = {{ lib:elpi.derive.trivial_uniq lp:TX lp:TPX lp:P lp:X lp:PX }}, - prove-args Rest TRest PRest. - -pred oty i:term, i:term, i:term, i:list term, i:list term, o:term. -oty IsT W _ [Idx,V] _ {{ lib:@elpi.eq lp:Ty lp:Wx lp:V }} :- - Ty = app[IsT,Idx], Wx = app[W,Idx]. - -pred body i:term, i:term, i:term, i:term, i:list term, i:list term, o:term. -body _ _ K (app _) V VT R :- std.do! [ - /* - coq.safe-dest-app K (global (indc Kname)) Params, - - prove-args V VT P, - assert! (param2-congr-db Kname CongrK) "run derive.param2.congr first", - coq.mk-app CongrK Params Rhd, - coq.mk-app Rhd P R,*/ - trivialize-param2 V VT Triv, - do-args {std.rev V} {std.rev VT} {std.rev Triv} [] K R, -]. - -pred trivialize-param2 i:list term, i:list term, o:list term. -trivialize-param2 [] [] []. -trivialize-param2 [_,_|XS] [_,TPX|PS] [TPX1,T|TS] :- std.do! [ - coq.safe-dest-app TPX HD ARGS, - drop-last 1 ARGS ARG, - coq.mk-app HD ARG TPX1, - param2-trivial-db TPX1 T, - trivialize-param2 XS PS TS, -]. - -pred do-args i:list term, i:list term, i:list term, i:list term, i:term, o:term. -do-args [] [] [] _ _ {{ lib:@elpi.erefl _ _ }}. -do-args [PX,X|XS] [_,TX|PS] [Triv,P|Trivs] Old K R :- std.do! [ - Q = {{ lib:elpi.derive.trivial_uniq lp:TX lp:P lp:Triv lp:X lp:PX }}, - F = {{ lib:elpi.derive.trivial_full lp:TX lp:P lp:Triv lp:X }}, - std.assert-ok! (coq.typecheck Q TQ) "wtf", - (pi v\ - coq.mk-app K {std.rev {std.append {std.append Old [v,X]} XS}} (K1 v)), - std.append Old [F,X] Old1, - coq.build-match Q TQ (do-oty K1 PX) (do-body XS PS Trivs Old1 K) R, -]. - -pred do-oty i:(term -> term), i:term, i:term, i:list term, i:list term, o:term. -do-oty K E _ [V,_] _ {{ lib:@elpi.eq _ _ lp:KV }} :- copy E V => copy (K V) KV. - -pred do-body i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term, i:list term, i:list term, o:term. -do-body XS PS Trivs Old K _ _ _ _ R :- do-args XS PS Trivs Old K R. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -pred body-params - i:int, % number of params left - i:term, % inductive type applied to parameters treated so far - i:term, % inductive type arity to process - o:term. - -body-params 0 IsT (prod _ T _\ prod _ T _\ sort _) R :- !, std.do! [ - std.assert! (param2-inhab-db IsT W) "www", - R = {{ fun x : lp:T => - lib:elpi.derive.contracts2self lp:T lp:IsT x (lp:W x) - ((fix IH (x : lp:T) (y : lp:IsT x x) {struct y} : - lib:@elpi.eq (lp:IsT x x) (lp:W x x) y := lp:{{ { - - param2-trivial-db IsT {{ fun x : lp:T => - lib:elpi.derive.contracts2self lp:T lp:IsT x (lp:W x x) (IH x) }} => - coq.build-match {{y}} {{lp:IsT x x}} (oty IsT W) (body IsT W) - } }} - ) x) }}, -]. - -% param1 have the form : isT A (P : A -> Type) .. , so we process two -% param2 have the form : isT A B (P : A -> B -> Type) .. , so we process two -% binders at a time and we assume (H : trivial P) for each A and P -body-params N T (prod A TA a\ prod P (TP a) (F a)) R :- N > 0, 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\ { - decl a A TA => - decl p P (TP a) => - decl pf `_` {{ lib:elpi.derive.trivial lp:a lp:p }} => - param a a p => - param2-trivial-db p pf => % to prove (P x) use (H x) - param2-inhab-db p {{ lib:elpi.derive.trivial_full lp:a lp:p lp:pf }} => % to prove (P x) use (H x) - body-params M {coq.mk-app T [a,p]} - (F a p)}). -body-params N T (prod A TA a\ prod P (TP a) (F a)) R :- N > 0, !, - M is N - 2, - R = (fun A TA a\ - fun P (TP a) p\ { - decl a A TA => - decl p P (TP a) => - param a a p => - body-params M {coq.mk-app T [a,p]} (F a p)}). - -body-params _ T _ _ :- - coq.say "derive.param2_trivial: wrong shape " {coq.term->string T} - ". It does not look like a unary parametricity translation of an inductive with no indexes.", - fail. - -pred main i:inductive, i:string, o:list prop. -main GR Suffix [Clause,param2-trivial-done GR] :- do! [ - coq.env.indt GR _ Lno _ Arity _ _, - body-params Lno (global (indt GR)) Arity R, - % coq.say {coq.term->string R}, - std.assert-ok! (coq.typecheck R RT) "derive.param2_trivial generates illtyped term", - - Name is {coq.gref->id (indt GR)} ^ Suffix, - coq.env.add-const Name R RT @transparent! Cst, - Clause = (param2-trivial-db (global (indt GR)) (global (const Cst))), - coq.elpi.accumulate _ "derive.param2.trivial.db" (clause _ _ Clause), - coq.elpi.accumulate _ "derive.param2.trivial.db" (clause _ _ (param2-trivial-done GR)), -]. - -} \ No newline at end of file diff --git a/generic/test_param2_inhab.v b/generic/test_param2_inhab.v deleted file mode 100644 index abbbbb1d..00000000 --- a/generic/test_param2_inhab.v +++ /dev/null @@ -1,67 +0,0 @@ - -(* From elpi.apps Require Import derive.std. *) -From elpi.apps Require Import derive.param2. -Require Import param2_inhab. - - -(* ========= *) -(* ENUM *) -(* ========= *) -Inductive empty :=. -Elpi derive.param2 empty. -Elpi derive.param2.inhab empty_R. -Check empty_R_inhab : forall x : empty, empty_R x x. -Print empty_R_inhab. - -Elpi derive.param2 unit. -Elpi derive.param2.inhab unit_R. -Check unit_R_inhab : forall x : unit, unit_R x x. -Print unit_R_inhab. - -Elpi derive.param2 bool. -Elpi derive.param2.inhab bool_R. -Check bool_R_inhab : forall x : bool, bool_R x x. -Print bool_R_inhab. - - -(* ========= *) -(* Mentioning other inductives *) -(* ========= *) -Inductive box_unit := B : unit -> box_unit. -Elpi derive.param2 box_unit. -Elpi derive.param2.inhab box_unit_R. -Check box_unit_R_inhab : forall x : box_unit, box_unit_R x x. -Print box_unit_R_inhab. - -(* ========= *) -(* RECURSIVE *) -(* ========= *) - -Elpi derive.param2 nat. -Elpi Trace Browser. -About nat_R. -Elpi derive.param2.inhab nat_R. -Check nat_R_inhab : forall x, nat_R x x. -Print nat_R_inhab. - -(* ========= *) -(* Parametric *) -(* ========= *) -Inductive wrap (A : Type) := W : A -> wrap. -Elpi derive.param2 wrap. -Elpi derive.param2.inhab wrap_R. -Check wrap_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : wrap A), wrap_R A A R x x. -Print wrap_R_inhab. - - -Inductive option (A : Type) := None | Some : A -> option. -Elpi derive.param2 option. -Elpi derive.param2.inhab option_R. -Check option_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : option A), option_R A A R x x. -Print option_R_inhab. - -Inductive list (A : Type) := Nil | Cons : A -> list. -Elpi derive.param2 list. -Elpi derive.param2.inhab list_R. -Check list_R_inhab : forall (A : Type) (R : A -> A -> Type) (H : full2self A R) (x : list A), list_R A A R x x. -Print list_R_inhab. \ No newline at end of file diff --git a/std/_CoqProject b/std/_CoqProject index 7d445fba..4cd5feed 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -29,19 +29,16 @@ generic/Param_vector.v generic/Trocq.v generic/Vernac.v --R ../algo Trocq.Algo --R ../tests Trocq.Tests - -../tests/coverage.v -../algo/mymap.v -../tests/test_mymap.v -../algo/injection_lemmas.v -../tests/test_injection_lemmas.v -../algo/mR.v -../tests/test_mR.v -../algo/Rm.v -../tests/test_Rm.v -../algo/injK.v -../tests/test_injK.v -../algo/mRRmK.v -../tests/test_mRRmK.v \ No newline at end of file +algo/tests/coverage.v +algo/theories/mymap.v +algo/tests/test_mymap.v +algo/theories/injection_lemmas.v +algo/tests/test_injection_lemmas.v +algo/theories/mR.v +algo/tests/test_mR.v +algo/theories/Rm.v +algo/tests/test_Rm.v +algo/theories/injK.v +algo/tests/test_injK.v +algo/theories/mRRmK.v +algo/tests/test_mRRmK.v \ No newline at end of file diff --git a/detailed/DetailedRm.v b/std/algo/detailed/DetailedRm.v similarity index 99% rename from detailed/DetailedRm.v rename to std/algo/detailed/DetailedRm.v index 3b2b3438..82b68ded 100644 --- a/detailed/DetailedRm.v +++ b/std/algo/detailed/DetailedRm.v @@ -2,7 +2,8 @@ From Coq Require Import ssreflect. From elpi.apps.derive Require Import derive derive.param2. From Trocq Require Import mymap. (* injection_lemmas. *) -Require Import HoTT_additions Hierarchy. +(* Require Import HoTT_additions Hierarchy. *) +Require Import Hierarchy. Unset Uniform Inductive Parameters. (* Unset Universe Minimization ToSet. *) diff --git a/detailed/Detailed_injijK.v b/std/algo/detailed/Detailed_injijK.v similarity index 98% rename from detailed/Detailed_injijK.v rename to std/algo/detailed/Detailed_injijK.v index 7a25d544..96c2a68f 100644 --- a/detailed/Detailed_injijK.v +++ b/std/algo/detailed/Detailed_injijK.v @@ -1,7 +1,8 @@ From Coq Require Import ssreflect ssrfun ssrbool. -From Trocq.Algo Require Import mR Rm. -From Trocq.Tests Require Import coverage. -From Trocq Require Import HoTT_additions Hierarchy. +From Trocq Require Import mR Rm. +From Trocq Require Import coverage. +From Trocq Require Import Hierarchy. +(* From Trocq Require Import HoTT_additions Hierarchy. *) Unset Uniform Inductive Parameters. Elpi derive.param2 False. diff --git a/detailed/Detailed_mRRmK.v b/std/algo/detailed/Detailed_mRRmK.v similarity index 88% rename from detailed/Detailed_mRRmK.v rename to std/algo/detailed/Detailed_mRRmK.v index a2204c2d..88019b50 100644 --- a/detailed/Detailed_mRRmK.v +++ b/std/algo/detailed/Detailed_mRRmK.v @@ -1,7 +1,10 @@ From Coq Require Import ssreflect ssrfun ssrbool. -From Trocq.Algo Require Import mR Rm injK. -From Trocq.Tests Require Import coverage. -From Trocq Require Import HoTT_additions Hierarchy. +From Trocq Require Import mR Rm injK. +From Trocq Require Import Hierarchy. +From Trocq Require Import HoTTNotations. +From Trocq Require Import coverage. +(* Search (?e ^). *) +(* From Trocq Require Import HoTT_additions Hierarchy. *) Unset Uniform Inductive Parameters. Elpi derive.param2 False. @@ -78,10 +81,13 @@ refine (fun w1 w2 wR=> _). refine (Wrap_R_ind Wrap_Pred _ w1 w2 wR). - refine (fun u1 u2 uR => _). refine (match -(Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))^ in _ = t +(@eq_sym _ _ _ (Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))) +(* (Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))^ *) +in _ = t return KWrap1_R u1 u2 (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR with eq_refl => _ end ). + refine (match (Unit_mRRmK u1 u2 uR)^ in _ = t return KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR with eq_refl => eq_refl end @@ -124,6 +130,10 @@ refine (fun w1 w2 wR => _). refine (WrapMore_R_ind WrapMore_Pred _ _ _ w1 w2 wR). - refine (fun u1 u2 uR => _). refine (fun b1 b2 bR => _). + simpl. + (* Set Printing All. *) + cbn beta. + cbn iota beta delta. refine (match (WrapMore_injK11 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^ in _ = t return KWrap_R u1 u2 (Unit_mR u1 u2 t) b1 b2 @@ -155,11 +165,22 @@ bcongr.eq_f Bool WrapMore (Bool_Rm b1 b2 bR)))) = KWrap_R u1 u2 uR b1 b2 bR with eq_refl => _ end). -refine (match (WrapMore_injK12 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^ in _ = t -return +set RWe1 := (WrapMore_injK12 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^. +set eqf1 := bcongr.eq_f _ _ _ _ _ _. +set eqf2 := bcongr.eq_f _ _ _ _ _ _. +Set Printing All. + +set T := WrapMore_injections12 (Unit_mymap u1) u2 (Bool_mymap b1) b2 +(bcongr.eq_f Unit WrapMore (KWrap^~ (Bool_mymap b1)) (Unit_mymap u1) u2 +(Unit_Rm u1 u2 uR) @ +(bcongr.eq_f Bool WrapMore [eta KWrap u2] (Bool_mymap b1) b2 (Bool_Rm b1 b2 bR) @ +1)). +refine (match (WrapMore_injK12 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^ +(* in _ = t *) +(* return KWrap_R u1 u2 uR b1 b2 (Bool_mR b1 b2 t) = -KWrap_R u1 u2 uR b1 b2 bR +KWrap_R u1 u2 uR b1 b2 bR *) with eq_refl => _ end ). refine (match (Bool_mRRmK _ _ bR)^ in _ = t return diff --git a/detailed/DetailedmR.v b/std/algo/detailed/DetailedmR.v similarity index 99% rename from detailed/DetailedmR.v rename to std/algo/detailed/DetailedmR.v index f4a887f2..cc7efe1b 100644 --- a/detailed/DetailedmR.v +++ b/std/algo/detailed/DetailedmR.v @@ -1,7 +1,8 @@ From Coq Require Import ssreflect. From elpi.apps.derive Require Import derive derive.param2. From Trocq Require Import mymap injection_lemmas. -Require Import HoTT_additions Hierarchy. +Require Import Hierarchy. +(* Require Import HoTT_additions Hierarchy. *) Unset Uniform Inductive Parameters. (* Unset Universe Polymorphism. *) Unset Universe Minimization ToSet. diff --git a/algo/Rm.elpi b/std/algo/elpi/Rm.elpi similarity index 100% rename from algo/Rm.elpi rename to std/algo/elpi/Rm.elpi diff --git a/algo/common_algo.elpi b/std/algo/elpi/common_algo.elpi similarity index 100% rename from algo/common_algo.elpi rename to std/algo/elpi/common_algo.elpi diff --git a/algo/injK.elpi b/std/algo/elpi/injK.elpi similarity index 100% rename from algo/injK.elpi rename to std/algo/elpi/injK.elpi diff --git a/algo/injection_lemmas.elpi b/std/algo/elpi/injection_lemmas.elpi similarity index 100% rename from algo/injection_lemmas.elpi rename to std/algo/elpi/injection_lemmas.elpi diff --git a/algo/mR.elpi b/std/algo/elpi/mR.elpi similarity index 100% rename from algo/mR.elpi rename to std/algo/elpi/mR.elpi diff --git a/algo/mRRmK.elpi b/std/algo/elpi/mRRmK.elpi similarity index 100% rename from algo/mRRmK.elpi rename to std/algo/elpi/mRRmK.elpi diff --git a/algo/mymap.elpi b/std/algo/elpi/mymap.elpi similarity index 100% rename from algo/mymap.elpi rename to std/algo/elpi/mymap.elpi diff --git a/algo/utils.elpi b/std/algo/elpi/utils.elpi similarity index 100% rename from algo/utils.elpi rename to std/algo/elpi/utils.elpi diff --git a/tests/coverage.v b/std/algo/tests/coverage.v similarity index 100% rename from tests/coverage.v rename to std/algo/tests/coverage.v diff --git a/tests/test_Rm.v b/std/algo/tests/test_Rm.v similarity index 92% rename from tests/test_Rm.v rename to std/algo/tests/test_Rm.v index 4a7c0fb2..eead86e1 100644 --- a/tests/test_Rm.v +++ b/std/algo/tests/test_Rm.v @@ -1,5 +1,5 @@ -From Trocq.Algo Require Import Rm. -From Trocq.Tests Require Import coverage. +From Trocq Require Import Rm. +From Trocq Require Import coverage. From Trocq Require Import Hierarchy. Unset Uniform Inductive Parameters. diff --git a/tests/test_injK.v b/std/algo/tests/test_injK.v similarity index 92% rename from tests/test_injK.v rename to std/algo/tests/test_injK.v index cb6c578c..cae2cc38 100644 --- a/tests/test_injK.v +++ b/std/algo/tests/test_injK.v @@ -1,5 +1,5 @@ -From Trocq.Algo Require Import injK. -From Trocq.Tests Require Import coverage. +From Trocq Require Import injK. +From Trocq Require Import coverage. From Trocq Require Import Hierarchy. Unset Uniform Inductive Parameters. diff --git a/tests/test_injection_lemmas.v b/std/algo/tests/test_injection_lemmas.v similarity index 87% rename from tests/test_injection_lemmas.v rename to std/algo/tests/test_injection_lemmas.v index 4bd289f8..fe66f545 100644 --- a/tests/test_injection_lemmas.v +++ b/std/algo/tests/test_injection_lemmas.v @@ -1,5 +1,5 @@ -From Trocq.Algo Require Import injection_lemmas. -From Trocq.Tests Require Import coverage. +From Trocq Require Import injection_lemmas. +From Trocq Require Import coverage. Unset Uniform Inductive Parameters. Elpi derive.projK False. diff --git a/tests/test_mR.v b/std/algo/tests/test_mR.v similarity index 95% rename from tests/test_mR.v rename to std/algo/tests/test_mR.v index 56d125dc..c5eceb78 100644 --- a/tests/test_mR.v +++ b/std/algo/tests/test_mR.v @@ -1,5 +1,5 @@ -From Trocq.Algo Require Import mR. -From Trocq.Tests Require Import coverage. +From Trocq Require Import mR. +From Trocq Require Import coverage. From Trocq Require Import Hierarchy. Unset Uniform Inductive Parameters. diff --git a/tests/test_mRRmK.v b/std/algo/tests/test_mRRmK.v similarity index 86% rename from tests/test_mRRmK.v rename to std/algo/tests/test_mRRmK.v index b329789f..5626d3d3 100644 --- a/tests/test_mRRmK.v +++ b/std/algo/tests/test_mRRmK.v @@ -1,5 +1,5 @@ -From Trocq.Algo Require Import mR Rm injK mRRmK. -From Trocq.Tests Require Import coverage. +From Trocq Require Import mR Rm injK mRRmK. +From Trocq Require Import coverage. From Trocq Require Import Hierarchy. Unset Uniform Inductive Parameters. @@ -38,7 +38,7 @@ Elpi derive.injections Wrap. Elpi derive.isK Wrap. Elpi derive.mR Wrap. Elpi derive.Rm Wrap. -Elpi derive.mRRmK Wrap. +Fail Elpi derive.mRRmK Wrap. Elpi derive.param2 WrapMore. Elpi derive.mymap WrapMore. @@ -47,7 +47,7 @@ Elpi derive.injections WrapMore. Elpi derive.isK WrapMore. Elpi derive.mR WrapMore. Elpi derive.Rm WrapMore. -Elpi derive.mRRmK WrapMore. +Fail Elpi derive.mRRmK WrapMore. Elpi derive.param2 Nat. Elpi derive.mymap Nat. @@ -56,7 +56,7 @@ Elpi derive.injections Nat. Elpi derive.isK Nat. Elpi derive.mR Nat. Elpi derive.Rm Nat. -Elpi derive.mRRmK Nat. +Fail Elpi derive.mRRmK Nat. Elpi derive.param2 Box. Elpi derive.mymap Box. @@ -65,7 +65,7 @@ Elpi derive.injections Box. Elpi derive.isK Box. Elpi derive.mR Box. Elpi derive.Rm Box. -Elpi derive.mRRmK Box. +Fail Elpi derive.mRRmK Box. Elpi derive.param2 Option. Elpi derive.mymap Option. @@ -74,7 +74,7 @@ Elpi derive.injections Option. Elpi derive.isK Option. Elpi derive.mR Option. Elpi derive.Rm Option. -Elpi derive.mRRmK Option. +Fail Elpi derive.mRRmK Option. Elpi derive.param2 Prod. Elpi derive.mymap Prod. @@ -83,7 +83,7 @@ Elpi derive.injections Prod. Elpi derive.isK Prod. Elpi derive.mR Prod. Elpi derive.Rm Prod. -Elpi derive.mRRmK Prod. +Fail Elpi derive.mRRmK Prod. Elpi derive.param2 ThreeTypes. Elpi derive.mymap ThreeTypes. @@ -92,7 +92,7 @@ Elpi derive.injections ThreeTypes. Elpi derive.isK ThreeTypes. Elpi derive.mR ThreeTypes. Elpi derive.Rm ThreeTypes. -Elpi derive.mRRmK ThreeTypes. +Fail Elpi derive.mRRmK ThreeTypes. Elpi derive.param2 List. Elpi derive.mymap List. @@ -101,4 +101,4 @@ Elpi derive.injections List. Elpi derive.isK List. Elpi derive.mR List. Elpi derive.Rm List. -Elpi derive.mRRmK List. \ No newline at end of file +Fail Elpi derive.mRRmK List. \ No newline at end of file diff --git a/tests/test_mymap.v b/std/algo/tests/test_mymap.v similarity index 81% rename from tests/test_mymap.v rename to std/algo/tests/test_mymap.v index 12aa9fef..a68d1a8c 100644 --- a/tests/test_mymap.v +++ b/std/algo/tests/test_mymap.v @@ -1,6 +1,6 @@ -From Trocq.Tests Require Import coverage. +From Trocq Require Import coverage. From elpi Require Import elpi. -From Trocq.Algo Require Import mymap. +From Trocq Require Import mymap. From Trocq Require Import Hierarchy. Unset Uniform Inductive Parameters. diff --git a/algo/Rm.v b/std/algo/theories/Rm.v similarity index 85% rename from algo/Rm.v rename to std/algo/theories/Rm.v index e06b7686..bc60b302 100644 --- a/algo/Rm.v +++ b/std/algo/theories/Rm.v @@ -1,12 +1,12 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Algo Extra Dependency "Rm.elpi" as Rm. -From Trocq.Algo Extra Dependency "common_algo.elpi" as common. -From Trocq.Algo Extra Dependency "utils.elpi" as algo_utils. +From Trocq Extra Dependency "algo/elpi/Rm.elpi" as Rm. +From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. +From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. From elpi Require Import elpi. From elpi.apps Require Import derive.param2. From elpi.apps Require Import derive.bcongr. (* for eq_f register *) -From Trocq.Algo Require Import mymap. +From Trocq Require Import mymap. From elpi.apps Require Import derive.induction. (* From Trocq Require Import HoTT_additions Hierarchy. *) From Trocq Require Import Hierarchy. diff --git a/algo/injK.v b/std/algo/theories/injK.v similarity index 89% rename from algo/injK.v rename to std/algo/theories/injK.v index e7b46922..3576b6c5 100644 --- a/algo/injK.v +++ b/std/algo/theories/injK.v @@ -1,8 +1,8 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Algo Extra Dependency "injK.elpi" as injK. -From Trocq.Algo Extra Dependency "utils.elpi" as algo_utils. -From Trocq.Algo Require Import injection_lemmas. +From Trocq Extra Dependency "algo/elpi/injK.elpi" as injK. +From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. +From Trocq Require Import injection_lemmas. From elpi Require Import elpi. From elpi.apps Require Import derive.bcongr. (* for eq_f register *) diff --git a/algo/injection_lemmas.v b/std/algo/theories/injection_lemmas.v similarity index 90% rename from algo/injection_lemmas.v rename to std/algo/theories/injection_lemmas.v index cc5c06c5..bea16f01 100644 --- a/algo/injection_lemmas.v +++ b/std/algo/theories/injection_lemmas.v @@ -1,8 +1,8 @@ From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Algo Extra Dependency "injection_lemmas.elpi" as injections. -From Trocq.Algo Extra Dependency "utils.elpi" as algo_utils. +From Trocq Extra Dependency "algo/elpi/injection_lemmas.elpi" as injections. +From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. From elpi Require Import elpi. From elpi.apps Require Import derive.bcongr. (* for eq_f register *) diff --git a/algo/mR.v b/std/algo/theories/mR.v similarity index 89% rename from algo/mR.v rename to std/algo/theories/mR.v index 71cd3225..e13a854e 100644 --- a/algo/mR.v +++ b/std/algo/theories/mR.v @@ -1,8 +1,8 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. -From Trocq.Algo Extra Dependency "common_algo.elpi" as common. -From Trocq.Algo Extra Dependency "mR.elpi" as mR. -From Trocq.Algo Require Import mymap injection_lemmas. +From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. +From Trocq Extra Dependency "algo/elpi/mR.elpi" as mR. +From Trocq Require Import mymap injection_lemmas. From elpi Require Import elpi. From elpi.apps Require Import derive.param2 derive.isK. diff --git a/algo/mRRmK.v b/std/algo/theories/mRRmK.v similarity index 90% rename from algo/mRRmK.v rename to std/algo/theories/mRRmK.v index 7af8af21..502fb55f 100644 --- a/algo/mRRmK.v +++ b/std/algo/theories/mRRmK.v @@ -1,7 +1,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Algo Extra Dependency "mRRmK.elpi" as mRRmK. -From Trocq.Algo Require Import injK mR Rm. -From Trocq.Algo Extra Dependency "common_algo.elpi" as common. +From Trocq Extra Dependency "algo/elpi/mRRmK.elpi" as mRRmK. +From Trocq Require Import injK mR Rm. +From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. (* From Trocq.Algo Extra Dependency "utils.elpi" as algo_utils. *) From elpi Require Import elpi. diff --git a/generic/mymap.v b/std/algo/theories/mymap.v similarity index 96% rename from generic/mymap.v rename to std/algo/theories/mymap.v index 99aa99c3..8e240bde 100644 --- a/generic/mymap.v +++ b/std/algo/theories/mymap.v @@ -1,5 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Algo Extra Dependency "mymap.elpi" as mymap. +From Trocq Extra Dependency "algo/elpi/mymap.elpi" as mymap. From elpi Require Import elpi. From elpi.apps Require Import derive. From 3ed6bccb6047924d9abb93a8e7bba09dd0500f9d Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 3 Sep 2025 14:22:43 +0200 Subject: [PATCH 10/42] collecting injKs collecting arguments for rewriting injKs mRRmK for inds with multiple constructors + multiple arguments. No recursion No Typaram mRRmK + recusion mRRmK for type parameters + recursion cleaning mRRmK deriving mRRmK --- std/_CoqProject | 4 +- std/algo/aignore/testing.v | 54 ++++ std/algo/detailed/Detailed_mRRmK.v | 115 +++++--- std/algo/elpi/Rm.elpi | 25 +- std/algo/elpi/injK.elpi | 4 +- std/algo/elpi/injection_lemmas.elpi | 27 +- std/algo/elpi/mR.elpi | 4 +- std/algo/elpi/mRRmK.elpi | 390 +++++++++++++++++++-------- std/algo/elpi/mymap.elpi | 21 +- std/algo/elpi/utils.elpi | 26 ++ std/algo/tests/coverage.v | 3 + std/algo/tests/test_algo.v | 42 +++ std/algo/tests/test_injK.v | 22 +- std/algo/tests/test_mRRmK.v | 28 +- std/algo/theories/Rm.v | 30 ++- std/algo/theories/algo.v | 104 +++++++ std/algo/theories/injK.v | 23 +- std/algo/theories/injection_lemmas.v | 22 +- std/algo/theories/mR.v | 39 ++- std/algo/theories/mRRmK.v | 38 ++- std/algo/theories/mymap.v | 22 +- 21 files changed, 770 insertions(+), 273 deletions(-) create mode 100644 std/algo/aignore/testing.v create mode 100644 std/algo/tests/test_algo.v create mode 100644 std/algo/theories/algo.v diff --git a/std/_CoqProject b/std/_CoqProject index 4cd5feed..111053ee 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -41,4 +41,6 @@ algo/tests/test_Rm.v algo/theories/injK.v algo/tests/test_injK.v algo/theories/mRRmK.v -algo/tests/test_mRRmK.v \ No newline at end of file +algo/tests/test_mRRmK.v +algo/theories/algo.v +algo/tests/test_algo.v \ No newline at end of file diff --git a/std/algo/aignore/testing.v b/std/algo/aignore/testing.v new file mode 100644 index 00000000..7308b4bc --- /dev/null +++ b/std/algo/aignore/testing.v @@ -0,0 +1,54 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +(* From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as inject. *) +(* From elpi.apps.derive.elpi Extra Dependency "bcongr.elpi" as bcongr. *) +From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. +From elpi Require Import elpi. +From elpi Require Import derive derive.bcongr derive.eqK derive.isK. + +(* use elpi.rewrite to implement + forall n m, n = m -> S n = S m. +*) +(* build a function of type forall n1, n1 = 0 -> n1 = 0. +implementing it by case on n1. +O => eq_refl +S n => discriminate. *) +Elpi Command test4. +Elpi Accumulate File discr. +Elpi Accumulate Db derive.isK.db. +Elpi Accumulate lp:{{ + + pred mkty i:(term -> term), i:term, i:list term, i:list term, o:term. + mkty Bo _ Ts _ (Bo X):- + std.last Ts X. + + pred mkBranch i:(term -> term), i:term, i:term, i:term, i:list term, i:list term, o:term. + mkBranch _ K T _ _ _ {{ fun e => eq_refl }} :- + coq.safe-dest-app T K _, !. + mkBranch ((n\ prod (En n) (ETy n) (G n))) _ T _ Ts _ (fun (En Curr) (ETy Curr) e\ (R e)) :- + coq.mk-app T Ts Curr, + coq.elaborate-skeleton (ETy Curr) _ ETyE _, + pi e\ + sigma GE\ + coq.elaborate-skeleton (G Curr e) _ GE _, + ltac.discriminate e ETyE GE (R e). + + % given the type build the function + % Bo n1 = n1 = 0 -> n1 = 0 + pred build i: term, o:term. + build (prod N1 {{nat}} n1\ (Bo n1)) + (fun N1 {{nat}} n1\ (R n1)) :- + @pi-decl N1 {{ nat }} n1\ + coq.build-match n1 {{ nat }} {{ _ }} (mkBranch Bo {{ 0 }}) (R n1). + + main _ :- + RTy = {{ forall (n1 : nat), n1 = 0 -> n1 = 0 }}, + build RTy R, + FName is "def4", + coq.elaborate-skeleton R RTy RE _, + coq.env.add-const FName RE _ _ _. + +}}. +Elpi derive.isK nat. +Elpi Query lp:{{ + main R. +}}. \ No newline at end of file diff --git a/std/algo/detailed/Detailed_mRRmK.v b/std/algo/detailed/Detailed_mRRmK.v index 88019b50..604335d2 100644 --- a/std/algo/detailed/Detailed_mRRmK.v +++ b/std/algo/detailed/Detailed_mRRmK.v @@ -14,7 +14,7 @@ Elpi derive.injections False. Elpi derive.isK False. Elpi derive.mR False. Elpi derive.Rm False. -Elpi derive.injectionsK False. +Elpi derive.injK False. Notation False_Pred := (fun w1 w2 wR => False_mR w1 w2 (False_Rm w1 w2 wR) = wR) (only parsing). Definition False_mRRmK : forall (w1 w2 : False) (wR : False_R w1 w2), False_mR w1 w2 (False_Rm w1 w2 wR) = wR. @@ -60,7 +60,7 @@ Elpi derive.projK Wrap. Elpi derive.injections Wrap. Elpi derive.mR Wrap. Elpi derive.Rm Wrap. -Elpi derive.injectionsK Wrap. +Elpi derive.injK Wrap. Notation Wrap_Pred := (fun w1 w2 wR => Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR) (only parsing). Definition Wrap_mRRmK : forall (w1 w2 : Wrap) (wR : Wrap_R w1 w2), @@ -69,8 +69,8 @@ Proof. refine (fun w1 w2 wR=> _). refine (Wrap_R_ind Wrap_Pred _ w1 w2 wR). - refine (fun u1 u2 uR => _). -refine (@eq_ind_r _ (Unit_Rm u1 u2 uR) (fun t=> KWrap1_R u1 u2 (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR) _ _ (Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))). -refine (@eq_ind_r _ uR (fun t => KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR) _ _ (Unit_mRRmK u1 u2 uR)). +refine (@eq_ind _ _ (fun t=> KWrap1_R _ _ (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR) _ _ (Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))^). +refine (@eq_ind _ uR (fun t => KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR) _ _ (Unit_mRRmK u1 u2 uR)^). exact (@eq_refl (Wrap_R (KWrap1 u1) (KWrap1 u2)) (KWrap1_R u1 u2 uR)). Defined. @@ -79,19 +79,26 @@ Definition Wrap_mRRmK' : forall (w1 w2 : Wrap) (wR : Wrap_R w1 w2), Proof. refine (fun w1 w2 wR=> _). refine (Wrap_R_ind Wrap_Pred _ w1 w2 wR). -- refine (fun u1 u2 uR => _). +- refine (fun u1 u2 uR => _). +unfold Wrap_mR. +unfold Wrap_Rm. +unfold Wrap_R_ind. +simpl. +cbv. refine (match (@eq_sym _ _ _ (Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))) (* (Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))^ *) -in _ = t -return KWrap1_R u1 u2 (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR +(* in _ = t +return KWrap1_R u1 u2 (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR *) with eq_refl => _ end ). +Show Proof. refine (match (Unit_mRRmK u1 u2 uR)^ in _ = t -return KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR +(* return KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR *) with eq_refl => eq_refl end ). +Show Proof. Defined. Elpi derive.param2 WrapMore. @@ -101,24 +108,7 @@ Elpi derive.injections WrapMore. Elpi derive.isK WrapMore. Elpi derive.mR WrapMore. Elpi derive.Rm WrapMore. -Elpi derive.injectionsK WrapMore. - -(* From elpi.apps Require Import eltac.rewrite. - -Axiom add_comm : forall x y, x + y = y + x. -Axiom mul_comm : forall x y, x * y = y * x. - -Goal (forall x : nat, 1 + x = x + 1) -> - forall y, 2 * ((y+y) + 1) = ((y + y)+1) * 2. -Proof. - intro H. - intro x. - eltac.rewrite H. - Show Proof. - eltac.rewrite mul_comm. - Show Proof. - exact eq_refl. -Defined. *) +Elpi derive.injK WrapMore. Notation WrapMore_Pred := (fun w1 w2 wR => WrapMore_mR w1 w2 (WrapMore_Rm w1 w2 wR) = wR) (only parsing). @@ -130,14 +120,22 @@ refine (fun w1 w2 wR => _). refine (WrapMore_R_ind WrapMore_Pred _ _ _ w1 w2 wR). - refine (fun u1 u2 uR => _). refine (fun b1 b2 bR => _). - simpl. - (* Set Printing All. *) - cbn beta. - cbn iota beta delta. - refine (match (WrapMore_injK11 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^ in _ = t + unfold WrapMore_mR. + refine (match (WrapMore_injK11 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^ + (* in _ = t return -KWrap_R u1 u2 (Unit_mR u1 u2 t) b1 b2 +KWrap_R u1 u2 (Unit_mR u1 u2 (Unit_Rm u1 u2 uR)) b1 b2 (Bool_mR b1 b2 +(WrapMore_injections12 (Unit_mymap u1) u2 +(Bool_mymap b1) b2 +(WrapMore_Rm (KWrap u1 b1) (KWrap u2 b2) +(KWrap_R u1 u2 uR b1 b2 bR)))) = +KWrap_R u1 u2 uR b1 b2 bR + *) + +(* KWrap_R u1 u2 (Unit_mR u1 u2 t) b1 b2 _ = +_ *) +(* (Bool_mR b1 b2 (WrapMore_injections12 (Unit_mymap u1) u2 (Bool_mymap b1) b2 @@ -148,8 +146,10 @@ b2 bcongr.eq_f Bool WrapMore [eta KWrap u2] (Bool_mymap b1) b2 (Bool_Rm b1 b2 bR)))) = -KWrap_R u1 u2 uR b1 b2 bR +KWrap_R u1 u2 uR b1 b2 bR *) with eq_refl => _ end). + + refine (match (Unit_mRRmK _ _ uR)^ in _ = t return KWrap_R u1 u2 t b1 b2 (Bool_mR b1 b2 @@ -168,8 +168,6 @@ with eq_refl => _ end). set RWe1 := (WrapMore_injK12 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^. set eqf1 := bcongr.eq_f _ _ _ _ _ _. set eqf2 := bcongr.eq_f _ _ _ _ _ _. -Set Printing All. - set T := WrapMore_injections12 (Unit_mymap u1) u2 (Bool_mymap b1) b2 (bcongr.eq_f Unit WrapMore (KWrap^~ (Bool_mymap b1)) (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR) @ @@ -191,7 +189,8 @@ with eq_refl => eq_refl end - move=> wr1 wr2 wrR. simpl. by rewrite WrapMore_injK21 Wrap_mRRmK. -- move=> ? ? ? ? ? ? ? ? ?. +- move=> u1 u2 uR1 u3 u4 uR2 u5 u6 uR3. +simpl. by rewrite /= WrapMore_injK31 WrapMore_injK32 WrapMore_injK33 !Unit_mRRmK. Defined. @@ -202,8 +201,7 @@ Elpi derive.injections Nat. Elpi derive.isK Nat. Elpi derive.mR Nat. Elpi derive.Rm Nat. -Elpi derive.injectionsK Nat. - +Elpi derive.injK Nat. Notation Nat_Pred := (fun n1 n2 nR => Nat_mR n1 n2 (Nat_Rm n1 n2 nR) = nR) (only parsing). Definition Nat_mRRmK : @@ -215,7 +213,6 @@ refine (fun n1 n2 nR => _). refine (Nat_R_ind Nat_Pred _ _ n1 n2 nR). - exact eq_refl. - refine (fun n1' n2' nR' Hrec=> _ ). -simpl. by rewrite Nat_injK21 f. Defined. @@ -226,7 +223,7 @@ Elpi derive.injections Box. Elpi derive.isK Box. Elpi derive.mR Box. Elpi derive.Rm Box. -Elpi derive.injectionsK Box. +Elpi derive.injK Box. Notation Box_Pred := (fun A1 A2 (AR : Param40.Rel A1 A2) => fun b1 b2 bR => Box_mR A1 A2 AR b1 b2 (Box_Rm A1 A2 AR b1 b2 bR) = bR) (only parsing). @@ -249,7 +246,7 @@ Elpi derive.injections Option. Elpi derive.isK Option. Elpi derive.mR Option. Elpi derive.Rm Option. -Elpi derive.injectionsK Option. +Elpi derive.injK Option. Elpi derive.param2 Prod. Elpi derive.mymap Prod. @@ -258,7 +255,37 @@ Elpi derive.injections Prod. Elpi derive.isK Prod. Elpi derive.mR Prod. Elpi derive.Rm Prod. -Elpi derive.injectionsK Prod. +Elpi derive.injK Prod. + +Notation Prod_Pred := (fun A1 A2 (AR : Param40.Rel A1 A2) A3 A4 (AR2 : Param40.Rel A3 A4) => + fun p1 p2 pR => Prod_mR A1 A2 AR A3 A4 AR2 p1 p2 (Prod_Rm A1 A2 AR A3 A4 AR2 p1 p2 pR) = pR) (only parsing). +Definition Prod_mRRmK : +forall (A1 A2 : Type) (AR : Param40.Rel A1 A2), + forall (A3 A4 : Type) (AR2 : Param40.Rel A3 A4), + forall (p1 : Prod A1 A3) (p2 : Prod A2 A4) (pR: Prod_R A1 A2 AR A3 A4 AR2 p1 p2), + Prod_mR A1 A2 AR A3 A4 AR2 p1 p2 (Prod_Rm A1 A2 AR A3 A4 AR2 p1 p2 pR) = pR. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun A3 A4 AR2=> _). +refine (fun p1 p2 pR=> Prod_R_ind A1 A2 AR A3 A4 AR2 (Prod_Pred A1 A2 AR A3 A4 AR2) _ p1 p2 pR). +refine (fun a1 a2 aR=> _). +refine (fun b1 b2 bR=> _). +unfold Prod_mR. +Check PR. +simpl. +by rewrite Prod_injK11 Prod_injK12 (R_in_mapK AR a1 a2 aR) (R_in_mapK AR2 b1 b2). +Defined. + +Elpi derive.param2 Mix. +(* Fail Elpi derive.mymap Mix. +TODO: fix universe issue +*) +Elpi derive.projK Mix. +Elpi derive.injections Mix. +Elpi derive.isK Mix. +Elpi derive.mR Mix. +Elpi derive.Rm Mix. +Elpi derive.injK Mix. Elpi derive.param2 ThreeTypes. Elpi derive.mymap ThreeTypes. @@ -267,7 +294,7 @@ Elpi derive.injections ThreeTypes. Elpi derive.isK ThreeTypes. Elpi derive.mR ThreeTypes. Elpi derive.Rm ThreeTypes. -Elpi derive.injectionsK ThreeTypes. +Elpi derive.injK ThreeTypes. Elpi derive.param2 List. Elpi derive.mymap List. @@ -276,4 +303,4 @@ Elpi derive.injections List. Elpi derive.isK List. Elpi derive.mR List. Elpi derive.Rm List. -Elpi derive.injectionsK List. +Elpi derive.injK List. diff --git a/std/algo/elpi/Rm.elpi b/std/algo/elpi/Rm.elpi index ca905f69..adcf2896 100644 --- a/std/algo/elpi/Rm.elpi +++ b/std/algo/elpi/Rm.elpi @@ -1,5 +1,5 @@ shorten derive.common-algo.{mk-mR-type-Rm}. -shorten derive.algo-utils.{mk-chain}. +shorten derive.algo-utils.{mk-chain, type-of-args}. namespace derive.Rm { @@ -63,14 +63,6 @@ process-args Ksrc Kdest N TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) (RF = R). - -pred type-of-args i:term, i:int, o:list term, o:list term. -type-of-args _ 0 [] []. -type-of-args (prod _AN1 ATy1 a1\ prod _AN2 ATy2 a2\ prod _ _ ar\ (Bo a1 a2 ar)) N [ATy1| SR] [ATy2 | DR] :- - M is N - 1, - pi a1 a2 ar\ - type-of-args (Bo a1 a2 ar) M SR DR. - % invariant: all type arguments were already processed. % Constructor src, Constructor dest, Constructor dest Type, No of Arguments to process, % constructorR Type, type of i2, something of type : i1 i2 iR => goal. @@ -139,16 +131,18 @@ implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 implement-Rm M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). -pred main i:inductive, i:string, o:list prop. +func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ KNs KTys, Ind = (global (indt GR)), - param Ind Ind TR, + std.assert! (param Ind Ind TR) "derive.Rm: use derive.param2 before", + % param Ind Ind TR, coq.typecheck TR TRTy _, - mymap-def Ind IndMap, + % mymap-def Ind IndMap, + std.assert! (mymap-def Ind IndMap) "derive.Rm: use derive.mymap before", mk-mR-type-Rm TyParamNo TRTy IndMap {{ Type }} TR MRTy, - coq.elaborate-skeleton MRTy _ MRTyE ok, + std.assert-ok! (coq.elaborate-skeleton MRTy _ MRTyE) "derive.Rm generates illtyped type", TR = global (indt GRR), coq.gref->id (indt GRR) Rname, RInductionName is Rname ^ "_ind", @@ -157,12 +151,13 @@ main GR Prefix Clauses :- std.do! [ coq.env.indt GRR _ _ _ _ _ KTyRs, std.map KNs (x\ r\ r = (global (indc x))) Ks, implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KTyRs Pred (global RInd) R, - coq.elaborate-skeleton R MRTyE Re E, + % coq.elaborate-skeleton R MRTyE Re ok, + std.assert-ok! (coq.elaborate-skeleton R MRTyE Re) "derive.Rm generates illtyped term", Name is Prefix ^ "Rm", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName Re MRTyE _ C, I = global (indt GR), - Clauses = [rm-done I, rm-db I (global (const C))], + Clauses = [rm-done GR, rm-db I (global (const C))], std.forall Clauses (x\ coq.elpi.accumulate _ "derive.Rm.db" (clause _ _ x) ), diff --git a/std/algo/elpi/injK.elpi b/std/algo/elpi/injK.elpi index c2ea6855..d6aad435 100644 --- a/std/algo/elpi/injK.elpi +++ b/std/algo/elpi/injK.elpi @@ -178,7 +178,7 @@ implement-injK-types TyParamNo [Kn|KNs] [ArgNo|ArgNos] [InjKTys|InjKTyss] [DestN implement-injK-types TyParamNo KNs ArgNos InjKTyss DestNoss RS. -pred main i:inductive, i:string, o:list prop. +func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ Name is Prefix ^ "injK", @@ -190,7 +190,7 @@ main GR Prefix Clauses :- std.do! [ implement-injK-types TyParamNo KNs ArgNos RTys DestNos RS, name-ijs FName 1 GR KNs RS Register Clausess, std.flatten Clausess Clauses, - ClausesFin = [injectionsK-done (global (indt GR)) | Clauses], + ClausesFin = [injectionsK-done GR | Clauses], std.forall ClausesFin (x\ coq.elpi.accumulate _ "derive.injectionsK.db" (clause _ _ x) ), diff --git a/std/algo/elpi/injection_lemmas.elpi b/std/algo/elpi/injection_lemmas.elpi index 0b0a347d..216c01e6 100644 --- a/std/algo/elpi/injection_lemmas.elpi +++ b/std/algo/elpi/injection_lemmas.elpi @@ -1,4 +1,4 @@ -shorten derive.algo-utils.{duplicate-arguments, count-args, name-ijs}. +shorten derive.algo-utils.{duplicate-arguments, count-args, name-ijs, for-K-get-KI}. namespace derive.injections { @@ -16,23 +16,6 @@ get the Projector GRK ArgNumber, Get the type ProjType, forall ArgTys Args Ind, ret Return the processed Types */ - -% Returns the list of projectors of a constructor. -pred get-projectors i:constructor, i:int, i:int, o:list term. -get-projectors _ Max Max [] :- !. -get-projectors GRK J Max [P|PJs] :- - I is J + 1, - projK-db GRK I P, - get-projectors GRK I Max PJs. - -% for a list of constructors returns a list with all the projectors of that construct -pred for-K-get-projectors i:int, i:list constructor, i:list term, o: list int, o:list (list term). -for-K-get-projectors _ [] [] [] []:- !. -for-K-get-projectors TyParamNo [Kn|KNs] [KTy|KTys] [ArgsNo|ArgsNos] [R|RS]:- - count-args TyParamNo KTy ArgsNo, - get-projectors Kn 0 ArgsNo R, - for-K-get-projectors TyParamNo KNs KTys ArgsNos RS. - % TyParam, ArgNo, F, Type of the equality, Left HS, Right HS % F is of type forall (Typarams : Type) ((Arg1 : A1) (Arg2 : A2) ...), Ret % Ret is discarded and replaced by Left = Right @@ -117,7 +100,11 @@ implement-injectors TyParam [ArgNo | ArgNos] [InjTys | InjTyss] [R | RS ] :- implement-K-injectors TyParam 1 ArgNo InjTys R, implement-injectors TyParam ArgNos InjTyss RS. -pred main i:inductive, i:string, o:list prop. +pred for-K-get-projectors i:int, i:list constructor, i:list term, o: list int, o:list (list term). +for-K-get-projectors TyParamNo KNs KTys ArgsNos PJss :- + for-K-get-KI TyParamNo KNs KTys (grk\ i\ p\ projK-db grk i p) ArgsNos PJss. + +func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ Name is Prefix ^ "injections", coq.ensure-fresh-global-id Name FName, @@ -129,7 +116,7 @@ main GR Prefix Clauses :- std.do! [ Register = (k\j\c\ (injections-db (global (indc k)) j (global (const c)))), name-ijs FName 1 GR KNs Injss Register Clausess, std.flatten Clausess Clauses, - ClausesFin = [injections-done (global (indt GR)) | Clauses], %[injections-done GR, injections GR (const C)], + ClausesFin = [injections-done GR | Clauses], %[injections-done GR, injections GR (const C)], std.forall ClausesFin (x\ coq.elpi.accumulate _ "derive.injections.db" (clause _ _ x) ), diff --git a/std/algo/elpi/mR.elpi b/std/algo/elpi/mR.elpi index beed9083..c0479ba0 100644 --- a/std/algo/elpi/mR.elpi +++ b/std/algo/elpi/mR.elpi @@ -156,7 +156,7 @@ implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) implement-mR M TyParamNo (Bo a1 a2 ar) (R a1 a2 ar). -pred main i:inductive, i:string, o:list prop. +func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ Name is Prefix ^ "mR", coq.env.indt GR _ UnifParamNo _ _ _ _, @@ -171,7 +171,7 @@ main GR Prefix Clauses :- std.do! [ coq.ensure-fresh-global-id Name FName, coq.env.add-const FName TE MRTyE _ C, I = global (indt GR), - Clauses = [mR-done I, mR-db I (global (const C))], + Clauses = [mR-done GR, mR-db I (global (const C))], std.forall Clauses (x\ coq.elpi.accumulate _ "derive.mR.db" (clause _ _ x) ), diff --git a/std/algo/elpi/mRRmK.elpi b/std/algo/elpi/mRRmK.elpi index 802bbf5a..d2d360a1 100644 --- a/std/algo/elpi/mRRmK.elpi +++ b/std/algo/elpi/mRRmK.elpi @@ -1,135 +1,314 @@ shorten derive.common-algo.{mk-mR-type-mRRmK}. -shorten derive.algo-utils.{mk-chain}. +shorten derive.algo-utils.{mk-chain, for-K-get-KI,type-of-args}. namespace derive.mRRmK { +pred collect-ma1-a2 i:int, i:list term, o:list term, o:list term. +collect-ma1-a2 0 _ [] []. +collect-ma1-a2 N [A1, A2| L] [A1|A1s] [A2|A2s] :- + M is N - 1, + collect-ma1-a2 M L A1s A2s. + +pred collect-paths i:int, i:term, o:list term. +collect-paths 0 _ []. +collect-paths N T [P|Ps] :- + M is N - 1, + coq.safe-dest-app T _EqTrans [_,_,_,_,AP1,AP2], + coq.safe-dest-app AP1 _ Args1, + std.last Args1 P, + collect-paths M AP2 Ps. + + % whd beta-iota-delta-zeta, main code +pred whd-fuel i:term, i:stack, i:int, o:term, o:stack. +whd-fuel T S 0 T S. +whd-fuel (app [Hd|Args]) C N X XC :- !, whd-fuel Hd {std.append Args C} N X XC. +whd-fuel (fun _ _ _ as X) [] _ X [] :- !. +whd-fuel (fun N T F) [B|C] M X XC :- !, + (pi x\ def x N T B => cache x BN_ => whd-fuel (F x) C M (F1 x) (C1 x)), X = F1 B, XC = C1 B. +whd-fuel (let N T B F) C M X XC :- !, + (pi x\ def x N T B => cache x BN_ => whd-fuel (F x) C M (F1 x) (C1 x)), X = F1 B, XC = C1 B. +whd-fuel (global (const GR)) C M X XC :- + O is M - 1, unfold GR none C D DC, !, whd-fuel D DC O X XC. +whd-fuel (pglobal (const GR) I) C M X XC :- + O is M - 1, + unfold GR (some I) C D DC, !, whd-fuel D DC O X XC. +whd-fuel (primitive (proj _ N)) [A|C] M X XC :- whd-indc A _ KA, !, + whd-fuel {proj-red KA N C} M X XC. +whd-fuel (global (const GR) as HD) C M X XC :- coq.env.primitive? GR, !, + unwind HD C Orig, + coq.reduction.lazy.whd_all Orig R, + if (same_term Orig R) (X = HD, XC = C) (whd-fuel R [] M X XC). +whd-fuel (match A _ L) C M X XC :- whd-indc A GR KA, !, + whd-fuel {match-red GR KA L C} M X XC. +whd-fuel (fix _ N _ F as Fix) C M X XC :- nth-stack N C LA A RA, whd-indc A GR KA, !, + whd-fuel {fix-red F Fix LA GR KA RA} M X XC. +whd-fuel N C M X XC :- name N, def N _ _ V, !, cache-whd N VN V, whd-fuel VN C M X XC. +whd-fuel X C _ X C. + + +pred iota-step i:term, i:stack, o:term, o:stack. +iota-step (match A _ L) C X XC :- whd-indc A GR KA, !, + match-red GR KA L C X XC. + +% delta beta iota iota +pred red-mR i:term, i:stack, o:term,o:stack. +red-mR X C R RS :- + whd-fuel X C 1 XX CC, + iota-step XX CC XXX CCC, + iota-step XXX CCC R RS. + +% delta beta beta eta delta beta iota (perhaps also starts with an eta red) +pred red-Rm i:term, i:stack, o:term,o:stack. +red-Rm X C R RS :- + whd-fuel X C 2 XX CC, + iota-step XX CC R RS. + +pred feed-injKs i:list term, i:list term, i:list term, i: list term, i:list term, o:list term. +feed-injKs InjKs [] [] [] [] InjKs. +feed-injKs InjKs [] [A1|Args1] [A2|Args2] [Path|Paths] ES :- + std.map InjKs (x\ r\ sigma TMP\ coq.mk-app x [A1,A2,Path] TMP, r = TMP) NewInjKs, + feed-injKs NewInjKs [] Args1 Args2 Paths ES. +feed-injKs InjKs TyArgsDest Args1 Args2 Paths Eqs :- + std.map InjKs (x\ r\ sigma TMP\ coq.mk-app x TyArgsDest TMP, r = TMP) NewInjKs, + feed-injKs NewInjKs [] Args1 Args2 Paths Eqs. + +pred invert-eqs i:list term, o:list term. +invert-eqs Eqs IEqs :- + std.map Eqs (x\r\ sigma Skel TMP Err\ Skel = {{ @eq_sym _ _ _ lp:x}}, + coq.elaborate-skeleton Skel _ TMP ok, + r = TMP + ) IEqs. + +pred collect-arguments i:int, i:int, i:term, o:list term, o:list term, o:list term, o:list term. +collect-arguments TyArgsNo InitArgs MRRM TyArgsDest Args1 Args2 Paths :- + red-mR MRRM [] _KR Args12r, % KR a1 a2 ar b1 b2 br ... + std.last Args12r LastMR, % each xr is xmR x1 x2 (inj Args12 Chain) + coq.safe-dest-app LastMR _NMR Args, + std.last Args Inj, % take the last inj + coq.safe-dest-app Inj _Injin InjArgs, + std.split-at TyArgsNo InjArgs TyArgsDest ArgsChain, % collect Type args + collect-ma1-a2 InitArgs ArgsChain Args1 Args2, % collect mapped args1 and args2 + % Args1 is (map a1), (map b1) + % Args2 is a2 b2 ... + std.last InjArgs Rm, + % last arg is IRm args which reduces to chain + coq.safe-dest-app Rm TheRm RmArgs, + red-Rm TheRm RmArgs Concat ChainArgs, + coq.mk-app Concat ChainArgs Chain, + collect-paths InitArgs Chain Paths. % Paths are Rm1 a1 a2 aR, Rm2 b1 b2 bR, ... + +pred rewrite-with i:list term, i:list term, i:term, o:term. +rewrite-with [] [] End End. +rewrite-with [Eq|Eqs] [Pat|Pats] End R :- + (pi rest\ + (T rest) = {{ @eq_ind _ _ lp:Pat lp:rest _ lp:Eq }}), + rewrite-with Eqs Pats End RestSkel, + coq.elaborate-skeleton RestSkel _ Rest ok, + R = (T Rest). + +pred drop-last i:list A, o:list A. +drop-last L R :- + Take is {std.length L} - 1, + std.take Take L R. + +% number of processed pats, total number of args, list of injK equations, list of patterns, list of resulting goals. +pred pierce-goal-injK i:int, i:int, i:int i:term, i:list term, o:list term, o:term. +pierce-goal-injK _ N N Goal [] [] Goal. +pierce-goal-injK TyParamNo N InitArgs CurrentGoal [Eq|Eqs] [Pat|Pats] EndGoal:- !, + M is N + 1, + coq.safe-dest-app CurrentGoal EqGoal [EqGoalTy,GoalLHS,GoalRHS], + coq.safe-dest-app GoalLHS KR Args, + Done is (TyParamNo * 3) + N * 3, + std.split-at Done Args L [A1,A2, AMRArgs | R], + coq.safe-dest-app AMRArgs AMR MArgs, + coq.typecheck {std.last MArgs} Ty ok, + (pi t\ + drop-last MArgs DArgs, + std.append DArgs [t] (NewMArgs t), + coq.mk-app AMR (NewMArgs t) (NewAMRArgs t), + coq.mk-app KR {std.append L {std.append [A1, A2, (NewAMRArgs t)] R}} (NewKR t), + coq.mk-app EqGoal [EqGoalTy,(NewKR t),GoalRHS] (NewEqGoal t)), + Pat = (fun `t` Ty t\ (NewEqGoal t)), + coq.typecheck Eq EqTy ok, + coq.safe-dest-app EqTy _ [_,LHS,_], + coq.mk-app Pat [LHS] NewGoal, + pierce-goal-injK TyParamNo M InitArgs NewGoal Eqs Pats EndGoal. + +% number of processed pats, total number of args, list of injK equations, list of patterns, list of resulting goals. +pred pierce-goal-mRRmK i:int, i:int, i:int i:term, i:list term, o:list term. +pierce-goal-mRRmK _ N N _ [] []. +pierce-goal-mRRmK TyParamNo N InitArgs CurrentGoal [Eq|Eqs] [Pat|Pats] :- !, + M is N + 1, + coq.safe-dest-app CurrentGoal EqGoal [EqGoalTy,GoalLHS,GoalRHS], + coq.safe-dest-app GoalLHS KR Args, + Done is (TyParamNo * 3) + (N * 3), + std.split-at Done Args L [A1,A2, AMRArgs | R], + coq.typecheck AMRArgs Ty ok, + (pi t\ + coq.mk-app KR {std.append L {std.append [A1, A2, t] R}} (NewKR t), + coq.mk-app EqGoal [EqGoalTy,(NewKR t),GoalRHS] (NewEqGoal t)), + Pat = (fun `t` Ty t\ (NewEqGoal t)), + coq.typecheck Eq EqTy ok, + coq.safe-dest-app EqTy _ [_,LHS,_], + coq.mk-app Pat [LHS] NewGoal, + pierce-goal-mRRmK TyParamNo M InitArgs NewGoal Eqs Pats. + +pred get-mRRmK-args i:list term, o:list (list term). +get-mRRmK-args [] []. +get-mRRmK-args [P|Paths] [Args|Argss] :- + coq.safe-dest-app P _ Args, + get-mRRmK-args Paths Argss. + +pred mix-mRRmK-args i:list term, i:list (list term), o:list term. +mix-mRRmK-args [] [] []. +mix-mRRmK-args [MRRMK| MRRMKs] [Args|Argss] [Eq| Eqs] :- + coq.mk-app MRRMK Args Eq, + mix-mRRmK-args MRRMKs Argss Eqs. + % Ksource, Kdest, remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, -% todo add KR to other cases -pred process-args i:term, i:term, i:int, i:int, i:term, i:term, i:list term, i:list term, i:term, i:term, o:term. +pred process-args i:term, i:term, i:int, i:int, i:int, i:term, i:term, i:term, i:term, +i:list term, i:list term, i:list term, o:term. % zero more arguments to process -process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest ITyTy KR R:- +process-args Ksrc Kdest 0 0 _ _ Goal _ KR _ _ _ R :- + coq.mk-app Goal [Ksrc, Kdest, KR] EqTy, + whd EqTy [] _ [IRTy,_,IR], + R = {{ @eq_refl lp:IRTy lp:IR }}. +process-args Ksrc Kdest 0 InitArgs TyArgsNo _ Goal _ KR InjKs _ MRRMKEq R:- coq.mk-app Goal [Ksrc, Kdest, KR] EqTy, %EqTy is the following type ImR i1 i2 (IRm i1 i2 ir) = ir for this specific branch - whd EqTy [] {{lib:@elpi.eq}} [IRTy,MRRM,IR], - - % whd MapA [] (global (indc _)) TySrcMappedArgs, - % whd B [] KDest TyDestArgs, - % std.drop TyArgsNo TySrcMappedArgs SrcArgs, - % std.drop TyArgsNo TyDestArgs DestArgs, - % coq.mk-app KDest {std.take TyArgsNo TyDestArgs} KAppTyArgs, - % mk-equalities TySrc ITyTy DestArgs Eqs, - + whd EqTy [] HD [IRTy,MRRM,IR], + collect-arguments TyArgsNo InitArgs MRRM TyArgsDest Args1 Args2 Paths, %paths are all + feed-injKs InjKs TyArgsDest Args1 Args2 Paths Eqs, + invert-eqs Eqs IEqs, + std.map MRRMKEq (x\ r\ sigma TMP\ coq.elaborate-skeleton x _ TMP ok, r = TMP) MRRMKElab, + invert-eqs {std.rev MRRMKElab} IEqs2, + End = {{ @eq_refl lp:IRTy lp:IR }}, + coq.mk-app HD [IRTy,{whd1 MRRM},IR] RGoal, % KR a1 a2 ar1[I_Rm] b1 b2 br[I_Rm] + pierce-goal-injK TyArgsNo 0 InitArgs RGoal IEqs PatsInj LastGoal, + pierce-goal-mRRmK TyArgsNo 0 InitArgs LastGoal IEqs2 PatsMRRMK, + rewrite-with {std.append IEqs IEqs2} {std.append PatsInj PatsMRRMK} End R. - % mk-rewrites SrcArgs DestArgs TyDest KAppTyArgs Eqs ITyTy B R, - % for every argument, rewrite under injKi and then the respective mRRmK - R = {{ eq_refl }}. - - % mk-chain SrcArgs DestArgs TyDest KAppTyArgs Eqs ITyTy B R. % still have to process an arg -% process-args Ksrc Kdest N TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal TySrc TyDest ITyTy -% (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- -% M is N - 1, -% @pi-decl AN1 A1Ty a1\ -% @pi-decl AN2 A2Ty a2\ -% @pi-decl ARN (ARTy a1 a2) ar\ -% coq.mk-app Ksrc [a1] (NewKS a1), -% coq.mk-app Kdest [a2] (NewKD a2), -% (param a2 a1 ar => -% process-args (NewKS a1) (NewKD a2) M TyArgsNo (Bo a1 a2 ar) Goal TySrc TyDest ITyTy (R a1 a2 ar)), -% % if the type of the argument is an instance of the inductive type add an induction hypothesis -% whd ITyTy _ Ind _, -% whd A2Ty _ IndD _, -% if (Ind = IndD) -% (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), -% (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) -% (RF = R). - - -% todo: move to utils -% todo: document -pred type-of-args i:term, i:int, o:list term, o:list term. -type-of-args _ 0 [] []. -type-of-args (prod _AN1 ATy1 a1\ prod _AN2 ATy2 a2\ prod _ _ ar\ (Bo a1 a2 ar)) N [ATy1| SR] [ATy2 | DR] :- +process-args Ksrc Kdest N InitArgs TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal ITyTy KR + InjKs [MRRMKSkel|MRRMKs] MRRMKEqs (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- M is N - 1, - pi a1 a2 ar\ - type-of-args (Bo a1 a2 ar) M SR DR. + @pi-decl AN1 A1Ty a1\ + @pi-decl AN2 A2Ty a2\ + @pi-decl ARN (ARTy a1 a2) ar\ + coq.mk-app Ksrc [a1] (NewKS a1), + coq.mk-app Kdest [a2] (NewKD a2), + coq.mk-app KR [a1,a2,ar] (NewKR a1 a2 ar), + coq.mk-app MRRMKSkel [a1,a2,ar] (MRRMK a1 a2 ar), + (ar-db a2 a1 ar ==> + process-args (NewKS a1) (NewKD a2) M InitArgs TyArgsNo (Bo a1 a2 ar) Goal ITyTy (NewKR a1 a2 ar) InjKs MRRMKs [(MRRMK a1 a2 ar)|MRRMKEqs] (R a1 a2 ar)), + % if the type of the argument is an instance of the inductive type add an induction hypothesis + whd ITyTy _ Ind _, + whd A2Ty _ IndD _, + if (Ind = IndD) + (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), + (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) + (RF = R). + +pred feed-mRRmK-type i:list term, i:term, o:term. +feed-mRRmK-type [] T T. +feed-mRRmK-type [A2|Args] T R :- + ar-db A1 A2 AR, + coq.mk-app T [A1, A2, AR] Acc, + feed-mRRmK-type Args Acc R. + +pred find-mRRmK i:list term, i:term, o: list term. +find-mRRmK [] _ []. +find-mRRmK [Ty|Tys] IndTy [MRRMK|MRRMKs] :- + coq.safe-dest-app Ty Ind TyArgs, + mRRmK-db Ind MRRMKS, + if (IndTy = Ind) + (MRRMK = MRRMKS) + (feed-mRRmK-type TyArgs MRRMKS MRRMK), + find-mRRmK Tys IndTy MRRMKs. -% todo: perhaps unify with Rm % invariant: all type arguments were already processed. % Constructor src, Constructor dest, Constructor dest Type, No of Arguments to process, % constructorR Type, type of i2, something of type : i1 i2 iR => goal. -pred mkBranch i:term, i:term, i:int, i:term, i:term, i:term, i:term, o:term. -mkBranch KS KD N KTyR ITyTy Goal KR Eq:- - type-of-args KTyR N SrcArgs DestArgs, - whd ITyTy [] _ TyArgs, - process-args KS KD N {std.length TyArgs} KTyR Goal SrcArgs DestArgs ITyTy KR Eq. - +% Argno, InjKs +pred mkBranch i:term, i:term, i:int, i:term, i:term, i:term, i:term, i:list term, o:term. +mkBranch KS KD N KTyR ITyTy Goal KR InjKs Eq:- + type-of-args KTyR N _ DestArgs, + whd ITyTy [] Hd TyArgs, + find-mRRmK DestArgs Hd MRRMKS, + % for every type dest add mRRmK to a list. + process-args KS KD N N {std.length TyArgs} KTyR Goal ITyTy KR InjKs MRRMKS [] Eq. +pred mkBranches i:list term, i:list term, i:list term, i:list term, i:term, i:term, +i:list term, i:list (list term), o:list term. +mkBranches [] [] [] [] _ _ [] [] []. +mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KTyR|KTyRs] ITyTy Goal [KR|KRs] [InjKs|InjKss] [R|Rs] :- + mkBranch KS KD {coq.count-prods KTy} KTyR ITyTy Goal KR InjKs R, + mkBranches KsS KsD KTys KTyRs ITyTy Goal KRs InjKss Rs. -% todo perhaps unify with Rm mkBranches -pred mkBranches i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:list term, o:list term. -mkBranches [] [] [] [] _ _ [] []. -mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KTyR|KTyRs] ITyTy Goal [KR|KRs] [R|Rs] :- - mkBranch KS KD {coq.count-prods KTy} KTyR ITyTy Goal KR R, - mkBranches KsS KsD KTys KTyRs ITyTy Goal KRs Rs. +pred for-K-get-injKs i:int, i:list constructor, i:list term, o: list int, o:list (list term). +for-K-get-injKs TyParamNo KNs KTys ArgsNos InjKss :- + F = (grk\ i\ p\ injectionsK-db (global (indc grk)) i p), + for-K-get-KI TyParamNo KNs KTys F ArgsNos InjKss. -% todo: perhaps unify with implement-Rm -% todo add KRs to other cases -pred implement-mRRmK i:int, i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:list term, o:term. +pred implement-mRRmK i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:list term, i:list (list term), o:term. % Pred comes with Type parameters applied % RInd comes with Type parameters applied -% implement-mRRmK 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KTyRs Pred RInd -% (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- -% coq.safe-dest-app ITy1 Ind _, -% Ind = (global (indt GR)), -% coq.env.recursive? GR, !, -% RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), -% coq.mk-app RInd [Pred] RIndP, -% @pi-decl `f` RT f\ -% @pi-decl IN1 ITy1 i1\ -% @pi-decl IN2 ITy2 i2\ -% @pi-decl ARN (ARTy i1 i2) ar\ -% (rm-db Ind f => -% mkBranches KsS KsD KTys KTyRs ITy2 Pred (Brs f)), -% std.append (Brs f) [i1,i2,ar] (IndArgs f i1 i2 ar), -% coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). -implement-mRRmK 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ir\ (EQ i1 i2 ir)) KsS KsD KTys KTyRs Pred RInd KRs +% mRRmK +implement-mRRmK 0 (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KTyRs Pred RInd KRs InjKss + (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (Re f i1 i2 ar)) :- + coq.safe-dest-app ITy1 Ind _, + Ind = (global (indt GR)), + coq.env.recursive? GR, !, + RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), + coq.mk-app RInd [Pred] RIndP, + @pi-decl `f` RT f\ + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + @pi-decl ARN (ARTy i1 i2) ar\ + (mRRmK-db Ind f => + mkBranches KsS KsD KTys KTyRs ITy2 Pred KRs InjKss (Brs f)), + std.append (Brs f) [i1,i2,ar] (IndArgs f i1 i2 ar), + coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar), + coq.elaborate-skeleton (R f i1 i2 ar) _ (Re f i1 i2 ar) ok. +implement-mRRmK 0 (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) _) KsS KsD KTys KTyRs Pred RInd KRs InjKss (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- coq.mk-app RInd [Pred] RIndP, @pi-decl IN1 ITy1 i1\ @pi-decl IN2 ITy2 i2\ @pi-decl ARN (ARTy i1 i2) ar\ - mkBranches KsS KsD KTys KTyRs ITy2 Pred KRs Brs, + mkBranches KsS KsD KTys KTyRs ITy2 Pred KRs InjKss Brs, std.append Brs [i1,i2,ar] (IndArgs i1 i2 ar), coq.mk-app RIndP (IndArgs i1 i2 ar) (R i1 i2 ar). -% implement-mRRmK N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KTys KTyRs Pred RInd -% (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- -% M is N - 1, -% @pi-decl AN1 ATy1 a1\ %A1 : Type -% @pi-decl AN2 ATy2 a2\ %A2 : Type -% @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param2b0.Rel A1 A2 -% coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), +implement-mRRmK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KTys KTyRs Pred RInd KRs InjKss + (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, + @pi-decl AN1 ATy1 a1\ %A1 : Type + @pi-decl AN2 ATy2 a2\ %A2 : Type + @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param40.Rel A1 A2 + coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), -% (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, -% coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, + (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, + coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, -% coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), -% coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, + coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), + coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, + + std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), + std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), + std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), + std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), + std.map KRs (x\ r\ sigma TMP\ coq.mk-app x [a1,a2,(RelAR a1 a2 ar)] TMP, r = TMP) (NewKRs a1 a2 ar), -% std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), -% std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), -% std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), -% std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), -% Rm = {{ @Trocq.Hierarchy.R_in_map }}, -% coq.mk-app Rm [a1, a2, ar] (RMS a1 a2 ar), -% % coq.elaborate-skeleton (RMS a1 a2 ar) _ (RM a1 a2 ar) ok, -% ar-db a1 a2 ar ==> -% rm-db a1 (RMS a1 a2 ar) ==> -% implement-mRRmK M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). + MRRMK = {{ @Trocq.Hierarchy.R_in_mapK }}, + coq.mk-app MRRMK [a1, a2, ar] (MRRMKS a1 a2 ar), + coq.typecheck (MRRMKS a1 a2 ar) _ ok, + ar-db a1 a2 ar ==> + mRRmK-db a2 (MRRMKS a1 a2 ar) ==> + implement-mRRmK M (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (NewKRs a1 a2 ar) InjKss (R a1 a2 ar). -pred main i:inductive, i:string, o:list prop. +func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ KNs KTys, @@ -139,7 +318,6 @@ main GR Prefix Clauses :- std.do! [ mymap-def Ind IndMap, mk-mR-type-mRRmK TyParamNo TRTy IndMap {{ Type }} TR mR-db rm-db MRTy, coq.elaborate-skeleton MRTy _ MRTyE ok, - % coq.say "MRTyE" MRTyE, TR = global (indt GRR), coq.gref->id (indt GRR) Rname, RInductionName is Rname ^ "_ind", @@ -148,18 +326,16 @@ main GR Prefix Clauses :- std.do! [ coq.env.indt GRR _ _ _ _ KNRs KTyRs, std.map KNs (x\ r\ r = (global (indc x))) Ks, std.map KNRs (x\ r\ r = (global (indc x))) KRs, - implement-mRRmK TyParamNo TyParamNo MRTyE Ks Ks KTys KTyRs Pred (global RInd) KRs R, - coq.say "Implemented mRRmK " R, - coq.elaborate-skeleton R MRTyE Re E, - coq.say "Erroring mRRmK E" E, + for-K-get-injKs TyParamNo KNs KTys _ InjKss, + implement-mRRmK TyParamNo MRTyE Ks Ks KTys KTyRs Pred (global RInd) KRs InjKss R, + coq.elaborate-skeleton R MRTyE Re ok, Name is Prefix ^ "mRRmK", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName Re MRTyE _ C, I = global (indt GR), - Clauses = [], -% Clauses = [rm-done I, rm-db I (global (const C))], + Clauses = [mRRmK-done GR, (mRRmK-db I (global (const C))) ], std.forall Clauses (x\ - coq.elpi.accumulate _ "derive.Rm.db" (clause _ _ x) + coq.elpi.accumulate _ "derive.mRRmK.db" (clause _ _ x) ), ]. diff --git a/std/algo/elpi/mymap.elpi b/std/algo/elpi/mymap.elpi index 036ec953..9ea7a225 100644 --- a/std/algo/elpi/mymap.elpi +++ b/std/algo/elpi/mymap.elpi @@ -183,7 +183,7 @@ mk-clause N Lno Ity1 Ity2 X Todo Map C :- whd1 X X1, !, mk-clause N Lno Ity1 Ity2 X1 Todo Map C. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -pred main i:inductive, i:string, o:list prop. +func main inductive, string -> list prop. main GR Prefix C :- do! [ T = global (indt GR), coq.env.indt GR _Ind Lno Luno Arity _ _, @@ -204,21 +204,4 @@ main GR Prefix C :- do! [ C = [mymap-done GR,Clause, (mymap-def (global (indt GR)) (global (const Funct)))] ]. -} -/* -namespace derive.mymap { - - pred main i:inductive, i:string, o:list prop. - main GR Prefix Clauses :- std.do! [ - %... % synthesize Body and Type - Name is Prefix ^ "myconcept", - coq.ensure-fresh-global-id Name FName, - coq.env.add-const FName Body Type _ C, - Clauses = [mymap-done GR, mymap-db GR (const C)], - std.forall Clauses (x\ - coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ x) - ), - ]. - -} -*/ \ No newline at end of file +} \ No newline at end of file diff --git a/std/algo/elpi/utils.elpi b/std/algo/elpi/utils.elpi index 4f4547fd..6265b7dd 100644 --- a/std/algo/elpi/utils.elpi +++ b/std/algo/elpi/utils.elpi @@ -97,5 +97,31 @@ name-ijs FName I GR [Kn | KNs] [InjTys | InjTyss] F [Clauses | Clausess] :- In is I + 1, name-ij FName I 1 GR Kn InjTys F Clauses, name-ijs FName In GR KNs InjTyss F Clausess. + +% Returns the list of P of F K I P of a constructor. +pred get-KI i:constructor, i:int, i:int, i:(pred i:constructor, i:int, o:term), o:list term. +get-KI _ Max Max _ [] :- !. +get-KI GRK J Max F [P|PJs] :- + I is J + 1, + F GRK I P, + get-KI GRK I Max F PJs. + +% for a list of P of F K I for a list of constructors +pred for-K-get-KI i:int, i:list constructor, i:list term, +i:(pred i:constructor, i:int, o:term), +o: list int, o:list (list term). +for-K-get-KI _ [] [] _ [] []:- !. +for-K-get-KI TyParamNo [Kn|KNs] [KTy|KTys] F [ArgsNo|ArgsNos] [R|RS]:- + count-args TyParamNo KTy ArgsNo, + get-KI Kn 0 ArgsNo F R, + for-K-get-KI TyParamNo KNs KTys F ArgsNos RS. + +% from a type of shape 3*(forall (a1 : T1) (a2 : T2), AR a1 a2, ...) extracts list of T1 and T2 +pred type-of-args i:term, i:int, o:list term, o:list term. +type-of-args _ 0 [] []. +type-of-args (prod _ ATy1 a1\ prod _ ATy2 a2\ prod _ _ ar\ (Bo a1 a2 ar)) N [ATy1| SR] [ATy2 | DR] :- + M is N - 1, + pi a1 a2 ar\ + type-of-args (Bo a1 a2 ar) M SR DR. } \ No newline at end of file diff --git a/std/algo/tests/coverage.v b/std/algo/tests/coverage.v index 9d069448..4c28298c 100644 --- a/std/algo/tests/coverage.v +++ b/std/algo/tests/coverage.v @@ -29,6 +29,9 @@ Inductive Option (A : Type) : Type := Inductive Prod (A B : Type) : Type := | PR : A -> B -> Prod A B. +Inductive Mix (A : Type) : Type := +| Con : A -> Unit -> Mix A. + Inductive ThreeTypes (A B C : Type) := | C1 : A -> ThreeTypes A B C | C2 : B -> ThreeTypes A B C diff --git a/std/algo/tests/test_algo.v b/std/algo/tests/test_algo.v new file mode 100644 index 00000000..b9b2d08b --- /dev/null +++ b/std/algo/tests/test_algo.v @@ -0,0 +1,42 @@ +From Trocq Require Import algo. +From Trocq Require Import coverage. +Unset Uniform Inductive Parameters. + +Elpi derive False. +Check False_mRRmK : forall f1 f2 fR, False_mR f1 f2 (False_Rm f1 f2 fR) = fR. + +Elpi derive Unit. +Check Unit_mRRmK : forall u1 u2 uR, Unit_mR u1 u2 (Unit_Rm u1 u2 uR) = uR. + +Elpi derive Bool. +Check Bool_mRRmK : forall b1 b2 bR, Bool_mR b1 b2 (Bool_Rm b1 b2 bR) = bR. + +Elpi derive Wrap. +Check Wrap_mRRmK : forall w1 w2 wR, Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. + +Elpi derive WrapMore. +Check WrapMore_mRRmK : forall w1 w2 wR, WrapMore_mR w1 w2 (WrapMore_Rm w1 w2 wR) = wR. + +Elpi derive Nat. +Check Nat_mRRmK : forall n1 n2 nR, Nat_mR n1 n2 (Nat_Rm n1 n2 nR) = nR. + +Elpi derive Box. +Check Box_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall (b1 : Box A1) (b2 : Box A2) (bR : Box_R A1 A2 AR b1 b2), + Box_mR A1 A2 AR b1 b2 (Box_Rm A1 A2 AR b1 b2 bR) = bR. + +Elpi derive Option. +Check Option_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall o1 o2 oR, Option_mR A1 A2 AR o1 o2 (Option_Rm A1 A2 AR o1 o2 oR) = oR. + +Elpi derive Prod. +Check Prod_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2) B1 B2 (BR : Param40.Rel B1 B2), + forall p1 p2 pR, Prod_mR A1 A2 AR B1 B2 BR p1 p2 (Prod_Rm A1 A2 AR B1 B2 BR p1 p2 pR) = pR. + +Elpi derive ThreeTypes. +Check ThreeTypes_mRRmK : +forall A1 A2 (AR : Param40.Rel A1 A2), +forall B1 B2 (BR : Param40.Rel B1 B2), +forall C1 C2 (CR : Param40.Rel C1 C2), + forall t1 t2 tR, ThreeTypes_mR A1 A2 AR B1 B2 BR C1 C2 CR t1 t2 (ThreeTypes_Rm A1 A2 AR B1 B2 BR C1 C2 CR t1 t2 tR) = tR. + +Elpi derive List. +Check List_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall l1 t2 lR, List_mR A1 A2 AR l1 t2 (List_Rm A1 A2 AR l1 t2 lR) = lR. \ No newline at end of file diff --git a/std/algo/tests/test_injK.v b/std/algo/tests/test_injK.v index cae2cc38..263cabba 100644 --- a/std/algo/tests/test_injK.v +++ b/std/algo/tests/test_injK.v @@ -5,44 +5,44 @@ Unset Uniform Inductive Parameters. Elpi derive.projK False. Elpi derive.injections False. -Elpi derive.injectionsK False. +Elpi derive.injK False. Elpi derive.projK Unit. Elpi derive.injections Unit. -Elpi derive.injectionsK Unit. +Elpi derive.injK Unit. Elpi derive.projK Bool. Elpi derive.injections Bool. -Elpi derive.injectionsK Bool. +Elpi derive.injK Bool. Elpi derive.projK Wrap. Elpi derive.injections Wrap. -Elpi derive.injectionsK Wrap. +Elpi derive.injK Wrap. Elpi derive.projK WrapMore. Elpi derive.injections WrapMore. -Elpi derive.injectionsK WrapMore. +Elpi derive.injK WrapMore. Elpi derive.projK Nat. Elpi derive.injections Nat. -Elpi derive.injectionsK Nat. +Elpi derive.injK Nat. Elpi derive.projK Box. Elpi derive.injections Box. -Elpi derive.injectionsK Box. +Elpi derive.injK Box. Elpi derive.projK Option. Elpi derive.injections Option. -Elpi derive.injectionsK Option. +Elpi derive.injK Option. Elpi derive.projK Prod. Elpi derive.injections Prod. -Elpi derive.injectionsK Prod. +Elpi derive.injK Prod. Elpi derive.projK ThreeTypes. Elpi derive.injections ThreeTypes. -Elpi derive.injectionsK ThreeTypes. +Elpi derive.injK ThreeTypes. Elpi derive.projK List. Elpi derive.injections List. -Elpi derive.injectionsK List. \ No newline at end of file +Elpi derive.injK List. \ No newline at end of file diff --git a/std/algo/tests/test_mRRmK.v b/std/algo/tests/test_mRRmK.v index 5626d3d3..27fa47d4 100644 --- a/std/algo/tests/test_mRRmK.v +++ b/std/algo/tests/test_mRRmK.v @@ -3,7 +3,6 @@ From Trocq Require Import coverage. From Trocq Require Import Hierarchy. Unset Uniform Inductive Parameters. - Elpi derive.param2 False. Elpi derive.mymap False. Elpi derive.projK False. @@ -11,6 +10,7 @@ Elpi derive.injections False. Elpi derive.isK False. Elpi derive.mR False. Elpi derive.Rm False. +Elpi derive.injK False. Elpi derive.mRRmK False. Elpi derive.param2 Unit. @@ -20,6 +20,7 @@ Elpi derive.injections Unit. Elpi derive.isK Unit. Elpi derive.mR Unit. Elpi derive.Rm Unit. +Elpi derive.injK Unit. Elpi derive.mRRmK Unit. Elpi derive.param2 Bool. @@ -29,6 +30,7 @@ Elpi derive.injections Bool. Elpi derive.isK Bool. Elpi derive.mR Bool. Elpi derive.Rm Bool. +Elpi derive.injK Bool. Elpi derive.mRRmK Bool. Elpi derive.param2 Wrap. @@ -38,7 +40,8 @@ Elpi derive.injections Wrap. Elpi derive.isK Wrap. Elpi derive.mR Wrap. Elpi derive.Rm Wrap. -Fail Elpi derive.mRRmK Wrap. +Elpi derive.injK Wrap. +Elpi derive.mRRmK Wrap. Elpi derive.param2 WrapMore. Elpi derive.mymap WrapMore. @@ -47,7 +50,8 @@ Elpi derive.injections WrapMore. Elpi derive.isK WrapMore. Elpi derive.mR WrapMore. Elpi derive.Rm WrapMore. -Fail Elpi derive.mRRmK WrapMore. +Elpi derive.injK WrapMore. +Elpi derive.mRRmK WrapMore. Elpi derive.param2 Nat. Elpi derive.mymap Nat. @@ -56,7 +60,8 @@ Elpi derive.injections Nat. Elpi derive.isK Nat. Elpi derive.mR Nat. Elpi derive.Rm Nat. -Fail Elpi derive.mRRmK Nat. +Elpi derive.injK Nat. +Elpi derive.mRRmK Nat. Elpi derive.param2 Box. Elpi derive.mymap Box. @@ -65,7 +70,8 @@ Elpi derive.injections Box. Elpi derive.isK Box. Elpi derive.mR Box. Elpi derive.Rm Box. -Fail Elpi derive.mRRmK Box. +Elpi derive.injK Box. +Elpi derive.mRRmK Box. Elpi derive.param2 Option. Elpi derive.mymap Option. @@ -74,7 +80,8 @@ Elpi derive.injections Option. Elpi derive.isK Option. Elpi derive.mR Option. Elpi derive.Rm Option. -Fail Elpi derive.mRRmK Option. +Elpi derive.injK Option. +Elpi derive.mRRmK Option. Elpi derive.param2 Prod. Elpi derive.mymap Prod. @@ -83,7 +90,8 @@ Elpi derive.injections Prod. Elpi derive.isK Prod. Elpi derive.mR Prod. Elpi derive.Rm Prod. -Fail Elpi derive.mRRmK Prod. +Elpi derive.injK Prod. +Elpi derive.mRRmK Prod. Elpi derive.param2 ThreeTypes. Elpi derive.mymap ThreeTypes. @@ -92,7 +100,8 @@ Elpi derive.injections ThreeTypes. Elpi derive.isK ThreeTypes. Elpi derive.mR ThreeTypes. Elpi derive.Rm ThreeTypes. -Fail Elpi derive.mRRmK ThreeTypes. +Elpi derive.injK ThreeTypes. +Elpi derive.mRRmK ThreeTypes. Elpi derive.param2 List. Elpi derive.mymap List. @@ -101,4 +110,5 @@ Elpi derive.injections List. Elpi derive.isK List. Elpi derive.mR List. Elpi derive.Rm List. -Fail Elpi derive.mRRmK List. \ No newline at end of file +Elpi derive.injK List. +Elpi derive.mRRmK List. \ No newline at end of file diff --git a/std/algo/theories/Rm.v b/std/algo/theories/Rm.v index bc60b302..386e055e 100644 --- a/std/algo/theories/Rm.v +++ b/std/algo/theories/Rm.v @@ -4,14 +4,14 @@ From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. From elpi Require Import elpi. -From elpi.apps Require Import derive.param2. -From elpi.apps Require Import derive.bcongr. (* for eq_f register *) -From Trocq Require Import mymap. -From elpi.apps Require Import derive.induction. -(* From Trocq Require Import HoTT_additions Hierarchy. *) -From Trocq Require Import Hierarchy. -Unset Uniform Inductive Parameters. +From Trocq Require Export Hierarchy. +From elpi.apps Require Export derive.param2. +From elpi.apps Require Export derive.bcongr. (* for eq_f register *) +(* From Trocq Require Export mymap. *) +(* todo: the real dependency is mymap *) +From Trocq Require Import mR. +Unset Uniform Inductive Parameters. Elpi Db derive.Rm.db lp:{{ % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. pred ar-db i:term, i:term, o:term. @@ -20,7 +20,7 @@ Elpi Db derive.Rm.db lp:{{ pred rm-db i:term, o:term. % [Rm-done T] mean T was already derived - pred rm-done o:term. + pred rm-done o:inductive. }}. Elpi Command derive.Rm. @@ -43,3 +43,17 @@ Elpi Accumulate lp:{{ pred usage. usage :- coq.error "Usage: derive.Rm ". }}. + +(* hook into derive *) +(* Elpi Accumulate derive Db Header derive.Rm.db. +Elpi Accumulate derive Db derive.Rm.db. +Elpi Accumulate derive File common. +Elpi Accumulate derive File algo_utils. +Elpi Accumulate derive File Rm. + +Elpi Accumulate derive lp:{{ +dep1 "Rm" "mymap". +dep1 "Rm" "param2". +derivation (indt T) Prefix ff (derive "Rm" (derive.Rm.main T Prefix) (rm-done T)). + +}}. *) diff --git a/std/algo/theories/algo.v b/std/algo/theories/algo.v new file mode 100644 index 00000000..525eaf60 --- /dev/null +++ b/std/algo/theories/algo.v @@ -0,0 +1,104 @@ +(* Hook for mymap *) +(* From elpi.apps Require Export derive.legacy. *) +From Trocq Require Export mymap. +From Trocq Extra Dependency "algo/elpi/mymap.elpi" as mymap. + +Elpi Accumulate derive Db derive.mymap.db. +Elpi Accumulate derive File mymap. + +Elpi Accumulate derive lp:{{ + +derivation (indt T) Prefix ff (derive "mymap" (derive.mymap.main T Prefix) (mymap-done T)). + +}}. + +(* Hook for injections *) +From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. +From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. +From Trocq Extra Dependency "algo/elpi/injection_lemmas.elpi" as injections. +From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. + +From Trocq Require Export injection_lemmas. +Elpi Accumulate derive Db derive.injections.db. +Elpi Accumulate derive File injection. +Elpi Accumulate derive File algo_utils. +Elpi Accumulate derive File injections. + +Elpi Accumulate derive lp:{{ + +dep1 "injections" "projK". +derivation (indt T) Prefix ff (derive "injections" (derive.injections.main T Prefix) (injections-done T)). + +}}. + +(* Hook for mR *) +From Trocq Require Export mR. +From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. +From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. +From Trocq Extra Dependency "algo/elpi/mR.elpi" as mR. + + +Elpi Accumulate derive Db derive.mR.db. +Elpi Accumulate derive File discr. +Elpi Accumulate derive File common. +Elpi Accumulate derive File injections. +Elpi Accumulate derive File mR. + +Elpi Accumulate derive lp:{{ + + dep1 "mR" "param2". + dep1 "mR" "mymap". + dep1 "mR" "injections". + dep1 "mR" "isK". + derivation (indt T) Prefix ff (derive "mR" (derive.mR.main T Prefix) (mR-done T)). + +}}. + +(* Hook for Rm *) +From Trocq Require Export Rm. +From Trocq Extra Dependency "algo/elpi/Rm.elpi" as Rm. +Elpi Accumulate derive Db Header derive.Rm.db. +Elpi Accumulate derive Db derive.Rm.db. +Elpi Accumulate derive File Rm. + +Elpi Accumulate derive lp:{{ +dep1 "Rm" "mymap". +dep1 "Rm" "param2". +derivation (indt T) Prefix ff (derive "Rm" (derive.Rm.main T Prefix) (rm-done T)). + +}}. + +(* injK hook into derive *) +From Trocq Require Export injK. +From Trocq Extra Dependency "algo/elpi/injK.elpi" as injK. + +Elpi Accumulate derive Db derive.injectionsK.db. +Elpi Accumulate derive File algo_utils. +Elpi Accumulate derive File injK. + +Elpi Accumulate derive lp:{{ + +dep1 "injK" "injections". +derivation (indt T) Prefix ff (derive "injK" (derive.injK.main T Prefix) (injectionsK-done T)). + +}}. + +(* mRRmK hook into derive *) +From Trocq Extra Dependency "algo/elpi/mRRmK.elpi" as mRRmK. +From Trocq Require Export mRRmK. +Elpi Accumulate derive Db derive.mRRmK.db. +Elpi Accumulate derive File common. +Elpi Accumulate derive File algo_utils. +Elpi Accumulate derive File mRRmK. + +Elpi Accumulate derive lp:{{ + +dep1 "mRRmK" "param2". +dep1 "mRRmK" "mymap". +dep1 "mRRmK" "injK". +dep1 "mRRmK" "mR". +dep1 "mRRmK" "Rm". +derivation (indt T) Prefix ff (derive "mRRmK" (derive.mRRmK.main T Prefix) (mRRmK-done T)). + +}}. + diff --git a/std/algo/theories/injK.v b/std/algo/theories/injK.v index 3576b6c5..18649680 100644 --- a/std/algo/theories/injK.v +++ b/std/algo/theories/injK.v @@ -2,11 +2,11 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From Trocq Extra Dependency "algo/elpi/injK.elpi" as injK. From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. -From Trocq Require Import injection_lemmas. +From Trocq Require Export injection_lemmas. From elpi Require Import elpi. -From elpi.apps Require Import derive.bcongr. (* for eq_f register *) -(* From elpi.apps Require Import projK. *) +From elpi.apps Require Export derive.bcongr. (* for eq_f register *) +(* From Trocq Require Export Rm. *) From Trocq Require Import Hierarchy. (* From Trocq Require Import HoTT_additions Hierarchy. *) @@ -29,10 +29,10 @@ Elpi Db derive.injectionsK.db lp:{{ pred injectionsK-db i:term, i:int, o:term. % [injectionsK-done T K] means T K was already derived - pred injectionsK-done o:term. + pred injectionsK-done o:inductive. }}. -Elpi Command derive.injectionsK. +Elpi Command derive.injK. Elpi Accumulate File derive_hook. Elpi Accumulate File algo_utils. Elpi Accumulate Db derive.injectionsK.db. @@ -48,3 +48,16 @@ Elpi Accumulate lp:{{ pred usage. usage :- coq.error "Usage: derive.Rm ". }}. + +(* hook into derive *) +(* Elpi Accumulate derive Db derive.injectionsK.db. +Elpi Accumulate derive File algo_utils. +Elpi Accumulate derive File injK. + +Elpi Accumulate derive lp:{{ + +dep1 "injK" "injections". +derivation (indt T) Prefix ff (derive "injK" (derive.injK.main T Prefix) (injectionsK-done T)). + +}}. *) + diff --git a/std/algo/theories/injection_lemmas.v b/std/algo/theories/injection_lemmas.v index bea16f01..ea8a0e81 100644 --- a/std/algo/theories/injection_lemmas.v +++ b/std/algo/theories/injection_lemmas.v @@ -4,9 +4,10 @@ From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive From Trocq Extra Dependency "algo/elpi/injection_lemmas.elpi" as injections. From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. -From elpi Require Import elpi. -From elpi.apps Require Import derive.bcongr. (* for eq_f register *) -From elpi.apps Require Import projK. +From elpi.apps Require Import derive.legacy. +From elpi.apps Require Export derive.bcongr. (* for eq_f register *) +From elpi.apps Require Export derive.projK. + Unset Uniform Inductive Parameters. Elpi Db derive.injections.db lp:{{ @@ -18,7 +19,7 @@ Elpi Db derive.injections.db lp:{{ pred injections-db i:term, i:int, o:term. % [injections-done T K] means T K was already derived - pred injections-done o:term. + pred injections-done o:inductive. }}. Elpi Command derive.injections. @@ -43,3 +44,16 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.injections ". }}. +(* hook into derive *) +(* Elpi Accumulate derive Db derive.injections.db. +Elpi Accumulate derive File injection. +Elpi Accumulate derive File algo_utils. +Elpi Accumulate derive File injections. + +Elpi Accumulate derive lp:{{ + +dep1 "injections" "projK". +derivation (indt T) Prefix ff (derive "injections" (derive.injections.main T Prefix) (injections-done T)). + +}}. *) + diff --git a/std/algo/theories/mR.v b/std/algo/theories/mR.v index e13a854e..ad144d3e 100644 --- a/std/algo/theories/mR.v +++ b/std/algo/theories/mR.v @@ -2,16 +2,16 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. From Trocq Extra Dependency "algo/elpi/mR.elpi" as mR. -From Trocq Require Import mymap injection_lemmas. +From Trocq Extra Dependency "algo/elpi/injection_lemmas.elpi" as injections. From elpi Require Import elpi. -From elpi.apps Require Import derive.param2 derive.isK. -From elpi.apps Require Import derive.bcongr (* for eq_f register *) +From elpi.apps Require Export derive.param2 derive.isK. +From elpi.apps Require Export derive.bcongr (* for eq_f register *) derive.eqK (*for bool_discr *) derive.isK. (* for isK db required by discriminate *) -(* From elpi.apps Require Import map. *) +From Trocq Require Export mymap injection_lemmas. -From Trocq Require Import Hierarchy. +From Trocq Require Export Hierarchy. Unset Uniform Inductive Parameters. Elpi Db derive.mR.db lp:{{ @@ -21,7 +21,7 @@ Elpi Db derive.mR.db lp:{{ pred mR-db i:term, o:term. % [mR-done T] mean T was already derived - pred mR-done o:term. + pred mR-done o:inductive. }}. Elpi Command derive.mR. @@ -46,3 +46,30 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.mR ". }}. +(* hook into derive *) +(* Elpi Accumulate derive Db derive.mR.db. +Elpi Accumulate derive File discr. +Elpi Accumulate derive File common. +Elpi Accumulate derive File injections. +Elpi Accumulate derive File mR. + +#[phases="both"] Elpi Accumulate derive lp:{{ + dep1 "mR" "param2". + dep1 "mR" "mymap". + dep1 "mR" "injections". + dep1 "mR" "isK". +}}. + +#[synterp] Elpi Accumulate derive lp:{{ + derivation _ _ (derive "mR" (cl\ cl = []) true). +}}. + +Elpi Accumulate derive lp:{{ + +derivation (indt T) Prefix ff (derive "mR" (derive.mR.main T Prefix) (mR-done T)). + +}}. *) + + + + diff --git a/std/algo/theories/mRRmK.v b/std/algo/theories/mRRmK.v index 502fb55f..2a7e2937 100644 --- a/std/algo/theories/mRRmK.v +++ b/std/algo/theories/mRRmK.v @@ -1,13 +1,13 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From Trocq Extra Dependency "algo/elpi/mRRmK.elpi" as mRRmK. -From Trocq Require Import injK mR Rm. From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. -(* From Trocq.Algo Extra Dependency "utils.elpi" as algo_utils. *) +From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. +From Trocq Require Export mymap injK mR Rm. From elpi Require Import elpi. -From elpi.apps Require Import derive.param2. +From elpi.apps Require Export derive.param2. (* From elpi.apps Require Import derive.bcongr. for eq_f register *) -(* From Trocq.Algo Require Import mymap. *) +(* From Trocq Require Import mymap. *) (* From elpi.apps Require Import derive.induction. *) From Trocq Require Import Hierarchy. (* From Trocq Require Import HoTT_additions Hierarchy. *) @@ -17,11 +17,11 @@ Elpi Db derive.mRRmK.db lp:{{ % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. pred ar-db i:term, i:term, o:term. - % [mRRm-db T D] links a type T to its corresponding R in map. - pred rm-db i:term, o:term. + % [mRRmK-db T D] links a type T to its corresponding R in map. + pred mRRmK-db i:term, o:term. - % [mRRm-done T] mean T was already derived - pred rm-done o:term. + % [mRRmK-done T] mean T was already derived + pred mRRmK-done o:inductive. }}. Elpi Command derive.mRRmK. @@ -30,7 +30,7 @@ Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.mymap.db. Elpi Accumulate File common. -(* Elpi Accumulate File algo_utils. *) +Elpi Accumulate File algo_utils. Elpi Accumulate Db Header derive.injectionsK.db. Elpi Accumulate Db derive.injectionsK.db. Elpi Accumulate Db Header derive.mR.db. @@ -38,6 +38,7 @@ Elpi Accumulate Db derive.mR.db. Elpi Accumulate Db Header derive.Rm.db. Elpi Accumulate Db derive.Rm.db. +Elpi Accumulate Db Header derive.mRRmK.db. Elpi Accumulate Db derive.mRRmK.db. Elpi Accumulate File mRRmK. Elpi Accumulate lp:{{ @@ -50,3 +51,22 @@ Elpi Accumulate lp:{{ pred usage. usage :- coq.error "Usage: derive.mRRmK ". }}. + + + +(* hook into derive +Elpi Accumulate derive Db derive.mRRmK.db. +Elpi Accumulate derive File common. +Elpi Accumulate derive File algo_utils. +Elpi Accumulate derive File mRRmK. + +Elpi Accumulate derive lp:{{ + +dep1 "mRRmK" "param2". +dep1 "mRRmK" "mymap". +dep1 "mRRmK" "injK". +dep1 "mRRmK" "mR". +dep1 "mRRmK" "Rm". +derivation (indt T) Prefix ff (derive "mRRmK" (derive.mRRmK.main T Prefix) (mRRmK-done T)). + +}}. *) diff --git a/std/algo/theories/mymap.v b/std/algo/theories/mymap.v index 8e240bde..a0ca227a 100644 --- a/std/algo/theories/mymap.v +++ b/std/algo/theories/mymap.v @@ -2,8 +2,8 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From Trocq Extra Dependency "algo/elpi/mymap.elpi" as mymap. From elpi Require Import elpi. -From elpi.apps Require Import derive. -From Trocq Require Import Hierarchy. +From elpi.apps Require Import derive.legacy. +From Trocq Require Export Hierarchy. Unset Uniform Inductive Parameters. Elpi Db derive.mymap.db lp:{{ @@ -42,14 +42,14 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.mymap ". }}. +(* hook into derive *) +(* Elpi Accumulate derive Db derive.mymap.db. +Elpi Accumulate derive File mymap. + +Elpi Accumulate derive lp:{{ + +derivation (indt T) Prefix ff (derive "mymap" (derive.mymap.main T Prefix) (mymap-done T)). + +}}. *) -Elpi Query lp:{{ - coq.locate "option" (indt Option), - std.findall (mymap-def (global (indt Option)) _) Rules. % empty - %std.findall (mymap-db {{ option nat }} {{ option nat }} _) Rules. % non empty - %std.findall (mymap-db {{ nat }} {{ nat }} _) Rules. % non empty - std.findall (mymap-db {{ nat }} B C) Rules. % empty - std.findall (mymap-db A B C) Rules. % empty - std.findall (mymap-done _) Rules. % empty -}}. From 5044d3c53292ac7645222405eb48590e01481189 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 17 Sep 2025 16:49:47 +0200 Subject: [PATCH 11/42] rollback on derivation dep declaration structure --- std/algo/elpi/common_algo.elpi | 29 ++++---- std/algo/elpi/mR.elpi | 4 +- std/algo/elpi/utils.elpi | 7 ++ std/algo/tests/test_algo.v | 42 ----------- std/algo/theories/Rm.v | 4 +- std/algo/theories/algo.v | 104 --------------------------- std/algo/theories/injK.v | 4 +- std/algo/theories/injection_lemmas.v | 4 +- std/algo/theories/mR.v | 8 +-- std/algo/theories/mRRmK.v | 4 +- std/algo/theories/mymap.v | 4 +- 11 files changed, 36 insertions(+), 178 deletions(-) delete mode 100644 std/algo/tests/test_algo.v delete mode 100644 std/algo/theories/algo.v diff --git a/std/algo/elpi/common_algo.elpi b/std/algo/elpi/common_algo.elpi index a67dfadd..99c61b5f 100644 --- a/std/algo/elpi/common_algo.elpi +++ b/std/algo/elpi/common_algo.elpi @@ -2,9 +2,11 @@ namespace derive.common-algo { pred rel-mode i:int o:term. -rel-mode 0 {{ Param2a0.Rel }}. -rel-mode 1 {{ Param2b0.Rel }}. -rel-mode 2 {{ Param40.Rel }}. +rel-mode 0 {{ Param10.Rel }}. +rel-mode 1 {{ Param2a0.Rel }}. +rel-mode 2 {{ Param2b0.Rel }}. +rel-mode 3 {{ Param30.Rel }}. +rel-mode 4 {{ Param40.Rel }}. pred swap i:term, i:term, i:bool, o:term, o:term. swap A B tt B A. @@ -17,13 +19,13 @@ mk-impl-return ML MR Rel SwapB ITyTy2 R :- swap Map Rel SwapB First Second, R = prod `_` First _\ Second. -% 0 is mR -% 1 is Rm -% 2 is mRRmK +% 1 is mR +% 2 is Rm +% 4 is mRRmK pred mk-return i:term, i:term, i:term, i:int, i:term, o:term. -mk-return ML MR Rel 0 ITyTy2 R :- - mk-impl-return ML MR Rel ff ITyTy2 R. mk-return ML MR Rel 1 ITyTy2 R :- + mk-impl-return ML MR Rel ff ITyTy2 R. +mk-return ML MR Rel 2 ITyTy2 R :- mk-impl-return ML MR Rel tt ITyTy2 R. % mk-return ML MR Rel @@ -40,7 +42,7 @@ pred mk-mR-type-priv i:int, i:term, i:term, i:term, i:term, i:int, i:list term, % The RHS of the equality is Y. mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- - (Swap = 0 ; Swap = 1), + (Swap = 1 ; Swap = 2), @pi-decl IN1 ITyTy x\ @pi-decl IN2 ITyTy2 y\ sigma NewML NewMR NewRel L\ @@ -49,9 +51,8 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ NewMR = y, coq.mk-app Rel {std.append L [x,y]} NewRel, mk-return NewML NewMR NewRel Swap ITyTy2 (R x y). -mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel Swap LRev MR-DB RM-DB +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 4 LRev MR-DB RM-DB (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ prod `IR` (RelTy x y) iR\ (R x y iR)) :- - Swap = 2, std.rev LRev L, @pi-decl IN1 ITyTy x\ @pi-decl IN2 ITyTy2 y\ @@ -90,14 +91,14 @@ mk-mR-type-mR N T ML MR Rel RTy :- % NewMR = y, % coq.mk-app Rel {std.append L [x,y]} NewRel, % mk-return NewML NewMR NewRel Swap ITyTy2 (R x y)) => - mk-mR-type-priv N T ML MR Rel 0 [] Dummy Dummy RTy. + mk-mR-type-priv N T ML MR Rel 1 [] Dummy Dummy RTy. pred mk-mR-type-Rm i:int, i:term, i:term, i:term, i:term, o:term. mk-mR-type-Rm N T ML MR Rel R :- - mk-mR-type-priv N T ML MR Rel 1 [] Dummy Dummy R. + mk-mR-type-priv N T ML MR Rel 2 [] Dummy Dummy R. pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:term, i:(pred i:term, o:term) , i: (pred i:term, o:term), o:term. % pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:term, i:(term -> term -> prop), i: (term -> term -> prop), o:term. mk-mR-type-mRRmK N T ML MR Rel MR-DB RM-DB R :- - mk-mR-type-priv N T ML MR Rel 2 [] MR-DB RM-DB R. + mk-mR-type-priv N T ML MR Rel 4 [] MR-DB RM-DB R. } \ No newline at end of file diff --git a/std/algo/elpi/mR.elpi b/std/algo/elpi/mR.elpi index c0479ba0..ad90bf17 100644 --- a/std/algo/elpi/mR.elpi +++ b/std/algo/elpi/mR.elpi @@ -165,9 +165,9 @@ main GR Prefix Clauses :- std.do! [ coq.typecheck TR TRTy _, mymap-def Ind IndMap, mk-mR-type-mR UnifParamNo TRTy IndMap {{ Type }} TR MRTy, - coq.elaborate-skeleton MRTy _ MRTyE ok, + std.assert-ok! (coq.elaborate-skeleton MRTy _ MRTyE) "derive.mR generates illtyped type", implement-mR UnifParamNo UnifParamNo MRTyE T, - coq.elaborate-skeleton T MRTyE TE ok, + std.assert-ok! (coq.elaborate-skeleton T MRTyE TE) "derive.mR generates illtyped term", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName TE MRTyE _ C, I = global (indt GR), diff --git a/std/algo/elpi/utils.elpi b/std/algo/elpi/utils.elpi index 6265b7dd..1b3de2ff 100644 --- a/std/algo/elpi/utils.elpi +++ b/std/algo/elpi/utils.elpi @@ -4,6 +4,13 @@ func names12 name -> name, name. names12 N N1 N2 :- !, coq.name-suffix N 1 N1, coq.name-suffix N 2 N2. +pred gen-names-umap i:name, o:name, o:name, o:name, o:name. +gen-names-umap N N1 N2 NR NU :- + coq.name-suffix N 1 N1, + coq.name-suffix N 2 N2, + coq.name-suffix N "R" NR, + coq.name-suffix N "U" NU. + pred name-prefix i: name, i:string, o:name. name-prefix N P R :- coq.name->id N NS, diff --git a/std/algo/tests/test_algo.v b/std/algo/tests/test_algo.v deleted file mode 100644 index b9b2d08b..00000000 --- a/std/algo/tests/test_algo.v +++ /dev/null @@ -1,42 +0,0 @@ -From Trocq Require Import algo. -From Trocq Require Import coverage. -Unset Uniform Inductive Parameters. - -Elpi derive False. -Check False_mRRmK : forall f1 f2 fR, False_mR f1 f2 (False_Rm f1 f2 fR) = fR. - -Elpi derive Unit. -Check Unit_mRRmK : forall u1 u2 uR, Unit_mR u1 u2 (Unit_Rm u1 u2 uR) = uR. - -Elpi derive Bool. -Check Bool_mRRmK : forall b1 b2 bR, Bool_mR b1 b2 (Bool_Rm b1 b2 bR) = bR. - -Elpi derive Wrap. -Check Wrap_mRRmK : forall w1 w2 wR, Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. - -Elpi derive WrapMore. -Check WrapMore_mRRmK : forall w1 w2 wR, WrapMore_mR w1 w2 (WrapMore_Rm w1 w2 wR) = wR. - -Elpi derive Nat. -Check Nat_mRRmK : forall n1 n2 nR, Nat_mR n1 n2 (Nat_Rm n1 n2 nR) = nR. - -Elpi derive Box. -Check Box_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall (b1 : Box A1) (b2 : Box A2) (bR : Box_R A1 A2 AR b1 b2), - Box_mR A1 A2 AR b1 b2 (Box_Rm A1 A2 AR b1 b2 bR) = bR. - -Elpi derive Option. -Check Option_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall o1 o2 oR, Option_mR A1 A2 AR o1 o2 (Option_Rm A1 A2 AR o1 o2 oR) = oR. - -Elpi derive Prod. -Check Prod_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2) B1 B2 (BR : Param40.Rel B1 B2), - forall p1 p2 pR, Prod_mR A1 A2 AR B1 B2 BR p1 p2 (Prod_Rm A1 A2 AR B1 B2 BR p1 p2 pR) = pR. - -Elpi derive ThreeTypes. -Check ThreeTypes_mRRmK : -forall A1 A2 (AR : Param40.Rel A1 A2), -forall B1 B2 (BR : Param40.Rel B1 B2), -forall C1 C2 (CR : Param40.Rel C1 C2), - forall t1 t2 tR, ThreeTypes_mR A1 A2 AR B1 B2 BR C1 C2 CR t1 t2 (ThreeTypes_Rm A1 A2 AR B1 B2 BR C1 C2 CR t1 t2 tR) = tR. - -Elpi derive List. -Check List_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall l1 t2 lR, List_mR A1 A2 AR l1 t2 (List_Rm A1 A2 AR l1 t2 lR) = lR. \ No newline at end of file diff --git a/std/algo/theories/Rm.v b/std/algo/theories/Rm.v index 386e055e..b31eaaf1 100644 --- a/std/algo/theories/Rm.v +++ b/std/algo/theories/Rm.v @@ -45,7 +45,7 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -(* Elpi Accumulate derive Db Header derive.Rm.db. +Elpi Accumulate derive Db Header derive.Rm.db. Elpi Accumulate derive Db derive.Rm.db. Elpi Accumulate derive File common. Elpi Accumulate derive File algo_utils. @@ -56,4 +56,4 @@ dep1 "Rm" "mymap". dep1 "Rm" "param2". derivation (indt T) Prefix ff (derive "Rm" (derive.Rm.main T Prefix) (rm-done T)). -}}. *) +}}. diff --git a/std/algo/theories/algo.v b/std/algo/theories/algo.v deleted file mode 100644 index 525eaf60..00000000 --- a/std/algo/theories/algo.v +++ /dev/null @@ -1,104 +0,0 @@ -(* Hook for mymap *) -(* From elpi.apps Require Export derive.legacy. *) -From Trocq Require Export mymap. -From Trocq Extra Dependency "algo/elpi/mymap.elpi" as mymap. - -Elpi Accumulate derive Db derive.mymap.db. -Elpi Accumulate derive File mymap. - -Elpi Accumulate derive lp:{{ - -derivation (indt T) Prefix ff (derive "mymap" (derive.mymap.main T Prefix) (mymap-done T)). - -}}. - -(* Hook for injections *) -From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. -From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq Extra Dependency "algo/elpi/injection_lemmas.elpi" as injections. -From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. - -From Trocq Require Export injection_lemmas. -Elpi Accumulate derive Db derive.injections.db. -Elpi Accumulate derive File injection. -Elpi Accumulate derive File algo_utils. -Elpi Accumulate derive File injections. - -Elpi Accumulate derive lp:{{ - -dep1 "injections" "projK". -derivation (indt T) Prefix ff (derive "injections" (derive.injections.main T Prefix) (injections-done T)). - -}}. - -(* Hook for mR *) -From Trocq Require Export mR. -From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. -From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. -From Trocq Extra Dependency "algo/elpi/mR.elpi" as mR. - - -Elpi Accumulate derive Db derive.mR.db. -Elpi Accumulate derive File discr. -Elpi Accumulate derive File common. -Elpi Accumulate derive File injections. -Elpi Accumulate derive File mR. - -Elpi Accumulate derive lp:{{ - - dep1 "mR" "param2". - dep1 "mR" "mymap". - dep1 "mR" "injections". - dep1 "mR" "isK". - derivation (indt T) Prefix ff (derive "mR" (derive.mR.main T Prefix) (mR-done T)). - -}}. - -(* Hook for Rm *) -From Trocq Require Export Rm. -From Trocq Extra Dependency "algo/elpi/Rm.elpi" as Rm. -Elpi Accumulate derive Db Header derive.Rm.db. -Elpi Accumulate derive Db derive.Rm.db. -Elpi Accumulate derive File Rm. - -Elpi Accumulate derive lp:{{ -dep1 "Rm" "mymap". -dep1 "Rm" "param2". -derivation (indt T) Prefix ff (derive "Rm" (derive.Rm.main T Prefix) (rm-done T)). - -}}. - -(* injK hook into derive *) -From Trocq Require Export injK. -From Trocq Extra Dependency "algo/elpi/injK.elpi" as injK. - -Elpi Accumulate derive Db derive.injectionsK.db. -Elpi Accumulate derive File algo_utils. -Elpi Accumulate derive File injK. - -Elpi Accumulate derive lp:{{ - -dep1 "injK" "injections". -derivation (indt T) Prefix ff (derive "injK" (derive.injK.main T Prefix) (injectionsK-done T)). - -}}. - -(* mRRmK hook into derive *) -From Trocq Extra Dependency "algo/elpi/mRRmK.elpi" as mRRmK. -From Trocq Require Export mRRmK. -Elpi Accumulate derive Db derive.mRRmK.db. -Elpi Accumulate derive File common. -Elpi Accumulate derive File algo_utils. -Elpi Accumulate derive File mRRmK. - -Elpi Accumulate derive lp:{{ - -dep1 "mRRmK" "param2". -dep1 "mRRmK" "mymap". -dep1 "mRRmK" "injK". -dep1 "mRRmK" "mR". -dep1 "mRRmK" "Rm". -derivation (indt T) Prefix ff (derive "mRRmK" (derive.mRRmK.main T Prefix) (mRRmK-done T)). - -}}. - diff --git a/std/algo/theories/injK.v b/std/algo/theories/injK.v index 18649680..fcacd606 100644 --- a/std/algo/theories/injK.v +++ b/std/algo/theories/injK.v @@ -50,7 +50,7 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -(* Elpi Accumulate derive Db derive.injectionsK.db. +Elpi Accumulate derive Db derive.injectionsK.db. Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File injK. @@ -59,5 +59,5 @@ Elpi Accumulate derive lp:{{ dep1 "injK" "injections". derivation (indt T) Prefix ff (derive "injK" (derive.injK.main T Prefix) (injectionsK-done T)). -}}. *) +}}. diff --git a/std/algo/theories/injection_lemmas.v b/std/algo/theories/injection_lemmas.v index ea8a0e81..f207afe2 100644 --- a/std/algo/theories/injection_lemmas.v +++ b/std/algo/theories/injection_lemmas.v @@ -45,7 +45,7 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -(* Elpi Accumulate derive Db derive.injections.db. +Elpi Accumulate derive Db derive.injections.db. Elpi Accumulate derive File injection. Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File injections. @@ -55,5 +55,5 @@ Elpi Accumulate derive lp:{{ dep1 "injections" "projK". derivation (indt T) Prefix ff (derive "injections" (derive.injections.main T Prefix) (injections-done T)). -}}. *) +}}. diff --git a/std/algo/theories/mR.v b/std/algo/theories/mR.v index ad144d3e..8b46320f 100644 --- a/std/algo/theories/mR.v +++ b/std/algo/theories/mR.v @@ -47,7 +47,7 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -(* Elpi Accumulate derive Db derive.mR.db. +Elpi Accumulate derive Db derive.mR.db. Elpi Accumulate derive File discr. Elpi Accumulate derive File common. Elpi Accumulate derive File injections. @@ -60,15 +60,11 @@ Elpi Accumulate derive File mR. dep1 "mR" "isK". }}. -#[synterp] Elpi Accumulate derive lp:{{ - derivation _ _ (derive "mR" (cl\ cl = []) true). -}}. - Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "mR" (derive.mR.main T Prefix) (mR-done T)). -}}. *) +}}. diff --git a/std/algo/theories/mRRmK.v b/std/algo/theories/mRRmK.v index 2a7e2937..1bca0357 100644 --- a/std/algo/theories/mRRmK.v +++ b/std/algo/theories/mRRmK.v @@ -54,7 +54,7 @@ Elpi Accumulate lp:{{ -(* hook into derive +(* hook into derive *) Elpi Accumulate derive Db derive.mRRmK.db. Elpi Accumulate derive File common. Elpi Accumulate derive File algo_utils. @@ -69,4 +69,4 @@ dep1 "mRRmK" "mR". dep1 "mRRmK" "Rm". derivation (indt T) Prefix ff (derive "mRRmK" (derive.mRRmK.main T Prefix) (mRRmK-done T)). -}}. *) +}}. diff --git a/std/algo/theories/mymap.v b/std/algo/theories/mymap.v index a0ca227a..1ff1d0c7 100644 --- a/std/algo/theories/mymap.v +++ b/std/algo/theories/mymap.v @@ -43,13 +43,13 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -(* Elpi Accumulate derive Db derive.mymap.db. +Elpi Accumulate derive Db derive.mymap.db. Elpi Accumulate derive File mymap. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "mymap" (derive.mymap.main T Prefix) (mymap-done T)). -}}. *) +}}. From e3dfed69e8ce443f0cd984c095bf665cb5c95e99 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 17 Sep 2025 16:51:45 +0200 Subject: [PATCH 12/42] map4 + umap derivation --- std/_CoqProject | 6 ++- std/algo/elpi/umap.elpi | 97 ++++++++++++++++++++++++++++++++++++++ std/algo/tests/test_map4.v | 42 +++++++++++++++++ std/algo/tests/test_umap.v | 36 ++++++++++++++ std/algo/theories/map4.v | 8 ++++ std/algo/theories/umap.v | 54 +++++++++++++++++++++ 6 files changed, 241 insertions(+), 2 deletions(-) create mode 100644 std/algo/elpi/umap.elpi create mode 100644 std/algo/tests/test_map4.v create mode 100644 std/algo/tests/test_umap.v create mode 100644 std/algo/theories/map4.v create mode 100644 std/algo/theories/umap.v diff --git a/std/_CoqProject b/std/_CoqProject index 111053ee..12ba0d87 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -42,5 +42,7 @@ algo/theories/injK.v algo/tests/test_injK.v algo/theories/mRRmK.v algo/tests/test_mRRmK.v -algo/theories/algo.v -algo/tests/test_algo.v \ No newline at end of file +algo/theories/map4.v +algo/tests/test_map4.v +algo/theories/umap.v +algo/tests/test_umap.v \ No newline at end of file diff --git a/std/algo/elpi/umap.elpi b/std/algo/elpi/umap.elpi new file mode 100644 index 00000000..8567552a --- /dev/null +++ b/std/algo/elpi/umap.elpi @@ -0,0 +1,97 @@ + +shorten derive.common-algo. {rel-mode}. +shorten derive.algo-utils.{gen-names-umap}. +namespace derive.umap { + +% TyParamNo +% Arity +% Ind +% IndR +% TyArgs1 +% TyArgs2 +% ARArgs +pred mk-umap-type-priv i:int, i:term, i:term, i:term, i:term, o:term. +mk-umap-type-priv 0 _ IndL IndR Rel {{ @IsUMap lp:IndL lp:IndR lp:Rel}}. +mk-umap-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR Rel + (prod TN1 Ty t1\ prod TN2 Ty t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- + M is N - 1, + gen-names-umap TN TN1 TN2 TRN URN, + @pi-decl TN1 Ty t1\ + @pi-decl TN2 Ty t2\ + (ARTy t1 t2) = {{ lp:t1 -> lp:t2 -> Type }}, + @pi-decl TRN (ARTy t1 t2) ar\ + (UMTy t1 t2 ar) = {{ @IsUMap lp:t1 lp:t2 lp:ar }}, + @pi-decl URN (UMTy t1 t2 ar) ur\ + coq.mk-app IndL [t1] (NIndL t1), + coq.mk-app IndR [t2] (NIndR t2), + coq.mk-app Rel [t1,t2,ar] (NRel t1 t2 ar), + mk-umap-type-priv M (Bo t1) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) (R t1 t2 ar ur). + +% TyParamNo Arity Ind Rel +pred mk-umap-type i:int, i:term, i:term, i:term, o:term. +mk-umap-type TyParamNo Arity Ind Rel R :- + mk-umap-type-priv TyParamNo Arity Ind Ind Rel R. + +% given two types and an UMap between them, elaborates the types of the different hierarchy relations. +pred insert-coersions i:term, i:term, i:term, o:term, o:term, o:term, o:term. +insert-coersions T1 T2 UR MapR MRR RMR MRRMKR :- + coq.mk-app {rel-mode 0} [T1,T2] MapRTy, + coq.mk-app {rel-mode 1} [T1,T2] MRRTy, + coq.mk-app {rel-mode 2} [T1,T2] RMRTy, + coq.mk-app {rel-mode 4} [T1,T2] MRRMKRTy, + std.assert-ok! (coq.elaborate-skeleton UR MapRTy MapR) "derive.umap fails to insert coersions to MapR", + std.assert-ok! (coq.elaborate-skeleton UR MRRTy MRR) "derive.umap fails to insert coersions to MRR", + std.assert-ok! (coq.elaborate-skeleton UR RMRTy RMR) "derive.umap fails to insert coersions to RMR", + std.assert-ok! (coq.elaborate-skeleton UR MRRMKRTy MRRMKR) "derive.umap fails to insert coersions to MRRMKR". + +% TyParamNo UMapTy IndL IndR Rel IndMap MR RM MRRMK +pred implement-umap i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:term, o:term. +% implement-umap _ _ _ _ _ _ _ _ {{ Type }}. +implement-umap 0 _ IndL IndR Rel IndMap MR RM MRRMK R :- + R = {{ @MkUMap lp:IndL lp:IndR lp:Rel lp:IndMap lp:MR lp:RM lp:MRRMK }}. +implement-umap N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (Bo t1 t2 ar ur)) IndL IndR Rel IndMap MR RM MRRMK (fun TN1 Ty1 t1\ fun TN2 Ty2 t2\ fun TRN (ARTy t1 t2) ar\ fun URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- + M is N - 1, + @pi-decl TN1 Ty1 t1\ + @pi-decl TN2 Ty2 t2\ + @pi-decl TRN (ARTy t1 t2) ar\ + @pi-decl URN (UMTy t1 t2 ar) ur\ + coq.mk-app IndL [t1] (NIndL t1), + coq.mk-app IndR [t2] (NIndR t2), + coq.mk-app Rel [t1,t2,ar] (NRel t1 t2 ar), + (UR t1 t2 ar ur) = {{ (@Param40.BuildRel _ _ lp:ar lp:ur (@Map0.BuildHas _ _ (@sym_rel lp:t1 lp:t2 lp:ar))) }}, + insert-coersions t1 t2 (UR t1 t2 ar ur) (MapR t1 t2 ar ur) (MRR t1 t2 ar ur) (RMR t1 t2 ar ur) (MRRMKR t1 t2 ar ur), + coq.mk-app IndMap [t1, t2, (MapR t1 t2 ar ur)] (NIndMap t1 t2 ar ur), + coq.mk-app MR [t1,t2, (MRR t1 t2 ar ur)] (NMR t1 t2 ar ur), + coq.mk-app RM [t1,t2, (RMR t1 t2 ar ur)] (NRM t1 t2 ar ur), + coq.mk-app MRRMK [t1,t2, (MRRMKR t1 t2 ar ur)] (NMRRMKR t1 t2 ar ur), + implement-umap M (Bo t1 t2 ar ur) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) + (NIndMap t1 t2 ar ur) (NMR t1 t2 ar ur) (NRM t1 t2 ar ur) (NMRRMKR t1 t2 ar ur) (R t1 t2 ar ur). + + +func main inductive, string -> list prop. +main GR Prefix Clauses :- std.do! [ + + coq.env.indt GR _ TyParamNo _ Arity _ _, + Ind = (global (indt GR)), + std.assert! (param Ind Ind IndR) "derive.umap: use derive.param2 before", + std.assert! (mymap-def Ind IndMap) "derive.umap: use derive.mymap before", + std.assert! (mR-db Ind MR) "derive.umap: use derive.mR before", + std.assert! (rm-db Ind RM) "derive.umap: use derive.Rm before", + std.assert! (mRRmK-db Ind MRRMK) "derive.umap: use derive.MRRMK before", + mk-umap-type TyParamNo Arity Ind IndR UMapTySkel, + std.assert-ok! (coq.elaborate-skeleton UMapTySkel _ UMapTy) "derive.umap generates illtyped type", + implement-umap TyParamNo UMapTy Ind Ind IndR IndMap MR RM MRRMK RUMapSkel, + std.assert-ok! (coq.elaborate-skeleton RUMapSkel _ RUMap) "derive.umap generates illtyped term", + NameUMap is Prefix ^ "umap", + coq.ensure-fresh-global-id NameUMap FNameUMap, + %coq.env.add-const FNameUMap RUMap UMapTy _ CUMap, + % todo: check RUMap against UMapTy modulo universes + coq.env.add-const FNameUMap RUMap _ _ CUMap, + ClausesUMap = [umap-done GR, umap-db Ind (global (const CUMap))], + Clauses = ClausesUMap, + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.umap.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/std/algo/tests/test_map4.v b/std/algo/tests/test_map4.v new file mode 100644 index 00000000..ce0a2d9b --- /dev/null +++ b/std/algo/tests/test_map4.v @@ -0,0 +1,42 @@ +From Trocq Require Import map4. +From Trocq Require Import coverage. +Unset Uniform Inductive Parameters. + +Elpi derive False. +Check False_mRRmK : forall f1 f2 fR, False_mR f1 f2 (False_Rm f1 f2 fR) = fR. + +Elpi derive Unit. +Check Unit_mRRmK : forall u1 u2 uR, Unit_mR u1 u2 (Unit_Rm u1 u2 uR) = uR. + +Elpi derive Bool. +Check Bool_mRRmK : forall b1 b2 bR, Bool_mR b1 b2 (Bool_Rm b1 b2 bR) = bR. + +Elpi derive Wrap. +Check Wrap_mRRmK : forall w1 w2 wR, Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. + +Elpi derive WrapMore. +Check WrapMore_mRRmK : forall w1 w2 wR, WrapMore_mR w1 w2 (WrapMore_Rm w1 w2 wR) = wR. + +Elpi derive Nat. +Check Nat_mRRmK : forall n1 n2 nR, Nat_mR n1 n2 (Nat_Rm n1 n2 nR) = nR. + +Elpi derive Box. +Check Box_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall (b1 : Box A1) (b2 : Box A2) (bR : Box_R A1 A2 AR b1 b2), + Box_mR A1 A2 AR b1 b2 (Box_Rm A1 A2 AR b1 b2 bR) = bR. + +Elpi derive Option. +Check Option_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall o1 o2 oR, Option_mR A1 A2 AR o1 o2 (Option_Rm A1 A2 AR o1 o2 oR) = oR. + +Elpi derive Prod. +Check Prod_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2) B1 B2 (BR : Param40.Rel B1 B2), + forall p1 p2 pR, Prod_mR A1 A2 AR B1 B2 BR p1 p2 (Prod_Rm A1 A2 AR B1 B2 BR p1 p2 pR) = pR. + +Elpi derive ThreeTypes. +Check ThreeTypes_mRRmK : +forall A1 A2 (AR : Param40.Rel A1 A2), +forall B1 B2 (BR : Param40.Rel B1 B2), +forall C1 C2 (CR : Param40.Rel C1 C2), + forall t1 t2 tR, ThreeTypes_mR A1 A2 AR B1 B2 BR C1 C2 CR t1 t2 (ThreeTypes_Rm A1 A2 AR B1 B2 BR C1 C2 CR t1 t2 tR) = tR. + +Elpi derive List. +Check List_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall l1 t2 lR, List_mR A1 A2 AR l1 t2 (List_Rm A1 A2 AR l1 t2 lR) = lR. \ No newline at end of file diff --git a/std/algo/tests/test_umap.v b/std/algo/tests/test_umap.v new file mode 100644 index 00000000..fe5ce759 --- /dev/null +++ b/std/algo/tests/test_umap.v @@ -0,0 +1,36 @@ +From Trocq Require Import map4 umap. +From Trocq Require Import coverage. +Unset Uniform Inductive Parameters. + +Elpi derive False. +Check False_umap : IsUMap False_R. + +Elpi derive Unit. +Check Unit_umap : IsUMap Unit_R. + +Elpi derive Bool. +Check Bool_umap : IsUMap Bool_R. + +Elpi derive Wrap. +Check Wrap_umap : IsUMap Wrap_R. + +Elpi derive WrapMore. +Check WrapMore_umap : IsUMap WrapMore_R. + +Elpi derive Nat. +Check Nat_umap : IsUMap Nat_R. + +Elpi derive Box. +Check Box_umap : forall A1 A2 AR UR, IsUMap (Box_R A1 A2 AR). + +Elpi derive Option. +Check Option_umap : forall A1 A2 AR UR, IsUMap (Option_R A1 A2 AR). + +Elpi derive Prod. +Check Prod_umap : forall A1 A2 AR UR B1 B2 BR BUR, IsUMap (Prod_R A1 A2 AR B1 B2 BR). + +Elpi derive ThreeTypes. +Check ThreeTypes_umap : forall A1 A2 AR UR B1 B2 BR BUR C1 C2 CR CUR, IsUMap (ThreeTypes_R A1 A2 AR B1 B2 BR C1 C2 CR). + +Elpi derive List. +Check List_umap : forall A1 A2 AR UR, IsUMap (List_R A1 A2 AR). \ No newline at end of file diff --git a/std/algo/theories/map4.v b/std/algo/theories/map4.v new file mode 100644 index 00000000..b2f18867 --- /dev/null +++ b/std/algo/theories/map4.v @@ -0,0 +1,8 @@ +(* Hook for mymap *) +(* From elpi.apps Require Export derive.legacy. *) +From Trocq Require Export mymap. +From Trocq Require Export injection_lemmas. +From Trocq Require Export mR. +From Trocq Require Export Rm. +From Trocq Require Export injK. +From Trocq Require Export mRRmK. \ No newline at end of file diff --git a/std/algo/theories/umap.v b/std/algo/theories/umap.v new file mode 100644 index 00000000..70ca2c78 --- /dev/null +++ b/std/algo/theories/umap.v @@ -0,0 +1,54 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From Trocq Extra Dependency "algo/elpi/umap.elpi" as umap. +From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. +From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. +From Trocq Require Import map4. +Unset Uniform Inductive Parameters. + +Elpi Db derive.umap.db lp:{{ + % [umap-db T D] + pred umap-db i:term, o:term. + + % [umap-done T D] + pred umap-done o:inductive. +}}. + +Elpi Command derive.umap. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db Header derive.mymap.db. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate Db Header derive.mR.db. +Elpi Accumulate Db derive.mR.db. +Elpi Accumulate Db Header derive.Rm.db. +Elpi Accumulate Db derive.Rm.db. +Elpi Accumulate Db Header derive.mRRmK.db. +Elpi Accumulate Db derive.mRRmK.db. +Elpi Accumulate File common. +Elpi Accumulate File algo_utils. + +Elpi Accumulate Db derive.umap.db. +Elpi Accumulate File umap. +Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), + coq.gref->id (indt GR) Tname, + Prefix is Tname ^ "_", + derive.umap.main GR Prefix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.rel40 ". +}}. + +Elpi Accumulate derive Db derive.umap.db. +Elpi Accumulate derive File common. +Elpi Accumulate derive File algo_utils. +Elpi Accumulate derive File umap. + +Elpi Accumulate derive lp:{{ + +dep1 "umap" "mRRmK". +derivation (indt T) Prefix ff (derive "umap" (derive.umap.main T Prefix) (umap-done T)). + +}}. From 4f49f7d194d14bfa53beeed15d2adf4d57064732 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 17 Sep 2025 17:51:46 +0200 Subject: [PATCH 13/42] generating Param40.Rel fix build detailed description for sym swap derivation removing unnused variables split sym and symK + changing a bit the generated type for sym generating type of symK symmetrizationK for inductives --- std/_CoqProject | 8 +- std/algo/detailed/Detailed_sym.v | 123 +++++++++++++++++++++ std/algo/detailed/Detailed_symK.v | 171 ++++++++++++++++++++++++++++++ std/algo/elpi/common_algo.elpi | 75 ++++++++----- std/algo/elpi/mRRmK.elpi | 52 +-------- std/algo/elpi/rel40.elpi | 69 ++++++++++++ std/algo/elpi/sym.elpi | 124 ++++++++++++++++++++++ std/algo/elpi/symK.elpi | 166 +++++++++++++++++++++++++++++ std/algo/elpi/utils.elpi | 48 +++++++++ std/algo/tests/test_Rel40.v | 36 +++++++ std/algo/tests/test_sym.v | 30 ++++++ std/algo/tests/test_symK.v | 39 +++++++ std/algo/theories/Rel40.v | 64 +++++++++++ std/algo/theories/sym.v | 60 +++++++++++ std/algo/theories/symK.v | 65 ++++++++++++ 15 files changed, 1055 insertions(+), 75 deletions(-) create mode 100644 std/algo/detailed/Detailed_sym.v create mode 100644 std/algo/detailed/Detailed_symK.v create mode 100644 std/algo/elpi/rel40.elpi create mode 100644 std/algo/elpi/sym.elpi create mode 100644 std/algo/elpi/symK.elpi create mode 100644 std/algo/tests/test_Rel40.v create mode 100644 std/algo/tests/test_sym.v create mode 100644 std/algo/tests/test_symK.v create mode 100644 std/algo/theories/Rel40.v create mode 100644 std/algo/theories/sym.v create mode 100644 std/algo/theories/symK.v diff --git a/std/_CoqProject b/std/_CoqProject index 12ba0d87..178af6d9 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -30,6 +30,10 @@ generic/Trocq.v generic/Vernac.v algo/tests/coverage.v +algo/theories/sym.v +algo/tests/test_sym.v +algo/theories/symK.v +algo/tests/test_symK.v algo/theories/mymap.v algo/tests/test_mymap.v algo/theories/injection_lemmas.v @@ -45,4 +49,6 @@ algo/tests/test_mRRmK.v algo/theories/map4.v algo/tests/test_map4.v algo/theories/umap.v -algo/tests/test_umap.v \ No newline at end of file +algo/tests/test_umap.v +algo/theories/Rel40.v +algo/tests/test_Rel40.v \ No newline at end of file diff --git a/std/algo/detailed/Detailed_sym.v b/std/algo/detailed/Detailed_sym.v new file mode 100644 index 00000000..7373190d --- /dev/null +++ b/std/algo/detailed/Detailed_sym.v @@ -0,0 +1,123 @@ +From Coq Require Import ssreflect. +From elpi.apps.derive Require Import derive derive.param2. +Require Import Hierarchy. +From Trocq Require Import coverage. +(* Require Import HoTT_additions Hierarchy. *) +Unset Uniform Inductive Parameters. +(* Unset Universe Polymorphism. *) +Unset Universe Minimization ToSet. + +(* Definition Unit := unit. *) + +Elpi derive.param2 Unit. +Definition UnitR := Unit_R. +Definition unit_Pred := fun (s1 s2: Unit) (RR : Unit_R s1 s2)=> Unit_R s2 s1. + +Definition unitR_sym : forall u1 u2, UnitR u1 u2 -> UnitR u2 u1. +Proof. +move=> u1 u2 uR. +refine (Unit_R_rect unit_Pred _ u1 u2 uR). +- exact TT_R. +Defined. + +Elpi derive.param2 Bool. +Definition BoolR := Bool_R. + +Notation BoolR_symPred := (fun b1 b2 (bR : Bool_R b1 b2)=> Bool_R b2 b1). +Definition boolR_sym : forall b1 b2 (bR : Bool_R b1 b2), Bool_R b2 b1. +Proof. +refine (fun b1 b2 bR=> Bool_R_rect BoolR_symPred _ _ b1 b2 bR). +- exact: Falseb_R. +- exact: Trueb_R. +Defined. + +Elpi derive.param2 Wrap. +Definition WrapR := Wrap_R. + +Notation wrapR_symPred := (fun w1 w2 (wR : Wrap_R w1 w2) => Wrap_R w2 w1). +Definition wrapR_sym : forall w1 w2, Wrap_R w1 w2 -> Wrap_R w2 w1. +Proof. +refine (fun w1 w2 wR=> Wrap_R_rect wrapR_symPred _ w1 w2 wR). +refine (fun u1 u2 uR=> _). +exact: (KWrap1_R u2 u1 (unitR_sym u1 u2 uR)). +Defined. + +Elpi derive.param2 WrapMore. +Notation wrapMoreR_symPred := (fun w1 w2 (wR : WrapMore_R w1 w2) => WrapMore_R w2 w1). +Definition wrapMoreR_sym : forall w1 w2, WrapMore_R w1 w2 -> WrapMore_R w2 w1. +Proof. +refine (fun w1 w2 wR=> WrapMore_R_rect wrapMoreR_symPred _ _ _ w1 w2 wR). +- refine (fun u1 u2 uR=> _). + refine (fun b1 b2 bR=> _). + exact: (KWrap_R u2 u1 (unitR_sym u1 u2 uR) b2 b1 (boolR_sym b1 b2 bR)). +- refine (fun w1 w2 wR=> _). + exact: (KWrapWrap_R w2 w1 (wrapR_sym w1 w2 wR)). +- refine (fun u1 u2 uR=> _). + refine (fun u3 u4 uR2=> _). + refine (fun u5 u6 uR3=> _). + exact: (F_R u2 u1 (unitR_sym u1 u2 uR) u4 u3 (unitR_sym u3 u4 uR2) u6 u5 (unitR_sym u5 u6 uR3)). +Defined. + +Definition Nat := nat. +Elpi derive.param2 nat. +Definition NatR := nat_R. + +Notation nat_symPred := (fun w1 w2 (wR : nat_R w1 w2) => nat_R w2 w1). +Fixpoint nat_sym : forall w1 w2, nat_R w1 w2 -> nat_R w2 w1. +Proof. +refine (fun w1 w2 wR=> nat_R_rect nat_symPred _ _ w1 w2 wR). +exact: O_R. +refine (fun n1 n2 nR IH => _). +apply (S_R _ _ (nat_sym _ _ nR)). +Defined. + +Inductive Box (A : Type) : Type := B : A -> Box A. +Elpi derive.param2 Box. + +Notation boxR_symPred := (fun A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : Box_R A1 A2 AR b1 b2) => Box_R A2 A1 (sym_rel AR) b2 b1). +Definition boxR_sym : forall A1 A2 (AR: A1 -> A2 -> Type) b1 b2, Box_R A1 A2 AR b1 b2 -> Box_R A2 A1 (sym_rel AR) b2 b1. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun b1 b2 bR=> _). +refine (Box_R_rect A1 A2 AR (boxR_symPred A1 A2 AR) _ _ _ bR). +move=> a1 a2 ar. +refine (B_R A2 A1 (sym_rel AR) a2 a1 _). +exact: ( (fun x y r => r) a1 a2 ar). +Defined. + +Elpi derive.param2 Option. + +Notation Option_symPred := (fun A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : Option_R A1 A2 AR b1 b2) => Option_R A2 A1 (sym_rel AR) b2 b1). +Definition Option_sym : forall A1 A2 (AR: A1 -> A2 -> Type) b1 b2, Option_R A1 A2 AR b1 b2 -> Option_R A2 A1 (sym_rel AR) b2 b1. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun b1 b2 bR=> _). +refine (Option_R_rect A1 A2 AR (Option_symPred A1 A2 AR) _ _ _ _ bR). +- move=> a1 a2 ar. exact: (Some_R A2 A1 (sym_rel AR) a2 a1 ar). +- exact: (None_R A2 A1 (sym_rel AR)). +Defined. + +Elpi derive.param2 List. + +Notation List_symPred := (fun A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : List_R A1 A2 AR b1 b2) => List_R A2 A1 (sym_rel AR) b2 b1). +Fixpoint List_sym : forall A1 A2 (AR: A1 -> A2 -> Type) b1 b2, List_R A1 A2 AR b1 b2 -> List_R A2 A1 (sym_rel AR) b2 b1. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun b1 b2 bR=> _). +refine (List_R_rect A1 A2 AR (List_symPred A1 A2 AR) _ _ _ _ bR). +- exact: (nil_R A2 A1 (sym_rel AR)). +- move=> a1 a2 ar l1 l2 lr IH. +exact: (cons_R A2 A1 (sym_rel AR) a2 a1 ar l2 l1 (List_sym A1 A2 AR _ _ lr)). +Defined. + +Elpi derive.param2 Prod. + +Notation Prod_symPred := (fun A1 A2 (AR: A1 -> A2 -> Type) B1 B2 (BR : B1 -> B2 -> Type) b1 b2 (bR : Prod_R A1 A2 AR B1 B2 BR b1 b2) => Prod_R A2 A1 (sym_rel AR) B2 B1 (sym_rel BR) b2 b1). +Definition Prod_sym : forall A1 A2 (AR: A1 -> A2 -> Type) B1 B2 (BR: B1 -> B2 -> Type) b1 b2, Prod_R A1 A2 AR B1 B2 BR b1 b2 -> Prod_R A2 A1 (sym_rel AR) B2 B1 (sym_rel BR) b2 b1. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun B1 B2 BR=> _). +refine (fun b1 b2 bR=> _). +refine (Prod_R_rect A1 A2 AR B1 B2 BR (Prod_symPred A1 A2 AR B1 B2 BR) _ _ _ bR). +- move=> a1 a2 ar b b' br. exact: (pair_R A2 A1 (sym_rel AR) B2 B1 (sym_rel BR) a2 a1 ar b' b br). +Defined. diff --git a/std/algo/detailed/Detailed_symK.v b/std/algo/detailed/Detailed_symK.v new file mode 100644 index 00000000..7b3eef50 --- /dev/null +++ b/std/algo/detailed/Detailed_symK.v @@ -0,0 +1,171 @@ +From Coq Require Import ssreflect. +From elpi.apps.derive Require Import derive derive.param2. +Require Import Hierarchy. +From Trocq Require Import HoTTNotations. +From Trocq Require Import coverage sym. +(* Require Import HoTT_additions Hierarchy. *) +Unset Uniform Inductive Parameters. +(* Unset Universe Polymorphism. *) +Unset Universe Minimization ToSet. + +Elpi derive.param2 False. +Elpi derive.sym False. + +Definition False_symKPred := fun u1 u2 (uR : False_R u1 u2)=> False_sym u2 u1 (False_sym u1 u2 uR) = uR. +Definition False_symK : forall u1 u2 (uR : False_R u1 u2), False_sym u2 u1 (False_sym u1 u2 uR) = uR. +Proof. +move=> u1 u2 uR. +refine (False_R_ind False_symKPred u1 u2 uR). +Defined. + +Elpi derive.param2 Unit. +Elpi derive.sym Unit. + +Definition Unit_symKPred := fun u1 u2 (uR : Unit_R u1 u2)=> Unit_sym u2 u1 (Unit_sym u1 u2 uR) = uR. +Definition Unit_symK : forall u1 u2 (uR : Unit_R u1 u2), Unit_sym u2 u1 (Unit_sym u1 u2 uR) = uR. +Proof. +move=> u1 u2 uR. +refine (Unit_R_ind Unit_symKPred _ u1 u2 uR). +exact: eq_refl. +Defined. + +Elpi derive.param2 Bool. +Elpi derive.sym Bool. + +Notation Bool_symKPred := (fun b1 b2 (bR : Bool_R b1 b2)=> Bool_sym b2 b1 (Bool_sym b1 b2 bR) = bR). +Definition Bool_symK : forall b1 b2 (bR : Bool_R b1 b2), Bool_sym b2 b1 (Bool_sym b1 b2 bR) = bR. +Proof. +refine (fun b1 b2 bR=> Bool_R_ind Bool_symKPred _ _ b1 b2 bR). +- exact: eq_refl. +- exact: eq_refl. +Defined. + +Elpi derive.param2 Wrap. +Elpi derive.sym Wrap. + +Notation Wrap_symKPred := (fun w1 w2 (wR : Wrap_R w1 w2) => Wrap_sym w2 w1 (Wrap_sym w1 w2 wR) = wR). +Definition Wrap_symK : forall w1 w2 (wR : Wrap_R w1 w2), Wrap_sym w2 w1 (Wrap_sym w1 w2 wR) = wR. +Proof. +refine (fun w1 w2 wR=> Wrap_R_ind Wrap_symKPred _ w1 w2 wR). +refine (fun u1 u2 uR=> _). +unfold Wrap_sym. +unfold Wrap_R_rect. +refine ( @eq_ind _ _ (fun t => KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR) _ _ (Unit_symK u1 u2 uR)^). +(* rewrite Unit_symK. *) +exact: eq_refl. +Defined. + +Elpi derive.param2 WrapMore. +Elpi derive.sym WrapMore. + +Notation WrapMore_symKPred := (fun w1 w2 (wR : WrapMore_R w1 w2) => WrapMore_sym w2 w1 (WrapMore_sym w1 w2 wR) = wR). +Definition WrapMore_symK : forall w1 w2 (wR : WrapMore_R w1 w2), WrapMore_sym w2 w1 (WrapMore_sym w1 w2 wR) = wR. +Proof. +refine (fun w1 w2 wR=> WrapMore_R_ind WrapMore_symKPred _ _ _ w1 w2 wR). +- refine (fun u1 u2 uR=> _). + refine (fun b1 b2 bR=> _). + cbn delta beta iota. + refine ( @eq_ind _ _ (fun t => KWrap_R u1 u2 t b1 b2 +(Bool_sym b2 b1 (Bool_sym b1 b2 bR)) = KWrap_R u1 u2 uR b1 b2 bR) _ _ (Unit_symK u1 u2 uR)^). + refine ( @eq_ind _ _ (fun t => KWrap_R u1 u2 uR b1 b2 +t = KWrap_R u1 u2 uR b1 b2 bR) _ _ (Bool_symK b1 b2 bR)^). + (* rewrite Unit_symK Bool_symK. *) + exact: eq_refl. +- refine (fun w1 w2 wR=> _). + cbn delta beta iota. + rewrite Wrap_symK. + exact: eq_refl. +- refine (fun u1 u2 uR=> _). + refine (fun u3 u4 uR2 => _). + refine (fun u5 u6 uR3 => _). + cbn delta beta iota. + rewrite !Unit_symK. + exact: eq_refl. +Defined. + +Elpi derive.param2 Nat. +Elpi derive.sym Nat. + +Notation Nat_symKPred := (fun w1 w2 (wR : Nat_R w1 w2) => Nat_sym w2 w1 (Nat_sym w1 w2 wR) = wR). +Fixpoint Nat_symK : forall w1 w2 (wR : Nat_R w1 w2), Nat_sym w2 w1 (Nat_sym w1 w2 wR) = wR. +Proof. +refine (fun w1 w2 wR=> Nat_R_ind Nat_symKPred _ _ w1 w2 wR). +exact: eq_refl. +refine (fun n1 n2 nR IH => _). +cbn delta beta iota. +refine (@eq_ind _ _ (fun t => S'_R n1 n2 t = S'_R n1 n2 nR) _ _ (Nat_symK n1 n2 nR)^). +(* rewrite IH. *) +exact: eq_refl. +Defined. + +Elpi derive.param2 Box. +Elpi derive.sym Box. + +Notation Box_symKPred := (fun A1 A2 (AR: A1 -> A2 -> Type) + b1 b2 (bR : Box_R A1 A2 AR b1 b2) + => Box_sym A2 A1 (sym_rel AR) b2 b1 (Box_sym A1 A2 AR b1 b2 bR) = bR). +Definition Box_symK : + forall A1 A2 (AR: A1 -> A2 -> Type) + b1 b2 (bR : Box_R A1 A2 AR b1 b2), + Box_sym A2 A1 (sym_rel AR) b2 b1 (Box_sym A1 A2 AR b1 b2 bR) = bR. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun b1 b2 bR=> _). +refine (Box_R_ind A1 A2 AR (Box_symKPred A1 A2 AR) _ b1 b2 bR). +move=> a1 a2 ar. +cbn delta beta iota. +exact: eq_refl. +Defined. + +Elpi derive.param2 Option. +Elpi derive.sym Option. + + +Notation Option_symKPred := (fun A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : Option_R A1 A2 AR b1 b2) => Option_sym A2 A1 (sym_rel AR) b2 b1 (Option_sym A1 A2 AR b1 b2 bR) = bR). +Definition Option_symK : + forall A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : Option_R A1 A2 AR b1 b2), Option_sym A2 A1 (sym_rel AR) b2 b1 (Option_sym A1 A2 AR b1 b2 bR) = bR. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun b1 b2 bR=> _). +refine (Option_R_ind A1 A2 AR (Option_symKPred A1 A2 AR) _ _ b1 b2 bR). +- exact: eq_refl. +- move=> a1 a2 ar. +simpl. +cbn delta beta iota. +Check (@eq_refl ((sym_rel AR) a2 a1) ar). +exact: eq_refl. +Defined. + +Elpi derive.param2 Prod. +Elpi derive.sym Prod. + +Notation Prod_symKPred := (fun A1 A2 (AR: A1 -> A2 -> Type) B1 B2 BR b1 b2 (bR : Prod_R A1 A2 AR B1 B2 BR b1 b2) => Prod_sym A2 A1 (sym_rel AR) B2 B1 (sym_rel BR) b2 b1 (Prod_sym A1 A2 AR B1 B2 BR b1 b2 bR) = bR). +Definition Prod_symK : + forall A1 A2 (AR: A1 -> A2 -> Type) B1 B2 (BR : B1 -> B2 -> Type) b1 b2 (bR : Prod_R A1 A2 AR B1 B2 BR b1 b2), Prod_sym A2 A1 (sym_rel AR) B2 B1 (sym_rel BR) b2 b1 (Prod_sym A1 A2 AR B1 B2 BR b1 b2 bR) = bR. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun B1 B2 BR=> _). +refine (fun b1 b2 bR=> _). +refine (Prod_R_ind A1 A2 AR B1 B2 BR (Prod_symKPred A1 A2 AR B1 B2 BR) _ b1 b2 bR). +- move=> a1 a2 ar b b' br. +exact: eq_refl. +Defined. + +Elpi derive.param2 List. +Elpi derive.sym List. + +Notation List_symKPred := (fun A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : List_R A1 A2 AR b1 b2) => List_sym A2 A1 (sym_rel AR) b2 b1 (List_sym A1 A2 AR b1 b2 bR) = bR). +Fixpoint List_symK : + forall A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : List_R A1 A2 AR b1 b2), List_sym A2 A1 (sym_rel AR) b2 b1 (List_sym A1 A2 AR b1 b2 bR) = bR. +Proof. +refine (fun A1 A2 AR=> _). +refine (fun b1 b2 bR=> _). +refine (List_R_ind A1 A2 AR (List_symKPred A1 A2 AR) _ _ b1 b2 bR). +- exact: eq_refl. +- move=> a1 a2 ar l1 l2 lr IH. + cbn delta beta iota. + refine (@eq_ind _ _ (fun t => Cons_R A1 A2 (sym_rel (sym_rel AR)) a1 a2 ar l1 l2 t = +Cons_R A1 A2 AR a1 a2 ar l1 l2 lr) _ _ (List_symK A1 A2 AR l1 l2 lr)^). + (* rewrite IH. *) + exact: eq_refl. +Defined. diff --git a/std/algo/elpi/common_algo.elpi b/std/algo/elpi/common_algo.elpi index 99c61b5f..3addc97b 100644 --- a/std/algo/elpi/common_algo.elpi +++ b/std/algo/elpi/common_algo.elpi @@ -2,11 +2,13 @@ namespace derive.common-algo { pred rel-mode i:int o:term. -rel-mode 0 {{ Param10.Rel }}. -rel-mode 1 {{ Param2a0.Rel }}. -rel-mode 2 {{ Param2b0.Rel }}. -rel-mode 3 {{ Param30.Rel }}. -rel-mode 4 {{ Param40.Rel }}. +rel-mode 0 {{ Param10.Rel }}. % my-map +rel-mode 1 {{ Param2a0.Rel }}. % mR +rel-mode 2 {{ Param2b0.Rel }}. % Rm +rel-mode 3 {{ Param30.Rel }}. % _ +rel-mode 4 {{ Param40.Rel }}. % mRRmK +rel-mode 5 {{ fun (A B : Type)=> A -> B -> Type }}. % sym +rel-mode 6 {{ fun (A B : Type)=> A -> B -> Type }}. % symK pred swap i:term, i:term, i:bool, o:term, o:term. swap A B tt B A. @@ -29,6 +31,13 @@ mk-return ML MR Rel 2 ITyTy2 R :- mk-impl-return ML MR Rel tt ITyTy2 R. % mk-return ML MR Rel +pred symm_tyargs i: list term, i: list term, o: list term. +symm_tyargs [] L L. +symm_tyargs [A1, A2, AR | L2] Acc R :- + coq.mk-app {{ @sym_rel }} [A1,A2,AR] RAS, + std.append Acc [A2, A1, RAS ] NewAcc, + symm_tyargs L2 NewAcc R. + % The number of Type parameters in T % Type of inductive T, % Type of bin parametricity translation TR, @@ -65,13 +74,35 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 4 LRev MR-DB RM- MR-DB Ind MapInR, coq.mk-app MapInR {std.append L [x,y,(Rm x y iR)]} (MRRM x y iR), (R x y iR) = {{ @eq _ lp:{{MRRM x y iR}} lp:iR }}. +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 5 LRev _ _ + (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- + std.rev LRev L, + symm_tyargs L [] L2, + @pi-decl IN1 ITyTy x\ + @pi-decl IN2 ITyTy2 y\ + coq.mk-app Rel {std.append L [x,y]} (RelTy1 x y), + coq.mk-app Rel {std.append L2 [y,x]} (RelTy2 x y), + R x y = {{ lp:{{RelTy1 x y}} -> lp:{{RelTy2 x y}} }}. +% TODO: remove use of MR-DB, try just pass the MR and RM +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) SymC _ Rel 6 LRev _ _ + (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ prod `IR` (RelTy x y) iR\ (R x y iR)) :- + std.rev LRev L, + symm_tyargs L [] L2, + @pi-decl IN1 ITyTy x\ + @pi-decl IN2 ITyTy2 y\ + coq.mk-app Rel {std.append L [x,y]} (RelTy x y), + @pi-decl `IR` (RelTy x y) iR\ + % sigma NewML NewMR NewRel L\ + coq.mk-app SymC {std.append L [x,y,iR]} (SymR x y iR), + coq.mk-app SymC {std.append L2 [y,x,(SymR x y iR)]} (SymSym x y iR), + (R x y iR) = {{ @eq _ lp:{{SymSym x y iR}} lp:iR }}. % Process two type parameters + 1 relation at a time. % Apply these parameters to the LHS of the equation. mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ lp:AR lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- M is N - 1, rel-mode Swap ARSkel, - coq.elaborate-skeleton ARSkel _ AR ok, + coq.elaborate-skeleton ARSkel {{ Type -> Type -> Type }} AR ok, pi a1 a2 ar\ sigma NewL\ std.append [ar,a2,a1] L NewL, @@ -79,26 +110,22 @@ mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 pred mk-mR-type-mR i:int, i:term, i:term, i:term, i:term, o:term. mk-mR-type-mR N T ML MR Rel RTy :- - - % (mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ - % (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- - % (Swap = 0 ; Swap = 1), - % @pi-decl IN1 ITyTy x\ - % @pi-decl IN2 ITyTy2 y\ - % sigma NewML NewMR NewRel L\ - % std.rev LRev L, - % coq.mk-app ML {std.append L [x]} NewML, - % NewMR = y, - % coq.mk-app Rel {std.append L [x,y]} NewRel, - % mk-return NewML NewMR NewRel Swap ITyTy2 (R x y)) => - mk-mR-type-priv N T ML MR Rel 1 [] Dummy Dummy RTy. + mk-mR-type-priv N T ML MR Rel 1 [] _ _ RTy. pred mk-mR-type-Rm i:int, i:term, i:term, i:term, i:term, o:term. mk-mR-type-Rm N T ML MR Rel R :- - mk-mR-type-priv N T ML MR Rel 2 [] Dummy Dummy R. + mk-mR-type-priv N T ML MR Rel 2 [] _ _ R. + +pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:(pred i:term, o:term) , i: (pred i:term, o:term), o:term. +mk-mR-type-mRRmK N T ML Rel MR-DB RM-DB R :- + mk-mR-type-priv N T ML _ Rel 4 [] MR-DB RM-DB R. + +pred mk-mR-type-sym i:int, i:term, i:term, o:term. +mk-mR-type-sym N T Rel R :- + mk-mR-type-priv N T _ _ Rel 5 [] _ _ R. + +pred mk-mR-type-symK i:int, i:term, i:term, i:term, o:term. +mk-mR-type-symK N T Rel Sym R :- + mk-mR-type-priv N T Sym _ Rel 6 [] _ _ R. -pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:term, i:(pred i:term, o:term) , i: (pred i:term, o:term), o:term. -% pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:term, i:(term -> term -> prop), i: (term -> term -> prop), o:term. -mk-mR-type-mRRmK N T ML MR Rel MR-DB RM-DB R :- - mk-mR-type-priv N T ML MR Rel 4 [] MR-DB RM-DB R. } \ No newline at end of file diff --git a/std/algo/elpi/mRRmK.elpi b/std/algo/elpi/mRRmK.elpi index d2d360a1..28145a33 100644 --- a/std/algo/elpi/mRRmK.elpi +++ b/std/algo/elpi/mRRmK.elpi @@ -1,5 +1,5 @@ shorten derive.common-algo.{mk-mR-type-mRRmK}. -shorten derive.algo-utils.{mk-chain, for-K-get-KI,type-of-args}. +shorten derive.algo-utils.{mk-chain, for-K-get-KI,type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with}. namespace derive.mRRmK { @@ -18,38 +18,6 @@ collect-paths N T [P|Ps] :- std.last Args1 P, collect-paths M AP2 Ps. - % whd beta-iota-delta-zeta, main code -pred whd-fuel i:term, i:stack, i:int, o:term, o:stack. -whd-fuel T S 0 T S. -whd-fuel (app [Hd|Args]) C N X XC :- !, whd-fuel Hd {std.append Args C} N X XC. -whd-fuel (fun _ _ _ as X) [] _ X [] :- !. -whd-fuel (fun N T F) [B|C] M X XC :- !, - (pi x\ def x N T B => cache x BN_ => whd-fuel (F x) C M (F1 x) (C1 x)), X = F1 B, XC = C1 B. -whd-fuel (let N T B F) C M X XC :- !, - (pi x\ def x N T B => cache x BN_ => whd-fuel (F x) C M (F1 x) (C1 x)), X = F1 B, XC = C1 B. -whd-fuel (global (const GR)) C M X XC :- - O is M - 1, unfold GR none C D DC, !, whd-fuel D DC O X XC. -whd-fuel (pglobal (const GR) I) C M X XC :- - O is M - 1, - unfold GR (some I) C D DC, !, whd-fuel D DC O X XC. -whd-fuel (primitive (proj _ N)) [A|C] M X XC :- whd-indc A _ KA, !, - whd-fuel {proj-red KA N C} M X XC. -whd-fuel (global (const GR) as HD) C M X XC :- coq.env.primitive? GR, !, - unwind HD C Orig, - coq.reduction.lazy.whd_all Orig R, - if (same_term Orig R) (X = HD, XC = C) (whd-fuel R [] M X XC). -whd-fuel (match A _ L) C M X XC :- whd-indc A GR KA, !, - whd-fuel {match-red GR KA L C} M X XC. -whd-fuel (fix _ N _ F as Fix) C M X XC :- nth-stack N C LA A RA, whd-indc A GR KA, !, - whd-fuel {fix-red F Fix LA GR KA RA} M X XC. -whd-fuel N C M X XC :- name N, def N _ _ V, !, cache-whd N VN V, whd-fuel VN C M X XC. -whd-fuel X C _ X C. - - -pred iota-step i:term, i:stack, o:term, o:stack. -iota-step (match A _ L) C X XC :- whd-indc A GR KA, !, - match-red GR KA L C X XC. - % delta beta iota iota pred red-mR i:term, i:stack, o:term,o:stack. red-mR X C R RS :- @@ -72,13 +40,6 @@ feed-injKs InjKs TyArgsDest Args1 Args2 Paths Eqs :- std.map InjKs (x\ r\ sigma TMP\ coq.mk-app x TyArgsDest TMP, r = TMP) NewInjKs, feed-injKs NewInjKs [] Args1 Args2 Paths Eqs. -pred invert-eqs i:list term, o:list term. -invert-eqs Eqs IEqs :- - std.map Eqs (x\r\ sigma Skel TMP Err\ Skel = {{ @eq_sym _ _ _ lp:x}}, - coq.elaborate-skeleton Skel _ TMP ok, - r = TMP - ) IEqs. - pred collect-arguments i:int, i:int, i:term, o:list term, o:list term, o:list term, o:list term. collect-arguments TyArgsNo InitArgs MRRM TyArgsDest Args1 Args2 Paths :- red-mR MRRM [] _KR Args12r, % KR a1 a2 ar b1 b2 br ... @@ -97,15 +58,6 @@ collect-arguments TyArgsNo InitArgs MRRM TyArgsDest Args1 Args2 Paths :- coq.mk-app Concat ChainArgs Chain, collect-paths InitArgs Chain Paths. % Paths are Rm1 a1 a2 aR, Rm2 b1 b2 bR, ... -pred rewrite-with i:list term, i:list term, i:term, o:term. -rewrite-with [] [] End End. -rewrite-with [Eq|Eqs] [Pat|Pats] End R :- - (pi rest\ - (T rest) = {{ @eq_ind _ _ lp:Pat lp:rest _ lp:Eq }}), - rewrite-with Eqs Pats End RestSkel, - coq.elaborate-skeleton RestSkel _ Rest ok, - R = (T Rest). - pred drop-last i:list A, o:list A. drop-last L R :- Take is {std.length L} - 1, @@ -316,7 +268,7 @@ main GR Prefix Clauses :- std.do! [ param Ind Ind TR, coq.typecheck TR TRTy _, mymap-def Ind IndMap, - mk-mR-type-mRRmK TyParamNo TRTy IndMap {{ Type }} TR mR-db rm-db MRTy, + mk-mR-type-mRRmK TyParamNo TRTy IndMap TR mR-db rm-db MRTy, coq.elaborate-skeleton MRTy _ MRTyE ok, TR = global (indt GRR), coq.gref->id (indt GRR) Rname, diff --git a/std/algo/elpi/rel40.elpi b/std/algo/elpi/rel40.elpi new file mode 100644 index 00000000..4ce2bfde --- /dev/null +++ b/std/algo/elpi/rel40.elpi @@ -0,0 +1,69 @@ +shorten derive.common-algo. {rel-mode}. +shorten derive.algo-utils.{gen-names-umap}. + +namespace derive.rel40 { + +% TyParamNo +% Arity +% Ind +% IndR +% TyArgs1 +% TyArgs2 +% ARArgs +pred mk-rel40-type-priv i:int, i:term, i:term, i:term, o:term. +mk-rel40-type-priv 0 _ IndL IndR {{ @Param40.Rel lp:IndL lp:IndR }}. +mk-rel40-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR + (prod TN1 Ty t1\ prod TN2 Ty t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- + M is N - 1, + gen-names-umap TN TN1 TN2 TRN URN, + @pi-decl TN1 Ty t1\ + @pi-decl TN2 Ty t2\ + (ARTy t1 t2) = {{ lp:t1 -> lp:t2 -> Type }}, + @pi-decl TRN (ARTy t1 t2) ar\ + (UMTy t1 t2 ar) = {{ @IsUMap lp:t1 lp:t2 lp:ar }}, + @pi-decl URN (UMTy t1 t2 ar) ur\ + coq.mk-app IndL [t1] (NIndL t1), + coq.mk-app IndR [t2] (NIndR t2), + mk-rel40-type-priv M (Bo t1) (NIndL t1) (NIndR t2) (R t1 t2 ar ur). + +% TyParamNo Arity Ind Rel +pred mk-rel40-type i:int, i:term, i:term, o:term. +mk-rel40-type TyParamNo Arity Ind R :- + mk-rel40-type-priv TyParamNo Arity Ind Ind R. + +% TyParamNo UMapTy IndL IndR Rel IndMap MR RM MRRMK +pred implement-rel40 i:int, i:term, i:term, o:term. +% implement-umap _ _ _ _ _ _ _ _ {{ Type }}. +implement-rel40 0 _ UMapI R :- + R = {{ @Build40 _ _ _ lp:UMapI }}. +implement-rel40 N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (Bo t1 t2 ar ur)) + UMapI (fun TN1 Ty1 t1\ fun TN2 Ty2 t2\ fun TRN (ARTy t1 t2) ar\ fun URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- + M is N - 1, + @pi-decl TN1 Ty1 t1\ + @pi-decl TN2 Ty2 t2\ + @pi-decl TRN (ARTy t1 t2) ar\ + @pi-decl URN (UMTy t1 t2 ar) ur\ + coq.mk-app UMapI [t1,t2,ar,ur] (NUMapI t1 t2 ar ur), + implement-rel40 M (Bo t1 t2 ar ur) (NUMapI t1 t2 ar ur) (R t1 t2 ar ur). + +func main inductive, string -> list prop. +main GR Prefix Clauses :- std.do! [ + + coq.env.indt GR _ TyParamNo _ Arity _ _, + Ind = (global (indt GR)), + std.assert! (umap-db Ind UMapI) "derive.rel40: use derive.umap before", + mk-rel40-type TyParamNo Arity Ind Rel40TySkel, + std.assert-ok! (coq.elaborate-skeleton Rel40TySkel _ Rel40Ty) "derive.rel40 generates illtyped type", + implement-rel40 TyParamNo Rel40Ty UMapI RRel40Skel, + std.assert-ok! (coq.elaborate-skeleton RRel40Skel _ RRel40) "derive.umap generates illtyped term", + NameRel is Prefix ^ "rel40", + coq.ensure-fresh-global-id NameRel FNameRel, + coq.env.add-const FNameRel RRel40 _ _ CRel, + ClausesRel = [rel40-done GR, rel40-db Ind (global (const CRel))], + Clauses = ClausesRel, + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.rel40.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/std/algo/elpi/sym.elpi b/std/algo/elpi/sym.elpi new file mode 100644 index 00000000..3d7319a8 --- /dev/null +++ b/std/algo/elpi/sym.elpi @@ -0,0 +1,124 @@ + +shorten derive.common-algo.{mk-mR-type-sym}. + +namespace derive.sym { + +% [|K|], remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, +pred process-args i:term, i:int, i:int, i:term, i:term, i:term, o:term. +process-args KR 0 _ _ _ _ R:- + R = KR. +process-args KR N _TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal ITyTy + (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- + M is N - 1, + @pi-decl AN1 A1Ty a1\ + @pi-decl AN2 A2Ty a2\ + @pi-decl ARN (ARTy a1 a2) ar\ + whd A1Ty _ A1Ind _, %TODO: fixme for inductives with type parameters, assemble sym + sym-db A1Ind SymC, + coq.mk-app SymC [a1,a2,ar] (RA a1 a2 ar), + coq.mk-app KR [a2,a1,(RA a1 a2 ar)] (NewKR a1 a2 ar), + (param a2 a1 ar =!=> + process-args (NewKR a1 a2 ar) M _ (Bo a1 a2 ar) Goal ITyTy (R a1 a2 ar)), + % if the type of the argument is an instance of the inductive type add an induction hypothesis + whd ITyTy _ Ind _, + whd A2Ty _ IndD _, + if (Ind = IndD) + (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), + (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) + (RF = R). + +% invariant: all type arguments were already processed. +% Constructor R, Constructor dest Type, No of Arguments to process, +% constructorR Type, type of i2, something of type : i1 i2 iR => goal. +pred mkBranch i:term, i:int, i:term, i:term, i:term, o:term. +mkBranch KR N KTyR ITyTy Goal Eq:- + whd ITyTy [] _ TyArgs, + process-args KR N {std.length TyArgs} KTyR Goal ITyTy Eq. + +pred mkBranches i:list term, i:list term, i:list term, i:term, i:term o:list term. +mkBranches [] [] [] _ _ []. +mkBranches [KR|KRs][KTy|KTys] [KTyR|KTyRs] ITyTy Goal [R|Rs] :- + mkBranch KR {coq.count-prods KTy} KTyR ITyTy Goal R, + mkBranches KRs KTys KTyRs ITyTy Goal Rs. + +pred implement-sym i:int, i:int, i:term, i:list term, i:list term, i:list term, i:term, i:term, o:term. +% Pred comes with Type parameters applied +% RInd comes with Type parameters applied +implement-sym 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KRs KTys KTyRs Pred RInd + (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- + coq.safe-dest-app ITy1 Ind _, + Ind = (global (indt GR)), + coq.env.recursive? GR, !, + RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), + coq.mk-app RInd [Pred] RIndP, + @pi-decl `f` RT f\ + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + @pi-decl ARN (ARTy i1 i2) ar\ + (sym-db Ind f => + mkBranches KRs KTys KTyRs ITy2 Pred (Brs f)), + std.append (Brs f) [i1,i2,ar] (IndArgs f i1 i2 ar), + coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). +implement-sym 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) _) KRs KTys KTyRs Pred RInd + (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- + coq.mk-app RInd [Pred] RIndP, + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + @pi-decl ARN (ARTy i1 i2) ar\ + mkBranches KRs KTys KTyRs ITy2 Pred Brs, + std.append Brs [i1,i2,ar] (IndArgs i1 i2 ar), + coq.mk-app RIndP (IndArgs i1 i2 ar) (R i1 i2 ar). +implement-sym N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KRs KTys KTyRs Pred RInd + (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, + @pi-decl AN1 ATy1 a1\ %A1 : Type + @pi-decl AN2 ATy2 a2\ %A2 : Type + @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param00.Rel A1 A2 + coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), + + (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, + coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, + coq.elaborate-skeleton {{ sym_rel lp:{{ RelAR a1 a2 ar }} }} (ARType a2 a1) (RelRA a1 a2 ar) ok, + + coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), + coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, + + std.map KRs (x\ r\ sigma TMP\ coq.mk-app x [a2,a1, (RelRA a1 a2 ar)] TMP, r = TMP) (NewKRs a1 a2 ar), + + std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), + std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), + Sym = {{ @sym_rel }}, + coq.mk-app Sym [a1, a2, ar] (SymApp a1 a2 ar), + (SymFun a1 a2 ar) = {{ fun (a1 : lp:{{a1}}) (a2 : lp:{{a2}}) (ar : lp:{{SymApp a1 a2 ar}})=> ar }}, + sym-db a1 (SymFun a1 a2 ar) ==> + implement-sym M TyParamNo (Bo a1 a2 ar) (NewKRs a1 a2 ar) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). + +func main inductive, string -> list prop. +main GR Prefix Clauses :- std.do! [ + + coq.env.indt GR _ TyParamNo _ _ _ KTys, + Ind = (global (indt GR)), + std.assert! (param Ind Ind TR) "derive.sym: use derive.param2 before", + coq.typecheck TR TRTy _, + mk-mR-type-sym TyParamNo TRTy TR MRTy, + std.assert-ok! (coq.elaborate-skeleton MRTy _ MRTyE) "derive.sym generates illtyped type", + TR = global (indt GRR), + coq.gref->id (indt GRR) Rname, + RInductionName is Rname ^ "_rect", + coq.locate RInductionName RInd, + coq.prod->fun MRTyE Pred, + coq.env.indt GRR _ _ _ _ KRNs KTyRs, + std.map KRNs (x\ r\ r = (global (indc x))) KRs, + implement-sym TyParamNo TyParamNo MRTyE KRs KTys KTyRs Pred (global RInd) R, + std.assert-ok! (coq.elaborate-skeleton R MRTyE Re) "derive.sym generates illtyped term", + Name is Prefix ^ "sym", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName Re MRTyE _ C, + I = global (indt GR), + Clauses = [sym-done GR, sym-db I (global (const C))], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.sym.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/std/algo/elpi/symK.elpi b/std/algo/elpi/symK.elpi new file mode 100644 index 00000000..3a9a2e22 --- /dev/null +++ b/std/algo/elpi/symK.elpi @@ -0,0 +1,166 @@ +shorten derive.algo-utils.{type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with}. +shorten derive.common-algo.{mk-mR-type-symK}. + +namespace derive.symK { + +% delta delta iota +pred red-symK i:term, i:stack, o:term,o:stack. +red-symK X C R RS :- + whd-fuel X C 2 XX CC, + iota-step XX CC R RS. + +pred pierce-goal-symK i:int, i:int, i:int, i:term, i: list term, o: list term, o: term. +pierce-goal-symK _ N N Goal [] [] Goal. +pierce-goal-symK TyParamNo N InitArgs CurrentGoal [Eq|Eqs] [Pat|Pats] EndGoal:- !, + M is N + 1, + coq.safe-dest-app CurrentGoal EqGoal [EqGoalTy,GoalLHS,GoalRHS], + coq.safe-dest-app GoalLHS KR Args, + Done is (TyParamNo * 3) + N * 3, + std.split-at Done Args L [A1,A2, SymSym | R], + coq.typecheck SymSym Ty ok, + (pi t\ + coq.mk-app KR {std.append L {std.append [A1, A2, t] R}} (NewKR t), + coq.mk-app EqGoal [EqGoalTy,(NewKR t),GoalRHS] (NewEqGoal t)), + Pat = (fun `t` Ty t\ (NewEqGoal t)), + coq.typecheck Eq EqTy ok, + coq.safe-dest-app EqTy _ [_,LHS,_], + coq.mk-app Pat [LHS] NewGoal, + pierce-goal-symK TyParamNo M InitArgs NewGoal Eqs Pats EndGoal. + +% [|K|], remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, +pred process-args i:term, i:term, i:term, i:int,i:int, i:int, i:term, i:list term, i:term, i:term, o:term. +process-args KsS KsD KR 0 ArgNo TyArgsNo _ RevEqs Goal _ R:- + std.rev RevEqs Eqs, + invert-eqs Eqs IEqs, + coq.mk-app Goal [KsS,KsD,KR] SubstGoal, + whd SubstGoal [] HD [IRTy,SymSymIR,IR], + red-symK SymSymIR [] KRHD KRArgs, + coq.mk-app KRHD KRArgs RedLHS, + coq.mk-app HD [IRTy,RedLHS,IR] StartingGoal, + pierce-goal-symK TyArgsNo 0 ArgNo StartingGoal IEqs PatsSym _, + End = {{ @eq_refl lp:IRTy lp:IR }}, + rewrite-with IEqs PatsSym End R. + +process-args KsS KsD KR N O TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Eqs Goal ITyTy + (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- + M is N - 1, + @pi-decl AN1 A1Ty a1\ + @pi-decl AN2 A2Ty a2\ + @pi-decl ARN (ARTy a1 a2) ar\ + + coq.mk-app KsS [a1] (NewKsS a1), + coq.mk-app KsD [a2] (NewKsD a2), + coq.mk-app KR [a1,a2,ar] (NewKR a1 a2 ar), + + (param a2 a1 ar =!=> + whd A2Ty _ IndD _, + symK-db IndD SymKA2, + coq.mk-app SymKA2 [a1, a2, ar] (SymKEq a1 a2 ar), + std.append [(SymKEq a1 a2 ar)] Eqs (NewEqs a1 a2 ar), + process-args (NewKsS a1) (NewKsD a2) (NewKR a1 a2 ar) M O TyArgsNo (Bo a1 a2 ar) (NewEqs a1 a2 ar) Goal ITyTy (R a1 a2 ar)), + % if the type of the argument is an instance of the inductive type add an induction hypothesis + whd ITyTy _ Ind _, + if (Ind = IndD) + (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), + (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) + (RF = R). + +% invariant: all type arguments were already processed. +% Constructor R, Constructor dest Type, No of Arguments to process, +% constructorR Type, type of i2, something of type : i1 i2 iR => goal. +pred mkBranch i:term, i:term, i:term, i:int, i:int, i:term, i:term, i:term, o:term. +mkBranch KsS KsD KR N M KTyR ITyTy Goal Eq:- + whd ITyTy [] _ TyArgs, + process-args KsS KsD KR N M {std.length TyArgs} KTyR [] Goal ITyTy Eq. + +pred mkBranches i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term o:list term. +mkBranches [] [] [] [] [] _ _ []. +mkBranches [KsS|KsSs] [KsD| KsDs] [KR|KRs][KTy|KTys] [KTyR|KTyRs] ITyTy Goal [R|Rs] :- + coq.count-prods KTy ArgNo, + mkBranch KsS KsD KR ArgNo ArgNo KTyR ITyTy Goal R, + mkBranches KsSs KsDs KRs KTys KTyRs ITyTy Goal Rs. + +pred implement-symK i:int, i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, o:term. +% Pred comes with Type parameters applied +% RInd comes with Type parameters applied +implement-symK 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KRs KTys KTyRs Pred RInd + (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- + coq.safe-dest-app ITy1 Ind _, + Ind = (global (indt GR)), + coq.env.recursive? GR, !, + RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), + coq.mk-app RInd [Pred] RIndP, + @pi-decl `f` RT f\ + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + @pi-decl ARN (ARTy i1 i2) ar\ + (symK-db Ind f => + mkBranches KsS KsD KRs KTys KTyRs ITy2 Pred (Brs f)), + std.append (Brs f) [i1,i2,ar] (IndArgs f i1 i2 ar), + coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). +implement-symK 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) _) KsS KsD KRs KTys KTyRs Pred RInd + (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- + !, + coq.mk-app RInd [Pred] RIndP, + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + @pi-decl ARN (ARTy i1 i2) ar\ + mkBranches KsS KsD KRs KTys KTyRs ITy2 Pred Brs, + std.append Brs [i1,i2,ar] (IndArgs i1 i2 ar), + coq.mk-app RIndP (IndArgs i1 i2 ar) (R i1 i2 ar). +implement-symK N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KRs KTys KTyRs Pred RInd + (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, + @pi-decl AN1 ATy1 a1\ %A1 : Type + @pi-decl AN2 ATy2 a2\ %A2 : Type + @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param00.Rel A1 A2 + coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), + + (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, + coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, + + coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), + coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, + + std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), + std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), + std.map KRs (x\ r\ sigma TMP\ coq.mk-app x [a1,a2, (RelAR a1 a2 ar)] TMP, r = TMP) (NewKRs a1 a2 ar), + + std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), + std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), + + (SymFun a1 a2 ar) = {{ fun (a1 : lp:{{a1}}) (a2 : lp:{{a2}}) (ar : (lp:{{ar}} a1 a2))=> @eq_refl (lp:{{ar}} a1 a2) ar }}, + symK-db a2 (SymFun a1 a2 ar) ==> + implement-symK M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKRs a1 a2 ar) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). + +func main inductive, string -> list prop. +main GR Prefix Clauses :- std.do! [ + + coq.env.indt GR _ TyParamNo _ _ KNs KTys, + Ind = (global (indt GR)), + std.assert! (param Ind Ind TR) "derive.sym: use derive.param2 before", + coq.typecheck TR TRTy _, + std.assert! (sym-db Ind SymInd) "derive.sym: use derive.sym before", + mk-mR-type-symK TyParamNo TRTy TR SymInd SymKTy, + std.assert-ok! (coq.elaborate-skeleton SymKTy _ SymKTyE) "derive.symK generates illtyped type", + TR = global (indt GRR), + coq.gref->id (indt GRR) Rname, + RInductionName is Rname ^ "_rect", + coq.locate RInductionName RInd, + coq.prod->fun SymKTyE Pred, + coq.env.indt GRR _ _ _ _ KRNs KTyRs, + std.map KNs (x\ r\ r = (global (indc x))) Ks, + std.map KRNs (x\ r\ r = (global (indc x))) KRs, + implement-symK TyParamNo TyParamNo SymKTyE Ks Ks KRs KTys KTyRs Pred (global RInd) R, + std.assert-ok! (coq.elaborate-skeleton R SymKTyE Re) "derive.symK generates illtyped term", + Name is Prefix ^ "symK", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName Re SymKTyE _ C, + I = global (indt GR), + Clauses = [symK-done GR, symK-db I (global (const C))], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.symK.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/std/algo/elpi/utils.elpi b/std/algo/elpi/utils.elpi index 1b3de2ff..1954d619 100644 --- a/std/algo/elpi/utils.elpi +++ b/std/algo/elpi/utils.elpi @@ -131,4 +131,52 @@ type-of-args (prod _ ATy1 a1\ prod _ ATy2 a2\ prod _ _ ar\ (Bo a1 a2 ar)) N [ATy pi a1 a2 ar\ type-of-args (Bo a1 a2 ar) M SR DR. + % whd beta-iota-delta-zeta, main code +pred whd-fuel i:term, i:stack, i:int, o:term, o:stack. +whd-fuel T S 0 T S. +whd-fuel (app [Hd|Args]) C N X XC :- !, whd-fuel Hd {std.append Args C} N X XC. +whd-fuel (fun _ _ _ as X) [] _ X [] :- !. +whd-fuel (fun N T F) [B|C] M X XC :- !, + (pi x\ def x N T B => cache x BN_ => whd-fuel (F x) C M (F1 x) (C1 x)), X = F1 B, XC = C1 B. +whd-fuel (let N T B F) C M X XC :- !, + (pi x\ def x N T B => cache x BN_ => whd-fuel (F x) C M (F1 x) (C1 x)), X = F1 B, XC = C1 B. +whd-fuel (global (const GR)) C M X XC :- + O is M - 1, unfold GR none C D DC, !, whd-fuel D DC O X XC. +whd-fuel (pglobal (const GR) I) C M X XC :- + O is M - 1, + unfold GR (some I) C D DC, !, whd-fuel D DC O X XC. +whd-fuel (primitive (proj _ N)) [A|C] M X XC :- whd-indc A _ KA, !, + whd-fuel {proj-red KA N C} M X XC. +whd-fuel (global (const GR) as HD) C M X XC :- coq.env.primitive? GR, !, + unwind HD C Orig, + coq.reduction.lazy.whd_all Orig R, + if (same_term Orig R) (X = HD, XC = C) (whd-fuel R [] M X XC). +whd-fuel (match A _ L) C M X XC :- whd-indc A GR KA, !, + whd-fuel {match-red GR KA L C} M X XC. +whd-fuel (fix _ N _ F as Fix) C M X XC :- nth-stack N C LA A RA, whd-indc A GR KA, !, + whd-fuel {fix-red F Fix LA GR KA RA} M X XC. +whd-fuel N C M X XC :- name N, def N _ _ V, !, cache-whd N VN V, whd-fuel VN C M X XC. +whd-fuel X C _ X C. + +pred iota-step i:term, i:stack, o:term, o:stack. +iota-step (match A _ L) C X XC :- whd-indc A GR KA, !, + match-red GR KA L C X XC. + +pred invert-eqs i:list term, o:list term. +invert-eqs Eqs IEqs :- + std.map Eqs (x\r\ sigma Skel TMP Err\ Skel = {{ @eq_sym _ _ _ lp:x}}, + coq.elaborate-skeleton Skel _ TMP ok, + r = TMP + ) IEqs. + +% expects list of equations +pred rewrite-with i:list term, i:list term, i:term, o:term. +rewrite-with [] [] End End. +rewrite-with [Eq|Eqs] [Pat|Pats] End R :- + (pi rest\ + (T rest) = {{ @eq_ind _ _ lp:Pat lp:rest _ lp:Eq }}), + rewrite-with Eqs Pats End RestSkel, + coq.elaborate-skeleton RestSkel _ Rest ok, + R = (T Rest). + } \ No newline at end of file diff --git a/std/algo/tests/test_Rel40.v b/std/algo/tests/test_Rel40.v new file mode 100644 index 00000000..95ba7cda --- /dev/null +++ b/std/algo/tests/test_Rel40.v @@ -0,0 +1,36 @@ +From Trocq Require Import map4 umap Rel40. +From Trocq Require Import coverage. +Unset Uniform Inductive Parameters. + +Elpi derive False. +Check False_rel40 : Param40.Rel False False. + +Elpi derive Unit. +Check Unit_rel40 : Param40.Rel Unit Unit. + +Elpi derive Bool. +Check Bool_rel40 : Param40.Rel Bool Bool. + +Elpi derive Wrap. +Check Wrap_rel40 : Param40.Rel Wrap Wrap. + +Elpi derive WrapMore. +Check WrapMore_rel40 : Param40.Rel WrapMore WrapMore. + +Elpi derive Nat. +Check Nat_rel40 : Param40.Rel Nat Nat. + +Elpi derive Box. +Check Box_rel40 : forall A1 A2 AR UR, Param40.Rel (Box A1) (Box A2). + +Elpi derive Option. +Check Option_rel40 : forall A1 A2 AR UR, Param40.Rel (Option A1) (Option A2). + +Elpi derive Prod. +Check Prod_rel40 : forall A1 A2 AR UR B1 B2 BR BUR, Param40.Rel (Prod A1 B1) (Prod A2 B2). + +Elpi derive ThreeTypes. +Check ThreeTypes_rel40 : forall A1 A2 AR UR B1 B2 BR BUR C1 C2 CR CUR, Param40.Rel (ThreeTypes A1 B1 C1) (ThreeTypes A2 B2 C2). + +Elpi derive List. +Check List_rel40 : forall A1 A2 AR UR, Param40.Rel (List A1) (List A2). diff --git a/std/algo/tests/test_sym.v b/std/algo/tests/test_sym.v new file mode 100644 index 00000000..7e0bc642 --- /dev/null +++ b/std/algo/tests/test_sym.v @@ -0,0 +1,30 @@ +From elpi Require Import elpi. +From elpi.apps Require Import derive.param2. +From Trocq Require Import coverage sym. + +Elpi derive.param2 False. +Elpi derive.sym False. + +Elpi derive.param2 Unit. +Elpi derive.sym Unit. + +Elpi derive.param2 Bool. +Elpi derive.sym Bool. + +Elpi derive.param2 Wrap. +Elpi derive.sym Wrap. + +Elpi derive.param2 WrapMore. +Elpi derive.sym WrapMore. + +Elpi derive.param2 Nat. +Elpi derive.sym Nat. + +Elpi derive.param2 Option. +Elpi derive.sym Option. + +Elpi derive.param2 Prod. +Elpi derive.sym Prod. + +Elpi derive.param2 List. +Elpi derive.sym List. \ No newline at end of file diff --git a/std/algo/tests/test_symK.v b/std/algo/tests/test_symK.v new file mode 100644 index 00000000..e3b7f5b1 --- /dev/null +++ b/std/algo/tests/test_symK.v @@ -0,0 +1,39 @@ +From elpi Require Import elpi. +From elpi.apps Require Import derive.param2. +From Trocq Require Import coverage sym symK. + +Elpi derive.param2 False. +Elpi derive.sym False. +Elpi derive.symK False. + +Elpi derive.param2 Unit. +Elpi derive.sym Unit. +Elpi derive.symK Unit. + +Elpi derive.param2 Bool. +Elpi derive.sym Bool. +Elpi derive.symK Bool. + +Elpi derive.param2 Wrap. +Elpi derive.sym Wrap. +Elpi derive.symK Wrap. + +Elpi derive.param2 WrapMore. +Elpi derive.sym WrapMore. +Elpi derive.symK WrapMore. + +Elpi derive.param2 Nat. +Elpi derive.sym Nat. +Elpi derive.symK Nat. + +Elpi derive.param2 Option. +Elpi derive.sym Option. +Elpi derive.symK Option. + +Elpi derive.param2 Prod. +Elpi derive.sym Prod. +Elpi derive.symK Prod. + +Elpi derive.param2 List. +Elpi derive.sym List. +Elpi derive.symK List. diff --git a/std/algo/theories/Rel40.v b/std/algo/theories/Rel40.v new file mode 100644 index 00000000..1485134d --- /dev/null +++ b/std/algo/theories/Rel40.v @@ -0,0 +1,64 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From Trocq Extra Dependency "algo/elpi/rel40.elpi" as Rel40. +From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. +From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. +From Trocq Require Import map4 umap. + + +Unset Uniform Inductive Parameters. + +(* todo: this function could be used in umap derivation *) +Definition Build40 (A B : Type) (R : A -> B -> Type) (UR : IsUMap R) : Param40.Rel A B := +(@Param40.BuildRel _ _ R UR (@Map0.BuildHas _ _ (@sym_rel A B R))). + +Elpi Db derive.rel40.db lp:{{ + % [rel40-db T D] links a type T to its corresponding Rel40. + pred rel40-db i:term, o:term. + + % [rel40-done T] mean T was already derived + pred rel40-done o:inductive. +}}. + +Elpi Command derive.Rel40. +Elpi Accumulate File derive_hook. +(* Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db Header derive.mymap.db. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate Db Header derive.mR.db. +Elpi Accumulate Db derive.mR.db. +Elpi Accumulate Db Header derive.Rm.db. +Elpi Accumulate Db derive.Rm.db. +Elpi Accumulate Db Header derive.mRRmK.db. +Elpi Accumulate Db derive.mRRmK.db. *) +Elpi Accumulate Db Header derive.umap.db. +Elpi Accumulate Db derive.umap.db. +Elpi Accumulate File common. +Elpi Accumulate File algo_utils. + +Elpi Accumulate Db derive.rel40.db. +Elpi Accumulate File Rel40. +Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), + coq.gref->id (indt GR) Tname, + Prefix is Tname ^ "_", + derive.rel40.main GR Prefix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.rel40 ". +}}. + + +Elpi Accumulate derive Db derive.rel40.db. +Elpi Accumulate derive File common. +Elpi Accumulate derive File algo_utils. +Elpi Accumulate derive File Rel40. + +Elpi Accumulate derive lp:{{ + +dep1 "rel40" "umap". +derivation (indt T) Prefix ff (derive "rel40" (derive.rel40.main T Prefix) (rel-done T)). + +}}. + diff --git a/std/algo/theories/sym.v b/std/algo/theories/sym.v new file mode 100644 index 00000000..fcb1e2fe --- /dev/null +++ b/std/algo/theories/sym.v @@ -0,0 +1,60 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. +From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. +From Trocq Extra Dependency "algo/elpi/utils.elpi" as utils. +From Trocq Extra Dependency "algo/elpi/sym.elpi" as sym. + +From elpi.apps Require Import derive.legacy derive.param2. + +From Trocq Require Export Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi Db derive.sym.db lp:{{ + + % [sym I S] links I inductive type, + % with the function showing symmetry + pred sym-db i:term, o:term. + + % [sym-done T K] means T K was already derived + pred sym-done o:inductive. +}}. + +Elpi Command derive.sym. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate File common. +Elpi Accumulate File utils. +Elpi Accumulate Db Header derive.sym.db. +Elpi Accumulate Db derive.sym.db. +Elpi Accumulate File sym. +Elpi Accumulate lp:{{ + + main [str I] :- !, + coq.locate I (indt GR), + % Ind is (indt GR) + coq.gref->id (indt GR) Tname, + Suffix is Tname ^ "_", + derive.sym.main GR Suffix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.sym ". +}}. + +(* hook into derive *) + + + +Elpi Accumulate derive Db Header derive.sym.db. +Elpi Accumulate derive Db derive.sym.db. +Elpi Accumulate derive File common. +Elpi Accumulate derive File utils. +Elpi Accumulate derive File sym. + +Elpi Accumulate derive lp:{{ + +dep1 "sym" "param2". +derivation (indt T) Prefix ff (derive "sym" (derive.sym.main T Prefix) (sym-done T)). + +}}. diff --git a/std/algo/theories/symK.v b/std/algo/theories/symK.v new file mode 100644 index 00000000..ea7e47a8 --- /dev/null +++ b/std/algo/theories/symK.v @@ -0,0 +1,65 @@ + +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. +From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. +From Trocq Extra Dependency "algo/elpi/utils.elpi" as utils. +From Trocq Extra Dependency "algo/elpi/symK.elpi" as symK. +From Trocq Require Import sym. +(* Extra Dependency "algo/elpi/sym.elpi" as sym. *) + +From elpi.apps Require Import derive.legacy derive.param2. + +From Trocq Require Export Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi Db derive.symK.db lp:{{ + + % [symK I S] links I inductive type, + % with the function showing symmetry is "involutive" + pred symK-db i:term, o:term. + + % [symK-done T K] means T K was already derived + pred symK-done o:inductive. +}}. + +Elpi Command derive.symK. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db Header derive.sym.db. +Elpi Accumulate Db derive.sym.db. +Elpi Accumulate File common. +Elpi Accumulate File utils. +Elpi Accumulate Db Header derive.symK.db. +Elpi Accumulate Db derive.symK.db. +Elpi Accumulate File symK. +Elpi Accumulate lp:{{ + + main [str I] :- !, + coq.locate I (indt GR), + % Ind is (indt GR) + coq.gref->id (indt GR) Tname, + Suffix is Tname ^ "_", + derive.symK.main GR Suffix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.symK ". +}}. + +(* hook into derive *) +Elpi Accumulate derive Db Header derive.symK.db. +Elpi Accumulate derive Db derive.symK.db. +Elpi Accumulate Db Header derive.sym.db. +Elpi Accumulate Db derive.sym.db. +Elpi Accumulate derive File common. +Elpi Accumulate derive File utils. +Elpi Accumulate derive File symK. + +Elpi Accumulate derive lp:{{ + +dep1 "symK" "param2". +dep1 "symK" "sym". +derivation (indt T) Prefix ff (derive "symK" (derive.symK.main T Prefix) (symK-done T)). + +}}. From fc9a4524b2042895558ac78f5924cf200dd6a153 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Thu, 22 Jan 2026 17:29:26 +0100 Subject: [PATCH 14/42] detailed example derivation for indexed inductives + detailed assembling symK to get paramnn.Rel s generating RsymK : forall i1 i2, [| I |]op i2 i1 <->> [| I |] i1 i2 --- std/_CoqProject | 5 +- std/algo/detailed/Detailed_Rsym.v | 112 +++++++++++++++++ std/algo/detailed/Detailed_rel44.v | 183 ++++++++++++++++++++++++++++ std/algo/detailed/Detailed_vector.v | 150 +++++++++++++++++++++++ std/algo/elpi/RsymK.elpi | 131 ++++++++++++++++++++ std/algo/elpi/common_algo.elpi | 39 +++++- std/algo/elpi/rel40.elpi | 4 +- std/algo/elpi/umap.elpi | 4 +- std/algo/elpi/utils.elpi | 6 +- std/algo/tests/test_RsymK.v | 59 +++++++++ std/algo/tests/test_umap.v | 1 + std/algo/theories/RsymK.v | 71 +++++++++++ 12 files changed, 751 insertions(+), 14 deletions(-) create mode 100644 std/algo/detailed/Detailed_Rsym.v create mode 100644 std/algo/detailed/Detailed_rel44.v create mode 100644 std/algo/detailed/Detailed_vector.v create mode 100644 std/algo/elpi/RsymK.elpi create mode 100644 std/algo/tests/test_RsymK.v create mode 100644 std/algo/theories/RsymK.v diff --git a/std/_CoqProject b/std/_CoqProject index 178af6d9..1768b329 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -34,6 +34,8 @@ algo/theories/sym.v algo/tests/test_sym.v algo/theories/symK.v algo/tests/test_symK.v +algo/theories/RsymK.v +algo/tests/test_RsymK.v algo/theories/mymap.v algo/tests/test_mymap.v algo/theories/injection_lemmas.v @@ -51,4 +53,5 @@ algo/tests/test_map4.v algo/theories/umap.v algo/tests/test_umap.v algo/theories/Rel40.v -algo/tests/test_Rel40.v \ No newline at end of file +algo/tests/test_Rel40.v +algo/theories/Rel44.v \ No newline at end of file diff --git a/std/algo/detailed/Detailed_Rsym.v b/std/algo/detailed/Detailed_Rsym.v new file mode 100644 index 00000000..b73ab708 --- /dev/null +++ b/std/algo/detailed/Detailed_Rsym.v @@ -0,0 +1,112 @@ +From Trocq Require Import symK. +Import HoTTNotations. +From Trocq Require Import coverage. +Unset Uniform Inductive Parameters. + +Require Import Hierarchy. +From mathcomp Require Import ssreflect. +Check existT. +Elpi derive False. +Definition FalseR_sym : forall f1 f2, sym_rel False_R f1 f2 <->> False_R f1 f2. +Proof. + intros f1 f2. + have@ f := False_sym f2 f1. + have@ g := False_sym f1 f2. + have@ fgK := False_symK f2 f1. + exact: (existT _ f (existT _ g fgK)). +Defined. +Print FalseR_sym. + +Elpi derive Unit. +Definition UnitR_sym : forall u1 u2, sym_rel Unit_R u1 u2 <->> Unit_R u1 u2. +Proof. + intros u1 u2. + refine (Unit_sym u2 u1; _). + refine (Unit_sym u1 u2; _). + refine (Unit_symK u2 u1). +Defined. + +Elpi derive Bool. +Definition BoolR_sym : forall u1 u2, sym_rel Bool_R u1 u2 <->> Bool_R u1 u2. +Proof. + intros u1 u2. + refine (Bool_sym u2 u1; _). + refine (Bool_sym u1 u2; _). + refine (Bool_symK u2 u1). +Defined. + +Elpi derive Wrap. +Definition WrapR_sym : forall u1 u2, sym_rel Wrap_R u1 u2 <->> Wrap_R u1 u2. +Proof. + intros u1 u2. + refine (Wrap_sym u2 u1; _). + refine (Wrap_sym u1 u2; _). + refine (Wrap_symK u2 u1). +Defined. + +Elpi derive WrapMore. +Definition WrapMoreR_sym : forall u1 u2, sym_rel WrapMore_R u1 u2 <->> WrapMore_R u1 u2. +Proof. + intros u1 u2. + refine (WrapMore_sym u2 u1; _). + refine (WrapMore_sym u1 u2; _). + refine (WrapMore_symK u2 u1). +Defined. + +Elpi derive Nat. +Definition NatR_sym : forall u1 u2, sym_rel Nat_R u1 u2 <->> Nat_R u1 u2. +Proof. + intros u1 u2. + refine (Nat_sym u2 u1; _). + refine (Nat_sym u1 u2; _). + refine (Nat_symK u2 u1). +Defined. + +Elpi derive Box. +Definition BoxR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, Box_R B A (sym_rel AR) u2 u1 <->> Box_R A B AR u1 u2. +Proof. + intros A B AR u1 u2. + refine ((Box_sym B A (sym_rel AR) u2 u1); _). + refine (Box_sym A B AR u1 u2; _). + refine (Box_symK B A (sym_rel AR) u2 u1). +Defined. + +Elpi derive Option. +Definition OptionR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, Option_R B A (sym_rel AR) u2 u1 <->> Option_R A B AR u1 u2. +Proof. + intros A B AR u1 u2. + refine ((Option_sym B A (sym_rel AR) u2 u1); _). + refine (Option_sym A B AR u1 u2; _). + refine (Option_symK B A (sym_rel AR) u2 u1). +Defined. + +Elpi derive Prod. +Definition ProdR_sym : forall (A B : Type) (AR : A -> B -> Type) (A2 B2 : Type) (AR2 : A2 -> B2 -> Type), + forall u1 u2, Prod_R B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1 <->> Prod_R A B AR A2 B2 AR2 u1 u2. +Proof. + intros A B AR A2 B2 AR2 u1 u2. + refine ((Prod_sym B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1); _). + refine (Prod_sym A B AR A2 B2 AR2 u1 u2; _). + refine (Prod_symK B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1). +Defined. + +Elpi derive ThreeTypes. +Definition ThreeTypesR_sym : forall (A B : Type) (AR : A -> B -> Type) (A2 B2 : Type) (AR2 : A2 -> B2 -> Type) + (A3 B3 : Type) (AR3 : A3 -> B3 -> Type), + forall u1 u2, ThreeTypes_R B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1 + <->> ThreeTypes_R A B AR A2 B2 AR2 A3 B3 AR3 u1 u2. +Proof. + intros A B AR A2 B2 AR2 A3 B3 AR3 u1 u2. + refine ((ThreeTypes_sym B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1); _). + refine (ThreeTypes_sym A B AR A2 B2 AR2 A3 B3 AR3 u1 u2; _). + refine (ThreeTypes_symK B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1). +Defined. + +Elpi derive List. +Definition ListR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, List_R B A (sym_rel AR) u2 u1 <->> List_R A B AR u1 u2. +Proof. + intros A B AR u1 u2. + refine ((List_sym B A (sym_rel AR) u2 u1); _). + refine (List_sym A B AR u1 u2; _). + refine (List_symK B A (sym_rel AR) u2 u1). +Defined. diff --git a/std/algo/detailed/Detailed_rel44.v b/std/algo/detailed/Detailed_rel44.v new file mode 100644 index 00000000..35c24a74 --- /dev/null +++ b/std/algo/detailed/Detailed_rel44.v @@ -0,0 +1,183 @@ + +From Trocq Require Import map4 umap Rel40 symK. +Import HoTTNotations. +From Trocq Require Import coverage. +Unset Uniform Inductive Parameters. + +Require Import Stdlib Hierarchy Param_lemmas. +Elpi derive False. +Check False_rel40 : Param40.Rel False False. + +Definition FalseR_sym : forall f1 f2, sym_rel False_R f1 f2 <->> False_R f1 f2. +Proof. + intros f1 f2. + refine (False_sym f2 f1; _). + refine (False_sym f1 f2; _). + refine (False_symK f2 f1). +Defined. + +Definition Param44_False : Param44.Rel False False := + MkUParam False_umap (eq_Map4 FalseR_sym False_umap). + +Elpi derive Unit. +(* Definition UnitR_sym : forall u1 u2, sym_rel Unit_R u1 u2 <->> Unit_R u1 u2. *) +Definition UnitR_sym : forall u1 u2, Unit_R u2 u1 <->> Unit_R u1 u2. +Proof. + intros u1 u2. + refine (Unit_sym u2 u1; _). + refine (Unit_sym u1 u2; _). + refine (Unit_symK u2 u1). +Defined. + +Definition Param00_Unit : Param00.Rel Unit Unit := + Param00.BuildRel _ _ Unit_R Unit_umap (eq_Map0 UnitR_sym Unit_umap). + +Definition Param11_Unit : Param11.Rel Unit Unit := + Param11.BuildRel _ _ Unit_R Unit_umap (eq_Map1 UnitR_sym Unit_umap). + +Definition Param2a2a_Unit : Param2a2a.Rel Unit Unit := + Param2a2a.BuildRel _ _ Unit_R Unit_umap (eq_Map2a UnitR_sym Unit_umap). + +Definition Param2b2b_Unit : Param2b2b.Rel Unit Unit := + Param2b2b.BuildRel _ _ Unit_R Unit_umap (eq_Map2b UnitR_sym Unit_umap). + +Definition Param33_Unit : Param33.Rel Unit Unit := + Param33.BuildRel _ _ Unit_R Unit_umap (eq_Map3 UnitR_sym Unit_umap). + +Definition Param44_Unit : Param44.Rel Unit Unit := + MkUParam Unit_umap (eq_Map4 UnitR_sym Unit_umap). + +Elpi derive Bool. +Definition BoolR_sym : forall u1 u2, sym_rel Bool_R u1 u2 <->> Bool_R u1 u2. +Proof. + intros u1 u2. + refine (Bool_sym u2 u1; _). + refine (Bool_sym u1 u2; _). + refine (Bool_symK u2 u1). +Defined. + +Definition Param44_Bool : Param44.Rel Bool Bool := + MkUParam Bool_umap (eq_Map4 BoolR_sym Bool_umap). + +Elpi derive Wrap. +Definition WrapR_sym : forall u1 u2, sym_rel Wrap_R u1 u2 <->> Wrap_R u1 u2. +Proof. + intros u1 u2. + refine (Wrap_sym u2 u1; _). + refine (Wrap_sym u1 u2; _). + refine (Wrap_symK u2 u1). +Defined. + +Definition Param44_Wrap : Param44.Rel Wrap Wrap := + MkUParam Wrap_umap (eq_Map4 WrapR_sym Wrap_umap). + +Elpi derive WrapMore. +Definition WrapMoreR_sym : forall u1 u2, sym_rel WrapMore_R u1 u2 <->> WrapMore_R u1 u2. +Proof. + intros u1 u2. + refine (WrapMore_sym u2 u1; _). + refine (WrapMore_sym u1 u2; _). + refine (WrapMore_symK u2 u1). +Defined. + +Definition Param44_WrapMore : Param44.Rel WrapMore WrapMore := + MkUParam WrapMore_umap (eq_Map4 WrapMoreR_sym WrapMore_umap). + +Elpi derive Nat. +Definition NatR_sym : forall u1 u2, sym_rel Nat_R u1 u2 <->> Nat_R u1 u2. +Proof. + intros u1 u2. + refine (Nat_sym u2 u1; _). + refine (Nat_sym u1 u2; _). + refine (Nat_symK u2 u1). +Defined. + +Definition Param44_Nat : Param44.Rel Nat Nat := + MkUParam Nat_umap (eq_Map4 NatR_sym Nat_umap). + +Elpi derive Box. +Definition BoxR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, Box_R B A (sym_rel AR) u2 u1 <->> Box_R A B AR u1 u2. +Proof. + intros A B AR u1 u2. + refine ((Box_sym B A (sym_rel AR) u2 u1); _). + refine (Box_sym A B AR u1 u2; _). + refine (Box_symK B A (sym_rel AR) u2 u1). +Defined. + +Definition Param00_Box : forall (A B : Type) (AR : Param00.Rel A B), Param00.Rel (Box A) (Box B). + Fail refine( fun A B AR=> Param00.BuildRel _ _ (Box_R A B AR) _ (eq_Map0 (BoxR_sym A B AR) _)). +Abort. + +Definition Param44_Box : forall (A B : Type) (AR : Param44.Rel A B), Param44.Rel (Box A) (Box B). +Proof. + refine (fun A B AR => MkUParam (Box_umap A B AR (Param44.covariant _ _ _)) _). + refine (eq_Map4 (BoxR_sym B A (sym_rel AR)) (Box_umap _ _ _ (Param44.contravariant _ _ _))). +Defined. + +Elpi derive Option. +Definition OptionR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, Option_R B A (sym_rel AR) u2 u1 <->> Option_R A B AR u1 u2. +Proof. + intros A B AR u1 u2. + refine ((Option_sym B A (sym_rel AR) u2 u1); _). + refine (Option_sym A B AR u1 u2; _). + refine (Option_symK B A (sym_rel AR) u2 u1). +Defined. + +Definition Param44_Option : forall (A B : Type) (AR : Param44.Rel A B), Param44.Rel (Option A) (Option B). +Proof. + refine (fun A B AR => MkUParam (Option_umap A B AR (Param44.covariant _ _ _)) _). + refine (eq_Map4 (OptionR_sym B A (sym_rel AR)) (Option_umap _ _ _ (Param44.contravariant _ _ _))). +Defined. + +Elpi derive Prod. +Definition ProdR_sym : forall (A B : Type) (AR : A -> B -> Type) (A2 B2 : Type) (AR2 : A2 -> B2 -> Type), + forall u1 u2, Prod_R B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1 <->> Prod_R A B AR A2 B2 AR2 u1 u2. +Proof. + intros A B AR A2 B2 AR2 u1 u2. + refine ((Prod_sym B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1); _). + refine (Prod_sym A B AR A2 B2 AR2 u1 u2; _). + refine (Prod_symK B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1). +Defined. + +Definition Param44_Prod : forall (A B : Type) (AR : Param44.Rel A B) (A2 B2 : Type) (AR2 : Param44.Rel A2 B2), + Param44.Rel (Prod A A2) (Prod B B2). +Proof. + refine (fun A B AR A2 B2 AR2 => MkUParam (Prod_umap A B AR (Param44.covariant _ _ _) A2 B2 AR2 (Param44.covariant _ _ _)) _). + refine (eq_Map4 (ProdR_sym B A (sym_rel AR) B2 A2 (sym_rel AR2)) (Prod_umap _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _))). +Defined. + +Elpi derive ThreeTypes. +Definition ThreeTypesR_sym : forall (A B : Type) (AR : A -> B -> Type) (A2 B2 : Type) (AR2 : A2 -> B2 -> Type) + (A3 B3 : Type) (AR3 : A3 -> B3 -> Type), + forall u1 u2, ThreeTypes_R B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1 + <->> ThreeTypes_R A B AR A2 B2 AR2 A3 B3 AR3 u1 u2. +Proof. + intros A B AR A2 B2 AR2 A3 B3 AR3 u1 u2. + refine ((ThreeTypes_sym B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1); _). + refine (ThreeTypes_sym A B AR A2 B2 AR2 A3 B3 AR3 u1 u2; _). + refine (ThreeTypes_symK B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1). +Defined. + +Definition Param44_ThreeTypes : forall (A B : Type) (AR : Param44.Rel A B) (A2 B2 : Type) (AR2 : Param44.Rel A2 B2) + (A3 B3 : Type) (AR3 : Param44.Rel A3 B3), + Param44.Rel (ThreeTypes A A2 A3) (ThreeTypes B B2 B3). +Proof. + refine (fun A B AR A2 B2 AR2 A3 B3 AR3 => + MkUParam (ThreeTypes_umap A B AR (Param44.covariant _ _ _) A2 B2 AR2 (Param44.covariant _ _ _) A3 B3 AR3 (Param44.covariant _ _ _)) _). + refine (eq_Map4 (ThreeTypesR_sym B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3)) (ThreeTypes_umap _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _))). +Defined. + +Elpi derive List. +Definition ListR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, List_R B A (sym_rel AR) u2 u1 <->> List_R A B AR u1 u2. +Proof. + intros A B AR u1 u2. + refine ((List_sym B A (sym_rel AR) u2 u1); _). + refine (List_sym A B AR u1 u2; _). + refine (List_symK B A (sym_rel AR) u2 u1). +Defined. + +Definition Param44_List : forall (A B : Type) (AR : Param44.Rel A B), Param44.Rel (List A) (List B). +Proof. + refine (fun A B AR => MkUParam (List_umap A B AR (Param44.covariant _ _ _)) _). + refine (eq_Map4 (ListR_sym B A (sym_rel AR)) (List_umap _ _ _ (Param44.contravariant _ _ _))). +Defined. diff --git a/std/algo/detailed/Detailed_vector.v b/std/algo/detailed/Detailed_vector.v new file mode 100644 index 00000000..2523edfd --- /dev/null +++ b/std/algo/detailed/Detailed_vector.v @@ -0,0 +1,150 @@ +From Trocq Require Import mymap mR. +From elpi.apps.derive Require Import derive derive.param2 derive.projK. +Require Import HoTTNotations. +Require Import Hierarchy. +From mathcomp Require Import ssreflect. + +Unset Uniform Inductive Parameters. +(* Unset Universe Polymorphism. *) +Unset Universe Minimization ToSet. + +Inductive vec (A : Type) : nat -> Type := +| Ov : vec A O +| Consv : A -> forall n, vec A n -> vec A (S n). + +Elpi derive nat. +Elpi derive.param2 vec. + +Fixpoint vec_map (A B : Type) (AR : Param10.Rel A B) (n1 n2 : nat) (nR : nat_R n1 n2) {struct nR} : + vec A n1 -> vec B n2. +Proof. +case: nR. +- move=> v; exact: (Ov B). +- move=> n1' n2' nR' v. + refine (Consv B _ _ _). + + move: v. + refine (fun v => match v in vec _ (S _) with Consv a n v0 => _ end). + by apply (map AR). + + refine (vec_map A B AR n1' n2' nR' _). + by refine ((match v in vec _ (S t) return ( vec A t) with Consv a n v0 => v0 end)). +Defined. + +Definition projConsv1 : + forall (A : Type), + forall n : nat, vec A (S n) -> A. +refine (fun A n v=> _ ). +by refine (match v in vec _ (S t) return A with +| Consv a n v0 => a end). +Defined. + +Definition projConsv2 : + forall (A : Type), + A -> forall n : nat, vec A (S n) -> vec A n. +refine (fun A a n v=> _ ). +by refine (match v in vec _ (S t) return vec _ t with +| Consv a n v0 => v0 end). +Defined. + +Definition vec_injections21 : +forall (A : Type) (_1 _2 : A) n (v1 v2 : vec A n) (e : Consv A _1 n v1 = Consv A _2 n v2), + projConsv1 A n (Consv A _1 n v1) = projConsv1 A n (Consv A _2 n v2). +Proof. +move=> A a1 a2 n v1 v2 eq. +exact: (f_equal _ eq). +Defined. + +Definition vec_injections22 : +forall (A : Type) (_1 _2 : A) n (v1 v2 : vec A n)(e : Consv A _1 n v1= Consv A _2 n v2), + projConsv2 A _1 n (Consv A _1 n v1) = projConsv2 A _1 n (Consv A _2 n v2). +Proof. +move=> A a1 a2 n v1 v2 eq. +exact: (f_equal _ eq). +Defined. + +Definition conv (A : Type) (x y : A) (p: x = y) + (P : forall x0 : A, x = x0 -> Prop) (P0 : P x eq_refl) := + match p as p0 in _ = t return (P t p0) + with eq_refl => P0 end. + +Definition vec_injK21 : + forall (A : Type) (_1 _2 : A) (p__1 : _1 = _2) n (_3 _4 : vec A n ) (p__2 : _3 = _4), +(fun (t : A) (p : _1 = t) => +vec_injections21 A _1 t n _3 _4 +(eq_trans (eq_f A (vec A (S n)) (fun R : A => Consv A R n _3) _1 t p) +(eq_trans (eq_f (vec A n) (vec A (S n)) (fun (R : vec A n) => Consv A t n R) _3 _4 +p__2) eq_refl)) = p) _2 p__1. +Proof. +move=> A a1 a2 p n v1 v2 p2. +apply (conv A a1 a2 p). +by apply (conv (vec A n) v1 v2 p2). +Defined. + +Definition vec_injK22 : + forall (A : Type) (_1 _2 : A) (p__1 : _1 = _2) n (_3 _4 : vec A n ) (p__2 : _3 = _4), +(fun (t : A) (p : _1 = t) => +vec_injections22 A _1 t n _3 _4 +(eq_trans (eq_f A (vec A (S n)) (fun R : A => Consv A R n _3) _1 t p) +(eq_trans (eq_f (vec A n) (vec A (S n)) (fun (R : vec A n) => Consv A t n R) _3 _4 +p__2) eq_refl)) = p__2) _2 p__1. +Proof. +move=> A a1 a2 p n v1 v2 p2. +apply (conv A a1 a2 p). +by apply (conv (vec A n) v1 v2 p2). +Defined. + +Fixpoint mRvec (A1 A2 : Type) (AR : Param2a0.Rel A1 A2) (n1 n2: nat) (nR : nat_R n1 n2) + {struct nR} : forall (v1 : vec A1 n1) (v2 : vec A2 n2), vec_map _ _ AR n1 n2 nR v1 = v2 -> vec_R A1 A2 AR n1 n2 nR v1 v2. +case: nR. +- refine (fun v1=> match v1 with Ov => _ end). + refine (fun v2=> match v2 with Ov => _ end). + move=> _; exact: Ov_R. +- move=> n1' n2' nR' v1. + move: mRvec=> /(_ A1 A2 AR _ _ nR')=> mRvec. + move: nR' mRvec. + refine (match v1 as vt in vec _ (S t) return +forall nR' : nat_R t n2', +(forall (v2 : vec A1 t) (v3 : vec A2 n2'), +vec_map A1 A2 AR t n2' nR' v2 = v3 -> vec_R A1 A2 AR t n2' nR' v2 v3) -> +forall v2 : vec A2 (S n2'), +vec_map A1 A2 AR (S t) (S n2') (S_R t n2' nR') vt = v2 -> +vec_R A1 A2 AR (S t) (S n2') (S_R t n2' nR') vt v2 +with +Consv a n v0 => _ end + ). + move=> nR' mRvec v2. + move: nR' mRvec. + refine (match v2 as vt in vec _ (S t) return + forall nR' : nat_R n t, +(forall (v3 : vec A1 n) (v4 : vec A2 t), +vec_map A1 A2 AR n t nR' v3 = v4 -> vec_R A1 A2 AR n t nR' v3 v4) -> +vec_map A1 A2 AR (S n) (S t) (S_R n t nR') (Consv A1 a n v0) = vt -> +vec_R A1 A2 AR (S n) (S t) (S_R n t nR') (Consv A1 a n v0) vt +with +Consv a n v0 => _ end + ). + move=> nR' mRvec eq. + apply (Consv_R _ _ _ _ _ (map_in_R AR _ _ (vec_injections21 A2 _ _ _ _ _ eq)) _ _ _). + by apply (mRvec v3 _ (vec_injections22 A2 _ _ _ _ _ eq)). +Defined. + +Fixpoint Rmvec (A1 A2 : Type) (AR : Param2b0.Rel A1 A2) (n1 n2: nat) (nR : nat_R n1 n2) + : forall (v1 : vec A1 n1) (v2 : vec A2 n2), vec_R A1 A2 AR n1 n2 nR v1 v2 -> vec_map _ _ AR n1 n2 nR v1 = v2. +move=> v1 v2 vR; case: vR. +- exact: eq_refl. +- move=> a1 a2 ar n1' n2' nR' v1' v2' vR' /=. + move: Rmvec=> /(_ A1 A2 AR _ _ nR')=> Rmvec. + have@ e1 := f_equal (fun a2'=> Consv A2 a2' n2' (vec_map A1 A2 AR n1' n2' nR' v1')) (R_in_map AR _ _ ar). + have@ e2 := f_equal (fun v => Consv A2 a2 n2' v) (Rmvec _ _ vR'). + exact: (e1 @ e2). +Defined. + +Fixpoint mRRmvec (A1 A2 : Type) (AR : Param40.Rel A1 A2) (n1 n2: nat) (nR : nat_R n1 n2) + : forall (v1 : vec A1 n1) (v2 : vec A2 n2) (vR: vec_R A1 A2 AR n1 n2 nR v1 v2), + mRvec A1 A2 AR n1 n2 nR v1 v2 (Rmvec A1 A2 AR n1 n2 nR v1 v2 vR) = vR. +move=> v1 v2 vR; case: vR. +- exact: eq_refl. +- move=> a1 a2 ar n1' n2' nR' v1' v2' vR' /=. + move: mRRmvec=> /(_ A1 A2 AR _ _ nR')=> mRRmvec. + rewrite vec_injK21 vec_injK22. rewrite (R_in_mapK AR). rewrite (mRRmvec v1' v2' vR'). + reflexivity. +Defined. \ No newline at end of file diff --git a/std/algo/elpi/RsymK.elpi b/std/algo/elpi/RsymK.elpi new file mode 100644 index 00000000..cf5297c9 --- /dev/null +++ b/std/algo/elpi/RsymK.elpi @@ -0,0 +1,131 @@ + +shorten derive.algo-utils.{type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with}. +shorten derive.common-algo.{mk-mR-type-rsymK, sym-tyargs}. + +namespace derive.rsymK { + +% delta delta iota +pred red-rsymK i:term, i:stack, o:term,o:stack. +red-rsymK X C R RS :- + whd-fuel X C 2 XX CC, + iota-step XX CC R RS. + +pred pierce-goal-rsymK i:int, i:int, i:int, i:term, i: list term, o: list term, o: term. +pierce-goal-rsymK _ N N Goal [] [] Goal. +pierce-goal-rsymK TyParamNo N InitArgs CurrentGoal [Eq|Eqs] [Pat|Pats] EndGoal:- !, + M is N + 1, + coq.safe-dest-app CurrentGoal EqGoal [EqGoalTy,GoalLHS,GoalRHS], + coq.safe-dest-app GoalLHS KR Args, + Done is (TyParamNo * 3) + N * 3, + std.split-at Done Args L [A1,A2, SymSym | R], + coq.typecheck SymSym Ty ok, + (pi t\ + coq.mk-app KR {std.append L {std.append [A1, A2, t] R}} (NewKR t), + coq.mk-app EqGoal [EqGoalTy,(NewKR t),GoalRHS] (NewEqGoal t)), + Pat = (fun `t` Ty t\ (NewEqGoal t)), + coq.typecheck Eq EqTy ok, + coq.safe-dest-app EqTy _ [_,LHS,_], + coq.mk-app Pat [LHS] NewGoal, + pierce-goal-rsymK TyParamNo M InitArgs NewGoal Eqs Pats EndGoal. + +% [|K|], remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, +pred process-args i:term, i:term, i:term, i:int,i:int, i:int, i:term, i:list term, i:term, i:term, o:term. +process-args KsS KsD KR 0 ArgNo TyArgsNo _ RevEqs Goal _ R:- + std.rev RevEqs Eqs, + invert-eqs Eqs IEqs, + coq.mk-app Goal [KsS,KsD,KR] SubstGoal, + whd SubstGoal [] HD [IRTy,SymSymIR,IR], + red-rsymK SymSymIR [] KRHD KRArgs, + coq.mk-app KRHD KRArgs RedLHS, + coq.mk-app HD [IRTy,RedLHS,IR] StartingGoal, + pierce-goal-rsymK TyArgsNo 0 ArgNo StartingGoal IEqs PatsSym _, + End = {{ @eq_refl lp:IRTy lp:IR }}, + rewrite-with IEqs PatsSym End R. + +process-args KsS KsD KR N O TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Eqs Goal ITyTy + (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- + M is N - 1, + @pi-decl AN1 A1Ty a1\ + @pi-decl AN2 A2Ty a2\ + @pi-decl ARN (ARTy a1 a2) ar\ + + coq.mk-app KsS [a1] (NewKsS a1), + coq.mk-app KsD [a2] (NewKsD a2), + coq.mk-app KR [a1,a2,ar] (NewKR a1 a2 ar), + + (param a2 a1 ar =!=> + whd A2Ty _ IndD _, + rsymK-db IndD SymKA2, + coq.mk-app SymKA2 [a1, a2, ar] (SymKEq a1 a2 ar), + std.append [(SymKEq a1 a2 ar)] Eqs (NewEqs a1 a2 ar), + process-args (NewKsS a1) (NewKsD a2) (NewKR a1 a2 ar) M O TyArgsNo (Bo a1 a2 ar) (NewEqs a1 a2 ar) Goal ITyTy (R a1 a2 ar)), + % if the type of the argument is an instance of the inductive type add an induction hypothesis + whd ITyTy _ Ind _, + if (Ind = IndD) + (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), + (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) + (RF = R). + +% invariant: all type arguments were already processed. +% Constructor R, Constructor dest Type, No of Arguments to process, +% constructorR Type, type of i2, something of type : i1 i2 iR => goal. +pred mkBranch i:term, i:term, i:term, i:int, i:int, i:term, i:term, i:term, o:term. +mkBranch KsS KsD KR N M KTyR ITyTy Goal Eq:- + whd ITyTy [] _ TyArgs, + process-args KsS KsD KR N M {std.length TyArgs} KTyR [] Goal ITyTy Eq. + +pred mkBranches i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term o:list term. +mkBranches [] [] [] [] [] _ _ []. +mkBranches [KsS|KsSs] [KsD| KsDs] [KR|KRs][KTy|KTys] [KTyR|KTyRs] ITyTy Goal [R|Rs] :- + coq.count-prods KTy ArgNo, + mkBranch KsS KsD KR ArgNo ArgNo KTyR ITyTy Goal R, + mkBranches KsSs KsDs KRs KTys KTyRs ITyTy Goal Rs. + +pred implement-rsymK i:int, i:term, i:term, i:term, i:list term, o:term. +implement-rsymK 0 (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ _) Sym SymK LRev (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ (R i1 i2)) :- + !, + std.rev LRev L, + sym-tyargs L LSym, + coq.mk-app Sym LSym FSym, + coq.mk-app Sym L GSym, + coq.mk-app SymK LSym SymKSym, + @pi-decl IN1 ITy1 i1\ + @pi-decl IN2 ITy2 i2\ + (F i1 i2) = {{ lp:FSym lp:i2 lp:i1 }}, + (G i1 i2) = {{ lp:GSym lp:i1 lp:i2 }}, + (FGK i1 i2) = {{ lp:SymKSym lp:i2 lp:i1 }}, + (R i1 i2) = {{ existT _ lp:{{ (F i1 i2) }} (existT _ lp:{{ (G i1 i2) }} lp:{{ (FGK i1 i2) }}) }}. +implement-rsymK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Sym SymK L + (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, + @pi-decl AN1 ATy1 a1\ %A1 : Type + @pi-decl AN2 ATy2 a2\ %A2 : Type + @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param00.Rel A1 A2 + sigma NewL\ + std.append [ar,a2,a1] L NewL, + implement-rsymK M (Bo a1 a2 ar) Sym SymK NewL (R a1 a2 ar). + +func main inductive, string -> list prop. +main GR Prefix Clauses :- std.do! [ + + coq.env.indt GR _ TyParamNo _ _ KNs KTys, + Ind = (global (indt GR)), + std.assert! (param Ind Ind TR) "derive.rsymK: use derive.param2 before", + coq.typecheck TR TRTy _, + mk-mR-type-rsymK TyParamNo TRTy TR {{ fun (A B : Type) => A <->> B }} SymKTy, + std.assert-ok! (coq.elaborate-skeleton SymKTy _ SymKTyE) "derive.rsymK generates illtyped type", + std.assert! (sym-db Ind SymInd) "derive.rsymK: use derive.sym before", + std.assert! (symK-db Ind SymKInd) "derive.rsymK: use derive.symK before", + implement-rsymK TyParamNo SymKTyE SymInd SymKInd [] R, + std.assert-ok! (coq.elaborate-skeleton R SymKTyE Re) "derive.rsymK generates illtyped term", + Name is Prefix ^ "rsymK", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName Re SymKTyE _ C, + I = global (indt GR), + Clauses = [rsymK-done GR, rsymK-db I (global (const C))], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.rsymK.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/std/algo/elpi/common_algo.elpi b/std/algo/elpi/common_algo.elpi index 3addc97b..1019e610 100644 --- a/std/algo/elpi/common_algo.elpi +++ b/std/algo/elpi/common_algo.elpi @@ -9,6 +9,8 @@ rel-mode 3 {{ Param30.Rel }}. % _ rel-mode 4 {{ Param40.Rel }}. % mRRmK rel-mode 5 {{ fun (A B : Type)=> A -> B -> Type }}. % sym rel-mode 6 {{ fun (A B : Type)=> A -> B -> Type }}. % symK +rel-mode 7 {{ fun (A B : Type)=> A -> B -> Type }}. % rsymK +rel-mode 8 {{ Param44.Rel }}. % pred swap i:term, i:term, i:bool, o:term, o:term. swap A B tt B A. @@ -31,12 +33,16 @@ mk-return ML MR Rel 2 ITyTy2 R :- mk-impl-return ML MR Rel tt ITyTy2 R. % mk-return ML MR Rel -pred symm_tyargs i: list term, i: list term, o: list term. -symm_tyargs [] L L. -symm_tyargs [A1, A2, AR | L2] Acc R :- +pred sym-tyargs-priv i: list term, i: list term, o: list term. +sym-tyargs-priv [] L L. +sym-tyargs-priv [A1, A2, AR | L2] Acc R :- coq.mk-app {{ @sym_rel }} [A1,A2,AR] RAS, std.append Acc [A2, A1, RAS ] NewAcc, - symm_tyargs L2 NewAcc R. + sym-tyargs-priv L2 NewAcc R. + +pred sym-tyargs i: list term, o: list term. +sym-tyargs L R :- + sym-tyargs-priv L [] R. % The number of Type parameters in T % Type of inductive T, @@ -77,17 +83,30 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 4 LRev MR-DB RM- mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 5 LRev _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- std.rev LRev L, - symm_tyargs L [] L2, + sym-tyargs L L2, @pi-decl IN1 ITyTy x\ @pi-decl IN2 ITyTy2 y\ coq.mk-app Rel {std.append L [x,y]} (RelTy1 x y), coq.mk-app Rel {std.append L2 [y,x]} (RelTy2 x y), R x y = {{ lp:{{RelTy1 x y}} -> lp:{{RelTy2 x y}} }}. +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) RSym _ Rel 7 LRev _ _ + (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- + std.rev LRev L, + sym-tyargs L L2, + @pi-decl IN1 ITyTy x\ + @pi-decl IN2 ITyTy2 y\ + coq.mk-app Rel {std.append L [x,y]} (RelTy1 x y), + coq.mk-app Rel {std.append L2 [y,x]} (RelTy2 x y), + RSkel x y = {{ lp:RSym lp:{{RelTy2 x y}} lp:{{RelTy1 x y}} }}, + whd1 (RSkel x y) (R x y). +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 8 _ _ _ + R :- + coq.mk-app { rel-mode 8 } [ITyTy, ITyTy2] R. % TODO: remove use of MR-DB, try just pass the MR and RM mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) SymC _ Rel 6 LRev _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ prod `IR` (RelTy x y) iR\ (R x y iR)) :- std.rev LRev L, - symm_tyargs L [] L2, + sym-tyargs L L2, @pi-decl IN1 ITyTy x\ @pi-decl IN2 ITyTy2 y\ coq.mk-app Rel {std.append L [x,y]} (RelTy x y), @@ -128,4 +147,12 @@ pred mk-mR-type-symK i:int, i:term, i:term, i:term, o:term. mk-mR-type-symK N T Rel Sym R :- mk-mR-type-priv N T Sym _ Rel 6 [] _ _ R. +pred mk-mR-type-rsymK i:int, i:term, i:term, i:term, o:term. +mk-mR-type-rsymK N T Rel RSym R :- + mk-mR-type-priv N T RSym _ Rel 7 [] _ _ R. + +pred mk-mR-type-rel44 i:int, i:term, i:term, o:term. +mk-mR-type-rel44 N T Rel R :- + mk-mR-type-priv N T _ _ Rel 8 [] _ _ R. + } \ No newline at end of file diff --git a/std/algo/elpi/rel40.elpi b/std/algo/elpi/rel40.elpi index 4ce2bfde..b683f9fc 100644 --- a/std/algo/elpi/rel40.elpi +++ b/std/algo/elpi/rel40.elpi @@ -1,5 +1,5 @@ shorten derive.common-algo. {rel-mode}. -shorten derive.algo-utils.{gen-names-umap}. +shorten derive.algo-utils.{gen-names-map}. namespace derive.rel40 { @@ -15,7 +15,7 @@ mk-rel40-type-priv 0 _ IndL IndR {{ @Param40.Rel lp:IndL lp:IndR }}. mk-rel40-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR (prod TN1 Ty t1\ prod TN2 Ty t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- M is N - 1, - gen-names-umap TN TN1 TN2 TRN URN, + gen-names-map TN TN1 TN2 TRN URN, @pi-decl TN1 Ty t1\ @pi-decl TN2 Ty t2\ (ARTy t1 t2) = {{ lp:t1 -> lp:t2 -> Type }}, diff --git a/std/algo/elpi/umap.elpi b/std/algo/elpi/umap.elpi index 8567552a..bb0c05ad 100644 --- a/std/algo/elpi/umap.elpi +++ b/std/algo/elpi/umap.elpi @@ -1,6 +1,6 @@ shorten derive.common-algo. {rel-mode}. -shorten derive.algo-utils.{gen-names-umap}. +shorten derive.algo-utils.{gen-names-map}. namespace derive.umap { % TyParamNo @@ -15,7 +15,7 @@ mk-umap-type-priv 0 _ IndL IndR Rel {{ @IsUMap lp:IndL lp:IndR lp:Rel}}. mk-umap-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR Rel (prod TN1 Ty t1\ prod TN2 Ty t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- M is N - 1, - gen-names-umap TN TN1 TN2 TRN URN, + gen-names-map TN TN1 TN2 TRN URN, @pi-decl TN1 Ty t1\ @pi-decl TN2 Ty t2\ (ARTy t1 t2) = {{ lp:t1 -> lp:t2 -> Type }}, diff --git a/std/algo/elpi/utils.elpi b/std/algo/elpi/utils.elpi index 1954d619..d7a5291b 100644 --- a/std/algo/elpi/utils.elpi +++ b/std/algo/elpi/utils.elpi @@ -4,12 +4,12 @@ func names12 name -> name, name. names12 N N1 N2 :- !, coq.name-suffix N 1 N1, coq.name-suffix N 2 N2. -pred gen-names-umap i:name, o:name, o:name, o:name, o:name. -gen-names-umap N N1 N2 NR NU :- +pred gen-names-map i:name, o:name, o:name, o:name, o:name. +gen-names-map N N1 N2 NR NU :- coq.name-suffix N 1 N1, coq.name-suffix N 2 N2, coq.name-suffix N "R" NR, - coq.name-suffix N "U" NU. + coq.name-suffix N "M" NU. pred name-prefix i: name, i:string, o:name. name-prefix N P R :- diff --git a/std/algo/tests/test_RsymK.v b/std/algo/tests/test_RsymK.v new file mode 100644 index 00000000..f9f0f78f --- /dev/null +++ b/std/algo/tests/test_RsymK.v @@ -0,0 +1,59 @@ + +From elpi.apps Require Import derive.param2. +From Trocq Require Import sym symK RsymK coverage. + +Elpi derive.param2 False. +Elpi derive.sym False. +Elpi derive.symK False. +Elpi derive.rsymK False. + +Elpi derive.param2 Unit. +Elpi derive.sym Unit. +Elpi derive.symK Unit. +Elpi derive.rsymK Unit. + +Elpi derive.param2 Bool. +Elpi derive.sym Bool. +Elpi derive.symK Bool. +Elpi derive.rsymK Bool. + +Elpi derive.param2 Wrap. +Elpi derive.sym Wrap. +Elpi derive.symK Wrap. +Elpi derive.rsymK Wrap. + +Elpi derive.param2 WrapMore. +Elpi derive.sym WrapMore. +Elpi derive.symK WrapMore. +Elpi derive.rsymK WrapMore. + +Elpi derive.param2 Nat. +Elpi derive.sym Nat. +Elpi derive.symK Nat. +Elpi derive.rsymK Nat. + +Elpi derive.param2 Box. +Elpi derive.sym Box. +Elpi derive.symK Box. +Elpi derive.rsymK Box. + +Elpi derive.param2 Option. +Elpi derive.sym Option. +Elpi derive.symK Option. +Elpi derive.rsymK Option. + +Elpi derive.param2 Prod. +Elpi derive.sym Prod. +Elpi derive.symK Prod. +Elpi derive.rsymK Prod. + + +Elpi derive.param2 ThreeTypes. +Elpi derive.sym ThreeTypes. +Elpi derive.symK ThreeTypes. +Elpi derive.rsymK ThreeTypes. + +Elpi derive.param2 List. +Elpi derive.sym List. +Elpi derive.symK List. +Elpi derive.rsymK List. \ No newline at end of file diff --git a/std/algo/tests/test_umap.v b/std/algo/tests/test_umap.v index fe5ce759..9ff89c8a 100644 --- a/std/algo/tests/test_umap.v +++ b/std/algo/tests/test_umap.v @@ -22,6 +22,7 @@ Check Nat_umap : IsUMap Nat_R. Elpi derive Box. Check Box_umap : forall A1 A2 AR UR, IsUMap (Box_R A1 A2 AR). +Print Box_umap. Elpi derive Option. Check Option_umap : forall A1 A2 AR UR, IsUMap (Option_R A1 A2 AR). diff --git a/std/algo/theories/RsymK.v b/std/algo/theories/RsymK.v new file mode 100644 index 00000000..81400124 --- /dev/null +++ b/std/algo/theories/RsymK.v @@ -0,0 +1,71 @@ + +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. +From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) +From Trocq Extra Dependency "algo/elpi/utils.elpi" as utils. +From Trocq Extra Dependency "algo/elpi/RsymK.elpi" as rsymK. +From Trocq Require Import sym symK. +Import HoTTNotations. +(* Extra Dependency "algo/elpi/sym.elpi" as sym. *) + +From elpi.apps Require Import derive.legacy derive.param2. + +From Trocq Require Export Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi Db derive.rsymK.db lp:{{ + + % [rsymK I S] links I inductive type, + % with the function showing i1 i2, [| I |]^ i2 i1 <->> [| I |] i1 i2 + pred rsymK-db i:term, o:term. + + % [rsymK-done T K] means T K was already derived + pred rsymK-done o:inductive. +}}. + +Elpi Command derive.rsymK. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db Header derive.sym.db. +Elpi Accumulate Db derive.sym.db. +Elpi Accumulate Db Header derive.symK.db. +Elpi Accumulate Db derive.symK.db. +Elpi Accumulate File common. +Elpi Accumulate File utils. +Elpi Accumulate Db Header derive.rsymK.db. +Elpi Accumulate Db derive.rsymK.db. +Elpi Accumulate File rsymK. +Elpi Accumulate lp:{{ + + main [str I] :- !, + coq.locate I (indt GR), + % Ind is (indt GR) + coq.gref->id (indt GR) Tname, + Suffix is Tname ^ "_", + derive.rsymK.main GR Suffix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.rsymK ". +}}. + +(* hook into derive *) +Elpi Accumulate derive Db Header derive.rsymK.db. +Elpi Accumulate derive Db derive.rsymK.db. +Elpi Accumulate Db Header derive.sym.db. +Elpi Accumulate Db derive.sym.db. +Elpi Accumulate Db Header derive.symK.db. +Elpi Accumulate Db derive.symK.db. +Elpi Accumulate derive File common. +Elpi Accumulate derive File utils. +Elpi Accumulate derive File rsymK. + +Elpi Accumulate derive lp:{{ + +dep1 "rsymK" "param2". +dep1 "rsymK" "sym". +dep1 "rsymK" "symK". +derivation (indt T) Prefix ff (derive "rsymK" (derive.rsymK.main T Prefix) (rsymK-done T)). + +}}. \ No newline at end of file From 021a60c4222b6b95d9a26966468ebe10d786d760 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Fri, 23 Jan 2026 20:32:04 +0100 Subject: [PATCH 15/42] automatic generation of rel44 cleaning details --- std/algo/detailed/Detailed_rel44.v | 132 +++++------------------------ std/algo/detailed/Detailed_symK.v | 13 --- std/algo/elpi/RsymK.elpi | 77 ----------------- std/algo/elpi/rel44.elpi | 75 ++++++++++++++++ std/algo/tests/test_Rel44.v | 35 ++++++++ std/algo/theories/Rel44.v | 73 ++++++++++++++++ 6 files changed, 203 insertions(+), 202 deletions(-) create mode 100644 std/algo/elpi/rel44.elpi create mode 100644 std/algo/tests/test_Rel44.v create mode 100644 std/algo/theories/Rel44.v diff --git a/std/algo/detailed/Detailed_rel44.v b/std/algo/detailed/Detailed_rel44.v index 35c24a74..95fde2f4 100644 --- a/std/algo/detailed/Detailed_rel44.v +++ b/std/algo/detailed/Detailed_rel44.v @@ -1,183 +1,91 @@ -From Trocq Require Import map4 umap Rel40 symK. +From Trocq Require Import map4 umap Rel40 symK RsymK. Import HoTTNotations. From Trocq Require Import coverage. Unset Uniform Inductive Parameters. Require Import Stdlib Hierarchy Param_lemmas. Elpi derive False. -Check False_rel40 : Param40.Rel False False. - -Definition FalseR_sym : forall f1 f2, sym_rel False_R f1 f2 <->> False_R f1 f2. -Proof. - intros f1 f2. - refine (False_sym f2 f1; _). - refine (False_sym f1 f2; _). - refine (False_symK f2 f1). -Defined. Definition Param44_False : Param44.Rel False False := - MkUParam False_umap (eq_Map4 FalseR_sym False_umap). + MkUParam False_umap (eq_Map4 False_rsymK False_umap). Elpi derive Unit. -(* Definition UnitR_sym : forall u1 u2, sym_rel Unit_R u1 u2 <->> Unit_R u1 u2. *) -Definition UnitR_sym : forall u1 u2, Unit_R u2 u1 <->> Unit_R u1 u2. -Proof. - intros u1 u2. - refine (Unit_sym u2 u1; _). - refine (Unit_sym u1 u2; _). - refine (Unit_symK u2 u1). -Defined. - Definition Param00_Unit : Param00.Rel Unit Unit := - Param00.BuildRel _ _ Unit_R Unit_umap (eq_Map0 UnitR_sym Unit_umap). + Param00.BuildRel _ _ Unit_R Unit_umap (eq_Map0 Unit_rsymK Unit_umap). Definition Param11_Unit : Param11.Rel Unit Unit := - Param11.BuildRel _ _ Unit_R Unit_umap (eq_Map1 UnitR_sym Unit_umap). + Param11.BuildRel _ _ Unit_R Unit_umap (eq_Map1 Unit_rsymK Unit_umap). Definition Param2a2a_Unit : Param2a2a.Rel Unit Unit := - Param2a2a.BuildRel _ _ Unit_R Unit_umap (eq_Map2a UnitR_sym Unit_umap). + Param2a2a.BuildRel _ _ Unit_R Unit_umap (eq_Map2a Unit_rsymK Unit_umap). Definition Param2b2b_Unit : Param2b2b.Rel Unit Unit := - Param2b2b.BuildRel _ _ Unit_R Unit_umap (eq_Map2b UnitR_sym Unit_umap). + Param2b2b.BuildRel _ _ Unit_R Unit_umap (eq_Map2b Unit_rsymK Unit_umap). Definition Param33_Unit : Param33.Rel Unit Unit := - Param33.BuildRel _ _ Unit_R Unit_umap (eq_Map3 UnitR_sym Unit_umap). + Param33.BuildRel _ _ Unit_R Unit_umap (eq_Map3 Unit_rsymK Unit_umap). Definition Param44_Unit : Param44.Rel Unit Unit := - MkUParam Unit_umap (eq_Map4 UnitR_sym Unit_umap). + MkUParam Unit_umap (eq_Map4 Unit_rsymK Unit_umap). Elpi derive Bool. -Definition BoolR_sym : forall u1 u2, sym_rel Bool_R u1 u2 <->> Bool_R u1 u2. -Proof. - intros u1 u2. - refine (Bool_sym u2 u1; _). - refine (Bool_sym u1 u2; _). - refine (Bool_symK u2 u1). -Defined. - Definition Param44_Bool : Param44.Rel Bool Bool := - MkUParam Bool_umap (eq_Map4 BoolR_sym Bool_umap). + MkUParam Bool_umap (eq_Map4 Bool_rsymK Bool_umap). Elpi derive Wrap. -Definition WrapR_sym : forall u1 u2, sym_rel Wrap_R u1 u2 <->> Wrap_R u1 u2. -Proof. - intros u1 u2. - refine (Wrap_sym u2 u1; _). - refine (Wrap_sym u1 u2; _). - refine (Wrap_symK u2 u1). -Defined. - Definition Param44_Wrap : Param44.Rel Wrap Wrap := - MkUParam Wrap_umap (eq_Map4 WrapR_sym Wrap_umap). + MkUParam Wrap_umap (eq_Map4 Wrap_rsymK Wrap_umap). Elpi derive WrapMore. -Definition WrapMoreR_sym : forall u1 u2, sym_rel WrapMore_R u1 u2 <->> WrapMore_R u1 u2. -Proof. - intros u1 u2. - refine (WrapMore_sym u2 u1; _). - refine (WrapMore_sym u1 u2; _). - refine (WrapMore_symK u2 u1). -Defined. Definition Param44_WrapMore : Param44.Rel WrapMore WrapMore := - MkUParam WrapMore_umap (eq_Map4 WrapMoreR_sym WrapMore_umap). + MkUParam WrapMore_umap (eq_Map4 WrapMore_rsymK WrapMore_umap). Elpi derive Nat. -Definition NatR_sym : forall u1 u2, sym_rel Nat_R u1 u2 <->> Nat_R u1 u2. -Proof. - intros u1 u2. - refine (Nat_sym u2 u1; _). - refine (Nat_sym u1 u2; _). - refine (Nat_symK u2 u1). -Defined. - Definition Param44_Nat : Param44.Rel Nat Nat := - MkUParam Nat_umap (eq_Map4 NatR_sym Nat_umap). + MkUParam Nat_umap (eq_Map4 Nat_rsymK Nat_umap). Elpi derive Box. -Definition BoxR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, Box_R B A (sym_rel AR) u2 u1 <->> Box_R A B AR u1 u2. -Proof. - intros A B AR u1 u2. - refine ((Box_sym B A (sym_rel AR) u2 u1); _). - refine (Box_sym A B AR u1 u2; _). - refine (Box_symK B A (sym_rel AR) u2 u1). -Defined. - Definition Param00_Box : forall (A B : Type) (AR : Param00.Rel A B), Param00.Rel (Box A) (Box B). - Fail refine( fun A B AR=> Param00.BuildRel _ _ (Box_R A B AR) _ (eq_Map0 (BoxR_sym A B AR) _)). + Fail refine( fun A B AR=> Param00.BuildRel _ _ (Box_R A B AR) _ (eq_Map0 (Box_rsymK A B AR) _)). Abort. Definition Param44_Box : forall (A B : Type) (AR : Param44.Rel A B), Param44.Rel (Box A) (Box B). Proof. - refine (fun A B AR => MkUParam (Box_umap A B AR (Param44.covariant _ _ _)) _). - refine (eq_Map4 (BoxR_sym B A (sym_rel AR)) (Box_umap _ _ _ (Param44.contravariant _ _ _))). + refine (fun A B AR => Param44.BuildRel (Box_umap A B AR (Param44.covariant A B AR)) _). + refine (eq_Map4 (Box_rsymK B A (sym_rel AR)) (Box_umap B A (sym_rel AR) (Param44.contravariant A B AR))). + Show Proof. Defined. Elpi derive Option. -Definition OptionR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, Option_R B A (sym_rel AR) u2 u1 <->> Option_R A B AR u1 u2. -Proof. - intros A B AR u1 u2. - refine ((Option_sym B A (sym_rel AR) u2 u1); _). - refine (Option_sym A B AR u1 u2; _). - refine (Option_symK B A (sym_rel AR) u2 u1). -Defined. - Definition Param44_Option : forall (A B : Type) (AR : Param44.Rel A B), Param44.Rel (Option A) (Option B). Proof. refine (fun A B AR => MkUParam (Option_umap A B AR (Param44.covariant _ _ _)) _). - refine (eq_Map4 (OptionR_sym B A (sym_rel AR)) (Option_umap _ _ _ (Param44.contravariant _ _ _))). + refine (eq_Map4 (Option_rsymK B A (sym_rel AR)) (Option_umap _ _ _ (Param44.contravariant _ _ _))). Defined. Elpi derive Prod. -Definition ProdR_sym : forall (A B : Type) (AR : A -> B -> Type) (A2 B2 : Type) (AR2 : A2 -> B2 -> Type), - forall u1 u2, Prod_R B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1 <->> Prod_R A B AR A2 B2 AR2 u1 u2. -Proof. - intros A B AR A2 B2 AR2 u1 u2. - refine ((Prod_sym B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1); _). - refine (Prod_sym A B AR A2 B2 AR2 u1 u2; _). - refine (Prod_symK B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1). -Defined. - Definition Param44_Prod : forall (A B : Type) (AR : Param44.Rel A B) (A2 B2 : Type) (AR2 : Param44.Rel A2 B2), Param44.Rel (Prod A A2) (Prod B B2). Proof. refine (fun A B AR A2 B2 AR2 => MkUParam (Prod_umap A B AR (Param44.covariant _ _ _) A2 B2 AR2 (Param44.covariant _ _ _)) _). - refine (eq_Map4 (ProdR_sym B A (sym_rel AR) B2 A2 (sym_rel AR2)) (Prod_umap _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _))). + refine (eq_Map4 (Prod_rsymK B A (sym_rel AR) B2 A2 (sym_rel AR2)) (Prod_umap _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _))). Defined. Elpi derive ThreeTypes. -Definition ThreeTypesR_sym : forall (A B : Type) (AR : A -> B -> Type) (A2 B2 : Type) (AR2 : A2 -> B2 -> Type) - (A3 B3 : Type) (AR3 : A3 -> B3 -> Type), - forall u1 u2, ThreeTypes_R B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1 - <->> ThreeTypes_R A B AR A2 B2 AR2 A3 B3 AR3 u1 u2. -Proof. - intros A B AR A2 B2 AR2 A3 B3 AR3 u1 u2. - refine ((ThreeTypes_sym B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1); _). - refine (ThreeTypes_sym A B AR A2 B2 AR2 A3 B3 AR3 u1 u2; _). - refine (ThreeTypes_symK B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1). -Defined. - Definition Param44_ThreeTypes : forall (A B : Type) (AR : Param44.Rel A B) (A2 B2 : Type) (AR2 : Param44.Rel A2 B2) (A3 B3 : Type) (AR3 : Param44.Rel A3 B3), Param44.Rel (ThreeTypes A A2 A3) (ThreeTypes B B2 B3). Proof. refine (fun A B AR A2 B2 AR2 A3 B3 AR3 => MkUParam (ThreeTypes_umap A B AR (Param44.covariant _ _ _) A2 B2 AR2 (Param44.covariant _ _ _) A3 B3 AR3 (Param44.covariant _ _ _)) _). - refine (eq_Map4 (ThreeTypesR_sym B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3)) (ThreeTypes_umap _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _))). + refine (eq_Map4 (ThreeTypes_rsymK B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3)) (ThreeTypes_umap _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _))). Defined. Elpi derive List. -Definition ListR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, List_R B A (sym_rel AR) u2 u1 <->> List_R A B AR u1 u2. -Proof. - intros A B AR u1 u2. - refine ((List_sym B A (sym_rel AR) u2 u1); _). - refine (List_sym A B AR u1 u2; _). - refine (List_symK B A (sym_rel AR) u2 u1). -Defined. - Definition Param44_List : forall (A B : Type) (AR : Param44.Rel A B), Param44.Rel (List A) (List B). Proof. refine (fun A B AR => MkUParam (List_umap A B AR (Param44.covariant _ _ _)) _). - refine (eq_Map4 (ListR_sym B A (sym_rel AR)) (List_umap _ _ _ (Param44.contravariant _ _ _))). + refine (eq_Map4 (List_rsymK B A (sym_rel AR)) (List_umap _ _ _ (Param44.contravariant _ _ _))). Defined. diff --git a/std/algo/detailed/Detailed_symK.v b/std/algo/detailed/Detailed_symK.v index 7b3eef50..f70170c6 100644 --- a/std/algo/detailed/Detailed_symK.v +++ b/std/algo/detailed/Detailed_symK.v @@ -72,19 +72,6 @@ t = KWrap_R u1 u2 uR b1 b2 bR) _ _ (Bool_symK b1 b2 bR)^). (* rewrite Unit_symK Bool_symK. *) exact: eq_refl. - refine (fun w1 w2 wR=> _). - cbn delta beta iota. - rewrite Wrap_symK. - exact: eq_refl. -- refine (fun u1 u2 uR=> _). - refine (fun u3 u4 uR2 => _). - refine (fun u5 u6 uR3 => _). - cbn delta beta iota. - rewrite !Unit_symK. - exact: eq_refl. -Defined. - -Elpi derive.param2 Nat. -Elpi derive.sym Nat. Notation Nat_symKPred := (fun w1 w2 (wR : Nat_R w1 w2) => Nat_sym w2 w1 (Nat_sym w1 w2 wR) = wR). Fixpoint Nat_symK : forall w1 w2 (wR : Nat_R w1 w2), Nat_sym w2 w1 (Nat_sym w1 w2 wR) = wR. diff --git a/std/algo/elpi/RsymK.elpi b/std/algo/elpi/RsymK.elpi index cf5297c9..626e1e46 100644 --- a/std/algo/elpi/RsymK.elpi +++ b/std/algo/elpi/RsymK.elpi @@ -4,83 +4,6 @@ shorten derive.common-algo.{mk-mR-type-rsymK, sym-tyargs}. namespace derive.rsymK { -% delta delta iota -pred red-rsymK i:term, i:stack, o:term,o:stack. -red-rsymK X C R RS :- - whd-fuel X C 2 XX CC, - iota-step XX CC R RS. - -pred pierce-goal-rsymK i:int, i:int, i:int, i:term, i: list term, o: list term, o: term. -pierce-goal-rsymK _ N N Goal [] [] Goal. -pierce-goal-rsymK TyParamNo N InitArgs CurrentGoal [Eq|Eqs] [Pat|Pats] EndGoal:- !, - M is N + 1, - coq.safe-dest-app CurrentGoal EqGoal [EqGoalTy,GoalLHS,GoalRHS], - coq.safe-dest-app GoalLHS KR Args, - Done is (TyParamNo * 3) + N * 3, - std.split-at Done Args L [A1,A2, SymSym | R], - coq.typecheck SymSym Ty ok, - (pi t\ - coq.mk-app KR {std.append L {std.append [A1, A2, t] R}} (NewKR t), - coq.mk-app EqGoal [EqGoalTy,(NewKR t),GoalRHS] (NewEqGoal t)), - Pat = (fun `t` Ty t\ (NewEqGoal t)), - coq.typecheck Eq EqTy ok, - coq.safe-dest-app EqTy _ [_,LHS,_], - coq.mk-app Pat [LHS] NewGoal, - pierce-goal-rsymK TyParamNo M InitArgs NewGoal Eqs Pats EndGoal. - -% [|K|], remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, -pred process-args i:term, i:term, i:term, i:int,i:int, i:int, i:term, i:list term, i:term, i:term, o:term. -process-args KsS KsD KR 0 ArgNo TyArgsNo _ RevEqs Goal _ R:- - std.rev RevEqs Eqs, - invert-eqs Eqs IEqs, - coq.mk-app Goal [KsS,KsD,KR] SubstGoal, - whd SubstGoal [] HD [IRTy,SymSymIR,IR], - red-rsymK SymSymIR [] KRHD KRArgs, - coq.mk-app KRHD KRArgs RedLHS, - coq.mk-app HD [IRTy,RedLHS,IR] StartingGoal, - pierce-goal-rsymK TyArgsNo 0 ArgNo StartingGoal IEqs PatsSym _, - End = {{ @eq_refl lp:IRTy lp:IR }}, - rewrite-with IEqs PatsSym End R. - -process-args KsS KsD KR N O TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Eqs Goal ITyTy - (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- - M is N - 1, - @pi-decl AN1 A1Ty a1\ - @pi-decl AN2 A2Ty a2\ - @pi-decl ARN (ARTy a1 a2) ar\ - - coq.mk-app KsS [a1] (NewKsS a1), - coq.mk-app KsD [a2] (NewKsD a2), - coq.mk-app KR [a1,a2,ar] (NewKR a1 a2 ar), - - (param a2 a1 ar =!=> - whd A2Ty _ IndD _, - rsymK-db IndD SymKA2, - coq.mk-app SymKA2 [a1, a2, ar] (SymKEq a1 a2 ar), - std.append [(SymKEq a1 a2 ar)] Eqs (NewEqs a1 a2 ar), - process-args (NewKsS a1) (NewKsD a2) (NewKR a1 a2 ar) M O TyArgsNo (Bo a1 a2 ar) (NewEqs a1 a2 ar) Goal ITyTy (R a1 a2 ar)), - % if the type of the argument is an instance of the inductive type add an induction hypothesis - whd ITyTy _ Ind _, - if (Ind = IndD) - (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), - (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) - (RF = R). - -% invariant: all type arguments were already processed. -% Constructor R, Constructor dest Type, No of Arguments to process, -% constructorR Type, type of i2, something of type : i1 i2 iR => goal. -pred mkBranch i:term, i:term, i:term, i:int, i:int, i:term, i:term, i:term, o:term. -mkBranch KsS KsD KR N M KTyR ITyTy Goal Eq:- - whd ITyTy [] _ TyArgs, - process-args KsS KsD KR N M {std.length TyArgs} KTyR [] Goal ITyTy Eq. - -pred mkBranches i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term o:list term. -mkBranches [] [] [] [] [] _ _ []. -mkBranches [KsS|KsSs] [KsD| KsDs] [KR|KRs][KTy|KTys] [KTyR|KTyRs] ITyTy Goal [R|Rs] :- - coq.count-prods KTy ArgNo, - mkBranch KsS KsD KR ArgNo ArgNo KTyR ITyTy Goal R, - mkBranches KsSs KsDs KRs KTys KTyRs ITyTy Goal Rs. - pred implement-rsymK i:int, i:term, i:term, i:term, i:list term, o:term. implement-rsymK 0 (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ _) Sym SymK LRev (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ (R i1 i2)) :- !, diff --git a/std/algo/elpi/rel44.elpi b/std/algo/elpi/rel44.elpi new file mode 100644 index 00000000..8ae151b8 --- /dev/null +++ b/std/algo/elpi/rel44.elpi @@ -0,0 +1,75 @@ +shorten derive.algo-utils.{type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with}. +shorten derive.common-algo.{mk-mR-type-rel44,sym-tyargs}. + +namespace derive.rel44 { + +pred refine-covariant-tyargs i: list term, i:term, i:list term, o: list term. +refine-covariant-tyargs [] _ L L. +refine-covariant-tyargs [A1, A2, AR | L2] Refiner Acc R :- + coq.mk-app Refiner [A1,A2,AR] Refined, + std.append Acc [A1, A2, AR, Refined] NewAcc, + refine-covariant-tyargs L2 Refiner NewAcc R. + +pred refine-Lsym i: list term, i:list term, i:term, i:list term, o: list term. +refine-Lsym [] [] _ L L. +refine-Lsym [A1, A2, AR | L2] [_,_,_,Refined | L2Ref] Refiner Acc R :- + coq.safe-dest-app Refined _ Lref, + coq.mk-app Refiner Lref RefinedContra, + std.append Acc [A1, A2, AR, RefinedContra] NewAcc, + refine-Lsym L2 L2Ref Refiner NewAcc R. + +% TyargNo, rel44 Type, mapi, eq_map, rsymK, list of args +pred implement-rel44 i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:list term, o:term. +implement-rel44 0 _ + Mapi Eq_map RsymK CovariantNN ContravariantNN BuildNN LRev R :- + !, + coq.say LRev, + std.rev LRev L, + refine-covariant-tyargs L CovariantNN [] LCo, + sym-tyargs L LSym, + refine-Lsym LSym LCo ContravariantNN [] LContra, + coq.say "LCo" LCo, + coq.say "LContra" LContra, + coq.say "LSym " LSym, + coq.mk-app Mapi LCo MapCovariant, + coq.mk-app Mapi LContra MapContravariant, + coq.mk-app RsymK LSym RsymKSym, + R = {{ lp:BuildNN lp:MapCovariant (lp:Eq_map lp:RsymKSym lp:MapContravariant )}}. +implement-rel44 N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) + Mapi Eq_map RsymK CovariantNN ContravariantNN BuildNN L + (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, + @pi-decl AN1 ATy1 a1\ %A1 : Type + @pi-decl AN2 ATy2 a2\ %A2 : Type + @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param00.Rel A1 A2 + sigma NewL\ + std.append [ar,a2,a1] L NewL, + implement-rel44 M (Bo a1 a2 ar) Mapi Eq_map RsymK CovariantNN ContravariantNN BuildNN NewL (R a1 a2 ar). + + +func main inductive, string -> list prop. +main GR Prefix Clauses :- std.do! [ + + coq.env.indt GR _ TyParamNo _ _ KNs KTys, + Ind = (global (indt GR)), + std.assert! (param Ind Ind TR) "derive.rel44: use derive.param2 before", + coq.typecheck TR TRTy _, + mk-mR-type-rel44 TyParamNo TRTy TR SymKTy, + std.assert-ok! (coq.elaborate-skeleton SymKTy _ SymKTyE) "derive.rel44 generates illtyped type", + std.assert! (umap-db Ind UmapI) "derive.rel44: use derive.umap before", + std.assert! (rsymK-db Ind RSymKInd) "derive.rel44: use derive.rsymK before", + Eq_map = {{ eq_Map4 }}, + implement-rel44 TyParamNo SymKTyE UmapI Eq_map RSymKInd (pglobal {{:gref Param44.covariant }} _) (pglobal {{:gref Param44.contravariant }} _) {{ MkUParam }} [] R, + coq.say "Term is" R, + std.assert-ok! (coq.elaborate-skeleton R SymKTyE Re) "derive.rel44 generates illtyped term", + Name is Prefix ^ "rel44", + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName Re SymKTyE _ C, + I = global (indt GR), + Clauses = [rel44-done GR, rel44-db I (global (const C))], + std.forall Clauses (x\ + coq.elpi.accumulate _ "derive.rel44.db" (clause _ _ x) + ), +]. + +} \ No newline at end of file diff --git a/std/algo/tests/test_Rel44.v b/std/algo/tests/test_Rel44.v new file mode 100644 index 00000000..aecb8d5d --- /dev/null +++ b/std/algo/tests/test_Rel44.v @@ -0,0 +1,35 @@ + +From Trocq Require Import coverage Rel44. + +Elpi derive False. +Check False_rel44. + +Elpi derive Unit. +Check Unit_rel44. + +Elpi derive Bool. +Check Bool_rel44. + +Elpi derive Wrap. +Check Wrap_rel44. + +Elpi derive WrapMore. +Check WrapMore_rel44. + +Elpi derive Nat. +Check Nat_rel44. + +Elpi derive Box. +Check Box_rel44. + +Elpi derive Option. +Check Option_rel44. + +Elpi derive Prod. +Check Prod_rel44. + +Elpi derive ThreeTypes. +Check ThreeTypes_rel44. + +Elpi derive List. +Check List_rel44. \ No newline at end of file diff --git a/std/algo/theories/Rel44.v b/std/algo/theories/Rel44.v new file mode 100644 index 00000000..1f7fcf2b --- /dev/null +++ b/std/algo/theories/Rel44.v @@ -0,0 +1,73 @@ +From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. +From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. +From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) +From Trocq Extra Dependency "algo/elpi/utils.elpi" as utils. +From Trocq Extra Dependency "algo/elpi/rel44.elpi" as rel44. +From Trocq Require Import sym symK RsymK Param_lemmas umap map4. +Import HoTTNotations. +(* Extra Dependency "algo/elpi/sym.elpi" as sym. *) + +From elpi.apps Require Import derive.legacy derive.param2. + +From Trocq Require Export Hierarchy. +Unset Uniform Inductive Parameters. + +Elpi Db derive.rel44.db lp:{{ + + % [rel44 I S] links I inductive type, + % with the function showing i1 i2, [| I |]^ i2 i1 <->> [| I |] i1 i2 + pred rel44-db i:term, o:term. + + % [rel44-done T K] means T K was already derived + pred rel44-done o:inductive. +}}. + +Elpi Command derive.rel44. +Elpi Accumulate File derive_hook. +Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db Header derive.rsymK.db. +Elpi Accumulate Db derive.rsymK.db. +Elpi Accumulate Db Header derive.umap.db. +Elpi Accumulate Db derive.umap.db. +Elpi Accumulate File common. +Elpi Accumulate File utils. +Elpi Accumulate Db Header derive.rel44.db. +Elpi Accumulate Db derive.rel44.db. + +Elpi Query lp:{{ + T = {{:gref Param44.covariant }}, + coq.say (pglobal T _). +}}. +Elpi Accumulate File rel44. +Elpi Accumulate lp:{{ + + main [str I] :- !, + coq.locate I (indt GR), + % Ind is (indt GR) + coq.gref->id (indt GR) Tname, + Suffix is Tname ^ "_", + derive.rel44.main GR Suffix _. + main _ :- usage. + + pred usage. + usage :- coq.error "Usage: derive.rel44 ". +}}. + +(* hook into derive *) +Elpi Accumulate derive Db Header derive.rel44.db. +Elpi Accumulate derive Db derive.rel44.db. +Elpi Accumulate Db Header derive.rsymK.db. +Elpi Accumulate Db derive.rsymK.db. +Elpi Accumulate Db Header derive.umap.db. +Elpi Accumulate Db derive.umap.db. +Elpi Accumulate derive File common. +Elpi Accumulate derive File utils. +Elpi Accumulate derive File rel44. +Elpi Accumulate derive lp:{{ + +dep1 "rel44" "rsymK". +dep1 "rel44" "umap". +derivation (indt T) Prefix ff (derive "rel44" (derive.rel44.main T Prefix) (rel44-done T)). + +}}. From a83574946f3ccc241e7f1d05d4aabd85344be82b Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Tue, 24 Feb 2026 17:08:21 +0100 Subject: [PATCH 16/42] wip refactor up-to mymap, build fails for mR refactor up-to mR wip refactor up-to rm refactor up-to rel44 --- std/algo/elpi/Rm.elpi | 22 +++++----- std/algo/elpi/common_algo.elpi | 75 ++++++++++++++++++++++------------ std/algo/elpi/mR.elpi | 24 ++++++----- std/algo/elpi/mRRmK.elpi | 26 ++++++------ std/algo/elpi/mymap.elpi | 46 +++++++++++++-------- std/algo/elpi/rel44.elpi | 5 --- std/algo/elpi/umap.elpi | 24 +++-------- std/algo/tests/test_map4.v | 21 +++++----- 8 files changed, 128 insertions(+), 115 deletions(-) diff --git a/std/algo/elpi/Rm.elpi b/std/algo/elpi/Rm.elpi index adcf2896..b38b8796 100644 --- a/std/algo/elpi/Rm.elpi +++ b/std/algo/elpi/Rm.elpi @@ -105,30 +105,28 @@ implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 mkBranches KsS KsD KTys KTyRs ITy2 Pred Brs, std.append Brs [i1,i2,ar] (IndArgs i1 i2 ar), coq.mk-app RIndP (IndArgs i1 i2 ar) (R i1 i2 ar). -implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KTys KTyRs Pred RInd - (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- +implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ prod AMN (AMTy a1 a2 ar) am\ (Bo a1 a2 ar am)) KsS KsD KTys KTyRs Pred RInd + (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ fun AMN (AMTy a1 a2 ar) am\ (R a1 a2 ar am)) :- M is N - 1, @pi-decl AN1 ATy1 a1\ %A1 : Type @pi-decl AN2 ATy2 a2\ %A2 : Type - @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param2b0.Rel A1 A2 - coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), - - (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, - coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, + @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param2b0.Rel A1 A2 Changing into A1 -> A2 -> Type + @pi-decl AMN (AMTy a1 a2 ar) am\ % Map2b.Has AR + coq.mk-app Pred [a1,a2,ar,am] (NewPred a1 a2 ar am), coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), - std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), - Rm = {{ @Trocq.Hierarchy.R_in_map }}, - coq.mk-app Rm [a1, a2, ar] (RMS a1 a2 ar), + std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,ar] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), + Rm = {{ @Trocq.Hierarchy.Map2b.R_in_map }}, + coq.mk-app Rm [a1, a2, ar, am] (RMS a1 a2 ar am), % coq.elaborate-skeleton (RMS a1 a2 ar) _ (RM a1 a2 ar) ok, ar-db a1 a2 ar ==> - rm-db a1 (RMS a1 a2 ar) ==> - implement-Rm M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). + rm-db a1 (RMS a1 a2 ar am) ==> + implement-Rm M TyParamNo (Bo a1 a2 ar am) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar am) (NewRInd a1 a2 ar) (R a1 a2 ar am). func main inductive, string -> list prop. diff --git a/std/algo/elpi/common_algo.elpi b/std/algo/elpi/common_algo.elpi index 1019e610..d961dc08 100644 --- a/std/algo/elpi/common_algo.elpi +++ b/std/algo/elpi/common_algo.elpi @@ -2,15 +2,19 @@ namespace derive.common-algo { pred rel-mode i:int o:term. -rel-mode 0 {{ Param10.Rel }}. % my-map -rel-mode 1 {{ Param2a0.Rel }}. % mR -rel-mode 2 {{ Param2b0.Rel }}. % Rm -rel-mode 3 {{ Param30.Rel }}. % _ -rel-mode 4 {{ Param40.Rel }}. % mRRmK +rel-mode 0 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map1.Has AR) (Rest : Type), Rest }}. % my-map +%rel-mode 0 {{ fun (A B : Type) (AR : A -> B -> Type) (Rest : Type)=> Map1.Has }}. % my-map +rel-mode 1 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map2a.Has AR) (Rest : Type), Rest }}. % mR +%rel-mode 1 {{ Map2a.Has }}. % mR +rel-mode 2 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map2b.Has AR) (Rest : Type), Rest }}. % Rm +rel-mode 3 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map3.Has AR) (Rest : Type), Rest }}. % _ +rel-mode 4 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map4.Has AR) (Rest : Type), Rest }}. % mRRmK +% the following 3 don't require extra assumption on relation and should be processed differently rel-mode 5 {{ fun (A B : Type)=> A -> B -> Type }}. % sym rel-mode 6 {{ fun (A B : Type)=> A -> B -> Type }}. % symK rel-mode 7 {{ fun (A B : Type)=> A -> B -> Type }}. % rsymK -rel-mode 8 {{ Param44.Rel }}. % +% the following one should be moved to another file. +rel-mode 8 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map2a.Has AR) (Rest : Type), Rest }}. % pred swap i:term, i:term, i:bool, o:term, o:term. swap A B tt B A. @@ -44,6 +48,11 @@ pred sym-tyargs i: list term, o: list term. sym-tyargs L R :- sym-tyargs-priv L [] R. +pred clean-l i: list term, o: list term. +clean-l [] []. +clean-l [A1, A2, AR, _ | L2] [A1,A2,AR | R] :- + clean-l L2 R. + % The number of Type parameters in T % Type of inductive T, % Type of bin parametricity translation TR, @@ -51,11 +60,12 @@ sym-tyargs L R :- % MR RHS of map equality % Rel type of TR applied to arguments % Returns the type of map in R for T +% Does it add an extra hyp on the relation? % X is the first inductive, Y is the second inductive. -pred mk-mR-type-priv i:int, i:term, i:term, i:term, i:term, i:int, i:list term, i: (pred i:term, o:term), i: (pred i:term, o:term), o:term. +pred mk-mR-type-priv i:int, i:term, i:term, i:term, i:term, i:int, i:list term, i: (pred i:term, o:term), i: (pred i:term, o:term), i:bool, o:term. % Introducing X and Y. % The RHS of the equality is Y. -mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- (Swap = 1 ; Swap = 2), @pi-decl IN1 ITyTy x\ @@ -64,14 +74,16 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ std.rev LRev L, coq.mk-app ML {std.append L [x]} NewML, NewMR = y, - coq.mk-app Rel {std.append L [x,y]} NewRel, + clean-l L CL, + coq.mk-app Rel {std.append CL [x,y]} NewRel, mk-return NewML NewMR NewRel Swap ITyTy2 (R x y). -mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 4 LRev MR-DB RM-DB +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 4 LRev MR-DB RM-DB _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ prod `IR` (RelTy x y) iR\ (R x y iR)) :- std.rev LRev L, @pi-decl IN1 ITyTy x\ @pi-decl IN2 ITyTy2 y\ - coq.mk-app Rel {std.append L [x,y]} (RelTy x y), + clean-l L CL, + coq.mk-app Rel {std.append CL [x,y]} (RelTy x y), @pi-decl `IR` (RelTy x y) iR\ % sigma NewML NewMR NewRel L\ whd ITyTy2 [] Ind _, @@ -80,7 +92,7 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 4 LRev MR-DB RM- MR-DB Ind MapInR, coq.mk-app MapInR {std.append L [x,y,(Rm x y iR)]} (MRRM x y iR), (R x y iR) = {{ @eq _ lp:{{MRRM x y iR}} lp:iR }}. -mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 5 LRev _ _ +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 5 LRev _ _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- std.rev LRev L, sym-tyargs L L2, @@ -89,7 +101,7 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 5 LRev _ _ coq.mk-app Rel {std.append L [x,y]} (RelTy1 x y), coq.mk-app Rel {std.append L2 [y,x]} (RelTy2 x y), R x y = {{ lp:{{RelTy1 x y}} -> lp:{{RelTy2 x y}} }}. -mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) RSym _ Rel 7 LRev _ _ +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) RSym _ Rel 7 LRev _ _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- std.rev LRev L, sym-tyargs L L2, @@ -99,11 +111,11 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) RSym _ Rel 7 LRev _ _ coq.mk-app Rel {std.append L2 [y,x]} (RelTy2 x y), RSkel x y = {{ lp:RSym lp:{{RelTy2 x y}} lp:{{RelTy1 x y}} }}, whd1 (RSkel x y) (R x y). -mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 8 _ _ _ +mk-mR-type-priv 0 (prod _ ITyTy x\ prod _ ITyTy2 _) _ _ _ 8 _ _ _ _ R :- coq.mk-app { rel-mode 8 } [ITyTy, ITyTy2] R. % TODO: remove use of MR-DB, try just pass the MR and RM -mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) SymC _ Rel 6 LRev _ _ +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) SymC _ Rel 6 LRev _ _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ prod `IR` (RelTy x y) iR\ (R x y iR)) :- std.rev LRev L, sym-tyargs L L2, @@ -117,42 +129,53 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) SymC _ Rel 6 LRev _ _ (R x y iR) = {{ @eq _ lp:{{SymSym x y iR}} lp:iR }}. % Process two type parameters + 1 relation at a time. % Apply these parameters to the LHS of the equation. -mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB - (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN {{ lp:AR lp:a1 lp:a2 }} ar\ (R a1 a2 ar)) :- +% This branch deals with adding the additional hypothesis in case the input boolean is set. +mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB tt + (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ prod NM (MTy a1 a2 ar) am\ (Rest a1 a2 ar am)) :- M is N - 1, rel-mode Swap ARSkel, - coq.elaborate-skeleton ARSkel {{ Type -> Type -> Type }} AR ok, + coq.name-suffix AN1 "M" NM, + pi a1 a2 ar am\ + sigma NewL\ + std.append [am,ar,a2,a1] L NewL, + mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR-DB RM-DB tt (R a1 a2 ar am), + coq.subst-prod [a1, a2, ar] ARSkel (prod _ (MTy a1 a2 ar) _), + coq.subst-prod [a1, a2, ar, am, (R a1 a2 ar am)] ARSkel (Rest a1 a2 ar am). +% This branch deals with the branch when the boolean is unset. +mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB ff + (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, pi a1 a2 ar\ sigma NewL\ std.append [ar,a2,a1] L NewL, - mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR-DB RM-DB (R a1 a2 ar). %dummy newMR + mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR-DB RM-DB ff (R a1 a2 ar). pred mk-mR-type-mR i:int, i:term, i:term, i:term, i:term, o:term. mk-mR-type-mR N T ML MR Rel RTy :- - mk-mR-type-priv N T ML MR Rel 1 [] _ _ RTy. + mk-mR-type-priv N T ML MR Rel 1 [] _ _ tt RTy. pred mk-mR-type-Rm i:int, i:term, i:term, i:term, i:term, o:term. mk-mR-type-Rm N T ML MR Rel R :- - mk-mR-type-priv N T ML MR Rel 2 [] _ _ R. + mk-mR-type-priv N T ML MR Rel 2 [] _ _ tt R. pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:(pred i:term, o:term) , i: (pred i:term, o:term), o:term. mk-mR-type-mRRmK N T ML Rel MR-DB RM-DB R :- - mk-mR-type-priv N T ML _ Rel 4 [] MR-DB RM-DB R. + mk-mR-type-priv N T ML _ Rel 4 [] MR-DB RM-DB tt R. pred mk-mR-type-sym i:int, i:term, i:term, o:term. mk-mR-type-sym N T Rel R :- - mk-mR-type-priv N T _ _ Rel 5 [] _ _ R. + mk-mR-type-priv N T _ _ Rel 5 [] _ _ ff R. pred mk-mR-type-symK i:int, i:term, i:term, i:term, o:term. mk-mR-type-symK N T Rel Sym R :- - mk-mR-type-priv N T Sym _ Rel 6 [] _ _ R. + mk-mR-type-priv N T Sym _ Rel 6 [] _ _ ff R. pred mk-mR-type-rsymK i:int, i:term, i:term, i:term, o:term. mk-mR-type-rsymK N T Rel RSym R :- - mk-mR-type-priv N T RSym _ Rel 7 [] _ _ R. + mk-mR-type-priv N T RSym _ Rel 7 [] _ _ ff R. pred mk-mR-type-rel44 i:int, i:term, i:term, o:term. mk-mR-type-rel44 N T Rel R :- - mk-mR-type-priv N T _ _ Rel 8 [] _ _ R. + mk-mR-type-priv N T _ _ Rel 8 [] _ _ tt R. } \ No newline at end of file diff --git a/std/algo/elpi/mR.elpi b/std/algo/elpi/mR.elpi index ad90bf17..9409b7cf 100644 --- a/std/algo/elpi/mR.elpi +++ b/std/algo/elpi/mR.elpi @@ -137,23 +137,25 @@ implement-mR 0 TyParamNo (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)) (fun I1 @pi-decl I1 I1Ty i1\ @pi-decl I2 I2Ty i2\ coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R i1 i2). -implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) ar\ (Bo a1 a2 ar)) - (fun A1 A1Ty a1\ fun A2 A2Ty a2\ fun AR (ARTy a1 a2) ar\ (R a1 a2 ar)) :- +implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) ar\ prod AM (AMTy a1 a2 ar) am\ (Bo a1 a2 ar am)) + (fun A1 A1Ty a1\ fun A2 A2Ty a2\ fun AR (ARTy a1 a2) ar\ fun AM (AMTy a1 a2 ar) am\ (R a1 a2 ar am)) :- M is N - 1, @pi-decl A1 A1Ty a1\ @pi-decl A2 A2Ty a2\ @pi-decl AR (ARTy a1 a2) ar\ - Map = {{ @Trocq.Hierarchy.map }}, - coq.mk-app Map [a1,a2,ar] (PMapA a1 a2 ar), + @pi-decl AM (AMTy a1 a2 ar) am\ + Map = {{ @Trocq.Hierarchy.Map1.map }}, + coq.mk-app Map [a1,a2,ar,am] (PMapA a1 a2 ar am), % insert coercions - coq.elaborate-skeleton (PMapA a1 a2 ar) _ (MapA a1 a2 ar) ok, - MR = {{ @Trocq.Hierarchy.map_in_R }}, - coq.mk-app MR [a1,a2,ar] (PMR a1 a2 ar), - coq.elaborate-skeleton (PMR a1 a2 ar) _ (MRA a1 a2 ar) ok, - mymap-def A1Ty (MapA a1 a2 ar) ==> - mR-db a1 (MRA a1 a2 ar) ==> + coq.elaborate-skeleton (PMapA a1 a2 ar am) _ (MapA a1 a2 ar am) ok, + MR = {{ @Trocq.Hierarchy.Map2a.map_in_R }}, + coq.mk-app MR [a1,a2,ar,am] (PMR a1 a2 ar am), + coq.elaborate-skeleton (PMR a1 a2 ar am) _ (MRA a1 a2 ar am) ok, + mymap-def A1Ty (MapA a1 a2 ar am) ==> + mR-db a1 (MRA a1 a2 ar am) ==> + % todo: check usage of ar-db in mR ar-db a1 a2 ar ==> - implement-mR M TyParamNo (Bo a1 a2 ar) (R a1 a2 ar). + implement-mR M TyParamNo (Bo a1 a2 ar am) (R a1 a2 ar am). func main inductive, string -> list prop. diff --git a/std/algo/elpi/mRRmK.elpi b/std/algo/elpi/mRRmK.elpi index 28145a33..14a8c534 100644 --- a/std/algo/elpi/mRRmK.elpi +++ b/std/algo/elpi/mRRmK.elpi @@ -231,32 +231,30 @@ implement-mRRmK 0 (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) _) mkBranches KsS KsD KTys KTyRs ITy2 Pred KRs InjKss Brs, std.append Brs [i1,i2,ar] (IndArgs i1 i2 ar), coq.mk-app RIndP (IndArgs i1 i2 ar) (R i1 i2 ar). -implement-mRRmK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) KsS KsD KTys KTyRs Pred RInd KRs InjKss - (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- +implement-mRRmK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ prod AMN (AMTy a1 a2 ar) am\ (Bo a1 a2 ar am)) KsS KsD KTys KTyRs Pred RInd KRs InjKss + (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ fun AMN (AMTy a1 a2 ar) am\ (R a1 a2 ar am)) :- M is N - 1, @pi-decl AN1 ATy1 a1\ %A1 : Type @pi-decl AN2 ATy2 a2\ %A2 : Type - @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param40.Rel A1 A2 - coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), + @pi-decl ARN (ARTy a1 a2) ar\ % AR : A1 -> A2 -> Type + @pi-decl AMN (AMTy a1 a2 ar) am\ % Map4.Has AR + coq.mk-app Pred [a1,a2,ar, am] (NewPred a1 a2 ar am), - (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, - coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, - coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), - std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), - std.map KRs (x\ r\ sigma TMP\ coq.mk-app x [a1,a2,(RelAR a1 a2 ar)] TMP, r = TMP) (NewKRs a1 a2 ar), + std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,ar] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), + std.map KRs (x\ r\ sigma TMP\ coq.mk-app x [a1,a2,ar] TMP, r = TMP) (NewKRs a1 a2 ar), - MRRMK = {{ @Trocq.Hierarchy.R_in_mapK }}, - coq.mk-app MRRMK [a1, a2, ar] (MRRMKS a1 a2 ar), - coq.typecheck (MRRMKS a1 a2 ar) _ ok, + MRRMK = {{ @Trocq.Hierarchy.Map4.R_in_mapK }}, + coq.mk-app MRRMK [a1, a2, ar, am] (MRRMKS a1 a2 ar am), + coq.typecheck (MRRMKS a1 a2 ar am) _ ok, ar-db a1 a2 ar ==> - mRRmK-db a2 (MRRMKS a1 a2 ar) ==> - implement-mRRmK M (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (NewKRs a1 a2 ar) InjKss (R a1 a2 ar). + mRRmK-db a2 (MRRMKS a1 a2 ar am) ==> + implement-mRRmK M (Bo a1 a2 ar am) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar am) (NewRInd a1 a2 ar) (NewKRs a1 a2 ar) InjKss (R a1 a2 ar am). diff --git a/std/algo/elpi/mymap.elpi b/std/algo/elpi/mymap.elpi index 9ea7a225..babf828b 100644 --- a/std/algo/elpi/mymap.elpi +++ b/std/algo/elpi/mymap.elpi @@ -65,9 +65,7 @@ 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 :- - mymap-db T S FRel, - % map.aux FRel F, - coq.mk-app {{ map }} [FRel] F, + mymap-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 :- @@ -98,31 +96,37 @@ bo-params Lno Lno Ity1 Ity2 A1 _ Ps (fix `f` Recno Fty Bo) :- @pi-decl `rec` Fty f\ mymap-db Ity1 Ity2 f => bo-idx A1 Ity1 Ity2 0 Recno Ps (Bo f) Fty. -bo-params Lno Lno Ity1 Ity2 A1 _ Ps Bo :- +bo-params Lno Lno Ity1 Ity2 A1 _ Ps Bo :- !, bo-idx A1 Ity1 Ity2 0 _ Ps Bo _. bo-params N Lno Ity1 Ity2 (prod A Sty1 Rty1) (prod _ Sty2 Rty2) Ps R :- coq.name-suffix A 1 A1, coq.name-suffix A 2 A2, + coq.name-suffix A "r" Ar, coq.name-suffix A "f" Af, N1 is N + 1, - (pi a b f \ mk-map-ty a Sty1 b Sty2 (FAB a b) f _ (Clause a b f)), - R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Af (FAB a b) f\ Bo a b f), - pi a b f\ sigma Ity1A Ity2A \ + (pi a b r f \ mk-map-ty a Sty1 b Sty2 (RAB a b) r (FAB a b r) f _ (Clause a b r f)), + % todo: add fun for map + %R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Ar (RAB a b) r\ fun Af (FAB a b r) f\ Bo a b r f), + R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Ar (RAB a b) r\ fun Af (FAB a b r) f\ Bo a b r f), + pi a b r f\ sigma Ity1A Ity2A \ coq.mk-app Ity1 [a] Ity1A, coq.mk-app Ity2 [b] Ity2A, - Clause a b f => + Clause a b r f => decl a A1 Sty1 => decl b A2 Sty2 => - decl f Af (FAB a b) => - bo-params N1 Lno Ity1A Ity2A (Rty1 a) (Rty2 b) [b|Ps] (Bo a b f). + (coq.elaborate-skeleton (RAB a b) _ (RABTy a b) ok, + decl r Ar (RABTy a b) ==> + coq.elaborate-skeleton (FAB a b r) _ (FABTy a b r) ok, + decl f Af (FABTy a b r) ==> + bo-params N1 Lno Ity1A Ity2A (Rty1 a) (Rty2 b) [b|Ps] (Bo a b r f)). bo-params N Lno Ity1 Ity2 T OT Ps R :- whd1 T T1, whd1 OT OT1, !, bo-params N Lno Ity1 Ity2 T1 OT1 Ps R. bo-params _ _ _ _ _ _ _ _ :- - stop "derive.map: Indexed data types not supported". + stop "derive.mymap: Indexed data types not supported". pred map-pi i:any, o:list prop. map-pi (x\ []) []. @@ -133,31 +137,37 @@ pred mk-map-ty i:term, % and its type i:term, % output variable i:term, % an its type + o:term, % type of relation input -> ouput -> type + i:term, % a term of type above o:term, % type of a mapping function from input to output i:term, % map function (having the type above) o:int, % arity of the predicate o:list prop. % mymap-db clause for map function -mk-map-ty A (prod _ SA T1) B (prod _ SB T2) (prod `x` SA x\ R x) F N C1 :- +mk-map-ty A (prod _ SA T1) B (prod _ SB T2) RelTy RTerm (prod `x` SA x\ R x) F N C1 :- mymap-db SA SB Fa, !, (pi x\ sigma Ax Fx BFx \ coq.mk-app A [x] Ax, coq.mk-app Fa [x] Fx, coq.mk-app B [Fx] BFx, - mk-map-ty Ax (T1 x) BFx (T2 BFx) (R x) {coq.mk-app F [x]} M (C x), + mk-map-ty Ax (T1 x) BFx (T2 BFx) RelTy RTerm (R x) {coq.mk-app F [x]} M (C x), N is M + 1), map-pi C C1. -mk-map-ty A (prod _ S1 T1) B (prod _ _ T2) (prod `x` S1 x\ R x) F N C1 :- +mk-map-ty A (prod _ S1 T1) B (prod _ _ T2) RelTy RTerm (prod `x` S1 x\ R x) F N C1 :- (pi x\ sigma Ax Bx \ coq.mk-app A [x] Ax, coq.mk-app B [x] Bx, - mk-map-ty Ax (T1 x) Bx (T2 x) (R x) {coq.mk-app F [x]} M (C x), + mk-map-ty Ax (T1 x) Bx (T2 x) RelTy RTerm (R x) {coq.mk-app F [x]} M (C x), N is M + 1), map-pi C C1. % mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ {{ Param10.Rel lp:A lp:B }} (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- -mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ (prod `x` A _\ B) (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- +mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ (prod `x` A _\ B) _ _ (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- drop-last 1 XS LA, drop-last 1 YS LB, drop-last 1 GS LF, coq.mk-app X LA PLA, coq.mk-app Y LB PLB, coq.mk-app G LF PLF. -mk-map-ty A _ B _ {{ Param10.Rel lp:A lp:B }} F 0 [mymap-db A B F]. +mk-map-ty A _ B _ RelTy RTerm Map F 0 [mymap-db A B {{ Map1.map _ lp:F }} ] :- + RelTy = {{ lp:A -> lp:B -> Type }} , + Map = {{ Map1.Has lp:RTerm }}. + + % mk-map-ty A _ B _ (prod `x` A _\ B) F 0 [mymap-db A B F]. % Build a clause %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -187,7 +197,7 @@ func main inductive, string -> list prop. main GR Prefix C :- do! [ T = global (indt GR), coq.env.indt GR _Ind Lno Luno Arity _ _, - assert! (Lno = Luno) "derive.map: Non-uniform parameters not supported", + assert! (Lno = Luno) "derive.mymap: Non-uniform parameters not supported", % generate map and add to the env (bo-params 0 Lno T T Arity Arity [] RSkel), diff --git a/std/algo/elpi/rel44.elpi b/std/algo/elpi/rel44.elpi index 8ae151b8..fdd9d9f0 100644 --- a/std/algo/elpi/rel44.elpi +++ b/std/algo/elpi/rel44.elpi @@ -23,14 +23,10 @@ pred implement-rel44 i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:te implement-rel44 0 _ Mapi Eq_map RsymK CovariantNN ContravariantNN BuildNN LRev R :- !, - coq.say LRev, std.rev LRev L, refine-covariant-tyargs L CovariantNN [] LCo, sym-tyargs L LSym, refine-Lsym LSym LCo ContravariantNN [] LContra, - coq.say "LCo" LCo, - coq.say "LContra" LContra, - coq.say "LSym " LSym, coq.mk-app Mapi LCo MapCovariant, coq.mk-app Mapi LContra MapContravariant, coq.mk-app RsymK LSym RsymKSym, @@ -60,7 +56,6 @@ main GR Prefix Clauses :- std.do! [ std.assert! (rsymK-db Ind RSymKInd) "derive.rel44: use derive.rsymK before", Eq_map = {{ eq_Map4 }}, implement-rel44 TyParamNo SymKTyE UmapI Eq_map RSymKInd (pglobal {{:gref Param44.covariant }} _) (pglobal {{:gref Param44.contravariant }} _) {{ MkUParam }} [] R, - coq.say "Term is" R, std.assert-ok! (coq.elaborate-skeleton R SymKTyE Re) "derive.rel44 generates illtyped term", Name is Prefix ^ "rel44", coq.ensure-fresh-global-id Name FName, diff --git a/std/algo/elpi/umap.elpi b/std/algo/elpi/umap.elpi index bb0c05ad..c37b7936 100644 --- a/std/algo/elpi/umap.elpi +++ b/std/algo/elpi/umap.elpi @@ -1,5 +1,4 @@ -shorten derive.common-algo. {rel-mode}. shorten derive.algo-utils.{gen-names-map}. namespace derive.umap { @@ -32,18 +31,6 @@ pred mk-umap-type i:int, i:term, i:term, i:term, o:term. mk-umap-type TyParamNo Arity Ind Rel R :- mk-umap-type-priv TyParamNo Arity Ind Ind Rel R. -% given two types and an UMap between them, elaborates the types of the different hierarchy relations. -pred insert-coersions i:term, i:term, i:term, o:term, o:term, o:term, o:term. -insert-coersions T1 T2 UR MapR MRR RMR MRRMKR :- - coq.mk-app {rel-mode 0} [T1,T2] MapRTy, - coq.mk-app {rel-mode 1} [T1,T2] MRRTy, - coq.mk-app {rel-mode 2} [T1,T2] RMRTy, - coq.mk-app {rel-mode 4} [T1,T2] MRRMKRTy, - std.assert-ok! (coq.elaborate-skeleton UR MapRTy MapR) "derive.umap fails to insert coersions to MapR", - std.assert-ok! (coq.elaborate-skeleton UR MRRTy MRR) "derive.umap fails to insert coersions to MRR", - std.assert-ok! (coq.elaborate-skeleton UR RMRTy RMR) "derive.umap fails to insert coersions to RMR", - std.assert-ok! (coq.elaborate-skeleton UR MRRMKRTy MRRMKR) "derive.umap fails to insert coersions to MRRMKR". - % TyParamNo UMapTy IndL IndR Rel IndMap MR RM MRRMK pred implement-umap i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:term, o:term. % implement-umap _ _ _ _ _ _ _ _ {{ Type }}. @@ -58,12 +45,10 @@ implement-umap N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ pr coq.mk-app IndL [t1] (NIndL t1), coq.mk-app IndR [t2] (NIndR t2), coq.mk-app Rel [t1,t2,ar] (NRel t1 t2 ar), - (UR t1 t2 ar ur) = {{ (@Param40.BuildRel _ _ lp:ar lp:ur (@Map0.BuildHas _ _ (@sym_rel lp:t1 lp:t2 lp:ar))) }}, - insert-coersions t1 t2 (UR t1 t2 ar ur) (MapR t1 t2 ar ur) (MRR t1 t2 ar ur) (RMR t1 t2 ar ur) (MRRMKR t1 t2 ar ur), - coq.mk-app IndMap [t1, t2, (MapR t1 t2 ar ur)] (NIndMap t1 t2 ar ur), - coq.mk-app MR [t1,t2, (MRR t1 t2 ar ur)] (NMR t1 t2 ar ur), - coq.mk-app RM [t1,t2, (RMR t1 t2 ar ur)] (NRM t1 t2 ar ur), - coq.mk-app MRRMK [t1,t2, (MRRMKR t1 t2 ar ur)] (NMRRMKR t1 t2 ar ur), + coq.mk-app IndMap [t1, t2, ar, ur] (NIndMap t1 t2 ar ur), + coq.mk-app MR [t1,t2, ar, ur] (NMR t1 t2 ar ur), + coq.mk-app RM [t1,t2, ar, ur] (NRM t1 t2 ar ur), + coq.mk-app MRRMK [t1,t2, ar, ur] (NMRRMKR t1 t2 ar ur), implement-umap M (Bo t1 t2 ar ur) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) (NIndMap t1 t2 ar ur) (NMR t1 t2 ar ur) (NRM t1 t2 ar ur) (NMRRMKR t1 t2 ar ur) (R t1 t2 ar ur). @@ -80,6 +65,7 @@ main GR Prefix Clauses :- std.do! [ std.assert! (mRRmK-db Ind MRRMK) "derive.umap: use derive.MRRMK before", mk-umap-type TyParamNo Arity Ind IndR UMapTySkel, std.assert-ok! (coq.elaborate-skeleton UMapTySkel _ UMapTy) "derive.umap generates illtyped type", + coq.say "UMapTy" UMapTy, implement-umap TyParamNo UMapTy Ind Ind IndR IndMap MR RM MRRMK RUMapSkel, std.assert-ok! (coq.elaborate-skeleton RUMapSkel _ RUMap) "derive.umap generates illtyped term", NameUMap is Prefix ^ "umap", diff --git a/std/algo/tests/test_map4.v b/std/algo/tests/test_map4.v index ce0a2d9b..452828e6 100644 --- a/std/algo/tests/test_map4.v +++ b/std/algo/tests/test_map4.v @@ -21,22 +21,23 @@ Elpi derive Nat. Check Nat_mRRmK : forall n1 n2 nR, Nat_mR n1 n2 (Nat_Rm n1 n2 nR) = nR. Elpi derive Box. -Check Box_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall (b1 : Box A1) (b2 : Box A2) (bR : Box_R A1 A2 AR b1 b2), - Box_mR A1 A2 AR b1 b2 (Box_Rm A1 A2 AR b1 b2 bR) = bR. +Check Box_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM : Map4.Has AR), forall (b1 : Box A1) (b2 : Box A2) (bR : Box_R A1 A2 AR b1 b2), + Box_mR A1 A2 AR AM b1 b2 (Box_Rm A1 A2 AR AM b1 b2 bR) = bR. Elpi derive Option. -Check Option_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall o1 o2 oR, Option_mR A1 A2 AR o1 o2 (Option_Rm A1 A2 AR o1 o2 oR) = oR. +Check Option_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM : Map4.Has AR), + forall o1 o2 oR, Option_mR A1 A2 AR AM o1 o2 (Option_Rm A1 A2 AR AM o1 o2 oR) = oR. Elpi derive Prod. -Check Prod_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2) B1 B2 (BR : Param40.Rel B1 B2), - forall p1 p2 pR, Prod_mR A1 A2 AR B1 B2 BR p1 p2 (Prod_Rm A1 A2 AR B1 B2 BR p1 p2 pR) = pR. +Check Prod_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM : Map4.Has AR) B1 B2 (BR : B1 -> B2 -> Type) (BM : Map4.Has BR), + forall p1 p2 pR, Prod_mR A1 A2 AR AM B1 B2 BR BM p1 p2 (Prod_Rm A1 A2 AR AM B1 B2 BR BM p1 p2 pR) = pR. Elpi derive ThreeTypes. Check ThreeTypes_mRRmK : -forall A1 A2 (AR : Param40.Rel A1 A2), -forall B1 B2 (BR : Param40.Rel B1 B2), -forall C1 C2 (CR : Param40.Rel C1 C2), - forall t1 t2 tR, ThreeTypes_mR A1 A2 AR B1 B2 BR C1 C2 CR t1 t2 (ThreeTypes_Rm A1 A2 AR B1 B2 BR C1 C2 CR t1 t2 tR) = tR. +forall A1 A2 (AR : A1 -> A2 -> Type) (AM : Map4.Has AR), +forall B1 B2 (BR : B1 -> B2 -> Type) (BM : Map4.Has BR), +forall C1 C2 (CR : C1 -> C2 -> Type) (CM : Map4.Has CR), + forall t1 t2 tR, ThreeTypes_mR A1 A2 AR AM B1 B2 BR BM C1 C2 CR CM t1 t2 (ThreeTypes_Rm A1 A2 AR AM B1 B2 BR BM C1 C2 CR CM t1 t2 tR) = tR. Elpi derive List. -Check List_mRRmK : forall A1 A2 (AR : Param40.Rel A1 A2), forall l1 t2 lR, List_mR A1 A2 AR l1 t2 (List_Rm A1 A2 AR l1 t2 lR) = lR. \ No newline at end of file +Check List_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM : Map4.Has AR), forall l1 t2 lR, List_mR A1 A2 AR AM l1 t2 (List_Rm A1 A2 AR AM l1 t2 lR) = lR. \ No newline at end of file From 28303154c78f7f35318220fd9a0d801f8b2dabb3 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Thu, 26 Feb 2026 17:26:38 +0100 Subject: [PATCH 17/42] generalizing umap program so it generates mapsN instead of just Map4 generating all mapN.Has preservation for inductives and storing them in trocq.db fixing build + generalizing rel44 generating ParamNM.Rel preservation for param-class of all kind --- elpi/database.elpi | 13 ++++ std/_CoqProject | 5 +- std/algo/detailed/Detailed_nm_inm.v | 62 ++++++++++++++++++ std/algo/elpi/common_algo.elpi | 56 ++++++++++------ std/algo/elpi/rel44.elpi | 68 ++++++++++++-------- std/algo/elpi/umap.elpi | 99 +++++++++++++++++------------ std/algo/tests/test_Rel44.v | 6 +- std/algo/tests/test_umap.v | 34 ++++++---- std/algo/theories/Rel40.v | 64 ------------------- std/algo/theories/Rel44.v | 23 ++----- std/algo/theories/umap.v | 20 ++++-- 11 files changed, 261 insertions(+), 189 deletions(-) create mode 100644 std/algo/detailed/Detailed_nm_inm.v delete mode 100644 std/algo/theories/Rel40.v diff --git a/elpi/database.elpi b/elpi/database.elpi index 4a7c515d..757896d3 100644 --- a/elpi/database.elpi +++ b/elpi/database.elpi @@ -23,6 +23,19 @@ pred map->class o:map-class, o:gref. % Given the class M, obtain {{indc_mapM}} pred map-class->indc-class o:map-class, o:gref. +% Given an inductive I and class M, obtain a proof that M has [|I|] +pred map-ind i:term, i:map-class, o:term. + +% Given an inductive I and class M, checks if M has [|I|] has been derived +pred map-ind-done o:inductive. + +% Given an inductive I and ParamNM, obtain a proof that +% given Tys1 NM related Tys2 then I Tys2 is NM related to I Tys2 +pred param-ind i:term, i:param-class, o:term. + +% Given an inductive and class M, checks if M has [|I|] has been derived +pred param-ind-done o:inductive. + % Given the class M, obtain {{Id_MapM}} pred id-map o:map-class, o:constant. diff --git a/std/_CoqProject b/std/_CoqProject index 1768b329..8c561075 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -52,6 +52,5 @@ algo/theories/map4.v algo/tests/test_map4.v algo/theories/umap.v algo/tests/test_umap.v -algo/theories/Rel40.v -algo/tests/test_Rel40.v -algo/theories/Rel44.v \ No newline at end of file +algo/theories/Rel44.v +algo/tests/test_Rel44.v \ No newline at end of file diff --git a/std/algo/detailed/Detailed_nm_inm.v b/std/algo/detailed/Detailed_nm_inm.v new file mode 100644 index 00000000..43c7a676 --- /dev/null +++ b/std/algo/detailed/Detailed_nm_inm.v @@ -0,0 +1,62 @@ + +From Trocq Require Import map4 umap Rel40 symK RsymK. +Import HoTTNotations. +From Trocq Require Import coverage. +Unset Uniform Inductive Parameters. + +Require Import Stdlib Hierarchy Param_lemmas. +Elpi derive List. + +(* From Trocq Require Import Hierarchy. *) +Require Import ssreflect. + +Lemma M1_List : forall A B (AR : A -> B -> Type) (AM : Map1.Has AR), + Map1.Has (List_R A B AR). +move=> A B AR M1. +apply Map1.BuildHas. +apply (List_mymap A B AR M1). +Set Printing All. +Show Proof. +Qed. +Lemma M2a_List : forall A B (AR : A -> B -> Type) (AM : Map2a.Has AR), + Map2a.Has (List_R A B AR). +move=> A B AR M1. +apply (Map2a.BuildHas _ _ _ (List_mymap A B AR M1) (List_mR A B AR M1)). +Show Proof. +Qed. +Lemma M2b_List : forall A B (AR : A -> B -> Type) (AM : Map2b.Has AR), + Map2b.Has (List_R A B AR). +move=> A B AR M1. +apply (Map2b.BuildHas _ _ _ (List_mymap A B AR M1) (List_Rm A B AR M1)). +Show Proof. +Qed. + +Lemma M3_List : forall A B (AR : A -> B -> Type) (AM : Map3.Has AR), + Map3.Has (List_R A B AR). +move=> A B AR M1. +apply (Map3.BuildHas _ _ _ (List_mymap A B AR M1) (List_mR A B AR M1) (List_Rm A B AR M1)). +Show Proof. +Qed. + +Lemma M4_List : forall A B (AR : A -> B -> Type) (AM : Map4.Has AR), + Map4.Has (List_R A B AR). +move=> A B AR M1. +About Map4.BuildHas. +About Map3.BuildHas. +apply (@Map4.BuildHas _ _ _ (List_mymap A B AR M1) (List_mR A B AR M1) (List_Rm A B AR M1) (List_mRRmK A B AR M1)). +Show Proof. +Qed. + +Lemma p42a_list : forall A B (AR : Param42a.Rel A B), Param42a.Rel (List A) (List B). +Proof. +move=> A B [R coM contraM]. +unshelve econstructor. +- exact: List_R. +- by apply List_umap. +- +unshelve eapply eq_Map2a. +exact (List_R B A (sym_rel R)). +exact (List_rsymK B A (sym_rel R)). +by apply M2a_List. +Show Proof. +Qed. \ No newline at end of file diff --git a/std/algo/elpi/common_algo.elpi b/std/algo/elpi/common_algo.elpi index d961dc08..58fee178 100644 --- a/std/algo/elpi/common_algo.elpi +++ b/std/algo/elpi/common_algo.elpi @@ -1,20 +1,24 @@ namespace derive.common-algo { +kind param-surgery type. +type raw param-surgery. +type refine param-surgery. +type subst param-surgery. + pred rel-mode i:int o:term. +% 0 - 4 could be merged for the change on the type parameters, but they have a different conclusion rel-mode 0 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map1.Has AR) (Rest : Type), Rest }}. % my-map -%rel-mode 0 {{ fun (A B : Type) (AR : A -> B -> Type) (Rest : Type)=> Map1.Has }}. % my-map rel-mode 1 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map2a.Has AR) (Rest : Type), Rest }}. % mR -%rel-mode 1 {{ Map2a.Has }}. % mR rel-mode 2 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map2b.Has AR) (Rest : Type), Rest }}. % Rm rel-mode 3 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map3.Has AR) (Rest : Type), Rest }}. % _ rel-mode 4 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map4.Has AR) (Rest : Type), Rest }}. % mRRmK -% the following 3 don't require extra assumption on relation and should be processed differently +% 5 - 7 don't require extra assumption, the only changes happen on the conclusion rel-mode 5 {{ fun (A B : Type)=> A -> B -> Type }}. % sym rel-mode 6 {{ fun (A B : Type)=> A -> B -> Type }}. % symK rel-mode 7 {{ fun (A B : Type)=> A -> B -> Type }}. % rsymK -% the following one should be moved to another file. -rel-mode 8 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map2a.Has AR) (Rest : Type), Rest }}. % +% substitutes the relation of type (A -> B -> Type) for (AR A B), which is provided on the client side +rel-mode 8 {{ forall (A B : Type) (AR : Type -> Type -> Type), (AR A B) }}. pred swap i:term, i:term, i:bool, o:term, o:term. swap A B tt B A. @@ -62,7 +66,7 @@ clean-l [A1, A2, AR, _ | L2] [A1,A2,AR | R] :- % Returns the type of map in R for T % Does it add an extra hyp on the relation? % X is the first inductive, Y is the second inductive. -pred mk-mR-type-priv i:int, i:term, i:term, i:term, i:term, i:int, i:list term, i: (pred i:term, o:term), i: (pred i:term, o:term), i:bool, o:term. +pred mk-mR-type-priv i:int, i:term, i:term, i:term, i:term, i:int, i:list term, i: (pred i:term, o:term), i: (pred i:term, o:term), i:param-surgery, o:term. % Introducing X and Y. % The RHS of the equality is Y. mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ _ @@ -111,9 +115,10 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) RSym _ Rel 7 LRev _ _ _ coq.mk-app Rel {std.append L2 [y,x]} (RelTy2 x y), RSkel x y = {{ lp:RSym lp:{{RelTy2 x y}} lp:{{RelTy1 x y}} }}, whd1 (RSkel x y) (R x y). -mk-mR-type-priv 0 (prod _ ITyTy x\ prod _ ITyTy2 _) _ _ _ 8 _ _ _ _ +mk-mR-type-priv 0 (prod _ ITyTy x\ prod _ ITyTy2 _) _ RelSTy _ 8 _ _ _ _ R :- - coq.mk-app { rel-mode 8 } [ITyTy, ITyTy2] R. + rel-mode 8 ARSkel, + coq.subst-prod [ITyTy, ITyTy2, RelSTy] ARSkel R. % TODO: remove use of MR-DB, try just pass the MR and RM mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) SymC _ Rel 6 LRev _ _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ prod `IR` (RelTy x y) iR\ (R x y iR)) :- @@ -130,7 +135,7 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) SymC _ Rel 6 LRev _ _ _ % Process two type parameters + 1 relation at a time. % Apply these parameters to the LHS of the equation. % This branch deals with adding the additional hypothesis in case the input boolean is set. -mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB tt +mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB refine (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ prod NM (MTy a1 a2 ar) am\ (Rest a1 a2 ar am)) :- M is N - 1, rel-mode Swap ARSkel, @@ -138,44 +143,53 @@ mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ pi a1 a2 ar am\ sigma NewL\ std.append [am,ar,a2,a1] L NewL, - mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR-DB RM-DB tt (R a1 a2 ar am), + mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR-DB RM-DB refine (R a1 a2 ar am), coq.subst-prod [a1, a2, ar] ARSkel (prod _ (MTy a1 a2 ar) _), coq.subst-prod [a1, a2, ar, am, (R a1 a2 ar am)] ARSkel (Rest a1 a2 ar am). % This branch deals with the branch when the boolean is unset. -mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB ff +mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB raw (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- M is N - 1, pi a1 a2 ar\ sigma NewL\ std.append [ar,a2,a1] L NewL, - mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR-DB RM-DB ff (R a1 a2 ar). + mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR-DB RM-DB raw (R a1 a2 ar). +mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML RelSTy Rel Swap L MR-DB RM-DB subst + (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (NewARTy a1 a2) ar\ (R a1 a2 ar)) :- + M is N - 1, + rel-mode Swap ARSkel, + pi a1 a2 ar\ + sigma NewL\ + std.append [ar,a2,a1] L NewL, + coq.subst-prod [a1, a2, RelSTy] ARSkel (NewARTy a1 a2), + mk-mR-type-priv M (Bo a1 a2 ar) ML RelSTy Rel Swap NewL MR-DB RM-DB subst (R a1 a2 ar). pred mk-mR-type-mR i:int, i:term, i:term, i:term, i:term, o:term. mk-mR-type-mR N T ML MR Rel RTy :- - mk-mR-type-priv N T ML MR Rel 1 [] _ _ tt RTy. + mk-mR-type-priv N T ML MR Rel 1 [] _ _ refine RTy. pred mk-mR-type-Rm i:int, i:term, i:term, i:term, i:term, o:term. mk-mR-type-Rm N T ML MR Rel R :- - mk-mR-type-priv N T ML MR Rel 2 [] _ _ tt R. + mk-mR-type-priv N T ML MR Rel 2 [] _ _ refine R. pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:(pred i:term, o:term) , i: (pred i:term, o:term), o:term. mk-mR-type-mRRmK N T ML Rel MR-DB RM-DB R :- - mk-mR-type-priv N T ML _ Rel 4 [] MR-DB RM-DB tt R. + mk-mR-type-priv N T ML _ Rel 4 [] MR-DB RM-DB refine R. pred mk-mR-type-sym i:int, i:term, i:term, o:term. mk-mR-type-sym N T Rel R :- - mk-mR-type-priv N T _ _ Rel 5 [] _ _ ff R. + mk-mR-type-priv N T _ _ Rel 5 [] _ _ raw R. pred mk-mR-type-symK i:int, i:term, i:term, i:term, o:term. mk-mR-type-symK N T Rel Sym R :- - mk-mR-type-priv N T Sym _ Rel 6 [] _ _ ff R. + mk-mR-type-priv N T Sym _ Rel 6 [] _ _ raw R. pred mk-mR-type-rsymK i:int, i:term, i:term, i:term, o:term. mk-mR-type-rsymK N T Rel RSym R :- - mk-mR-type-priv N T RSym _ Rel 7 [] _ _ ff R. + mk-mR-type-priv N T RSym _ Rel 7 [] _ _ raw R. -pred mk-mR-type-rel44 i:int, i:term, i:term, o:term. -mk-mR-type-rel44 N T Rel R :- - mk-mR-type-priv N T _ _ Rel 8 [] _ _ tt R. +pred mk-mR-type-rel44 i:int, i:term, i:term, i:term, o:term. +mk-mR-type-rel44 N T Rel RelSTy R :- + mk-mR-type-priv N T _ RelSTy Rel 8 [] _ _ subst R. } \ No newline at end of file diff --git a/std/algo/elpi/rel44.elpi b/std/algo/elpi/rel44.elpi index fdd9d9f0..6fa8fb48 100644 --- a/std/algo/elpi/rel44.elpi +++ b/std/algo/elpi/rel44.elpi @@ -18,52 +18,70 @@ refine-Lsym [A1, A2, AR | L2] [_,_,_,Refined | L2Ref] Refiner Acc R :- std.append Acc [A1, A2, AR, RefinedContra] NewAcc, refine-Lsym L2 L2Ref Refiner NewAcc R. -% TyargNo, rel44 Type, mapi, eq_map, rsymK, list of args -pred implement-rel44 i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:list term, o:term. +% TyargNo, rel44 Type, mapnCov, mapmContra, eq_map, rsymK, list of args +pred implement-rel44 i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:list term, o:term. implement-rel44 0 _ - Mapi Eq_map RsymK CovariantNN ContravariantNN BuildNN LRev R :- + MapNCov MapMContra Eq_map RsymK CovariantNN ContravariantNN BuildNN LRev R :- !, std.rev LRev L, refine-covariant-tyargs L CovariantNN [] LCo, sym-tyargs L LSym, refine-Lsym LSym LCo ContravariantNN [] LContra, - coq.mk-app Mapi LCo MapCovariant, - coq.mk-app Mapi LContra MapContravariant, + coq.mk-app MapNCov LCo MapCovariant, + coq.mk-app MapMContra LContra MapContravariant, coq.mk-app RsymK LSym RsymKSym, - R = {{ lp:BuildNN lp:MapCovariant (lp:Eq_map lp:RsymKSym lp:MapContravariant )}}. + R = {{ lp:BuildNN _ _ _ lp:MapCovariant (lp:Eq_map lp:RsymKSym lp:MapContravariant )}}. implement-rel44 N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) - Mapi Eq_map RsymK CovariantNN ContravariantNN BuildNN L + MapNCov MapMContra Eq_map RsymK CovariantNN ContravariantNN BuildNN L (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- M is N - 1, @pi-decl AN1 ATy1 a1\ %A1 : Type @pi-decl AN2 ATy2 a2\ %A2 : Type - @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param00.Rel A1 A2 + @pi-decl ARN (ARTy a1 a2) ar\ % AR : ParamNM.Rel A1 A2 sigma NewL\ std.append [ar,a2,a1] L NewL, - implement-rel44 M (Bo a1 a2 ar) Mapi Eq_map RsymK CovariantNN ContravariantNN BuildNN NewL (R a1 a2 ar). + implement-rel44 M (Bo a1 a2 ar) MapNCov MapMContra Eq_map RsymK CovariantNN ContravariantNN BuildNN NewL (R a1 a2 ar). +pred get-eq-map i:map-class, o:term. +get-eq-map map0 {{ eq_Map0 }}. +get-eq-map map1 {{ eq_Map1 }}. +get-eq-map map2a {{ eq_Map2a }}. +get-eq-map map2b {{ eq_Map2b }}. +get-eq-map map3 {{ eq_Map3 }}. +get-eq-map map4 {{ eq_Map4 }}. -func main inductive, string -> list prop. -main GR Prefix Clauses :- std.do! [ - +pred generate-relNM i:inductive, i:param-class, o: term, o: term. +generate-relNM GR (pc N M as PC) ReTy Re :- coq.env.indt GR _ TyParamNo _ _ KNs KTys, Ind = (global (indt GR)), - std.assert! (param Ind Ind TR) "derive.rel44: use derive.param2 before", + std.assert! (param Ind Ind TR) "derive.relNM: use derive.param2 before", coq.typecheck TR TRTy _, - mk-mR-type-rel44 TyParamNo TRTy TR SymKTy, - std.assert-ok! (coq.elaborate-skeleton SymKTy _ SymKTyE) "derive.rel44 generates illtyped type", - std.assert! (umap-db Ind UmapI) "derive.rel44: use derive.umap before", - std.assert! (rsymK-db Ind RSymKInd) "derive.rel44: use derive.rsymK before", - Eq_map = {{ eq_Map4 }}, - implement-rel44 TyParamNo SymKTyE UmapI Eq_map RSymKInd (pglobal {{:gref Param44.covariant }} _) (pglobal {{:gref Param44.contravariant }} _) {{ MkUParam }} [] R, - std.assert-ok! (coq.elaborate-skeleton R SymKTyE Re) "derive.rel44 generates illtyped term", - Name is Prefix ^ "rel44", - coq.ensure-fresh-global-id Name FName, - coq.env.add-const FName Re SymKTyE _ C, + trocq.db.rel PC PRelNM BuildNM _ CovNM ContraNM, + mk-mR-type-rel44 TyParamNo TRTy TR (pglobal PRelNM _) RTy, + std.assert-ok! (coq.elaborate-skeleton RTy _ ReTy) "derive.relNM generates illtyped type", + std.assert! (trocq.db.map-ind Ind N UmapNCov) "derive.relNM: use derive.umap before", + std.assert! (trocq.db.map-ind Ind M UmapMContra) "derive.relNM: use derive.umap before", + std.assert! (rsymK-db Ind RSymKInd) "derive.relNM: use derive.rsymK before", + get-eq-map M Eq_map, + implement-rel44 TyParamNo ReTy UmapNCov UmapMContra Eq_map RSymKInd (pglobal CovNM _) (pglobal ContraNM _) (pglobal BuildNM _) [] R, + std.assert-ok! (coq.elaborate-skeleton R ReTy Re) "derive.relNM generates illtyped term". + +func main inductive, string -> list prop. +main GR Prefix Clauses :- std.do! [ I = global (indt GR), - Clauses = [rel44-done GR, rel44-db I (global (const C))], + std.fold {param-class.all-of-kind all} [] + (PC\ Cls\ Cls'\ + sigma N M C ReTy Re Name FName\ + (pc N M) = PC, + generate-relNM GR PC ReTy Re, + Name is Prefix ^ "rel" ^ {map-class.to_string N} ^ {map-class.to_string M}, + coq.ensure-fresh-global-id Name FName, + coq.env.add-const FName Re ReTy _ C, + Cls' = [trocq.db.param-ind I PC (global (const C))| Cls]) + RCls, + Clauses = [trocq.db.param-ind-done GR | RCls], std.forall Clauses (x\ - coq.elpi.accumulate _ "derive.rel44.db" (clause _ _ x) + coq.elpi.accumulate _ "trocq.db" (clause _ _ x) ), ]. diff --git a/std/algo/elpi/umap.elpi b/std/algo/elpi/umap.elpi index c37b7936..f1ba4b4d 100644 --- a/std/algo/elpi/umap.elpi +++ b/std/algo/elpi/umap.elpi @@ -9,9 +9,9 @@ namespace derive.umap { % TyArgs1 % TyArgs2 % ARArgs -pred mk-umap-type-priv i:int, i:term, i:term, i:term, i:term, o:term. -mk-umap-type-priv 0 _ IndL IndR Rel {{ @IsUMap lp:IndL lp:IndR lp:Rel}}. -mk-umap-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR Rel +pred mk-umap-type-priv i:int, i:term, i:term, i:term, i:term, i:term, o:term. +mk-umap-type-priv 0 _ IndL IndR Rel MTy {{ lp:MTy lp:IndL lp:IndR lp:Rel}}. +mk-umap-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR Rel MTy (prod TN1 Ty t1\ prod TN2 Ty t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- M is N - 1, gen-names-map TN TN1 TN2 TRN URN, @@ -19,24 +19,24 @@ mk-umap-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR Rel @pi-decl TN2 Ty t2\ (ARTy t1 t2) = {{ lp:t1 -> lp:t2 -> Type }}, @pi-decl TRN (ARTy t1 t2) ar\ - (UMTy t1 t2 ar) = {{ @IsUMap lp:t1 lp:t2 lp:ar }}, + (UMTy t1 t2 ar) = {{ lp:MTy lp:t1 lp:t2 lp:ar }}, @pi-decl URN (UMTy t1 t2 ar) ur\ coq.mk-app IndL [t1] (NIndL t1), coq.mk-app IndR [t2] (NIndR t2), coq.mk-app Rel [t1,t2,ar] (NRel t1 t2 ar), - mk-umap-type-priv M (Bo t1) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) (R t1 t2 ar ur). + mk-umap-type-priv M (Bo t1) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) MTy (R t1 t2 ar ur). -% TyParamNo Arity Ind Rel -pred mk-umap-type i:int, i:term, i:term, i:term, o:term. -mk-umap-type TyParamNo Arity Ind Rel R :- - mk-umap-type-priv TyParamNo Arity Ind Ind Rel R. +% TyParamNo Arity Ind MapTy Rel +pred mk-umap-type i:int, i:term, i:term, i:term, i:term, o:term. +mk-umap-type TyParamNo Arity Ind Rel MTy R :- + mk-umap-type-priv TyParamNo Arity Ind Ind Rel MTy R. -% TyParamNo UMapTy IndL IndR Rel IndMap MR RM MRRMK -pred implement-umap i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:term, o:term. +% TyParamNo UMapTy IndL IndR Rel listReqs IndMap MR RM MRRMK +pred implement-umap i:int, i:term, i:term, i:term, i:term, i: list term, i:term, o:term. % implement-umap _ _ _ _ _ _ _ _ {{ Type }}. -implement-umap 0 _ IndL IndR Rel IndMap MR RM MRRMK R :- - R = {{ @MkUMap lp:IndL lp:IndR lp:Rel lp:IndMap lp:MR lp:RM lp:MRRMK }}. -implement-umap N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (Bo t1 t2 ar ur)) IndL IndR Rel IndMap MR RM MRRMK (fun TN1 Ty1 t1\ fun TN2 Ty2 t2\ fun TRN (ARTy t1 t2) ar\ fun URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- +implement-umap 0 _ IndL IndR Rel Reqs BH R :- + coq.mk-app BH [IndL,IndR,Rel | Reqs] R. +implement-umap N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (Bo t1 t2 ar ur)) IndL IndR Rel Reqs BH (fun TN1 Ty1 t1\ fun TN2 Ty2 t2\ fun TRN (ARTy t1 t2) ar\ fun URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- M is N - 1, @pi-decl TN1 Ty1 t1\ @pi-decl TN2 Ty2 t2\ @@ -45,39 +45,60 @@ implement-umap N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ pr coq.mk-app IndL [t1] (NIndL t1), coq.mk-app IndR [t2] (NIndR t2), coq.mk-app Rel [t1,t2,ar] (NRel t1 t2 ar), - coq.mk-app IndMap [t1, t2, ar, ur] (NIndMap t1 t2 ar ur), - coq.mk-app MR [t1,t2, ar, ur] (NMR t1 t2 ar ur), - coq.mk-app RM [t1,t2, ar, ur] (NRM t1 t2 ar ur), - coq.mk-app MRRMK [t1,t2, ar, ur] (NMRRMKR t1 t2 ar ur), + std.map Reqs (x\ r\ sigma TMP\ coq.mk-app x [t1,t2,ar,ur] TMP, r = TMP) (NewReqs t1 t2 ar ur), implement-umap M (Bo t1 t2 ar ur) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) - (NIndMap t1 t2 ar ur) (NMR t1 t2 ar ur) (NRM t1 t2 ar ur) (NMRRMKR t1 t2 ar ur) (R t1 t2 ar ur). + (NewReqs t1 t2 ar ur) BH (R t1 t2 ar ur). +pred build-has-of i:map-class, o:gref. +build-has-of M R :- + coq.locate {calc ("Map" ^ {map-class.to_string M} ^ ".BuildHas")} R. -func main inductive, string -> list prop. -main GR Prefix Clauses :- std.do! [ +pred map-reqs i:map-class, i:term, o: list term. +map-reqs map0 _ []. +map-reqs map1 Ind [IndMap] :- + std.assert! (mymap-def Ind IndMap) "derive.umap: use derive.mymap before". +map-reqs map2a Ind [MR | M1] :- + map-reqs map1 Ind M1, + std.assert! (mR-db Ind MR) "derive.umap: use derive.mR before". +map-reqs map2b Ind [RM | M1] :- + map-reqs map1 Ind M1, + std.assert! (rm-db Ind RM) "derive.umap: use derive.Rm before". +map-reqs map3 Ind [RM | M2a] :- + map-reqs map2a Ind M2a, + std.assert! (rm-db Ind RM) "derive.umap: use derive.Rm before". +map-reqs map4 Ind [MRRMK | M3] :- + map-reqs map3 Ind M3, + std.assert! (mRRmK-db Ind MRRMK) "derive.umap: use derive.MRRMK before". +pred implement-mapM i:map-class, i:inductive, o: term. +implement-mapM M GR RUMap :- coq.env.indt GR _ TyParamNo _ Arity _ _, Ind = (global (indt GR)), std.assert! (param Ind Ind IndR) "derive.umap: use derive.param2 before", - std.assert! (mymap-def Ind IndMap) "derive.umap: use derive.mymap before", - std.assert! (mR-db Ind MR) "derive.umap: use derive.mR before", - std.assert! (rm-db Ind RM) "derive.umap: use derive.Rm before", - std.assert! (mRRmK-db Ind MRRMK) "derive.umap: use derive.MRRMK before", - mk-umap-type TyParamNo Arity Ind IndR UMapTySkel, + std.rev {map-reqs M Ind} Reqs, + trocq.db.map->class M UM, + build-has-of M BH4, + % todo: address universe polymorphism + mk-umap-type TyParamNo Arity Ind IndR (pglobal UM _) UMapTySkel, std.assert-ok! (coq.elaborate-skeleton UMapTySkel _ UMapTy) "derive.umap generates illtyped type", - coq.say "UMapTy" UMapTy, - implement-umap TyParamNo UMapTy Ind Ind IndR IndMap MR RM MRRMK RUMapSkel, - std.assert-ok! (coq.elaborate-skeleton RUMapSkel _ RUMap) "derive.umap generates illtyped term", - NameUMap is Prefix ^ "umap", - coq.ensure-fresh-global-id NameUMap FNameUMap, - %coq.env.add-const FNameUMap RUMap UMapTy _ CUMap, - % todo: check RUMap against UMapTy modulo universes - coq.env.add-const FNameUMap RUMap _ _ CUMap, - ClausesUMap = [umap-done GR, umap-db Ind (global (const CUMap))], - Clauses = ClausesUMap, - std.forall Clauses (x\ - coq.elpi.accumulate _ "derive.umap.db" (clause _ _ x) - ), + implement-umap TyParamNo UMapTy Ind Ind IndR Reqs (pglobal BH4 _) RUMapSkel, + std.assert-ok! (coq.elaborate-skeleton RUMapSkel _ RUMap) "derive.umap generates illtyped term". + +func main inductive, string -> list prop. +main GR Prefix Clauses :- std.do! [ + Ind = (global (indt GR)), + std.fold {map-class.all-of-kind all} [] (M\ C\ C'\ sigma RUMap NameUMap FNameUMap CUMap Entry\ + implement-mapM M GR RUMap, + NameUMap is Prefix ^ "map" ^ {map-class.to_string M}, + coq.ensure-fresh-global-id NameUMap FNameUMap, + coq.env.add-const FNameUMap RUMap _ _ CUMap, + Entry = trocq.db.map-ind Ind M (global (const CUMap)), + coq.elpi.accumulate _ "trocq.db" (clause _ _ Entry), + C' = [Entry | C] + ) MClauses, + DEntry = (trocq.db.map-ind-done GR), + coq.elpi.accumulate _ "trocq.db" (clause _ _ DEntry), + Clauses = [DEntry | MClauses], ]. } \ No newline at end of file diff --git a/std/algo/tests/test_Rel44.v b/std/algo/tests/test_Rel44.v index aecb8d5d..2323b926 100644 --- a/std/algo/tests/test_Rel44.v +++ b/std/algo/tests/test_Rel44.v @@ -1,5 +1,6 @@ -From Trocq Require Import coverage Rel44. +Require Import Database. +From Trocq Require Import coverage Rel44. Elpi derive False. Check False_rel44. @@ -32,4 +33,5 @@ Elpi derive ThreeTypes. Check ThreeTypes_rel44. Elpi derive List. -Check List_rel44. \ No newline at end of file +Check List_rel44. +Check List_rel2a2a. \ No newline at end of file diff --git a/std/algo/tests/test_umap.v b/std/algo/tests/test_umap.v index 9ff89c8a..e4080f08 100644 --- a/std/algo/tests/test_umap.v +++ b/std/algo/tests/test_umap.v @@ -1,37 +1,47 @@ +Require Import Database. From Trocq Require Import map4 umap. From Trocq Require Import coverage. Unset Uniform Inductive Parameters. Elpi derive False. -Check False_umap : IsUMap False_R. +Check False_map0 : Map0.Has False_R. +Check False_map1 : Map1.Has False_R. +Check False_map2a : Map2a.Has False_R. +Check False_map2b : Map2b.Has False_R. +Check False_map3 : Map3.Has False_R. +Check False_map4 : IsUMap False_R. Elpi derive Unit. -Check Unit_umap : IsUMap Unit_R. +Check Unit_map4 : IsUMap Unit_R. Elpi derive Bool. -Check Bool_umap : IsUMap Bool_R. +Check Bool_map4 : IsUMap Bool_R. Elpi derive Wrap. -Check Wrap_umap : IsUMap Wrap_R. +Check Wrap_map4 : IsUMap Wrap_R. Elpi derive WrapMore. -Check WrapMore_umap : IsUMap WrapMore_R. +Check WrapMore_map4 : IsUMap WrapMore_R. Elpi derive Nat. -Check Nat_umap : IsUMap Nat_R. +Check Nat_map4 : IsUMap Nat_R. Elpi derive Box. -Check Box_umap : forall A1 A2 AR UR, IsUMap (Box_R A1 A2 AR). -Print Box_umap. +Check Box_map4 : forall A1 A2 AR UR, IsUMap (Box_R A1 A2 AR). Elpi derive Option. -Check Option_umap : forall A1 A2 AR UR, IsUMap (Option_R A1 A2 AR). +Check Option_map4 : forall A1 A2 AR UR, IsUMap (Option_R A1 A2 AR). Elpi derive Prod. -Check Prod_umap : forall A1 A2 AR UR B1 B2 BR BUR, IsUMap (Prod_R A1 A2 AR B1 B2 BR). +Check Prod_map4 : forall A1 A2 AR UR B1 B2 BR BUR, IsUMap (Prod_R A1 A2 AR B1 B2 BR). Elpi derive ThreeTypes. -Check ThreeTypes_umap : forall A1 A2 AR UR B1 B2 BR BUR C1 C2 CR CUR, IsUMap (ThreeTypes_R A1 A2 AR B1 B2 BR C1 C2 CR). +Check ThreeTypes_map4 : forall A1 A2 AR UR B1 B2 BR BUR C1 C2 CR CUR, IsUMap (ThreeTypes_R A1 A2 AR B1 B2 BR C1 C2 CR). Elpi derive List. -Check List_umap : forall A1 A2 AR UR, IsUMap (List_R A1 A2 AR). \ No newline at end of file +Check List_map0 : forall A1 A2 AR UR, Map0.Has (List_R A1 A2 AR). +Check List_map1 : forall A1 A2 AR UR, Map1.Has (List_R A1 A2 AR). +Check List_map2a: forall A1 A2 AR UR, Map2a.Has (List_R A1 A2 AR). +Check List_map2b: forall A1 A2 AR UR, Map2b.Has (List_R A1 A2 AR). +Check List_map3: forall A1 A2 AR UR, Map3.Has (List_R A1 A2 AR). +Check List_map4: forall A1 A2 AR UR, IsUMap (List_R A1 A2 AR). \ No newline at end of file diff --git a/std/algo/theories/Rel40.v b/std/algo/theories/Rel40.v deleted file mode 100644 index 1485134d..00000000 --- a/std/algo/theories/Rel40.v +++ /dev/null @@ -1,64 +0,0 @@ -From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq Extra Dependency "algo/elpi/rel40.elpi" as Rel40. -From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. -From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. -From Trocq Require Import map4 umap. - - -Unset Uniform Inductive Parameters. - -(* todo: this function could be used in umap derivation *) -Definition Build40 (A B : Type) (R : A -> B -> Type) (UR : IsUMap R) : Param40.Rel A B := -(@Param40.BuildRel _ _ R UR (@Map0.BuildHas _ _ (@sym_rel A B R))). - -Elpi Db derive.rel40.db lp:{{ - % [rel40-db T D] links a type T to its corresponding Rel40. - pred rel40-db i:term, o:term. - - % [rel40-done T] mean T was already derived - pred rel40-done o:inductive. -}}. - -Elpi Command derive.Rel40. -Elpi Accumulate File derive_hook. -(* Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate Db derive.param2.db. -Elpi Accumulate Db Header derive.mymap.db. -Elpi Accumulate Db derive.mymap.db. -Elpi Accumulate Db Header derive.mR.db. -Elpi Accumulate Db derive.mR.db. -Elpi Accumulate Db Header derive.Rm.db. -Elpi Accumulate Db derive.Rm.db. -Elpi Accumulate Db Header derive.mRRmK.db. -Elpi Accumulate Db derive.mRRmK.db. *) -Elpi Accumulate Db Header derive.umap.db. -Elpi Accumulate Db derive.umap.db. -Elpi Accumulate File common. -Elpi Accumulate File algo_utils. - -Elpi Accumulate Db derive.rel40.db. -Elpi Accumulate File Rel40. -Elpi Accumulate lp:{{ - main [str I] :- !, coq.locate I (indt GR), - coq.gref->id (indt GR) Tname, - Prefix is Tname ^ "_", - derive.rel40.main GR Prefix _. - main _ :- usage. - - pred usage. - usage :- coq.error "Usage: derive.rel40 ". -}}. - - -Elpi Accumulate derive Db derive.rel40.db. -Elpi Accumulate derive File common. -Elpi Accumulate derive File algo_utils. -Elpi Accumulate derive File Rel40. - -Elpi Accumulate derive lp:{{ - -dep1 "rel40" "umap". -derivation (indt T) Prefix ff (derive "rel40" (derive.rel40.main T Prefix) (rel-done T)). - -}}. - diff --git a/std/algo/theories/Rel44.v b/std/algo/theories/Rel44.v index 1f7fcf2b..9826e994 100644 --- a/std/algo/theories/Rel44.v +++ b/std/algo/theories/Rel44.v @@ -10,9 +10,10 @@ Import HoTTNotations. From elpi.apps Require Import derive.legacy derive.param2. From Trocq Require Export Hierarchy. +Require Import Database. Unset Uniform Inductive Parameters. -Elpi Db derive.rel44.db lp:{{ +(* Elpi Db derive.rel44.db lp:{{ % [rel44 I S] links I inductive type, % with the function showing i1 i2, [| I |]^ i2 i1 <->> [| I |] i1 i2 @@ -20,7 +21,7 @@ Elpi Db derive.rel44.db lp:{{ % [rel44-done T K] means T K was already derived pred rel44-done o:inductive. -}}. +}}. *) Elpi Command derive.rel44. Elpi Accumulate File derive_hook. @@ -28,17 +29,10 @@ Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db Header derive.rsymK.db. Elpi Accumulate Db derive.rsymK.db. -Elpi Accumulate Db Header derive.umap.db. -Elpi Accumulate Db derive.umap.db. +Elpi Accumulate Db trocq.db. Elpi Accumulate File common. Elpi Accumulate File utils. -Elpi Accumulate Db Header derive.rel44.db. -Elpi Accumulate Db derive.rel44.db. - -Elpi Query lp:{{ - T = {{:gref Param44.covariant }}, - coq.say (pglobal T _). -}}. +Elpi Accumulate Db trocq.db. Elpi Accumulate File rel44. Elpi Accumulate lp:{{ @@ -55,12 +49,9 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -Elpi Accumulate derive Db Header derive.rel44.db. -Elpi Accumulate derive Db derive.rel44.db. Elpi Accumulate Db Header derive.rsymK.db. Elpi Accumulate Db derive.rsymK.db. -Elpi Accumulate Db Header derive.umap.db. -Elpi Accumulate Db derive.umap.db. +Elpi Accumulate Db trocq.db. Elpi Accumulate derive File common. Elpi Accumulate derive File utils. Elpi Accumulate derive File rel44. @@ -68,6 +59,6 @@ Elpi Accumulate derive lp:{{ dep1 "rel44" "rsymK". dep1 "rel44" "umap". -derivation (indt T) Prefix ff (derive "rel44" (derive.rel44.main T Prefix) (rel44-done T)). +derivation (indt T) Prefix ff (derive "rel44" (derive.rel44.main T Prefix) (trocq.db.param-ind-done T)). }}. diff --git a/std/algo/theories/umap.v b/std/algo/theories/umap.v index 70ca2c78..e33ab88b 100644 --- a/std/algo/theories/umap.v +++ b/std/algo/theories/umap.v @@ -3,15 +3,21 @@ From Trocq Extra Dependency "algo/elpi/umap.elpi" as umap. From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. From Trocq Require Import map4. +Require Import Database. Unset Uniform Inductive Parameters. -Elpi Db derive.umap.db lp:{{ +(* I have to use Trocq db due to a dependency of type declaration of predicates in umap-db *) +(* if the class file is accumulated in umap-db then accumulating trocq.db is an issue *) +(* Elpi Db derive.umap.db lp:{{ }}. +Elpi Accumulate derive.umap.db Db trocq.db. *) +(* Elpi Accumulate derive Db trocq.db. *) +(* Elpi Db derive.umap.db lp:{{ % [umap-db T D] - pred umap-db i:term, o:term. + pred umap-db i:term, i:map-class, o:term. % [umap-done T D] - pred umap-done o:inductive. -}}. + pred umap-done o:inductive, o:map-class. +}}. *) Elpi Command derive.umap. Elpi Accumulate File derive_hook. @@ -28,7 +34,7 @@ Elpi Accumulate Db derive.mRRmK.db. Elpi Accumulate File common. Elpi Accumulate File algo_utils. -Elpi Accumulate Db derive.umap.db. +Elpi Accumulate Db trocq.db. Elpi Accumulate File umap. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), @@ -41,7 +47,7 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.rel40 ". }}. -Elpi Accumulate derive Db derive.umap.db. +Elpi Accumulate derive Db trocq.db. Elpi Accumulate derive File common. Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File umap. @@ -49,6 +55,6 @@ Elpi Accumulate derive File umap. Elpi Accumulate derive lp:{{ dep1 "umap" "mRRmK". -derivation (indt T) Prefix ff (derive "umap" (derive.umap.main T Prefix) (umap-done T)). +derivation (indt T) Prefix ff (derive "umap" (derive.umap.main T Prefix) (trocq.db.map-ind-done T)). }}. From 7cacaf62ef7762b51bea4981a3809487eea9a450 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Fri, 13 Mar 2026 10:53:53 +0100 Subject: [PATCH 18/42] replacing supported generic files + their use in examples/std --- examples/list_option.v | 2 +- examples/std/Vector_tuple.v | 5 +- examples/std/flt3_step.v | 2 +- examples/std/int_to_Zp.v | 2 +- examples/std/square_and_cube_mod7.v | 2 +- generic/Param_Empty.v | 90 +++-------- generic/Param_bool.v | 88 +++-------- generic/Param_list.v | 231 ++++++++-------------------- generic/Param_nat.v | 128 +++------------ generic/Param_option.v | 141 ++++++----------- generic/Param_prod.v | 118 +------------- generic/Param_sum.v | 149 +----------------- generic/Param_vector.v | 41 ++--- std/algo/elpi/sym.elpi | 18 +-- std/algo/tests/coverage.v | 3 - 15 files changed, 235 insertions(+), 785 deletions(-) diff --git a/examples/list_option.v b/examples/list_option.v index bef50844..b883aca9 100644 --- a/examples/list_option.v +++ b/examples/list_option.v @@ -70,7 +70,7 @@ Proof. induction lR; simpl. - apply nilR. - apply consR. - + apply (fR a a' aR). + + apply (fR a1 a2 a_R). + apply IHlR. Defined. diff --git a/examples/std/Vector_tuple.v b/examples/std/Vector_tuple.v index 42746c83..c008e65e 100644 --- a/examples/std/Vector_tuple.v +++ b/examples/std/Vector_tuple.v @@ -15,6 +15,7 @@ From mathcomp Require Import ssreflect ssrfun. From Trocq Require Import Trocq. Set Universe Polymorphism. +Unset Universe Minimization ToSet. (* iterated tuple type *) @@ -349,6 +350,9 @@ Proof. - exact (@R_in_mapK_bv_bnat k). Defined. + +(* Set Printing All. +Set Printing Universes. *) Definition Param44_bnat_bv_d {k : nat} : Param44.Rel (bounded_nat k) (bitvector k). Proof. @@ -357,7 +361,6 @@ Proof. - exact (@Map4_bnat_bv k). - exact (@Map4_bv_bnat k). Defined. - Definition Param44_bnat_bv (k k' : nat) (kR : natR k k') : Param44.Rel (bounded_nat k) (bitvector k'). Proof. diff --git a/examples/std/flt3_step.v b/examples/std/flt3_step.v index 70982d08..a740b9bc 100644 --- a/examples/std/flt3_step.v +++ b/examples/std/flt3_step.v @@ -11,7 +11,7 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import all_boot all_algebra. From Trocq Require Import Stdlib Trocq. Import GRing.Theory. diff --git a/examples/std/int_to_Zp.v b/examples/std/int_to_Zp.v index 3ee876ec..0f982eda 100644 --- a/examples/std/int_to_Zp.v +++ b/examples/std/int_to_Zp.v @@ -11,7 +11,7 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import all_boot all_algebra. From Trocq Require Import Stdlib Trocq. Import GRing.Theory. Local Open Scope bool_scope. diff --git a/examples/std/square_and_cube_mod7.v b/examples/std/square_and_cube_mod7.v index 7a21635f..c1eb7964 100644 --- a/examples/std/square_and_cube_mod7.v +++ b/examples/std/square_and_cube_mod7.v @@ -11,7 +11,7 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import all_boot all_algebra. From Trocq Require Import Stdlib Trocq. Import GRing.Theory. diff --git a/generic/Param_Empty.v b/generic/Param_Empty.v index 3349a559..c001938b 100644 --- a/generic/Param_Empty.v +++ b/generic/Param_Empty.v @@ -14,73 +14,33 @@ Require Import ssreflect. Require Import Stdlib Hierarchy. -Set Universe Polymorphism. -Unset Universe Minimization ToSet. - Import HoTTNotations. -Inductive EmptyR : Empty -> Empty -> Type := . - -Definition map_Empty (e : Empty) : Empty := e. - -Definition map_in_R_Empty : forall (e e' : Empty), map_Empty e = e' -> EmptyR e e' := - fun e => match e with end. - -Definition R_in_map_Empty : forall (e e' : Empty), EmptyR e e' -> map_Empty e = e' := - fun e => match e with end. - -Definition R_in_mapK_Empty : forall (e e' : Empty) (eR : EmptyR e e'), - map_in_R_Empty e e' (R_in_map_Empty e e' eR) = eR := - fun e => match e with end. - -Definition Map0_Empty : Map0.Has EmptyR. -Proof. constructor. Defined. +Require Import Database. +From Trocq Require Import Rel44. -Definition Map1_Empty : Map1.Has EmptyR. -Proof. constructor. exact map_Empty. Defined. +(* translations of inductives in Prop is not yet supported, +but we can still generate everything for False by manually defining its parametricity translation and making it land in Type. *) +Inductive EmptyR : Empty -> Empty -> Type :=. +(* param2 does not handle universe polymorphic inductives. + Hence we have define EmptyR before seting Universe Polymorphism. *) +Elpi derive.param2.register "False" "EmptyR". -Definition Map2a_Empty : Map2a.Has EmptyR. -Proof. - unshelve econstructor. - - exact map_Empty. - - exact map_in_R_Empty. -Defined. - -Definition Map2b_Empty : Map2b.Has EmptyR. -Proof. - unshelve econstructor. - - exact map_Empty. - - exact R_in_map_Empty. -Defined. - -Definition Map3_Empty : Map3.Has EmptyR. -Proof. - unshelve econstructor. - - exact map_Empty. - - exact map_in_R_Empty. - - exact R_in_map_Empty. -Defined. - -Definition Map4_Empty : Map4.Has EmptyR. -Proof. - unshelve econstructor. - - exact map_Empty. - - exact map_in_R_Empty. - - exact R_in_map_Empty. - - exact R_in_mapK_Empty. -Defined. - -Definition Param01_Empty : Param01.Rel Empty Empty. -Proof. -unshelve econstructor; first exact: EmptyR. -- done. -- constructor; exact map_Empty. -Defined. - -Definition Param10_Empty : Param10.Rel Empty Empty. -Proof. -unshelve econstructor; first exact: EmptyR. -- constructor; exact map_Empty. -- done. -Defined. +Set Universe Polymorphism. +Unset Universe Minimization ToSet. +Elpi derive Empty. + +Check EmptyR : False -> False -> Type. +Check False_mymap : False -> False. +Check False_mR : forall (b b' : False) (e : False_mymap b = b'), EmptyR b b'. +Check False_Rm : forall (b b' : False) (bR : EmptyR b b'), False_mymap b = b'. +Check False_mRRmK : forall (b b' : False) (bR : EmptyR b b'), False_mR _ _ (False_Rm _ _ bR) = bR. +Check False_sym : forall (b b' : False) (bR : EmptyR b b'), EmptyR b' b. +Check False_symK : forall (b b' : False) (bR : EmptyR b b'), False_sym _ _ (False_sym _ _ bR) = bR. +Check False_rsymK : forall (b b' : False), sym_rel EmptyR b b' <->> EmptyR b b'. +Check False_map4 : Map4.Has EmptyR. +Check False_rel44 : Param44.Rel False False. + +Definition Param01_Empty := False_rel01. +Definition Param10_Empty := False_rel10. diff --git a/generic/Param_bool.v b/generic/Param_bool.v index ff44c3a2..6a00e2cb 100644 --- a/generic/Param_bool.v +++ b/generic/Param_bool.v @@ -19,69 +19,25 @@ Unset Universe Minimization ToSet. Import HoTTNotations. -Inductive BoolR : Bool -> Bool -> Type := - | falseR : BoolR false false - | trueR : BoolR true true. - -Definition map_Bool : Bool -> Bool := idmap. - -Definition map_in_R_Bool {b b' : Bool} (e : map_Bool b = b') : BoolR b b' := - match e with - | idpath => - match b with - | false => falseR - | true => trueR - end - end. - -Definition R_in_map_Bool {b b' : Bool} (bR : BoolR b b') : map_Bool b = b' := - match bR with - | falseR => idpath - | trueR => idpath - end. - -Definition R_in_mapK_Bool {b b' : Bool} (bR : BoolR b b') : - map_in_R_Bool (R_in_map_Bool bR) = bR := - match bR with - | falseR => idpath - | trueR => idpath - end. - -Definition Param_Bool_sym {b b' : Bool} (bR : BoolR b b') : BoolR b' b := - match bR with - | falseR => falseR - | trueR => trueR - end. - -Definition Param_Bool_sym_inv {b b' : Bool} (bR : BoolR b b') : - Param_Bool_sym (Param_Bool_sym bR) = bR := - match bR with - | falseR => idpath - | trueR => idpath - end. - -Definition BoolR_sym : forall (b b' : Bool), sym_rel BoolR b b' <->> BoolR b b'. -Proof. - intros b b'; unshelve eexists _,_ . - - apply Param_Bool_sym. - - apply Param_Bool_sym. - - intro bR. apply Param_Bool_sym_inv. -Defined. - -Definition Map4_Bool : Map4.Has BoolR. -Proof. - unshelve econstructor. - - exact map_Bool. - - exact @map_in_R_Bool. - - exact @R_in_map_Bool. - - exact @R_in_mapK_Bool. -Defined. - -Definition Param44_Bool : Param44.Rel Bool Bool. -Proof. - unshelve econstructor. - - exact BoolR. - - exact Map4_Bool. - - apply (fun e => @eq_Map4 _ _ (sym_rel BoolR) BoolR e Map4_Bool). - apply BoolR_sym. -Defined. +Require Import Database. +From Trocq Require Import Rel44. +Elpi derive Bool. +Definition BoolR := bool_R. +Definition trueR := true_R. + +Check bool_R : Bool -> Bool -> Type. +Check bool_mymap : Bool -> Bool. +Check bool_mR : forall (b b' : Bool) (e : bool_mymap b = b'), bool_R b b'. +Check bool_Rm : forall (b b' : Bool) (bR : bool_R b b'), bool_mymap b = b'. +Check bool_mRRmK : forall (b b' : Bool) (bR : bool_R b b'), bool_mR _ _ (bool_Rm _ _ bR) = bR. +Check bool_sym : forall (b b' : Bool) (bR : bool_R b b'), bool_R b' b. +Check bool_symK : forall (b b' : Bool) (bR : bool_R b b'), bool_sym _ _ (bool_sym _ _ bR) = bR. +Check bool_rsymK : forall (b b' : Bool), sym_rel bool_R b b' <->> bool_R b b'. +Check bool_map4 : Map4.Has bool_R. +Check bool_rel44 : Param44.Rel Bool Bool. + +Definition Param44_Bool := bool_rel44. +Set Printing All. +Set Printing Universes. +Print bool_rel44. +Print Universes Subgraph (bool_rel44.u0 bool_rel44.u1). diff --git a/generic/Param_list.v b/generic/Param_list.v index e5c82067..5b2c9fcd 100644 --- a/generic/Param_list.v +++ b/generic/Param_list.v @@ -20,173 +20,74 @@ Set Asymmetric Patterns. Import HoTTNotations. -Inductive listR (A A' : Type) (AR : A -> A' -> Type) : list A -> list A' -> Type := - | nilR : listR A A' AR (@nil A) (@nil A') - | consR : - forall (a : A) (a' : A') (aR : AR a a') - (l : list A) (l' : list A') (lR : listR A A' AR l l'), - listR A A' AR (cons a l) (cons a' l'). - -Definition map_list (A A' : Type) (AR : Param10.Rel A A') : list A -> list A' := - fix F (l : list A) : list A' := - match l with - | nil => nil - | cons a l => cons (map AR a) (F l) - end. - -Definition map_in_R_list (A A' : Type) (AR : Param2a0.Rel A A') : - forall (l : list A) (l' : list A'), map_list A A' AR l = l' -> listR A A' AR l l' := - fun l l' e => - match e with - | idpath => - (fix F l : listR A A' AR l (map_list A A' AR l) := - match l with - | nil => nilR A A' AR - | cons a l => - consR A A' AR - a (map AR a) (map_in_R AR a (map AR a) idpath) - l (map_list A A' AR l) (F l) - end) l - end. - -Definition R_in_map_list (A A' : Type) (AR : Param2b0.Rel A A') : - forall (l : list A) (l' : list A'), listR A A' AR l l' -> map_list A A' AR l = l' := - fix F l l' lR := - match lR with - | nilR => idpath - | consR a a' aR l l' lR => - match R_in_map AR a a' aR with - | idpath => - match F l l' lR with - | idpath => idpath - end - end - end. - -Definition Map2a_list (A A' : Type) (AR : Param2a0.Rel A A') : Map2a.Has (listR A A' AR). -Proof. - unshelve econstructor. - - exact (map_list A A' AR). - - exact (map_in_R_list A A' AR). -Defined. - -Definition Map2b_list (A A' : Type) (AR : Param2b0.Rel A A') : Map2b.Has (listR A A' AR). -Proof. - unshelve econstructor. - - exact (map_list A A' AR). - - exact (R_in_map_list A A' AR). -Defined. - -Definition Map3_list (A A' : Type) (AR : Param30.Rel A A') : Map3.Has (listR A A' AR). -Proof. - unshelve econstructor. - - exact (map_list A A' AR). - - exact (map_in_R_list A A' AR). - - exact (R_in_map_list A A' AR). -Defined. - -Definition Map4_list (A A' : Type) (AR : Param40.Rel A A') : Map4.Has (listR A A' AR). -Proof. - unshelve econstructor. - - exact (map_list A A' AR). - - exact (map_in_R_list A A' AR). - - exact (R_in_map_list A A' AR). - - move=> a b; elim => //= {}a {}a' aR l l' lR /=. - elim: {2}_ / => //=. - case: _ / (R_in_map_list A A' AR l l' lR) => {l' lR}. - rewrite -{2}[aR](R_in_mapK AR). - by case: _ / (R_in_map AR a a' aR). -Qed. - -Definition listR_flip (A A' : Type) (AR : A -> A' -> Type) : - forall (l : list A) (l' : list A'), listR A A' AR l l' -> listR A' A (sym_rel AR) l' l := - fix F l l' lR := - match lR with - | nilR => nilR A' A (sym_rel AR) - | consR a a' aR l l' lR => - consR A' A (sym_rel AR) a' a aR l' l (F l l' lR) - end. - -Definition listR_flipK (A A' : Type) (AR : A -> A' -> Type) : - forall (l : list A) (l' : list A') (lR : listR A A' AR l l'), - listR_flip A' A (sym_rel AR) l' l (listR_flip A A' AR l l' lR) = lR := - fix F l l' lR := - match lR with - | nilR => idpath - | consR a a' aR l l' lR => - ap (fun lR => consR A A' AR a a' aR l l' lR) (F l l' lR) - end. - -Definition listR_sym (A A' : Type) (AR : A -> A' -> Type) : - forall (l' : list A') (l : list A), - listR A A' AR l l' <->> listR A' A (sym_rel AR) l' l. -Proof. - intros l' l. - unshelve econstructor. - - exact (listR_flip A A' AR l l'). - - unshelve econstructor. - + exact (listR_flip A' A (sym_rel AR) l' l). - + exact (listR_flipK A A' AR l l'). -Defined. - -Definition Param00_list (A A' : Type) (AR : Param00.Rel A A') : Param00.Rel (list A) (list A'). -Proof. - unshelve econstructor. - - exact (listR A A' AR). - - constructor. - - constructor. -Defined. - -Definition Param42a_list (A A' : Type) (AR : Param42a.Rel A A') : Param42a.Rel (list A) (list A'). -Proof. - unshelve econstructor. - - exact (listR A A' AR). - - exact (Map4_list A A' AR). - - refine (eq_Map2a _ _). - + apply listR_sym. - + exact (Map2a_list A' A (Param2a2a_sym _ _ AR)). -Defined. - -Definition Param42b_list (A A' : Type) (AR : Param42b.Rel A A') : Param42b.Rel (list A) (list A'). -Proof. - unshelve econstructor. - - exact (listR A A' AR). - - exact (Map4_list A A' AR). - - refine (eq_Map2b _ _). - + apply listR_sym. - + exact (Map2b_list A' A (Param2b2b_sym _ _ AR)). -Defined. - -Definition Param2a4_list (A A' : Type) (AR : Param2a4.Rel A A') : - Param2a4.Rel (list A) (list A') := Param42a_sym _ _ (Param42a_list _ _ (Param2a4_sym _ _ AR)). - -Definition Param2b4_list (A A' : Type) (AR : Param2b4.Rel A A') : - Param2b4.Rel (list A) (list A') := Param42b_sym _ _ (Param42b_list _ _ (Param2b4_sym _ _ AR)). - -Definition Param33_list (A A' : Type) (AR : Param33.Rel A A') : Param33.Rel (list A) (list A'). -Proof. - unshelve econstructor. - - exact (listR A A' AR). - - exact (Map3_list A A' AR). - - refine (eq_Map3 _ _). - + apply listR_sym. - + exact (Map3_list A' A (Param33_sym _ _ AR)). -Defined. - -Definition Param44_list (A A' : Type) (AR : Param44.Rel A A') : Param44.Rel (list A) (list A'). -Proof. - unshelve econstructor. - - exact (listR A A' AR). - - exact (Map4_list A A' AR). - - refine (eq_Map4 _ _). - + apply listR_sym. - + exact (Map4_list A' A (Param44_sym _ _ AR)). -Defined. +Require Import Database. +From Trocq Require Import Rel44. +Elpi derive list. +Notation listR := list_R. +Notation nilR := nil_R. +Notation consR := cons_R. + +Check list_R : forall A1 A2 (AR : A1 -> A2 -> Type), list A1 -> list A2 -> Type. +Check list_mymap : forall A1 A2 (AR : A1 -> A2 -> Type), Map1.Has AR-> list A1 -> list A2. +Check list_mR : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map2a.Has AR), + forall l1 l2, list_mymap _ _ _ AM l1 = l2 -> list_R _ _ AR l1 l2. +Check list_Rm : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map2b.Has AR), + forall l1 l2, list_R _ _ AR l1 l2 -> list_mymap _ _ _ AM l1 = l2. +Check list_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map4.Has AR), + forall l1 l2 lR, list_mR _ _ _ AM _ _ (list_Rm _ _ _ AM _ _ lR) = lR. +Check list_sym : forall A1 A2 (A_R : A1 -> A2 -> Type) l1 l2, list_R A1 A2 A_R l1 l2 -> +list_R A2 A1 (sym_rel A_R) l2 l1. + +Check list_symK : forall (A1 A2 : Type) (A_R : A1 -> A2 -> Type) (s1 : list A1) +(s2 : list A2) (IR : list_R A1 A2 A_R s1 s2), + list_sym A2 A1 (sym_rel A_R) s2 s1 (list_sym A1 A2 A_R s1 s2 IR) = + IR. +Check list_rsymK : forall (A1 A2 : Type) (A_R : A1 -> A2 -> Type) (s1 : list A1) + (s2 : list A2), + list_R A2 A1 (sym_rel A_R) s2 s1 <->> list_R A1 A2 A_R s1 s2. +Check list_rel44 : + forall A1 A2 : Type, (A1 <=> A2)%P -> (list A1 <=> list A2)%P. + +Check list_map2a : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), +Map2a.Has AR -> Map2a.Has (list_R A1 A2 AR). + +Check list_map2b : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), +Map2b.Has AR -> Map2b.Has (list_R A1 A2 AR). + +Check list_map3 : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), +Map3.Has AR -> Map3.Has (list_R A1 A2 AR). + +Check list_map4 : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), +Map4.Has AR -> Map4.Has (list_R A1 A2 AR). + +Check list_rel00 : forall A1 A2 : Type, +Param00.Rel A1 A2 -> Param00.Rel (list A1) (list A2). + +Check list_rel42a : forall A1 A2 : Type, +Param42a.Rel A1 A2 -> Param42a.Rel (list A1) (list A2). + +Check list_rel42b : forall A1 A2 : Type, +Param42b.Rel A1 A2 -> Param42b.Rel (list A1) (list A2). + +Check list_rel2a4 : forall A1 A2 : Type, +Param2a4.Rel A1 A2 -> Param2a4.Rel (list A1) (list A2). + +Check list_rel2b4 : forall A1 A2 : Type, +Param2b4.Rel A1 A2 -> Param2b4.Rel (list A1) (list A2). + +Check list_rel33 : forall A1 A2 : Type, +Param33.Rel A1 A2 -> Param33.Rel (list A1) (list A2). + +Check list_rel44 : forall (A A' : Type) (AR : Param44.Rel A A'), Param44.Rel (list A) (list A'). + +Definition Param42b_list := list_rel42b. +Definition Param2a4_list := list_rel2a4. +Definition Param44_list := list_rel44. Definition Param_nil : forall (A A' : Type) (AR : Param00.Rel A A'), - listR A A' AR (@nil A) (@nil A') := @nilR. + list_R A A' AR (@nil A) (@nil A') := @nil_R. Definition Param_cons : forall (A A' : Type) (AR : Param00.Rel A A') (a : A) (a' : A') (aR : AR a a') - (l : list A) (l' : list A') (lR : listR A A' AR l l'), - listR A A' AR (cons a l) (cons a' l') := @consR. + (l : list A) (l' : list A') (lR : list_R A A' AR l l'), + list_R A A' AR (cons a l) (cons a' l') := @cons_R. diff --git a/generic/Param_nat.v b/generic/Param_nat.v index 5c31a198..2bcd14a6 100644 --- a/generic/Param_nat.v +++ b/generic/Param_nat.v @@ -19,112 +19,26 @@ Unset Universe Minimization ToSet. Import HoTTNotations. -Inductive natR : nat -> nat -> Type := - | OR : natR O O - | SR : forall (n n' : nat), natR n n' -> natR (S n) (S n'). - -(* From Rocq's stdlib *) -Fixpoint eqb n m : Bool := - match n, m with - | O, O => true - | O, S _ => false - | S _, O => false - | S n', S m' => eqb n' m' - end. - -Lemma uip_lifted_bool (b: Bool) (x1 x2 : is_true b): - x1 = x2. -Proof. - revert x1 x2. - case b=> /= ; case. - by case. -Qed. - -Lemma natR_irrelevant m n (nR nR' : natR m n) : nR = nR'. -Proof. -have @phi k l (r : natR k l) : is_true (eqb k l). -1: { - elim: r => {k l}; first by reflexivity. - move=> k l r e; exact: e. -} -have @psi k l (e : is_true (eqb k l)) : natR k l. - - elim: k l e => [| k ihk] l e. - + case: l e => [| l] // _; exact OR. - + case: l e => [| l] // e. - exact: SR (ihk _ e). - - have phiK k l r : psi k l (phi k l r) = r. - + elim: r => {k l} // k l r e /=. - by rewrite [X in SR _ _ X]e. - + rewrite -(phiK m n nR) -(phiK m n nR'). - suff -> : phi _ _ nR = phi _ _ nR' by []. - apply uip_lifted_bool. -Defined. - -Definition map_nat : nat -> nat := idmap. - -Definition map_in_R_nat : forall {n n' : nat}, map_nat n = n' -> natR n n' := - fun n n' e => - match e with - | idpath => - (fix F n := - match n with - | O => OR - | S m => SR m m (F m) - end) n - end. - -Definition R_in_map_nat : forall {n n' : nat}, natR n n' -> map_nat n = n' := - fix F n n' (nR : natR n n') : map_nat n = n' := - match nR with - | OR => idpath - | SR m m' mR => ap S (F m m' mR) - end. - -Definition R_in_mapK_nat : forall {n n' : nat} (nR : natR n n'), - map_in_R_nat (R_in_map_nat nR) = nR. -Proof. -by move=> n n'; case: _ / => //= {}n {}n' nR; apply: natR_irrelevant. -Qed. - -Definition Param_nat_sym {n n' : nat} : natR n n' -> natR n' n. -Proof. - intro nR. induction nR as [|m m' _ IH]. - - exact OR. - - exact (SR m' m IH). -Defined. - -Definition Param_nat_sym_inv {n n' : nat} : - forall (nR : natR n n'), Param_nat_sym (Param_nat_sym nR) = nR. -Proof. by elim => //= {}n {}n' nR ->. Defined. - -Definition natR_sym : forall (n n' : nat), sym_rel natR n n' <->> natR n n'. -Proof. - intros n n'; unshelve eexists _, _. - - apply Param_nat_sym. - - apply Param_nat_sym. - - intro nR. apply Param_nat_sym_inv. -Defined. - -Definition Map4_nat : Map4.Has natR. -Proof. - unshelve econstructor. - - exact map_nat. - - exact @map_in_R_nat. - - exact @R_in_map_nat. - - exact @R_in_mapK_nat. -Defined. - -Definition Param44_nat : Param44.Rel nat nat. -Proof. - unshelve econstructor. - - exact natR. - - exact Map4_nat. - - apply (fun e => @eq_Map4 _ _ (sym_rel natR) natR e Map4_nat). - apply natR_sym. -Defined. - -Definition Param00_nat : Param00.Rel nat nat := Param44_nat. -Definition Param2a0_nat : Param2a0.Rel nat nat := Param44_nat. +Require Import Database. +From Trocq Require Import Rel44. +Elpi derive nat. +Notation natR := nat_R. +Definition OR := O_R. +Definition SR := S_R. + +Check nat_R : nat -> nat -> Type. +Check nat_mymap : nat -> nat. +Check nat_mR : forall (b b' : nat) (e : nat_mymap b = b'), nat_R b b'. +Check nat_Rm : forall (b b' : nat) (bR : nat_R b b'), nat_mymap b = b'. +Check nat_mRRmK : forall (b b' : nat) (bR : nat_R b b'), nat_mR _ _ (nat_Rm _ _ bR) = bR. +Check nat_sym : forall (b b' : nat) (bR : nat_R b b'), nat_R b' b. +Check nat_symK : forall (b b' : nat) (bR : nat_R b b'), nat_sym _ _ (nat_sym _ _ bR) = bR. +Check nat_rsymK : forall (b b' : nat), sym_rel nat_R b b' <->> nat_R b b'. +Check nat_map4 : Map4.Has nat_R. +Check nat_rel44 : Param44.Rel nat nat. +Check nat_rel00 : Param00.Rel nat nat. +Check nat_rel2a0 : Param2a0.Rel nat nat. +Definition Param2a0_nat := nat_rel2a0. Definition Param_add : forall (n1 n1' : nat) (n1R : natR n1 n1') (n2 n2' : nat) (n2R : natR n2 n2'), @@ -134,4 +48,4 @@ Proof. induction n1R as [|n1 n1' n1R IHn1R]. - simpl. exact n2R. - simpl. apply SR. exact IHn1R. -Defined. +Defined. diff --git a/generic/Param_option.v b/generic/Param_option.v index 52a927d6..3c11ddca 100644 --- a/generic/Param_option.v +++ b/generic/Param_option.v @@ -18,104 +18,59 @@ Set Universe Polymorphism. Unset Universe Minimization ToSet. Import HoTTNotations. +Require Import Database. +From Trocq Require Import Rel44. +Elpi derive option. -Inductive optionR (A A' : Type) (AR : A -> A' -> Type) : - option A -> option A' -> Type := - | someR : - forall (a : A) (a' : A'), AR a a' -> - optionR A A' AR (Some a) (Some a') - | noneR : optionR A A' AR None None. +Check option_R : forall A1 A2 (AR : A1 -> A2 -> Type), option A1 -> option A2 -> Type. +Check option_mymap : forall A1 A2 (AR : A1 -> A2 -> Type), Map1.Has AR-> option A1 -> option A2. +Check option_mR : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map2a.Has AR), + forall l1 l2, option_mymap _ _ _ AM l1 = l2 -> option_R _ _ AR l1 l2. +Check option_Rm : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map2b.Has AR), + forall l1 l2, option_R _ _ AR l1 l2 -> option_mymap _ _ _ AM l1 = l2. +Check option_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map4.Has AR), + forall l1 l2 lR, option_mR _ _ _ AM _ _ (option_Rm _ _ _ AM _ _ lR) = lR. +Check option_sym : forall A1 A2 (A_R : A1 -> A2 -> Type) l1 l2, option_R A1 A2 A_R l1 l2 -> +option_R A2 A1 (sym_rel A_R) l2 l1. -Definition option_map : -forall (A A' : Type) (AR : Param10.Rel A A'), option A -> option A' := - fun A A' AR => - fun oa => - match oa in option _ return option A' with - | Some a => Some (map AR a) - | None => None - end. +Check option_symK : forall (A1 A2 : Type) (A_R : A1 -> A2 -> Type) (s1 : option A1) +(s2 : option A2) (IR : option_R A1 A2 A_R s1 s2), + option_sym A2 A1 (sym_rel A_R) s2 s1 (option_sym A1 A2 A_R s1 s2 IR) = + IR. +Check option_rsymK : forall (A1 A2 : Type) (A_R : A1 -> A2 -> Type) (s1 : option A1) + (s2 : option A2), + option_R A2 A1 (sym_rel A_R) s2 s1 <->> option_R A1 A2 A_R s1 s2. +Check option_rel44 : + forall A1 A2 : Type, (A1 <=> A2)%P -> (option A1 <=> option A2)%P. + +Check option_map2a : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), +Map2a.Has AR -> Map2a.Has (option_R A1 A2 AR). -Definition some_inj1 : -forall (A : Type) (a1 a2 : A), Some a1 = Some a2 -> a1 = a2 := - fun A a1 a2 e => - let proj1 (oa : option A) := - match oa with - | Some a => a - | None => a1 - end - in ap proj1 e. +Check option_map2b : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), +Map2b.Has AR -> Map2b.Has (option_R A1 A2 AR). -Definition exfalso_option_some_none : - forall (T : Type) (A : Type) (a : A), Some a = None -> T := - fun T A a e => - match e in @paths _ _ t - return - match t with - | Some _ => Unit - | _ => T - end - with - | idpath => tt - end. +Check option_map3 : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), +Map3.Has AR -> Map3.Has (option_R A1 A2 AR). -Definition exfalso_option_none_some : - forall (T : Type) (A : Type) (a : A), None = Some a -> T := - fun T A a e => - match e in @paths _ _ t - return - match t with - | None => Unit - | Some _ => T - end - with - | idpath => tt - end. +Check option_map4 : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), +Map4.Has AR -> Map4.Has (option_R A1 A2 AR). -Definition option_map_in_R : - forall (A A' : Type) (AR : Param2a0.Rel A A') - (oa : option A) (oa' : option A'), - option_map A A' AR oa = oa' -> optionR A A' AR oa oa' := - fun A A' AR => - fun oa oa' => - match oa with - | Some a => - match oa' with - | Some a' => - fun e => - someR A A' AR a a' (map_in_R AR a a' (some_inj1 A' (map AR a) a' e)) - | None => - fun e => - exfalso_option_some_none (optionR A A' AR (Some a) (None)) - A' (map AR a) e - end - | None => - match oa' with - | Some a' => - fun e => - exfalso_option_none_some (optionR A A' AR (None) (Some a')) - A' a' e - | None => fun e => noneR A A' AR - end - end. +Check option_rel00 : forall A1 A2 : Type, +Param00.Rel A1 A2 -> Param00.Rel (option A1) (option A2). -Definition option_R_in_map : - forall (A A' : Type) (AR : Param2b0.Rel A A') - (oa : option A) (oa' : option A'), - optionR A A' AR oa oa' -> option_map A A' AR oa = oa' - := - fun A A' AR => - fun oa oa' oaR => - match oaR in optionR _ _ _ oa oa' return option_map A A' AR oa = oa' with - | @someR _ _ _ a a' aR => - @transport A' (fun t => Some t = Some a') - a' (map AR a) (R_in_map AR a a' aR)^ - idpath - | @noneR _ _ _ => idpath - end. +Check option_rel42a : forall A1 A2 : Type, +Param42a.Rel A1 A2 -> Param42a.Rel (option A1) (option A2). -Definition option_R_in_mapK (A A' : Type) (AR : Param40.Rel A A') - (oa : option A) (oa' : option A') (oaR : optionR A A' AR oa oa') : - option_map_in_R A A' AR oa oa' (option_R_in_map A A' AR oa oa' oaR) = oaR. -Proof. -by case: oaR => [a a' aR|]//=; elim/(ind_map AR): _; rewrite transport_1. -Qed. +Check option_rel42b : forall A1 A2 : Type, +Param42b.Rel A1 A2 -> Param42b.Rel (option A1) (option A2). + +Check option_rel2a4 : forall A1 A2 : Type, +Param2a4.Rel A1 A2 -> Param2a4.Rel (option A1) (option A2). + +Check option_rel2b4 : forall A1 A2 : Type, +Param2b4.Rel A1 A2 -> Param2b4.Rel (option A1) (option A2). + +Check option_rel33 : forall A1 A2 : Type, +Param33.Rel A1 A2 -> Param33.Rel (option A1) (option A2). + +Check option_rel44 : forall (A A' : Type) (AR : Param44.Rel A A'), Param44.Rel (option A) (option A'). diff --git a/generic/Param_prod.v b/generic/Param_prod.v index 6788fb2e..f14b766e 100644 --- a/generic/Param_prod.v +++ b/generic/Param_prod.v @@ -19,117 +19,9 @@ Unset Universe Minimization ToSet. Import HoTTNotations. -Inductive prodR - {A A'} (AR : A -> A' -> Type) {B B'} (BR : B -> B' -> Type) : A * B -> A' * B' -> Type := - | pairR a a' (aR : AR a a') b b' (bR : BR b b') : prodR AR BR (a, b) (a', b'). +Require Import Database. +From Trocq Require Import Rel44. +Elpi derive prod. -Arguments pairR {A A' AR B B' BR} a a' aR b b' bR. - -(* *) - -Definition prod_map - (A A' : Type) (AR : Param10.Rel A A') (B B' : Type) (BR : Param10.Rel B B') : - A * B -> A' * B' := - fun p => - match p with - | (a, b) => (map AR a, map BR b) - end. - -(* *) - -Definition pair_inj1 A B (a1 a2 : A) (b1 b2 : B) : - (a1, b1) = (a2, b2) -> a1 = a2 := - fun e => - match e in _ = (a, b) return _ = a with - | @idpath _ _ => @idpath _ a1 - end. - -Definition pair_inj2 A B (a1 a2 : A) (b1 b2 : B) : - (a1, b1) = (a2, b2) -> b1 = b2 := - fun e => - match e in @paths _ _ (a, b) return _ = b with - | @idpath _ _ => @idpath _ b1 - end. - -Definition prod_map_in_R - (A A' : Type) (AR : Param2a0.Rel A A') (B B' : Type) (BR : Param2a0.Rel B B') : - forall p p', prod_map A A' AR B B' BR p = p' -> prodR AR BR p p' := - fun p p' => - match p with - | (a, b) => - match p' with - | (a', b') => - fun e => - pairR - a a' (map_in_R AR a a' (pair_inj1 A' B' (map AR a) a' (map BR b) b' e)) - b b' (map_in_R BR b b' (pair_inj2 A' B' (map AR a) a' (map BR b) b' e)) - end - end. - -(* *) - -Definition prod_R_in_map - (A A' : Type) (AR : Param2b0.Rel A A') (B B' : Type) (BR : Param2b0.Rel B B') : - forall p p', prodR AR BR p p' -> prod_map A A' AR B B' BR p = p' := - fun p p' r => - match r with - | pairR a a' aR b b' bR => - @transport _ (fun t => (t, map BR b) = (a', b')) _ _ (R_in_map AR a a' aR)^ - (@transport _ (fun t => (a', t) = (a', b')) _ _ (R_in_map BR b b' bR)^ idpath) - end. - -(* *) - -Definition prod_R_in_mapK - (A A' : Type) (AR : Param40.Rel A A') (B B' : Type) (BR : Param40.Rel B B') : - forall p p' (r : prodR AR BR p p'), - prod_map_in_R A A' AR B B' BR p p' (prod_R_in_map A A' AR B B' BR p p' r) = r. -Proof. -intros p p' []; rewrite /prod_R_in_map/=. -by elim/(ind_map AR): _; elim/(ind_map BR): _. -Qed. - -(* *) - -Definition Map0_prod A A' (AR : Param00.Rel A A') B B' (BR : Param00.Rel B B') : - Map0.Has (prodR AR BR). -Proof. constructor. Defined. - -Definition Map1_prod A A' (AR : Param10.Rel A A') B B' (BR : Param10.Rel B B') : - Map1.Has (prodR AR BR). -Proof. constructor. exact (prod_map A A' AR B B' BR). Defined. - -Definition Map2a_prod A A' (AR : Param2a0.Rel A A') B B' (BR : Param2a0.Rel B B') : - Map2a.Has (prodR AR BR). -Proof. - unshelve econstructor. - - exact (prod_map A A' AR B B' BR). - - exact (prod_map_in_R A A' AR B B' BR). -Defined. - -Definition Map2b_prod A A' (AR : Param2b0.Rel A A') B B' (BR : Param2b0.Rel B B') : - Map2b.Has (prodR AR BR). -Proof. - unshelve econstructor. - - exact (prod_map A A' AR B B' BR). - - exact (prod_R_in_map A A' AR B B' BR). -Defined. - -Definition Map3_prod A A' (AR : Param30.Rel A A') B B' (BR : Param30.Rel B B') : - Map3.Has (prodR AR BR). -Proof. - unshelve econstructor. - - exact (prod_map A A' AR B B' BR). - - exact (prod_map_in_R A A' AR B B' BR). - - exact (prod_R_in_map A A' AR B B' BR). -Defined. - -Definition Map4_prod A A' (AR : Param40.Rel A A') B B' (BR : Param40.Rel B B') : - Map4.Has (prodR AR BR). -Proof. - unshelve econstructor. - - exact (prod_map A A' AR B B' BR). - - exact (prod_map_in_R A A' AR B B' BR). - - exact (prod_R_in_map A A' AR B B' BR). - - exact (prod_R_in_mapK A A' AR B B' BR). -Defined. +Check prod_map4 : forall A A' (AR : A -> A' -> Type) (AM : Map4.Has AR) B B' (BR : B -> B' -> Type) (BM : Map4.Has BR), + Map4.Has (prod_R _ _ AR _ _ BR). \ No newline at end of file diff --git a/generic/Param_sum.v b/generic/Param_sum.v index 9d329da6..63681120 100644 --- a/generic/Param_sum.v +++ b/generic/Param_sum.v @@ -20,144 +20,11 @@ Set Asymmetric Patterns. Import HoTTNotations. -Inductive sumR - A A' (AR : A -> A' -> Type) B B' (BR : B -> B' -> Type) : A + B -> A' + B' -> Type := - | inlR a a' (aR : AR a a') : sumR A A' AR B B' BR (inl a) (inl a') - | inrR b b' (bR : BR b b') : sumR A A' AR B B' BR (inr b) (inr b'). - -(* *) - -Definition sum_map - (A A' : Type) (AR : Param10.Rel A A') (B B' : Type) (BR : Param10.Rel B B') : - A + B -> A' + B' := - fun p => - match p with - | inl a => inl (map AR a) - | inr b => inr (map BR b) - end. - -Definition inl_inj {A B} {a1 a2 : A} : - @inl A B a1 = inl a2 -> a1 = a2 := - fun e => - match e in @paths _ _ (inl a1) return _ = a1 with - | @idpath _ _ => @idpath _ a1 - end. - -Definition inr_inj {A B} {b1 b2 : B} : - @inr A B b1 = inr b2 -> b1 = b2 := - fun e => - match e in @paths _ _ (inr b1) return _ = b1 with - | @idpath _ _ => @idpath _ b1 - end. - -Definition inl_inr {A B a b} : @inl A B a = inr b -> False. -Proof. discriminate. Defined. - -Definition inr_inl {A B b a} : @inr A B b = inl a -> False. -Proof. discriminate. Defined. - -Definition sum_map_in_R - (A A' : Type) (AR : Param2a0.Rel A A') (B B' : Type) (BR : Param2a0.Rel B B') : - forall p p', sum_map A A' AR B B' BR p = p' -> sumR A A' AR B B' BR p p'. -Proof. -case=> [a|b] [a'|b']; do ?discriminate. -- by move=> /inl_inj<-; constructor; apply: map_in_R. -- by move=> /inr_inj<-; constructor; apply: map_in_R. -Defined. - -(* *) - -Definition sum_R_in_map - (A A' : Type) (AR : Param2b0.Rel A A') (B B' : Type) (BR : Param2b0.Rel B B') : - forall p p', sumR A A' AR B B' BR p p' -> sum_map A A' AR B B' BR p = p'. -Proof. -by move=> _ _ [a a' aR|b b' bR]/=; apply: ap; apply: R_in_map. -Defined. - -Definition sum_R_in_mapK - (A A' : Type) (AR : Param40.Rel A A') (B B' : Type) (BR : Param40.Rel B B') : - forall p p' (r : sumR A A' AR B B' BR p p'), - sum_map_in_R A A' AR B B' BR p p' (sum_R_in_map A A' AR B B' BR p p' r) = r. -Proof. - move=> _ _ [a a' aR|b b' bR]/=. - - by elim/(ind_map AR): _ => /=. - - by elim/(ind_map BR): _ => /=. -Qed. - -Definition Map0_sum A A' (AR : Param00.Rel A A') B B' (BR : Param00.Rel B B') : - Map0.Has (sumR A A' AR B B' BR). -Proof. constructor. Defined. - -Definition Map1_sum A A' (AR : Param10.Rel A A') B B' (BR : Param10.Rel B B') : - Map1.Has (sumR A A' AR B B' BR). -Proof. constructor. exact (sum_map A A' AR B B' BR). Defined. - -Definition Map2a_sum A A' (AR : Param2a0.Rel A A') B B' (BR : Param2a0.Rel B B') : - Map2a.Has (sumR A A' AR B B' BR). -Proof. - unshelve econstructor. - - exact (sum_map A A' AR B B' BR). - - exact (sum_map_in_R A A' AR B B' BR). -Defined. - -Definition Map2b_sum A A' (AR : Param2b0.Rel A A') B B' (BR : Param2b0.Rel B B') : - Map2b.Has (sumR A A' AR B B' BR). -Proof. - unshelve econstructor. - - exact (sum_map A A' AR B B' BR). - - exact (sum_R_in_map A A' AR B B' BR). -Defined. - -Definition Map3_sum A A' (AR : Param30.Rel A A') B B' (BR : Param30.Rel B B') : - Map3.Has (sumR A A' AR B B' BR). -Proof. - unshelve econstructor. - - exact (sum_map A A' AR B B' BR). - - exact (sum_map_in_R A A' AR B B' BR). - - exact (sum_R_in_map A A' AR B B' BR). -Defined. - -Definition Map4_sum A A' (AR : Param40.Rel A A') B B' (BR : Param40.Rel B B') : - Map4.Has (sumR A A' AR B B' BR). -Proof. - unshelve econstructor. - - exact (sum_map A A' AR B B' BR). - - exact (sum_map_in_R A A' AR B B' BR). - - exact (sum_R_in_map A A' AR B B' BR). - - exact (sum_R_in_mapK A A' AR B B' BR). -Defined. - -Definition sumR_flip {A A' : Type} (AR : A -> A' -> Type) - {B B' : Type} (BR : B -> B' -> Type) (s : A + B) (s' : A' + B') - (sR : sumR A A' AR B B' BR s s') : - sumR A' A (sym_rel AR) B' B (sym_rel BR) s' s := - match sR with - | inlR a a' aR => inlR A' A (sym_rel AR) B' B (sym_rel BR) a' a aR - | inrR b b' bR => inrR A' A (sym_rel AR) B' B (sym_rel BR) b' b bR - end. - -Definition sumR_flipK {A A' : Type} (AR : A -> A' -> Type) - {B B' : Type} (BR : B -> B' -> Type) (s : A + B) (s' : A' + B') - (sR : sumR A A' AR B B' BR s s') : - sumR_flip (sym_rel AR) (sym_rel BR) s' s (sumR_flip AR BR s s' sR) = sR. -Proof. case sR; constructor. Defined. - -Definition sumR_sym {A A' : Type} (AR : A -> A' -> Type) - {B B' : Type} (BR : B -> B' -> Type) (s : A + B) (s' : A' + B') : - sumR A A' AR B B' BR s s' <->> sumR A' A (sym_rel AR) B' B (sym_rel BR) s' s. -Proof. - unshelve econstructor. - - exact (sumR_flip AR BR s s'). - - unshelve econstructor. - + exact (sumR_flip (sym_rel AR) (sym_rel BR) s' s). - + exact (sumR_flipK AR BR s s'). -Defined. - -Definition Param01_sum A A' (AR : Param01.Rel A A') B B' (BR : Param01.Rel B B') : - Param01.Rel (A + B) (A' + B'). -exists (sumR A A' AR B B' BR). -- exact: Map0_sum. -- constructor. - exact (Map1.map _ (Map1_sum _ _ - (Param01_sym _ _ AR) _ _ (Param01_sym _ _ BR))). -Defined. +Require Import Database. +From Trocq Require Import Rel44. +Elpi derive sum. +Check sum_map4 : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), +IsUMap AR -> forall (B1 B2 : Type) (BR : B1 -> B2 -> Type), +IsUMap BR -> IsUMap (sum_R A1 A2 AR B1 B2 BR). + +Definition Param01_sum := sum_rel01. diff --git a/generic/Param_vector.v b/generic/Param_vector.v index 83a6404b..ca9230c8 100644 --- a/generic/Param_vector.v +++ b/generic/Param_vector.v @@ -96,8 +96,8 @@ Definition map : fun A A' AR => fix F n n' nR := match nR with - | OR => fun _ => nil - | SR m m' mR => fun v => cons (map AR (hd v)) (F m m' mR (tail v)) + | O_R => fun _ => nil + | S_R m m' mR => fun v => cons (map AR (hd v)) (F m m' mR (tail v)) end. Definition t0 {A} (v : t A O) : v = nil := match v in t _ m return @@ -169,36 +169,32 @@ Proof. by case: _ / R_in_map. Qed. -Definition Param_nat_symK m n (nR : natR m n) : nR = Param_nat_sym (Param_nat_sym nR). -Proof. by elim: nR => //= {}m {}n mn emn; apply: ap. Defined. - Definition tR_sym_f {A A' : Type} (AR : A -> A' -> Type) {n n' : nat} (nR : natR n n') {v : t A n} {v' : t A' n'} : - sym_rel (tR A A' AR n n' nR) v' v -> tR A' A (sym_rel AR) n' n (Param_nat_sym nR) v' v. + sym_rel (tR A A' AR n n' nR) v' v -> tR A' A (sym_rel AR) n' n (nat_sym _ _ nR) v' v. Proof. by elim=> //=; constructor. Defined. Definition tR_sym_t {A A' : Type} (AR : A -> A' -> Type) {n n' : nat} (nR : natR n n') {v' : t A' n'} {v : t A n} : - tR A A' AR n n' (Param_nat_sym (Param_nat_sym nR)) v v' -> tR A A' AR n n' nR v v'. + tR A A' AR n n' (nat_sym _ _ (nat_sym _ _ nR)) v v' -> tR A A' AR n n' nR v v'. Proof. apply: (transport (fun nR => tR _ _ _ _ _ nR _ _)). - symmetry; exact: Param_nat_symK. + exact: nat_symK. Defined. Definition tR_sym_tV {A A' : Type} (AR : A -> A' -> Type) {n n' : nat} (nR : natR n n') {v' : t A' n'} {v : t A n} : - tR A A' AR n n' nR v v' -> tR A A' AR n n' (Param_nat_sym (Param_nat_sym nR)) v v'. + tR A A' AR n n' nR v v' -> tR A A' AR n n' (nat_sym _ _ (nat_sym _ _ nR)) v v'. Proof. apply: (transport (fun nR => tR _ _ _ _ _ nR _ _)). -exact: Param_nat_symK. +symmetry; exact: nat_symK. Defined. -(* Definition tR_symK *) Lemma tR_sym_tK A A' AR n n' nR v v' (vR : tR A A' AR n n' - (Param_nat_sym (Param_nat_sym nR)) v v') : + (nat_sym _ _ (nat_sym _ _ nR)) v v') : tR_sym_tV AR nR (tR_sym_t AR nR vR) = vR. Proof. -by rewrite /tR_sym_t /tR_sym_tV -transport_pp concat_Vp. +by rewrite /tR_sym_t /tR_sym_tV -transport_pp concat_pV. Defined. Local Notation f := (tR_sym_f _ _). @@ -209,8 +205,17 @@ Definition tR_sym_fK {A A' : Type} (AR : A -> A' -> Type) {n n' : nat} (nR : nat (v : t A n) (v' : t A' n') (vR : tR A A' AR n n' nR v v') : g (f (f vR)) = vR. Proof. -elim: vR => // {}n {}n' {}nR a a' aR {}v {}v' vR {2}<-/=; rewrite /g /=. -by case: _ / Param_nat_symK (tR_sym_f _ _ _). +elim: vR => // {}n {}n' {}nR a a' aR {}v {}v' vR {2}<-/=; rewrite /g/=. +move: (tR_sym_f _ _ _)=> vR'; move: vR'. +move: ((nat_symK _ _ _))=> p. +by refine (match p as p0 in (_ = nRR) +return +forall vR' : tR A A' (sym_rel (sym_rel AR)) n n' (nat_sym n' n (nat_sym n n' nR)) v v', +transport _ (eq_ind nRR (fun t1 : nat_R n n' => S_R n n' t1 = S_R n n' nRR) 1 _ p0^) + (consR A A' (sym_rel (sym_rel AR)) n n' (nat_sym n' n (nat_sym n n' nR)) a a' aR v v' vR') += consR A A' AR n n' nRR a a' aR v v' (transport _ p0 vR') +with eq_refl => _ end +). Qed. Definition tR_sym_fE {A A' : Type} (AR : A -> A' -> Type) {n n' : nat} (nR : natR n n') @@ -220,7 +225,7 @@ Proof. by rewrite -{2}[vR]tR_sym_fK tR_sym_tK tR_sym_fK. Qed. Definition tR_sym (A A' : Type) (AR : A -> A' -> Type) (n n' : nat) (nR : natR n n') (v' : t A' n') (v : t A n) : - sym_rel (tR A A' AR n n' nR) v' v <->> tR A' A (sym_rel AR) n' n (Param_nat_sym nR) v' v. + sym_rel (tR A A' AR n n' nR) v' v <->> tR A' A (sym_rel AR) n' n (nat_sym _ _ nR) v' v. Proof. unshelve eexists _, _. - exact: tR_sym_f. @@ -249,9 +254,9 @@ Proof. - unshelve eapply (@eq_Map4 _ _ (sym_rel (tR A A' AR n n' nR)) - (tR A' A (sym_rel AR) n' n (Param_nat_sym nR))). + (tR A' A (sym_rel AR) n' n (nat_sym _ _ nR))). + exact (tR_sym A A' AR n n' nR). - + exact (Map4 A' A (Param44_sym A A' AR) n' n (Param_nat_sym nR)). + + exact (Map4 A' A (Param44_sym A A' AR) n' n (nat_sym _ _ nR)). Defined. (* append ~ append *) diff --git a/std/algo/elpi/sym.elpi b/std/algo/elpi/sym.elpi index 3d7319a8..9c279fbc 100644 --- a/std/algo/elpi/sym.elpi +++ b/std/algo/elpi/sym.elpi @@ -97,25 +97,25 @@ func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ _ KTys, - Ind = (global (indt GR)), + coq.env.global (indt GR) Ind, std.assert! (param Ind Ind TR) "derive.sym: use derive.param2 before", - coq.typecheck TR TRTy _, + coq.env.global (indt GRR) TR, + coq.gref->id (indt GRR) Rname, + coq.env.indt GRR _ _ _ TRTy KRNs KTyRs, + mk-mR-type-sym TyParamNo TRTy TR MRTy, std.assert-ok! (coq.elaborate-skeleton MRTy _ MRTyE) "derive.sym generates illtyped type", - TR = global (indt GRR), - coq.gref->id (indt GRR) Rname, RInductionName is Rname ^ "_rect", coq.locate RInductionName RInd, + coq.env.global RInd RIndT, coq.prod->fun MRTyE Pred, - coq.env.indt GRR _ _ _ _ KRNs KTyRs, - std.map KRNs (x\ r\ r = (global (indc x))) KRs, - implement-sym TyParamNo TyParamNo MRTyE KRs KTys KTyRs Pred (global RInd) R, + std.map KRNs (x\ r\ sigma TMP\ coq.env.global (indc x) TMP, r = TMP) KRs, + implement-sym TyParamNo TyParamNo MRTyE KRs KTys KTyRs Pred RIndT R, std.assert-ok! (coq.elaborate-skeleton R MRTyE Re) "derive.sym generates illtyped term", Name is Prefix ^ "sym", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName Re MRTyE _ C, - I = global (indt GR), - Clauses = [sym-done GR, sym-db I (global (const C))], + Clauses = [sym-done GR, sym-db Ind (global (const C))], std.forall Clauses (x\ coq.elpi.accumulate _ "derive.sym.db" (clause _ _ x) ), diff --git a/std/algo/tests/coverage.v b/std/algo/tests/coverage.v index 4c28298c..9d069448 100644 --- a/std/algo/tests/coverage.v +++ b/std/algo/tests/coverage.v @@ -29,9 +29,6 @@ Inductive Option (A : Type) : Type := Inductive Prod (A B : Type) : Type := | PR : A -> B -> Prod A B. -Inductive Mix (A : Type) : Type := -| Con : A -> Unit -> Mix A. - Inductive ThreeTypes (A B C : Type) := | C1 : A -> ThreeTypes A B C | C2 : B -> ThreeTypes A B C From d5bac20e07a678d722eaf6f6d21ca1b016d0247f Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 1 Apr 2026 11:01:44 +0200 Subject: [PATCH 19/42] a hott generalizaion --- std/algo/tests/merely_inhabited_relation.v | 161 +++++++++++++++++++++ 1 file changed, 161 insertions(+) create mode 100644 std/algo/tests/merely_inhabited_relation.v diff --git a/std/algo/tests/merely_inhabited_relation.v b/std/algo/tests/merely_inhabited_relation.v new file mode 100644 index 00000000..3754298f --- /dev/null +++ b/std/algo/tests/merely_inhabited_relation.v @@ -0,0 +1,161 @@ + +Require Import ssreflect. +From Trocq Require Import Trocq. + +Require Import HoTTNotations. + +Section Trocqlib. + (* Lemma MereM4 `{Funext} (A B : Type) (R : A -> B -> Type) (map : A -> B) : + {f : forall x : A, R x (map x) & + forall (x : A) (y : B) (r : R x y), {e : map x = y & transport (R x) e (f x) = r}} <~> + {f : forall x : A, R x (map x) & forall (x : A) (y : B) (r : R x y), +(map x; f x) = (y; r)}. *) +End Trocqlib. + +Require Import Stdlib.Program.Equality. + +Section Preliminary. + + Definition tr {T : Type}{x y : T} (P : T -> Type) (p : x = y) : P x -> P y. + refine (match p with eq_refl => fun P => P end). + Defined. + + Definition apd {T : Type}{P : T -> Type} (f : forall x, P x) {x y : T} (p : x = y) : + tr _ p (f x) = f y. + Proof. + refine (match p with eq_refl => eq_refl end). + Defined. + + Lemma tr_concat {T : Type} {x y z : T} (p : x = y) (q : y = z) : tr _ q p = p @ q. + Proof. + move: q. + refine (match p as p0 in _ = t return forall (q : t = z), tr _ q p0 = p0 @ q with eq_refl => _ end). + exact (fun q => match q with eq_refl => 1 end). + Defined. + +End Preliminary. + +(*Lemma 2.9.6 in the HoTT BooK weakened *) +Axiom L : forall {T : Type}{P Q : T -> Type} {x y : T} (p : x = y) (f : P x -> Q x) (g : P y -> Q y) + ,tr (fun x => P x -> Q x) p f = g -> forall x, tr _ p (f x) = g (tr _ p x). + +Section Genthm722. + + Variable A B : Type. + Variable R : A -> B -> Type. + Variable m : A -> B. + Variable Rrefl : forall x, R x (m x). (* 2a *) + Variable imp : forall x y, R x y -> m x = y. (* 2b *) + Variable MereR : forall x y (r1 r2 : R x y), r1 = r2. + + Definition F {x : A} {y : B} (p : m x = y) := apd (imp x) p. + + Definition inverses_concat_tr : forall x, + forall p : m x = m x, + imp x (m x) (Rrefl x) @ p = imp x (m x) (tr _ p (Rrefl x)). + Proof. move=> x p. + rewrite -tr_concat. + apply L. + exact: F. + Defined. + + Definition path_shape : forall x, + forall p : m x = m x, + p = (imp x (m x) (Rrefl x))^ @ imp x (m x) (@tr _ _ _ _ p (Rrefl x)). + Proof. + move=> x p. + rewrite -[LHS](concat_1p p). + rewrite -(concat_Vp (imp x (m x) (Rrefl x))). + rewrite concat_pp_p. + apply ap. + apply inverses_concat_tr. + Defined. + + Lemma tr_id : forall (x : A) (p : m x = m x), tr (fun y=> R x y) p (Rrefl x) = (Rrefl x). + Proof. move=> x p; apply MereR. Qed. + + Definition UIP_MA {x y : A} (p q : m x = m y): p = q. + Proof. + move: q. + refine (match p as p0 return forall q, p0 = q with eq_refl => _ end). + move=> q. + rewrite (path_shape x 1) /=. + rewrite (path_shape x q). + (* rewrite -uniqr. *) + by rewrite tr_id. + Defined. + + Section inj. + Definition injective {A B : Type} (f : A -> B) := forall x y, f x = f y -> x = y. + Hypothesis m_inj : injective m. + + Lemma ap_inj {C D : Type} (f : C -> D) (inj_f : injective f) : forall x y, injective (@f_equal _ _ f x y). + Proof. + move=> x y p1 p2. + dependent destruction p1. + dependent destruction p2. + move=> _ ; exact: eq_refl. + Defined. + Print JMeq_refl. + + Definition UIP_A {x y : A} (p q : x = y) : p = q. + Proof. + set mp := @f_equal _ _ m _ _ p. + set mq := @f_equal _ _ m _ _ q. + have : mp = mq. by apply UIP_MA. + by apply: ap_inj. + Defined. + + End inj. + + Section surj. + + Definition fiber {C D : Type} (f : C -> D) (d : D) := { c & f c = d}. + Definition isContr (A : Type) := { t & forall t1 : A, t = t1}. + Definition isProp (A : Type) := forall (x y : A), isContr(x = y). + Definition surjection {C D : Type} (f : C -> D) := forall y, isProp (fiber f y). + Hypothesis m_surj : surjection m. + + Lemma UIP_B : forall (x y : B) (p q : x = y), p = q. + Proof. + move=> x y. + have := m_surj x. + Abort. + + End surj. + Section surj2. + + Hypothesis comap : B -> A. + Hypothesis corefl : forall b, R (comap b) b. + + Lemma UIP_B : forall (x y : B) (p q : x = y), p = q. + Proof. + move=> x y. + have := (imp _ _ (corefl x)). + have := (imp _ _ (corefl y)). + elim. + elim. + apply UIP_MA. + Qed. + + End surj2. + +End Genthm722. + +Section thm722. + + Variable A : Type. + Variable R : A -> A -> Type. + Variable rrefl : forall x, R x x. (* 2a *) + Variable imp : forall x y, R x y -> x = y. (* 2b *) + Variable mereR : forall x y (r1 r2 : R x y), r1 = r2. + Variable M4 : forall x (r1 r2 : {y & R x y} ), r1 = r2. + + Lemma uip_a (x y : A) (p q : x = y) : p = q. + Proof. + apply (UIP_MA A A R (@id A) rrefl imp). + by move=> e ?; apply mereR. + Qed. + +End thm722. + From 612c216abbc50bb3f240333bddd883a33925ff67 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Fri, 10 Apr 2026 00:58:05 +0200 Subject: [PATCH 20/42] a proof of RmmRK --- std/algo/tests/rmmrK.v | 113 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 113 insertions(+) create mode 100644 std/algo/tests/rmmrK.v diff --git a/std/algo/tests/rmmrK.v b/std/algo/tests/rmmrK.v new file mode 100644 index 00000000..662baf4b --- /dev/null +++ b/std/algo/tests/rmmrK.v @@ -0,0 +1,113 @@ +Require Import ssreflect. +From Trocq Require Import Trocq. + +Require Import HoTTNotations. + +Section Preliminary. + + Definition tr {T : Type}{x y : T} (P : T -> Type) (p : x = y) : P x -> P y. + refine (match p with eq_refl => fun P => P end). + Defined. + + Definition apd {T : Type}{P : T -> Type} (f : forall x, P x) {x y : T} (p : x = y) : + tr _ p (f x) = f y. + Proof. + refine (match p with eq_refl => eq_refl end). + Defined. + + Lemma tr_concat {T : Type} {x y z : T} (p : x = y) (q : y = z) : tr _ q p = p @ q. + Proof. + move: q. + refine (match p as p0 in _ = t return forall (q : t = z), tr _ q p0 = p0 @ q with eq_refl => _ end). + exact (fun q => match q with eq_refl => 1 end). + Defined. + + Lemma left_transpose_eq_concat : forall {T : Type} + {x y : T} (p : x = y) {z : T} (q : y = z) (r : x = z), + p @ q = r -> q = p^ @ r. + Proof. + move=> T x y p. + case : _ / p => /= z q r. + by rewrite !concat_1p. + Defined. + +(*Lemma 2.9.6 in the HoTT BooK weakened *) +Lemma L : forall {T : Type}{P Q : T -> Type} {x y : T} (p : x = y) (f : P x -> Q x) (g : P y -> Q y) + ,tr (fun x => P x -> Q x) p f = g -> forall x, tr _ p (f x) = g (tr _ p x). +Proof. +move=> T P Q x y p. +case: _ / p. +move=> f g /= -> //. +Defined. + +End Preliminary. + +Section RmmRK. + + Variable A B : Type. + Variable R : A -> B -> Type. + Variable map : A -> B. + Variable map_in_R : forall x y, map x = y -> R x y. + Variable R_in_map : forall x y, R x y -> map x = y. + Variable mRRmK : forall x y (r : R x y), map_in_R _ _ (R_in_map _ _ r) = r. + + Definition F {x : A} {y : B} (p : map x = y) := apd (R_in_map x) p. + + Definition inverses_concat_tr : forall x y, + forall p : map x = y, + R_in_map x (map x) (map_in_R x (map x) 1) @ p + = R_in_map x y (tr _ p (map_in_R x (map x) 1)). + Proof. + move=> x y p. + rewrite -tr_concat. + apply L. + exact: F. + Defined. + + Definition path_shape {x y} : + forall p : map x = y, + p = (R_in_map x (map x) (map_in_R x (map x) 1))^ + @ R_in_map x y (tr _ p (map_in_R x (map x) 1)). + Proof. + move=> p. + rewrite -[LHS](concat_1p p). + rewrite -[X in X @ p](concat_Vp (R_in_map x (map x) (map_in_R x (map x) 1))). + rewrite concat_pp_p. + apply ap. + apply inverses_concat_tr. + Defined. + + Lemma tr_id : forall (x : A) y (p : map x = y), + tr (fun y=> R x y) p (map_in_R _ _ 1) = (map_in_R x y p). + Proof. + move=> x y p. + by case: _ / p . + Defined. + + Lemma Rm_concat : forall a b b' + (e : map a = b) + (e1 : b = b'), + R_in_map a b' (map_in_R a b' (e @ e1)) = + R_in_map a b (map_in_R a b e) @ e1. + Proof. + move=> a b1 b2 e e1. + by case: _ / e1. + Defined. + + Definition RmmRK : forall a b (e : map a = b), + R_in_map _ _ (map_in_R _ _ e) = e. + Proof. + move=> a b e. + rewrite [RHS](path_shape e). + rewrite tr_id. + set q := R_in_map a b _. + set p := R_in_map _ _ _. + apply (left_transpose_eq_concat p q q). + rewrite -Rm_concat. + rewrite concat_1p. + rewrite mRRmK. + reflexivity. + Defined. + +End RmmRK. + From fd82c5e8246dedd4e837374da7b3fd98c3240cee Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Thu, 16 Apr 2026 18:03:07 +0200 Subject: [PATCH 21/42] wip move theories to generic/inductives + mv elpi to /elpi --- {std/algo/elpi => elpi/inductives}/Rm.elpi | 0 {std/algo/elpi => elpi/inductives}/RsymK.elpi | 0 .../elpi => elpi/inductives}/common_algo.elpi | 0 {std/algo/elpi => elpi/inductives}/injK.elpi | 0 .../inductives}/injection_lemmas.elpi | 0 {std/algo/elpi => elpi/inductives}/mR.elpi | 0 {std/algo/elpi => elpi/inductives}/mRRmK.elpi | 0 {std/algo/elpi => elpi/inductives}/mymap.elpi | 0 {std/algo/elpi => elpi/inductives}/rel40.elpi | 0 {std/algo/elpi => elpi/inductives}/rel44.elpi | 0 {std/algo/elpi => elpi/inductives}/sym.elpi | 0 {std/algo/elpi => elpi/inductives}/symK.elpi | 0 {std/algo/elpi => elpi/inductives}/umap.elpi | 0 {std/algo/elpi => elpi/inductives}/utils.elpi | 0 .../theories => generic/inductives}/Rel44.v | 6 +-- .../algo/theories => generic/inductives}/Rm.v | 6 +-- .../theories => generic/inductives}/RsymK.v | 6 +-- .../theories => generic/inductives}/injK.v | 4 +- .../inductives}/injection_lemmas.v | 4 +- .../algo/theories => generic/inductives}/mR.v | 6 +-- .../theories => generic/inductives}/mRRmK.v | 6 +-- .../theories => generic/inductives}/map4.v | 0 .../theories => generic/inductives}/mymap.v | 2 +- .../theories => generic/inductives}/sym.v | 6 +-- .../theories => generic/inductives}/symK.v | 6 +-- .../theories => generic/inductives}/umap.v | 6 +-- hott/_CoqProject | 14 +++++ hott/generic/inductives | 1 + std/_CoqProject | 54 ++++++++++--------- std/generic/inductives | 1 + 30 files changed, 73 insertions(+), 55 deletions(-) rename {std/algo/elpi => elpi/inductives}/Rm.elpi (100%) rename {std/algo/elpi => elpi/inductives}/RsymK.elpi (100%) rename {std/algo/elpi => elpi/inductives}/common_algo.elpi (100%) rename {std/algo/elpi => elpi/inductives}/injK.elpi (100%) rename {std/algo/elpi => elpi/inductives}/injection_lemmas.elpi (100%) rename {std/algo/elpi => elpi/inductives}/mR.elpi (100%) rename {std/algo/elpi => elpi/inductives}/mRRmK.elpi (100%) rename {std/algo/elpi => elpi/inductives}/mymap.elpi (100%) rename {std/algo/elpi => elpi/inductives}/rel40.elpi (100%) rename {std/algo/elpi => elpi/inductives}/rel44.elpi (100%) rename {std/algo/elpi => elpi/inductives}/sym.elpi (100%) rename {std/algo/elpi => elpi/inductives}/symK.elpi (100%) rename {std/algo/elpi => elpi/inductives}/umap.elpi (100%) rename {std/algo/elpi => elpi/inductives}/utils.elpi (100%) rename {std/algo/theories => generic/inductives}/Rel44.v (87%) rename {std/algo/theories => generic/inductives}/Rm.v (89%) rename {std/algo/theories => generic/inductives}/RsymK.v (88%) rename {std/algo/theories => generic/inductives}/injK.v (92%) rename {std/algo/theories => generic/inductives}/injection_lemmas.v (91%) rename {std/algo/theories => generic/inductives}/mR.v (90%) rename {std/algo/theories => generic/inductives}/mRRmK.v (90%) rename {std/algo/theories => generic/inductives}/map4.v (100%) rename {std/algo/theories => generic/inductives}/mymap.v (95%) rename {std/algo/theories => generic/inductives}/sym.v (87%) rename {std/algo/theories => generic/inductives}/symK.v (89%) rename {std/algo/theories => generic/inductives}/umap.v (89%) create mode 120000 hott/generic/inductives create mode 120000 std/generic/inductives diff --git a/std/algo/elpi/Rm.elpi b/elpi/inductives/Rm.elpi similarity index 100% rename from std/algo/elpi/Rm.elpi rename to elpi/inductives/Rm.elpi diff --git a/std/algo/elpi/RsymK.elpi b/elpi/inductives/RsymK.elpi similarity index 100% rename from std/algo/elpi/RsymK.elpi rename to elpi/inductives/RsymK.elpi diff --git a/std/algo/elpi/common_algo.elpi b/elpi/inductives/common_algo.elpi similarity index 100% rename from std/algo/elpi/common_algo.elpi rename to elpi/inductives/common_algo.elpi diff --git a/std/algo/elpi/injK.elpi b/elpi/inductives/injK.elpi similarity index 100% rename from std/algo/elpi/injK.elpi rename to elpi/inductives/injK.elpi diff --git a/std/algo/elpi/injection_lemmas.elpi b/elpi/inductives/injection_lemmas.elpi similarity index 100% rename from std/algo/elpi/injection_lemmas.elpi rename to elpi/inductives/injection_lemmas.elpi diff --git a/std/algo/elpi/mR.elpi b/elpi/inductives/mR.elpi similarity index 100% rename from std/algo/elpi/mR.elpi rename to elpi/inductives/mR.elpi diff --git a/std/algo/elpi/mRRmK.elpi b/elpi/inductives/mRRmK.elpi similarity index 100% rename from std/algo/elpi/mRRmK.elpi rename to elpi/inductives/mRRmK.elpi diff --git a/std/algo/elpi/mymap.elpi b/elpi/inductives/mymap.elpi similarity index 100% rename from std/algo/elpi/mymap.elpi rename to elpi/inductives/mymap.elpi diff --git a/std/algo/elpi/rel40.elpi b/elpi/inductives/rel40.elpi similarity index 100% rename from std/algo/elpi/rel40.elpi rename to elpi/inductives/rel40.elpi diff --git a/std/algo/elpi/rel44.elpi b/elpi/inductives/rel44.elpi similarity index 100% rename from std/algo/elpi/rel44.elpi rename to elpi/inductives/rel44.elpi diff --git a/std/algo/elpi/sym.elpi b/elpi/inductives/sym.elpi similarity index 100% rename from std/algo/elpi/sym.elpi rename to elpi/inductives/sym.elpi diff --git a/std/algo/elpi/symK.elpi b/elpi/inductives/symK.elpi similarity index 100% rename from std/algo/elpi/symK.elpi rename to elpi/inductives/symK.elpi diff --git a/std/algo/elpi/umap.elpi b/elpi/inductives/umap.elpi similarity index 100% rename from std/algo/elpi/umap.elpi rename to elpi/inductives/umap.elpi diff --git a/std/algo/elpi/utils.elpi b/elpi/inductives/utils.elpi similarity index 100% rename from std/algo/elpi/utils.elpi rename to elpi/inductives/utils.elpi diff --git a/std/algo/theories/Rel44.v b/generic/inductives/Rel44.v similarity index 87% rename from std/algo/theories/Rel44.v rename to generic/inductives/Rel44.v index 9826e994..6873c0dd 100644 --- a/std/algo/theories/Rel44.v +++ b/generic/inductives/Rel44.v @@ -1,8 +1,8 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) -From Trocq Extra Dependency "algo/elpi/utils.elpi" as utils. -From Trocq Extra Dependency "algo/elpi/rel44.elpi" as rel44. +From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) +From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. +From Trocq.Elpi Extra Dependency "inductives/rel44.elpi" as rel44. From Trocq Require Import sym symK RsymK Param_lemmas umap map4. Import HoTTNotations. (* Extra Dependency "algo/elpi/sym.elpi" as sym. *) diff --git a/std/algo/theories/Rm.v b/generic/inductives/Rm.v similarity index 89% rename from std/algo/theories/Rm.v rename to generic/inductives/Rm.v index b31eaaf1..e9735545 100644 --- a/std/algo/theories/Rm.v +++ b/generic/inductives/Rm.v @@ -1,7 +1,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq Extra Dependency "algo/elpi/Rm.elpi" as Rm. -From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. -From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. +From Trocq.Elpi Extra Dependency "inductives/Rm.elpi" as Rm. +From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. +From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. From elpi Require Import elpi. From Trocq Require Export Hierarchy. diff --git a/std/algo/theories/RsymK.v b/generic/inductives/RsymK.v similarity index 88% rename from std/algo/theories/RsymK.v rename to generic/inductives/RsymK.v index 81400124..2e432f6a 100644 --- a/std/algo/theories/RsymK.v +++ b/generic/inductives/RsymK.v @@ -1,9 +1,9 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) -From Trocq Extra Dependency "algo/elpi/utils.elpi" as utils. -From Trocq Extra Dependency "algo/elpi/RsymK.elpi" as rsymK. +From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) +From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. +From Trocq.Elpi Extra Dependency "inductives/RsymK.elpi" as rsymK. From Trocq Require Import sym symK. Import HoTTNotations. (* Extra Dependency "algo/elpi/sym.elpi" as sym. *) diff --git a/std/algo/theories/injK.v b/generic/inductives/injK.v similarity index 92% rename from std/algo/theories/injK.v rename to generic/inductives/injK.v index fcacd606..aa613190 100644 --- a/std/algo/theories/injK.v +++ b/generic/inductives/injK.v @@ -1,7 +1,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq Extra Dependency "algo/elpi/injK.elpi" as injK. -From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. +From Trocq.Elpi Extra Dependency "inductives/injK.elpi" as injK. +From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. From Trocq Require Export injection_lemmas. From elpi Require Import elpi. diff --git a/std/algo/theories/injection_lemmas.v b/generic/inductives/injection_lemmas.v similarity index 91% rename from std/algo/theories/injection_lemmas.v rename to generic/inductives/injection_lemmas.v index f207afe2..0753a237 100644 --- a/std/algo/theories/injection_lemmas.v +++ b/generic/inductives/injection_lemmas.v @@ -1,8 +1,8 @@ From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq Extra Dependency "algo/elpi/injection_lemmas.elpi" as injections. -From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. +From Trocq.Elpi Extra Dependency "inductives/injection_lemmas.elpi" as injections. +From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. From elpi.apps Require Import derive.legacy. From elpi.apps Require Export derive.bcongr. (* for eq_f register *) diff --git a/std/algo/theories/mR.v b/generic/inductives/mR.v similarity index 90% rename from std/algo/theories/mR.v rename to generic/inductives/mR.v index 8b46320f..47f4e8ce 100644 --- a/std/algo/theories/mR.v +++ b/generic/inductives/mR.v @@ -1,8 +1,8 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. -From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. -From Trocq Extra Dependency "algo/elpi/mR.elpi" as mR. -From Trocq Extra Dependency "algo/elpi/injection_lemmas.elpi" as injections. +From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. +From Trocq.Elpi Extra Dependency "inductives/mR.elpi" as mR. +From Trocq.Elpi Extra Dependency "inductives/injection_lemmas.elpi" as injections. From elpi Require Import elpi. From elpi.apps Require Export derive.param2 derive.isK. diff --git a/std/algo/theories/mRRmK.v b/generic/inductives/mRRmK.v similarity index 90% rename from std/algo/theories/mRRmK.v rename to generic/inductives/mRRmK.v index 1bca0357..fe7eac70 100644 --- a/std/algo/theories/mRRmK.v +++ b/generic/inductives/mRRmK.v @@ -1,7 +1,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq Extra Dependency "algo/elpi/mRRmK.elpi" as mRRmK. -From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. -From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. +From Trocq.Elpi Extra Dependency "inductives/mRRmK.elpi" as mRRmK. +From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. +From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. From Trocq Require Export mymap injK mR Rm. From elpi Require Import elpi. diff --git a/std/algo/theories/map4.v b/generic/inductives/map4.v similarity index 100% rename from std/algo/theories/map4.v rename to generic/inductives/map4.v diff --git a/std/algo/theories/mymap.v b/generic/inductives/mymap.v similarity index 95% rename from std/algo/theories/mymap.v rename to generic/inductives/mymap.v index 1ff1d0c7..f9e3afcd 100644 --- a/std/algo/theories/mymap.v +++ b/generic/inductives/mymap.v @@ -1,5 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq Extra Dependency "algo/elpi/mymap.elpi" as mymap. +From Trocq.Elpi Extra Dependency "inductives/mymap.elpi" as mymap. From elpi Require Import elpi. From elpi.apps Require Import derive.legacy. diff --git a/std/algo/theories/sym.v b/generic/inductives/sym.v similarity index 87% rename from std/algo/theories/sym.v rename to generic/inductives/sym.v index fcb1e2fe..d267454c 100644 --- a/std/algo/theories/sym.v +++ b/generic/inductives/sym.v @@ -1,8 +1,8 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. -From Trocq Extra Dependency "algo/elpi/utils.elpi" as utils. -From Trocq Extra Dependency "algo/elpi/sym.elpi" as sym. +From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. +From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. +From Trocq.Elpi Extra Dependency "inductives/sym.elpi" as sym. From elpi.apps Require Import derive.legacy derive.param2. diff --git a/std/algo/theories/symK.v b/generic/inductives/symK.v similarity index 89% rename from std/algo/theories/symK.v rename to generic/inductives/symK.v index ea7e47a8..3faa8679 100644 --- a/std/algo/theories/symK.v +++ b/generic/inductives/symK.v @@ -1,9 +1,9 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. -From Trocq Extra Dependency "algo/elpi/utils.elpi" as utils. -From Trocq Extra Dependency "algo/elpi/symK.elpi" as symK. +From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. +From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. +From Trocq.Elpi Extra Dependency "inductives/symK.elpi" as symK. From Trocq Require Import sym. (* Extra Dependency "algo/elpi/sym.elpi" as sym. *) diff --git a/std/algo/theories/umap.v b/generic/inductives/umap.v similarity index 89% rename from std/algo/theories/umap.v rename to generic/inductives/umap.v index e33ab88b..58920565 100644 --- a/std/algo/theories/umap.v +++ b/generic/inductives/umap.v @@ -1,7 +1,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq Extra Dependency "algo/elpi/umap.elpi" as umap. -From Trocq Extra Dependency "algo/elpi/common_algo.elpi" as common. -From Trocq Extra Dependency "algo/elpi/utils.elpi" as algo_utils. +From Trocq.Elpi Extra Dependency "inductives/umap.elpi" as umap. +From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. +From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. From Trocq Require Import map4. Require Import Database. Unset Uniform Inductive Parameters. diff --git a/hott/_CoqProject b/hott/_CoqProject index f3b6d9a6..5e5e0e2c 100644 --- a/hott/_CoqProject +++ b/hott/_CoqProject @@ -15,6 +15,20 @@ Param_arrow.v Param_forall.v Param_lemmas.v Stdlib.v + +generic/inductives/sym.v +generic/inductives/symK.v +generic/inductives/RsymK.v +generic/inductives/mymap.v +generic/inductives/injection_lemmas.v +generic/inductives/mR.v +generic/inductives/Rm.v +generic/inductives/injK.v +generic/inductives/mRRmK.v +generic/inductives/map4.v +generic/inductives/umap.v +generic/inductives/Rel44.v + generic/Database.v generic/Param_Empty.v generic/Param_bool.v diff --git a/hott/generic/inductives b/hott/generic/inductives new file mode 120000 index 00000000..b05dbf4f --- /dev/null +++ b/hott/generic/inductives @@ -0,0 +1 @@ +../../generic/inductives \ No newline at end of file diff --git a/std/_CoqProject b/std/_CoqProject index 8c561075..7009d446 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -14,6 +14,34 @@ Param_arrow.v Param_forall.v Param_lemmas.v Stdlib.v + +generic/inductives/sym.v +generic/inductives/symK.v +generic/inductives/RsymK.v +generic/inductives/mymap.v +generic/inductives/injection_lemmas.v +generic/inductives/mR.v +generic/inductives/Rm.v +generic/inductives/injK.v +generic/inductives/mRRmK.v +generic/inductives/map4.v +generic/inductives/umap.v +generic/inductives/Rel44.v + +algo/tests/coverage.v +algo/tests/test_sym.v +algo/tests/test_symK.v +algo/tests/test_RsymK.v +algo/tests/test_mymap.v +algo/tests/test_injection_lemmas.v +algo/tests/test_mR.v +algo/tests/test_Rm.v +algo/tests/test_injK.v +algo/tests/test_mRRmK.v +algo/tests/test_map4.v +algo/tests/test_umap.v +algo/tests/test_Rel44.v + generic/Database.v generic/Param_Empty.v generic/Param_bool.v @@ -28,29 +56,3 @@ generic/Param_trans.v generic/Param_vector.v generic/Trocq.v generic/Vernac.v - -algo/tests/coverage.v -algo/theories/sym.v -algo/tests/test_sym.v -algo/theories/symK.v -algo/tests/test_symK.v -algo/theories/RsymK.v -algo/tests/test_RsymK.v -algo/theories/mymap.v -algo/tests/test_mymap.v -algo/theories/injection_lemmas.v -algo/tests/test_injection_lemmas.v -algo/theories/mR.v -algo/tests/test_mR.v -algo/theories/Rm.v -algo/tests/test_Rm.v -algo/theories/injK.v -algo/tests/test_injK.v -algo/theories/mRRmK.v -algo/tests/test_mRRmK.v -algo/theories/map4.v -algo/tests/test_map4.v -algo/theories/umap.v -algo/tests/test_umap.v -algo/theories/Rel44.v -algo/tests/test_Rel44.v \ No newline at end of file diff --git a/std/generic/inductives b/std/generic/inductives new file mode 120000 index 00000000..b05dbf4f --- /dev/null +++ b/std/generic/inductives @@ -0,0 +1 @@ +../../generic/inductives \ No newline at end of file From 03e7e4dd54bed6c808053766e35581ef6b2d1ece Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Sat, 30 May 2026 11:48:00 +0200 Subject: [PATCH 22/42] update in structure add logical path to generic/inductives add generic to logical path in tests rename rel44 umap + mv tests to tests/inductives removing checks in generic fix tests postpone docs on inductive generation --- elpi/inductives/common_algo.elpi | 4 +- elpi/inductives/{umap.elpi => mapn.elpi} | 61 ++-- elpi/inductives/rel40.elpi | 69 ---- elpi/inductives/{rel44.elpi => relnm.elpi} | 18 +- generic/Param_Empty.v | 14 +- generic/Param_bool.v | 19 +- generic/Param_list.v | 56 +--- generic/Param_nat.v | 15 +- generic/Param_option.v | 56 +--- generic/Param_prod.v | 6 +- generic/Param_sum.v | 7 +- generic/inductives/{Rel44.v => Relnm.v} | 20 +- generic/inductives/map4.v | 2 - generic/inductives/{umap.v => mapn.v} | 14 +- generic/inductives/sym.v | 2 +- hott/_CoqProject | 5 +- std/_CoqProject | 19 +- std/algo/detailed/DetailedRm.v | 208 ------------ std/algo/detailed/Detailed_Rsym.v | 112 ------- std/algo/detailed/Detailed_injijK.v | 257 --------------- std/algo/detailed/Detailed_mRRmK.v | 306 ------------------ std/algo/detailed/Detailed_nm_inm.v | 62 ---- std/algo/detailed/Detailed_rel44.v | 91 ------ std/algo/detailed/Detailed_sym.v | 123 ------- std/algo/detailed/Detailed_symK.v | 158 --------- std/algo/detailed/Detailed_vector.v | 150 --------- std/algo/detailed/DetailedmR.v | 257 --------------- std/algo/tests/test_Rel40.v | 36 --- tests/_CoqProject.hott | 15 + tests/_CoqProject.std | 15 + .../tests => tests/inductives}/coverage.v | 0 .../inductives}/merely_inhabited_relation.v | 0 {std/algo/tests => tests/inductives}/rmmrK.v | 0 .../inductives/test_Relnm.v | 2 +- .../algo/tests => tests/inductives}/test_Rm.v | 0 .../tests => tests/inductives}/test_RsymK.v | 0 .../tests => tests/inductives}/test_injK.v | 0 .../inductives}/test_injection_lemmas.v | 0 .../algo/tests => tests/inductives}/test_mR.v | 0 .../tests => tests/inductives}/test_mRRmK.v | 0 .../tests => tests/inductives}/test_map4.v | 0 .../inductives/test_mapn.v | 2 +- .../tests => tests/inductives}/test_mymap.v | 0 .../tests => tests/inductives}/test_sym.v | 0 .../tests => tests/inductives}/test_symK.v | 0 45 files changed, 110 insertions(+), 2071 deletions(-) rename elpi/inductives/{umap.elpi => mapn.elpi} (56%) delete mode 100644 elpi/inductives/rel40.elpi rename elpi/inductives/{rel44.elpi => relnm.elpi} (87%) rename generic/inductives/{Rel44.v => Relnm.v} (79%) rename generic/inductives/{umap.v => mapn.v} (86%) delete mode 100644 std/algo/detailed/DetailedRm.v delete mode 100644 std/algo/detailed/Detailed_Rsym.v delete mode 100644 std/algo/detailed/Detailed_injijK.v delete mode 100644 std/algo/detailed/Detailed_mRRmK.v delete mode 100644 std/algo/detailed/Detailed_nm_inm.v delete mode 100644 std/algo/detailed/Detailed_rel44.v delete mode 100644 std/algo/detailed/Detailed_sym.v delete mode 100644 std/algo/detailed/Detailed_symK.v delete mode 100644 std/algo/detailed/Detailed_vector.v delete mode 100644 std/algo/detailed/DetailedmR.v delete mode 100644 std/algo/tests/test_Rel40.v rename {std/algo/tests => tests/inductives}/coverage.v (100%) rename {std/algo/tests => tests/inductives}/merely_inhabited_relation.v (100%) rename {std/algo/tests => tests/inductives}/rmmrK.v (100%) rename std/algo/tests/test_Rel44.v => tests/inductives/test_Relnm.v (91%) rename {std/algo/tests => tests/inductives}/test_Rm.v (100%) rename {std/algo/tests => tests/inductives}/test_RsymK.v (100%) rename {std/algo/tests => tests/inductives}/test_injK.v (100%) rename {std/algo/tests => tests/inductives}/test_injection_lemmas.v (100%) rename {std/algo/tests => tests/inductives}/test_mR.v (100%) rename {std/algo/tests => tests/inductives}/test_mRRmK.v (100%) rename {std/algo/tests => tests/inductives}/test_map4.v (100%) rename std/algo/tests/test_umap.v => tests/inductives/test_mapn.v (97%) rename {std/algo/tests => tests/inductives}/test_mymap.v (100%) rename {std/algo/tests => tests/inductives}/test_sym.v (100%) rename {std/algo/tests => tests/inductives}/test_symK.v (100%) diff --git a/elpi/inductives/common_algo.elpi b/elpi/inductives/common_algo.elpi index 58fee178..5e966a69 100644 --- a/elpi/inductives/common_algo.elpi +++ b/elpi/inductives/common_algo.elpi @@ -188,8 +188,8 @@ pred mk-mR-type-rsymK i:int, i:term, i:term, i:term, o:term. mk-mR-type-rsymK N T Rel RSym R :- mk-mR-type-priv N T RSym _ Rel 7 [] _ _ raw R. -pred mk-mR-type-rel44 i:int, i:term, i:term, i:term, o:term. -mk-mR-type-rel44 N T Rel RelSTy R :- +pred mk-mR-type-relnm i:int, i:term, i:term, i:term, o:term. +mk-mR-type-relnm N T Rel RelSTy R :- mk-mR-type-priv N T _ RelSTy Rel 8 [] _ _ subst R. } \ No newline at end of file diff --git a/elpi/inductives/umap.elpi b/elpi/inductives/mapn.elpi similarity index 56% rename from elpi/inductives/umap.elpi rename to elpi/inductives/mapn.elpi index f1ba4b4d..a53dcee3 100644 --- a/elpi/inductives/umap.elpi +++ b/elpi/inductives/mapn.elpi @@ -1,6 +1,6 @@ shorten derive.algo-utils.{gen-names-map}. -namespace derive.umap { +namespace derive.mapn { % TyParamNo % Arity @@ -9,9 +9,9 @@ namespace derive.umap { % TyArgs1 % TyArgs2 % ARArgs -pred mk-umap-type-priv i:int, i:term, i:term, i:term, i:term, i:term, o:term. -mk-umap-type-priv 0 _ IndL IndR Rel MTy {{ lp:MTy lp:IndL lp:IndR lp:Rel}}. -mk-umap-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR Rel MTy +pred mk-mapn-type-priv i:int, i:term, i:term, i:term, i:term, i:term, o:term. +mk-mapn-type-priv 0 _ IndL IndR Rel MTy {{ lp:MTy lp:IndL lp:IndR lp:Rel}}. +mk-mapn-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR Rel MTy (prod TN1 Ty t1\ prod TN2 Ty t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- M is N - 1, gen-names-map TN TN1 TN2 TRN URN, @@ -24,19 +24,18 @@ mk-umap-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR Rel MTy coq.mk-app IndL [t1] (NIndL t1), coq.mk-app IndR [t2] (NIndR t2), coq.mk-app Rel [t1,t2,ar] (NRel t1 t2 ar), - mk-umap-type-priv M (Bo t1) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) MTy (R t1 t2 ar ur). + mk-mapn-type-priv M (Bo t1) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) MTy (R t1 t2 ar ur). % TyParamNo Arity Ind MapTy Rel -pred mk-umap-type i:int, i:term, i:term, i:term, i:term, o:term. -mk-umap-type TyParamNo Arity Ind Rel MTy R :- - mk-umap-type-priv TyParamNo Arity Ind Ind Rel MTy R. +pred mk-mapn-type i:int, i:term, i:term, i:term, i:term, o:term. +mk-mapn-type TyParamNo Arity Ind Rel MTy R :- + mk-mapn-type-priv TyParamNo Arity Ind Ind Rel MTy R. -% TyParamNo UMapTy IndL IndR Rel listReqs IndMap MR RM MRRMK -pred implement-umap i:int, i:term, i:term, i:term, i:term, i: list term, i:term, o:term. -% implement-umap _ _ _ _ _ _ _ _ {{ Type }}. -implement-umap 0 _ IndL IndR Rel Reqs BH R :- +% TyParamNo MapnTy IndL IndR Rel listReqs IndMap MR RM MRRMK +pred implement-mapn i:int, i:term, i:term, i:term, i:term, i: list term, i:term, o:term. +implement-mapn 0 _ IndL IndR Rel Reqs BH R :- coq.mk-app BH [IndL,IndR,Rel | Reqs] R. -implement-umap N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (Bo t1 t2 ar ur)) IndL IndR Rel Reqs BH (fun TN1 Ty1 t1\ fun TN2 Ty2 t2\ fun TRN (ARTy t1 t2) ar\ fun URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- +implement-mapn N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (Bo t1 t2 ar ur)) IndL IndR Rel Reqs BH (fun TN1 Ty1 t1\ fun TN2 Ty2 t2\ fun TRN (ARTy t1 t2) ar\ fun URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- M is N - 1, @pi-decl TN1 Ty1 t1\ @pi-decl TN2 Ty2 t2\ @@ -46,7 +45,7 @@ implement-umap N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ pr coq.mk-app IndR [t2] (NIndR t2), coq.mk-app Rel [t1,t2,ar] (NRel t1 t2 ar), std.map Reqs (x\ r\ sigma TMP\ coq.mk-app x [t1,t2,ar,ur] TMP, r = TMP) (NewReqs t1 t2 ar ur), - implement-umap M (Bo t1 t2 ar ur) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) + implement-mapn M (Bo t1 t2 ar ur) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) (NewReqs t1 t2 ar ur) BH (R t1 t2 ar ur). pred build-has-of i:map-class, o:gref. @@ -56,43 +55,43 @@ build-has-of M R :- pred map-reqs i:map-class, i:term, o: list term. map-reqs map0 _ []. map-reqs map1 Ind [IndMap] :- - std.assert! (mymap-def Ind IndMap) "derive.umap: use derive.mymap before". + std.assert! (mymap-def Ind IndMap) "derive.mapn: use derive.mymap before". map-reqs map2a Ind [MR | M1] :- map-reqs map1 Ind M1, - std.assert! (mR-db Ind MR) "derive.umap: use derive.mR before". + std.assert! (mR-db Ind MR) "derive.mapn: use derive.mR before". map-reqs map2b Ind [RM | M1] :- map-reqs map1 Ind M1, - std.assert! (rm-db Ind RM) "derive.umap: use derive.Rm before". + std.assert! (rm-db Ind RM) "derive.mapn: use derive.Rm before". map-reqs map3 Ind [RM | M2a] :- map-reqs map2a Ind M2a, - std.assert! (rm-db Ind RM) "derive.umap: use derive.Rm before". + std.assert! (rm-db Ind RM) "derive.mapn: use derive.Rm before". map-reqs map4 Ind [MRRMK | M3] :- map-reqs map3 Ind M3, - std.assert! (mRRmK-db Ind MRRMK) "derive.umap: use derive.MRRMK before". + std.assert! (mRRmK-db Ind MRRMK) "derive.mapn: use derive.MRRMK before". pred implement-mapM i:map-class, i:inductive, o: term. -implement-mapM M GR RUMap :- +implement-mapM M GR RMapn :- coq.env.indt GR _ TyParamNo _ Arity _ _, Ind = (global (indt GR)), - std.assert! (param Ind Ind IndR) "derive.umap: use derive.param2 before", + std.assert! (param Ind Ind IndR) "derive.mapn: use derive.param2 before", std.rev {map-reqs M Ind} Reqs, trocq.db.map->class M UM, build-has-of M BH4, % todo: address universe polymorphism - mk-umap-type TyParamNo Arity Ind IndR (pglobal UM _) UMapTySkel, - std.assert-ok! (coq.elaborate-skeleton UMapTySkel _ UMapTy) "derive.umap generates illtyped type", - implement-umap TyParamNo UMapTy Ind Ind IndR Reqs (pglobal BH4 _) RUMapSkel, - std.assert-ok! (coq.elaborate-skeleton RUMapSkel _ RUMap) "derive.umap generates illtyped term". + mk-mapn-type TyParamNo Arity Ind IndR (pglobal UM _) MapnTySkel, + std.assert-ok! (coq.elaborate-skeleton MapnTySkel _ MapnTy) "derive.mapn generates illtyped type", + implement-mapn TyParamNo MapnTy Ind Ind IndR Reqs (pglobal BH4 _) RMapnSkel, + std.assert-ok! (coq.elaborate-skeleton RMapnSkel _ RMapn) "derive.mapn generates illtyped term". func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ Ind = (global (indt GR)), - std.fold {map-class.all-of-kind all} [] (M\ C\ C'\ sigma RUMap NameUMap FNameUMap CUMap Entry\ - implement-mapM M GR RUMap, - NameUMap is Prefix ^ "map" ^ {map-class.to_string M}, - coq.ensure-fresh-global-id NameUMap FNameUMap, - coq.env.add-const FNameUMap RUMap _ _ CUMap, - Entry = trocq.db.map-ind Ind M (global (const CUMap)), + std.fold {map-class.all-of-kind all} [] (M\ C\ C'\ sigma RMapn NameMapn FNameMapn CMapn Entry\ + implement-mapM M GR RMapn, + NameMapn is Prefix ^ "map" ^ {map-class.to_string M}, + coq.ensure-fresh-global-id NameMapn FNameMapn, + coq.env.add-const FNameMapn RMapn _ _ CMapn, + Entry = trocq.db.map-ind Ind M (global (const CMapn)), coq.elpi.accumulate _ "trocq.db" (clause _ _ Entry), C' = [Entry | C] ) MClauses, diff --git a/elpi/inductives/rel40.elpi b/elpi/inductives/rel40.elpi deleted file mode 100644 index b683f9fc..00000000 --- a/elpi/inductives/rel40.elpi +++ /dev/null @@ -1,69 +0,0 @@ -shorten derive.common-algo. {rel-mode}. -shorten derive.algo-utils.{gen-names-map}. - -namespace derive.rel40 { - -% TyParamNo -% Arity -% Ind -% IndR -% TyArgs1 -% TyArgs2 -% ARArgs -pred mk-rel40-type-priv i:int, i:term, i:term, i:term, o:term. -mk-rel40-type-priv 0 _ IndL IndR {{ @Param40.Rel lp:IndL lp:IndR }}. -mk-rel40-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR - (prod TN1 Ty t1\ prod TN2 Ty t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- - M is N - 1, - gen-names-map TN TN1 TN2 TRN URN, - @pi-decl TN1 Ty t1\ - @pi-decl TN2 Ty t2\ - (ARTy t1 t2) = {{ lp:t1 -> lp:t2 -> Type }}, - @pi-decl TRN (ARTy t1 t2) ar\ - (UMTy t1 t2 ar) = {{ @IsUMap lp:t1 lp:t2 lp:ar }}, - @pi-decl URN (UMTy t1 t2 ar) ur\ - coq.mk-app IndL [t1] (NIndL t1), - coq.mk-app IndR [t2] (NIndR t2), - mk-rel40-type-priv M (Bo t1) (NIndL t1) (NIndR t2) (R t1 t2 ar ur). - -% TyParamNo Arity Ind Rel -pred mk-rel40-type i:int, i:term, i:term, o:term. -mk-rel40-type TyParamNo Arity Ind R :- - mk-rel40-type-priv TyParamNo Arity Ind Ind R. - -% TyParamNo UMapTy IndL IndR Rel IndMap MR RM MRRMK -pred implement-rel40 i:int, i:term, i:term, o:term. -% implement-umap _ _ _ _ _ _ _ _ {{ Type }}. -implement-rel40 0 _ UMapI R :- - R = {{ @Build40 _ _ _ lp:UMapI }}. -implement-rel40 N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (Bo t1 t2 ar ur)) - UMapI (fun TN1 Ty1 t1\ fun TN2 Ty2 t2\ fun TRN (ARTy t1 t2) ar\ fun URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- - M is N - 1, - @pi-decl TN1 Ty1 t1\ - @pi-decl TN2 Ty2 t2\ - @pi-decl TRN (ARTy t1 t2) ar\ - @pi-decl URN (UMTy t1 t2 ar) ur\ - coq.mk-app UMapI [t1,t2,ar,ur] (NUMapI t1 t2 ar ur), - implement-rel40 M (Bo t1 t2 ar ur) (NUMapI t1 t2 ar ur) (R t1 t2 ar ur). - -func main inductive, string -> list prop. -main GR Prefix Clauses :- std.do! [ - - coq.env.indt GR _ TyParamNo _ Arity _ _, - Ind = (global (indt GR)), - std.assert! (umap-db Ind UMapI) "derive.rel40: use derive.umap before", - mk-rel40-type TyParamNo Arity Ind Rel40TySkel, - std.assert-ok! (coq.elaborate-skeleton Rel40TySkel _ Rel40Ty) "derive.rel40 generates illtyped type", - implement-rel40 TyParamNo Rel40Ty UMapI RRel40Skel, - std.assert-ok! (coq.elaborate-skeleton RRel40Skel _ RRel40) "derive.umap generates illtyped term", - NameRel is Prefix ^ "rel40", - coq.ensure-fresh-global-id NameRel FNameRel, - coq.env.add-const FNameRel RRel40 _ _ CRel, - ClausesRel = [rel40-done GR, rel40-db Ind (global (const CRel))], - Clauses = ClausesRel, - std.forall Clauses (x\ - coq.elpi.accumulate _ "derive.rel40.db" (clause _ _ x) - ), -]. - -} \ No newline at end of file diff --git a/elpi/inductives/rel44.elpi b/elpi/inductives/relnm.elpi similarity index 87% rename from elpi/inductives/rel44.elpi rename to elpi/inductives/relnm.elpi index 6fa8fb48..26087d2c 100644 --- a/elpi/inductives/rel44.elpi +++ b/elpi/inductives/relnm.elpi @@ -1,7 +1,7 @@ shorten derive.algo-utils.{type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with}. -shorten derive.common-algo.{mk-mR-type-rel44,sym-tyargs}. +shorten derive.common-algo.{mk-mR-type-relnm,sym-tyargs}. -namespace derive.rel44 { +namespace derive.relnm { pred refine-covariant-tyargs i: list term, i:term, i:list term, o: list term. refine-covariant-tyargs [] _ L L. @@ -18,9 +18,9 @@ refine-Lsym [A1, A2, AR | L2] [_,_,_,Refined | L2Ref] Refiner Acc R :- std.append Acc [A1, A2, AR, RefinedContra] NewAcc, refine-Lsym L2 L2Ref Refiner NewAcc R. -% TyargNo, rel44 Type, mapnCov, mapmContra, eq_map, rsymK, list of args -pred implement-rel44 i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:list term, o:term. -implement-rel44 0 _ +% TyargNo, relnm Type, mapnCov, mapmContra, eq_map, rsymK, list of args +pred implement-relnm i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:list term, o:term. +implement-relnm 0 _ MapNCov MapMContra Eq_map RsymK CovariantNN ContravariantNN BuildNN LRev R :- !, std.rev LRev L, @@ -31,7 +31,7 @@ implement-rel44 0 _ coq.mk-app MapMContra LContra MapContravariant, coq.mk-app RsymK LSym RsymKSym, R = {{ lp:BuildNN _ _ _ lp:MapCovariant (lp:Eq_map lp:RsymKSym lp:MapContravariant )}}. -implement-rel44 N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) +implement-relnm N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) MapNCov MapMContra Eq_map RsymK CovariantNN ContravariantNN BuildNN L (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- M is N - 1, @@ -40,7 +40,7 @@ implement-rel44 N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ @pi-decl ARN (ARTy a1 a2) ar\ % AR : ParamNM.Rel A1 A2 sigma NewL\ std.append [ar,a2,a1] L NewL, - implement-rel44 M (Bo a1 a2 ar) MapNCov MapMContra Eq_map RsymK CovariantNN ContravariantNN BuildNN NewL (R a1 a2 ar). + implement-relnm M (Bo a1 a2 ar) MapNCov MapMContra Eq_map RsymK CovariantNN ContravariantNN BuildNN NewL (R a1 a2 ar). pred get-eq-map i:map-class, o:term. get-eq-map map0 {{ eq_Map0 }}. @@ -57,13 +57,13 @@ generate-relNM GR (pc N M as PC) ReTy Re :- std.assert! (param Ind Ind TR) "derive.relNM: use derive.param2 before", coq.typecheck TR TRTy _, trocq.db.rel PC PRelNM BuildNM _ CovNM ContraNM, - mk-mR-type-rel44 TyParamNo TRTy TR (pglobal PRelNM _) RTy, + mk-mR-type-relnm TyParamNo TRTy TR (pglobal PRelNM _) RTy, std.assert-ok! (coq.elaborate-skeleton RTy _ ReTy) "derive.relNM generates illtyped type", std.assert! (trocq.db.map-ind Ind N UmapNCov) "derive.relNM: use derive.umap before", std.assert! (trocq.db.map-ind Ind M UmapMContra) "derive.relNM: use derive.umap before", std.assert! (rsymK-db Ind RSymKInd) "derive.relNM: use derive.rsymK before", get-eq-map M Eq_map, - implement-rel44 TyParamNo ReTy UmapNCov UmapMContra Eq_map RSymKInd (pglobal CovNM _) (pglobal ContraNM _) (pglobal BuildNM _) [] R, + implement-relnm TyParamNo ReTy UmapNCov UmapMContra Eq_map RSymKInd (pglobal CovNM _) (pglobal ContraNM _) (pglobal BuildNM _) [] R, std.assert-ok! (coq.elaborate-skeleton R ReTy Re) "derive.relNM generates illtyped term". func main inductive, string -> list prop. diff --git a/generic/Param_Empty.v b/generic/Param_Empty.v index c001938b..5cb51843 100644 --- a/generic/Param_Empty.v +++ b/generic/Param_Empty.v @@ -17,7 +17,7 @@ Require Import Stdlib Hierarchy. Import HoTTNotations. Require Import Database. -From Trocq Require Import Rel44. +From Trocq Require Import Relnm. (* translations of inductives in Prop is not yet supported, but we can still generate everything for False by manually defining its parametricity translation and making it land in Type. *) @@ -30,17 +30,5 @@ Set Universe Polymorphism. Unset Universe Minimization ToSet. Elpi derive Empty. - -Check EmptyR : False -> False -> Type. -Check False_mymap : False -> False. -Check False_mR : forall (b b' : False) (e : False_mymap b = b'), EmptyR b b'. -Check False_Rm : forall (b b' : False) (bR : EmptyR b b'), False_mymap b = b'. -Check False_mRRmK : forall (b b' : False) (bR : EmptyR b b'), False_mR _ _ (False_Rm _ _ bR) = bR. -Check False_sym : forall (b b' : False) (bR : EmptyR b b'), EmptyR b' b. -Check False_symK : forall (b b' : False) (bR : EmptyR b b'), False_sym _ _ (False_sym _ _ bR) = bR. -Check False_rsymK : forall (b b' : False), sym_rel EmptyR b b' <->> EmptyR b b'. -Check False_map4 : Map4.Has EmptyR. -Check False_rel44 : Param44.Rel False False. - Definition Param01_Empty := False_rel01. Definition Param10_Empty := False_rel10. diff --git a/generic/Param_bool.v b/generic/Param_bool.v index 6a00e2cb..e6424a0f 100644 --- a/generic/Param_bool.v +++ b/generic/Param_bool.v @@ -20,24 +20,9 @@ Unset Universe Minimization ToSet. Import HoTTNotations. Require Import Database. -From Trocq Require Import Rel44. +From Trocq Require Import Relnm. + Elpi derive Bool. Definition BoolR := bool_R. Definition trueR := true_R. - -Check bool_R : Bool -> Bool -> Type. -Check bool_mymap : Bool -> Bool. -Check bool_mR : forall (b b' : Bool) (e : bool_mymap b = b'), bool_R b b'. -Check bool_Rm : forall (b b' : Bool) (bR : bool_R b b'), bool_mymap b = b'. -Check bool_mRRmK : forall (b b' : Bool) (bR : bool_R b b'), bool_mR _ _ (bool_Rm _ _ bR) = bR. -Check bool_sym : forall (b b' : Bool) (bR : bool_R b b'), bool_R b' b. -Check bool_symK : forall (b b' : Bool) (bR : bool_R b b'), bool_sym _ _ (bool_sym _ _ bR) = bR. -Check bool_rsymK : forall (b b' : Bool), sym_rel bool_R b b' <->> bool_R b b'. -Check bool_map4 : Map4.Has bool_R. -Check bool_rel44 : Param44.Rel Bool Bool. - Definition Param44_Bool := bool_rel44. -Set Printing All. -Set Printing Universes. -Print bool_rel44. -Print Universes Subgraph (bool_rel44.u0 bool_rel44.u1). diff --git a/generic/Param_list.v b/generic/Param_list.v index 5b2c9fcd..5f9b5a1b 100644 --- a/generic/Param_list.v +++ b/generic/Param_list.v @@ -21,65 +21,13 @@ Set Asymmetric Patterns. Import HoTTNotations. Require Import Database. -From Trocq Require Import Rel44. +From Trocq Require Import Relnm. + Elpi derive list. Notation listR := list_R. Notation nilR := nil_R. Notation consR := cons_R. -Check list_R : forall A1 A2 (AR : A1 -> A2 -> Type), list A1 -> list A2 -> Type. -Check list_mymap : forall A1 A2 (AR : A1 -> A2 -> Type), Map1.Has AR-> list A1 -> list A2. -Check list_mR : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map2a.Has AR), - forall l1 l2, list_mymap _ _ _ AM l1 = l2 -> list_R _ _ AR l1 l2. -Check list_Rm : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map2b.Has AR), - forall l1 l2, list_R _ _ AR l1 l2 -> list_mymap _ _ _ AM l1 = l2. -Check list_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map4.Has AR), - forall l1 l2 lR, list_mR _ _ _ AM _ _ (list_Rm _ _ _ AM _ _ lR) = lR. -Check list_sym : forall A1 A2 (A_R : A1 -> A2 -> Type) l1 l2, list_R A1 A2 A_R l1 l2 -> -list_R A2 A1 (sym_rel A_R) l2 l1. - -Check list_symK : forall (A1 A2 : Type) (A_R : A1 -> A2 -> Type) (s1 : list A1) -(s2 : list A2) (IR : list_R A1 A2 A_R s1 s2), - list_sym A2 A1 (sym_rel A_R) s2 s1 (list_sym A1 A2 A_R s1 s2 IR) = - IR. -Check list_rsymK : forall (A1 A2 : Type) (A_R : A1 -> A2 -> Type) (s1 : list A1) - (s2 : list A2), - list_R A2 A1 (sym_rel A_R) s2 s1 <->> list_R A1 A2 A_R s1 s2. -Check list_rel44 : - forall A1 A2 : Type, (A1 <=> A2)%P -> (list A1 <=> list A2)%P. - -Check list_map2a : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), -Map2a.Has AR -> Map2a.Has (list_R A1 A2 AR). - -Check list_map2b : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), -Map2b.Has AR -> Map2b.Has (list_R A1 A2 AR). - -Check list_map3 : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), -Map3.Has AR -> Map3.Has (list_R A1 A2 AR). - -Check list_map4 : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), -Map4.Has AR -> Map4.Has (list_R A1 A2 AR). - -Check list_rel00 : forall A1 A2 : Type, -Param00.Rel A1 A2 -> Param00.Rel (list A1) (list A2). - -Check list_rel42a : forall A1 A2 : Type, -Param42a.Rel A1 A2 -> Param42a.Rel (list A1) (list A2). - -Check list_rel42b : forall A1 A2 : Type, -Param42b.Rel A1 A2 -> Param42b.Rel (list A1) (list A2). - -Check list_rel2a4 : forall A1 A2 : Type, -Param2a4.Rel A1 A2 -> Param2a4.Rel (list A1) (list A2). - -Check list_rel2b4 : forall A1 A2 : Type, -Param2b4.Rel A1 A2 -> Param2b4.Rel (list A1) (list A2). - -Check list_rel33 : forall A1 A2 : Type, -Param33.Rel A1 A2 -> Param33.Rel (list A1) (list A2). - -Check list_rel44 : forall (A A' : Type) (AR : Param44.Rel A A'), Param44.Rel (list A) (list A'). - Definition Param42b_list := list_rel42b. Definition Param2a4_list := list_rel2a4. Definition Param44_list := list_rel44. diff --git a/generic/Param_nat.v b/generic/Param_nat.v index 2bcd14a6..52dd52f9 100644 --- a/generic/Param_nat.v +++ b/generic/Param_nat.v @@ -20,24 +20,13 @@ Unset Universe Minimization ToSet. Import HoTTNotations. Require Import Database. -From Trocq Require Import Rel44. +From Trocq Require Import Relnm. + Elpi derive nat. Notation natR := nat_R. Definition OR := O_R. Definition SR := S_R. -Check nat_R : nat -> nat -> Type. -Check nat_mymap : nat -> nat. -Check nat_mR : forall (b b' : nat) (e : nat_mymap b = b'), nat_R b b'. -Check nat_Rm : forall (b b' : nat) (bR : nat_R b b'), nat_mymap b = b'. -Check nat_mRRmK : forall (b b' : nat) (bR : nat_R b b'), nat_mR _ _ (nat_Rm _ _ bR) = bR. -Check nat_sym : forall (b b' : nat) (bR : nat_R b b'), nat_R b' b. -Check nat_symK : forall (b b' : nat) (bR : nat_R b b'), nat_sym _ _ (nat_sym _ _ bR) = bR. -Check nat_rsymK : forall (b b' : nat), sym_rel nat_R b b' <->> nat_R b b'. -Check nat_map4 : Map4.Has nat_R. -Check nat_rel44 : Param44.Rel nat nat. -Check nat_rel00 : Param00.Rel nat nat. -Check nat_rel2a0 : Param2a0.Rel nat nat. Definition Param2a0_nat := nat_rel2a0. Definition Param_add : diff --git a/generic/Param_option.v b/generic/Param_option.v index 3c11ddca..b4c72a26 100644 --- a/generic/Param_option.v +++ b/generic/Param_option.v @@ -19,58 +19,6 @@ Unset Universe Minimization ToSet. Import HoTTNotations. Require Import Database. -From Trocq Require Import Rel44. -Elpi derive option. +From Trocq Require Import Relnm. -Check option_R : forall A1 A2 (AR : A1 -> A2 -> Type), option A1 -> option A2 -> Type. -Check option_mymap : forall A1 A2 (AR : A1 -> A2 -> Type), Map1.Has AR-> option A1 -> option A2. -Check option_mR : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map2a.Has AR), - forall l1 l2, option_mymap _ _ _ AM l1 = l2 -> option_R _ _ AR l1 l2. -Check option_Rm : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map2b.Has AR), - forall l1 l2, option_R _ _ AR l1 l2 -> option_mymap _ _ _ AM l1 = l2. -Check option_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM: Map4.Has AR), - forall l1 l2 lR, option_mR _ _ _ AM _ _ (option_Rm _ _ _ AM _ _ lR) = lR. -Check option_sym : forall A1 A2 (A_R : A1 -> A2 -> Type) l1 l2, option_R A1 A2 A_R l1 l2 -> -option_R A2 A1 (sym_rel A_R) l2 l1. - -Check option_symK : forall (A1 A2 : Type) (A_R : A1 -> A2 -> Type) (s1 : option A1) -(s2 : option A2) (IR : option_R A1 A2 A_R s1 s2), - option_sym A2 A1 (sym_rel A_R) s2 s1 (option_sym A1 A2 A_R s1 s2 IR) = - IR. -Check option_rsymK : forall (A1 A2 : Type) (A_R : A1 -> A2 -> Type) (s1 : option A1) - (s2 : option A2), - option_R A2 A1 (sym_rel A_R) s2 s1 <->> option_R A1 A2 A_R s1 s2. -Check option_rel44 : - forall A1 A2 : Type, (A1 <=> A2)%P -> (option A1 <=> option A2)%P. - -Check option_map2a : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), -Map2a.Has AR -> Map2a.Has (option_R A1 A2 AR). - -Check option_map2b : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), -Map2b.Has AR -> Map2b.Has (option_R A1 A2 AR). - -Check option_map3 : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), -Map3.Has AR -> Map3.Has (option_R A1 A2 AR). - -Check option_map4 : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), -Map4.Has AR -> Map4.Has (option_R A1 A2 AR). - -Check option_rel00 : forall A1 A2 : Type, -Param00.Rel A1 A2 -> Param00.Rel (option A1) (option A2). - -Check option_rel42a : forall A1 A2 : Type, -Param42a.Rel A1 A2 -> Param42a.Rel (option A1) (option A2). - -Check option_rel42b : forall A1 A2 : Type, -Param42b.Rel A1 A2 -> Param42b.Rel (option A1) (option A2). - -Check option_rel2a4 : forall A1 A2 : Type, -Param2a4.Rel A1 A2 -> Param2a4.Rel (option A1) (option A2). - -Check option_rel2b4 : forall A1 A2 : Type, -Param2b4.Rel A1 A2 -> Param2b4.Rel (option A1) (option A2). - -Check option_rel33 : forall A1 A2 : Type, -Param33.Rel A1 A2 -> Param33.Rel (option A1) (option A2). - -Check option_rel44 : forall (A A' : Type) (AR : Param44.Rel A A'), Param44.Rel (option A) (option A'). +Elpi derive option. \ No newline at end of file diff --git a/generic/Param_prod.v b/generic/Param_prod.v index f14b766e..f95e9003 100644 --- a/generic/Param_prod.v +++ b/generic/Param_prod.v @@ -20,8 +20,6 @@ Unset Universe Minimization ToSet. Import HoTTNotations. Require Import Database. -From Trocq Require Import Rel44. -Elpi derive prod. +From Trocq Require Import Relnm. -Check prod_map4 : forall A A' (AR : A -> A' -> Type) (AM : Map4.Has AR) B B' (BR : B -> B' -> Type) (BM : Map4.Has BR), - Map4.Has (prod_R _ _ AR _ _ BR). \ No newline at end of file +Elpi derive prod. \ No newline at end of file diff --git a/generic/Param_sum.v b/generic/Param_sum.v index 63681120..8bd55e94 100644 --- a/generic/Param_sum.v +++ b/generic/Param_sum.v @@ -21,10 +21,7 @@ Set Asymmetric Patterns. Import HoTTNotations. Require Import Database. -From Trocq Require Import Rel44. -Elpi derive sum. -Check sum_map4 : forall (A1 A2 : Type) (AR : A1 -> A2 -> Type), -IsUMap AR -> forall (B1 B2 : Type) (BR : B1 -> B2 -> Type), -IsUMap BR -> IsUMap (sum_R A1 A2 AR B1 B2 BR). +From Trocq Require Import Relnm. +Elpi derive sum. Definition Param01_sum := sum_rel01. diff --git a/generic/inductives/Rel44.v b/generic/inductives/Relnm.v similarity index 79% rename from generic/inductives/Rel44.v rename to generic/inductives/Relnm.v index 6873c0dd..982b61df 100644 --- a/generic/inductives/Rel44.v +++ b/generic/inductives/Relnm.v @@ -2,8 +2,8 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. -From Trocq.Elpi Extra Dependency "inductives/rel44.elpi" as rel44. -From Trocq Require Import sym symK RsymK Param_lemmas umap map4. +From Trocq.Elpi Extra Dependency "inductives/relnm.elpi" as relnm. +From Trocq Require Import sym symK RsymK Param_lemmas mapn map4. Import HoTTNotations. (* Extra Dependency "algo/elpi/sym.elpi" as sym. *) @@ -23,7 +23,7 @@ Unset Uniform Inductive Parameters. pred rel44-done o:inductive. }}. *) -Elpi Command derive.rel44. +Elpi Command derive.relnm. Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db derive.param2.db. @@ -33,7 +33,7 @@ Elpi Accumulate Db trocq.db. Elpi Accumulate File common. Elpi Accumulate File utils. Elpi Accumulate Db trocq.db. -Elpi Accumulate File rel44. +Elpi Accumulate File relnm. Elpi Accumulate lp:{{ main [str I] :- !, @@ -41,11 +41,11 @@ Elpi Accumulate lp:{{ % Ind is (indt GR) coq.gref->id (indt GR) Tname, Suffix is Tname ^ "_", - derive.rel44.main GR Suffix _. + derive.relnm.main GR Suffix _. main _ :- usage. pred usage. - usage :- coq.error "Usage: derive.rel44 ". + usage :- coq.error "Usage: derive.relnm ". }}. (* hook into derive *) @@ -54,11 +54,11 @@ Elpi Accumulate Db derive.rsymK.db. Elpi Accumulate Db trocq.db. Elpi Accumulate derive File common. Elpi Accumulate derive File utils. -Elpi Accumulate derive File rel44. +Elpi Accumulate derive File relnm. Elpi Accumulate derive lp:{{ -dep1 "rel44" "rsymK". -dep1 "rel44" "umap". -derivation (indt T) Prefix ff (derive "rel44" (derive.rel44.main T Prefix) (trocq.db.param-ind-done T)). +dep1 "relnm" "rsymK". +dep1 "relnm" "mapn". +derivation (indt T) Prefix ff (derive "relnm" (derive.relnm.main T Prefix) (trocq.db.param-ind-done T)). }}. diff --git a/generic/inductives/map4.v b/generic/inductives/map4.v index b2f18867..7d412973 100644 --- a/generic/inductives/map4.v +++ b/generic/inductives/map4.v @@ -1,5 +1,3 @@ -(* Hook for mymap *) -(* From elpi.apps Require Export derive.legacy. *) From Trocq Require Export mymap. From Trocq Require Export injection_lemmas. From Trocq Require Export mR. diff --git a/generic/inductives/umap.v b/generic/inductives/mapn.v similarity index 86% rename from generic/inductives/umap.v rename to generic/inductives/mapn.v index 58920565..1b5dde4e 100644 --- a/generic/inductives/umap.v +++ b/generic/inductives/mapn.v @@ -1,5 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Elpi Extra Dependency "inductives/umap.elpi" as umap. +From Trocq.Elpi Extra Dependency "inductives/mapn.elpi" as mapn. From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. From Trocq Require Import map4. @@ -19,7 +19,7 @@ Elpi Accumulate derive.umap.db Db trocq.db. *) pred umap-done o:inductive, o:map-class. }}. *) -Elpi Command derive.umap. +Elpi Command derive.mapn. Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db derive.param2.db. @@ -35,12 +35,12 @@ Elpi Accumulate File common. Elpi Accumulate File algo_utils. Elpi Accumulate Db trocq.db. -Elpi Accumulate File umap. +Elpi Accumulate File mapn. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, Prefix is Tname ^ "_", - derive.umap.main GR Prefix _. + derive.mapn.main GR Prefix _. main _ :- usage. pred usage. @@ -50,11 +50,11 @@ Elpi Accumulate lp:{{ Elpi Accumulate derive Db trocq.db. Elpi Accumulate derive File common. Elpi Accumulate derive File algo_utils. -Elpi Accumulate derive File umap. +Elpi Accumulate derive File mapn. Elpi Accumulate derive lp:{{ -dep1 "umap" "mRRmK". -derivation (indt T) Prefix ff (derive "umap" (derive.umap.main T Prefix) (trocq.db.map-ind-done T)). +dep1 "mapn" "mRRmK". +derivation (indt T) Prefix ff (derive "mapn" (derive.mapn.main T Prefix) (trocq.db.map-ind-done T)). }}. diff --git a/generic/inductives/sym.v b/generic/inductives/sym.v index d267454c..b9eb6655 100644 --- a/generic/inductives/sym.v +++ b/generic/inductives/sym.v @@ -6,7 +6,7 @@ From Trocq.Elpi Extra Dependency "inductives/sym.elpi" as sym. From elpi.apps Require Import derive.legacy derive.param2. -From Trocq Require Export Hierarchy. +From Trocq Require Export Hierarchy Stdlib. Unset Uniform Inductive Parameters. Elpi Db derive.sym.db lp:{{ diff --git a/hott/_CoqProject b/hott/_CoqProject index 5e5e0e2c..6582f06e 100644 --- a/hott/_CoqProject +++ b/hott/_CoqProject @@ -3,6 +3,7 @@ -arg -w -arg +elpi.typechecker -R . Trocq +-R ./generic/inductives Trocq -R ../elpi/ Trocq.Elpi Common.v @@ -26,8 +27,8 @@ generic/inductives/Rm.v generic/inductives/injK.v generic/inductives/mRRmK.v generic/inductives/map4.v -generic/inductives/umap.v -generic/inductives/Rel44.v +generic/inductives/mapn.v +generic/inductives/Relnm.v generic/Database.v generic/Param_Empty.v diff --git a/std/_CoqProject b/std/_CoqProject index 7009d446..683c94a5 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -2,6 +2,7 @@ -arg -w -arg +elpi.typechecker -R . Trocq +-R ./generic/inductives Trocq -R ../elpi/ Trocq.Elpi HoTTNotations.v @@ -25,22 +26,8 @@ generic/inductives/Rm.v generic/inductives/injK.v generic/inductives/mRRmK.v generic/inductives/map4.v -generic/inductives/umap.v -generic/inductives/Rel44.v - -algo/tests/coverage.v -algo/tests/test_sym.v -algo/tests/test_symK.v -algo/tests/test_RsymK.v -algo/tests/test_mymap.v -algo/tests/test_injection_lemmas.v -algo/tests/test_mR.v -algo/tests/test_Rm.v -algo/tests/test_injK.v -algo/tests/test_mRRmK.v -algo/tests/test_map4.v -algo/tests/test_umap.v -algo/tests/test_Rel44.v +generic/inductives/mapn.v +generic/inductives/Relnm.v generic/Database.v generic/Param_Empty.v diff --git a/std/algo/detailed/DetailedRm.v b/std/algo/detailed/DetailedRm.v deleted file mode 100644 index 82b68ded..00000000 --- a/std/algo/detailed/DetailedRm.v +++ /dev/null @@ -1,208 +0,0 @@ -From Coq Require Import ssreflect. -From elpi.apps.derive Require Import derive derive.param2. -From Trocq Require Import mymap. - (* injection_lemmas. *) -(* Require Import HoTT_additions Hierarchy. *) -Require Import Hierarchy. -Unset Uniform Inductive Parameters. -(* Unset Universe Minimization ToSet. *) - -Inductive False :=. -Elpi derive.param2 False. -Elpi derive.mymap False. -Definition false_Rm : forall (f1 f2 : False), False_R f1 f2 -> False_mymap f1 = f2. -Proof. -(* refine (fun f1 f2 fR=> False_R_ind (fun (f1 f2 : False) => (False_R f1 f2) -> False_mymap f1 = f2) f1 f2 fR fR). *) -refine (fun f1 f2 fR=> False_R_ind (fun (f1 f2 : False) => False_mymap f1 = f2) f1 f2 fR). -Defined. - -Definition Unit := unit. - -Elpi derive.param2 unit. -Definition UnitR := unit_R. -(* Inductive UnitR : Unit -> Unit -> Type := - | tt_R : UnitR tt tt. *) - -Elpi derive.mymap unit. -Definition unit_map : unit -> unit := unit_mymap. - -Definition Pred := fun (s1 s2: unit) (RR : unit_R s1 s2)=> unit_map s1 = s2 . -Definition unit_Rm : forall (u1 u2 : Unit), UnitR u1 u2-> unit_map u1 = u2 . -Proof. -refine (fun u1 u2 uR=> unit_R_ind Pred eq_refl u1 u2 uR). -Defined. - -Definition Bool := bool. -Elpi derive.param2 bool. - -Definition BoolR := bool_R. -(* Inductive BoolR : Bool -> Bool -> Type := -| true_R : BoolR true true -| false_R : BoolR false false. *) - -Elpi derive.mymap bool. -Definition bool_map : Bool -> Bool := bool_mymap. - -Definition Pred_bool := (fun (s1 s2: bool) (RR : bool_R s1 s2)=> bool_map s1 = s2). -Definition bool_Rm : forall (u1 u2 : Bool), BoolR u1 u2 -> bool_map u1 = u2. -Proof. -refine (fun b1 b2 bR=> bool_R_ind Pred_bool _ _ b1 b2 bR). -+ exact (@eq_refl Bool true). -+ exact (@eq_refl Bool false). -Defined. - -Inductive Wrap : Type := -| KWrap1 : unit -> Wrap. - -Elpi derive.param2 Wrap. -Definition WrapR := Wrap_R. -Elpi derive.mymap Wrap. - -Definition wrap_map := Wrap_mymap. -About concat. -Notation Pred_wrap := (fun (w1 w2 : Wrap ) (wR : Wrap_R w1 w2) => wrap_map w1 = w2) (only parsing). -Definition wrap_Rm : forall w1 w2, WrapR w1 w2 -> wrap_map w1 = w2. -Proof. -refine (fun w1 w2 wR => Wrap_R_ind Pred_wrap _ w1 w2 wR). -+ set eta1 := (fun R=> KWrap1 R). - refine (fun u1 u2 uR=> _). - set e1 := @ap unit Wrap eta1 (unit_map u1) u2 (unit_Rm u1 u2 uR). - set end_ := @eq_refl Wrap (KWrap1 u2). - exact (@eq_trans Wrap _ _ _ e1 end_). -Defined. - -Inductive FArgsK : Type := -| C1 : unit -> bool -> Wrap -> bool -> FArgsK. - -Elpi derive.param2 FArgsK. -Elpi derive.mymap FArgsK. -Notation Pred_fargsk := (fun (f1 f2 : FArgsK)(fR : FArgsK_R f1 f2)=> FArgsK_mymap f1 = f2) (only parsing). -Definition Rm_fargsk : forall f1 f2 (fR : FArgsK_R f1 f2), FArgsK_mymap f1 = f2. -Proof. -refine (fun f1 f2 fR=> FArgsK_R_ind Pred_fargsk _ f1 f2 fR). -refine (fun u1 u2 uR=> _). -refine (fun b1 b2 bR=> _). -refine (fun w1 w2 wR=> _). -refine (fun b1' b2' bR'=> _). -set goal := FArgsK_mymap (C1 u1 b1 w1 b1') = C1 u2 b2 w2 b2'. -simpl in goal. -(* set start := @eq_refl FArgsK (FArgsK_mymap (C1 u1 b1 w1 b1')). *) -(* set start := @eq_refl FArgsK (C1 (unit_map u1) (bool_mymap b1) (Wrap_mymap w1) (bool_mymap b1')). *) -set eta1 := (fun R:unit => C1 R (bool_mymap b1) (Wrap_mymap w1) (bool_mymap b1')). -set eta2 := (fun R2:bool => C1 u2 R2 (Wrap_mymap w1) (bool_mymap b1')). -set eta3 := (fun R3:Wrap => C1 u2 b2 R3 (bool_mymap b1')). -set eta4 := (fun R4:bool => C1 u2 b2 w2 R4). -set e1 := @ap unit FArgsK eta1 (unit_map u1) u2 (unit_Rm u1 u2 uR). -set e2 := @ap bool FArgsK eta2 (bool_map b1) b2 (bool_Rm b1 b2 bR). -set e3 := @ap Wrap FArgsK eta3 (wrap_map w1) w2 (wrap_Rm w1 w2 wR). -set e4 := @ap bool FArgsK eta4 (bool_map b1') b2' (bool_Rm b1' b2' bR'). -set end_ := @eq_refl FArgsK (C1 u2 b2 w2 b2'). -exact (e1 @ e2 @ e3 @ e4 @ end_). -Defined. - -Definition Nat := nat. -Elpi derive.param2 nat. - -Definition NatR := nat_R. - -Elpi derive.mymap nat. -Definition nat_map := nat_mymap. -Notation Pred_nat := (fun (n1 n2: nat) (nR : nat_R n1 n2) => nat_map n1 = n2) (only parsing). -Definition nat_Rm : forall n1 n2, NatR n1 n2 -> nat_map n1 = n2. -Proof. -fix F 3. -refine (fun n1 n2 nR=> nat_R_ind Pred_nat _ _ n1 n2 nR). -+ exact (@eq_refl nat O). -+ refine (fun n1' n2' nR' e=> _). - set eta1 := fun R => S R. - have E1 := @ap nat nat S (nat_map n1') n2' (F n1' n2' nR'). - have end_ := @eq_refl nat (S n2'). - exact (E1 @ end_). - Defined. - -Inductive Box (A : Type) : Type := B : A -> Box A. -Elpi derive.param2 Box. -Elpi derive.mymap Box. -Print Box_R. - - -Print Box_R_ind. -(* The term "__R" has type "A_R _1 _2" while it is expected to have type - "@Hierarchy.rel A1 A2 (forget_10_00 A1 A2 (forget_2b0_10 A1 A2 A_R)) _1 _2". *) -Notation Pred_Box := (fun A1 A2 (AR : Param2b0.Rel A1 A2) => (fun (b1 : Box A1) (b2 : Box A2) (bR : Box_R A1 A2 AR b1 b2)=> Box_mymap A1 A2 AR b1 = b2)) (only parsing). - -(* Goal forall A1 A2 (AR: Param2b0.Rel A1 A2) b1 b2, Box_R A1 A2 AR b1 b2 -> Box_mymap A1 A2 AR b1 = b2. -simpl. *) - -Definition box_Rm : -(* forall (A1 A2 : Type) (AR : Param2b0.Rel A1 A2) (b1 : Box A1) (b2 : Box A2) -(_ : Box_R A1 A2 (@rel A1 A2 (forget_10_00 A1 A2 (forget_2b0_10 A1 A2 AR))) b1 b2), -@eq (Box A2) (Box_mymap A1 A2 (forget_2b0_10 A1 A2 AR) b1) b2. *) -forall A1 A2 (AR: Param2b0.Rel A1 A2) b1 b2, Box_R A1 A2 AR b1 b2 -> Box_mymap A1 A2 AR b1 = b2. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun b1 b2 bR=> Box_R_ind A1 A2 AR (Pred_Box A1 A2 AR) _ b1 b2 bR). -refine (fun a1 a2 aR=> _). - set eta1 := fun R => @B A2 R. - have E1 := @ap A2 (@Box A2) eta1 (map AR a1) a2 (R_in_map AR a1 a2 aR). - have end_ := @eq_refl (@Box A2) (@B A2 a2). - exact: (E1 @ end_). -Defined. - -Definition Option (A : Type) : Type := option A. - -Elpi derive.param2 option. -Definition OptionR := option_R. -(* Inductive OptionR (A1 A2 : Type) (AR : A1 -> A2 -> Type) : option A1 -> option A2 -> Type := -| SomeR : forall a1 a2 (aR : AR a1 a2), OptionR A1 A2 AR (Some a1) (Some a2) -| NoneR : OptionR A1 A2 AR None None. *) - -Elpi derive.mymap option. -Definition option_map := option_mymap. -(* Definition option_map (A1 A2 : Type) (AR : Param10.Rel A1 A2) : option A1 -> option A2 := -fun oa => - match oa with - | Some a => Some (map AR a) - | None => None - end. *) - -(* Elpi derive.injections option. *) -(* Print option_injections11. *) -Definition Pred_option := (fun A1 A2 (AR : Param2b0.Rel A1 A2)=> (fun (oa1 : option A1) (oa2 : option A2) (oaR : option_R A1 A2 AR oa1 oa2) => option_map A1 A2 AR oa1 = oa2)). -Definition option_Rm : forall (A1 A2 : Type) (AR : Param2b0.Rel A1 A2) oa1 oa2, OptionR A1 A2 AR oa1 oa2 -> option_map A1 A2 AR oa1 = oa2. -Proof. -refine (fun A1 A2 AR => _). -refine (fun oa1 oa2 oaR => option_R_ind A1 A2 AR (Pred_option A1 A2 AR) _ _ oa1 oa2 oaR). -+ refine (fun a1 a2 aR=> _). - set eta1 := fun R => @Some A2 R. - have E1 := @ap A2 (@option A2) eta1 (map AR a1) a2 (R_in_map AR a1 a2 aR). - have end_ := @eq_refl (@option A2) (@Some A2 a2). - exact (E1 @ end_). -+ exact: @eq_refl (@option A2) (@None A2). -Defined. - -Definition List (A : Type) := list A. -Elpi derive.param2 list. - -Definition ListR := list_R. -Elpi derive.mymap list. - -Definition list_map := list_mymap. -Definition Pred_list := fun A1 A2 (AR : Param2b0.Rel A1 A2)=> (fun (l1: list A1) (l2: list A2) (lR : list_R A1 A2 AR l1 l2)=> list_map A1 A2 AR l1 = l2). - -Definition list_Rm : forall (A1 A2 : Type) (AR : Param2b0.Rel A1 A2) l1 l2, ListR A1 A2 AR l1 l2 -> list_map A1 A2 AR l1 = l2. -Proof. -refine (fun A1 A2 AR=> _). -fix F 3. -refine (fun l1 l2 lR => list_R_ind A1 A2 AR (Pred_list A1 A2 AR) _ _ l1 l2 lR). -+ exact: (@eq_refl (@list A2) (@nil A2)). -+ refine (fun a1 a2 aR => _). - refine (fun l1' l2' lR' e => _). - set eta1 := fun R => @cons A2 R (list_map A1 A2 AR l1'). - set eta2 := fun R => @cons A2 a2 R. - have E1 := @ap A2 (@list A2) eta1 (map AR a1) a2 (R_in_map AR a1 a2 aR). - have E2 := @ap (@list A2) (@list A2) eta2 (list_map A1 A2 AR l1') l2' (F l1' l2' lR'). - have end_ := (@eq_refl (@list A2) (@cons A2 a2 l2')). - exact (E1 @ E2 @ end_). -Defined. - diff --git a/std/algo/detailed/Detailed_Rsym.v b/std/algo/detailed/Detailed_Rsym.v deleted file mode 100644 index b73ab708..00000000 --- a/std/algo/detailed/Detailed_Rsym.v +++ /dev/null @@ -1,112 +0,0 @@ -From Trocq Require Import symK. -Import HoTTNotations. -From Trocq Require Import coverage. -Unset Uniform Inductive Parameters. - -Require Import Hierarchy. -From mathcomp Require Import ssreflect. -Check existT. -Elpi derive False. -Definition FalseR_sym : forall f1 f2, sym_rel False_R f1 f2 <->> False_R f1 f2. -Proof. - intros f1 f2. - have@ f := False_sym f2 f1. - have@ g := False_sym f1 f2. - have@ fgK := False_symK f2 f1. - exact: (existT _ f (existT _ g fgK)). -Defined. -Print FalseR_sym. - -Elpi derive Unit. -Definition UnitR_sym : forall u1 u2, sym_rel Unit_R u1 u2 <->> Unit_R u1 u2. -Proof. - intros u1 u2. - refine (Unit_sym u2 u1; _). - refine (Unit_sym u1 u2; _). - refine (Unit_symK u2 u1). -Defined. - -Elpi derive Bool. -Definition BoolR_sym : forall u1 u2, sym_rel Bool_R u1 u2 <->> Bool_R u1 u2. -Proof. - intros u1 u2. - refine (Bool_sym u2 u1; _). - refine (Bool_sym u1 u2; _). - refine (Bool_symK u2 u1). -Defined. - -Elpi derive Wrap. -Definition WrapR_sym : forall u1 u2, sym_rel Wrap_R u1 u2 <->> Wrap_R u1 u2. -Proof. - intros u1 u2. - refine (Wrap_sym u2 u1; _). - refine (Wrap_sym u1 u2; _). - refine (Wrap_symK u2 u1). -Defined. - -Elpi derive WrapMore. -Definition WrapMoreR_sym : forall u1 u2, sym_rel WrapMore_R u1 u2 <->> WrapMore_R u1 u2. -Proof. - intros u1 u2. - refine (WrapMore_sym u2 u1; _). - refine (WrapMore_sym u1 u2; _). - refine (WrapMore_symK u2 u1). -Defined. - -Elpi derive Nat. -Definition NatR_sym : forall u1 u2, sym_rel Nat_R u1 u2 <->> Nat_R u1 u2. -Proof. - intros u1 u2. - refine (Nat_sym u2 u1; _). - refine (Nat_sym u1 u2; _). - refine (Nat_symK u2 u1). -Defined. - -Elpi derive Box. -Definition BoxR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, Box_R B A (sym_rel AR) u2 u1 <->> Box_R A B AR u1 u2. -Proof. - intros A B AR u1 u2. - refine ((Box_sym B A (sym_rel AR) u2 u1); _). - refine (Box_sym A B AR u1 u2; _). - refine (Box_symK B A (sym_rel AR) u2 u1). -Defined. - -Elpi derive Option. -Definition OptionR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, Option_R B A (sym_rel AR) u2 u1 <->> Option_R A B AR u1 u2. -Proof. - intros A B AR u1 u2. - refine ((Option_sym B A (sym_rel AR) u2 u1); _). - refine (Option_sym A B AR u1 u2; _). - refine (Option_symK B A (sym_rel AR) u2 u1). -Defined. - -Elpi derive Prod. -Definition ProdR_sym : forall (A B : Type) (AR : A -> B -> Type) (A2 B2 : Type) (AR2 : A2 -> B2 -> Type), - forall u1 u2, Prod_R B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1 <->> Prod_R A B AR A2 B2 AR2 u1 u2. -Proof. - intros A B AR A2 B2 AR2 u1 u2. - refine ((Prod_sym B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1); _). - refine (Prod_sym A B AR A2 B2 AR2 u1 u2; _). - refine (Prod_symK B A (sym_rel AR) B2 A2 (sym_rel AR2) u2 u1). -Defined. - -Elpi derive ThreeTypes. -Definition ThreeTypesR_sym : forall (A B : Type) (AR : A -> B -> Type) (A2 B2 : Type) (AR2 : A2 -> B2 -> Type) - (A3 B3 : Type) (AR3 : A3 -> B3 -> Type), - forall u1 u2, ThreeTypes_R B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1 - <->> ThreeTypes_R A B AR A2 B2 AR2 A3 B3 AR3 u1 u2. -Proof. - intros A B AR A2 B2 AR2 A3 B3 AR3 u1 u2. - refine ((ThreeTypes_sym B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1); _). - refine (ThreeTypes_sym A B AR A2 B2 AR2 A3 B3 AR3 u1 u2; _). - refine (ThreeTypes_symK B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3) u2 u1). -Defined. - -Elpi derive List. -Definition ListR_sym : forall (A B : Type) (AR : A -> B -> Type), forall u1 u2, List_R B A (sym_rel AR) u2 u1 <->> List_R A B AR u1 u2. -Proof. - intros A B AR u1 u2. - refine ((List_sym B A (sym_rel AR) u2 u1); _). - refine (List_sym A B AR u1 u2; _). - refine (List_symK B A (sym_rel AR) u2 u1). -Defined. diff --git a/std/algo/detailed/Detailed_injijK.v b/std/algo/detailed/Detailed_injijK.v deleted file mode 100644 index 96c2a68f..00000000 --- a/std/algo/detailed/Detailed_injijK.v +++ /dev/null @@ -1,257 +0,0 @@ -From Coq Require Import ssreflect ssrfun ssrbool. -From Trocq Require Import mR Rm. -From Trocq Require Import coverage. -From Trocq Require Import Hierarchy. -(* From Trocq Require Import HoTT_additions Hierarchy. *) -Unset Uniform Inductive Parameters. - -Elpi derive.param2 False. -Elpi derive.mymap False. -Elpi derive.projK False. -Elpi derive.injections False. -Elpi derive.isK False. -Elpi derive.mR False. -Elpi derive.Rm False. - -Elpi derive.param2 Unit. -Elpi derive.mymap Unit. -Elpi derive.projK Unit. -Elpi derive.injections Unit. -Elpi derive.isK Unit. -Elpi derive.mR Unit. -Elpi derive.Rm Unit. - -Elpi derive.param2 Bool. -Elpi derive.mymap Bool. -Elpi derive.isK Bool. -Elpi derive.mR Bool. -Elpi derive.Rm Bool. - -Elpi derive.param2 Wrap. -Elpi derive.mymap Wrap. -Elpi derive.projK Wrap. -Elpi derive.injections Wrap. -Elpi derive.mR Wrap. -Elpi derive.Rm Wrap. - -Definition conv (A : Type) (x y : A) (p: x = y) - (P : forall x0 : A, x = x0 -> Prop) (P0 : P x eq_refl) := - match p as p0 in _ = t return (P t p0) - with eq_refl => P0 end. - - -Notation Wrap_Pred_inj11K := (fun (u1 u2 :Unit) (p : u1 = u2) => -(Wrap_injections11 u1 u2 - (bcongr.eq_f Unit Wrap (fun R : Unit => KWrap1 R) u1 u2 p) = p)) (only parsing). -Definition Wrap_inj11K : - forall (u1 u2 : Unit) (p : u1 = u2), - Wrap_Pred_inj11K u1 u2 p. -Proof. -refine (fun u1 u2 p1=> _). -refine (conv _ u1 u2 p1 (Wrap_Pred_inj11K u1) _). -exact (@eq_refl (@eq Unit u1 u1) (@eq_refl Unit u1)). -Defined. - -Elpi derive.param2 WrapMore. -Elpi derive.mymap WrapMore. -Elpi derive.projK WrapMore. -Elpi derive.injections WrapMore. -Elpi derive.isK WrapMore. -Elpi derive.mR WrapMore. -Elpi derive.Rm WrapMore. - -Notation WrapMore_Pred_inj1K := - (fun (u1 u2 :Unit) (p : u1 = u2) (b1 b2 : Bool)(p2 : b1 = b2) f => - (f u1 u2 b1 b2 - ((bcongr.eq_f Unit WrapMore (fun R : Unit => KWrap R b1) u1 u2 p) @ (bcongr.eq_f Bool WrapMore (fun R : Bool => KWrap u2 R) b1 b2 p2)))) (only parsing). - -Notation WrapMore_Pred_inj11K := - (fun (u1 u2 :Unit) (p : u1 = u2) (b1 b2 : Bool)(p2 : b1 = b2)=> - (WrapMore_Pred_inj1K u1 u2 p b1 b2 p2 WrapMore_injections11) = p) (only parsing). - -Notation WrapMore_Pred_inj12K := - (fun (u1 u2 :Unit) (p : u1 = u2) (b1 b2 : Bool)(p2 : b1 = b2)=> - (WrapMore_Pred_inj1K u1 u2 p b1 b2 p2 WrapMore_injections12) = p2) (only parsing). - -Definition WrapMore_inj11K : - forall (u1 u2 : Unit) (p : u1 = u2), - forall (b1 b2 : Bool) (p2 : b1 = b2), -WrapMore_Pred_inj11K u1 u2 p b1 b2 p2. -Proof. -refine (fun u1 u2 p1=> _). -refine (fun b1 b2 p2=> _). -refine (conv _ u1 u2 p1 (fun (t : Unit) (p : u1 = t) => (WrapMore_Pred_inj11K u1 t p b1 b2 p2)) _). -refine (conv _ b1 b2 p2 (fun (t : Bool) (p : b1 = t) => (WrapMore_Pred_inj11K u1 u1 1 b1 t p)) _). -exact (@eq_refl (@eq Unit u1 u1) (@eq_refl Unit u1)). -Defined. - -Definition WrapMore_inj12K : - forall (u1 u2 : Unit) (p : u1 = u2), - forall (b1 b2 : Bool) (p2 : b1 = b2), - WrapMore_Pred_inj12K u1 u2 p b1 b2 p2. -Proof. -refine (fun u1 u2 p1=> _). -refine (fun b1 b2 p2=> _). -refine (conv _ u1 u2 p1 (fun (t : Unit) (p : u1 = t) => (WrapMore_Pred_inj12K u1 t p b1 b2 p2)) _). -refine (conv _ b1 b2 p2 (fun (t : Bool) (p : b1 = t) => (WrapMore_Pred_inj12K u1 u1 1 b1 t p)) _). -exact (@eq_refl (@eq Bool b1 b1) (@eq_refl Bool b1)). -Defined. - -Notation WrapMore_Pred_inj2K := - (fun (w1 w2 :Wrap) (p : w1 = w2) f => - (f w1 w2 - (bcongr.eq_f Wrap WrapMore (fun R : Wrap => KWrapWrap R) w1 w2 p))) (only parsing). - -Notation WrapMore_Pred_inj21K := - (fun (w1 w2 :Wrap) (p : w1 = w2) => - WrapMore_Pred_inj2K w1 w2 p WrapMore_injections21 = p) (only parsing). - -Definition WrapMore_inj21K : - forall (w1 w2 : Wrap) (p : w1 = w2), - WrapMore_Pred_inj21K w1 w2 p. -Proof. -refine (fun w1 w2 p=> _). -refine (conv _ w1 w2 p (fun t p => WrapMore_Pred_inj21K w1 t p) _). -exact (@eq_refl (@eq Wrap w1 w1) (@eq_refl Wrap w1)). -Defined. - -Notation WrapMore_Pred_inj3K := - (fun (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6) f => - (f u1 u2 u3 u4 u5 u6 - ((bcongr.eq_f Unit WrapMore (fun R : Unit => F R u3 u5) u1 u2 p) - @ (bcongr.eq_f Unit WrapMore (fun R : Unit => F u2 R u5) u3 u4 p2) - @ (bcongr.eq_f Unit WrapMore (fun R : Unit => F u2 u4 R) u5 u6 p3)))) (only parsing). - -Notation WrapMore_Pred_inj31K := - (fun (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6) => - WrapMore_Pred_inj3K u1 u2 p u3 u4 p2 u5 u6 p3 WrapMore_injections31 = p )(only parsing). - -Notation WrapMore_Pred_inj32K := - (fun (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6) => - WrapMore_Pred_inj3K u1 u2 p u3 u4 p2 u5 u6 p3 WrapMore_injections32 = p2 )(only parsing). - -Notation WrapMore_Pred_inj33K := - (fun (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6) => - WrapMore_Pred_inj3K u1 u2 p u3 u4 p2 u5 u6 p3 WrapMore_injections33 = p3 )(only parsing). - -Definition WrapMore_inj31K : - forall (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6), - WrapMore_Pred_inj31K u1 u2 p u3 u4 p2 u5 u6 p3. -Proof. -refine (fun u1 u2 p=> _). -refine (fun u3 u4 p2=> _). -refine (fun u5 u6 p3=> _). -refine (conv _ u1 u2 p (fun t p => WrapMore_Pred_inj31K u1 t p u3 u4 p2 u5 u6 p3) _). -refine (conv _ u3 u4 p2 (fun t p => WrapMore_Pred_inj31K u1 u1 1 u3 t p u5 u6 p3) _). -refine (conv _ u5 u6 p3 (fun t p => WrapMore_Pred_inj31K u1 u1 1 u3 u3 1 u5 t p) _). -refine (@eq_refl (@eq Unit u1 u1) (@eq_refl Unit u1)). -Defined. - -Definition WrapMore_inj32K : - forall (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6), - WrapMore_Pred_inj32K u1 u2 p u3 u4 p2 u5 u6 p3. -Proof. -refine (fun u1 u2 p=> _). -refine (fun u3 u4 p2=> _). -refine (fun u5 u6 p3=> _). -refine (conv _ u1 u2 p ((fun t p => WrapMore_Pred_inj32K u1 t p u3 u4 p2 u5 u6 p3)) _). -refine (conv _ u3 u4 p2 ((fun t p => WrapMore_Pred_inj32K u1 u1 1 u3 t p u5 u6 p3)) _). -refine (conv _ u5 u6 p3 ((fun t p => WrapMore_Pred_inj32K u1 u1 1 u3 u3 1 u5 t p) ) _). -refine (@eq_refl (@eq Unit u3 u3) (@eq_refl Unit u3)). -Defined. - -Definition WrapMore_inj33K : - forall (u1 u2 : Unit) (p : u1 = u2) (u3 u4 : Unit) (p2 : u3 = u4) (u5 u6 : Unit) (p3 : u5 = u6), - WrapMore_Pred_inj33K u1 u2 p u3 u4 p2 u5 u6 p3. -Proof. -refine (fun u1 u2 p=> _). -refine (fun u3 u4 p2=> _). -refine (fun u5 u6 p3=> _). -refine (conv _ u1 u2 p (fun t p => WrapMore_Pred_inj33K u1 t p u3 u4 p2 u5 u6 p3) _). -refine (conv _ u3 u4 p2 (fun t p => WrapMore_Pred_inj33K u1 u1 1 u3 t p u5 u6 p3) _). -refine (conv _ u5 u6 p3 (fun t p => WrapMore_Pred_inj33K u1 u1 1 u3 u3 1 u5 t p) _). -refine (@eq_refl (@eq Unit u5 u5) (@eq_refl Unit u5)). -Defined. - -Elpi derive.param2 Nat. -Elpi derive.mymap Nat. -Elpi derive.projK Nat. -Elpi derive.injections Nat. -Elpi derive.isK Nat. -Elpi derive.mR Nat. -Elpi derive.Rm Nat. - -Notation nat_Pred_inj2K := - (fun (n1 n2 : Nat) (p : n1 = n2) f => - f n1 n2 (bcongr.eq_f Nat Nat (fun R => S' R) n1 n2 p)) (only parsing). -Notation nat_Pred_inj21K := - (fun (n1 n2 : Nat) (p : n1 = n2) => - nat_Pred_inj2K n1 n2 p Nat_injections21 = p) (only parsing). - -Definition nat_inj21K : - forall (n1 n2 : Nat) (p : n1 = n2), - nat_Pred_inj21K n1 n2 p. -Proof. -refine (fun n1 n2 p=> _). -refine (conv _ n1 n2 p (fun t p => nat_Pred_inj21K n1 t p) _). -refine (@eq_refl (@eq Nat n1 n1) (@eq_refl Nat n1)). -Defined. - -Elpi derive.param2 Box. -Elpi derive.mymap Box. -Elpi derive.projK Box. -Elpi derive.injections Box. -Elpi derive.isK Box. -Elpi derive.mR Box. -Elpi derive.Rm Box. - -Notation Box_Pred_inj1K := - (fun (A2: Type) (a1 a2 : A2) (p : a1 = a2) f => - f A2 a1 a2 (bcongr.eq_f A2 (@Box A2) (fun R => @B A2 R) a1 a2 p)) (only parsing). - -Notation Box_Pred_inj11K := - (fun (A2: Type) (a1 a2 : A2) (p : a1 = a2) => - Box_Pred_inj1K A2 a1 a2 p Box_injections11 = p) (only parsing). - -Definition Box_inj11K : - forall (A2: Type) (a1 a2 : A2) (p : a1 = a2), - Box_Pred_inj11K A2 a1 a2 p. -Proof. -refine (fun A2=> _). -refine (fun a1 a2 p=> _). -refine (conv A2 a1 a2 p (fun t p => Box_Pred_inj11K A2 a1 t p) _). -refine (@eq_refl (@eq A2 a1 a1) (@eq_refl A2 a1)). -Defined. - -Elpi derive.param2 Option. -Elpi derive.mymap Option. -Elpi derive.projK Option. -Elpi derive.injections Option. -Elpi derive.isK Option. -Elpi derive.mR Option. -Elpi derive.Rm Option. - -Elpi derive.param2 Prod. -Elpi derive.mymap Prod. -Elpi derive.projK Prod. -Elpi derive.injections Prod. -Elpi derive.isK Prod. -Elpi derive.mR Prod. -Elpi derive.Rm Prod. - -Elpi derive.param2 ThreeTypes. -Elpi derive.mymap ThreeTypes. -Elpi derive.projK ThreeTypes. -Elpi derive.injections ThreeTypes. -Elpi derive.isK ThreeTypes. -Elpi derive.mR ThreeTypes. -Elpi derive.Rm ThreeTypes. - -Elpi derive.param2 List. -Elpi derive.mymap List. -Elpi derive.projK List. -Elpi derive.injections List. -Elpi derive.isK List. -Elpi derive.mR List. -Elpi derive.Rm List. - diff --git a/std/algo/detailed/Detailed_mRRmK.v b/std/algo/detailed/Detailed_mRRmK.v deleted file mode 100644 index 604335d2..00000000 --- a/std/algo/detailed/Detailed_mRRmK.v +++ /dev/null @@ -1,306 +0,0 @@ -From Coq Require Import ssreflect ssrfun ssrbool. -From Trocq Require Import mR Rm injK. -From Trocq Require Import Hierarchy. -From Trocq Require Import HoTTNotations. -From Trocq Require Import coverage. -(* Search (?e ^). *) -(* From Trocq Require Import HoTT_additions Hierarchy. *) -Unset Uniform Inductive Parameters. - -Elpi derive.param2 False. -Elpi derive.mymap False. -Elpi derive.projK False. -Elpi derive.injections False. -Elpi derive.isK False. -Elpi derive.mR False. -Elpi derive.Rm False. -Elpi derive.injK False. - -Notation False_Pred := (fun w1 w2 wR => False_mR w1 w2 (False_Rm w1 w2 wR) = wR) (only parsing). -Definition False_mRRmK : forall (w1 w2 : False) (wR : False_R w1 w2), False_mR w1 w2 (False_Rm w1 w2 wR) = wR. -Proof. -refine (fun f1 f2 fR => _). -exact (False_R_ind False_Pred f1 f2 fR). -Defined. - -Elpi derive.param2 Unit. -Elpi derive.mymap Unit. -Elpi derive.projK Unit. -Elpi derive.injections Unit. -Elpi derive.isK Unit. -Elpi derive.mR Unit. -Elpi derive.Rm Unit. - -Notation Unit_Pred := (fun u1 u2 uR => Unit_mR u1 u2 (Unit_Rm u1 u2 uR) = uR). -Definition Unit_mRRmK : forall (w1 w2 : Unit) (wR : Unit_R w1 w2), Unit_mR w1 w2 (Unit_Rm w1 w2 wR) = wR. -Proof. -refine (fun u1 u2 uR=> _). -refine (Unit_R_ind Unit_Pred _ u1 u2 uR). -- exact (@eq_refl (Unit_R TT TT) TT_R). -Defined. - -Elpi derive.param2 Bool. -Elpi derive.mymap Bool. -Elpi derive.isK Bool. -Elpi derive.mR Bool. -Elpi derive.Rm Bool. - -Notation Bool_Pred := (fun b1 b2 bR => Bool_mR b1 b2 (Bool_Rm b1 b2 bR) = bR). -Definition Bool_mRRmK : forall (w1 w2 : Bool) (wR : Bool_R w1 w2), Bool_mR w1 w2 (Bool_Rm w1 w2 wR) = wR. -Proof. -refine (fun b1 b2 bR=> _). -refine (Bool_R_ind Bool_Pred _ _ b1 b2 bR). -- exact (@eq_refl (Bool_R Falseb Falseb) Falseb_R). -- exact (@eq_refl (Bool_R Trueb Trueb) Trueb_R). -Defined. - -Elpi derive.param2 Wrap. -Elpi derive.mymap Wrap. -Elpi derive.projK Wrap. -Elpi derive.injections Wrap. -Elpi derive.mR Wrap. -Elpi derive.Rm Wrap. -Elpi derive.injK Wrap. - -Notation Wrap_Pred := (fun w1 w2 wR => Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR) (only parsing). -Definition Wrap_mRRmK : forall (w1 w2 : Wrap) (wR : Wrap_R w1 w2), - Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. -Proof. -refine (fun w1 w2 wR=> _). -refine (Wrap_R_ind Wrap_Pred _ w1 w2 wR). -- refine (fun u1 u2 uR => _). -refine (@eq_ind _ _ (fun t=> KWrap1_R _ _ (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR) _ _ (Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))^). -refine (@eq_ind _ uR (fun t => KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR) _ _ (Unit_mRRmK u1 u2 uR)^). -exact (@eq_refl (Wrap_R (KWrap1 u1) (KWrap1 u2)) (KWrap1_R u1 u2 uR)). -Defined. - -Definition Wrap_mRRmK' : forall (w1 w2 : Wrap) (wR : Wrap_R w1 w2), - Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. -Proof. -refine (fun w1 w2 wR=> _). -refine (Wrap_R_ind Wrap_Pred _ w1 w2 wR). -- refine (fun u1 u2 uR => _). -unfold Wrap_mR. -unfold Wrap_Rm. -unfold Wrap_R_ind. -simpl. -cbv. -refine (match -(@eq_sym _ _ _ (Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))) -(* (Wrap_injK11 (Unit_mymap u1) u2 (Unit_Rm u1 u2 uR))^ *) -(* in _ = t -return KWrap1_R u1 u2 (Unit_mR u1 u2 t) = KWrap1_R u1 u2 uR *) -with eq_refl => _ end -). -Show Proof. - -refine (match (Unit_mRRmK u1 u2 uR)^ in _ = t -(* return KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR *) -with eq_refl => eq_refl end -). -Show Proof. -Defined. - -Elpi derive.param2 WrapMore. -Elpi derive.mymap WrapMore. -Elpi derive.projK WrapMore. -Elpi derive.injections WrapMore. -Elpi derive.isK WrapMore. -Elpi derive.mR WrapMore. -Elpi derive.Rm WrapMore. -Elpi derive.injK WrapMore. - -Notation WrapMore_Pred := (fun w1 w2 wR => WrapMore_mR w1 w2 (WrapMore_Rm w1 w2 wR) = wR) (only parsing). - -Definition WrapMore_mRRmK : - forall (w1 w2 : WrapMore) (wR: WrapMore_R w1 w2), - WrapMore_mR w1 w2 (WrapMore_Rm w1 w2 wR) = wR. -Proof. -refine (fun w1 w2 wR => _). -refine (WrapMore_R_ind WrapMore_Pred _ _ _ w1 w2 wR). -- refine (fun u1 u2 uR => _). - refine (fun b1 b2 bR => _). - unfold WrapMore_mR. - refine (match (WrapMore_injK11 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^ - (* in _ = t - return -KWrap_R u1 u2 (Unit_mR u1 u2 (Unit_Rm u1 u2 uR)) b1 b2 -(Bool_mR b1 b2 -(WrapMore_injections12 (Unit_mymap u1) u2 -(Bool_mymap b1) b2 -(WrapMore_Rm (KWrap u1 b1) (KWrap u2 b2) -(KWrap_R u1 u2 uR b1 b2 bR)))) = -KWrap_R u1 u2 uR b1 b2 bR - *) - -(* KWrap_R u1 u2 (Unit_mR u1 u2 t) b1 b2 _ = -_ *) -(* (Bool_mR b1 b2 -(WrapMore_injections12 -(Unit_mymap u1) u2 (Bool_mymap b1) -b2 -(bcongr.eq_f Unit WrapMore -(KWrap^~ (Bool_mymap b1)) -(Unit_mymap u1) u2 -(Unit_Rm u1 u2 uR) @ -bcongr.eq_f Bool WrapMore -[eta KWrap u2] (Bool_mymap b1) b2 -(Bool_Rm b1 b2 bR)))) = -KWrap_R u1 u2 uR b1 b2 bR *) -with eq_refl => _ end). - - - refine (match (Unit_mRRmK _ _ uR)^ in _ = t return - KWrap_R u1 u2 t b1 b2 -(Bool_mR b1 b2 -(WrapMore_injections12 -(Unit_mymap u1) u2 (Bool_mymap b1) -b2 -(bcongr.eq_f Unit WrapMore -(KWrap^~ (Bool_mymap b1)) -(Unit_mymap u1) u2 -(Unit_Rm u1 u2 uR) @ -bcongr.eq_f Bool WrapMore -[eta KWrap u2] (Bool_mymap b1) b2 -(Bool_Rm b1 b2 bR)))) = -KWrap_R u1 u2 uR b1 b2 bR -with eq_refl => _ end). -set RWe1 := (WrapMore_injK12 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^. -set eqf1 := bcongr.eq_f _ _ _ _ _ _. -set eqf2 := bcongr.eq_f _ _ _ _ _ _. -set T := WrapMore_injections12 (Unit_mymap u1) u2 (Bool_mymap b1) b2 -(bcongr.eq_f Unit WrapMore (KWrap^~ (Bool_mymap b1)) (Unit_mymap u1) u2 -(Unit_Rm u1 u2 uR) @ -(bcongr.eq_f Bool WrapMore [eta KWrap u2] (Bool_mymap b1) b2 (Bool_Rm b1 b2 bR) @ -1)). -refine (match (WrapMore_injK12 (Unit_mymap u1) u2 (Unit_Rm _ _ uR) (Bool_mymap b1) b2 (Bool_Rm _ _ bR))^ -(* in _ = t *) -(* return -KWrap_R u1 u2 uR b1 b2 -(Bool_mR b1 b2 t) = -KWrap_R u1 u2 uR b1 b2 bR *) -with eq_refl => _ end -). -refine (match (Bool_mRRmK _ _ bR)^ in _ = t return -KWrap_R u1 u2 uR b1 b2 t = -KWrap_R u1 u2 uR b1 b2 bR -with eq_refl => eq_refl end -). -- move=> wr1 wr2 wrR. -simpl. -by rewrite WrapMore_injK21 Wrap_mRRmK. -- move=> u1 u2 uR1 u3 u4 uR2 u5 u6 uR3. -simpl. - by rewrite /= WrapMore_injK31 WrapMore_injK32 WrapMore_injK33 !Unit_mRRmK. -Defined. - -Elpi derive.param2 Nat. -Elpi derive.mymap Nat. -Elpi derive.projK Nat. -Elpi derive.injections Nat. -Elpi derive.isK Nat. -Elpi derive.mR Nat. -Elpi derive.Rm Nat. -Elpi derive.injK Nat. -Notation Nat_Pred := (fun n1 n2 nR => Nat_mR n1 n2 (Nat_Rm n1 n2 nR) = nR) (only parsing). - -Definition Nat_mRRmK : - forall (n1 n2 : Nat ) (nR: Nat_R n1 n2), - Nat_mR n1 n2 (Nat_Rm n1 n2 nR) = nR. -Proof. - fix f 3. -refine (fun n1 n2 nR => _). -refine (Nat_R_ind Nat_Pred _ _ n1 n2 nR). -- exact eq_refl. -- refine (fun n1' n2' nR' Hrec=> _ ). -by rewrite Nat_injK21 f. -Defined. - -Elpi derive.param2 Box. -Elpi derive.mymap Box. -Elpi derive.projK Box. -Elpi derive.injections Box. -Elpi derive.isK Box. -Elpi derive.mR Box. -Elpi derive.Rm Box. -Elpi derive.injK Box. - -Notation Box_Pred := (fun A1 A2 (AR : Param40.Rel A1 A2) => fun b1 b2 bR => Box_mR A1 A2 AR b1 b2 (Box_Rm A1 A2 AR b1 b2 bR) = bR) (only parsing). - -Definition Box_mRRmK : -forall (A1 A2 : Type) (AR : Param40.Rel A1 A2), - forall (b1 : Box A1) (b2 : Box A2) (bR: Box_R A1 A2 AR b1 b2), - Box_mR A1 A2 AR b1 b2 (Box_Rm A1 A2 AR b1 b2 bR) = bR. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun b1 b2 bR=> Box_R_ind A1 A2 AR (Box_Pred A1 A2 AR) _ b1 b2 bR). -refine (fun a1 a2 aR=> _). -simpl. -by rewrite Box_injK11 (R_in_mapK AR a1 a2 aR). -Defined. - -Elpi derive.param2 Option. -Elpi derive.mymap Option. -Elpi derive.projK Option. -Elpi derive.injections Option. -Elpi derive.isK Option. -Elpi derive.mR Option. -Elpi derive.Rm Option. -Elpi derive.injK Option. - -Elpi derive.param2 Prod. -Elpi derive.mymap Prod. -Elpi derive.projK Prod. -Elpi derive.injections Prod. -Elpi derive.isK Prod. -Elpi derive.mR Prod. -Elpi derive.Rm Prod. -Elpi derive.injK Prod. - -Notation Prod_Pred := (fun A1 A2 (AR : Param40.Rel A1 A2) A3 A4 (AR2 : Param40.Rel A3 A4) => - fun p1 p2 pR => Prod_mR A1 A2 AR A3 A4 AR2 p1 p2 (Prod_Rm A1 A2 AR A3 A4 AR2 p1 p2 pR) = pR) (only parsing). -Definition Prod_mRRmK : -forall (A1 A2 : Type) (AR : Param40.Rel A1 A2), - forall (A3 A4 : Type) (AR2 : Param40.Rel A3 A4), - forall (p1 : Prod A1 A3) (p2 : Prod A2 A4) (pR: Prod_R A1 A2 AR A3 A4 AR2 p1 p2), - Prod_mR A1 A2 AR A3 A4 AR2 p1 p2 (Prod_Rm A1 A2 AR A3 A4 AR2 p1 p2 pR) = pR. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun A3 A4 AR2=> _). -refine (fun p1 p2 pR=> Prod_R_ind A1 A2 AR A3 A4 AR2 (Prod_Pred A1 A2 AR A3 A4 AR2) _ p1 p2 pR). -refine (fun a1 a2 aR=> _). -refine (fun b1 b2 bR=> _). -unfold Prod_mR. -Check PR. -simpl. -by rewrite Prod_injK11 Prod_injK12 (R_in_mapK AR a1 a2 aR) (R_in_mapK AR2 b1 b2). -Defined. - -Elpi derive.param2 Mix. -(* Fail Elpi derive.mymap Mix. -TODO: fix universe issue -*) -Elpi derive.projK Mix. -Elpi derive.injections Mix. -Elpi derive.isK Mix. -Elpi derive.mR Mix. -Elpi derive.Rm Mix. -Elpi derive.injK Mix. - -Elpi derive.param2 ThreeTypes. -Elpi derive.mymap ThreeTypes. -Elpi derive.projK ThreeTypes. -Elpi derive.injections ThreeTypes. -Elpi derive.isK ThreeTypes. -Elpi derive.mR ThreeTypes. -Elpi derive.Rm ThreeTypes. -Elpi derive.injK ThreeTypes. - -Elpi derive.param2 List. -Elpi derive.mymap List. -Elpi derive.projK List. -Elpi derive.injections List. -Elpi derive.isK List. -Elpi derive.mR List. -Elpi derive.Rm List. -Elpi derive.injK List. diff --git a/std/algo/detailed/Detailed_nm_inm.v b/std/algo/detailed/Detailed_nm_inm.v deleted file mode 100644 index 43c7a676..00000000 --- a/std/algo/detailed/Detailed_nm_inm.v +++ /dev/null @@ -1,62 +0,0 @@ - -From Trocq Require Import map4 umap Rel40 symK RsymK. -Import HoTTNotations. -From Trocq Require Import coverage. -Unset Uniform Inductive Parameters. - -Require Import Stdlib Hierarchy Param_lemmas. -Elpi derive List. - -(* From Trocq Require Import Hierarchy. *) -Require Import ssreflect. - -Lemma M1_List : forall A B (AR : A -> B -> Type) (AM : Map1.Has AR), - Map1.Has (List_R A B AR). -move=> A B AR M1. -apply Map1.BuildHas. -apply (List_mymap A B AR M1). -Set Printing All. -Show Proof. -Qed. -Lemma M2a_List : forall A B (AR : A -> B -> Type) (AM : Map2a.Has AR), - Map2a.Has (List_R A B AR). -move=> A B AR M1. -apply (Map2a.BuildHas _ _ _ (List_mymap A B AR M1) (List_mR A B AR M1)). -Show Proof. -Qed. -Lemma M2b_List : forall A B (AR : A -> B -> Type) (AM : Map2b.Has AR), - Map2b.Has (List_R A B AR). -move=> A B AR M1. -apply (Map2b.BuildHas _ _ _ (List_mymap A B AR M1) (List_Rm A B AR M1)). -Show Proof. -Qed. - -Lemma M3_List : forall A B (AR : A -> B -> Type) (AM : Map3.Has AR), - Map3.Has (List_R A B AR). -move=> A B AR M1. -apply (Map3.BuildHas _ _ _ (List_mymap A B AR M1) (List_mR A B AR M1) (List_Rm A B AR M1)). -Show Proof. -Qed. - -Lemma M4_List : forall A B (AR : A -> B -> Type) (AM : Map4.Has AR), - Map4.Has (List_R A B AR). -move=> A B AR M1. -About Map4.BuildHas. -About Map3.BuildHas. -apply (@Map4.BuildHas _ _ _ (List_mymap A B AR M1) (List_mR A B AR M1) (List_Rm A B AR M1) (List_mRRmK A B AR M1)). -Show Proof. -Qed. - -Lemma p42a_list : forall A B (AR : Param42a.Rel A B), Param42a.Rel (List A) (List B). -Proof. -move=> A B [R coM contraM]. -unshelve econstructor. -- exact: List_R. -- by apply List_umap. -- -unshelve eapply eq_Map2a. -exact (List_R B A (sym_rel R)). -exact (List_rsymK B A (sym_rel R)). -by apply M2a_List. -Show Proof. -Qed. \ No newline at end of file diff --git a/std/algo/detailed/Detailed_rel44.v b/std/algo/detailed/Detailed_rel44.v deleted file mode 100644 index 95fde2f4..00000000 --- a/std/algo/detailed/Detailed_rel44.v +++ /dev/null @@ -1,91 +0,0 @@ - -From Trocq Require Import map4 umap Rel40 symK RsymK. -Import HoTTNotations. -From Trocq Require Import coverage. -Unset Uniform Inductive Parameters. - -Require Import Stdlib Hierarchy Param_lemmas. -Elpi derive False. - -Definition Param44_False : Param44.Rel False False := - MkUParam False_umap (eq_Map4 False_rsymK False_umap). - -Elpi derive Unit. -Definition Param00_Unit : Param00.Rel Unit Unit := - Param00.BuildRel _ _ Unit_R Unit_umap (eq_Map0 Unit_rsymK Unit_umap). - -Definition Param11_Unit : Param11.Rel Unit Unit := - Param11.BuildRel _ _ Unit_R Unit_umap (eq_Map1 Unit_rsymK Unit_umap). - -Definition Param2a2a_Unit : Param2a2a.Rel Unit Unit := - Param2a2a.BuildRel _ _ Unit_R Unit_umap (eq_Map2a Unit_rsymK Unit_umap). - -Definition Param2b2b_Unit : Param2b2b.Rel Unit Unit := - Param2b2b.BuildRel _ _ Unit_R Unit_umap (eq_Map2b Unit_rsymK Unit_umap). - -Definition Param33_Unit : Param33.Rel Unit Unit := - Param33.BuildRel _ _ Unit_R Unit_umap (eq_Map3 Unit_rsymK Unit_umap). - -Definition Param44_Unit : Param44.Rel Unit Unit := - MkUParam Unit_umap (eq_Map4 Unit_rsymK Unit_umap). - -Elpi derive Bool. -Definition Param44_Bool : Param44.Rel Bool Bool := - MkUParam Bool_umap (eq_Map4 Bool_rsymK Bool_umap). - -Elpi derive Wrap. -Definition Param44_Wrap : Param44.Rel Wrap Wrap := - MkUParam Wrap_umap (eq_Map4 Wrap_rsymK Wrap_umap). - -Elpi derive WrapMore. - -Definition Param44_WrapMore : Param44.Rel WrapMore WrapMore := - MkUParam WrapMore_umap (eq_Map4 WrapMore_rsymK WrapMore_umap). - -Elpi derive Nat. -Definition Param44_Nat : Param44.Rel Nat Nat := - MkUParam Nat_umap (eq_Map4 Nat_rsymK Nat_umap). - -Elpi derive Box. -Definition Param00_Box : forall (A B : Type) (AR : Param00.Rel A B), Param00.Rel (Box A) (Box B). - Fail refine( fun A B AR=> Param00.BuildRel _ _ (Box_R A B AR) _ (eq_Map0 (Box_rsymK A B AR) _)). -Abort. - -Definition Param44_Box : forall (A B : Type) (AR : Param44.Rel A B), Param44.Rel (Box A) (Box B). -Proof. - refine (fun A B AR => Param44.BuildRel (Box_umap A B AR (Param44.covariant A B AR)) _). - refine (eq_Map4 (Box_rsymK B A (sym_rel AR)) (Box_umap B A (sym_rel AR) (Param44.contravariant A B AR))). - Show Proof. -Defined. - -Elpi derive Option. -Definition Param44_Option : forall (A B : Type) (AR : Param44.Rel A B), Param44.Rel (Option A) (Option B). -Proof. - refine (fun A B AR => MkUParam (Option_umap A B AR (Param44.covariant _ _ _)) _). - refine (eq_Map4 (Option_rsymK B A (sym_rel AR)) (Option_umap _ _ _ (Param44.contravariant _ _ _))). -Defined. - -Elpi derive Prod. -Definition Param44_Prod : forall (A B : Type) (AR : Param44.Rel A B) (A2 B2 : Type) (AR2 : Param44.Rel A2 B2), - Param44.Rel (Prod A A2) (Prod B B2). -Proof. - refine (fun A B AR A2 B2 AR2 => MkUParam (Prod_umap A B AR (Param44.covariant _ _ _) A2 B2 AR2 (Param44.covariant _ _ _)) _). - refine (eq_Map4 (Prod_rsymK B A (sym_rel AR) B2 A2 (sym_rel AR2)) (Prod_umap _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _))). -Defined. - -Elpi derive ThreeTypes. -Definition Param44_ThreeTypes : forall (A B : Type) (AR : Param44.Rel A B) (A2 B2 : Type) (AR2 : Param44.Rel A2 B2) - (A3 B3 : Type) (AR3 : Param44.Rel A3 B3), - Param44.Rel (ThreeTypes A A2 A3) (ThreeTypes B B2 B3). -Proof. - refine (fun A B AR A2 B2 AR2 A3 B3 AR3 => - MkUParam (ThreeTypes_umap A B AR (Param44.covariant _ _ _) A2 B2 AR2 (Param44.covariant _ _ _) A3 B3 AR3 (Param44.covariant _ _ _)) _). - refine (eq_Map4 (ThreeTypes_rsymK B A (sym_rel AR) B2 A2 (sym_rel AR2) B3 A3 (sym_rel AR3)) (ThreeTypes_umap _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _) _ _ _ (Param44.contravariant _ _ _))). -Defined. - -Elpi derive List. -Definition Param44_List : forall (A B : Type) (AR : Param44.Rel A B), Param44.Rel (List A) (List B). -Proof. - refine (fun A B AR => MkUParam (List_umap A B AR (Param44.covariant _ _ _)) _). - refine (eq_Map4 (List_rsymK B A (sym_rel AR)) (List_umap _ _ _ (Param44.contravariant _ _ _))). -Defined. diff --git a/std/algo/detailed/Detailed_sym.v b/std/algo/detailed/Detailed_sym.v deleted file mode 100644 index 7373190d..00000000 --- a/std/algo/detailed/Detailed_sym.v +++ /dev/null @@ -1,123 +0,0 @@ -From Coq Require Import ssreflect. -From elpi.apps.derive Require Import derive derive.param2. -Require Import Hierarchy. -From Trocq Require Import coverage. -(* Require Import HoTT_additions Hierarchy. *) -Unset Uniform Inductive Parameters. -(* Unset Universe Polymorphism. *) -Unset Universe Minimization ToSet. - -(* Definition Unit := unit. *) - -Elpi derive.param2 Unit. -Definition UnitR := Unit_R. -Definition unit_Pred := fun (s1 s2: Unit) (RR : Unit_R s1 s2)=> Unit_R s2 s1. - -Definition unitR_sym : forall u1 u2, UnitR u1 u2 -> UnitR u2 u1. -Proof. -move=> u1 u2 uR. -refine (Unit_R_rect unit_Pred _ u1 u2 uR). -- exact TT_R. -Defined. - -Elpi derive.param2 Bool. -Definition BoolR := Bool_R. - -Notation BoolR_symPred := (fun b1 b2 (bR : Bool_R b1 b2)=> Bool_R b2 b1). -Definition boolR_sym : forall b1 b2 (bR : Bool_R b1 b2), Bool_R b2 b1. -Proof. -refine (fun b1 b2 bR=> Bool_R_rect BoolR_symPred _ _ b1 b2 bR). -- exact: Falseb_R. -- exact: Trueb_R. -Defined. - -Elpi derive.param2 Wrap. -Definition WrapR := Wrap_R. - -Notation wrapR_symPred := (fun w1 w2 (wR : Wrap_R w1 w2) => Wrap_R w2 w1). -Definition wrapR_sym : forall w1 w2, Wrap_R w1 w2 -> Wrap_R w2 w1. -Proof. -refine (fun w1 w2 wR=> Wrap_R_rect wrapR_symPred _ w1 w2 wR). -refine (fun u1 u2 uR=> _). -exact: (KWrap1_R u2 u1 (unitR_sym u1 u2 uR)). -Defined. - -Elpi derive.param2 WrapMore. -Notation wrapMoreR_symPred := (fun w1 w2 (wR : WrapMore_R w1 w2) => WrapMore_R w2 w1). -Definition wrapMoreR_sym : forall w1 w2, WrapMore_R w1 w2 -> WrapMore_R w2 w1. -Proof. -refine (fun w1 w2 wR=> WrapMore_R_rect wrapMoreR_symPred _ _ _ w1 w2 wR). -- refine (fun u1 u2 uR=> _). - refine (fun b1 b2 bR=> _). - exact: (KWrap_R u2 u1 (unitR_sym u1 u2 uR) b2 b1 (boolR_sym b1 b2 bR)). -- refine (fun w1 w2 wR=> _). - exact: (KWrapWrap_R w2 w1 (wrapR_sym w1 w2 wR)). -- refine (fun u1 u2 uR=> _). - refine (fun u3 u4 uR2=> _). - refine (fun u5 u6 uR3=> _). - exact: (F_R u2 u1 (unitR_sym u1 u2 uR) u4 u3 (unitR_sym u3 u4 uR2) u6 u5 (unitR_sym u5 u6 uR3)). -Defined. - -Definition Nat := nat. -Elpi derive.param2 nat. -Definition NatR := nat_R. - -Notation nat_symPred := (fun w1 w2 (wR : nat_R w1 w2) => nat_R w2 w1). -Fixpoint nat_sym : forall w1 w2, nat_R w1 w2 -> nat_R w2 w1. -Proof. -refine (fun w1 w2 wR=> nat_R_rect nat_symPred _ _ w1 w2 wR). -exact: O_R. -refine (fun n1 n2 nR IH => _). -apply (S_R _ _ (nat_sym _ _ nR)). -Defined. - -Inductive Box (A : Type) : Type := B : A -> Box A. -Elpi derive.param2 Box. - -Notation boxR_symPred := (fun A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : Box_R A1 A2 AR b1 b2) => Box_R A2 A1 (sym_rel AR) b2 b1). -Definition boxR_sym : forall A1 A2 (AR: A1 -> A2 -> Type) b1 b2, Box_R A1 A2 AR b1 b2 -> Box_R A2 A1 (sym_rel AR) b2 b1. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun b1 b2 bR=> _). -refine (Box_R_rect A1 A2 AR (boxR_symPred A1 A2 AR) _ _ _ bR). -move=> a1 a2 ar. -refine (B_R A2 A1 (sym_rel AR) a2 a1 _). -exact: ( (fun x y r => r) a1 a2 ar). -Defined. - -Elpi derive.param2 Option. - -Notation Option_symPred := (fun A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : Option_R A1 A2 AR b1 b2) => Option_R A2 A1 (sym_rel AR) b2 b1). -Definition Option_sym : forall A1 A2 (AR: A1 -> A2 -> Type) b1 b2, Option_R A1 A2 AR b1 b2 -> Option_R A2 A1 (sym_rel AR) b2 b1. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun b1 b2 bR=> _). -refine (Option_R_rect A1 A2 AR (Option_symPred A1 A2 AR) _ _ _ _ bR). -- move=> a1 a2 ar. exact: (Some_R A2 A1 (sym_rel AR) a2 a1 ar). -- exact: (None_R A2 A1 (sym_rel AR)). -Defined. - -Elpi derive.param2 List. - -Notation List_symPred := (fun A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : List_R A1 A2 AR b1 b2) => List_R A2 A1 (sym_rel AR) b2 b1). -Fixpoint List_sym : forall A1 A2 (AR: A1 -> A2 -> Type) b1 b2, List_R A1 A2 AR b1 b2 -> List_R A2 A1 (sym_rel AR) b2 b1. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun b1 b2 bR=> _). -refine (List_R_rect A1 A2 AR (List_symPred A1 A2 AR) _ _ _ _ bR). -- exact: (nil_R A2 A1 (sym_rel AR)). -- move=> a1 a2 ar l1 l2 lr IH. -exact: (cons_R A2 A1 (sym_rel AR) a2 a1 ar l2 l1 (List_sym A1 A2 AR _ _ lr)). -Defined. - -Elpi derive.param2 Prod. - -Notation Prod_symPred := (fun A1 A2 (AR: A1 -> A2 -> Type) B1 B2 (BR : B1 -> B2 -> Type) b1 b2 (bR : Prod_R A1 A2 AR B1 B2 BR b1 b2) => Prod_R A2 A1 (sym_rel AR) B2 B1 (sym_rel BR) b2 b1). -Definition Prod_sym : forall A1 A2 (AR: A1 -> A2 -> Type) B1 B2 (BR: B1 -> B2 -> Type) b1 b2, Prod_R A1 A2 AR B1 B2 BR b1 b2 -> Prod_R A2 A1 (sym_rel AR) B2 B1 (sym_rel BR) b2 b1. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun B1 B2 BR=> _). -refine (fun b1 b2 bR=> _). -refine (Prod_R_rect A1 A2 AR B1 B2 BR (Prod_symPred A1 A2 AR B1 B2 BR) _ _ _ bR). -- move=> a1 a2 ar b b' br. exact: (pair_R A2 A1 (sym_rel AR) B2 B1 (sym_rel BR) a2 a1 ar b' b br). -Defined. diff --git a/std/algo/detailed/Detailed_symK.v b/std/algo/detailed/Detailed_symK.v deleted file mode 100644 index f70170c6..00000000 --- a/std/algo/detailed/Detailed_symK.v +++ /dev/null @@ -1,158 +0,0 @@ -From Coq Require Import ssreflect. -From elpi.apps.derive Require Import derive derive.param2. -Require Import Hierarchy. -From Trocq Require Import HoTTNotations. -From Trocq Require Import coverage sym. -(* Require Import HoTT_additions Hierarchy. *) -Unset Uniform Inductive Parameters. -(* Unset Universe Polymorphism. *) -Unset Universe Minimization ToSet. - -Elpi derive.param2 False. -Elpi derive.sym False. - -Definition False_symKPred := fun u1 u2 (uR : False_R u1 u2)=> False_sym u2 u1 (False_sym u1 u2 uR) = uR. -Definition False_symK : forall u1 u2 (uR : False_R u1 u2), False_sym u2 u1 (False_sym u1 u2 uR) = uR. -Proof. -move=> u1 u2 uR. -refine (False_R_ind False_symKPred u1 u2 uR). -Defined. - -Elpi derive.param2 Unit. -Elpi derive.sym Unit. - -Definition Unit_symKPred := fun u1 u2 (uR : Unit_R u1 u2)=> Unit_sym u2 u1 (Unit_sym u1 u2 uR) = uR. -Definition Unit_symK : forall u1 u2 (uR : Unit_R u1 u2), Unit_sym u2 u1 (Unit_sym u1 u2 uR) = uR. -Proof. -move=> u1 u2 uR. -refine (Unit_R_ind Unit_symKPred _ u1 u2 uR). -exact: eq_refl. -Defined. - -Elpi derive.param2 Bool. -Elpi derive.sym Bool. - -Notation Bool_symKPred := (fun b1 b2 (bR : Bool_R b1 b2)=> Bool_sym b2 b1 (Bool_sym b1 b2 bR) = bR). -Definition Bool_symK : forall b1 b2 (bR : Bool_R b1 b2), Bool_sym b2 b1 (Bool_sym b1 b2 bR) = bR. -Proof. -refine (fun b1 b2 bR=> Bool_R_ind Bool_symKPred _ _ b1 b2 bR). -- exact: eq_refl. -- exact: eq_refl. -Defined. - -Elpi derive.param2 Wrap. -Elpi derive.sym Wrap. - -Notation Wrap_symKPred := (fun w1 w2 (wR : Wrap_R w1 w2) => Wrap_sym w2 w1 (Wrap_sym w1 w2 wR) = wR). -Definition Wrap_symK : forall w1 w2 (wR : Wrap_R w1 w2), Wrap_sym w2 w1 (Wrap_sym w1 w2 wR) = wR. -Proof. -refine (fun w1 w2 wR=> Wrap_R_ind Wrap_symKPred _ w1 w2 wR). -refine (fun u1 u2 uR=> _). -unfold Wrap_sym. -unfold Wrap_R_rect. -refine ( @eq_ind _ _ (fun t => KWrap1_R u1 u2 t = KWrap1_R u1 u2 uR) _ _ (Unit_symK u1 u2 uR)^). -(* rewrite Unit_symK. *) -exact: eq_refl. -Defined. - -Elpi derive.param2 WrapMore. -Elpi derive.sym WrapMore. - -Notation WrapMore_symKPred := (fun w1 w2 (wR : WrapMore_R w1 w2) => WrapMore_sym w2 w1 (WrapMore_sym w1 w2 wR) = wR). -Definition WrapMore_symK : forall w1 w2 (wR : WrapMore_R w1 w2), WrapMore_sym w2 w1 (WrapMore_sym w1 w2 wR) = wR. -Proof. -refine (fun w1 w2 wR=> WrapMore_R_ind WrapMore_symKPred _ _ _ w1 w2 wR). -- refine (fun u1 u2 uR=> _). - refine (fun b1 b2 bR=> _). - cbn delta beta iota. - refine ( @eq_ind _ _ (fun t => KWrap_R u1 u2 t b1 b2 -(Bool_sym b2 b1 (Bool_sym b1 b2 bR)) = KWrap_R u1 u2 uR b1 b2 bR) _ _ (Unit_symK u1 u2 uR)^). - refine ( @eq_ind _ _ (fun t => KWrap_R u1 u2 uR b1 b2 -t = KWrap_R u1 u2 uR b1 b2 bR) _ _ (Bool_symK b1 b2 bR)^). - (* rewrite Unit_symK Bool_symK. *) - exact: eq_refl. -- refine (fun w1 w2 wR=> _). - -Notation Nat_symKPred := (fun w1 w2 (wR : Nat_R w1 w2) => Nat_sym w2 w1 (Nat_sym w1 w2 wR) = wR). -Fixpoint Nat_symK : forall w1 w2 (wR : Nat_R w1 w2), Nat_sym w2 w1 (Nat_sym w1 w2 wR) = wR. -Proof. -refine (fun w1 w2 wR=> Nat_R_ind Nat_symKPred _ _ w1 w2 wR). -exact: eq_refl. -refine (fun n1 n2 nR IH => _). -cbn delta beta iota. -refine (@eq_ind _ _ (fun t => S'_R n1 n2 t = S'_R n1 n2 nR) _ _ (Nat_symK n1 n2 nR)^). -(* rewrite IH. *) -exact: eq_refl. -Defined. - -Elpi derive.param2 Box. -Elpi derive.sym Box. - -Notation Box_symKPred := (fun A1 A2 (AR: A1 -> A2 -> Type) - b1 b2 (bR : Box_R A1 A2 AR b1 b2) - => Box_sym A2 A1 (sym_rel AR) b2 b1 (Box_sym A1 A2 AR b1 b2 bR) = bR). -Definition Box_symK : - forall A1 A2 (AR: A1 -> A2 -> Type) - b1 b2 (bR : Box_R A1 A2 AR b1 b2), - Box_sym A2 A1 (sym_rel AR) b2 b1 (Box_sym A1 A2 AR b1 b2 bR) = bR. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun b1 b2 bR=> _). -refine (Box_R_ind A1 A2 AR (Box_symKPred A1 A2 AR) _ b1 b2 bR). -move=> a1 a2 ar. -cbn delta beta iota. -exact: eq_refl. -Defined. - -Elpi derive.param2 Option. -Elpi derive.sym Option. - - -Notation Option_symKPred := (fun A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : Option_R A1 A2 AR b1 b2) => Option_sym A2 A1 (sym_rel AR) b2 b1 (Option_sym A1 A2 AR b1 b2 bR) = bR). -Definition Option_symK : - forall A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : Option_R A1 A2 AR b1 b2), Option_sym A2 A1 (sym_rel AR) b2 b1 (Option_sym A1 A2 AR b1 b2 bR) = bR. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun b1 b2 bR=> _). -refine (Option_R_ind A1 A2 AR (Option_symKPred A1 A2 AR) _ _ b1 b2 bR). -- exact: eq_refl. -- move=> a1 a2 ar. -simpl. -cbn delta beta iota. -Check (@eq_refl ((sym_rel AR) a2 a1) ar). -exact: eq_refl. -Defined. - -Elpi derive.param2 Prod. -Elpi derive.sym Prod. - -Notation Prod_symKPred := (fun A1 A2 (AR: A1 -> A2 -> Type) B1 B2 BR b1 b2 (bR : Prod_R A1 A2 AR B1 B2 BR b1 b2) => Prod_sym A2 A1 (sym_rel AR) B2 B1 (sym_rel BR) b2 b1 (Prod_sym A1 A2 AR B1 B2 BR b1 b2 bR) = bR). -Definition Prod_symK : - forall A1 A2 (AR: A1 -> A2 -> Type) B1 B2 (BR : B1 -> B2 -> Type) b1 b2 (bR : Prod_R A1 A2 AR B1 B2 BR b1 b2), Prod_sym A2 A1 (sym_rel AR) B2 B1 (sym_rel BR) b2 b1 (Prod_sym A1 A2 AR B1 B2 BR b1 b2 bR) = bR. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun B1 B2 BR=> _). -refine (fun b1 b2 bR=> _). -refine (Prod_R_ind A1 A2 AR B1 B2 BR (Prod_symKPred A1 A2 AR B1 B2 BR) _ b1 b2 bR). -- move=> a1 a2 ar b b' br. -exact: eq_refl. -Defined. - -Elpi derive.param2 List. -Elpi derive.sym List. - -Notation List_symKPred := (fun A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : List_R A1 A2 AR b1 b2) => List_sym A2 A1 (sym_rel AR) b2 b1 (List_sym A1 A2 AR b1 b2 bR) = bR). -Fixpoint List_symK : - forall A1 A2 (AR: A1 -> A2 -> Type) b1 b2 (bR : List_R A1 A2 AR b1 b2), List_sym A2 A1 (sym_rel AR) b2 b1 (List_sym A1 A2 AR b1 b2 bR) = bR. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun b1 b2 bR=> _). -refine (List_R_ind A1 A2 AR (List_symKPred A1 A2 AR) _ _ b1 b2 bR). -- exact: eq_refl. -- move=> a1 a2 ar l1 l2 lr IH. - cbn delta beta iota. - refine (@eq_ind _ _ (fun t => Cons_R A1 A2 (sym_rel (sym_rel AR)) a1 a2 ar l1 l2 t = -Cons_R A1 A2 AR a1 a2 ar l1 l2 lr) _ _ (List_symK A1 A2 AR l1 l2 lr)^). - (* rewrite IH. *) - exact: eq_refl. -Defined. diff --git a/std/algo/detailed/Detailed_vector.v b/std/algo/detailed/Detailed_vector.v deleted file mode 100644 index 2523edfd..00000000 --- a/std/algo/detailed/Detailed_vector.v +++ /dev/null @@ -1,150 +0,0 @@ -From Trocq Require Import mymap mR. -From elpi.apps.derive Require Import derive derive.param2 derive.projK. -Require Import HoTTNotations. -Require Import Hierarchy. -From mathcomp Require Import ssreflect. - -Unset Uniform Inductive Parameters. -(* Unset Universe Polymorphism. *) -Unset Universe Minimization ToSet. - -Inductive vec (A : Type) : nat -> Type := -| Ov : vec A O -| Consv : A -> forall n, vec A n -> vec A (S n). - -Elpi derive nat. -Elpi derive.param2 vec. - -Fixpoint vec_map (A B : Type) (AR : Param10.Rel A B) (n1 n2 : nat) (nR : nat_R n1 n2) {struct nR} : - vec A n1 -> vec B n2. -Proof. -case: nR. -- move=> v; exact: (Ov B). -- move=> n1' n2' nR' v. - refine (Consv B _ _ _). - + move: v. - refine (fun v => match v in vec _ (S _) with Consv a n v0 => _ end). - by apply (map AR). - + refine (vec_map A B AR n1' n2' nR' _). - by refine ((match v in vec _ (S t) return ( vec A t) with Consv a n v0 => v0 end)). -Defined. - -Definition projConsv1 : - forall (A : Type), - forall n : nat, vec A (S n) -> A. -refine (fun A n v=> _ ). -by refine (match v in vec _ (S t) return A with -| Consv a n v0 => a end). -Defined. - -Definition projConsv2 : - forall (A : Type), - A -> forall n : nat, vec A (S n) -> vec A n. -refine (fun A a n v=> _ ). -by refine (match v in vec _ (S t) return vec _ t with -| Consv a n v0 => v0 end). -Defined. - -Definition vec_injections21 : -forall (A : Type) (_1 _2 : A) n (v1 v2 : vec A n) (e : Consv A _1 n v1 = Consv A _2 n v2), - projConsv1 A n (Consv A _1 n v1) = projConsv1 A n (Consv A _2 n v2). -Proof. -move=> A a1 a2 n v1 v2 eq. -exact: (f_equal _ eq). -Defined. - -Definition vec_injections22 : -forall (A : Type) (_1 _2 : A) n (v1 v2 : vec A n)(e : Consv A _1 n v1= Consv A _2 n v2), - projConsv2 A _1 n (Consv A _1 n v1) = projConsv2 A _1 n (Consv A _2 n v2). -Proof. -move=> A a1 a2 n v1 v2 eq. -exact: (f_equal _ eq). -Defined. - -Definition conv (A : Type) (x y : A) (p: x = y) - (P : forall x0 : A, x = x0 -> Prop) (P0 : P x eq_refl) := - match p as p0 in _ = t return (P t p0) - with eq_refl => P0 end. - -Definition vec_injK21 : - forall (A : Type) (_1 _2 : A) (p__1 : _1 = _2) n (_3 _4 : vec A n ) (p__2 : _3 = _4), -(fun (t : A) (p : _1 = t) => -vec_injections21 A _1 t n _3 _4 -(eq_trans (eq_f A (vec A (S n)) (fun R : A => Consv A R n _3) _1 t p) -(eq_trans (eq_f (vec A n) (vec A (S n)) (fun (R : vec A n) => Consv A t n R) _3 _4 -p__2) eq_refl)) = p) _2 p__1. -Proof. -move=> A a1 a2 p n v1 v2 p2. -apply (conv A a1 a2 p). -by apply (conv (vec A n) v1 v2 p2). -Defined. - -Definition vec_injK22 : - forall (A : Type) (_1 _2 : A) (p__1 : _1 = _2) n (_3 _4 : vec A n ) (p__2 : _3 = _4), -(fun (t : A) (p : _1 = t) => -vec_injections22 A _1 t n _3 _4 -(eq_trans (eq_f A (vec A (S n)) (fun R : A => Consv A R n _3) _1 t p) -(eq_trans (eq_f (vec A n) (vec A (S n)) (fun (R : vec A n) => Consv A t n R) _3 _4 -p__2) eq_refl)) = p__2) _2 p__1. -Proof. -move=> A a1 a2 p n v1 v2 p2. -apply (conv A a1 a2 p). -by apply (conv (vec A n) v1 v2 p2). -Defined. - -Fixpoint mRvec (A1 A2 : Type) (AR : Param2a0.Rel A1 A2) (n1 n2: nat) (nR : nat_R n1 n2) - {struct nR} : forall (v1 : vec A1 n1) (v2 : vec A2 n2), vec_map _ _ AR n1 n2 nR v1 = v2 -> vec_R A1 A2 AR n1 n2 nR v1 v2. -case: nR. -- refine (fun v1=> match v1 with Ov => _ end). - refine (fun v2=> match v2 with Ov => _ end). - move=> _; exact: Ov_R. -- move=> n1' n2' nR' v1. - move: mRvec=> /(_ A1 A2 AR _ _ nR')=> mRvec. - move: nR' mRvec. - refine (match v1 as vt in vec _ (S t) return -forall nR' : nat_R t n2', -(forall (v2 : vec A1 t) (v3 : vec A2 n2'), -vec_map A1 A2 AR t n2' nR' v2 = v3 -> vec_R A1 A2 AR t n2' nR' v2 v3) -> -forall v2 : vec A2 (S n2'), -vec_map A1 A2 AR (S t) (S n2') (S_R t n2' nR') vt = v2 -> -vec_R A1 A2 AR (S t) (S n2') (S_R t n2' nR') vt v2 -with -Consv a n v0 => _ end - ). - move=> nR' mRvec v2. - move: nR' mRvec. - refine (match v2 as vt in vec _ (S t) return - forall nR' : nat_R n t, -(forall (v3 : vec A1 n) (v4 : vec A2 t), -vec_map A1 A2 AR n t nR' v3 = v4 -> vec_R A1 A2 AR n t nR' v3 v4) -> -vec_map A1 A2 AR (S n) (S t) (S_R n t nR') (Consv A1 a n v0) = vt -> -vec_R A1 A2 AR (S n) (S t) (S_R n t nR') (Consv A1 a n v0) vt -with -Consv a n v0 => _ end - ). - move=> nR' mRvec eq. - apply (Consv_R _ _ _ _ _ (map_in_R AR _ _ (vec_injections21 A2 _ _ _ _ _ eq)) _ _ _). - by apply (mRvec v3 _ (vec_injections22 A2 _ _ _ _ _ eq)). -Defined. - -Fixpoint Rmvec (A1 A2 : Type) (AR : Param2b0.Rel A1 A2) (n1 n2: nat) (nR : nat_R n1 n2) - : forall (v1 : vec A1 n1) (v2 : vec A2 n2), vec_R A1 A2 AR n1 n2 nR v1 v2 -> vec_map _ _ AR n1 n2 nR v1 = v2. -move=> v1 v2 vR; case: vR. -- exact: eq_refl. -- move=> a1 a2 ar n1' n2' nR' v1' v2' vR' /=. - move: Rmvec=> /(_ A1 A2 AR _ _ nR')=> Rmvec. - have@ e1 := f_equal (fun a2'=> Consv A2 a2' n2' (vec_map A1 A2 AR n1' n2' nR' v1')) (R_in_map AR _ _ ar). - have@ e2 := f_equal (fun v => Consv A2 a2 n2' v) (Rmvec _ _ vR'). - exact: (e1 @ e2). -Defined. - -Fixpoint mRRmvec (A1 A2 : Type) (AR : Param40.Rel A1 A2) (n1 n2: nat) (nR : nat_R n1 n2) - : forall (v1 : vec A1 n1) (v2 : vec A2 n2) (vR: vec_R A1 A2 AR n1 n2 nR v1 v2), - mRvec A1 A2 AR n1 n2 nR v1 v2 (Rmvec A1 A2 AR n1 n2 nR v1 v2 vR) = vR. -move=> v1 v2 vR; case: vR. -- exact: eq_refl. -- move=> a1 a2 ar n1' n2' nR' v1' v2' vR' /=. - move: mRRmvec=> /(_ A1 A2 AR _ _ nR')=> mRRmvec. - rewrite vec_injK21 vec_injK22. rewrite (R_in_mapK AR). rewrite (mRRmvec v1' v2' vR'). - reflexivity. -Defined. \ No newline at end of file diff --git a/std/algo/detailed/DetailedmR.v b/std/algo/detailed/DetailedmR.v deleted file mode 100644 index cc7efe1b..00000000 --- a/std/algo/detailed/DetailedmR.v +++ /dev/null @@ -1,257 +0,0 @@ -From Coq Require Import ssreflect. -From elpi.apps.derive Require Import derive derive.param2. -From Trocq Require Import mymap injection_lemmas. -Require Import Hierarchy. -(* Require Import HoTT_additions Hierarchy. *) -Unset Uniform Inductive Parameters. -(* Unset Universe Polymorphism. *) -Unset Universe Minimization ToSet. - -Definition Unit := unit. - -Elpi derive.param2 unit. -Definition UnitR := unit_R. -(* Inductive UnitR : Unit -> Unit -> Type := - | tt_R : UnitR tt tt. *) - -Elpi derive.mymap unit. -Definition unit_map : unit -> unit := unit_mymap. -Definition Unit_mR : forall (u1 u2 : Unit), unit_map u1 = u2 -> UnitR u1 u2. -Proof. -refine (fun u1 => match u1 as u return - forall u2 : Unit, unit_map u = u2 -> UnitR u u2 - with - | tt => _ end - ). -refine (fun u2 => match u2 as u return - unit_map tt = u -> UnitR tt u - with - | tt => _ end). -refine (fun e => tt_R). -Defined. - -Definition Bool := bool. -Elpi derive.param2 bool. - -Definition BoolR := bool_R. -(* Inductive BoolR : Bool -> Bool -> Type := -| true_R : BoolR true true -| false_R : BoolR false false. *) - -Elpi derive.mymap bool. -Definition bool_map : Bool -> Bool := bool_mymap. -Definition Bool_mR : forall (u1 u2 : Bool), bool_map u1 = u2 -> BoolR u1 u2. -Proof. -refine (fun u1 : Bool => match u1 as u return - forall u2 : Bool, bool_map u = u2 -> BoolR u u2 - with - | true => _ - | false => _ - end - ). -+ refine (fun u2 : Bool => match u2 as u return - bool_map true = u -> BoolR true u - with - | true => _ - | false => _ - end - ). - - (* true true *) - refine (fun e => true_R). - - (* true false *) intros e; discriminate e. -+ refine (fun u2 : Bool => match u2 as u return - bool_map false = u -> BoolR false u - with - | true => _ - | false => _ - end - ). - - (* false true *) intros e; discriminate e. - - (* false false *) refine (fun e => false_R). -Defined. - -Inductive Wrap : Type := -| KWrap1 : unit -> Wrap. - -Elpi derive.param2 Wrap. -Definition WrapR := Wrap_R. -Elpi derive.mymap Wrap. - -Definition wrap_map := Wrap_mymap. -Elpi derive.projK Wrap. -Elpi derive.injections Wrap. -Definition wrap_mR : forall w1 w2, wrap_map w1 = w2 -> WrapR w1 w2. -Proof. -refine (fun w1=> match w1 as w return - forall w2, wrap_map w = w2 -> WrapR w w2 - with - | KWrap1 u1 => _ end). -- refine (fun w2=> match w2 as w return - wrap_map (KWrap1 u1) = w -> WrapR (KWrap1 u1) w - with - | KWrap1 u2 => _ end). - refine (fun e => KWrap1_R u1 u2 (Unit_mR u1 u2 (Wrap_injections11 (unit_map u1) u2 e))). -Defined. - -Definition Nat := nat. -Elpi derive.param2 nat. -Definition NatR := nat_R. - -Elpi derive.mymap nat. -Definition nat_map := nat_mymap. -Elpi derive.injections nat. -Print nat_injections21. - -Definition nat_mR : forall n1 n2, nat_map n1 = n2 -> NatR n1 n2. -Proof. -fix F 1. -refine (fun n1 => match n1 as n return - forall n2, nat_map n = n2 -> NatR n n2 - with - | O => _ - | S n1' => _ end). -+ (* O *) - refine (fun n2 => match n2 as n return - nat_map 0 = n -> NatR 0 n - with - | O => _ - | S n2' => _ end). - - (* O O *) - refine (fun e => O_R). - - (* O S n2' *) intros e; discriminate e. -+ (* S n' *) - refine (fun n2 => match n2 as n return - nat_map (S n1') = n -> NatR (S n1') n - with - | O => _ - | S n2' => _ end). - - (* S n1' O *) intros e; discriminate e. - - (* S n1' S n2' *) - refine (fun e => S_R n1' n2' (F n1' n2' (nat_injections21 (nat_map n1') n2' e))). -Defined. - -Inductive Box (A : Type) : Type := B : A -> Box A. -Elpi derive.param2 Box. -Elpi derive.mymap Box. -Elpi derive.projK Box. -Elpi derive.injections Box. -Elpi derive.isK Box. -Check @Trocq.Hierarchy.map. -Definition box_mR : forall A1 A2 (AR: Param2a0.Rel A1 A2) b1 b2, Box_mymap A1 A2 AR b1 = b2 -> Box_R A1 A2 AR b1 b2. -Proof. -refine (fun A1 A2 AR=> _). -refine (fun b1 b2=> _). -refine (match b1 as b0 return Box_mymap A1 A2 AR b0 = b2 -> Box_R A1 A2 AR b0 b2 - with B _ a1 => _ end). - Set Printing All. -refine (match b2 as b0 return Box_mymap A1 A2 AR (B A1 a1) = b0 -> Box_R A1 A2 AR (B A1 a1) b0 - with B _ a2 => _ end). -refine (fun e => _). -simpl in e. -exact (B_R A1 A2 AR a1 a2 ((map_in_R AR) a1 a2 (Box_injections11 A2 ((map AR) a1) a2 e))). -Defined. - -Definition Option (A : Type) : Type := option A. - -Elpi derive.param2 option. -Definition OptionR := option_R. -(* Inductive OptionR (A1 A2 : Type) (AR : A1 -> A2 -> Type) : option A1 -> option A2 -> Type := -| SomeR : forall a1 a2 (aR : AR a1 a2), OptionR A1 A2 AR (Some a1) (Some a2) -| NoneR : OptionR A1 A2 AR None None. *) - -Elpi derive.mymap option. -Definition option_map := option_mymap. -(* Definition option_map (A1 A2 : Type) (AR : Param10.Rel A1 A2) : option A1 -> option A2 := -fun oa => - match oa with - | Some a => Some (map AR a) - | None => None - end. *) - -(* Elpi derive.injections option. *) -(* Print option_injections11. *) - -Definition option_mR : forall (A1 A2 : Type) (AR : Param2a0.Rel A1 A2) oa1 oa2, option_map A1 A2 AR oa1 = oa2 -> OptionR A1 A2 AR oa1 oa2. -Proof. -refine (fun A1 A2 AR => _). -refine (fun oa1 => match oa1 as oa -return forall oa2, option_map A1 A2 AR oa = oa2 -> OptionR A1 A2 AR oa oa2 -with - | Some a1 => _ - | None => _ end). -+ (* Some *) - refine (fun oa2 => match oa2 as oa - return option_map A1 A2 AR (Some a1) = oa -> OptionR A1 A2 AR (Some a1) oa - with - | Some a2 => _ - | None => _ end). - - (* Some Some *) - refine (fun e => Some_R A1 A2 AR a1 a2 (map_in_R AR a1 a2 (option_injections11 A2 (map AR a1) a2 e))). - - (* Some None *) intros e; discriminate e. -+ (* None *) - refine (fun oa2 => match oa2 as oa - return option_map A1 A2 AR None = oa -> OptionR A1 A2 AR None oa - with - | Some a2 => _ - | None => _ end). - - (* None Some *) intros e; discriminate e. - - refine (fun e => None_R A1 A2 AR). -Defined. - -Definition List (A : Type) := list A. -Elpi derive.param2 list. - -Definition ListR := list_R. -Elpi derive.mymap list. - -Definition list_map := list_mymap. - -Elpi derive.injections list. -Print list_injections21. - -Print cons_R. -Definition list_mR : forall (A1 A2 : Type) (AR : Param2a0.Rel A1 A2) l1 l2, list_map A1 A2 AR l1 = l2 -> ListR A1 A2 AR l1 l2. -Proof. -refine (fun A1 A2 AR=> _). -fix F 1. -refine (fun l1 => match l1 as l - return forall l2, list_map A1 A2 AR l = l2 - -> ListR A1 A2 AR l l2 - with - | nil => _ - | cons a1 l1' => _ end). -+ (* nil *) - refine (fun l2 => match l2 as l - return list_map A1 A2 AR nil = l -> ListR A1 A2 AR nil l - with - | nil => _ - | cons a2 l2' => _ end). - - (* nil nil *) - refine (fun e => nil_R A1 A2 AR). - - intros e; discriminate e. -+ (* cons *) - refine (fun l2 => match l2 as l - return list_map A1 A2 AR (cons a1 l1') = l -> ListR A1 A2 AR (cons a1 l1') l - with - | nil => _ - | cons a2 l2' => _ end). - - intros e; discriminate e. - - refine (fun e => cons_R A1 A2 AR - a1 a2 (map_in_R AR a1 a2 (list_injections21 A2 (map AR a1) a2 (list_map A1 A2 AR l1') l2' e)) - l1' l2' (F l1' l2' (list_injections22 A2 (map AR a1) a2 (list_map A1 A2 AR l1') l2' e))). -Defined. - -Inductive ParamWrap (A : Type) := -(* | PH : unit -> ParamWrap A *) -| SomeW : option A -> ParamWrap A. - -Elpi derive.param2 ParamWrap. -Definition ParamWrapR := ParamWrap_R. - -Fail Elpi derive.mymap ParamWrap. -Fail Elpi derive.map ParamWrap. - -(* Definition list_map := list_mymap. *) -Elpi derive.projK ParamWrap. -Elpi derive.injections ParamWrap. - diff --git a/std/algo/tests/test_Rel40.v b/std/algo/tests/test_Rel40.v deleted file mode 100644 index 95ba7cda..00000000 --- a/std/algo/tests/test_Rel40.v +++ /dev/null @@ -1,36 +0,0 @@ -From Trocq Require Import map4 umap Rel40. -From Trocq Require Import coverage. -Unset Uniform Inductive Parameters. - -Elpi derive False. -Check False_rel40 : Param40.Rel False False. - -Elpi derive Unit. -Check Unit_rel40 : Param40.Rel Unit Unit. - -Elpi derive Bool. -Check Bool_rel40 : Param40.Rel Bool Bool. - -Elpi derive Wrap. -Check Wrap_rel40 : Param40.Rel Wrap Wrap. - -Elpi derive WrapMore. -Check WrapMore_rel40 : Param40.Rel WrapMore WrapMore. - -Elpi derive Nat. -Check Nat_rel40 : Param40.Rel Nat Nat. - -Elpi derive Box. -Check Box_rel40 : forall A1 A2 AR UR, Param40.Rel (Box A1) (Box A2). - -Elpi derive Option. -Check Option_rel40 : forall A1 A2 AR UR, Param40.Rel (Option A1) (Option A2). - -Elpi derive Prod. -Check Prod_rel40 : forall A1 A2 AR UR B1 B2 BR BUR, Param40.Rel (Prod A1 B1) (Prod A2 B2). - -Elpi derive ThreeTypes. -Check ThreeTypes_rel40 : forall A1 A2 AR UR B1 B2 BR BUR C1 C2 CR CUR, Param40.Rel (ThreeTypes A1 B1 C1) (ThreeTypes A2 B2 C2). - -Elpi derive List. -Check List_rel40 : forall A1 A2 AR UR, Param40.Rel (List A1) (List A2). diff --git a/tests/_CoqProject.hott b/tests/_CoqProject.hott index 0dce3862..3a63ca38 100644 --- a/tests/_CoqProject.hott +++ b/tests/_CoqProject.hott @@ -3,6 +3,7 @@ -arg -w -arg +elpi.typechecker -R ../hott/ Trocq +-R ../hott/generic/inductives Trocq -R ../elpi/ Trocq.Elpi unit_arrow_contravariant.v @@ -28,3 +29,17 @@ unit_transfer5.v unit_twoTranslations.v unit_typeArrow.v unit_type.v + +inductives/coverage.v +inductives/test_sym.v +inductives/test_symK.v +inductives/test_RsymK.v +inductives/test_mymap.v +inductives/test_injection_lemmas.v +inductives/test_mR.v +inductives/test_Rm.v +inductives/test_injK.v +inductives/test_mRRmK.v +inductives/test_map4.v +inductives/test_mapn.v +inductives/test_Relnm.v diff --git a/tests/_CoqProject.std b/tests/_CoqProject.std index 2e7b131f..2758bfad 100644 --- a/tests/_CoqProject.std +++ b/tests/_CoqProject.std @@ -2,6 +2,7 @@ -arg -w -arg +elpi.typechecker -R ../std/ Trocq +-R ../std/generic/inductives Trocq -R ../elpi/ Trocq.Elpi unit_arrow_contravariant.v @@ -27,3 +28,17 @@ unit_transfer5.v unit_twoTranslations.v unit_typeArrow.v unit_type.v + +inductives/coverage.v +inductives/test_sym.v +inductives/test_symK.v +inductives/test_RsymK.v +inductives/test_mymap.v +inductives/test_injection_lemmas.v +inductives/test_mR.v +inductives/test_Rm.v +inductives/test_injK.v +inductives/test_mRRmK.v +inductives/test_map4.v +inductives/test_mapn.v +inductives/test_Relnm.v diff --git a/std/algo/tests/coverage.v b/tests/inductives/coverage.v similarity index 100% rename from std/algo/tests/coverage.v rename to tests/inductives/coverage.v diff --git a/std/algo/tests/merely_inhabited_relation.v b/tests/inductives/merely_inhabited_relation.v similarity index 100% rename from std/algo/tests/merely_inhabited_relation.v rename to tests/inductives/merely_inhabited_relation.v diff --git a/std/algo/tests/rmmrK.v b/tests/inductives/rmmrK.v similarity index 100% rename from std/algo/tests/rmmrK.v rename to tests/inductives/rmmrK.v diff --git a/std/algo/tests/test_Rel44.v b/tests/inductives/test_Relnm.v similarity index 91% rename from std/algo/tests/test_Rel44.v rename to tests/inductives/test_Relnm.v index 2323b926..d6d30ee4 100644 --- a/std/algo/tests/test_Rel44.v +++ b/tests/inductives/test_Relnm.v @@ -1,6 +1,6 @@ Require Import Database. -From Trocq Require Import coverage Rel44. +From Trocq Require Import coverage Relnm. Elpi derive False. Check False_rel44. diff --git a/std/algo/tests/test_Rm.v b/tests/inductives/test_Rm.v similarity index 100% rename from std/algo/tests/test_Rm.v rename to tests/inductives/test_Rm.v diff --git a/std/algo/tests/test_RsymK.v b/tests/inductives/test_RsymK.v similarity index 100% rename from std/algo/tests/test_RsymK.v rename to tests/inductives/test_RsymK.v diff --git a/std/algo/tests/test_injK.v b/tests/inductives/test_injK.v similarity index 100% rename from std/algo/tests/test_injK.v rename to tests/inductives/test_injK.v diff --git a/std/algo/tests/test_injection_lemmas.v b/tests/inductives/test_injection_lemmas.v similarity index 100% rename from std/algo/tests/test_injection_lemmas.v rename to tests/inductives/test_injection_lemmas.v diff --git a/std/algo/tests/test_mR.v b/tests/inductives/test_mR.v similarity index 100% rename from std/algo/tests/test_mR.v rename to tests/inductives/test_mR.v diff --git a/std/algo/tests/test_mRRmK.v b/tests/inductives/test_mRRmK.v similarity index 100% rename from std/algo/tests/test_mRRmK.v rename to tests/inductives/test_mRRmK.v diff --git a/std/algo/tests/test_map4.v b/tests/inductives/test_map4.v similarity index 100% rename from std/algo/tests/test_map4.v rename to tests/inductives/test_map4.v diff --git a/std/algo/tests/test_umap.v b/tests/inductives/test_mapn.v similarity index 97% rename from std/algo/tests/test_umap.v rename to tests/inductives/test_mapn.v index e4080f08..7fe28738 100644 --- a/std/algo/tests/test_umap.v +++ b/tests/inductives/test_mapn.v @@ -1,5 +1,5 @@ Require Import Database. -From Trocq Require Import map4 umap. +From Trocq Require Import map4 mapn. From Trocq Require Import coverage. Unset Uniform Inductive Parameters. diff --git a/std/algo/tests/test_mymap.v b/tests/inductives/test_mymap.v similarity index 100% rename from std/algo/tests/test_mymap.v rename to tests/inductives/test_mymap.v diff --git a/std/algo/tests/test_sym.v b/tests/inductives/test_sym.v similarity index 100% rename from std/algo/tests/test_sym.v rename to tests/inductives/test_sym.v diff --git a/std/algo/tests/test_symK.v b/tests/inductives/test_symK.v similarity index 100% rename from std/algo/tests/test_symK.v rename to tests/inductives/test_symK.v From 870d3c602e7a7ad12e1a1c91f69e734f07b2ea95 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Mon, 20 Apr 2026 15:38:17 +0200 Subject: [PATCH 23/42] improving imports wip introducing use of coq.env.global to recover HoTT build pruning extra plugins in derive --- elpi/inductives/Rm.elpi | 8 ++--- elpi/inductives/RsymK.elpi | 2 +- elpi/inductives/common_algo.elpi | 16 +++++----- elpi/inductives/injK.elpi | 8 ++--- elpi/inductives/mR.elpi | 5 +-- elpi/inductives/mRRmK.elpi | 6 ++-- elpi/inductives/mymap.elpi | 33 +++++++++++--------- elpi/inductives/relnm.elpi | 12 ++++---- elpi/inductives/symK.elpi | 4 +-- elpi/inductives/utils.elpi | 8 ++--- generic/Param_Empty.v | 9 ++---- generic/Param_bool.v | 9 ++---- generic/Param_list.v | 9 ++---- generic/Param_nat.v | 8 +---- generic/Param_option.v | 7 +---- generic/Param_prod.v | 8 +---- generic/Param_sum.v | 8 +---- generic/inductives/Gen.v | 10 ++++++ generic/inductives/Relnm.v | 5 ++- generic/inductives/Rm.v | 8 ++--- generic/inductives/RsymK.v | 2 +- generic/inductives/injK.v | 12 +++----- generic/inductives/injection_lemmas.v | 4 ++- generic/inductives/mR.v | 7 ++--- generic/inductives/mapn.v | 3 +- generic/inductives/mymap.v | 6 ++-- generic/inductives/sym.v | 2 +- generic/inductives/symK.v | 2 +- hott/Hierarchy.v | 6 ++++ hott/HoTTNotations.v | 1 + hott/Param_lemmas.v | 7 +++++ hott/Stdlib.v | 7 +++++ hott/_CoqProject | 1 + std/Hierarchy.v | 4 +++ std/Param_lemmas.v | 7 +++++ std/Stdlib.v | 7 +++++ tests/inductives/coverage.v | 14 +++++---- tests/inductives/test_Relnm.v | 13 ++++---- tests/inductives/test_Rm.v | 15 +++++---- tests/inductives/test_RsymK.v | 19 ++++++------ tests/inductives/test_injK.v | 15 +++++---- tests/inductives/test_injection_lemmas.v | 10 +++--- tests/inductives/test_mR.v | 23 +++++++------- tests/inductives/test_mRRmK.v | 39 ++++++++++++------------ tests/inductives/test_map4.v | 10 +++--- tests/inductives/test_mapn.v | 11 +++---- tests/inductives/test_mymap.v | 8 ++--- tests/inductives/test_sym.v | 14 +++++---- tests/inductives/test_symK.v | 15 ++++----- 49 files changed, 238 insertions(+), 229 deletions(-) create mode 100644 generic/inductives/Gen.v create mode 100644 hott/HoTTNotations.v diff --git a/elpi/inductives/Rm.elpi b/elpi/inductives/Rm.elpi index b38b8796..dff2448b 100644 --- a/elpi/inductives/Rm.elpi +++ b/elpi/inductives/Rm.elpi @@ -38,7 +38,7 @@ pred process-args i:term, i:term, i:int, i:int, i:term, i:term, i:list term, i:l process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest ITyTy R:- coq.mk-app Goal [Ksrc, Kdest, {{ Type }}] EqTy, %discards the relation between Ksrc and Kdest, we want the equality. whd EqTy [] {{lib:@elpi.eq}} [ITyTy,MapA,B], - whd MapA [] (global (indc _)) TySrcMappedArgs, + whd MapA [] _ TySrcMappedArgs, whd B [] KDest TyDestArgs, std.drop TyArgsNo TySrcMappedArgs SrcArgs, std.drop TyArgsNo TyDestArgs DestArgs, @@ -84,7 +84,7 @@ pred implement-Rm i:int, i:int, i:term, i:list term, i:list term, i:list term, i implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KTyRs Pred RInd (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- coq.safe-dest-app ITy1 Ind _, - Ind = (global (indt GR)), + coq.env.global (indt GR) Ind, coq.env.recursive? GR, !, RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), coq.mk-app RInd [Pred] RIndP, @@ -121,9 +121,9 @@ implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,ar] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), - Rm = {{ @Trocq.Hierarchy.Map2b.R_in_map }}, + %todo: fixme use of universes + coq.env.global {{:gref lib:trocq.map2b.r_in_map }} Rm, coq.mk-app Rm [a1, a2, ar, am] (RMS a1 a2 ar am), - % coq.elaborate-skeleton (RMS a1 a2 ar) _ (RM a1 a2 ar) ok, ar-db a1 a2 ar ==> rm-db a1 (RMS a1 a2 ar am) ==> implement-Rm M TyParamNo (Bo a1 a2 ar am) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar am) (NewRInd a1 a2 ar) (R a1 a2 ar am). diff --git a/elpi/inductives/RsymK.elpi b/elpi/inductives/RsymK.elpi index 626e1e46..0c9abd24 100644 --- a/elpi/inductives/RsymK.elpi +++ b/elpi/inductives/RsymK.elpi @@ -17,7 +17,7 @@ implement-rsymK 0 (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ _) Sym SymK LRev (fun IN1 (F i1 i2) = {{ lp:FSym lp:i2 lp:i1 }}, (G i1 i2) = {{ lp:GSym lp:i1 lp:i2 }}, (FGK i1 i2) = {{ lp:SymKSym lp:i2 lp:i1 }}, - (R i1 i2) = {{ existT _ lp:{{ (F i1 i2) }} (existT _ lp:{{ (G i1 i2) }} lp:{{ (FGK i1 i2) }}) }}. + (R i1 i2) = {{ lib:trocq.exist _ lp:{{ (F i1 i2) }} (lib:trocq.exist _ lp:{{ (G i1 i2) }} lp:{{ (FGK i1 i2) }}) }}. implement-rsymK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Sym SymK L (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- M is N - 1, diff --git a/elpi/inductives/common_algo.elpi b/elpi/inductives/common_algo.elpi index 5e966a69..de807054 100644 --- a/elpi/inductives/common_algo.elpi +++ b/elpi/inductives/common_algo.elpi @@ -8,11 +8,11 @@ type subst param-surgery. pred rel-mode i:int o:term. % 0 - 4 could be merged for the change on the type parameters, but they have a different conclusion -rel-mode 0 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map1.Has AR) (Rest : Type), Rest }}. % my-map -rel-mode 1 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map2a.Has AR) (Rest : Type), Rest }}. % mR -rel-mode 2 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map2b.Has AR) (Rest : Type), Rest }}. % Rm -rel-mode 3 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map3.Has AR) (Rest : Type), Rest }}. % _ -rel-mode 4 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : Map4.Has AR) (Rest : Type), Rest }}. % mRRmK +rel-mode 0 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : lib:trocq.map1 AR) (Rest : Type), Rest }}. % my-map +rel-mode 1 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : lib:trocq.map2a AR) (Rest : Type), Rest }}. % mR +rel-mode 2 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : lib:trocq.map2b AR) (Rest : Type), Rest }}. % Rm +rel-mode 3 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : lib:trocq.map3 AR) (Rest : Type), Rest }}. % _ +rel-mode 4 {{ forall (A B : Type) (AR : A -> B -> Type) (_ : lib:trocq.map4 AR) (Rest : Type), Rest }}. % mRRmK % 5 - 7 don't require extra assumption, the only changes happen on the conclusion rel-mode 5 {{ fun (A B : Type)=> A -> B -> Type }}. % sym rel-mode 6 {{ fun (A B : Type)=> A -> B -> Type }}. % symK @@ -27,7 +27,7 @@ swap A B ff A B. % Reached a sort, return map L = R -> IR. pred mk-impl-return i:term, i:term, i:term, i:bool, i:term, o:term. mk-impl-return ML MR Rel SwapB ITyTy2 R :- - Map = {{ @eq lp:ITyTy2 lp:ML lp:MR }}, + Map = {{ lib:@trocq.paths lp:ITyTy2 lp:ML lp:MR }}, swap Map Rel SwapB First Second, R = prod `_` First _\ Second. @@ -95,7 +95,7 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 4 LRev MR-DB RM- coq.mk-app RInMap {std.append L [x,y,iR]} (Rm x y iR), MR-DB Ind MapInR, coq.mk-app MapInR {std.append L [x,y,(Rm x y iR)]} (MRRM x y iR), - (R x y iR) = {{ @eq _ lp:{{MRRM x y iR}} lp:iR }}. + (R x y iR) = {{ lib:@trocq.paths _ lp:{{MRRM x y iR}} lp:iR }}. mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 5 LRev _ _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- std.rev LRev L, @@ -131,7 +131,7 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) SymC _ Rel 6 LRev _ _ _ % sigma NewML NewMR NewRel L\ coq.mk-app SymC {std.append L [x,y,iR]} (SymR x y iR), coq.mk-app SymC {std.append L2 [y,x,(SymR x y iR)]} (SymSym x y iR), - (R x y iR) = {{ @eq _ lp:{{SymSym x y iR}} lp:iR }}. + (R x y iR) = {{ lib:@trocq.paths _ lp:{{SymSym x y iR}} lp:iR }}. % Process two type parameters + 1 relation at a time. % Apply these parameters to the LHS of the equation. % This branch deals with adding the additional hypothesis in case the input boolean is set. diff --git a/elpi/inductives/injK.elpi b/elpi/inductives/injK.elpi index d6aad435..78611b30 100644 --- a/elpi/inductives/injK.elpi +++ b/elpi/inductives/injK.elpi @@ -92,7 +92,7 @@ mk-pred Curr I ArgNo Pred T P [A1|Args1] [_A2|Args2] [A2Ty|TyArgs2] [_Path|Paths Curr < I, !, J is Curr + 1, - coq.mk-app Pred [A1,A1,{{ @eq_refl lp:A2Ty lp:A1}}] NewPred, + coq.mk-app Pred [A1,A1,{{ lib:@trocq.idpath lp:A2Ty lp:A1}}] NewPred, mk-pred J I ArgNo NewPred T P Args1 Args2 TyArgs2 Paths TyPaths R. mk-pred I I ArgNo Pred T P [A1|Args1] [_A2|Args2] [_A2Ty|TyArgs2] [_Path|Paths] [_PathTy|TyPaths] R :- @@ -121,7 +121,7 @@ mk-preds I ArgNo [P|Preds] Args1 Args2 TyArgs2 Paths TyPaths [ fun `t` Ty t\ fun pred iter-convs i:list term, i:list term, i:list term, i:list term, i:list term, i:term, o:term. iter-convs [] [] [] [] [] End End. iter-convs [Ty|Tys] [A1|Args1] [A2|Args2] [Path|Paths] [Pred|Preds] End R :- - Conv = {{lib:@elpi.derive.conv}}, + Conv = {{lib:@trocq.conv}}, iter-convs Tys Args1 Args2 Paths Preds End P0, coq.mk-app Conv [ Ty, A1, A2, Path, Pred, P0] R. @@ -141,9 +141,9 @@ implement-injK 0 0 ArgNo DestNo _ Pred TyParamsR Args1R Args2R TyArgs2R PathsR T std.nth DestNo Args1 A1, std.nth DestNo TyArgs2 Ty, - EndArg = {{ @eq_refl lp:Ty lp:A1}}, + EndArg = {{ lib:@trocq.idpath lp:Ty lp:A1}}, coq.typecheck EndArg EndTy ok, - End = {{@eq_refl lp:EndTy lp:EndArg}}, + End = {{ lib:@trocq.idpath lp:EndTy lp:EndArg}}, iter-convs TyArgs2 Args1 Args2 Paths RPreds End RSkel, coq.elaborate-skeleton RSkel _ R ok. diff --git a/elpi/inductives/mR.elpi b/elpi/inductives/mR.elpi index 9409b7cf..66a741ba 100644 --- a/elpi/inductives/mR.elpi +++ b/elpi/inductives/mR.elpi @@ -144,11 +144,12 @@ implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) @pi-decl A2 A2Ty a2\ @pi-decl AR (ARTy a1 a2) ar\ @pi-decl AM (AMTy a1 a2 ar) am\ - Map = {{ @Trocq.Hierarchy.Map1.map }}, + % todo: fix me: universes + Map = pglobal {{:gref lib:trocq.map1.map }} _ , coq.mk-app Map [a1,a2,ar,am] (PMapA a1 a2 ar am), % insert coercions coq.elaborate-skeleton (PMapA a1 a2 ar am) _ (MapA a1 a2 ar am) ok, - MR = {{ @Trocq.Hierarchy.Map2a.map_in_R }}, + MR = pglobal {{:gref lib:trocq.map2a.map_in_r }} _, coq.mk-app MR [a1,a2,ar,am] (PMR a1 a2 ar am), coq.elaborate-skeleton (PMR a1 a2 ar am) _ (MRA a1 a2 ar am) ok, mymap-def A1Ty (MapA a1 a2 ar am) ==> diff --git a/elpi/inductives/mRRmK.elpi b/elpi/inductives/mRRmK.elpi index 14a8c534..7163b474 100644 --- a/elpi/inductives/mRRmK.elpi +++ b/elpi/inductives/mRRmK.elpi @@ -124,7 +124,7 @@ i:list term, i:list term, i:list term, o:term. process-args Ksrc Kdest 0 0 _ _ Goal _ KR _ _ _ R :- coq.mk-app Goal [Ksrc, Kdest, KR] EqTy, whd EqTy [] _ [IRTy,_,IR], - R = {{ @eq_refl lp:IRTy lp:IR }}. + R = {{ lib:@trocq.idpath lp:IRTy lp:IR }}. process-args Ksrc Kdest 0 InitArgs TyArgsNo _ Goal _ KR InjKs _ MRRMKEq R:- coq.mk-app Goal [Ksrc, Kdest, KR] EqTy, %EqTy is the following type ImR i1 i2 (IRm i1 i2 ir) = ir for this specific branch @@ -134,7 +134,7 @@ process-args Ksrc Kdest 0 InitArgs TyArgsNo _ Goal _ KR InjKs _ MRRMKEq R:- invert-eqs Eqs IEqs, std.map MRRMKEq (x\ r\ sigma TMP\ coq.elaborate-skeleton x _ TMP ok, r = TMP) MRRMKElab, invert-eqs {std.rev MRRMKElab} IEqs2, - End = {{ @eq_refl lp:IRTy lp:IR }}, + End = {{ lib:@trocq.idpath lp:IRTy lp:IR }}, coq.mk-app HD [IRTy,{whd1 MRRM},IR] RGoal, % KR a1 a2 ar1[I_Rm] b1 b2 br[I_Rm] pierce-goal-injK TyArgsNo 0 InitArgs RGoal IEqs PatsInj LastGoal, pierce-goal-mRRmK TyArgsNo 0 InitArgs LastGoal IEqs2 PatsMRRMK, @@ -249,7 +249,7 @@ implement-mRRmK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,ar] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), std.map KRs (x\ r\ sigma TMP\ coq.mk-app x [a1,a2,ar] TMP, r = TMP) (NewKRs a1 a2 ar), - MRRMK = {{ @Trocq.Hierarchy.Map4.R_in_mapK }}, + MRRMK = pglobal {{:gref lib:trocq.map4.r_in_mapk }} _, coq.mk-app MRRMK [a1, a2, ar, am] (MRRMKS a1 a2 ar am), coq.typecheck (MRRMKS a1 a2 ar am) _ ok, ar-db a1 a2 ar ==> diff --git a/elpi/inductives/mymap.elpi b/elpi/inductives/mymap.elpi index babf828b..15c41de9 100644 --- a/elpi/inductives/mymap.elpi +++ b/elpi/inductives/mymap.elpi @@ -4,14 +4,18 @@ shorten std.{split-at, length, rev, append, do!, drop-last, assert!}. -mymap-db (app[global (indt GR1)|A1]) (app[global (indt GR2)|A2]) R :- +mymap-db (app[ A1HD|A1]) (app[ A2HD |A2]) R :- + coq.env.global (indt GR1) A1HD, + coq.env.global (indt GR2) A2HD, + % A1HD = global (indt GR1), + % A2HD = global (indt GR2), coq.env.indt GR1 _ Lno1 _ _ _ _, coq.env.indt GR2 _ Lno2 _ _ _ _, {length A1} > Lno1, {length A2} > Lno2, split-at Lno1 A1 Args1 Points1, split-at Lno2 A2 Args2 Points2, Points1 = Points2, !, - mymap-db {coq.mk-app (global (indt GR1)) Args1} {coq.mk-app (global (indt GR2)) Args2} F, + mymap-db {coq.mk-app A1HD Args1} {coq.mk-app A2HD Args2} F, coq.mk-app F Points1 R. namespace derive.mymap { @@ -52,9 +56,10 @@ bo-idx-rty Ps ItyArgs _ Vs _ R :- pred bo-k-args i:list term, i:term, i:term, i:list term, i:list term, o:term. bo-k-args ParamsRev K _ Args Tys R :- rev ParamsRev Params, - coq.safe-dest-app K (global (indc GR)) _, + coq.safe-dest-app K KB _, + coq.env.global (indc GR) KB, coq.env.typeof (indc GR) T, coq.subst-prod Params T KT, - (bo-k-args.aux {coq.mk-app (global (indc GR)) Params} Args Tys KT R), + (bo-k-args.aux {coq.mk-app KB Params} Args Tys KT R), !. % the first combination that typechecks % pred map.aux i:term, o:term. @@ -64,10 +69,6 @@ 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 :- - mymap-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 :- mymap-db T S F, coq.mk-app F [A] FA, @@ -92,7 +93,9 @@ pred bo-params o:term. % map function bo-params Lno Lno Ity1 Ity2 A1 _ Ps (fix `f` Recno Fty Bo) :- - coq.safe-dest-app Ity1 (global (indt I)) _, coq.env.recursive? I, !, + coq.safe-dest-app Ity1 Ind _, + coq.env.global (indt I) Ind, + coq.env.recursive? I, !, @pi-decl `rec` Fty f\ mymap-db Ity1 Ity2 f => bo-idx A1 Ity1 Ity2 0 Recno Ps (Bo f) Fty. @@ -163,9 +166,11 @@ mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ (prod `x` A _\ B) _ _ (app [G|GS coq.mk-app X LA PLA, coq.mk-app Y LB PLB, coq.mk-app G LF PLF. -mk-map-ty A _ B _ RelTy RTerm Map F 0 [mymap-db A B {{ Map1.map _ lp:F }} ] :- +mk-map-ty A _ B _ RelTy RTerm Map F 0 [mymap-db A B {{ lp:M1mTerm lp:A lp:B _ lp:F }} ] :- + % todo: fix use of universe + coq.env.global {{:gref lib:trocq.map1.map }} M1mTerm, RelTy = {{ lp:A -> lp:B -> Type }} , - Map = {{ Map1.Has lp:RTerm }}. + Map = {{ lib:trocq.map1 lp:RTerm }}. % mk-map-ty A _ B _ (prod `x` A _\ B) F 0 [mymap-db A B F]. @@ -195,7 +200,7 @@ mk-clause N Lno Ity1 Ity2 X Todo Map C :- whd1 X X1, !, %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% func main inductive, string -> list prop. main GR Prefix C :- do! [ - T = global (indt GR), + coq.env.global (indt GR) T, coq.env.indt GR _Ind Lno Luno Arity _ _, assert! (Lno = Luno) "derive.mymap: Non-uniform parameters not supported", @@ -208,10 +213,10 @@ main GR Prefix C :- do! [ % generate clause and add to the db mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause, - coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-def (global (indt GR)) (global (const Funct)))), + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-def T (global (const Funct)))), coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ Clause), coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-done GR)), - C = [mymap-done GR,Clause, (mymap-def (global (indt GR)) (global (const Funct)))] + C = [mymap-done GR,Clause, (mymap-def T (global (const Funct)))] ]. } \ No newline at end of file diff --git a/elpi/inductives/relnm.elpi b/elpi/inductives/relnm.elpi index 26087d2c..40bdab53 100644 --- a/elpi/inductives/relnm.elpi +++ b/elpi/inductives/relnm.elpi @@ -43,12 +43,12 @@ implement-relnm N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ implement-relnm M (Bo a1 a2 ar) MapNCov MapMContra Eq_map RsymK CovariantNN ContravariantNN BuildNN NewL (R a1 a2 ar). pred get-eq-map i:map-class, o:term. -get-eq-map map0 {{ eq_Map0 }}. -get-eq-map map1 {{ eq_Map1 }}. -get-eq-map map2a {{ eq_Map2a }}. -get-eq-map map2b {{ eq_Map2b }}. -get-eq-map map3 {{ eq_Map3 }}. -get-eq-map map4 {{ eq_Map4 }}. +get-eq-map map0 {{ lib:trocq.eq_map0 }}. +get-eq-map map1 {{ lib:trocq.eq_map1 }}. +get-eq-map map2a {{ lib:trocq.eq_map2a }}. +get-eq-map map2b {{ lib:trocq.eq_map2b }}. +get-eq-map map3 {{ lib:trocq.eq_map3 }}. +get-eq-map map4 {{ lib:trocq.eq_map4 }}. pred generate-relNM i:inductive, i:param-class, o: term, o: term. generate-relNM GR (pc N M as PC) ReTy Re :- diff --git a/elpi/inductives/symK.elpi b/elpi/inductives/symK.elpi index 3a9a2e22..a4ca5d90 100644 --- a/elpi/inductives/symK.elpi +++ b/elpi/inductives/symK.elpi @@ -38,7 +38,7 @@ process-args KsS KsD KR 0 ArgNo TyArgsNo _ RevEqs Goal _ R:- coq.mk-app KRHD KRArgs RedLHS, coq.mk-app HD [IRTy,RedLHS,IR] StartingGoal, pierce-goal-symK TyArgsNo 0 ArgNo StartingGoal IEqs PatsSym _, - End = {{ @eq_refl lp:IRTy lp:IR }}, + End = {{ lib:@trocq.idpath lp:IRTy lp:IR }}, rewrite-with IEqs PatsSym End R. process-args KsS KsD KR N O TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Eqs Goal ITyTy @@ -129,7 +129,7 @@ implement-symK N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), std.map KTyRs (x\ r\ sigma TMP1\ coq.subst-prod [a1,a2,(RelAR a1 a2 ar)] x TMP1, r = TMP1) (NewKTyRs a1 a2 ar), - (SymFun a1 a2 ar) = {{ fun (a1 : lp:{{a1}}) (a2 : lp:{{a2}}) (ar : (lp:{{ar}} a1 a2))=> @eq_refl (lp:{{ar}} a1 a2) ar }}, + (SymFun a1 a2 ar) = {{ fun (a1 : lp:{{a1}}) (a2 : lp:{{a2}}) (ar : (lp:{{ar}} a1 a2))=> lib:@trocq.idpath (lp:{{ar}} a1 a2) ar }}, symK-db a2 (SymFun a1 a2 ar) ==> implement-symK M TyParamNo (Bo a1 a2 ar) (NewKsS a1) (NewKsD a2) (NewKRs a1 a2 ar) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar) (NewRInd a1 a2 ar) (R a1 a2 ar). diff --git a/elpi/inductives/utils.elpi b/elpi/inductives/utils.elpi index d7a5291b..2e20bb13 100644 --- a/elpi/inductives/utils.elpi +++ b/elpi/inductives/utils.elpi @@ -74,7 +74,7 @@ mk-etas SrcArgs DestArgs TyDest KAppTyArgs REtas :- pred compose-path i:list term, i:term, i:term o: term. compose-path [] End _ End. -compose-path [Argk|Args] End ITy {{ @eq_trans lp:ITy _ _ _ lp:Argk lp:R }} :- +compose-path [Argk|Args] End ITy {{ lib:@trocq.concat lp:ITy _ _ _ lp:Argk lp:R }} :- compose-path Args End ITy R. % List of src args, list of dest args and their types, K applied to type parameters, equalities src = dest, type of K TyParam Dest. @@ -83,7 +83,7 @@ pred mk-chain i:list term, i:list term, i:list term, i:term, i:list term, i:term mk-chain SrcArgs DestArgs DestArgsTy K Eqs ITyTy RHS R :- mk-etas SrcArgs DestArgs DestArgsTy K REtas, mk-aps-etas DestArgsTy ITyTy REtas SrcArgs DestArgs Eqs Raps, - compose-path Raps {{ @eq_refl lp:ITyTy lp:RHS }} ITyTy RSkel, + compose-path Raps {{ lib:@trocq.idpath lp:ITyTy lp:RHS }} ITyTy RSkel, coq.elaborate-skeleton RSkel _ R ok. % pred name-ij i:string, i:int, i:int, i:inductive, i:constructor, i:list term, i: constructor -> int -> constant -> prop, o:list prop. @@ -164,7 +164,7 @@ iota-step (match A _ L) C X XC :- whd-indc A GR KA, !, pred invert-eqs i:list term, o:list term. invert-eqs Eqs IEqs :- - std.map Eqs (x\r\ sigma Skel TMP Err\ Skel = {{ @eq_sym _ _ _ lp:x}}, + std.map Eqs (x\r\ sigma Skel TMP Err\ Skel = {{ lib:@trocq.inverse _ _ _ lp:x}}, coq.elaborate-skeleton Skel _ TMP ok, r = TMP ) IEqs. @@ -174,7 +174,7 @@ pred rewrite-with i:list term, i:list term, i:term, o:term. rewrite-with [] [] End End. rewrite-with [Eq|Eqs] [Pat|Pats] End R :- (pi rest\ - (T rest) = {{ @eq_ind _ _ lp:Pat lp:rest _ lp:Eq }}), + (T rest) = {{ lib:@trocq.paths_ind _ _ lp:Pat lp:rest _ lp:Eq }}), rewrite-with Eqs Pats End RestSkel, coq.elaborate-skeleton RestSkel _ Rest ok, R = (T Rest). diff --git a/generic/Param_Empty.v b/generic/Param_Empty.v index 5cb51843..4b38b5c5 100644 --- a/generic/Param_Empty.v +++ b/generic/Param_Empty.v @@ -11,16 +11,11 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -Require Import ssreflect. -Require Import Stdlib Hierarchy. - -Import HoTTNotations. - -Require Import Database. -From Trocq Require Import Relnm. +From Trocq Require Import HoTTNotations Relnm. (* translations of inductives in Prop is not yet supported, but we can still generate everything for False by manually defining its parametricity translation and making it land in Type. *) +Unset Universe Polymorphism. Inductive EmptyR : Empty -> Empty -> Type :=. (* param2 does not handle universe polymorphic inductives. Hence we have define EmptyR before seting Universe Polymorphism. *) diff --git a/generic/Param_bool.v b/generic/Param_bool.v index e6424a0f..c2a116ca 100644 --- a/generic/Param_bool.v +++ b/generic/Param_bool.v @@ -11,17 +11,12 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -Require Import ssreflect. -Require Import Stdlib Hierarchy Param_lemmas. +From Trocq Require Import Relnm. +From Trocq Require Export HoTTNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. -Import HoTTNotations. - -Require Import Database. -From Trocq Require Import Relnm. - Elpi derive Bool. Definition BoolR := bool_R. Definition trueR := true_R. diff --git a/generic/Param_list.v b/generic/Param_list.v index 5f9b5a1b..8f77ba13 100644 --- a/generic/Param_list.v +++ b/generic/Param_list.v @@ -11,19 +11,14 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -Require Import ssreflect. -Require Import Stdlib Hierarchy Param_lemmas. +From Trocq Require Import Relnm. Set Universe Polymorphism. Unset Universe Minimization ToSet. Set Asymmetric Patterns. -Import HoTTNotations. - -Require Import Database. -From Trocq Require Import Relnm. - Elpi derive list. + Notation listR := list_R. Notation nilR := nil_R. Notation consR := cons_R. diff --git a/generic/Param_nat.v b/generic/Param_nat.v index 52dd52f9..4d111de1 100644 --- a/generic/Param_nat.v +++ b/generic/Param_nat.v @@ -11,17 +11,11 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -Require Import ssreflect ssrbool. -Require Import Stdlib Hierarchy Param_lemmas. +From Trocq Require Import Relnm. Set Universe Polymorphism. Unset Universe Minimization ToSet. -Import HoTTNotations. - -Require Import Database. -From Trocq Require Import Relnm. - Elpi derive nat. Notation natR := nat_R. Definition OR := O_R. diff --git a/generic/Param_option.v b/generic/Param_option.v index b4c72a26..69ce3cca 100644 --- a/generic/Param_option.v +++ b/generic/Param_option.v @@ -11,14 +11,9 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -Require Import ssreflect. -Require Import Stdlib Hierarchy Param_lemmas. +From Trocq Require Import Relnm. Set Universe Polymorphism. Unset Universe Minimization ToSet. -Import HoTTNotations. -Require Import Database. -From Trocq Require Import Relnm. - Elpi derive option. \ No newline at end of file diff --git a/generic/Param_prod.v b/generic/Param_prod.v index f95e9003..af2a251f 100644 --- a/generic/Param_prod.v +++ b/generic/Param_prod.v @@ -11,15 +11,9 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -Require Import ssreflect. -Require Import Stdlib Hierarchy Param_lemmas. +From Trocq Require Import Relnm. Set Universe Polymorphism. Unset Universe Minimization ToSet. -Import HoTTNotations. - -Require Import Database. -From Trocq Require Import Relnm. - Elpi derive prod. \ No newline at end of file diff --git a/generic/Param_sum.v b/generic/Param_sum.v index 8bd55e94..89727f75 100644 --- a/generic/Param_sum.v +++ b/generic/Param_sum.v @@ -11,17 +11,11 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -Require Import ssreflect. -Require Import Stdlib Hierarchy Param_lemmas. +From Trocq Require Import Relnm. Set Universe Polymorphism. Unset Universe Minimization ToSet. Set Asymmetric Patterns. -Import HoTTNotations. - -Require Import Database. -From Trocq Require Import Relnm. - Elpi derive sum. Definition Param01_sum := sum_rel01. diff --git a/generic/inductives/Gen.v b/generic/inductives/Gen.v new file mode 100644 index 00000000..df30c9d4 --- /dev/null +++ b/generic/inductives/Gen.v @@ -0,0 +1,10 @@ +From elpi.apps Require Export derive. + +From elpi.apps Require Export + derive.param2 + derive.projK. + +From Trocq Require Export HoTTNotations Hierarchy Stdlib. +From Trocq Require Export sym symK RsymK. +From Trocq Require Export injection_lemmas injK. +From Trocq Require Export mymap mR Rm mRRmK mapn Relnm. \ No newline at end of file diff --git a/generic/inductives/Relnm.v b/generic/inductives/Relnm.v index 982b61df..b06fafb1 100644 --- a/generic/inductives/Relnm.v +++ b/generic/inductives/Relnm.v @@ -7,10 +7,9 @@ From Trocq Require Import sym symK RsymK Param_lemmas mapn map4. Import HoTTNotations. (* Extra Dependency "algo/elpi/sym.elpi" as sym. *) -From elpi.apps Require Import derive.legacy derive.param2. +From elpi.apps Require Import derive derive.param2. -From Trocq Require Export Hierarchy. -Require Import Database. +From Trocq Require Export Stdlib Hierarchy Param_lemmas. Unset Uniform Inductive Parameters. (* Elpi Db derive.rel44.db lp:{{ diff --git a/generic/inductives/Rm.v b/generic/inductives/Rm.v index e9735545..49f627fb 100644 --- a/generic/inductives/Rm.v +++ b/generic/inductives/Rm.v @@ -4,13 +4,11 @@ From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. From elpi Require Import elpi. -From Trocq Require Export Hierarchy. +From Trocq Require Export Hierarchy Param_lemmas mymap. -From elpi.apps Require Export derive.param2. +From elpi.apps Require Export derive derive.param2. From elpi.apps Require Export derive.bcongr. (* for eq_f register *) -(* From Trocq Require Export mymap. *) -(* todo: the real dependency is mymap *) -From Trocq Require Import mR. + Unset Uniform Inductive Parameters. Elpi Db derive.Rm.db lp:{{ % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. diff --git a/generic/inductives/RsymK.v b/generic/inductives/RsymK.v index 2e432f6a..66a49198 100644 --- a/generic/inductives/RsymK.v +++ b/generic/inductives/RsymK.v @@ -8,7 +8,7 @@ From Trocq Require Import sym symK. Import HoTTNotations. (* Extra Dependency "algo/elpi/sym.elpi" as sym. *) -From elpi.apps Require Import derive.legacy derive.param2. +From elpi.apps Require Import derive derive.param2. From Trocq Require Export Hierarchy. Unset Uniform Inductive Parameters. diff --git a/generic/inductives/injK.v b/generic/inductives/injK.v index aa613190..dabb6599 100644 --- a/generic/inductives/injK.v +++ b/generic/inductives/injK.v @@ -4,20 +4,18 @@ From Trocq.Elpi Extra Dependency "inductives/injK.elpi" as injK. From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. From Trocq Require Export injection_lemmas. -From elpi Require Import elpi. From elpi.apps Require Export derive.bcongr. (* for eq_f register *) -(* From Trocq Require Export Rm. *) -From Trocq Require Import Hierarchy. -(* From Trocq Require Import HoTT_additions Hierarchy. *) +From Trocq Require Import HoTTNotations Stdlib Hierarchy. + Unset Uniform Inductive Parameters. Definition conv (A : Type) (x y : A) (p: x = y) - (P : forall x0 : A, x = x0 -> Prop) (P0 : P x eq_refl) := + (P : forall x0 : A, x = x0 -> Prop) (P0 : P x idpath) := match p as p0 in _ = t return (P t p0) - with eq_refl => P0 end. + with idpath => P0 end. -Register conv as elpi.derive.conv. +Register conv as trocq.conv. Elpi Db derive.injectionsK.db lp:{{ diff --git a/generic/inductives/injection_lemmas.v b/generic/inductives/injection_lemmas.v index 0753a237..9ca57bf3 100644 --- a/generic/inductives/injection_lemmas.v +++ b/generic/inductives/injection_lemmas.v @@ -4,10 +4,12 @@ From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive From Trocq.Elpi Extra Dependency "inductives/injection_lemmas.elpi" as injections. From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. -From elpi.apps Require Import derive.legacy. +From elpi.apps Require Import derive. From elpi.apps Require Export derive.bcongr. (* for eq_f register *) From elpi.apps Require Export derive.projK. +From Trocq Require Export Stdlib. + Unset Uniform Inductive Parameters. Elpi Db derive.injections.db lp:{{ diff --git a/generic/inductives/mR.v b/generic/inductives/mR.v index 47f4e8ce..bf1f3563 100644 --- a/generic/inductives/mR.v +++ b/generic/inductives/mR.v @@ -6,12 +6,14 @@ From Trocq.Elpi Extra Dependency "inductives/injection_lemmas.elpi" as injection From elpi Require Import elpi. From elpi.apps Require Export derive.param2 derive.isK. +(* todo: ask for bool_discr to be defined elsewhere *) +(* todo: perhaps redefine eq_f *) From elpi.apps Require Export derive.bcongr (* for eq_f register *) derive.eqK (*for bool_discr *) derive.isK. (* for isK db required by discriminate *) From Trocq Require Export mymap injection_lemmas. -From Trocq Require Export Hierarchy. +From Trocq Require Export Hierarchy Param_lemmas Stdlib. Unset Uniform Inductive Parameters. Elpi Db derive.mR.db lp:{{ @@ -66,6 +68,3 @@ derivation (indt T) Prefix ff (derive "mR" (derive.mR.main T Prefix) (mR-done T) }}. - - - diff --git a/generic/inductives/mapn.v b/generic/inductives/mapn.v index 1b5dde4e..96b2659a 100644 --- a/generic/inductives/mapn.v +++ b/generic/inductives/mapn.v @@ -2,8 +2,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From Trocq.Elpi Extra Dependency "inductives/mapn.elpi" as mapn. From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. -From Trocq Require Import map4. -Require Import Database. +From Trocq Require Import Database map4. Unset Uniform Inductive Parameters. (* I have to use Trocq db due to a dependency of type declaration of predicates in umap-db *) diff --git a/generic/inductives/mymap.v b/generic/inductives/mymap.v index f9e3afcd..c10d360f 100644 --- a/generic/inductives/mymap.v +++ b/generic/inductives/mymap.v @@ -2,8 +2,8 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From Trocq.Elpi Extra Dependency "inductives/mymap.elpi" as mymap. From elpi Require Import elpi. -From elpi.apps Require Import derive.legacy. -From Trocq Require Export Hierarchy. +From elpi.apps Require Import derive. +From Trocq Require Export Stdlib Hierarchy. Unset Uniform Inductive Parameters. Elpi Db derive.mymap.db lp:{{ @@ -51,5 +51,3 @@ Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "mymap" (derive.mymap.main T Prefix) (mymap-done T)). }}. - - diff --git a/generic/inductives/sym.v b/generic/inductives/sym.v index b9eb6655..c8574859 100644 --- a/generic/inductives/sym.v +++ b/generic/inductives/sym.v @@ -4,7 +4,7 @@ From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. From Trocq.Elpi Extra Dependency "inductives/sym.elpi" as sym. -From elpi.apps Require Import derive.legacy derive.param2. +From elpi.apps Require Export derive derive.param2 derive.bcongr. From Trocq Require Export Hierarchy Stdlib. Unset Uniform Inductive Parameters. diff --git a/generic/inductives/symK.v b/generic/inductives/symK.v index 3faa8679..3cec889e 100644 --- a/generic/inductives/symK.v +++ b/generic/inductives/symK.v @@ -7,7 +7,7 @@ From Trocq.Elpi Extra Dependency "inductives/symK.elpi" as symK. From Trocq Require Import sym. (* Extra Dependency "algo/elpi/sym.elpi" as sym. *) -From elpi.apps Require Import derive.legacy derive.param2. +From elpi.apps Require Import derive derive.param2. From Trocq Require Export Hierarchy. Unset Uniform Inductive Parameters. diff --git a/hott/Hierarchy.v b/hott/Hierarchy.v index 84fc549c..4848a499 100644 --- a/hott/Hierarchy.v +++ b/hott/Hierarchy.v @@ -89,10 +89,16 @@ End Map4. Register Map0.Has as trocq.map0. Register Map1.Has as trocq.map1. +Register Map1.map as trocq.map1.map. Register Map2a.Has as trocq.map2a. +(* I would rather define trocq.map2a.map-in-r in elpi *) +Register Map2a.map_in_R as trocq.map2a.map_in_r. Register Map2b.Has as trocq.map2b. +(* I would rather define trocq.map2b.r-in-map in elpi *) +Register Map2b.R_in_map as trocq.map2b.r_in_map. Register Map3.Has as trocq.map3. Register Map4.Has as trocq.map4. +Register Map4.R_in_mapK as trocq.map4.r_in_mapk. Elpi Query lp:{{register-map-classes}}. Definition sym_rel@{i} {A B : Type@{i}} (R : A -> B -> Type@{i}) := fun b a => R a b. diff --git a/hott/HoTTNotations.v b/hott/HoTTNotations.v new file mode 100644 index 00000000..ab782c60 --- /dev/null +++ b/hott/HoTTNotations.v @@ -0,0 +1 @@ +(* File for compatibility with /std *) \ No newline at end of file diff --git a/hott/Param_lemmas.v b/hott/Param_lemmas.v index d8f9a134..ab4fd81c 100644 --- a/hott/Param_lemmas.v +++ b/hott/Param_lemmas.v @@ -168,6 +168,13 @@ move=> RR' [m mR Rm RmK]; unshelve eexists m _ _. by case: RR' => /= f [/= g ]. Defined. +Register eq_Map0 as trocq.eq_map0. +Register eq_Map1 as trocq.eq_map1. +Register eq_Map2a as trocq.eq_map2a. +Register eq_Map2b as trocq.eq_map2b. +Register eq_Map3 as trocq.eq_map3. +Register eq_Map4 as trocq.eq_map4. + (************************) (* Proofs about Param44 *) diff --git a/hott/Stdlib.v b/hott/Stdlib.v index 7e7d052e..b1f5603c 100644 --- a/hott/Stdlib.v +++ b/hott/Stdlib.v @@ -13,7 +13,14 @@ From HoTT Require Export HoTT. From Trocq Require Export HoTT_additions. +From elpi Require Export elpi. Module HoTTNotations. (* Stub for compatibility with stdlib version *) End HoTTNotations. + +Register concat as trocq.concat. +Register idpath as trocq.idpath. +Register inverse as trocq.inverse. +Register paths_ind as trocq.paths_ind. +Register exist as trocq.exist. \ No newline at end of file diff --git a/hott/_CoqProject b/hott/_CoqProject index 6582f06e..aa18adc9 100644 --- a/hott/_CoqProject +++ b/hott/_CoqProject @@ -6,6 +6,7 @@ -R ./generic/inductives Trocq -R ../elpi/ Trocq.Elpi +HoTTNotations.v Common.v Hierarchy.v HoTT_additions.v diff --git a/std/Hierarchy.v b/std/Hierarchy.v index 7696791f..ec32423f 100644 --- a/std/Hierarchy.v +++ b/std/Hierarchy.v @@ -89,10 +89,14 @@ End Map4. Register Map0.Has as trocq.map0. Register Map1.Has as trocq.map1. +Register Map1.map as trocq.map1.map. Register Map2a.Has as trocq.map2a. +Register Map2a.map_in_R as trocq.map2a.map_in_r. Register Map2b.Has as trocq.map2b. +Register Map2b.R_in_map as trocq.map2b.r_in_map. Register Map3.Has as trocq.map3. Register Map4.Has as trocq.map4. +Register Map4.R_in_mapK as trocq.map4.r_in_mapk. Elpi Query lp:{{register-map-classes}}. Definition sym_rel@{i} {A B : Type@{i}} (R : A -> B -> Type@{i}) := fun b a => R a b. diff --git a/std/Param_lemmas.v b/std/Param_lemmas.v index 428d68db..4050523f 100644 --- a/std/Param_lemmas.v +++ b/std/Param_lemmas.v @@ -168,3 +168,10 @@ move=> RR' [m mR Rm RmK]; unshelve eexists m _ _. - move=> a' b r /=; rewrite RmK. by case: RR' => /= f [/= g ]. Defined. + +Register eq_Map0 as trocq.eq_map0. +Register eq_Map1 as trocq.eq_map1. +Register eq_Map2a as trocq.eq_map2a. +Register eq_Map2b as trocq.eq_map2b. +Register eq_Map3 as trocq.eq_map3. +Register eq_Map4 as trocq.eq_map4. \ No newline at end of file diff --git a/std/Stdlib.v b/std/Stdlib.v index a1b680f1..62abbe57 100644 --- a/std/Stdlib.v +++ b/std/Stdlib.v @@ -12,6 +12,13 @@ (*****************************************************************************) Require Import ssreflect. From Trocq Require Import HoTTNotations. +From elpi Require Export elpi. + +Register idpath as trocq.idpath. +Register concat as trocq.concat. +Register inverse as trocq.inverse. +Register eq_ind as trocq.paths_ind. +Register existT as trocq.exist. Set Universe Polymorphism. Unset Universe Minimization ToSet. diff --git a/tests/inductives/coverage.v b/tests/inductives/coverage.v index 9d069448..89a484fa 100644 --- a/tests/inductives/coverage.v +++ b/tests/inductives/coverage.v @@ -1,19 +1,21 @@ +Unset Universe Polymorphism. + Inductive False : Set :=. -Inductive Unit : Set := -| TT : Unit. +Inductive testUnit : Set := +| TT : testUnit. -Inductive Bool : Set := +Inductive testBool : Set := | Falseb | Trueb. Inductive Wrap : Set := -| KWrap1 : Unit -> Wrap. +| KWrap1 : testUnit -> Wrap. Inductive WrapMore : Set := -| KWrap : Unit -> Bool -> WrapMore +| KWrap : testUnit -> testBool -> WrapMore | KWrapWrap : Wrap -> WrapMore -| F : Unit -> Unit -> Unit -> WrapMore. +| F : testUnit -> testUnit -> testUnit -> WrapMore. Inductive Nat : Set := | O' diff --git a/tests/inductives/test_Relnm.v b/tests/inductives/test_Relnm.v index d6d30ee4..fdd9e1cb 100644 --- a/tests/inductives/test_Relnm.v +++ b/tests/inductives/test_Relnm.v @@ -1,15 +1,14 @@ - -Require Import Database. -From Trocq Require Import coverage Relnm. +From Trocq Require Import Relnm. +Require Import coverage. Elpi derive False. Check False_rel44. -Elpi derive Unit. -Check Unit_rel44. +Elpi derive testUnit. +Check testUnit_rel44. -Elpi derive Bool. -Check Bool_rel44. +Elpi derive testBool. +Check testBool_rel44. Elpi derive Wrap. Check Wrap_rel44. diff --git a/tests/inductives/test_Rm.v b/tests/inductives/test_Rm.v index eead86e1..fde7532c 100644 --- a/tests/inductives/test_Rm.v +++ b/tests/inductives/test_Rm.v @@ -1,19 +1,18 @@ From Trocq Require Import Rm. -From Trocq Require Import coverage. -From Trocq Require Import Hierarchy. +Require Import coverage. Unset Uniform Inductive Parameters. Elpi derive.param2 False. Elpi derive.mymap False. Elpi derive.Rm False. -Elpi derive.param2 Unit. -Elpi derive.mymap Unit. -Elpi derive.Rm Unit. +Elpi derive.param2 testUnit. +Elpi derive.mymap testUnit. +Elpi derive.Rm testUnit. -Elpi derive.param2 Bool. -Elpi derive.mymap Bool. -Elpi derive.Rm Bool. +Elpi derive.param2 testBool. +Elpi derive.mymap testBool. +Elpi derive.Rm testBool. Elpi derive.param2 Wrap. Elpi derive.mymap Wrap. diff --git a/tests/inductives/test_RsymK.v b/tests/inductives/test_RsymK.v index f9f0f78f..3383cf16 100644 --- a/tests/inductives/test_RsymK.v +++ b/tests/inductives/test_RsymK.v @@ -1,21 +1,22 @@ From elpi.apps Require Import derive.param2. -From Trocq Require Import sym symK RsymK coverage. +From Trocq Require Import sym symK RsymK. +Require Import coverage. Elpi derive.param2 False. Elpi derive.sym False. Elpi derive.symK False. Elpi derive.rsymK False. -Elpi derive.param2 Unit. -Elpi derive.sym Unit. -Elpi derive.symK Unit. -Elpi derive.rsymK Unit. +Elpi derive.param2 testUnit. +Elpi derive.sym testUnit. +Elpi derive.symK testUnit. +Elpi derive.rsymK testUnit. -Elpi derive.param2 Bool. -Elpi derive.sym Bool. -Elpi derive.symK Bool. -Elpi derive.rsymK Bool. +Elpi derive.param2 testBool. +Elpi derive.sym testBool. +Elpi derive.symK testBool. +Elpi derive.rsymK testBool. Elpi derive.param2 Wrap. Elpi derive.sym Wrap. diff --git a/tests/inductives/test_injK.v b/tests/inductives/test_injK.v index 263cabba..ab3c17f9 100644 --- a/tests/inductives/test_injK.v +++ b/tests/inductives/test_injK.v @@ -1,19 +1,18 @@ From Trocq Require Import injK. -From Trocq Require Import coverage. -From Trocq Require Import Hierarchy. +Require Import coverage. Unset Uniform Inductive Parameters. Elpi derive.projK False. Elpi derive.injections False. Elpi derive.injK False. -Elpi derive.projK Unit. -Elpi derive.injections Unit. -Elpi derive.injK Unit. +Elpi derive.projK testUnit. +Elpi derive.injections testUnit. +Elpi derive.injK testUnit. -Elpi derive.projK Bool. -Elpi derive.injections Bool. -Elpi derive.injK Bool. +Elpi derive.projK testBool. +Elpi derive.injections testBool. +Elpi derive.injK testBool. Elpi derive.projK Wrap. Elpi derive.injections Wrap. diff --git a/tests/inductives/test_injection_lemmas.v b/tests/inductives/test_injection_lemmas.v index fe66f545..bffb87c3 100644 --- a/tests/inductives/test_injection_lemmas.v +++ b/tests/inductives/test_injection_lemmas.v @@ -1,15 +1,15 @@ From Trocq Require Import injection_lemmas. -From Trocq Require Import coverage. +Require Import coverage. Unset Uniform Inductive Parameters. Elpi derive.projK False. Elpi derive.injections False. -Elpi derive.projK Unit. -Elpi derive.injections Unit. +Elpi derive.projK testUnit. +Elpi derive.injections testUnit. -Elpi derive.projK Bool. -Elpi derive.injections Bool. +Elpi derive.projK testBool. +Elpi derive.injections testBool. Elpi derive.projK Wrap. Elpi derive.injections Wrap. diff --git a/tests/inductives/test_mR.v b/tests/inductives/test_mR.v index c5eceb78..0597dc2a 100644 --- a/tests/inductives/test_mR.v +++ b/tests/inductives/test_mR.v @@ -1,6 +1,5 @@ From Trocq Require Import mR. -From Trocq Require Import coverage. -From Trocq Require Import Hierarchy. +Require Import coverage. Unset Uniform Inductive Parameters. Elpi derive.param2 False. @@ -10,17 +9,17 @@ Elpi derive.injections False. Elpi derive.isK False. Elpi derive.mR False. -Elpi derive.param2 Unit. -Elpi derive.mymap Unit. -Elpi derive.projK Unit. -Elpi derive.injections Unit. -Elpi derive.isK Unit. -Elpi derive.mR Unit. +Elpi derive.param2 testUnit. +Elpi derive.mymap testUnit. +Elpi derive.projK testUnit. +Elpi derive.injections testUnit. +Elpi derive.isK testUnit. +Elpi derive.mR testUnit. -Elpi derive.param2 Bool. -Elpi derive.mymap Bool. -Elpi derive.isK Bool. -Elpi derive.mR Bool. +Elpi derive.param2 testBool. +Elpi derive.mymap testBool. +Elpi derive.isK testBool. +Elpi derive.mR testBool. Elpi derive.param2 Wrap. Elpi derive.mymap Wrap. diff --git a/tests/inductives/test_mRRmK.v b/tests/inductives/test_mRRmK.v index 27fa47d4..89441834 100644 --- a/tests/inductives/test_mRRmK.v +++ b/tests/inductives/test_mRRmK.v @@ -1,6 +1,5 @@ From Trocq Require Import mR Rm injK mRRmK. -From Trocq Require Import coverage. -From Trocq Require Import Hierarchy. +Require Import coverage. Unset Uniform Inductive Parameters. Elpi derive.param2 False. @@ -13,25 +12,25 @@ Elpi derive.Rm False. Elpi derive.injK False. Elpi derive.mRRmK False. -Elpi derive.param2 Unit. -Elpi derive.mymap Unit. -Elpi derive.projK Unit. -Elpi derive.injections Unit. -Elpi derive.isK Unit. -Elpi derive.mR Unit. -Elpi derive.Rm Unit. -Elpi derive.injK Unit. -Elpi derive.mRRmK Unit. +Elpi derive.param2 testUnit. +Elpi derive.mymap testUnit. +Elpi derive.projK testUnit. +Elpi derive.injections testUnit. +Elpi derive.isK testUnit. +Elpi derive.mR testUnit. +Elpi derive.Rm testUnit. +Elpi derive.injK testUnit. +Elpi derive.mRRmK testUnit. -Elpi derive.param2 Bool. -Elpi derive.mymap Bool. -Elpi derive.projK Bool. -Elpi derive.injections Bool. -Elpi derive.isK Bool. -Elpi derive.mR Bool. -Elpi derive.Rm Bool. -Elpi derive.injK Bool. -Elpi derive.mRRmK Bool. +Elpi derive.param2 testBool. +Elpi derive.mymap testBool. +Elpi derive.projK testBool. +Elpi derive.injections testBool. +Elpi derive.isK testBool. +Elpi derive.mR testBool. +Elpi derive.Rm testBool. +Elpi derive.injK testBool. +Elpi derive.mRRmK testBool. Elpi derive.param2 Wrap. Elpi derive.mymap Wrap. diff --git a/tests/inductives/test_map4.v b/tests/inductives/test_map4.v index 452828e6..625534da 100644 --- a/tests/inductives/test_map4.v +++ b/tests/inductives/test_map4.v @@ -1,15 +1,15 @@ From Trocq Require Import map4. -From Trocq Require Import coverage. +Require Import coverage. Unset Uniform Inductive Parameters. Elpi derive False. Check False_mRRmK : forall f1 f2 fR, False_mR f1 f2 (False_Rm f1 f2 fR) = fR. -Elpi derive Unit. -Check Unit_mRRmK : forall u1 u2 uR, Unit_mR u1 u2 (Unit_Rm u1 u2 uR) = uR. +Elpi derive testUnit. +Check testUnit_mRRmK : forall u1 u2 uR, testUnit_mR u1 u2 (testUnit_Rm u1 u2 uR) = uR. -Elpi derive Bool. -Check Bool_mRRmK : forall b1 b2 bR, Bool_mR b1 b2 (Bool_Rm b1 b2 bR) = bR. +Elpi derive testBool. +Check testBool_mRRmK : forall b1 b2 bR, testBool_mR b1 b2 (testBool_Rm b1 b2 bR) = bR. Elpi derive Wrap. Check Wrap_mRRmK : forall w1 w2 wR, Wrap_mR w1 w2 (Wrap_Rm w1 w2 wR) = wR. diff --git a/tests/inductives/test_mapn.v b/tests/inductives/test_mapn.v index 7fe28738..e34d35b1 100644 --- a/tests/inductives/test_mapn.v +++ b/tests/inductives/test_mapn.v @@ -1,6 +1,5 @@ -Require Import Database. From Trocq Require Import map4 mapn. -From Trocq Require Import coverage. +Require Import coverage. Unset Uniform Inductive Parameters. Elpi derive False. @@ -11,11 +10,11 @@ Check False_map2b : Map2b.Has False_R. Check False_map3 : Map3.Has False_R. Check False_map4 : IsUMap False_R. -Elpi derive Unit. -Check Unit_map4 : IsUMap Unit_R. +Elpi derive testUnit. +Check testUnit_map4 : IsUMap testUnit_R. -Elpi derive Bool. -Check Bool_map4 : IsUMap Bool_R. +Elpi derive testBool. +Check testBool_map4 : IsUMap testBool_R. Elpi derive Wrap. Check Wrap_map4 : IsUMap Wrap_R. diff --git a/tests/inductives/test_mymap.v b/tests/inductives/test_mymap.v index a68d1a8c..9a2e48b7 100644 --- a/tests/inductives/test_mymap.v +++ b/tests/inductives/test_mymap.v @@ -1,12 +1,10 @@ -From Trocq Require Import coverage. -From elpi Require Import elpi. From Trocq Require Import mymap. -From Trocq Require Import Hierarchy. +Require Import coverage. Unset Uniform Inductive Parameters. Elpi derive.mymap False. -Elpi derive.mymap Unit. -Elpi derive.mymap Bool. +Elpi derive.mymap testUnit. +Elpi derive.mymap testBool. Elpi derive.mymap Wrap. Elpi derive.mymap WrapMore. Elpi derive.mymap Box. diff --git a/tests/inductives/test_sym.v b/tests/inductives/test_sym.v index 7e0bc642..78ad5bf3 100644 --- a/tests/inductives/test_sym.v +++ b/tests/inductives/test_sym.v @@ -1,15 +1,17 @@ From elpi Require Import elpi. -From elpi.apps Require Import derive.param2. -From Trocq Require Import coverage sym. +From elpi.apps Require Import derive.legacy derive.param2. + +Require Import coverage. +From Trocq Require Import sym. Elpi derive.param2 False. Elpi derive.sym False. -Elpi derive.param2 Unit. -Elpi derive.sym Unit. +Elpi derive.param2 testUnit. +Elpi derive.sym testUnit. -Elpi derive.param2 Bool. -Elpi derive.sym Bool. +Elpi derive.param2 testBool. +Elpi derive.sym testBool. Elpi derive.param2 Wrap. Elpi derive.sym Wrap. diff --git a/tests/inductives/test_symK.v b/tests/inductives/test_symK.v index e3b7f5b1..c528e43e 100644 --- a/tests/inductives/test_symK.v +++ b/tests/inductives/test_symK.v @@ -1,18 +1,19 @@ From elpi Require Import elpi. From elpi.apps Require Import derive.param2. -From Trocq Require Import coverage sym symK. +From Trocq Require Import sym symK. +Require Import coverage. Elpi derive.param2 False. Elpi derive.sym False. Elpi derive.symK False. -Elpi derive.param2 Unit. -Elpi derive.sym Unit. -Elpi derive.symK Unit. +Elpi derive.param2 testUnit. +Elpi derive.sym testUnit. +Elpi derive.symK testUnit. -Elpi derive.param2 Bool. -Elpi derive.sym Bool. -Elpi derive.symK Bool. +Elpi derive.param2 testBool. +Elpi derive.sym testBool. +Elpi derive.symK testBool. Elpi derive.param2 Wrap. Elpi derive.sym Wrap. From 4245361f9746f4a74d70e780fe5a7e128b6ecbbe Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 22 Apr 2026 13:05:42 +0200 Subject: [PATCH 24/42] removing elpi.lib dependencies removing derive.bcongr dependency removing derive.eqk dependency removing some comments --- elpi/inductives/Rm.elpi | 1 + elpi/inductives/injection_lemmas.elpi | 3 ++- elpi/inductives/utils.elpi | 2 +- generic/Param_Empty.v | 2 ++ generic/inductives/DeriveLib.v | 13 +++++++++++ generic/inductives/Relnm.v | 1 - generic/inductives/Rm.v | 1 - generic/inductives/RsymK.v | 1 - generic/inductives/injK.v | 4 +--- generic/inductives/injection_lemmas.v | 6 ++---- generic/inductives/mR.v | 11 +++------- generic/inductives/mRRmK.v | 4 ---- generic/inductives/sym.v | 3 +-- generic/inductives/symK.v | 1 - generic/inductives/test.v | 31 +++++++++++++++++++++++++++ hott/Stdlib.v | 3 ++- hott/_CoqProject | 1 + std/Stdlib.v | 1 + std/_CoqProject | 1 + 19 files changed, 62 insertions(+), 28 deletions(-) create mode 100644 generic/inductives/DeriveLib.v create mode 100644 generic/inductives/test.v diff --git a/elpi/inductives/Rm.elpi b/elpi/inductives/Rm.elpi index dff2448b..49f82284 100644 --- a/elpi/inductives/Rm.elpi +++ b/elpi/inductives/Rm.elpi @@ -37,6 +37,7 @@ mk-equalities [STy| SrcTys] ITyTy [DA|Dargs] [R|RS] :- pred process-args i:term, i:term, i:int, i:int, i:term, i:term, i:list term, i:list term, i:term, o:term. process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest ITyTy R:- coq.mk-app Goal [Ksrc, Kdest, {{ Type }}] EqTy, %discards the relation between Ksrc and Kdest, we want the equality. + % todo: change elpi.eq for trocq.idpath whd EqTy [] {{lib:@elpi.eq}} [ITyTy,MapA,B], whd MapA [] _ TySrcMappedArgs, whd B [] KDest TyDestArgs, diff --git a/elpi/inductives/injection_lemmas.elpi b/elpi/inductives/injection_lemmas.elpi index 216c01e6..fd4d6a12 100644 --- a/elpi/inductives/injection_lemmas.elpi +++ b/elpi/inductives/injection_lemmas.elpi @@ -21,6 +21,7 @@ Return the processed Types */ % Ret is discarded and replaced by Left = Right pred craft-eq i:int, i:int, i:int, i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, o:term. craft-eq 0 0 _ _ _ EqTy Left Right ConclEqTy ConclL ConclR R:- !, + %todo use trocq.idpath coq.mk-app {{lib:@elpi.eq}} [EqTy, Left, Right] AETy, coq.mk-app {{lib:@elpi.eq}} [ConclEqTy, ConclL, ConclR] C, R = {{ forall (e : lp:AETy), lp:C }}. @@ -73,7 +74,7 @@ implement-K-injector-J 0 J 0 TyParam (prod E Ty _) R :- !, @pi-decl E Ty e\ sigma GR TyArgs GRK KArgs A B\ ltac.injection? Ty GR TyArgs GRK KArgs A B, - ltac.injection.arg-i I J {{lib:@elpi.derive.eq_f}} GR TyArgs TyParam GRK KArgs A B e [(PL e)]. + ltac.injection.arg-i I J {{lib:@trocq.ap }} GR TyArgs TyParam GRK KArgs A B e [(PL e)]. implement-K-injector-J 0 J ArgNo TyParam (prod ArgN1 ArgTy a\ (prod ArgN2 ArgTy b\ (Bo a b))) (fun ArgN1 ArgTy a\ fun ArgN2 ArgTy b\ (R a b) ) :- !, ArgNon is ArgNo - 1, diff --git a/elpi/inductives/utils.elpi b/elpi/inductives/utils.elpi index 2e20bb13..b96cefc2 100644 --- a/elpi/inductives/utils.elpi +++ b/elpi/inductives/utils.elpi @@ -43,7 +43,7 @@ count-args N T R :- pred mk-aps-etas i:list term, i:term, i:list term, i:list term, i:list term, i:list term, o:list term. mk-aps-etas [] _ [] [] [] [] []. mk-aps-etas [DTy|DestTys] ITyTy [Eta|Etas] [SA|SrcArgs] [DA|DestArgs] [Eq|Eqs] [RE | RS] :- - Ap = {{ eq_f }}, + Ap = {{ lib:@trocq.ap }}, coq.mk-app Ap [DTy,ITyTy,Eta,SA,DA,Eq] R, coq.elaborate-skeleton R _ RE ok, mk-aps-etas DestTys ITyTy Etas SrcArgs DestArgs Eqs RS. diff --git a/generic/Param_Empty.v b/generic/Param_Empty.v index 4b38b5c5..bcd5e82d 100644 --- a/generic/Param_Empty.v +++ b/generic/Param_Empty.v @@ -20,6 +20,7 @@ Inductive EmptyR : Empty -> Empty -> Type :=. (* param2 does not handle universe polymorphic inductives. Hence we have define EmptyR before seting Universe Polymorphism. *) Elpi derive.param2.register "False" "EmptyR". +Elpi derive.param2.register "Empty" "EmptyR". Set Universe Polymorphism. Unset Universe Minimization ToSet. @@ -27,3 +28,4 @@ Unset Universe Minimization ToSet. Elpi derive Empty. Definition Param01_Empty := False_rel01. Definition Param10_Empty := False_rel10. + diff --git a/generic/inductives/DeriveLib.v b/generic/inductives/DeriveLib.v new file mode 100644 index 00000000..194912ad --- /dev/null +++ b/generic/inductives/DeriveLib.v @@ -0,0 +1,13 @@ +(* Compatibility layer with elpi's derive *) +From elpi Require Export elpi. +From Trocq Require Export Stdlib HoTTNotations. + +Definition eq_f := @ap. +Register eq_f as elpi.derive.eq_f. + +Definition bool_discr : true = false -> forall T : Type, T := +fun e T => + match e in _ = t + return match t with false => T | true => Unit end + with idpath => tt end. +Register bool_discr as elpi.bool_discr. \ No newline at end of file diff --git a/generic/inductives/Relnm.v b/generic/inductives/Relnm.v index b06fafb1..fab5ccab 100644 --- a/generic/inductives/Relnm.v +++ b/generic/inductives/Relnm.v @@ -5,7 +5,6 @@ From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. From Trocq.Elpi Extra Dependency "inductives/relnm.elpi" as relnm. From Trocq Require Import sym symK RsymK Param_lemmas mapn map4. Import HoTTNotations. -(* Extra Dependency "algo/elpi/sym.elpi" as sym. *) From elpi.apps Require Import derive derive.param2. diff --git a/generic/inductives/Rm.v b/generic/inductives/Rm.v index 49f627fb..6d66a7f8 100644 --- a/generic/inductives/Rm.v +++ b/generic/inductives/Rm.v @@ -7,7 +7,6 @@ From elpi Require Import elpi. From Trocq Require Export Hierarchy Param_lemmas mymap. From elpi.apps Require Export derive derive.param2. -From elpi.apps Require Export derive.bcongr. (* for eq_f register *) Unset Uniform Inductive Parameters. Elpi Db derive.Rm.db lp:{{ diff --git a/generic/inductives/RsymK.v b/generic/inductives/RsymK.v index 66a49198..67e5be6f 100644 --- a/generic/inductives/RsymK.v +++ b/generic/inductives/RsymK.v @@ -6,7 +6,6 @@ From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. From Trocq.Elpi Extra Dependency "inductives/RsymK.elpi" as rsymK. From Trocq Require Import sym symK. Import HoTTNotations. -(* Extra Dependency "algo/elpi/sym.elpi" as sym. *) From elpi.apps Require Import derive derive.param2. diff --git a/generic/inductives/injK.v b/generic/inductives/injK.v index dabb6599..4d809fc4 100644 --- a/generic/inductives/injK.v +++ b/generic/inductives/injK.v @@ -4,9 +4,7 @@ From Trocq.Elpi Extra Dependency "inductives/injK.elpi" as injK. From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. From Trocq Require Export injection_lemmas. -From elpi.apps Require Export derive.bcongr. (* for eq_f register *) - -From Trocq Require Import HoTTNotations Stdlib Hierarchy. +From Trocq Require Import DeriveLib HoTTNotations Stdlib Hierarchy. Unset Uniform Inductive Parameters. diff --git a/generic/inductives/injection_lemmas.v b/generic/inductives/injection_lemmas.v index 9ca57bf3..cd840534 100644 --- a/generic/inductives/injection_lemmas.v +++ b/generic/inductives/injection_lemmas.v @@ -4,11 +4,9 @@ From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive From Trocq.Elpi Extra Dependency "inductives/injection_lemmas.elpi" as injections. From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. -From elpi.apps Require Import derive. -From elpi.apps Require Export derive.bcongr. (* for eq_f register *) +From elpi.apps Require Export derive. From elpi.apps Require Export derive.projK. - -From Trocq Require Export Stdlib. +From Trocq Require Export DeriveLib. Unset Uniform Inductive Parameters. Elpi Db derive.injections.db lp:{{ diff --git a/generic/inductives/mR.v b/generic/inductives/mR.v index bf1f3563..b8c4076d 100644 --- a/generic/inductives/mR.v +++ b/generic/inductives/mR.v @@ -5,13 +5,8 @@ From Trocq.Elpi Extra Dependency "inductives/mR.elpi" as mR. From Trocq.Elpi Extra Dependency "inductives/injection_lemmas.elpi" as injections. From elpi Require Import elpi. -From elpi.apps Require Export derive.param2 derive.isK. -(* todo: ask for bool_discr to be defined elsewhere *) -(* todo: perhaps redefine eq_f *) -From elpi.apps Require Export derive.bcongr (* for eq_f register *) - derive.eqK (*for bool_discr *) - derive.isK. (* for isK db required by discriminate *) -From Trocq Require Export mymap injection_lemmas. +From elpi.apps Require Export derive.param2 derive.isK. (* for isK db required by discriminate *) +From Trocq Require Export DeriveLib mymap injection_lemmas. From Trocq Require Export Hierarchy Param_lemmas Stdlib. Unset Uniform Inductive Parameters. @@ -31,8 +26,8 @@ Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.mymap.db. -Elpi Accumulate File discr. Elpi Accumulate Db derive.isK.db. +Elpi Accumulate File discr. Elpi Accumulate Db derive.injections.db. Elpi Accumulate File common. Elpi Accumulate Db derive.mR.db. diff --git a/generic/inductives/mRRmK.v b/generic/inductives/mRRmK.v index fe7eac70..96f4ad38 100644 --- a/generic/inductives/mRRmK.v +++ b/generic/inductives/mRRmK.v @@ -6,11 +6,7 @@ From Trocq Require Export mymap injK mR Rm. From elpi Require Import elpi. From elpi.apps Require Export derive.param2. -(* From elpi.apps Require Import derive.bcongr. for eq_f register *) -(* From Trocq Require Import mymap. *) -(* From elpi.apps Require Import derive.induction. *) From Trocq Require Import Hierarchy. -(* From Trocq Require Import HoTT_additions Hierarchy. *) Unset Uniform Inductive Parameters. Elpi Db derive.mRRmK.db lp:{{ diff --git a/generic/inductives/sym.v b/generic/inductives/sym.v index c8574859..6df50ab9 100644 --- a/generic/inductives/sym.v +++ b/generic/inductives/sym.v @@ -4,8 +4,7 @@ From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. From Trocq.Elpi Extra Dependency "inductives/sym.elpi" as sym. -From elpi.apps Require Export derive derive.param2 derive.bcongr. - +From elpi.apps Require Export derive derive.param2. From Trocq Require Export Hierarchy Stdlib. Unset Uniform Inductive Parameters. diff --git a/generic/inductives/symK.v b/generic/inductives/symK.v index 3cec889e..09804f2c 100644 --- a/generic/inductives/symK.v +++ b/generic/inductives/symK.v @@ -5,7 +5,6 @@ From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. From Trocq.Elpi Extra Dependency "inductives/symK.elpi" as symK. From Trocq Require Import sym. -(* Extra Dependency "algo/elpi/sym.elpi" as sym. *) From elpi.apps Require Import derive derive.param2. diff --git a/generic/inductives/test.v b/generic/inductives/test.v new file mode 100644 index 00000000..3c784e4f --- /dev/null +++ b/generic/inductives/test.v @@ -0,0 +1,31 @@ +From elpi.apps Require Export derive. + +From elpi.apps Require Export + derive.param2. + +From Trocq Require Export HoTTNotations Hierarchy Stdlib. + +Unset Universe Polymorphism. +Inductive EmptyR : Empty -> Empty -> Type :=. +(* param2 does not handle universe polymorphic inductives. + Hence we have define EmptyR before seting Universe Polymorphism. *) +Elpi derive.param2.register "False" "EmptyR". + +Set Universe Polymorphism. + From Trocq Require Export injection_lemmas injK. + +#[verbose] Elpi derive Empty. +#[verbose] Elpi derive.injections Empty. +Elpi derive.injK Empty. +Elpi derive Empty. + + derive.projK. + +(* From Trocq Require Export sym symK RsymK. *) +(* From Trocq Require Export mymap mR Rm mRRmK mapn Relnm. *) + +Unset Universe Minimization ToSet. + +#[verbose] Elpi derive Empty. +Definition Param01_Empty := False_rel01. +Definition Param10_Empty := False_rel10. diff --git a/hott/Stdlib.v b/hott/Stdlib.v index b1f5603c..e8e9cfff 100644 --- a/hott/Stdlib.v +++ b/hott/Stdlib.v @@ -23,4 +23,5 @@ Register concat as trocq.concat. Register idpath as trocq.idpath. Register inverse as trocq.inverse. Register paths_ind as trocq.paths_ind. -Register exist as trocq.exist. \ No newline at end of file +Register exist as trocq.exist. +Register ap as trocq.ap. \ No newline at end of file diff --git a/hott/_CoqProject b/hott/_CoqProject index aa18adc9..19471356 100644 --- a/hott/_CoqProject +++ b/hott/_CoqProject @@ -18,6 +18,7 @@ Param_forall.v Param_lemmas.v Stdlib.v +generic/inductives/DeriveLib.v generic/inductives/sym.v generic/inductives/symK.v generic/inductives/RsymK.v diff --git a/std/Stdlib.v b/std/Stdlib.v index 62abbe57..df2a4ea5 100644 --- a/std/Stdlib.v +++ b/std/Stdlib.v @@ -36,6 +36,7 @@ Definition inv_V {A : Type} {x y : A} (p : x = y) : (p^)^ = p := Definition ap := f_equal. Arguments ap {A B} f {x y}. +Register ap as trocq.ap. (* relation for forall *) Monomorphic Axiom Funext : Prop. diff --git a/std/_CoqProject b/std/_CoqProject index 683c94a5..af9804d9 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -16,6 +16,7 @@ Param_forall.v Param_lemmas.v Stdlib.v +generic/inductives/DeriveLib.v generic/inductives/sym.v generic/inductives/symK.v generic/inductives/RsymK.v From 39a7e64a88c46a2a3a4f82518c15c40ffee8361f Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Thu, 30 Apr 2026 22:44:25 +0200 Subject: [PATCH 25/42] fix issue with name overlap in coverage --- generic/inductives/sym.v | 1 + tests/inductives/coverage.v | 7 ++++++- tests/inductives/test_Relnm.v | 4 ++-- tests/inductives/test_Rm.v | 6 +++--- tests/inductives/test_RsymK.v | 8 ++++---- tests/inductives/test_mRRmK.v | 18 +++++++++--------- tests/inductives/test_map4.v | 4 ++-- tests/inductives/test_mapn.v | 14 +++++++------- tests/inductives/test_sym.v | 6 +++--- tests/inductives/test_symK.v | 6 +++--- 10 files changed, 40 insertions(+), 34 deletions(-) diff --git a/generic/inductives/sym.v b/generic/inductives/sym.v index 6df50ab9..6ef93c4d 100644 --- a/generic/inductives/sym.v +++ b/generic/inductives/sym.v @@ -57,3 +57,4 @@ dep1 "sym" "param2". derivation (indt T) Prefix ff (derive "sym" (derive.sym.main T Prefix) (sym-done T)). }}. + diff --git a/tests/inductives/coverage.v b/tests/inductives/coverage.v index 89a484fa..08422802 100644 --- a/tests/inductives/coverage.v +++ b/tests/inductives/coverage.v @@ -1,6 +1,11 @@ Unset Universe Polymorphism. +From elpi Require Import elpi. +From elpi.apps Require Import derive derive.param2. -Inductive False : Set :=. +From Trocq Require Import sym. +Unset Uniform Inductive Parameters. + +Inductive testFalse : Set :=. Inductive testUnit : Set := | TT : testUnit. diff --git a/tests/inductives/test_Relnm.v b/tests/inductives/test_Relnm.v index fdd9e1cb..b0b43384 100644 --- a/tests/inductives/test_Relnm.v +++ b/tests/inductives/test_Relnm.v @@ -1,8 +1,8 @@ From Trocq Require Import Relnm. Require Import coverage. -Elpi derive False. -Check False_rel44. +Elpi derive testFalse. +Check testFalse_rel44. Elpi derive testUnit. Check testUnit_rel44. diff --git a/tests/inductives/test_Rm.v b/tests/inductives/test_Rm.v index fde7532c..b32db4a3 100644 --- a/tests/inductives/test_Rm.v +++ b/tests/inductives/test_Rm.v @@ -2,9 +2,9 @@ From Trocq Require Import Rm. Require Import coverage. Unset Uniform Inductive Parameters. -Elpi derive.param2 False. -Elpi derive.mymap False. -Elpi derive.Rm False. +Elpi derive.param2 testFalse. +Elpi derive.mymap testFalse. +Elpi derive.Rm testFalse. Elpi derive.param2 testUnit. Elpi derive.mymap testUnit. diff --git a/tests/inductives/test_RsymK.v b/tests/inductives/test_RsymK.v index 3383cf16..cbb1f709 100644 --- a/tests/inductives/test_RsymK.v +++ b/tests/inductives/test_RsymK.v @@ -3,10 +3,10 @@ From elpi.apps Require Import derive.param2. From Trocq Require Import sym symK RsymK. Require Import coverage. -Elpi derive.param2 False. -Elpi derive.sym False. -Elpi derive.symK False. -Elpi derive.rsymK False. +Elpi derive.param2 testFalse. +Elpi derive.sym testFalse. +Elpi derive.symK testFalse. +Elpi derive.rsymK testFalse. Elpi derive.param2 testUnit. Elpi derive.sym testUnit. diff --git a/tests/inductives/test_mRRmK.v b/tests/inductives/test_mRRmK.v index 89441834..25333f12 100644 --- a/tests/inductives/test_mRRmK.v +++ b/tests/inductives/test_mRRmK.v @@ -2,15 +2,15 @@ From Trocq Require Import mR Rm injK mRRmK. Require Import coverage. Unset Uniform Inductive Parameters. -Elpi derive.param2 False. -Elpi derive.mymap False. -Elpi derive.projK False. -Elpi derive.injections False. -Elpi derive.isK False. -Elpi derive.mR False. -Elpi derive.Rm False. -Elpi derive.injK False. -Elpi derive.mRRmK False. +Elpi derive.param2 testFalse. +Elpi derive.mymap testFalse. +Elpi derive.projK testFalse. +Elpi derive.injections testFalse. +Elpi derive.isK testFalse. +Elpi derive.mR testFalse. +Elpi derive.Rm testFalse. +Elpi derive.injK testFalse. +Elpi derive.mRRmK testFalse. Elpi derive.param2 testUnit. Elpi derive.mymap testUnit. diff --git a/tests/inductives/test_map4.v b/tests/inductives/test_map4.v index 625534da..c9dbae47 100644 --- a/tests/inductives/test_map4.v +++ b/tests/inductives/test_map4.v @@ -2,8 +2,8 @@ From Trocq Require Import map4. Require Import coverage. Unset Uniform Inductive Parameters. -Elpi derive False. -Check False_mRRmK : forall f1 f2 fR, False_mR f1 f2 (False_Rm f1 f2 fR) = fR. +Elpi derive testFalse. +Check testFalse_mRRmK : forall f1 f2 fR, testFalse_mR f1 f2 (testFalse_Rm f1 f2 fR) = fR. Elpi derive testUnit. Check testUnit_mRRmK : forall u1 u2 uR, testUnit_mR u1 u2 (testUnit_Rm u1 u2 uR) = uR. diff --git a/tests/inductives/test_mapn.v b/tests/inductives/test_mapn.v index e34d35b1..a993aade 100644 --- a/tests/inductives/test_mapn.v +++ b/tests/inductives/test_mapn.v @@ -2,13 +2,13 @@ From Trocq Require Import map4 mapn. Require Import coverage. Unset Uniform Inductive Parameters. -Elpi derive False. -Check False_map0 : Map0.Has False_R. -Check False_map1 : Map1.Has False_R. -Check False_map2a : Map2a.Has False_R. -Check False_map2b : Map2b.Has False_R. -Check False_map3 : Map3.Has False_R. -Check False_map4 : IsUMap False_R. +Elpi derive testFalse. +Check testFalse_map0 : Map0.Has testFalse_R. +Check testFalse_map1 : Map1.Has testFalse_R. +Check testFalse_map2a : Map2a.Has testFalse_R. +Check testFalse_map2b : Map2b.Has testFalse_R. +Check testFalse_map3 : Map3.Has testFalse_R. +Check testFalse_map4 : IsUMap testFalse_R. Elpi derive testUnit. Check testUnit_map4 : IsUMap testUnit_R. diff --git a/tests/inductives/test_sym.v b/tests/inductives/test_sym.v index 78ad5bf3..572e9750 100644 --- a/tests/inductives/test_sym.v +++ b/tests/inductives/test_sym.v @@ -1,11 +1,11 @@ From elpi Require Import elpi. -From elpi.apps Require Import derive.legacy derive.param2. +From elpi.apps Require Import derive derive.param2. Require Import coverage. From Trocq Require Import sym. -Elpi derive.param2 False. -Elpi derive.sym False. +Elpi derive.param2 testFalse. +Elpi derive.sym testFalse. Elpi derive.param2 testUnit. Elpi derive.sym testUnit. diff --git a/tests/inductives/test_symK.v b/tests/inductives/test_symK.v index c528e43e..5f71bd98 100644 --- a/tests/inductives/test_symK.v +++ b/tests/inductives/test_symK.v @@ -3,9 +3,9 @@ From elpi.apps Require Import derive.param2. From Trocq Require Import sym symK. Require Import coverage. -Elpi derive.param2 False. -Elpi derive.sym False. -Elpi derive.symK False. +Elpi derive.param2 testFalse. +Elpi derive.sym testFalse. +Elpi derive.symK testFalse. Elpi derive.param2 testUnit. Elpi derive.sym testUnit. From 3b77308ac85f26bf625307b424fefebe4330d9a3 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Fri, 1 May 2026 21:05:45 +0200 Subject: [PATCH 26/42] generalize inductive generation to universe polymorphism adapt to univ.poly.param2 issue 1003 in rocq-elpi fix some uses of coq.env.global recovers param_empty for HoTT. requires isK and discriminate for pglobal to recover the rest fixes param_bool for hott adapt injections + injK to sortpoly fix injK for inductives with type parameteres fix sym symK non-dep path induction fix option for hott fixes sym and symK fix injections + injK + Rm fixes mRRmK up to sum fixes prod + adds 'iota' for primitive projections fixes lists fix vector fixes hott --- elpi/database.elpi | 4 +- elpi/inductives/Rm.elpi | 95 +++++++++-------- elpi/inductives/RsymK.elpi | 7 +- elpi/inductives/common_algo.elpi | 31 +++--- elpi/inductives/injK.elpi | 88 ++++++++-------- elpi/inductives/injection_lemmas.elpi | 54 +++++----- elpi/inductives/mR.elpi | 107 +++++++++++--------- elpi/inductives/mRRmK.elpi | 123 ++++++++++++----------- elpi/inductives/mapn.elpi | 32 +++--- elpi/inductives/mymap.elpi | 65 +++++++----- elpi/inductives/relnm.elpi | 4 +- elpi/inductives/sym.elpi | 39 ++++--- elpi/inductives/symK.elpi | 55 +++++----- elpi/inductives/utils.elpi | 116 ++++++++++++++------- generic/Param_Empty.v | 9 +- generic/Param_bool.v | 17 +++- generic/Param_prod.v | 10 ++ generic/Param_vector.v | 5 +- generic/inductives/DeriveLib.v | 5 +- generic/inductives/Rm.v | 16 ++- generic/inductives/RsymK.v | 10 ++ generic/inductives/injK.v | 17 +++- generic/inductives/injection_lemmas.v | 12 ++- generic/inductives/mR.v | 20 +++- generic/inductives/mRRmK.v | 18 +++- generic/inductives/map4.v | 3 +- generic/inductives/mapn.v | 13 ++- generic/inductives/mymap.v | 2 +- generic/inductives/sym.v | 12 ++- generic/inductives/symK.v | 12 ++- hott/Hierarchy.v | 1 - hott/Stdlib.v | 6 +- hott/_CoqProject | 6 +- std/Hierarchy.v | 1 - std/Stdlib.v | 1 + std/_CoqProject | 6 +- tests/inductives/coverage.v | 28 +++--- tests/inductives/test_injK.v | 6 +- tests/inductives/test_injection_lemmas.v | 4 +- tests/inductives/test_mR.v | 12 +-- tests/inductives/test_map4.v | 20 ++-- tests/inductives/test_mymap.v | 2 +- 42 files changed, 638 insertions(+), 456 deletions(-) diff --git a/elpi/database.elpi b/elpi/database.elpi index 757896d3..d230c4c9 100644 --- a/elpi/database.elpi +++ b/elpi/database.elpi @@ -25,11 +25,13 @@ pred map-class->indc-class o:map-class, o:gref. % Given an inductive I and class M, obtain a proof that M has [|I|] pred map-ind i:term, i:map-class, o:term. +% Dispatcher of the above for universe polymorphic definitions. +pred map-def i:gref, i:map-class, o:gref. % Given an inductive I and class M, checks if M has [|I|] has been derived pred map-ind-done o:inductive. -% Given an inductive I and ParamNM, obtain a proof that +% Given an inductive I and ParamNM, obtain a proof that % given Tys1 NM related Tys2 then I Tys2 is NM related to I Tys2 pred param-ind i:term, i:param-class, o:term. diff --git a/elpi/inductives/Rm.elpi b/elpi/inductives/Rm.elpi index 49f82284..bf79e5eb 100644 --- a/elpi/inductives/Rm.elpi +++ b/elpi/inductives/Rm.elpi @@ -1,5 +1,6 @@ shorten derive.common-algo.{mk-mR-type-Rm}. -shorten derive.algo-utils.{mk-chain, type-of-args}. +shorten derive.algo-utils.{mk-chain, type-of-args, elim-into-path-suffix}. +shorten derive.algo-utils.{cmp-indt}. namespace derive.Rm { @@ -17,56 +18,57 @@ build-Rm-args [A1|Args1] [A2|Args2] T R :- pred build-Rm i:term, i:term, o:term. build-Rm STy ITyTy R :- - coq.safe-dest-app STy Ind Args1, - coq.safe-dest-app ITyTy Ind2 Args2, - rm-db Ind RM, - if (Ind = Ind2) + cmp-indt STy ITyTy SInd Ind, + coq.safe-dest-app STy _ Args1, + coq.safe-dest-app ITyTy _ Args2, + rm-db SInd _ RM, + if (Ind = SInd) (R = RM) - (build-Rm-args Args1 Args2 RM RSkel, - coq.elaborate-skeleton RSkel _ R ok). + (build-Rm-args Args1 Args2 RM RSkel, + (@keepunivs! => coq.elaborate-skeleton RSkel _ R ok)). -pred mk-equalities i:list term, i:term, i: list term, o:list term. -mk-equalities [] _ [] []. -mk-equalities [STy| SrcTys] ITyTy [DA|Dargs] [R|RS] :- - param DA A AR, +pred mk-equalities i:list term, i:term, i: list term, i: list term, o:list term. +mk-equalities [] _ [] [] []. +mk-equalities [STy| SrcTys] ITyTy [_|Sargs] [DA|Dargs] [R|RS] :- + paramR A DA AR, build-Rm STy ITyTy RM, coq.mk-app RM [A, DA, AR] R, - mk-equalities SrcTys ITyTy Dargs RS. + mk-equalities SrcTys ITyTy Sargs Dargs RS. % Ksource, Kdest, remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, pred process-args i:term, i:term, i:int, i:int, i:term, i:term, i:list term, i:list term, i:term, o:term. -process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest ITyTy R:- +process-args Ksrc Kdest 0 TyArgsNo _ Goal TySrc TyDest ITyTy R:- coq.mk-app Goal [Ksrc, Kdest, {{ Type }}] EqTy, %discards the relation between Ksrc and Kdest, we want the equality. % todo: change elpi.eq for trocq.idpath - whd EqTy [] {{lib:@elpi.eq}} [ITyTy,MapA,B], - whd MapA [] _ TySrcMappedArgs, + whd EqTy [] {{lib:@trocq.paths }} [ITyTy,MapA,B], + whd MapA [] K TySrcMappedArgs, + coq.env.global (indc _) K, !, whd B [] KDest TyDestArgs, std.drop TyArgsNo TySrcMappedArgs SrcArgs, std.drop TyArgsNo TyDestArgs DestArgs, coq.mk-app KDest {std.take TyArgsNo TyDestArgs} KAppTyArgs, - mk-equalities TySrc ITyTy DestArgs Eqs, - mk-chain SrcArgs DestArgs TyDest KAppTyArgs Eqs ITyTy B R. -process-args Ksrc Kdest N TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal TySrc TyDest ITyTy - (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- + mk-equalities TySrc ITyTy SrcArgs DestArgs Eqs, + mk-chain SrcArgs DestArgs TyDest KAppTyArgs Eqs ITyTy B R. +process-args Ksrc Kdest N TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal TySrc TyDest ITyTy + (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- M is N - 1, @pi-decl AN1 A1Ty a1\ @pi-decl AN2 A2Ty a2\ @pi-decl ARN (ARTy a1 a2) ar\ coq.mk-app Ksrc [a1] (NewKS a1), coq.mk-app Kdest [a2] (NewKD a2), - (param a2 a1 ar =!=> + (paramR a1 a2 ar =!=> process-args (NewKS a1) (NewKD a2) M TyArgsNo (Bo a1 a2 ar) Goal TySrc TyDest ITyTy (R a1 a2 ar)), % if the type of the argument is an instance of the inductive type add an induction hypothesis - whd ITyTy _ Ind _, - whd A2Ty _ IndD _, + cmp-indt A2Ty ITyTy IndD Ind, if (Ind = IndD) (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) (RF = R). -% invariant: all type arguments were already processed. -% Constructor src, Constructor dest, Constructor dest Type, No of Arguments to process, -% constructorR Type, type of i2, something of type : i1 i2 iR => goal. +% invariant: all type arguments were already processed. +% Constructor src, Constructor dest, Constructor dest Type, No of Arguments to process, +% constructorR Type, type of i2, something of type : i1 i2 iR => goal. pred mkBranch i:term, i:term, i:int, i:term, i:term, i:term, o:term. mkBranch KS KD N KTyR ITyTy Goal Eq:- type-of-args KTyR N SrcArgs DestArgs, @@ -80,11 +82,11 @@ mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KTyR|KTyRs] ITyTy Goal [R|Rs] :- mkBranches KsS KsD KTys KTyRs ITyTy Goal Rs. pred implement-Rm i:int, i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, o:term. -% Pred comes with Type parameters applied -% RInd comes with Type parameters applied +% Pred comes with Type parameters applied +% RInd comes with Type parameters applied implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KTyRs Pred RInd (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- - coq.safe-dest-app ITy1 Ind _, + coq.safe-dest-app ITy2 Ind _, coq.env.global (indt GR) Ind, coq.env.recursive? GR, !, RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), @@ -93,13 +95,13 @@ implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 @pi-decl IN1 ITy1 i1\ @pi-decl IN2 ITy2 i2\ @pi-decl ARN (ARTy i1 i2) ar\ - (rm-db Ind f => + (rm-db Ind Ind f => mkBranches KsS KsD KTys KTyRs ITy2 Pred (Brs f)), std.append (Brs f) [i1,i2,ar] (IndArgs f i1 i2 ar), coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). implement-Rm 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) _) KsS KsD KTys KTyRs Pred RInd (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- - coq.mk-app RInd [Pred] RIndP, + coq.mk-app RInd [Pred] RIndP, !, @pi-decl IN1 ITy1 i1\ @pi-decl IN2 ITy2 i2\ @pi-decl ARN (ARTy i1 i2) ar\ @@ -116,7 +118,7 @@ implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 coq.mk-app Pred [a1,a2,ar,am] (NewPred a1 a2 ar am), coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), - coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, + (@keepunivs! => coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok), std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), @@ -126,7 +128,7 @@ implement-Rm N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 coq.env.global {{:gref lib:trocq.map2b.r_in_map }} Rm, coq.mk-app Rm [a1, a2, ar, am] (RMS a1 a2 ar am), ar-db a1 a2 ar ==> - rm-db a1 (RMS a1 a2 ar am) ==> + rm-db a1 a2 (RMS a1 a2 ar am) ==> implement-Rm M TyParamNo (Bo a1 a2 ar am) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar am) (NewRInd a1 a2 ar) (R a1 a2 ar am). @@ -134,29 +136,26 @@ func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ KNs KTys, - Ind = (global (indt GR)), - std.assert! (param Ind Ind TR) "derive.Rm: use derive.param2 before", - % param Ind Ind TR, + coq.env.global (indt GR) Ind, + std.assert! (paramR Ind Ind TR) "derive.Rm: use derive.param2 before", coq.typecheck TR TRTy _, - % mymap-def Ind IndMap, - std.assert! (mymap-def Ind IndMap) "derive.Rm: use derive.mymap before", - mk-mR-type-Rm TyParamNo TRTy IndMap {{ Type }} TR MRTy, - std.assert-ok! (coq.elaborate-skeleton MRTy _ MRTyE) "derive.Rm generates illtyped type", - TR = global (indt GRR), + std.assert! (mymap-def (indt GR) IndMapGR) "derive.Rm: use derive.mymap before", + mk-mR-type-Rm TyParamNo TRTy {coq.env.global IndMapGR} {{ Type }} TR MRTy, + (@keepunivs! => std.assert-ok! (coq.elaborate-skeleton MRTy _ MRTyE) "derive.Rm generates illtyped type"), + coq.env.global (indt GRR) TR, coq.gref->id (indt GRR) Rname, - RInductionName is Rname ^ "_ind", + elim-into-path-suffix Rname Suff, + RInductionName is Rname ^ Suff, coq.locate RInductionName RInd, coq.prod->fun MRTyE Pred, coq.env.indt GRR _ _ _ _ _ KTyRs, - std.map KNs (x\ r\ r = (global (indc x))) Ks, - implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KTyRs Pred (global RInd) R, - % coq.elaborate-skeleton R MRTyE Re ok, - std.assert-ok! (coq.elaborate-skeleton R MRTyE Re) "derive.Rm generates illtyped term", + std.map KNs (x\ r\ r = {coq.env.global (indc x)}) Ks, + implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KTyRs Pred {coq.env.global RInd} R, + std.assert-ok! (coq.elaborate-skeleton R TyE Re) "derive.Rm generates illtyped term", Name is Prefix ^ "Rm", coq.ensure-fresh-global-id Name FName, - coq.env.add-const FName Re MRTyE _ C, - I = global (indt GR), - Clauses = [rm-done GR, rm-db I (global (const C))], + coq.env.add-const FName Re TyE _ C, + Clauses = [rm-done GR, rm-def (indt GR) (const C)], std.forall Clauses (x\ coq.elpi.accumulate _ "derive.Rm.db" (clause _ _ x) ), diff --git a/elpi/inductives/RsymK.elpi b/elpi/inductives/RsymK.elpi index 0c9abd24..2285ce78 100644 --- a/elpi/inductives/RsymK.elpi +++ b/elpi/inductives/RsymK.elpi @@ -18,7 +18,7 @@ implement-rsymK 0 (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ _) Sym SymK LRev (fun IN1 (G i1 i2) = {{ lp:GSym lp:i1 lp:i2 }}, (FGK i1 i2) = {{ lp:SymKSym lp:i2 lp:i1 }}, (R i1 i2) = {{ lib:trocq.exist _ lp:{{ (F i1 i2) }} (lib:trocq.exist _ lp:{{ (G i1 i2) }} lp:{{ (FGK i1 i2) }}) }}. -implement-rsymK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Sym SymK L +implement-rsymK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Sym SymK L (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- M is N - 1, @pi-decl AN1 ATy1 a1\ %A1 : Type @@ -32,7 +32,7 @@ func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ KNs KTys, - Ind = (global (indt GR)), + coq.env.global (indt GR) Ind, std.assert! (param Ind Ind TR) "derive.rsymK: use derive.param2 before", coq.typecheck TR TRTy _, mk-mR-type-rsymK TyParamNo TRTy TR {{ fun (A B : Type) => A <->> B }} SymKTy, @@ -44,8 +44,7 @@ main GR Prefix Clauses :- std.do! [ Name is Prefix ^ "rsymK", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName Re SymKTyE _ C, - I = global (indt GR), - Clauses = [rsymK-done GR, rsymK-db I (global (const C))], + Clauses = [rsymK-done GR, rsymK-def (indt GR) (const C)], std.forall Clauses (x\ coq.elpi.accumulate _ "derive.rsymK.db" (clause _ _ x) ), diff --git a/elpi/inductives/common_algo.elpi b/elpi/inductives/common_algo.elpi index de807054..829dbcf3 100644 --- a/elpi/inductives/common_algo.elpi +++ b/elpi/inductives/common_algo.elpi @@ -66,7 +66,7 @@ clean-l [A1, A2, AR, _ | L2] [A1,A2,AR | R] :- % Returns the type of map in R for T % Does it add an extra hyp on the relation? % X is the first inductive, Y is the second inductive. -pred mk-mR-type-priv i:int, i:term, i:term, i:term, i:term, i:int, i:list term, i: (pred i:term, o:term), i: (pred i:term, o:term), i:param-surgery, o:term. +pred mk-mR-type-priv i:int, i:term, i:term, i:term, i:term, i:int, i:list term, i: term, i: term, i:param-surgery, o:term. % Introducing X and Y. % The RHS of the equality is Y. mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ _ @@ -81,7 +81,7 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) ML _ Rel Swap LRev _ _ _ clean-l L CL, coq.mk-app Rel {std.append CL [x,y]} NewRel, mk-return NewML NewMR NewRel Swap ITyTy2 (R x y). -mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 4 LRev MR-DB RM-DB _ +mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 4 LRev MR RM _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ prod `IR` (RelTy x y) iR\ (R x y iR)) :- std.rev LRev L, @pi-decl IN1 ITyTy x\ @@ -90,11 +90,9 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 4 LRev MR-DB RM- coq.mk-app Rel {std.append CL [x,y]} (RelTy x y), @pi-decl `IR` (RelTy x y) iR\ % sigma NewML NewMR NewRel L\ - whd ITyTy2 [] Ind _, - RM-DB Ind RInMap, - coq.mk-app RInMap {std.append L [x,y,iR]} (Rm x y iR), - MR-DB Ind MapInR, - coq.mk-app MapInR {std.append L [x,y,(Rm x y iR)]} (MRRM x y iR), + % whd ITyTy2 [] _ _, + coq.mk-app RM {std.append L [x,y,iR]} (Rm x y iR), + coq.mk-app MR {std.append L [x,y,(Rm x y iR)]} (MRRM x y iR), (R x y iR) = {{ lib:@trocq.paths _ lp:{{MRRM x y iR}} lp:iR }}. mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) _ _ Rel 5 LRev _ _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ (R x y)) :- @@ -119,7 +117,6 @@ mk-mR-type-priv 0 (prod _ ITyTy x\ prod _ ITyTy2 _) _ RelSTy _ 8 _ _ _ _ R :- rel-mode 8 ARSkel, coq.subst-prod [ITyTy, ITyTy2, RelSTy] ARSkel R. -% TODO: remove use of MR-DB, try just pass the MR and RM mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) SymC _ Rel 6 LRev _ _ _ (prod IN1 ITyTy x\ prod IN2 ITyTy2 y\ prod `IR` (RelTy x y) iR\ (R x y iR)) :- std.rev LRev L, @@ -135,7 +132,7 @@ mk-mR-type-priv 0 (prod IN1 ITyTy x\ prod IN2 ITyTy2 _) SymC _ Rel 6 LRev _ _ _ % Process two type parameters + 1 relation at a time. % Apply these parameters to the LHS of the equation. % This branch deals with adding the additional hypothesis in case the input boolean is set. -mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB refine +mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR RM refine (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ prod NM (MTy a1 a2 ar) am\ (Rest a1 a2 ar am)) :- M is N - 1, rel-mode Swap ARSkel, @@ -143,18 +140,18 @@ mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ pi a1 a2 ar am\ sigma NewL\ std.append [am,ar,a2,a1] L NewL, - mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR-DB RM-DB refine (R a1 a2 ar am), + mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR RM refine (R a1 a2 ar am), coq.subst-prod [a1, a2, ar] ARSkel (prod _ (MTy a1 a2 ar) _), coq.subst-prod [a1, a2, ar, am, (R a1 a2 ar am)] ARSkel (Rest a1 a2 ar am). % This branch deals with the branch when the boolean is unset. -mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR-DB RM-DB raw +mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) ML _ Rel Swap L MR RM raw (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- M is N - 1, pi a1 a2 ar\ sigma NewL\ std.append [ar,a2,a1] L NewL, - mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR-DB RM-DB raw (R a1 a2 ar). -mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML RelSTy Rel Swap L MR-DB RM-DB subst + mk-mR-type-priv M (Bo a1 a2 ar) ML {{ Type }} Rel Swap NewL MR RM raw (R a1 a2 ar). +mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 ar)) ML RelSTy Rel Swap L MR RM subst (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (NewARTy a1 a2) ar\ (R a1 a2 ar)) :- M is N - 1, rel-mode Swap ARSkel, @@ -162,7 +159,7 @@ mk-mR-type-priv N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN _ ar\ (Bo a1 a2 sigma NewL\ std.append [ar,a2,a1] L NewL, coq.subst-prod [a1, a2, RelSTy] ARSkel (NewARTy a1 a2), - mk-mR-type-priv M (Bo a1 a2 ar) ML RelSTy Rel Swap NewL MR-DB RM-DB subst (R a1 a2 ar). + mk-mR-type-priv M (Bo a1 a2 ar) ML RelSTy Rel Swap NewL MR RM subst (R a1 a2 ar). pred mk-mR-type-mR i:int, i:term, i:term, i:term, i:term, o:term. mk-mR-type-mR N T ML MR Rel RTy :- @@ -172,9 +169,9 @@ pred mk-mR-type-Rm i:int, i:term, i:term, i:term, i:term, o:term. mk-mR-type-Rm N T ML MR Rel R :- mk-mR-type-priv N T ML MR Rel 2 [] _ _ refine R. -pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:(pred i:term, o:term) , i: (pred i:term, o:term), o:term. -mk-mR-type-mRRmK N T ML Rel MR-DB RM-DB R :- - mk-mR-type-priv N T ML _ Rel 4 [] MR-DB RM-DB refine R. +pred mk-mR-type-mRRmK i:int, i:term, i:term, i:term, i:term, i: term, o:term. +mk-mR-type-mRRmK N T ML Rel MR RM R :- + mk-mR-type-priv N T ML _ Rel 4 [] MR RM refine R. pred mk-mR-type-sym i:int, i:term, i:term, o:term. mk-mR-type-sym N T Rel R :- diff --git a/elpi/inductives/injK.elpi b/elpi/inductives/injK.elpi index 78611b30..1467d68b 100644 --- a/elpi/inductives/injK.elpi +++ b/elpi/inductives/injK.elpi @@ -4,14 +4,14 @@ namespace derive.injK { pred add-equalities i:int, i:int, i:term, o:term. add-equalities 0 0 T T. -add-equalities 0 M (prod AN1 ATy a1\ prod AN2 ATy a2\ (Bo a1 a2)) +add-equalities 0 M (prod AN1 ATy a1\ prod AN2 ATy a2\ (Bo a1 a2)) (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (EqTy a1 a2) e\ (R a1 a2)) :- O is M - 1, name-prefix AN1 "p_" EN, pi a1 a2\ - coq.mk-app {{lib:@elpi.eq}} [ATy, a1, a2] (EqTy a1 a2), + coq.mk-app {{lib:@trocq.paths}} [ATy, a1, a2] (EqTy a1 a2), add-equalities 0 O (Bo a1 a2) (R a1 a2). -add-equalities N M (prod AN1 ATy a1\ (Bo a1)) +add-equalities N M (prod AN1 ATy a1\ (Bo a1)) (prod AN1 ATy a1\ (R a1)) :- O is N - 1, pi a1\ @@ -19,14 +19,14 @@ add-equalities N M (prod AN1 ATy a1\ (Bo a1)) pred get-injectors i:list term, i: list int, o: list (list term), o:list (list int). get-injectors [] [] [] []. -get-injectors [K|Ks] [ArgNo|ArgNos] [R|RS] [Tmp|Tmps]:- +get-injectors [K|Ks] [ArgNo|ArgNos] [R|RS] [Tmp|Tmps]:- std.iota ArgNo Tmp, std.map Tmp (x\r\ sigma Add1\ Add1 is x + 1, r = Add1) Add1, std.map Add1 (x\r\ sigma R\ injections-db K x R, r = R) R, get-injectors Ks ArgNos RS Tmps. % TyParam, ArgNo, type of duplicated args + eq, injector, dest path no, RHS path (dflt dummy). -% +% pred add-concl i:int, i:int, i:int, i:term, i:term, i:int, i:term, i:term, i:list term, i:list term, i: list term, o:term. add-concl 0 ArgNo ArgNo _ Injtor _ RHS K SrcArgs_R DestArgs_R Eqs_R R :- % M > ArgNo, @@ -37,11 +37,11 @@ add-concl 0 ArgNo ArgNo _ Injtor _ RHS K SrcArgs_R DestArgs_R Eqs_R R :- std.map DestArgs (x\r\ sigma R\ coq.typecheck x R ok, r = R) DestArgsTy, coq.mk-app K DestArgs Ind, coq.typecheck Ind ITyTy ok, - mk-chain SrcArgs DestArgs DestArgsTy K Eqs ITyTy Ind Chain, + mk-chain SrcArgs DestArgs DestArgsTy K Eqs ITyTy Ind Chain, coq.mk-app Injtor [Chain] LHS, - coq.mk-app {{lib:@elpi.eq}} [{{ _ }}, LHS, RHS] RSkel, - coq.elaborate-skeleton RSkel _ R ok. -add-concl 0 M ArgNo (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (ETy a1 a2) e\ (Bo a1 a2 e)) Injtor DestPathNo RHS K SrcArgs DestArgs Eqs + coq.mk-app {{lib:@trocq.paths}} [{{ _ }}, LHS, RHS] RSkel, + @keepunivs! => coq.elaborate-skeleton RSkel _ R ok. +add-concl 0 M ArgNo (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (ETy a1 a2) e\ (Bo a1 a2 e)) Injtor DestPathNo RHS K SrcArgs DestArgs Eqs (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (ETy a1 a2) e\ (R a1 a2 e)) :- !, O is M + 1, @@ -54,7 +54,7 @@ add-concl 0 M ArgNo (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (ETy a1 a2) e\ (B ((NewRHS e) = RHS), add-concl 0 O ArgNo (Bo a1 a2 e) (NewInjtor a1 a2) DestPathNo (NewRHS e) K [a1 | SrcArgs] [a2| DestArgs] [e | Eqs] (R a1 a2 e). -add-concl N 0 ArgNo (prod AN1 ATy a1\ (Bo a1)) Injtor DestPathNo RHS K SrcArgs DestArgs Eqs +add-concl N 0 ArgNo (prod AN1 ATy a1\ (Bo a1)) Injtor DestPathNo RHS K SrcArgs DestArgs Eqs (prod AN1 ATy a1\ (R a1)) :- M is N - 1, @pi-decl AN1 ATy a1\ @@ -67,21 +67,21 @@ add-concl N 0 ArgNo (prod AN1 ATy a1\ (Bo a1)) Injtor DestPathNo RHS K SrcArgs D pred add-conclss i:list term, i:list term, i:int, i:list int, i:list (list term), i:list (list int), o: list (list term). add-conclss [] [] _ [] [] [] []. add-conclss [PTy|PTys] [K|Ks] TyParamNo [ArgNo|ArgNos] [Injs|Injss] [DestNos|DestNoss] [InjTys|InjTyss] :- - std.map2 Injs DestNos (x\y\r\ sigma R\ add-concl TyParamNo 0 ArgNo PTy x y {{Type}} K [] [] [] R, r = R) InjTys, + std.map2 Injs DestNos (x\y\r\ sigma R\ add-concl TyParamNo 0 ArgNo PTy x y {{Type}} K [] [] [] R, r = R) InjTys, add-conclss PTys Ks TyParamNo ArgNos Injss DestNoss InjTyss. %TyParamNo, constructors, type of constructors, output. -% for every constructor, +% for every constructor, % collects its injectors and build the corresponding type for every injector pred mk-injK-types i:int, i: list constructor, i:list term, o:list (list term), o:list int, o:list (list int). mk-injK-types TyParamNo KNs KTys InjTyss ArgNos DestNoss :- std.map KTys (x\ r\ sigma R\ count-args TyParamNo x R, r = R) ArgNos, - std.map2 KTys ArgNos - (x\ y\ r\ sigma ArgNo R1 R2\ + std.map2 KTys ArgNos + (x\ y\ r\ sigma ArgNo R1 R2\ duplicate-arguments TyParamNo y x R1, add-equalities TyParamNo y R1 R2, r = R2) PTy, - std.map KNs (x\ r\ r = global (indc x)) Ks, + std.map KNs (x\ r\ r = {coq.env.global (indc x)}) Ks, get-injectors Ks ArgNos Injss DestNoss, add-conclss PTy Ks TyParamNo ArgNos Injss DestNoss InjTyss. @@ -107,15 +107,16 @@ mk-pred Curr I ArgNo Pred T P [A1|Args1] [A2|Args2] [_A2Ty|TyArgs2] [Path|Paths] pred mk-preds i:int, i:int, i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, o:list term. mk-preds _ _ [] _ _ _ _ _ []. -mk-preds I ArgNo [P|Preds] Args1 Args2 TyArgs2 Paths TyPaths [ fun `t` Ty t\ fun `p` (PatTy t) p\ (R t p) | RS ] :- +mk-preds I ArgNo [P|Preds] Args1 Args2 TyArgs2 Paths TyPaths [ RP | RS ] :- J is I + 1, - std.nth I TyArgs2 Ty, std.nth I TyPaths PTy, - whd PTy [] {{lib:@elpi.eq}} [T,A,_], - @pi-decl `t` Ty t\ - coq.mk-app {{lib:@elpi.eq}} [T,A,t] (PatTy t), + whd PTy [] {{lib:@trocq.paths}} [T,A,_], + @pi-decl `t` T t\ + coq.mk-app {{lib:@trocq.paths}} [T,A,t] (PatTy t), @pi-decl `p` (PatTy t) p\ mk-pred 0 I ArgNo P t p Args1 Args2 TyArgs2 Paths TyPaths (R t p), + RPSkel = (fun `t` T t\ fun `p` (PatTy t) p\ (R t p)), + (@keepunivs! => coq.elaborate-skeleton RPSkel _ RP ok), mk-preds J ArgNo Preds Args1 Args2 TyArgs2 Paths TyPaths RS. pred iter-convs i:list term, i:list term, i:list term, i:list term, i:list term, i:term, o:term. @@ -127,7 +128,7 @@ iter-convs [Ty|Tys] [A1|Args1] [A2|Args2] [Path|Paths] [Pred|Preds] End R :- pred implement-injK i:int, i:int, i:int, i:int, i:term, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, o:term. -implement-injK 0 0 ArgNo DestNo _ Pred TyParamsR Args1R Args2R TyArgs2R PathsR TyPathsR R :- +implement-injK 0 0 ArgNo DestNo _ Pred TyParamsR Args1R Args2R TyArgs2R PathsR TyPathsR R :- !, std.rev TyParamsR TyParams, std.rev Args1R Args1, std.rev Args2R Args2, @@ -135,21 +136,21 @@ implement-injK 0 0 ArgNo DestNo _ Pred TyParamsR Args1R Args2R TyArgs2R PathsR T std.rev PathsR Paths, std.rev TyPathsR TyPaths, coq.mk-app Pred TyParams PredT, - std.iota ArgNo Tmp, + std.iota ArgNo Tmp, std.map Tmp (x\r\ r = PredT) Preds, mk-preds 0 ArgNo Preds Args1 Args2 TyArgs2 Paths TyPaths RPreds, std.nth DestNo Args1 A1, std.nth DestNo TyArgs2 Ty, EndArg = {{ lib:@trocq.idpath lp:Ty lp:A1}}, - coq.typecheck EndArg EndTy ok, - End = {{ lib:@trocq.idpath lp:EndTy lp:EndArg}}, + (@keepunivs! => coq.typecheck EndArg EndTy ok), + End = {{ lib:@trocq.idpath lp:EndTy lp:EndArg}}, iter-convs TyArgs2 Args1 Args2 Paths RPreds End RSkel, - coq.elaborate-skeleton RSkel _ R ok. + (@keepunivs! => coq.elaborate-skeleton RSkel _ R ok). % build the stuff. % reverse args -implement-injK 0 N ArgNo DestNo (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (EqTy a1 a2) e\ (Bo a1 a2 e)) +implement-injK 0 N ArgNo DestNo (prod AN1 ATy a1\ prod AN2 ATy a2\ prod EN (EqTy a1 a2) e\ (Bo a1 a2 e)) Pred TyParams Args1 Args2 TyArgs2 Paths TyPaths (fun AN1 ATy a1\ fun AN2 ATy a2\ fun EN (EqTy a1 a2) e\ (R a1 a2 e)) :- M is N - 1, @pi-decl AN1 ATy a1\ @@ -167,7 +168,8 @@ pred implement-injKs i:int, i:constructor, i:int, i:list term, i:list int, o:lis implement-injKs _ _ _ [] [] []. implement-injKs TyParamNo _ ArgNo [InjKTy|InjKTys] [DestNo | DestNos] [R| RS] :- coq.prod->fun InjKTy Pred, - implement-injK TyParamNo ArgNo ArgNo DestNo InjKTy Pred [] [] [] [] [] [] R, + implement-injK TyParamNo ArgNo ArgNo DestNo InjKTy Pred [] [] [] [] [] [] RSkel, + coq.elaborate-skeleton RSkel _ R ok, implement-injKs TyParamNo _ ArgNo InjKTys DestNos RS. % todo rm constructors as arg @@ -177,38 +179,30 @@ implement-injK-types TyParamNo [Kn|KNs] [ArgNo|ArgNos] [InjKTys|InjKTyss] [DestN implement-injKs TyParamNo Kn ArgNo InjKTys DestNos R, implement-injK-types TyParamNo KNs ArgNos InjKTyss DestNoss RS. +register-db.aux K J C R :- + coq.env.global (indc K) Tm, + R = (injectionsK-db Tm J (global (const C))). +register-def.aux K J C R :- + coq.env.global (indc K) _, + R = (injectionsK-def (indc K) J (const C)). +register.aux K J C [R1,R2] :- + register-db.aux K J C R1, + register-def.aux K J C R2. func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ - + Name is Prefix ^ "injK", coq.ensure-fresh-global-id Name FName, coq.env.indt GR _ TyParamNo _ _ KNs KTys, - % Ind = (global (indt GR)), - mk-injK-types TyParamNo KNs KTys RTys ArgNos DestNos, - Register = (k\j\c\ (injectionsK-db (global (indc k)) j (global (const c)))), + mk-injK-types TyParamNo KNs KTys RTys ArgNos DestNos, implement-injK-types TyParamNo KNs ArgNos RTys DestNos RS, - name-ijs FName 1 GR KNs RS Register Clausess, + name-ijs FName 1 GR KNs RS register.aux Clausess, std.flatten Clausess Clauses, ClausesFin = [injectionsK-done GR | Clauses], std.forall ClausesFin (x\ coq.elpi.accumulate _ "derive.injectionsK.db" (clause _ _ x) ), - % coq.elaborate-skeleton MRTy _ MRTyE ok, - % TR = global (indt GRR), - % coq.gref->id (indt GRR) Rname, - % RInductionName is Rname ^ "_ind", - % coq.locate RInductionName RInd, - % coq.prod->fun MRTyE Pred, - % coq.env.indt GRR _ _ _ _ KNRs KTyRs, - % std.map KNs (x\ r\ r = (global (indc x))) Ks, - % std.map KNRs (x\ r\ r = (global (indc x))) KRs, - % implement-Rm TyParamNo TyParamNo MRTyE Ks Ks KTys KRs KTyRs Pred (global RInd) R, - % coq.elaborate-skeleton R MRTyE Re ok, - % Name is Prefix ^ "Rm", - % coq.ensure-fresh-global-id Name FName, - % coq.env.add-const FName Re MRTyE _ C, - % I = global (indt GR), ]. } \ No newline at end of file diff --git a/elpi/inductives/injection_lemmas.elpi b/elpi/inductives/injection_lemmas.elpi index fd4d6a12..4a14db08 100644 --- a/elpi/inductives/injection_lemmas.elpi +++ b/elpi/inductives/injection_lemmas.elpi @@ -2,18 +2,18 @@ shorten derive.algo-utils.{duplicate-arguments, count-args, name-ijs, for-K-get- namespace derive.injections { -/* for all projectors of type forall Args T, ret +/* for all projectors of type forall Args T, ret generate forall Args1-> Args2-> (e : Kj args->1 = Kj args->2) argj -Take an inductive Ind, +Take an inductive Ind, take its constructors global references, for each global reference GRK, Compute the number of arguments J for each GRK, -for each ArgNumber in 1 to J+1, -get the Projector GRK ArgNumber, -Get the type ProjType, forall ArgTys Args Ind, ret +for each ArgNumber in 1 to J+1, +get the Projector GRK ArgNumber, +Get the type ProjType, forall ArgTys Args Ind, ret Return the processed Types */ % TyParam, ArgNo, F, Type of the equality, Left HS, Right HS @@ -21,10 +21,9 @@ Return the processed Types */ % Ret is discarded and replaced by Left = Right pred craft-eq i:int, i:int, i:int, i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, o:term. craft-eq 0 0 _ _ _ EqTy Left Right ConclEqTy ConclL ConclR R:- !, - %todo use trocq.idpath - coq.mk-app {{lib:@elpi.eq}} [EqTy, Left, Right] AETy, - coq.mk-app {{lib:@elpi.eq}} [ConclEqTy, ConclL, ConclR] C, - R = {{ forall (e : lp:AETy), lp:C }}. + coq.mk-app {{lib:@trocq.paths}} [EqTy, Left, Right] AETy, + coq.mk-app {{lib:@trocq.paths}} [ConclEqTy, ConclL, ConclR] C, + R = {{ forall (e : lp:AETy), lp:C }}. craft-eq 0 ArgNo J Max (prod N1 T x\ prod N2 T y\ (Bo x y)) EqTy Left Right ConclEq ConclL ConclR (prod N1 T x\ prod N2 T y\ (S x y)) :- !, M is ArgNo - 1, @@ -33,10 +32,10 @@ craft-eq 0 ArgNo J Max (prod N1 T x\ prod N2 T y\ (Bo x y)) EqTy Left Right Conc @pi-decl N2 T y\ sigma NewLeft NewRight NewConclEq NewConclL NewConclR\ (if (J? = J) - (NewConclEq = T, + (NewConclEq = T, NewConclL = x, NewConclR = y) - (NewConclEq = ConclEq, + (NewConclEq = ConclEq, NewConclL = ConclL, NewConclR = ConclR)), coq.mk-app Left [x] NewLeft, @@ -45,7 +44,7 @@ craft-eq 0 ArgNo J Max (prod N1 T x\ prod N2 T y\ (Bo x y)) EqTy Left Right Conc craft-eq TyParam ArgNo J Max (prod N T Bo) EqTy Left Right CE CL CR (prod N T x\ S x) :- !, M is TyParam - 1, - @pi-decl N T x\ + @pi-decl N T x\ sigma NewEqTy NewLeft NewRight\ coq.mk-app EqTy [x] NewEqTy, coq.mk-app Left [x] NewLeft, @@ -57,13 +56,13 @@ build-type-K-injector _ _ _ _ _ _ [] [] :- !. build-type-K-injector TyParamNo J GR Kn ArgNo KTy [PJ|PJs] [Eq|RS] :- std.do! [ Jn is J + 1, duplicate-arguments TyParamNo ArgNo PJ S, - (craft-eq TyParamNo ArgNo J ArgNo S (global (indt GR)) (global (indc Kn)) (global (indc Kn)) {{tt}} {{tt}} {{tt}} Eq), - coq.typecheck Eq _ ok, + (craft-eq TyParamNo ArgNo J ArgNo S {coq.env.global (indt GR)} {coq.env.global (indc Kn)} {coq.env.global (indc Kn)} {{tt}} {{tt}} {{tt}} Eq), + (@keepunivs! => coq.typecheck Eq _ ok), build-type-K-injector TyParamNo Jn GR Kn ArgNo KTy PJs RS]. pred build-types-injectors i:int, i: inductive, i:list constructor, i: list int, i:list (term), i:list (list term), o:list (list term). build-types-injectors _ _ [] [] [] [] [] :- !. -build-types-injectors TyParamNo GR [Kn|KNs] [ArgNo|ArgsNos] [KTy|KTys] [PJs|PJss] [R|RS] :- +build-types-injectors TyParamNo GR [Kn|KNs] [ArgNo|ArgsNos] [KTy|KTys] [PJs|PJss] [R|RS] :- build-type-K-injector TyParamNo 1 GR Kn ArgNo KTy PJs R, build-types-injectors TyParamNo GR KNs ArgsNos KTys PJss RS. @@ -76,23 +75,23 @@ implement-K-injector-J 0 J 0 TyParam (prod E Ty _) R :- !, ltac.injection? Ty GR TyArgs GRK KArgs A B, ltac.injection.arg-i I J {{lib:@trocq.ap }} GR TyArgs TyParam GRK KArgs A B e [(PL e)]. -implement-K-injector-J 0 J ArgNo TyParam (prod ArgN1 ArgTy a\ (prod ArgN2 ArgTy b\ (Bo a b))) (fun ArgN1 ArgTy a\ fun ArgN2 ArgTy b\ (R a b) ) :- !, +implement-K-injector-J 0 J ArgNo TyParam (prod ArgN1 ArgTy1 a\ (prod ArgN2 ArgTy2 b\ (Bo a b))) (fun ArgN1 ArgTy1 a\ fun ArgN2 ArgTy2 b\ (R a b) ) :- !, ArgNon is ArgNo - 1, - @pi-decl ArgN1 ArgTy a\ - @pi-decl ArgN2 ArgTy b\ + @pi-decl ArgN1 ArgTy1 a\ + @pi-decl ArgN2 ArgTy2 b\ implement-K-injector-J 0 J ArgNon TyParam (Bo a b) (R a b). -implement-K-injector-J ParamNo J ArgNo TyParam (prod TyArg T t\ (Bo t)) (fun TyArg T t\ (R t) ) :- !, +implement-K-injector-J ParamNo J ArgNo TyParam (prod TyArg T t\ (Bo t)) (fun TyArg T t\ (R t) ) :- ParamNon is ParamNo - 1, @pi-decl TyArg T t\ implement-K-injector-J ParamNon J ArgNo TyParam (Bo t) (R t). - + pred implement-K-injectors i:int, i:int, i:int, i:list term, o:list term. implement-K-injectors _ _ _ [] []. implement-K-injectors TyParam J ArgNo [InjTy | InjTys] [R | RS] :- Jn is J + 1, - (implement-K-injector-J TyParam J ArgNo TyParam InjTy R), - coq.typecheck R InjTy ok, + (implement-K-injector-J TyParam J ArgNo TyParam InjTy RSkel), + (@keepunivs! => coq.elaborate-skeleton RSkel _ R ok), implement-K-injectors TyParam Jn ArgNo InjTys RS. pred implement-injectors i:int, i:list int, i:list (list term), o:list (list term). @@ -105,17 +104,22 @@ pred for-K-get-projectors i:int, i:list constructor, i:list term, o: list int, o for-K-get-projectors TyParamNo KNs KTys ArgsNos PJss :- for-K-get-KI TyParamNo KNs KTys (grk\ i\ p\ projK-db grk i p) ArgsNos PJss. +register-def.aux K J C R :- + coq.env.global (indc K) _, + R = (injections-def (indc K) J (const C)). +register.aux K J C [R1] :- + register-def.aux K J C R1. + func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ Name is Prefix ^ "injections", coq.ensure-fresh-global-id Name FName, coq.env.indt GR _ TyParamNo _ _ KNs KTys, for-K-get-projectors TyParamNo KNs KTys ArgsNos PJss, - std.map PJss (x\ r\ sigma R\ (std.map x (y\ r\ sigma Ty\ coq.typecheck y Ty _, r = Ty) R), r = R) PJTyss, + std.map PJss (x\ r\ sigma R\ (std.map x (y\ r\ sigma Ty\ (@keepunivs! => coq.typecheck y Ty ok), r = Ty) R), r = R) PJTyss, build-types-injectors TyParamNo GR KNs ArgsNos KTys PJTyss InjTyss, implement-injectors TyParamNo ArgsNos InjTyss Injss, - Register = (k\j\c\ (injections-db (global (indc k)) j (global (const c)))), - name-ijs FName 1 GR KNs Injss Register Clausess, + name-ijs FName 1 GR KNs Injss register.aux Clausess, std.flatten Clausess Clauses, ClausesFin = [injections-done GR | Clauses], %[injections-done GR, injections GR (const C)], std.forall ClausesFin (x\ diff --git a/elpi/inductives/mR.elpi b/elpi/inductives/mR.elpi index 66a741ba..1b2cf01f 100644 --- a/elpi/inductives/mR.elpi +++ b/elpi/inductives/mR.elpi @@ -1,11 +1,12 @@ shorten derive.common-algo.{mk-mR-type-mR}. +shorten derive.algo-utils.{cmp-indt}. namespace derive.mR { % Given Y and Bo: x\ y\ RT. The return type of the match on X is: substituting the binder of X in the match. pred rty-1 i:(term -> term -> term), i:term , i:term, i: list term, i: list term, o:term. -rty-1 Bo Y _ Ts _ R :- +rty-1 Bo Y _ Ts _ R :- std.last Ts X, R = Bo X Y. @@ -15,9 +16,9 @@ rty-2 Bo X _ Ts _ R :- std.last Ts Y, R = Bo X Y. -pred sub-branch i:int, i: term, i:list term, i:list term, i:term, i:list term, i:list term, +pred sub-branch i:term, i:int, i: term, i:list term, i:list term, i:term, i:list term, i:list term, i:(term -> term -> term), o:term. -sub-branch TyParamNo K1 Args1 ArgTys1 K2 Args2 ArgTys2 Bo (fun `e` ETy e\ (R e)):- +sub-branch YTy TyParamNo K1 Args1 ArgTys1 K2 Args2 ArgTys2 Bo (fun `e` ETy e\ (R e)):- coq.mk-app K1 Args1 X, coq.mk-app K2 Args2 Y, BoXY = Bo X Y, @@ -26,43 +27,44 @@ sub-branch TyParamNo K1 Args1 ArgTys1 K2 Args2 ArgTys2 Bo (fun `e` ETy e\ (R e)) whd K1 [] Constr1 TypeArgs1, whd K2 [] Constr2 TypeArgs2, @pi-decl `e` ETy e\ - matrix TyParamNo Constr1 TypeArgs1 Args1 ArgTys1 Constr2 TypeArgs2 Args2 ArgTys2 e ETy (G e) (R e). + matrix YTy TyParamNo Constr1 TypeArgs1 Args1 ArgTys1 Constr2 TypeArgs2 Args2 ArgTys2 e ETy (G e) (R e). % Each branch matches on Y as Y0, returning a term of type (Bo (K KArgs) Y0) given by matrix. pred mkBranch i:int, i:(term -> term -> term), i:term, i:term, i:term, i:term, i:list term, i:list term, o:term. mkBranch TyParamNo Bo Y YTy K _ Ts TYs R :- coq.mk-app K Ts X, - coq.build-match Y YTy (rty-2 Bo X) - (k2\ _\ ts\ tys\ - sub-branch TyParamNo K Ts TYs k2 ts tys Bo) + coq.build-match Y YTy (rty-2 Bo X) + (k2\ _\ ts\ tys\ + sub-branch YTy TyParamNo K Ts TYs k2 ts tys Bo) R. pred build-mRA-ty-args i:list term, i:list term, i:term, o:term. build-mRA-ty-args [] [] R R. build-mRA-ty-args [ATy1| ArgsTy1] [ATy2| ArgsTy2] MR R :- ar-db ATy1 ATy2 AR, - coq.mk-app MR [ATy1, ATy2, AR] NewMR, + coq.mk-app MR [ATy1, ATy2, AR] NewMR, build-mRA-ty-args ArgsTy1 ArgsTy2 NewMR R. % TODO update: this considers that type arguments come in Ts, they don't come in there. -pred build-mRA i:term, i:term, i:term, o:term. -build-mRA ATy1 ATy2 Ind R :- - whd ATy1 [] ITy ArgsTy1, - whd ATy2 [] _ ArgsTy2, - coq.typecheck Ind IndTy _, - mR-db ITy MR, +pred build-mRA i:term, i:term, i:term, i:term, o:term. +build-mRA IndTy ATy1 ATy2 _ R :- + cmp-indt ATy1 IndTy IndS Ind, + cmp-indt ATy2 IndTy IndD Ind, + coq.safe-dest-app ATy1 _ ArgsTy1, + coq.safe-dest-app ATy2 _ ArgsTy2, + mR-db IndS IndD MR, % TODO: change following line to implement non uniform parameters + definition of the fix. - if (ATy1 = IndTy) + if (IndS = Ind) (R = MR) (build-mRA-ty-args ArgsTy1 ArgsTy2 MR R). -pred build-injEKJ-args i:int, i:list term, i:list term, +pred build-injEKJ-args i:int, i:list term, i:list term, i:term, i:term, o:term. % applies TyParamNo time the Type parameter of the return Inductive. -build-injEKJ-args 0 Args1 Args2 InjKJ E R :- - app-interleave InjKJ Args1 Args2 InjKJArgs, +build-injEKJ-args 0 Args1 Args2 InjKJ E R :- + app-interleave InjKJ Args1 Args2 InjKJArgs, coq.mk-app InjKJArgs [E] R. -build-injEKJ-args N [_ | ATys1] [ATy2|ATys2] InjKJ E R :- +build-injEKJ-args N [_ | ATys1] [ATy2|ATys2] InjKJ E R :- M is N - 1, coq.mk-app InjKJ [ATy2] InjKJA, build-injEKJ-args M ATys1 ATys2 InjKJA E R. @@ -76,68 +78,74 @@ app-interleave F [A|Args1] [B|Args2] R :- pred build-injEKJ i:int, i:term, i:term, i:term, i:int o: term. build-injEKJ TyParamNo E ETy K J R :- injections-db K J InjKJ, - whd ETy [] {{lib:@elpi.eq}} [_,A,B], - whd A [] (global (indc _)) ArgsL, - whd B [] (global (indc _)) ArgsR, + whd ETy [] {{lib:@trocq.paths}} [_,A,B], + whd A [] KA ArgsL, + whd B [] KB ArgsR, + coq.env.global (indc _) KA, + coq.env.global (indc _) KB, build-injEKJ-args TyParamNo ArgsL ArgsR InjKJ E InjEKJ, coq.elaborate-skeleton InjEKJ _ R _. % TODO: for processing params extend with an int of param no + db Type Type AR. % TODO: for processing contained types, lookup mR-db apply arg1 arg2 + the ith constructor injection of the equality. -pred apply-indR i:int, i:int, i:term, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term, i:term, i:int, o: term. +pred apply-indR i:term, i:int, i:int, i:term, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term, i:term, i:int, o: term. % N J K KR K1Args K1Tys K2Args K2Tys X Y E TyParamNo -apply-indR 0 _ _ KR [] [] [] [] [] [] _ _ _ _ _ KR. +apply-indR _ 0 _ _ KR [] [] [] [] [] [] _ _ _ _ _ KR. % for the jth argument provide A1 A2 AR12 % For AR12 we bring mR_ATy ATyArgs1 ATyArgs2 ARs % For the equality we bring injectionKJ TyArgs2 (Args1 of the eq) (Args2 of the eq) -apply-indR 0 J K KR [] [A1|Args1] [ATy1|ArgTys1] [] [A2|Args2] [ATy2| ArgTys2] LHS RHS E ETy TyParamNo R :- +apply-indR YTy 0 J K KR [] [A1|Args1] [ATy1|ArgTys1] [] [A2|Args2] [ATy2| ArgTys2] LHS RHS E ETy TyParamNo R :- Jn is J + 1, - build-mRA ATy1 ATy2 LHS MRA, + build-mRA YTy ATy1 ATy2 LHS MRA, build-injEKJ TyParamNo E ETy K J InjEKJ, - coq.mk-app MRA [A1,A2,InjEKJ] A12R, + coq.mk-app MRA [A1,A2,InjEKJ] A12R, coq.mk-app KR [A1,A2, A12R] KA12AR, - apply-indR 0 Jn K KA12AR [] Args1 ArgTys1 [] Args2 ArgTys2 LHS RHS E ETy TyParamNo R. -apply-indR N J K KR [Ty1|TyArgs1] Args1 ArgTys1 [Ty2|TyArgs2] Args2 ArgTys2 LHS RHS E ETy TyParamNo R :- + apply-indR YTy 0 Jn K KA12AR [] Args1 ArgTys1 [] Args2 ArgTys2 LHS RHS E ETy TyParamNo R. +apply-indR YTy N J K KR [Ty1|TyArgs1] Args1 ArgTys1 [Ty2|TyArgs2] Args2 ArgTys2 LHS RHS E ETy TyParamNo R :- M is N - 1, ar-db Ty1 Ty2 AR, coq.mk-app KR [Ty1, Ty2, AR] NewKR, - apply-indR M J K NewKR TyArgs1 Args1 ArgTys1 TyArgs2 Args2 ArgTys2 LHS RHS E ETy TyParamNo R. + apply-indR YTy M J K NewKR TyArgs1 Args1 ArgTys1 TyArgs2 Args2 ArgTys2 LHS RHS E ETy TyParamNo R. -% On the diagonal return KR a1 a2 ... +% On the diagonal return KR a1 a2 ... % Outside the diagonal discriminate -pred matrix - i:int, i: term, i:list term, i:list term, i:list term, i:term, i:list term, i:list term, i:list term, +pred matrix + i: term, + i:int, i: term, i:list term, i:list term, i:list term, i:term, i:list term, i:list term, i:list term, i:term, i:term, i:term, o:term. -matrix TyParamNo K1 TyArgs1 KArgs1 ArgTys1 K1 TyArgs2 KArgs2 ArgTys2 E ETy _ R :- +matrix YTy TyParamNo K1 TyArgs1 KArgs1 ArgTys1 K2 TyArgs2 KArgs2 ArgTys2 E ETy _ R :- + coq.env.global (indc K) K1, + coq.env.global (indc K) K2, !, param K1 K1 KR, coq.mk-app K1 {std.append TyArgs1 KArgs1} LHS, - coq.mk-app K1 {std.append TyArgs2 KArgs2} RHS, - apply-indR TyParamNo 1 K1 KR TyArgs1 KArgs1 ArgTys1 TyArgs2 KArgs2 ArgTys2 LHS RHS E ETy TyParamNo R. + coq.mk-app K2 {std.append TyArgs2 KArgs2} RHS, + apply-indR YTy TyParamNo 1 K1 KR TyArgs1 KArgs1 ArgTys1 TyArgs2 KArgs2 ArgTys2 LHS RHS E ETy TyParamNo R. -matrix _ _ _ _ _ _ _ _ _ E ETy G R :- !, +matrix _ _ _ _ _ _ _ _ _ _ E ETy G R :- !, ltac.discriminate E ETy G R. pred implement-mR i:int, i:int, i:term, o:term. -% all TyParams processed, +% all TyParams processed, % remains forall (i1: I Args1) (i2 : I Args2), map -> IR % Bo is i1\ i2\ mapI Args1 Args2 ARs i1 = i2 -> IR Args1i Args2i ARsi i1 i2. % todo: Carry the list of TyArgs, needed for apply-ind params. implement-mR 0 TyParamNo (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)) (fix `f` 0 RT f\ fun I1 I1Ty i1\ fun I2 I2Ty i2\ (R f i1 i2)) :- - Ind = (global (indt GR)), - coq.safe-dest-app I1Ty Ind _, + coq.safe-dest-app I2Ty Ind _, + coq.env.global (indt GR) Ind, coq.env.recursive? GR, !, RT = (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)), @pi-decl `f` RT f\ @pi-decl I1 I1Ty i1\ @pi-decl I2 I2Ty i2\ - mR-db Ind f => + % TODO: I'm a bug fix me + mR-db Ind Ind f => coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R f i1 i2). implement-mR 0 TyParamNo (prod I1 I1Ty i1\ prod I2 I2Ty i2\ (Bo i1 i2)) (fun I1 I1Ty i1\ fun I2 I2Ty i2\ (R i1 i2)) :- @pi-decl I1 I1Ty i1\ @pi-decl I2 I2Ty i2\ - coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R i1 i2). -implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) ar\ prod AM (AMTy a1 a2 ar) am\ (Bo a1 a2 ar am)) + !, coq.build-match i1 I1Ty (rty-1 Bo i2) (mkBranch TyParamNo Bo i2 I2Ty) (R i1 i2). +implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) ar\ prod AM (AMTy a1 a2 ar) am\ (Bo a1 a2 ar am)) (fun A1 A1Ty a1\ fun A2 A2Ty a2\ fun AR (ARTy a1 a2) ar\ fun AM (AMTy a1 a2 ar) am\ (R a1 a2 ar am)) :- M is N - 1, @pi-decl A1 A1Ty a1\ @@ -152,8 +160,8 @@ implement-mR N TyParamNo (prod A1 A1Ty a1\ prod A2 A2Ty a2\ prod AR (ARTy a1 a2) MR = pglobal {{:gref lib:trocq.map2a.map_in_r }} _, coq.mk-app MR [a1,a2,ar,am] (PMR a1 a2 ar am), coq.elaborate-skeleton (PMR a1 a2 ar am) _ (MRA a1 a2 ar am) ok, - mymap-def A1Ty (MapA a1 a2 ar am) ==> - mR-db a1 (MRA a1 a2 ar am) ==> + mymap-db A1Ty A2Ty (MapA a1 a2 ar am) ==> + mR-db a1 a2 (MRA a1 a2 ar am) ==> % todo: check usage of ar-db in mR ar-db a1 a2 ar ==> implement-mR M TyParamNo (Bo a1 a2 ar am) (R a1 a2 ar am). @@ -163,18 +171,17 @@ func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ Name is Prefix ^ "mR", coq.env.indt GR _ UnifParamNo _ _ _ _, - Ind = (global (indt GR)), + coq.env.global (indt GR) Ind, param Ind Ind TR, coq.typecheck TR TRTy _, - mymap-def Ind IndMap, - mk-mR-type-mR UnifParamNo TRTy IndMap {{ Type }} TR MRTy, + mymap-def (indt GR) IndMapGR, + mk-mR-type-mR UnifParamNo TRTy {coq.env.global IndMapGR} {{ Type }} TR MRTy, std.assert-ok! (coq.elaborate-skeleton MRTy _ MRTyE) "derive.mR generates illtyped type", implement-mR UnifParamNo UnifParamNo MRTyE T, std.assert-ok! (coq.elaborate-skeleton T MRTyE TE) "derive.mR generates illtyped term", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName TE MRTyE _ C, - I = global (indt GR), - Clauses = [mR-done GR, mR-db I (global (const C))], + Clauses = [mR-done GR, mR-def (indt GR) (const C)], std.forall Clauses (x\ coq.elpi.accumulate _ "derive.mR.db" (clause _ _ x) ), diff --git a/elpi/inductives/mRRmK.elpi b/elpi/inductives/mRRmK.elpi index 7163b474..4847671b 100644 --- a/elpi/inductives/mRRmK.elpi +++ b/elpi/inductives/mRRmK.elpi @@ -1,5 +1,5 @@ shorten derive.common-algo.{mk-mR-type-mRRmK}. -shorten derive.algo-utils.{mk-chain, for-K-get-KI,type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with}. +shorten derive.algo-utils.{mk-chain, for-K-get-KI,type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with, elim-into-path-suffix, cmp-indt}. namespace derive.mRRmK { @@ -9,15 +9,15 @@ collect-ma1-a2 N [A1, A2| L] [A1|A1s] [A2|A2s] :- M is N - 1, collect-ma1-a2 M L A1s A2s. -pred collect-paths i:int, i:term, o:list term. +pred collect-paths i:int, i:term, o:list term. collect-paths 0 _ []. collect-paths N T [P|Ps] :- M is N - 1, coq.safe-dest-app T _EqTrans [_,_,_,_,AP1,AP2], coq.safe-dest-app AP1 _ Args1, std.last Args1 P, - collect-paths M AP2 Ps. - + collect-paths M AP2 Ps. + % delta beta iota iota pred red-mR i:term, i:stack, o:term,o:stack. red-mR X C R RS :- @@ -36,11 +36,11 @@ feed-injKs InjKs [] [] [] [] InjKs. feed-injKs InjKs [] [A1|Args1] [A2|Args2] [Path|Paths] ES :- std.map InjKs (x\ r\ sigma TMP\ coq.mk-app x [A1,A2,Path] TMP, r = TMP) NewInjKs, feed-injKs NewInjKs [] Args1 Args2 Paths ES. -feed-injKs InjKs TyArgsDest Args1 Args2 Paths Eqs :- +feed-injKs InjKs TyArgsDest Args1 Args2 Paths Eqs :- std.map InjKs (x\ r\ sigma TMP\ coq.mk-app x TyArgsDest TMP, r = TMP) NewInjKs, feed-injKs NewInjKs [] Args1 Args2 Paths Eqs. -pred collect-arguments i:int, i:int, i:term, o:list term, o:list term, o:list term, o:list term. +pred collect-arguments i:int, i:int, i:term, o:list term, o:list term, o:list term, o:list term. collect-arguments TyArgsNo InitArgs MRRM TyArgsDest Args1 Args2 Paths :- red-mR MRRM [] _KR Args12r, % KR a1 a2 ar b1 b2 br ... std.last Args12r LastMR, % each xr is xmR x1 x2 (inj Args12 Chain) @@ -56,7 +56,7 @@ collect-arguments TyArgsNo InitArgs MRRM TyArgsDest Args1 Args2 Paths :- coq.safe-dest-app Rm TheRm RmArgs, red-Rm TheRm RmArgs Concat ChainArgs, coq.mk-app Concat ChainArgs Chain, - collect-paths InitArgs Chain Paths. % Paths are Rm1 a1 a2 aR, Rm2 b1 b2 bR, ... + collect-paths InitArgs Chain Paths. % Paths are Rm1 a1 a2 aR, Rm2 b1 b2 bR, ... pred drop-last i:list A, o:list A. drop-last L R :- @@ -104,7 +104,7 @@ pierce-goal-mRRmK TyParamNo N InitArgs CurrentGoal [Eq|Eqs] [Pat|Pats] :- !, coq.safe-dest-app EqTy _ [_,LHS,_], coq.mk-app Pat [LHS] NewGoal, pierce-goal-mRRmK TyParamNo M InitArgs NewGoal Eqs Pats. - + pred get-mRRmK-args i:list term, o:list (list term). get-mRRmK-args [] []. get-mRRmK-args [P|Paths] [Args|Argss] :- @@ -118,21 +118,21 @@ mix-mRRmK-args [MRRMK| MRRMKs] [Args|Argss] [Eq| Eqs] :- mix-mRRmK-args MRRMKs Argss Eqs. % Ksource, Kdest, remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, -pred process-args i:term, i:term, i:int, i:int, i:int, i:term, i:term, i:term, i:term, +pred process-args i:term, i:term, i:int, i:int, i:int, i:term, i:term, i:term, i:term, i:list term, i:list term, i:list term, o:term. % zero more arguments to process -process-args Ksrc Kdest 0 0 _ _ Goal _ KR _ _ _ R :- - coq.mk-app Goal [Ksrc, Kdest, KR] EqTy, +process-args Ksrc Kdest 0 0 _ _ Goal _ KR _ _ _ R :- + coq.mk-app Goal [Ksrc, Kdest, KR] EqTy, whd EqTy [] _ [IRTy,_,IR], R = {{ lib:@trocq.idpath lp:IRTy lp:IR }}. -process-args Ksrc Kdest 0 InitArgs TyArgsNo _ Goal _ KR InjKs _ MRRMKEq R:- - coq.mk-app Goal [Ksrc, Kdest, KR] EqTy, +process-args Ksrc Kdest 0 InitArgs TyArgsNo _ Goal _ KR InjKs _ MRRMKEq R:- + coq.mk-app Goal [Ksrc, Kdest, KR] EqTy, %EqTy is the following type ImR i1 i2 (IRm i1 i2 ir) = ir for this specific branch whd EqTy [] HD [IRTy,MRRM,IR], - collect-arguments TyArgsNo InitArgs MRRM TyArgsDest Args1 Args2 Paths, %paths are all + collect-arguments TyArgsNo InitArgs MRRM TyArgsDest Args1 Args2 Paths, %paths are all feed-injKs InjKs TyArgsDest Args1 Args2 Paths Eqs, - invert-eqs Eqs IEqs, - std.map MRRMKEq (x\ r\ sigma TMP\ coq.elaborate-skeleton x _ TMP ok, r = TMP) MRRMKElab, + invert-eqs Eqs IEqs, + std.map MRRMKEq (x\ r\ sigma TMP\ @keepunivs! => coq.elaborate-skeleton x _ TMP ok, r = TMP) MRRMKElab, invert-eqs {std.rev MRRMKElab} IEqs2, End = {{ lib:@trocq.idpath lp:IRTy lp:IR }}, coq.mk-app HD [IRTy,{whd1 MRRM},IR] RGoal, % KR a1 a2 ar1[I_Rm] b1 b2 br[I_Rm] @@ -142,7 +142,7 @@ process-args Ksrc Kdest 0 InitArgs TyArgsNo _ Goal _ KR InjKs _ MRRMKEq R:- % still have to process an arg process-args Ksrc Kdest N InitArgs TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal ITyTy KR - InjKs [MRRMKSkel|MRRMKs] MRRMKEqs (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- + InjKs [MRRMKSkel|MRRMKs] MRRMKEqs (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- M is N - 1, @pi-decl AN1 A1Ty a1\ @pi-decl AN2 A2Ty a2\ @@ -154,9 +154,8 @@ process-args Ksrc Kdest N InitArgs TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ (ar-db a2 a1 ar ==> process-args (NewKS a1) (NewKD a2) M InitArgs TyArgsNo (Bo a1 a2 ar) Goal ITyTy (NewKR a1 a2 ar) InjKs MRRMKs [(MRRMK a1 a2 ar)|MRRMKEqs] (R a1 a2 ar)), % if the type of the argument is an instance of the inductive type add an induction hypothesis - whd ITyTy _ Ind _, - whd A2Ty _ IndD _, - if (Ind = IndD) + cmp-indt A2Ty ITyTy A2IndT Ind, + if (Ind = A2IndT) (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) (RF = R). @@ -168,29 +167,31 @@ feed-mRRmK-type [A2|Args] T R :- coq.mk-app T [A1, A2, AR] Acc, feed-mRRmK-type Args Acc R. -pred find-mRRmK i:list term, i:term, o: list term. -find-mRRmK [] _ []. -find-mRRmK [Ty|Tys] IndTy [MRRMK|MRRMKs] :- - coq.safe-dest-app Ty Ind TyArgs, - mRRmK-db Ind MRRMKS, - if (IndTy = Ind) +pred find-mRRmK i:list term, i:list term, i:term, o: list term. +find-mRRmK [] [] _ []. +find-mRRmK [STy| STys][DTy|DTys] IndTy [MRRMK|MRRMKs] :- + cmp-indt DTy IndTy IndD Ind, + cmp-indt STy IndTy IndS Ind, + coq.safe-dest-app DTy IndD TyArgs, + mRRmK-db IndS IndD MRRMKS, + if (Ind = IndD) (MRRMK = MRRMKS) (feed-mRRmK-type TyArgs MRRMKS MRRMK), - find-mRRmK Tys IndTy MRRMKs. + find-mRRmK STys DTys IndTy MRRMKs. -% invariant: all type arguments were already processed. -% Constructor src, Constructor dest, Constructor dest Type, No of Arguments to process, -% constructorR Type, type of i2, something of type : i1 i2 iR => goal. +% invariant: all type arguments were already processed. +% Constructor src, Constructor dest, Constructor dest Type, No of Arguments to process, +% constructorR Type, type of i2, something of type : i1 i2 iR => goal. % Argno, InjKs pred mkBranch i:term, i:term, i:int, i:term, i:term, i:term, i:term, i:list term, o:term. mkBranch KS KD N KTyR ITyTy Goal KR InjKs Eq:- - type-of-args KTyR N _ DestArgs, + type-of-args KTyR N SrcArgs DestArgs, whd ITyTy [] Hd TyArgs, - find-mRRmK DestArgs Hd MRRMKS, - % for every type dest add mRRmK to a list. + find-mRRmK SrcArgs DestArgs Hd MRRMKS, + % for every type dest add mRRmK to a list. process-args KS KD N N {std.length TyArgs} KTyR Goal ITyTy KR InjKs MRRMKS [] Eq. -pred mkBranches i:list term, i:list term, i:list term, i:list term, i:term, i:term, +pred mkBranches i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:list term, i:list (list term), o:list term. mkBranches [] [] [] [] _ _ [] [] []. mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KTyR|KTyRs] ITyTy Goal [KR|KRs] [InjKs|InjKss] [R|Rs] :- @@ -199,17 +200,17 @@ mkBranches [KS|KsS] [KD|KsD] [KTy|KTys] [KTyR|KTyRs] ITyTy Goal [KR|KRs] [InjKs| pred for-K-get-injKs i:int, i:list constructor, i:list term, o: list int, o:list (list term). for-K-get-injKs TyParamNo KNs KTys ArgsNos InjKss :- - F = (grk\ i\ p\ injectionsK-db (global (indc grk)) i p), + F = (grk\ i\ p\ injectionsK-db {coq.env.global (indc grk)} i p), for-K-get-KI TyParamNo KNs KTys F ArgsNos InjKss. pred implement-mRRmK i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:list term, i:list (list term), o:term. -% Pred comes with Type parameters applied -% RInd comes with Type parameters applied +% Pred comes with Type parameters applied +% RInd comes with Type parameters applied % mRRmK implement-mRRmK 0 (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KTys KTyRs Pred RInd KRs InjKss (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (Re f i1 i2 ar)) :- - coq.safe-dest-app ITy1 Ind _, - Ind = (global (indt GR)), + coq.safe-dest-app ITy1 Ind _, + coq.env.global (indt GR) Ind, coq.env.recursive? GR, !, RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), coq.mk-app RInd [Pred] RIndP, @@ -217,13 +218,14 @@ implement-mRRmK 0 (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ @pi-decl IN1 ITy1 i1\ @pi-decl IN2 ITy2 i2\ @pi-decl ARN (ARTy i1 i2) ar\ - (mRRmK-db Ind f => + % to implement non uniformity change f's RT + db entry for Ind *) + (mRRmK-db Ind Ind f => mkBranches KsS KsD KTys KTyRs ITy2 Pred KRs InjKss (Brs f)), std.append (Brs f) [i1,i2,ar] (IndArgs f i1 i2 ar), coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar), coq.elaborate-skeleton (R f i1 i2 ar) _ (Re f i1 i2 ar) ok. implement-mRRmK 0 (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) _) KsS KsD KTys KTyRs Pred RInd KRs InjKss - (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- + (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- !, coq.mk-app RInd [Pred] RIndP, @pi-decl IN1 ITy1 i1\ @pi-decl IN2 ITy2 i2\ @@ -236,13 +238,13 @@ implement-mRRmK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ M is N - 1, @pi-decl AN1 ATy1 a1\ %A1 : Type @pi-decl AN2 ATy2 a2\ %A2 : Type - @pi-decl ARN (ARTy a1 a2) ar\ % AR : A1 -> A2 -> Type - @pi-decl AMN (AMTy a1 a2 ar) am\ % Map4.Has AR + @pi-decl ARN (ARTy a1 a2) ar\ % AR : A1 -> A2 -> Type + @pi-decl AMN (AMTy a1 a2 ar) am\ % Map4.Has AR coq.mk-app Pred [a1,a2,ar, am] (NewPred a1 a2 ar am), - + coq.mk-app RInd [a1,a2,ar] (NewRIndSkel a1 a2 ar), coq.elaborate-skeleton (NewRIndSkel a1 a2 ar) _ (NewRInd a1 a2 ar) ok, - + std.map KsS (x\ r\ sigma TMP\ coq.mk-app x [a1] TMP, r = TMP) (NewKsS a1), std.map KsD (x\ r\ sigma TMP\ coq.mk-app x [a2] TMP, r = TMP) (NewKsD a2), std.map KTys (x\ r\ sigma TMP\ coq.subst-prod [a2] x TMP, r = TMP) (NewKTys a2), @@ -253,7 +255,7 @@ implement-mRRmK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ coq.mk-app MRRMK [a1, a2, ar, am] (MRRMKS a1 a2 ar am), coq.typecheck (MRRMKS a1 a2 ar am) _ ok, ar-db a1 a2 ar ==> - mRRmK-db a2 (MRRMKS a1 a2 ar am) ==> + mRRmK-db a1 a2 (MRRMKS a1 a2 ar am) ==> implement-mRRmK M (Bo a1 a2 ar am) (NewKsS a1) (NewKsD a2) (NewKTys a2) (NewKTyRs a1 a2 ar) (NewPred a1 a2 ar am) (NewRInd a1 a2 ar) (NewKRs a1 a2 ar) InjKss (R a1 a2 ar am). @@ -262,28 +264,31 @@ func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ KNs KTys, - Ind = (global (indt GR)), + coq.env.global (indt GR) Ind, param Ind Ind TR, coq.typecheck TR TRTy _, - mymap-def Ind IndMap, - mk-mR-type-mRRmK TyParamNo TRTy IndMap TR mR-db rm-db MRTy, - coq.elaborate-skeleton MRTy _ MRTyE ok, - TR = global (indt GRR), + mymap-def (indt GR) IndMapGR, + coq.env.global IndMapGR IndMap, + coq.env.global {mR-def (indt GR)} MR, + coq.env.global {rm-def (indt GR)} RM, + mk-mR-type-mRRmK TyParamNo TRTy IndMap TR MR RM MRTy, + (@keepunivs! => coq.elaborate-skeleton MRTy _ MRTyE ok), + coq.env.global (indt GRR) TR, coq.gref->id (indt GRR) Rname, - RInductionName is Rname ^ "_ind", + elim-into-path-suffix Rname Suff, + RInductionName is Rname ^ Suff, coq.locate RInductionName RInd, coq.prod->fun MRTyE Pred, coq.env.indt GRR _ _ _ _ KNRs KTyRs, - std.map KNs (x\ r\ r = (global (indc x))) Ks, - std.map KNRs (x\ r\ r = (global (indc x))) KRs, + std.map KNs (x\ r\ r = {coq.env.global (indc x)}) Ks, + std.map KNRs (x\ r\ r = {coq.env.global (indc x)}) KRs, for-K-get-injKs TyParamNo KNs KTys _ InjKss, - implement-mRRmK TyParamNo MRTyE Ks Ks KTys KTyRs Pred (global RInd) KRs InjKss R, - coq.elaborate-skeleton R MRTyE Re ok, + implement-mRRmK TyParamNo MRTyE Ks Ks KTys KTyRs Pred {coq.env.global RInd} KRs InjKss R, + (@keepunivs! => coq.elaborate-skeleton R MRTyE Re ok), Name is Prefix ^ "mRRmK", coq.ensure-fresh-global-id Name FName, - coq.env.add-const FName Re MRTyE _ C, - I = global (indt GR), - Clauses = [mRRmK-done GR, (mRRmK-db I (global (const C))) ], + @dropunivs! => coq.env.add-const FName Re MRTyE _ C, + Clauses = [mRRmK-done GR, (mRRmK-def (indt GR) (const C)) ], std.forall Clauses (x\ coq.elpi.accumulate _ "derive.mRRmK.db" (clause _ _ x) ), diff --git a/elpi/inductives/mapn.elpi b/elpi/inductives/mapn.elpi index a53dcee3..8eeb89ed 100644 --- a/elpi/inductives/mapn.elpi +++ b/elpi/inductives/mapn.elpi @@ -3,7 +3,7 @@ shorten derive.algo-utils.{gen-names-map}. namespace derive.mapn { % TyParamNo -% Arity +% Arity % Ind % IndR % TyArgs1 @@ -25,14 +25,14 @@ mk-mapn-type-priv N (prod TN Ty t\ (Bo t)) IndL IndR Rel MTy coq.mk-app IndR [t2] (NIndR t2), coq.mk-app Rel [t1,t2,ar] (NRel t1 t2 ar), mk-mapn-type-priv M (Bo t1) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) MTy (R t1 t2 ar ur). - + % TyParamNo Arity Ind MapTy Rel pred mk-mapn-type i:int, i:term, i:term, i:term, i:term, o:term. mk-mapn-type TyParamNo Arity Ind Rel MTy R :- mk-mapn-type-priv TyParamNo Arity Ind Ind Rel MTy R. -% TyParamNo MapnTy IndL IndR Rel listReqs IndMap MR RM MRRMK -pred implement-mapn i:int, i:term, i:term, i:term, i:term, i: list term, i:term, o:term. +% TyParamNo MapnTy IndL IndR Rel listReqs IndMap MR RM MRRMK +pred implement-mapn i:int, i:term, i:term, i:term, i:term, i: list term, i:term, o:term. implement-mapn 0 _ IndL IndR Rel Reqs BH R :- coq.mk-app BH [IndL,IndR,Rel | Reqs] R. implement-mapn N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ prod URN (UMTy t1 t2 ar) ur\ (Bo t1 t2 ar ur)) IndL IndR Rel Reqs BH (fun TN1 Ty1 t1\ fun TN2 Ty2 t2\ fun TRN (ARTy t1 t2) ar\ fun URN (UMTy t1 t2 ar) ur\ (R t1 t2 ar ur)) :- @@ -45,36 +45,38 @@ implement-mapn N (prod TN1 Ty1 t1\ prod TN2 Ty2 t2\ prod TRN (ARTy t1 t2) ar\ pr coq.mk-app IndR [t2] (NIndR t2), coq.mk-app Rel [t1,t2,ar] (NRel t1 t2 ar), std.map Reqs (x\ r\ sigma TMP\ coq.mk-app x [t1,t2,ar,ur] TMP, r = TMP) (NewReqs t1 t2 ar ur), - implement-mapn M (Bo t1 t2 ar ur) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) + implement-mapn M (Bo t1 t2 ar ur) (NIndL t1) (NIndR t2) (NRel t1 t2 ar) (NewReqs t1 t2 ar ur) BH (R t1 t2 ar ur). pred build-has-of i:map-class, o:gref. -build-has-of M R :- +build-has-of M R :- coq.locate {calc ("Map" ^ {map-class.to_string M} ^ ".BuildHas")} R. -pred map-reqs i:map-class, i:term, o: list term. +pred map-reqs i:map-class, i:gref, o: list gref. map-reqs map0 _ []. map-reqs map1 Ind [IndMap] :- std.assert! (mymap-def Ind IndMap) "derive.mapn: use derive.mymap before". map-reqs map2a Ind [MR | M1] :- map-reqs map1 Ind M1, - std.assert! (mR-db Ind MR) "derive.mapn: use derive.mR before". + std.assert! (mR-def Ind MR) "derive.mapn: use derive.mR before". map-reqs map2b Ind [RM | M1] :- map-reqs map1 Ind M1, - std.assert! (rm-db Ind RM) "derive.mapn: use derive.Rm before". + std.assert! (rm-def Ind RM) "derive.mapn: use derive.Rm before". map-reqs map3 Ind [RM | M2a] :- map-reqs map2a Ind M2a, - std.assert! (rm-db Ind RM) "derive.mapn: use derive.Rm before". + std.assert! (rm-def Ind RM) "derive.mapn: use derive.Rm before". map-reqs map4 Ind [MRRMK | M3] :- map-reqs map3 Ind M3, - std.assert! (mRRmK-db Ind MRRMK) "derive.mapn: use derive.MRRMK before". + std.assert! (mRRmK-def Ind MRRMK) "derive.mapn: use derive.MRRMK before". pred implement-mapM i:map-class, i:inductive, o: term. implement-mapM M GR RMapn :- coq.env.indt GR _ TyParamNo _ Arity _ _, - Ind = (global (indt GR)), + coq.env.global (indt GR) Ind, std.assert! (param Ind Ind IndR) "derive.mapn: use derive.param2 before", - std.rev {map-reqs M Ind} Reqs, + std.rev {map-reqs M (indt GR)} ReqsGR, + std.map ReqsGR (x\ r\ r = {coq.env.global x}) Reqs, + trocq.db.map->class M UM, build-has-of M BH4, % todo: address universe polymorphism @@ -85,13 +87,13 @@ implement-mapM M GR RMapn :- func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ - Ind = (global (indt GR)), + coq.env.global (indt GR) Ind, std.fold {map-class.all-of-kind all} [] (M\ C\ C'\ sigma RMapn NameMapn FNameMapn CMapn Entry\ implement-mapM M GR RMapn, NameMapn is Prefix ^ "map" ^ {map-class.to_string M}, coq.ensure-fresh-global-id NameMapn FNameMapn, coq.env.add-const FNameMapn RMapn _ _ CMapn, - Entry = trocq.db.map-ind Ind M (global (const CMapn)), + Entry = trocq.db.map-def (indt GR) M (const CMapn), coq.elpi.accumulate _ "trocq.db" (clause _ _ Entry), C' = [Entry | C] ) MClauses, diff --git a/elpi/inductives/mymap.elpi b/elpi/inductives/mymap.elpi index 15c41de9..50d863d5 100644 --- a/elpi/inductives/mymap.elpi +++ b/elpi/inductives/mymap.elpi @@ -7,8 +7,6 @@ shorten std.{split-at, length, rev, append, do!, drop-last, assert!}. mymap-db (app[ A1HD|A1]) (app[ A2HD |A2]) R :- coq.env.global (indt GR1) A1HD, coq.env.global (indt GR2) A2HD, - % A1HD = global (indt GR1), - % A2HD = global (indt GR2), coq.env.indt GR1 _ Lno1 _ _ _ _, coq.env.indt GR2 _ Lno2 _ _ _ _, {length A1} > Lno1, {length A2} > Lno2, @@ -41,7 +39,9 @@ bo-idx (prod _ S1 T1) Ity1 Ity2 N M Ps (fun `x` S1 Bo) (prod `x` S1 Ty) :- !, bo-idx (sort _) Ity1 Ity2 N N Ps (fun `x` Ity1 Bo) (prod `_` Ity1 _\ Ity2) :- !, @pi-decl `x` Ity1 x\ - coq.build-match x Ity1 (bo-idx-rty Ps Ity2) (bo-k-args Ps) (Bo x). + coq.safe-dest-app Ity1 IndT _, + coq.env.global GR IndT, + coq.build-match x Ity1 (bo-idx-rty Ps Ity2) (bo-k-args Ps GR) (Bo x). bo-idx X Ity1 Ity2 N M Ps R1 R2 :- whd1 X X1, !, bo-idx X1 Ity1 Ity2 N M Ps R1 R2. @@ -53,30 +53,40 @@ bo-idx-rty Ps ItyArgs _ Vs _ R :- coq.safe-dest-app ItyArgs HD _, coq.mk-app HD {append {rev Ps} Idxs} R. -pred bo-k-args i:list term, i:term, i:term, i:list term, i:list term, o:term. -bo-k-args ParamsRev K _ Args Tys R :- +pred bo-k-args i:list term, i:gref, i:term, i:term, i:list term, i:list term, o:term. +bo-k-args ParamsRev IndGR K _ Args Tys R :- rev ParamsRev Params, coq.safe-dest-app K KB _, coq.env.global (indc GR) KB, coq.env.typeof (indc GR) T, coq.subst-prod Params T KT, - (bo-k-args.aux {coq.mk-app KB Params} Args Tys KT R), + (bo-k-args.aux {coq.mk-app {coq.env.global (indc GR)} Params} IndGR Args Tys KT R), !. % the first combination that typechecks -% pred map.aux i:term, o:term. -% map.aux (prod T N B) (prod T N B). +% pred map.aux i:term, o:term. +% map.aux (prod T N B) (prod T N B). % map.aux FRel R :- -% coq.mk-app {{ map }} [FRel] 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 :- +% coq.mk-app {{ map }} [FRel] R. +% pred bobo i:term, o:term. +% bobo T U :- +% mymap-db T U _. + +pred bo-k-args.aux i:term, i:gref, 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 IndGR [A|As] [T|Ts] (prod _ S Ty) R :- mymap-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] [_|Ts] (prod _ _ Ty) R :- !, - bo-k-args.aux {coq.mk-app K [A]} As Ts (Ty A) R. -bo-k-args.aux K As Ts X R :- whd1 X X1, !, - bo-k-args.aux K As Ts X1 R. + bo-k-args.aux {coq.mk-app K [FA]} IndGR As Ts (Ty FA) R. +bo-k-args.aux K IndGR [A|As] [T|Ts] (prod _ _ Ty) R :- + coq.safe-dest-app T IndT ArgsIndT, + coq.env.global IndGR IndT, !, + coq.mk-app IndT Args2 TDest, + mymap-db IndT IndT F, + coq.mk-app F [A] FA, + bo-k-args.aux {coq.mk-app K [FA]} IndGR As Ts (Ty FA) R. +bo-k-args.aux K IndGR [A|As] [_|Ts] (prod _ _ Ty) R :- !, + bo-k-args.aux {coq.mk-app K [A]} IndGR As Ts (Ty A) R. +bo-k-args.aux K IndGR As Ts X R :- whd1 X X1, !, + bo-k-args.aux K IndGR As Ts X1 R. % Take in input a mapping function for each parameter @@ -93,11 +103,11 @@ pred bo-params o:term. % map function bo-params Lno Lno Ity1 Ity2 A1 _ Ps (fix `f` Recno Fty Bo) :- - coq.safe-dest-app Ity1 Ind _, + coq.safe-dest-app Ity1 Ind _, coq.env.global (indt I) Ind, coq.env.recursive? I, !, @pi-decl `rec` Fty f\ - mymap-db Ity1 Ity2 f => + mymap-db Ind Ind f => bo-idx A1 Ity1 Ity2 0 Recno Ps (Bo f) Fty. bo-params Lno Lno Ity1 Ity2 A1 _ Ps Bo :- !, bo-idx A1 Ity1 Ity2 0 _ Ps Bo _. @@ -115,19 +125,20 @@ bo-params N Lno Ity1 Ity2 (prod A Sty1 Rty1) (prod _ Sty2 Rty2) Ps R :- pi a b r f\ sigma Ity1A Ity2A \ coq.mk-app Ity1 [a] Ity1A, coq.mk-app Ity2 [b] Ity2A, - Clause a b r f => - decl a A1 Sty1 => - decl b A2 Sty2 => + Clause a b r f ==> + decl a A1 Sty1 ==> + decl b A2 Sty2 ==> (coq.elaborate-skeleton (RAB a b) _ (RABTy a b) ok, decl r Ar (RABTy a b) ==> coq.elaborate-skeleton (FAB a b r) _ (FABTy a b r) ok, decl f Af (FABTy a b r) ==> + mymap-db a b (FAB a b r)==> bo-params N1 Lno Ity1A Ity2A (Rty1 a) (Rty2 b) [b|Ps] (Bo a b r f)). bo-params N Lno Ity1 Ity2 T OT Ps R :- whd1 T T1, whd1 OT OT1, !, bo-params N Lno Ity1 Ity2 T1 OT1 Ps R. - + bo-params _ _ _ _ _ _ _ _ :- stop "derive.mymap: Indexed data types not supported". @@ -213,10 +224,10 @@ main GR Prefix C :- do! [ % generate clause and add to the db mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause, - coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-def T (global (const Funct)))), + coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-def (indt GR) (const Funct))), coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ Clause), coq.elpi.accumulate _ "derive.mymap.db" (clause _ _ (mymap-done GR)), - C = [mymap-done GR,Clause, (mymap-def T (global (const Funct)))] + C = [mymap-done GR,Clause, (mymap-def (indt GR) (const Funct))] ]. - + } \ No newline at end of file diff --git a/elpi/inductives/relnm.elpi b/elpi/inductives/relnm.elpi index 40bdab53..a8aeb9d3 100644 --- a/elpi/inductives/relnm.elpi +++ b/elpi/inductives/relnm.elpi @@ -53,7 +53,7 @@ get-eq-map map4 {{ lib:trocq.eq_map4 }}. pred generate-relNM i:inductive, i:param-class, o: term, o: term. generate-relNM GR (pc N M as PC) ReTy Re :- coq.env.indt GR _ TyParamNo _ _ KNs KTys, - Ind = (global (indt GR)), + coq.env.global (indt GR) Ind, std.assert! (param Ind Ind TR) "derive.relNM: use derive.param2 before", coq.typecheck TR TRTy _, trocq.db.rel PC PRelNM BuildNM _ CovNM ContraNM, @@ -68,7 +68,7 @@ generate-relNM GR (pc N M as PC) ReTy Re :- func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ - I = global (indt GR), + coq.env.global (indt GR) I, std.fold {param-class.all-of-kind all} [] (PC\ Cls\ Cls'\ sigma N M C ReTy Re Name FName\ diff --git a/elpi/inductives/sym.elpi b/elpi/inductives/sym.elpi index 9c279fbc..3352420d 100644 --- a/elpi/inductives/sym.elpi +++ b/elpi/inductives/sym.elpi @@ -1,35 +1,33 @@ shorten derive.common-algo.{mk-mR-type-sym}. +shorten derive.algo-utils.{cmp-indt}. namespace derive.sym { % [|K|], remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, pred process-args i:term, i:int, i:int, i:term, i:term, i:term, o:term. -process-args KR 0 _ _ _ _ R:- - R = KR. -process-args KR N _TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal ITyTy - (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- +process-args KR 0 _ _ _ _ KR. +process-args KR N _TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Goal ITyTy + (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- M is N - 1, @pi-decl AN1 A1Ty a1\ @pi-decl AN2 A2Ty a2\ @pi-decl ARN (ARTy a1 a2) ar\ - whd A1Ty _ A1Ind _, %TODO: fixme for inductives with type parameters, assemble sym - sym-db A1Ind SymC, - coq.mk-app SymC [a1,a2,ar] (RA a1 a2 ar), + cmp-indt A1Ty ITyTy A1IndT Ind, + sym-db A1IndT SymC, + coq.mk-app SymC [a1,a2,ar] (RA a1 a2 ar), coq.mk-app KR [a2,a1,(RA a1 a2 ar)] (NewKR a1 a2 ar), (param a2 a1 ar =!=> process-args (NewKR a1 a2 ar) M _ (Bo a1 a2 ar) Goal ITyTy (R a1 a2 ar)), % if the type of the argument is an instance of the inductive type add an induction hypothesis - whd ITyTy _ Ind _, - whd A2Ty _ IndD _, - if (Ind = IndD) + if (Ind = A1IndT) (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) (RF = R). -% invariant: all type arguments were already processed. -% Constructor R, Constructor dest Type, No of Arguments to process, -% constructorR Type, type of i2, something of type : i1 i2 iR => goal. +% invariant: all type arguments were already processed. +% Constructor R, Constructor dest Type, No of Arguments to process, +% constructorR Type, type of i2, something of type : i1 i2 iR => goal. pred mkBranch i:term, i:int, i:term, i:term, i:term, o:term. mkBranch KR N KTyR ITyTy Goal Eq:- whd ITyTy [] _ TyArgs, @@ -42,12 +40,12 @@ mkBranches [KR|KRs][KTy|KTys] [KTyR|KTyRs] ITyTy Goal [R|Rs] :- mkBranches KRs KTys KTyRs ITyTy Goal Rs. pred implement-sym i:int, i:int, i:term, i:list term, i:list term, i:list term, i:term, i:term, o:term. -% Pred comes with Type parameters applied -% RInd comes with Type parameters applied +% Pred comes with Type parameters applied +% RInd comes with Type parameters applied implement-sym 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KRs KTys KTyRs Pred RInd (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- - coq.safe-dest-app ITy1 Ind _, - Ind = (global (indt GR)), + coq.safe-dest-app ITy2 Ind _, + coq.env.global (indt GR) Ind, coq.env.recursive? GR, !, RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), coq.mk-app RInd [Pred] RIndP, @@ -55,12 +53,13 @@ implement-sym 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i @pi-decl IN1 ITy1 i1\ @pi-decl IN2 ITy2 i2\ @pi-decl ARN (ARTy i1 i2) ar\ - (sym-db Ind f => + (sym-db Ind f => mkBranches KRs KTys KTyRs ITy2 Pred (Brs f)), std.append (Brs f) [i1,i2,ar] (IndArgs f i1 i2 ar), coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). implement-sym 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) _) KRs KTys KTyRs Pred RInd (fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R i1 i2 ar)) :- + !, coq.mk-app RInd [Pred] RIndP, @pi-decl IN1 ITy1 i1\ @pi-decl IN2 ITy2 i2\ @@ -75,7 +74,7 @@ implement-sym N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 @pi-decl AN2 ATy2 a2\ %A2 : Type @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param00.Rel A1 A2 coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), - + (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, coq.elaborate-skeleton {{ sym_rel lp:{{ RelAR a1 a2 ar }} }} (ARType a2 a1) (RelRA a1 a2 ar) ok, @@ -115,7 +114,7 @@ main GR Prefix Clauses :- std.do! [ Name is Prefix ^ "sym", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName Re MRTyE _ C, - Clauses = [sym-done GR, sym-db Ind (global (const C))], + Clauses = [sym-done GR, sym-def (indt GR) (const C)], std.forall Clauses (x\ coq.elpi.accumulate _ "derive.sym.db" (clause _ _ x) ), diff --git a/elpi/inductives/symK.elpi b/elpi/inductives/symK.elpi index a4ca5d90..53ef09ca 100644 --- a/elpi/inductives/symK.elpi +++ b/elpi/inductives/symK.elpi @@ -1,5 +1,6 @@ shorten derive.algo-utils.{type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with}. shorten derive.common-algo.{mk-mR-type-symK}. +shorten derive.algo-utils.{cmp-indt}. namespace derive.symK { @@ -11,7 +12,7 @@ red-symK X C R RS :- pred pierce-goal-symK i:int, i:int, i:int, i:term, i: list term, o: list term, o: term. pierce-goal-symK _ N N Goal [] [] Goal. -pierce-goal-symK TyParamNo N InitArgs CurrentGoal [Eq|Eqs] [Pat|Pats] EndGoal:- !, +pierce-goal-symK TyParamNo N InitArgs CurrentGoal [Eq|Eqs] [Pat|Pats] EndGoal :- M is N + 1, coq.safe-dest-app CurrentGoal EqGoal [EqGoalTy,GoalLHS,GoalRHS], coq.safe-dest-app GoalLHS KR Args, @@ -29,7 +30,8 @@ pierce-goal-symK TyParamNo N InitArgs CurrentGoal [Eq|Eqs] [Pat|Pats] EndGoal:- % [|K|], remaining args, number of type args, KRTy, Type of args Ksource, Type of args KDest, Goal, pred process-args i:term, i:term, i:term, i:int,i:int, i:int, i:term, i:list term, i:term, i:term, o:term. -process-args KsS KsD KR 0 ArgNo TyArgsNo _ RevEqs Goal _ R:- +process-args KsS KsD KR 0 ArgNo TyArgsNo _ RevEqs Goal _ R:- + !, std.rev RevEqs Eqs, invert-eqs Eqs IEqs, coq.mk-app Goal [KsS,KsD,KR] SubstGoal, @@ -41,8 +43,8 @@ process-args KsS KsD KR 0 ArgNo TyArgsNo _ RevEqs Goal _ R:- End = {{ lib:@trocq.idpath lp:IRTy lp:IR }}, rewrite-with IEqs PatsSym End R. -process-args KsS KsD KR N O TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Eqs Goal ITyTy - (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- +process-args KsS KsD KR N O TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) Eqs Goal ITyTy + (fun AN1 A1Ty a1\ fun AN2 A2Ty a2\ fun ARN (ARTy a1 a2) ar\ (RF a1 a2 ar)):- M is N - 1, @pi-decl AN1 A1Ty a1\ @pi-decl AN2 A2Ty a2\ @@ -52,22 +54,21 @@ process-args KsS KsD KR N O TyArgsNo (prod AN1 A1Ty a1\ prod AN2 A2Ty a2\ prod A coq.mk-app KsD [a2] (NewKsD a2), coq.mk-app KR [a1,a2,ar] (NewKR a1 a2 ar), - (param a2 a1 ar =!=> - whd A2Ty _ IndD _, + cmp-indt A2Ty ITyTy IndD Ind, symK-db IndD SymKA2, coq.mk-app SymKA2 [a1, a2, ar] (SymKEq a1 a2 ar), std.append [(SymKEq a1 a2 ar)] Eqs (NewEqs a1 a2 ar), + (param a2 a1 ar =!=> process-args (NewKsS a1) (NewKsD a2) (NewKR a1 a2 ar) M O TyArgsNo (Bo a1 a2 ar) (NewEqs a1 a2 ar) Goal ITyTy (R a1 a2 ar)), % if the type of the argument is an instance of the inductive type add an induction hypothesis - whd ITyTy _ Ind _, if (Ind = IndD) (coq.mk-app Goal [a1, a2, ar] (EqTy a1 a2 ar), (RF a1 a2 ar) = fun `e` (EqTy a1 a2 ar) e\ (R a1 a2 ar)) (RF = R). -% invariant: all type arguments were already processed. -% Constructor R, Constructor dest Type, No of Arguments to process, -% constructorR Type, type of i2, something of type : i1 i2 iR => goal. +% invariant: all type arguments were already processed. +% Constructor R, Constructor dest Type, No of Arguments to process, +% constructorR Type, type of i2, something of type : i1 i2 iR => goal. pred mkBranch i:term, i:term, i:term, i:int, i:int, i:term, i:term, i:term, o:term. mkBranch KsS KsD KR N M KTyR ITyTy Goal Eq:- whd ITyTy [] _ TyArgs, @@ -77,16 +78,17 @@ pred mkBranches i:list term, i:list term, i:list term, i:list term, i:list term, mkBranches [] [] [] [] [] _ _ []. mkBranches [KsS|KsSs] [KsD| KsDs] [KR|KRs][KTy|KTys] [KTyR|KTyRs] ITyTy Goal [R|Rs] :- coq.count-prods KTy ArgNo, - mkBranch KsS KsD KR ArgNo ArgNo KTyR ITyTy Goal R, + mkBranch KsS KsD KR ArgNo ArgNo KTyR ITyTy Goal RSkel, + (@keepunivs! => coq.elaborate-skeleton RSkel _ R ok), mkBranches KsSs KsDs KRs KTys KTyRs ITyTy Goal Rs. pred implement-symK i:int, i:int, i:term, i:list term, i:list term, i:list term, i:list term, i:list term, i:term, i:term, o:term. -% Pred comes with Type parameters applied -% RInd comes with Type parameters applied +% Pred comes with Type parameters applied +% RInd comes with Type parameters applied implement-symK 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)) KsS KsD KRs KTys KTyRs Pred RInd (fix `f` 2 RT f\ fun IN1 ITy1 i1\ fun IN2 ITy2 i2\ fun ARN (ARTy i1 i2) ar\ (R f i1 i2 ar)) :- - coq.safe-dest-app ITy1 Ind _, - Ind = (global (indt GR)), + coq.safe-dest-app ITy2 Ind _, + coq.env.global (indt GR) Ind, coq.env.recursive? GR, !, RT = (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy i1 i2) ar\ (Bo i1 i2 ar)), coq.mk-app RInd [Pred] RIndP, @@ -94,7 +96,7 @@ implement-symK 0 _TyParamNo (prod IN1 ITy1 i1\ prod IN2 ITy2 i2\ prod ARN (ARTy @pi-decl IN1 ITy1 i1\ @pi-decl IN2 ITy2 i2\ @pi-decl ARN (ARTy i1 i2) ar\ - (symK-db Ind f => + (symK-db Ind f => mkBranches KsS KsD KRs KTys KTyRs ITy2 Pred (Brs f)), std.append (Brs f) [i1,i2,ar] (IndArgs f i1 i2 ar), coq.mk-app RIndP (IndArgs f i1 i2 ar) (R f i1 i2 ar). @@ -115,7 +117,7 @@ implement-symK N TyParamNo (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a @pi-decl AN2 ATy2 a2\ %A2 : Type @pi-decl ARN (ARTy a1 a2) ar\ % AR : Param00.Rel A1 A2 coq.mk-app Pred [a1,a2,ar] (NewPred a1 a2 ar), - + (ARType a1 a2) = {{ lp:a1 -> lp:a2 -> Type }}, coq.elaborate-skeleton ar (ARType a1 a2) (RelAR a1 a2 ar) ok, @@ -137,27 +139,26 @@ func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ KNs KTys, - Ind = (global (indt GR)), + coq.env.global (indt GR) Ind, std.assert! (param Ind Ind TR) "derive.sym: use derive.param2 before", coq.typecheck TR TRTy _, std.assert! (sym-db Ind SymInd) "derive.sym: use derive.sym before", mk-mR-type-symK TyParamNo TRTy TR SymInd SymKTy, - std.assert-ok! (coq.elaborate-skeleton SymKTy _ SymKTyE) "derive.symK generates illtyped type", - TR = global (indt GRR), + (@keepunivs! => std.assert-ok! (coq.elaborate-skeleton SymKTy _ SymKTyE) "derive.symK generates illtyped type"), + (@keepunivs! => coq.env.global (indt GRR) TR), coq.gref->id (indt GRR) Rname, RInductionName is Rname ^ "_rect", coq.locate RInductionName RInd, coq.prod->fun SymKTyE Pred, coq.env.indt GRR _ _ _ _ KRNs KTyRs, - std.map KNs (x\ r\ r = (global (indc x))) Ks, - std.map KRNs (x\ r\ r = (global (indc x))) KRs, - implement-symK TyParamNo TyParamNo SymKTyE Ks Ks KRs KTys KTyRs Pred (global RInd) R, - std.assert-ok! (coq.elaborate-skeleton R SymKTyE Re) "derive.symK generates illtyped term", + std.map KNs (x\ r\ r = {coq.env.global (indc x)}) Ks, + std.map KRNs (x\ r\ r = {coq.env.global (indc x)}) KRs, + implement-symK TyParamNo TyParamNo SymKTyE Ks Ks KRs KTys KTyRs Pred {coq.env.global RInd} R, + (@keepunivs! => std.assert-ok! (coq.elaborate-skeleton R SymKTyE Re) "derive.symK generates illtyped term"), Name is Prefix ^ "symK", coq.ensure-fresh-global-id Name FName, - coq.env.add-const FName Re SymKTyE _ C, - I = global (indt GR), - Clauses = [symK-done GR, symK-db I (global (const C))], + (@dropunivs! => coq.env.add-const FName Re SymKTyE _ C), + Clauses = [symK-done GR, symK-def (indt GR) (const C)], std.forall Clauses (x\ coq.elpi.accumulate _ "derive.symK.db" (clause _ _ x) ), diff --git a/elpi/inductives/utils.elpi b/elpi/inductives/utils.elpi index b96cefc2..c436cd41 100644 --- a/elpi/inductives/utils.elpi +++ b/elpi/inductives/utils.elpi @@ -6,9 +6,9 @@ names12 N N1 N2 :- !, pred gen-names-map i:name, o:name, o:name, o:name, o:name. gen-names-map N N1 N2 NR NU :- - coq.name-suffix N 1 N1, + coq.name-suffix N 1 N1, coq.name-suffix N 2 N2, - coq.name-suffix N "R" NR, + coq.name-suffix N "R" NR, coq.name-suffix N "M" NU. pred name-prefix i: name, i:string, o:name. @@ -17,13 +17,22 @@ name-prefix N P R :- S is P ^ NS, coq.string->name S R. -% given TyParam ArgNo and T, -% duplicate-argument skips TyParam products, -% then for the first ArgNo products adds another product expecting an argument of the same Type, +pred elim-into-path-suffix i:string, o:string. +elim-into-path-suffix Id Suff :- + (indt Eq) = {{:gref @lib:trocq.paths}}, + if ( Id = "paths") (Suff = "_nondep") + (coq.env.indt Eq _ _ _ (prod _ _ _\ (prod _ _ _\ (prod _ _ _\ sort S))) _ _, + if (S = prop) + (Suff = "_ind") + (Suff = "_rect")). + +% given TyParam ArgNo and T, +% duplicate-argument skips TyParam products, +% then for the first ArgNo products adds another product expecting an argument of the same Type, % after all lambdas are processed returns the body unchanged pred duplicate-arguments i:int, i:int, i:term, o:term. duplicate-arguments 0 0 T T :- !. -duplicate-arguments 0 O (prod N TyA T) (prod Arg1 TyA a1\ (prod Arg2 TyA a2\ (S a1 a2))) :- +duplicate-arguments 0 O (prod N TyA T) (prod Arg1 TyA a1\ (prod Arg2 TyA a2\ (S a1 a2))) :- O > 0, P is O - 1, names12 N Arg1 Arg2, @@ -38,24 +47,24 @@ count-args N T R :- coq.count-prods T M, R is M - N. -% given list eta-src type, eta-RT, list of etas, list of src, list of dest, list of src = dest, +% given list eta-src type, eta-RT, list of etas, list of src, list of dest, list of src = dest, % builds the corresponding ap. pred mk-aps-etas i:list term, i:term, i:list term, i:list term, i:list term, i:list term, o:list term. mk-aps-etas [] _ [] [] [] [] []. mk-aps-etas [DTy|DestTys] ITyTy [Eta|Etas] [SA|SrcArgs] [DA|DestArgs] [Eq|Eqs] [RE | RS] :- Ap = {{ lib:@trocq.ap }}, coq.mk-app Ap [DTy,ITyTy,Eta,SA,DA,Eq] R, - coq.elaborate-skeleton R _ RE ok, + (@keepunivs! => coq.elaborate-skeleton R _ RE ok), mk-aps-etas DestTys ITyTy Etas SrcArgs DestArgs Eqs RS. % K comes with type arguments already applied. pred mk-ith-eta i:int, i:list term, i:list term, i:list term, i:term, o:term. -mk-ith-eta I MArgs DestArgs DestTys K FR :- +mk-ith-eta I MArgs DestArgs DestTys K FR :- J is I - 1, std.take J DestArgs Done, % list of args already processed. std.drop I MArgs MTODO, % list of args to yet process std.nth J DestTys CurrTy, - (pi curr\ + (pi curr\ coq.mk-app K {std.append Done [curr|MTODO]} (KArgs curr)), FR = fun `R` CurrTy (r\ (KArgs r)). @@ -63,7 +72,7 @@ mk-ith-eta I MArgs DestArgs DestTys K FR :- % KDest comes with the type arguments already applied. pred mk-etas-priv i:list term, i:list term, i:list term, i:int, i:int, i: term, o:list term. mk-etas-priv _ _ _ M N _ [] :- M > N. -mk-etas-priv SrcArgs DestArgs DestTys I N KDest [R| RS] :- +mk-etas-priv SrcArgs DestArgs DestTys I N KDest [R| RS] :- J is I + 1, mk-ith-eta I SrcArgs DestArgs DestTys KDest R, mk-etas-priv SrcArgs DestArgs DestTys J N KDest RS. @@ -84,20 +93,22 @@ mk-chain SrcArgs DestArgs DestArgsTy K Eqs ITyTy RHS R :- mk-etas SrcArgs DestArgs DestArgsTy K REtas, mk-aps-etas DestArgsTy ITyTy REtas SrcArgs DestArgs Eqs Raps, compose-path Raps {{ lib:@trocq.idpath lp:ITyTy lp:RHS }} ITyTy RSkel, - coq.elaborate-skeleton RSkel _ R ok. + @keepunivs! => coq.elaborate-skeleton RSkel _ R ok. % pred name-ij i:string, i:int, i:int, i:inductive, i:constructor, i:list term, i: constructor -> int -> constant -> prop, o:list prop. -pred name-ij i:string, i:int, i:int, i:inductive, i:constructor, i:list term, i: (pred i:constructor, i:int, o:constant), o:list prop. -name-ij _ _ _ _ _ [] _ []. -name-ij FName I J GR Kn [InjTy|InjTyss] F [Clause|Clauses] :- +pred name-ij i:string, i:int, i:int, i:inductive, i:constructor, i:list term, i: (pred i:constructor, i:int, i:constant, o:list prop), o:list prop. +name-ij _ _ _ _ _ [] _ []. +name-ij FName I J GR Kn [InjTyS|InjTyss] F ClausesR :- Jn is J + 1, NameIJ is {std.any->string FName} ^ {std.any->string I} ^ {std.any->string J}, - coq.env.add-const NameIJ InjTy _ _ C, - Clause = (F Kn J C), - name-ij FName I Jn GR Kn InjTyss F Clauses. + (@dropunivs! => coq.elaborate-skeleton InjTyS _ InjTy ok), + (@dropunivs! => coq.env.add-const NameIJ InjTy _ _ C), + (F Kn J C Clauses), + name-ij FName I Jn GR Kn InjTyss F ClausesRec, + std.append Clauses ClausesRec ClausesR. % Prefix, current constructor, an inductive, its constructors, list of list of terms to name -pred name-ijs i:string, i:int, i:inductive, i:list constructor, i:list (list term), i: (pred i:constructor, i:int, o:constant), o:list (list prop). +pred name-ijs i:string, i:int, i:inductive, i:list constructor, i:list (list term), i: (pred i:constructor, i:int, i:constant, o:list prop), o:list (list prop). % pred name-ijs i:string, i:int, i:inductive, i:list constructor, i:list (list term), i: constructor -> int -> constant -> prop, o:list (list prop). name-ijs _ _ _ [] [] _ []. name-ijs FName I GR [Kn | KNs] [InjTys | InjTyss] F [Clauses | Clausess] :- @@ -105,32 +116,32 @@ name-ijs FName I GR [Kn | KNs] [InjTys | InjTyss] F [Clauses | Clausess] :- name-ij FName I 1 GR Kn InjTys F Clauses, name-ijs FName In GR KNs InjTyss F Clausess. -% Returns the list of P of F K I P of a constructor. +% Returns the list of P of F K I P of a constructor. pred get-KI i:constructor, i:int, i:int, i:(pred i:constructor, i:int, o:term), o:list term. get-KI _ Max Max _ [] :- !. -get-KI GRK J Max F [P|PJs] :- +get-KI GRK J Max F [P|PJs] :- I is J + 1, F GRK I P, get-KI GRK I Max F PJs. -% for a list of P of F K I for a list of constructors -pred for-K-get-KI i:int, i:list constructor, i:list term, +% for a list of P of F K I for a list of constructors +pred for-K-get-KI i:int, i:list constructor, i:list term, i:(pred i:constructor, i:int, o:term), o: list int, o:list (list term). for-K-get-KI _ [] [] _ [] []:- !. -for-K-get-KI TyParamNo [Kn|KNs] [KTy|KTys] F [ArgsNo|ArgsNos] [R|RS]:- +for-K-get-KI TyParamNo [Kn|KNs] [KTy|KTys] F [ArgsNo|ArgsNos] [R|RS]:- count-args TyParamNo KTy ArgsNo, get-KI Kn 0 ArgsNo F R, for-K-get-KI TyParamNo KNs KTys F ArgsNos RS. % from a type of shape 3*(forall (a1 : T1) (a2 : T2), AR a1 a2, ...) extracts list of T1 and T2 -pred type-of-args i:term, i:int, o:list term, o:list term. +pred type-of-args i:term, i:int, o:list term, o:list term. type-of-args _ 0 [] []. type-of-args (prod _ ATy1 a1\ prod _ ATy2 a2\ prod _ _ ar\ (Bo a1 a2 ar)) N [ATy1| SR] [ATy2 | DR] :- M is N - 1, - pi a1 a2 ar\ + pi a1 a2 ar\ type-of-args (Bo a1 a2 ar) M SR DR. - + % whd beta-iota-delta-zeta, main code pred whd-fuel i:term, i:stack, i:int, o:term, o:stack. whd-fuel T S 0 T S. @@ -140,43 +151,72 @@ whd-fuel (fun N T F) [B|C] M X XC :- !, (pi x\ def x N T B => cache x BN_ => whd-fuel (F x) C M (F1 x) (C1 x)), X = F1 B, XC = C1 B. whd-fuel (let N T B F) C M X XC :- !, (pi x\ def x N T B => cache x BN_ => whd-fuel (F x) C M (F1 x) (C1 x)), X = F1 B, XC = C1 B. -whd-fuel (global (const GR)) C M X XC :- +whd-fuel (global (const GR)) C M X XC :- O is M - 1, unfold GR none C D DC, !, whd-fuel D DC O X XC. -whd-fuel (pglobal (const GR) I) C M X XC :- +whd-fuel (pglobal (const GR) I) C M X XC :- O is M - 1, unfold GR (some I) C D DC, !, whd-fuel D DC O X XC. whd-fuel (primitive (proj _ N)) [A|C] M X XC :- whd-indc A _ KA, !, - whd-fuel {proj-red KA N C} M X XC. + O is M - 1, + whd-fuel {proj-red KA N C} O X XC. whd-fuel (global (const GR) as HD) C M X XC :- coq.env.primitive? GR, !, + O is M - 1, unwind HD C Orig, coq.reduction.lazy.whd_all Orig R, - if (same_term Orig R) (X = HD, XC = C) (whd-fuel R [] M X XC). + if (same_term Orig R) (X = HD, XC = C) (whd-fuel R [] O X XC). whd-fuel (match A _ L) C M X XC :- whd-indc A GR KA, !, whd-fuel {match-red GR KA L C} M X XC. whd-fuel (fix _ N _ F as Fix) C M X XC :- nth-stack N C LA A RA, whd-indc A GR KA, !, whd-fuel {fix-red F Fix LA GR KA RA} M X XC. whd-fuel N C M X XC :- name N, def N _ _ V, !, cache-whd N VN V, whd-fuel VN C M X XC. -whd-fuel X C _ X C. +whd-fuel X C _ X C. + +pred unfold-prim-proj i:term, i:stack, o:term, o:stack. +unfold-prim-proj (let _ _ ((app [ (primitive (proj _ _)) | _ ]) as B) F) C XX CC :- + whd B [] B' [], + Hd = F B', Args = C, + unfold-prim-proj Hd Args XX CC. +unfold-prim-proj X C XX CC :- + hd-beta X C XX CC. pred iota-step i:term, i:stack, o:term, o:stack. iota-step (match A _ L) C X XC :- whd-indc A GR KA, !, match-red GR KA L C X XC. +% deals with primitive projections +iota-step (let _ _ B F) C X XC :- !, + Hd = F B, Args = C, + unfold-prim-proj Hd Args X XC. pred invert-eqs i:list term, o:list term. invert-eqs Eqs IEqs :- - std.map Eqs (x\r\ sigma Skel TMP Err\ Skel = {{ lib:@trocq.inverse _ _ _ lp:x}}, - coq.elaborate-skeleton Skel _ TMP ok, + std.map Eqs (x\r\ sigma Skel TMP Err\ Skel = {{ lib:@trocq.inverse _ _ _ lp:x}}, + (@keepunivs! => coq.elaborate-skeleton Skel _ TMP ok), r = TMP ) IEqs. % expects list of equations pred rewrite-with i:list term, i:list term, i:term, o:term. -rewrite-with [] [] End End. +rewrite-with [] [] End End. rewrite-with [Eq|Eqs] [Pat|Pats] End R :- (pi rest\ - (T rest) = {{ lib:@trocq.paths_ind _ _ lp:Pat lp:rest _ lp:Eq }}), + + coq.gref->id {{:gref @lib:trocq.paths }} PathsID, + elim-into-path-suffix PathsID Suff, + PathIndName is PathsID ^ Suff, + coq.locate PathIndName PathIndGR, + coq.env.global PathIndGR PathInd, + (T rest) = {{ lp:PathInd _ _ lp:Pat lp:rest _ lp:Eq }}), rewrite-with Eqs Pats End RestSkel, - coq.elaborate-skeleton RestSkel _ Rest ok, - R = (T Rest). + (@keepunivs! => coq.elaborate-skeleton RestSkel _ Rest ok), + RSkel = (T Rest), + (@keepunivs! => coq.elaborate-skeleton RSkel _ R Err). + +% checks if two types refer to the same indt, and returns a canonical one. +pred cmp-indt i:term, i:term, o:term, o:term. +cmp-indt T1 T2 R T2Hd:- + coq.safe-dest-app T1 T1Hd _, + coq.safe-dest-app T2 T2Hd _, + coq.env.global (indt GR) T2Hd, + if ( T1Hd = pglobal (indt GR) _) (R = T2Hd) ( R = T1Hd ). } \ No newline at end of file diff --git a/generic/Param_Empty.v b/generic/Param_Empty.v index bcd5e82d..8c384ede 100644 --- a/generic/Param_Empty.v +++ b/generic/Param_Empty.v @@ -16,16 +16,15 @@ From Trocq Require Import HoTTNotations Relnm. (* translations of inductives in Prop is not yet supported, but we can still generate everything for False by manually defining its parametricity translation and making it land in Type. *) Unset Universe Polymorphism. -Inductive EmptyR : Empty -> Empty -> Type :=. +Inductive EmptyR : Empty -> Empty -> Type :=. (* param2 does not handle universe polymorphic inductives. Hence we have define EmptyR before seting Universe Polymorphism. *) Elpi derive.param2.register "False" "EmptyR". -Elpi derive.param2.register "Empty" "EmptyR". Set Universe Polymorphism. Unset Universe Minimization ToSet. -Elpi derive Empty. -Definition Param01_Empty := False_rel01. -Definition Param10_Empty := False_rel10. +#[prefix="Empty_"] Elpi derive Empty. +Definition Param01_Empty := Empty_rel01. +Definition Param10_Empty := Empty_rel10. diff --git a/generic/Param_bool.v b/generic/Param_bool.v index c2a116ca..35e6f92a 100644 --- a/generic/Param_bool.v +++ b/generic/Param_bool.v @@ -17,7 +17,18 @@ From Trocq Require Export HoTTNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. -Elpi derive Bool. -Definition BoolR := bool_R. +#[prefix="Bool_"] Elpi derive Bool. + +(* Enables to generically deal with Bool +despite one is a notation to bool and the other an inductive Bool*) +(* The inductive generates Bool_R = [| Bool |], +and the notation generates bool_R = [| Bool |]*) +(* Since param declares monomorphic definitions [| Bool |] has to be wrapped with a universe polymorphic definition *) +Module FakeBool. + Definition Bool := Bool. +End FakeBool. +Elpi derive.param2 FakeBool.Bool. + +Definition BoolR := Bool_R. Definition trueR := true_R. -Definition Param44_Bool := bool_rel44. +Definition Param44_Bool := Bool_rel44. diff --git a/generic/Param_prod.v b/generic/Param_prod.v index af2a251f..a2d9d862 100644 --- a/generic/Param_prod.v +++ b/generic/Param_prod.v @@ -16,4 +16,14 @@ From Trocq Require Import Relnm. Set Universe Polymorphism. Unset Universe Minimization ToSet. +Unset Universe Polymorphism. +Inductive prod_R (A1 A2 : Type) (A_R : A1 -> A2 -> Type) (B1 B2 : Type) (B_R : B1 -> B2 -> Type) +: prod A1 B1 -> prod A2 B2 -> Type := + pair_R : forall (a1 : A1) (a2 : A2), +A_R a1 a2 -> forall (b3 : B1) (b4 : B2), +B_R b3 b4 -> prod_R A1 A2 A_R B1 B2 B_R (@pair A1 B1 a1 b3) (@pair A2 B2 a2 b4). +Set Universe Polymorphism. + +Elpi derive.param2.register "prod" "prod_R". +Elpi derive.param2.register "pair" "pair_R". Elpi derive prod. \ No newline at end of file diff --git a/generic/Param_vector.v b/generic/Param_vector.v index ca9230c8..313df934 100644 --- a/generic/Param_vector.v +++ b/generic/Param_vector.v @@ -208,13 +208,14 @@ Proof. elim: vR => // {}n {}n' {}nR a a' aR {}v {}v' vR {2}<-/=; rewrite /g/=. move: (tR_sym_f _ _ _)=> vR'; move: vR'. move: ((nat_symK _ _ _))=> p. +set f := (X in (X nR _ )). by refine (match p as p0 in (_ = nRR) return forall vR' : tR A A' (sym_rel (sym_rel AR)) n n' (nat_sym n' n (nat_sym n n' nR)) v v', -transport _ (eq_ind nRR (fun t1 : nat_R n n' => S_R n n' t1 = S_R n n' nRR) 1 _ p0^) +transport _ (f nRR (fun t1 : nat_R n n' => S_R n n' t1 = S_R n n' nRR) 1 _ p0^) (consR A A' (sym_rel (sym_rel AR)) n n' (nat_sym n' n (nat_sym n n' nR)) a a' aR v v' vR') = consR A A' AR n n' nRR a a' aR v v' (transport _ p0 vR') -with eq_refl => _ end +with idpath => _ end ). Qed. diff --git a/generic/inductives/DeriveLib.v b/generic/inductives/DeriveLib.v index 194912ad..cd6bea81 100644 --- a/generic/inductives/DeriveLib.v +++ b/generic/inductives/DeriveLib.v @@ -4,10 +4,11 @@ From Trocq Require Export Stdlib HoTTNotations. Definition eq_f := @ap. Register eq_f as elpi.derive.eq_f. +Register paths as elpi.eq. -Definition bool_discr : true = false -> forall T : Type, T := +Definition bool_discr : Datatypes.true = Datatypes.false -> forall T : Type, T := fun e T => match e in _ = t - return match t with false => T | true => Unit end + return match t with Datatypes.false => T | Datatypes.true => Unit end with idpath => tt end. Register bool_discr as elpi.bool_discr. \ No newline at end of file diff --git a/generic/inductives/Rm.v b/generic/inductives/Rm.v index 6d66a7f8..68b2b83a 100644 --- a/generic/inductives/Rm.v +++ b/generic/inductives/Rm.v @@ -13,13 +13,24 @@ Elpi Db derive.Rm.db lp:{{ % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. pred ar-db i:term, i:term, o:term. - % [Rm-db T D] links a type T to its corresponding R in map. - pred rm-db i:term, o:term. + % [Rm-db T D] links an inductive type T to its corresponding R in map. + pred rm-def i:gref, o:gref. + pred rm-db i:term, o:term, o:term. % [Rm-done T] mean T was already derived pred rm-done o:inductive. }}. +#[superglobal] Elpi Accumulate derive.Rm.db lp:{{ + + % refactor db dispatchers + rm-db I _ R :- + coq.env.global (indt GRI) I, + rm-def (indt GRI) GRR, + coq.env.global GRR R. + +}}. + Elpi Command derive.Rm. Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. @@ -31,6 +42,7 @@ Elpi Accumulate Db Header derive.Rm.db. Elpi Accumulate Db derive.Rm.db. Elpi Accumulate File Rm. Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, Prefix is Tname ^ "_", diff --git a/generic/inductives/RsymK.v b/generic/inductives/RsymK.v index 67e5be6f..b036deea 100644 --- a/generic/inductives/RsymK.v +++ b/generic/inductives/RsymK.v @@ -17,6 +17,7 @@ Elpi Db derive.rsymK.db lp:{{ % [rsymK I S] links I inductive type, % with the function showing i1 i2, [| I |]^ i2 i1 <->> [| I |] i1 i2 pred rsymK-db i:term, o:term. + pred rsymK-def i:gref, o:gref. % [rsymK-done T K] means T K was already derived pred rsymK-done o:inductive. @@ -49,6 +50,15 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.rsymK ". }}. +#[superglobal] Elpi Accumulate derive.rsymK.db lp:{{ + + % refactor db dispatchers + rsymK-db I R :- + coq.env.global (indt GRI) I, + rsymK-def (indt GRI) GRR, + coq.env.global GRR R. + +}}. (* hook into derive *) Elpi Accumulate derive Db Header derive.rsymK.db. Elpi Accumulate derive Db derive.rsymK.db. diff --git a/generic/inductives/injK.v b/generic/inductives/injK.v index 4d809fc4..235841e1 100644 --- a/generic/inductives/injK.v +++ b/generic/inductives/injK.v @@ -7,13 +7,15 @@ From Trocq Require Export injection_lemmas. From Trocq Require Import DeriveLib HoTTNotations Stdlib Hierarchy. Unset Uniform Inductive Parameters. +Unset Universe Minimization ToSet. +Unset Universe Polymorphism. Definition conv (A : Type) (x y : A) (p: x = y) - (P : forall x0 : A, x = x0 -> Prop) (P0 : P x idpath) := + (P : forall x0 : A, x = x0 -> Type) (P0 : P x idpath) := match p as p0 in _ = t return (P t p0) with idpath => P0 end. - Register conv as trocq.conv. +Set Universe Polymorphism. Elpi Db derive.injectionsK.db lp:{{ @@ -23,6 +25,7 @@ Elpi Db derive.injectionsK.db lp:{{ % a natural number > 0 (representing the constructor number) % with the list of injectionK lemmas for that constructor pred injectionsK-db i:term, i:int, o:term. + pred injectionsK-def i:gref, i:int, o:gref. % [injectionsK-done T K] means T K was already derived pred injectionsK-done o:inductive. @@ -45,6 +48,15 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.Rm ". }}. +#[superglobal] Elpi Accumulate derive.injectionsK.db lp:{{ + + injectionsK-db K N R :- + coq.env.global (indc GRK) K, + injectionsK-def (indc GRK) N GRR, + coq.env.global GRR R. + +}}. + (* hook into derive *) Elpi Accumulate derive Db derive.injectionsK.db. Elpi Accumulate derive File algo_utils. @@ -56,4 +68,3 @@ dep1 "injK" "injections". derivation (indt T) Prefix ff (derive "injK" (derive.injK.main T Prefix) (injectionsK-done T)). }}. - diff --git a/generic/inductives/injection_lemmas.v b/generic/inductives/injection_lemmas.v index cd840534..e8bc3d76 100644 --- a/generic/inductives/injection_lemmas.v +++ b/generic/inductives/injection_lemmas.v @@ -9,6 +9,7 @@ From elpi.apps Require Export derive.projK. From Trocq Require Export DeriveLib. Unset Uniform Inductive Parameters. +Unset Universe Minimization ToSet. Elpi Db derive.injections.db lp:{{ % [injections I K ILs] links I, @@ -17,6 +18,7 @@ Elpi Db derive.injections.db lp:{{ % a natural number > 0 (representing the constructor number) % with the list of injection lemmas for that constructor pred injections-db i:term, i:int, o:term. + pred injections-def i:gref, i:int, o:gref. % [injections-done T K] means T K was already derived pred injections-done o:inductive. @@ -44,6 +46,15 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.injections ". }}. +#[superglobal] Elpi Accumulate derive.injections.db lp:{{ + + injections-db K N R :- + coq.env.global (indc GRK) K, + injections-def (indc GRK) N GRR, + coq.env.global GRR R. + +}}. + (* hook into derive *) Elpi Accumulate derive Db derive.injections.db. Elpi Accumulate derive File injection. @@ -56,4 +67,3 @@ dep1 "injections" "projK". derivation (indt T) Prefix ff (derive "injections" (derive.injections.main T Prefix) (injections-done T)). }}. - diff --git a/generic/inductives/mR.v b/generic/inductives/mR.v index b8c4076d..23e7b576 100644 --- a/generic/inductives/mR.v +++ b/generic/inductives/mR.v @@ -1,6 +1,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. +From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. From Trocq.Elpi Extra Dependency "inductives/mR.elpi" as mR. From Trocq.Elpi Extra Dependency "inductives/injection_lemmas.elpi" as injections. @@ -14,13 +15,25 @@ Unset Uniform Inductive Parameters. Elpi Db derive.mR.db lp:{{ % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. pred ar-db i:term, i:term, o:term. - % [mR-db T D] links a type T to its corresponding map in R. - pred mR-db i:term, o:term. + % [mR-db T D] links an inductive T to its corresponding map in R. + pred mR-def i:gref, o:gref. + + pred mR-db i:term, i:term, o:term. % [mR-done T] mean T was already derived pred mR-done o:inductive. }}. +#[superglobal] Elpi Accumulate derive.mR.db lp:{{ + + % refactor db dispatchers + mR-db I _ R :- + coq.env.global (indt GRI) I, + mR-def (indt GRI) GRR, + coq.env.global GRR R. + +}}. + Elpi Command derive.mR. Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. @@ -30,9 +43,11 @@ Elpi Accumulate Db derive.isK.db. Elpi Accumulate File discr. Elpi Accumulate Db derive.injections.db. Elpi Accumulate File common. +Elpi Accumulate File utils. Elpi Accumulate Db derive.mR.db. Elpi Accumulate File mR. Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, Prefix is Tname ^ "_", @@ -62,4 +77,3 @@ Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "mR" (derive.mR.main T Prefix) (mR-done T)). }}. - diff --git a/generic/inductives/mRRmK.v b/generic/inductives/mRRmK.v index 96f4ad38..796c50d9 100644 --- a/generic/inductives/mRRmK.v +++ b/generic/inductives/mRRmK.v @@ -13,13 +13,25 @@ Elpi Db derive.mRRmK.db lp:{{ % [ar-db A1 A2 AR] returns the relation between a type A1 and A2. pred ar-db i:term, i:term, o:term. - % [mRRmK-db T D] links a type T to its corresponding R in map. - pred mRRmK-db i:term, o:term. + % [mRRmK-def T D] links an inductive type T to its corresponding R in mapK. + pred mRRmK-def i:gref, o:gref. + + pred mRRmK-db i:term, o:term, o:term. % [mRRmK-done T] mean T was already derived pred mRRmK-done o:inductive. }}. +#[superglobal] Elpi Accumulate derive.mRRmK.db lp:{{ + + % refactor db dispatchers + mRRmK-db I _ R :- + coq.env.global (indt GRI) I, + mRRmK-def (indt GRI) GRR, + coq.env.global GRR R. + +}}. + Elpi Command derive.mRRmK. Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. @@ -38,6 +50,7 @@ Elpi Accumulate Db Header derive.mRRmK.db. Elpi Accumulate Db derive.mRRmK.db. Elpi Accumulate File mRRmK. Elpi Accumulate lp:{{ + main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, Prefix is Tname ^ "_", @@ -49,7 +62,6 @@ Elpi Accumulate lp:{{ }}. - (* hook into derive *) Elpi Accumulate derive Db derive.mRRmK.db. Elpi Accumulate derive File common. diff --git a/generic/inductives/map4.v b/generic/inductives/map4.v index 7d412973..d391e572 100644 --- a/generic/inductives/map4.v +++ b/generic/inductives/map4.v @@ -3,4 +3,5 @@ From Trocq Require Export injection_lemmas. From Trocq Require Export mR. From Trocq Require Export Rm. From Trocq Require Export injK. -From Trocq Require Export mRRmK. \ No newline at end of file +From Trocq Require Export mRRmK. +From Trocq Require Export Stdlib Hierarchy. \ No newline at end of file diff --git a/generic/inductives/mapn.v b/generic/inductives/mapn.v index 96b2659a..8e819b8f 100644 --- a/generic/inductives/mapn.v +++ b/generic/inductives/mapn.v @@ -7,8 +7,9 @@ Unset Uniform Inductive Parameters. (* I have to use Trocq db due to a dependency of type declaration of predicates in umap-db *) (* if the class file is accumulated in umap-db then accumulating trocq.db is an issue *) -(* Elpi Db derive.umap.db lp:{{ }}. -Elpi Accumulate derive.umap.db Db trocq.db. *) +(* Elpi Db derive.umap.db lp:{{ }}. *) + +(* Elpi Accumulate derive.umap.db Db trocq.db. *) (* Elpi Accumulate derive Db trocq.db. *) (* Elpi Db derive.umap.db lp:{{ % [umap-db T D] @@ -46,6 +47,14 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.rel40 ". }}. +#[superglobal] Elpi Accumulate trocq.db lp:{{ + + trocq.db.map-ind I M R :- + coq.env.global (indt GRI) I, + trocq.db.map-def (indt GRI) M GRR, + coq.env.global GRR R. + +}}. Elpi Accumulate derive Db trocq.db. Elpi Accumulate derive File common. Elpi Accumulate derive File algo_utils. diff --git a/generic/inductives/mymap.v b/generic/inductives/mymap.v index c10d360f..bef8a04a 100644 --- a/generic/inductives/mymap.v +++ b/generic/inductives/mymap.v @@ -8,7 +8,7 @@ Unset Uniform Inductive Parameters. Elpi Db derive.mymap.db lp:{{ % [mymap-def I C] brings the constant defined for mapping inductive I. - pred mymap-def i:term, o:term. + pred mymap-def i:gref, o:gref. % [mymap T1 T2 D] for T1 and T2 brings a map D from T1 to T2. pred mymap-db i:term, i:term, o:term. diff --git a/generic/inductives/sym.v b/generic/inductives/sym.v index 6ef93c4d..f3748a77 100644 --- a/generic/inductives/sym.v +++ b/generic/inductives/sym.v @@ -13,11 +13,22 @@ Elpi Db derive.sym.db lp:{{ % [sym I S] links I inductive type, % with the function showing symmetry pred sym-db i:term, o:term. + pred sym-def i:gref, o:gref. % [sym-done T K] means T K was already derived pred sym-done o:inductive. }}. +#[superglobal] Elpi Accumulate derive.sym.db lp:{{ + + % refactor db dispatchers + sym-db I R :- + coq.env.global (indt GRI) I, + sym-def (indt GRI) GRR, + coq.env.global GRR R. + +}}. + Elpi Command derive.sym. Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. @@ -44,7 +55,6 @@ Elpi Accumulate lp:{{ (* hook into derive *) - Elpi Accumulate derive Db Header derive.sym.db. Elpi Accumulate derive Db derive.sym.db. Elpi Accumulate derive File common. diff --git a/generic/inductives/symK.v b/generic/inductives/symK.v index 09804f2c..eee2c5b5 100644 --- a/generic/inductives/symK.v +++ b/generic/inductives/symK.v @@ -8,7 +8,7 @@ From Trocq Require Import sym. From elpi.apps Require Import derive derive.param2. -From Trocq Require Export Hierarchy. +From Trocq Require Export Hierarchy Stdlib. Unset Uniform Inductive Parameters. Elpi Db derive.symK.db lp:{{ @@ -16,10 +16,20 @@ Elpi Db derive.symK.db lp:{{ % [symK I S] links I inductive type, % with the function showing symmetry is "involutive" pred symK-db i:term, o:term. + pred symK-def i:gref, o:gref. % [symK-done T K] means T K was already derived pred symK-done o:inductive. }}. +#[superglobal] Elpi Accumulate derive.symK.db lp:{{ + + % refactor db dispatchers + symK-db I R :- + coq.env.global (indt GRI) I, + symK-def (indt GRI) GRR, + coq.env.global GRR R. + +}}. Elpi Command derive.symK. Elpi Accumulate File derive_hook. diff --git a/hott/Hierarchy.v b/hott/Hierarchy.v index 4848a499..6515d682 100644 --- a/hott/Hierarchy.v +++ b/hott/Hierarchy.v @@ -104,7 +104,6 @@ Elpi Query lp:{{register-map-classes}}. Definition sym_rel@{i} {A B : Type@{i}} (R : A -> B -> Type@{i}) := fun b a => R a b. Register sym_rel as trocq.sym_rel. -Register paths as trocq.paths. Elpi Query lp:{{ coq.elpi.accumulate _ "trocq.db" (clause _ _ (trocq.db.sym-rel {{:gref lib:trocq.sym_rel}})), diff --git a/hott/Stdlib.v b/hott/Stdlib.v index e8e9cfff..d6220505 100644 --- a/hott/Stdlib.v +++ b/hott/Stdlib.v @@ -19,9 +19,13 @@ Module HoTTNotations. (* Stub for compatibility with stdlib version *) End HoTTNotations. +Register paths as trocq.paths. Register concat as trocq.concat. Register idpath as trocq.idpath. Register inverse as trocq.inverse. Register paths_ind as trocq.paths_ind. Register exist as trocq.exist. -Register ap as trocq.ap. \ No newline at end of file +Register ap as trocq.ap. + +Definition paths_nondep (A : Type) (x : A) (P : A -> Type) : P x -> forall y : A, x = y -> P y := + fun w y e=> paths_rect A x (fun a0 e => P a0) w y e. \ No newline at end of file diff --git a/hott/_CoqProject b/hott/_CoqProject index 19471356..aa6dc5b5 100644 --- a/hott/_CoqProject +++ b/hott/_CoqProject @@ -35,13 +35,13 @@ generic/inductives/Relnm.v generic/Database.v generic/Param_Empty.v generic/Param_bool.v -generic/Param_list.v generic/Param_nat.v generic/Param_option.v -generic/Param_paths.v generic/Param_prod.v -generic/Param_sigma.v generic/Param_sum.v +generic/Param_list.v +generic/Param_paths.v +generic/Param_sigma.v generic/Param_trans.v generic/Param_vector.v generic/Trocq.v diff --git a/std/Hierarchy.v b/std/Hierarchy.v index ec32423f..629942c6 100644 --- a/std/Hierarchy.v +++ b/std/Hierarchy.v @@ -104,7 +104,6 @@ Definition sym_rel@{i} {A B : Type@{i}} (R : A -> B -> Type@{i}) := fun b a => R Import HoTTNotations. Register sym_rel as trocq.sym_rel. -Register paths as trocq.paths. Elpi Query lp:{{ coq.elpi.accumulate _ "trocq.db" (clause _ _ (trocq.db.sym-rel {{:gref lib:trocq.sym_rel}})), diff --git a/std/Stdlib.v b/std/Stdlib.v index df2a4ea5..3a3a30ca 100644 --- a/std/Stdlib.v +++ b/std/Stdlib.v @@ -14,6 +14,7 @@ Require Import ssreflect. From Trocq Require Import HoTTNotations. From elpi Require Export elpi. +Register paths as trocq.paths. Register idpath as trocq.idpath. Register concat as trocq.concat. Register inverse as trocq.inverse. diff --git a/std/_CoqProject b/std/_CoqProject index af9804d9..57daa0a4 100644 --- a/std/_CoqProject +++ b/std/_CoqProject @@ -33,13 +33,13 @@ generic/inductives/Relnm.v generic/Database.v generic/Param_Empty.v generic/Param_bool.v -generic/Param_list.v generic/Param_nat.v generic/Param_option.v -generic/Param_paths.v generic/Param_prod.v -generic/Param_sigma.v generic/Param_sum.v +generic/Param_list.v +generic/Param_paths.v +generic/Param_sigma.v generic/Param_trans.v generic/Param_vector.v generic/Trocq.v diff --git a/tests/inductives/coverage.v b/tests/inductives/coverage.v index 08422802..6944b858 100644 --- a/tests/inductives/coverage.v +++ b/tests/inductives/coverage.v @@ -1,8 +1,4 @@ Unset Universe Polymorphism. -From elpi Require Import elpi. -From elpi.apps Require Import derive derive.param2. - -From Trocq Require Import sym. Unset Uniform Inductive Parameters. Inductive testFalse : Set :=. @@ -15,32 +11,32 @@ Inductive testBool : Set := | Trueb. Inductive Wrap : Set := -| KWrap1 : testUnit -> Wrap. +| KWrap1 : forall _ : testUnit, Wrap. Inductive WrapMore : Set := -| KWrap : testUnit -> testBool -> WrapMore -| KWrapWrap : Wrap -> WrapMore -| F : testUnit -> testUnit -> testUnit -> WrapMore. +| KWrap : forall (_: testUnit) (_ : testBool), WrapMore +| KWrapWrap : forall (_ : Wrap), WrapMore +| F : forall (_ : testUnit) (_ : testUnit) (_ : testUnit), WrapMore. Inductive Nat : Set := | O' -| S' : Nat -> Nat. +| S' : forall (_ : Nat), Nat. Inductive Box (A : Type) : Type := -| B : A -> Box A. +| B : forall (_: A), Box A. Inductive Option (A : Type) : Type := | None' : Option A -| Some' : A -> Option A. +| Some' : forall (_ : A), Option A. Inductive Prod (A B : Type) : Type := -| PR : A -> B -> Prod A B. +| PR : forall (_ : A) (_ : B), Prod A B. Inductive ThreeTypes (A B C : Type) := -| C1 : A -> ThreeTypes A B C -| C2 : B -> ThreeTypes A B C -| C3 : C -> ThreeTypes A B C. +| C1 : forall (_ : A), ThreeTypes A B C +| C2 : forall (_ : B), ThreeTypes A B C +| C3 : forall (_ : C), ThreeTypes A B C. Inductive List (A : Type) : Type := | Nil : List A -| Cons : A -> List A -> List A. +| Cons : forall (_ : A) (_ : List A), List A. diff --git a/tests/inductives/test_injK.v b/tests/inductives/test_injK.v index ab3c17f9..35a43d9a 100644 --- a/tests/inductives/test_injK.v +++ b/tests/inductives/test_injK.v @@ -2,9 +2,9 @@ From Trocq Require Import injK. Require Import coverage. Unset Uniform Inductive Parameters. -Elpi derive.projK False. -Elpi derive.injections False. -Elpi derive.injK False. +Elpi derive.projK testFalse. +Elpi derive.injections testFalse. +Elpi derive.injK testFalse. Elpi derive.projK testUnit. Elpi derive.injections testUnit. diff --git a/tests/inductives/test_injection_lemmas.v b/tests/inductives/test_injection_lemmas.v index bffb87c3..44230065 100644 --- a/tests/inductives/test_injection_lemmas.v +++ b/tests/inductives/test_injection_lemmas.v @@ -2,8 +2,8 @@ From Trocq Require Import injection_lemmas. Require Import coverage. Unset Uniform Inductive Parameters. -Elpi derive.projK False. -Elpi derive.injections False. +Elpi derive.projK testFalse. +Elpi derive.injections testFalse. Elpi derive.projK testUnit. Elpi derive.injections testUnit. diff --git a/tests/inductives/test_mR.v b/tests/inductives/test_mR.v index 0597dc2a..5c9155bb 100644 --- a/tests/inductives/test_mR.v +++ b/tests/inductives/test_mR.v @@ -2,12 +2,12 @@ From Trocq Require Import mR. Require Import coverage. Unset Uniform Inductive Parameters. -Elpi derive.param2 False. -Elpi derive.mymap False. -Elpi derive.projK False. -Elpi derive.injections False. -Elpi derive.isK False. -Elpi derive.mR False. +Elpi derive.param2 testFalse. +Elpi derive.mymap testFalse. +Elpi derive.projK testFalse. +Elpi derive.injections testFalse. +Elpi derive.isK testFalse. +Elpi derive.mR testFalse. Elpi derive.param2 testUnit. Elpi derive.mymap testUnit. diff --git a/tests/inductives/test_map4.v b/tests/inductives/test_map4.v index c9dbae47..d195a20d 100644 --- a/tests/inductives/test_map4.v +++ b/tests/inductives/test_map4.v @@ -1,4 +1,5 @@ From Trocq Require Import map4. +Import HoTTNotations. Require Import coverage. Unset Uniform Inductive Parameters. @@ -21,23 +22,24 @@ Elpi derive Nat. Check Nat_mRRmK : forall n1 n2 nR, Nat_mR n1 n2 (Nat_Rm n1 n2 nR) = nR. Elpi derive Box. -Check Box_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM : Map4.Has AR), forall (b1 : Box A1) (b2 : Box A2) (bR : Box_R A1 A2 AR b1 b2), - Box_mR A1 A2 AR AM b1 b2 (Box_Rm A1 A2 AR AM b1 b2 bR) = bR. +About Box_mRRmK. +(* Check Box_mRRmK. Bug? Why does it break? *) Elpi derive Option. -Check Option_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM : Map4.Has AR), - forall o1 o2 oR, Option_mR A1 A2 AR AM o1 o2 (Option_Rm A1 A2 AR AM o1 o2 oR) = oR. +About Option_mRRmK. +(* Check Option_mRRmK : forall A1 A2 (AR : forall (_: A1) (_ : A2), Type) (AM : Map4.Has AR), + forall o1 o2 oR, Option_mR A1 A2 AR AM o1 o2 (Option_Rm A1 A2 AR AM o1 o2 oR) = oR. *) Elpi derive Prod. -Check Prod_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM : Map4.Has AR) B1 B2 (BR : B1 -> B2 -> Type) (BM : Map4.Has BR), +Check Prod_mRRmK : forall A1 A2 (AR : forall (_ : A1) (_ : A2), Type) (AM : Map4.Has AR) B1 B2 (BR : forall (_ : B1) (_ : B2), Type) (BM : Map4.Has BR), forall p1 p2 pR, Prod_mR A1 A2 AR AM B1 B2 BR BM p1 p2 (Prod_Rm A1 A2 AR AM B1 B2 BR BM p1 p2 pR) = pR. Elpi derive ThreeTypes. Check ThreeTypes_mRRmK : -forall A1 A2 (AR : A1 -> A2 -> Type) (AM : Map4.Has AR), -forall B1 B2 (BR : B1 -> B2 -> Type) (BM : Map4.Has BR), -forall C1 C2 (CR : C1 -> C2 -> Type) (CM : Map4.Has CR), +forall A1 A2 (AR : forall (_:A1) (_:A2), Type) (AM : Map4.Has AR), +forall B1 B2 (BR : forall (_:B1) (_:B2), Type) (BM : Map4.Has BR), +forall C1 C2 (CR : forall (_:C1) (_:C2), Type) (CM : Map4.Has CR), forall t1 t2 tR, ThreeTypes_mR A1 A2 AR AM B1 B2 BR BM C1 C2 CR CM t1 t2 (ThreeTypes_Rm A1 A2 AR AM B1 B2 BR BM C1 C2 CR CM t1 t2 tR) = tR. Elpi derive List. -Check List_mRRmK : forall A1 A2 (AR : A1 -> A2 -> Type) (AM : Map4.Has AR), forall l1 t2 lR, List_mR A1 A2 AR AM l1 t2 (List_Rm A1 A2 AR AM l1 t2 lR) = lR. \ No newline at end of file +Check List_mRRmK : forall A1 A2 (AR : forall (_ :A1) (_ : A2), Type) (AM : Map4.Has AR), forall l1 t2 lR, List_mR A1 A2 AR AM l1 t2 (List_Rm A1 A2 AR AM l1 t2 lR) = lR. \ No newline at end of file diff --git a/tests/inductives/test_mymap.v b/tests/inductives/test_mymap.v index 9a2e48b7..dd8add1d 100644 --- a/tests/inductives/test_mymap.v +++ b/tests/inductives/test_mymap.v @@ -2,7 +2,7 @@ From Trocq Require Import mymap. Require Import coverage. Unset Uniform Inductive Parameters. -Elpi derive.mymap False. +Elpi derive.mymap testFalse. Elpi derive.mymap testUnit. Elpi derive.mymap testBool. Elpi derive.mymap Wrap. From 89809de0b0db6a09baa1e1b426a8610c05ef057a Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Sun, 31 May 2026 00:08:08 +0200 Subject: [PATCH 27/42] recovers examples recover examples/std fixes examples/hott --- examples/list_option.v | 3 +-- generic/Param_bool.v | 2 +- generic/inductives/DeriveLib.v | 3 ++- hott/Stdlib.v | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/examples/list_option.v b/examples/list_option.v index b883aca9..85ae30db 100644 --- a/examples/list_option.v +++ b/examples/list_option.v @@ -67,11 +67,10 @@ Definition mapR (l : list A) (l' : list A') (lR : listR A A' AR l l') : listR B B' BR (map f l) (map f' l'). Proof. - induction lR; simpl. + elim: lR=> /= [| a1 a2 a_R l1 l2 lr]. - apply nilR. - apply consR. + apply (fR a1 a2 a_R). - + apply IHlR. Defined. Lemma option_to_list_map_morph (A B : Type) (f : A -> B) (xo : option A) : diff --git a/generic/Param_bool.v b/generic/Param_bool.v index 35e6f92a..fc7f4ed1 100644 --- a/generic/Param_bool.v +++ b/generic/Param_bool.v @@ -12,7 +12,7 @@ (*****************************************************************************) From Trocq Require Import Relnm. -From Trocq Require Export HoTTNotations. +From Trocq Require Import HoTTNotations. Set Universe Polymorphism. Unset Universe Minimization ToSet. diff --git a/generic/inductives/DeriveLib.v b/generic/inductives/DeriveLib.v index cd6bea81..b8fd44e0 100644 --- a/generic/inductives/DeriveLib.v +++ b/generic/inductives/DeriveLib.v @@ -1,6 +1,7 @@ (* Compatibility layer with elpi's derive *) From elpi Require Export elpi. -From Trocq Require Export Stdlib HoTTNotations. +From Trocq Require Export Stdlib. +From Trocq Require Import HoTTNotations. Definition eq_f := @ap. Register eq_f as elpi.derive.eq_f. diff --git a/hott/Stdlib.v b/hott/Stdlib.v index d6220505..aa8ab263 100644 --- a/hott/Stdlib.v +++ b/hott/Stdlib.v @@ -11,9 +11,9 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) +(* From elpi Require Export elpi. *) From HoTT Require Export HoTT. From Trocq Require Export HoTT_additions. -From elpi Require Export elpi. Module HoTTNotations. (* Stub for compatibility with stdlib version *) From 9eff89ab3245fe9049b3ed08b3ebc525376ef570 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Sun, 31 May 2026 00:40:57 +0200 Subject: [PATCH 28/42] updates dependencies update dependencies trocq-std opam temporary hott dep + dev dep update nix temporary nix dependency for hott as discussed in #79 and a temporary dependency for coq-elpi update nix, last PR got merged in coq-elpi master --- .nix/config.nix | 7 ++++++- .nix/coq-nix-toolbox.nix | 2 +- coq-trocq-dev.opam | 2 +- coq-trocq-hott.opam | 2 +- coq-trocq.opam | 2 +- 5 files changed, 10 insertions(+), 5 deletions(-) diff --git a/.nix/config.nix b/.nix/config.nix index 7eeabbd9..2a87d801 100644 --- a/.nix/config.nix +++ b/.nix/config.nix @@ -16,13 +16,18 @@ in { "rocq-9.0" = { rocqPackages = { rocq-core.override.version = "9.0"; }; - coqPackages = common-bundles // { coq.override.version = "9.0"; }; + coqPackages = common-bundles // { + coq.override.version = "9.0"; + coq-elpi.override.version = "ba3cc750eda486c85d94e3eb35fb0eba77609338"; # 3.4.0. is enough for trocq-std, trocq-hott needs https://github.com/LPCIC/coq-elpi/pull/1030 + }; }; "rocq-9.1" = { rocqPackages = { rocq-core.override.version = "9.1"; }; coqPackages = common-bundles // { coq.override.version = "9.1"; HoTT.override.version = "9dbe413246b53352d4891efb85cd2ea1a8d01c12"; # HoTT isn't available yet for 9.1 + coq-elpi.override.version = "ba3cc750eda486c85d94e3eb35fb0eba77609338"; # 3.4.0. is enough for trocq-std, trocq-hott needs https://github.com/LPCIC/coq-elpi/pull/1030 + }; }; ## Trocq is broken on Rocq-master diff --git a/.nix/coq-nix-toolbox.nix b/.nix/coq-nix-toolbox.nix index d1cb4e1d..22ddfe2f 100644 --- a/.nix/coq-nix-toolbox.nix +++ b/.nix/coq-nix-toolbox.nix @@ -1 +1 @@ -"32b164eef0752f2e0d2b57feaba9933a1ec590fb" +"dd198b999f8526670a6f71a28bc1ea6ef7393cc5" diff --git a/coq-trocq-dev.opam b/coq-trocq-dev.opam index 7c9214c3..f4a76777 100644 --- a/coq-trocq-dev.opam +++ b/coq-trocq-dev.opam @@ -38,7 +38,7 @@ build: [make "-j%{jobs}%"] install: [make "install"] depends: [ "coq" {>= "8.20" & < "9.2"} - "coq-elpi" {>= "2.5.2"} + "coq-elpi" {>= "3.4.0"} "coq-hott" "coq-mathcomp-algebra" ] diff --git a/coq-trocq-hott.opam b/coq-trocq-hott.opam index 4e4387b1..7ed38892 100644 --- a/coq-trocq-hott.opam +++ b/coq-trocq-hott.opam @@ -41,7 +41,7 @@ build: [make "-j%{jobs}%" "hott"] install: [make "install" "-C" "hott"] depends: [ "coq" {>= "8.20" & < "9.1"} - "coq-elpi" {= "2.5.2"} + "coq-elpi" {>= "3.4.0"} "coq-hott" ] diff --git a/coq-trocq.opam b/coq-trocq.opam index 0262b34f..b7f0fb48 100644 --- a/coq-trocq.opam +++ b/coq-trocq.opam @@ -41,7 +41,7 @@ build: [make "-j%{jobs}%" "std"] install: [make "install" "-C" "std"] depends: [ "coq" {>= "9.0" & < "9.2"} - "coq-elpi" {>= "2.5.2"} + "coq-elpi" {>= "3.4.0"} ] tags: [ From 9ad9f4cb40f9a43915510a6cd81926dae9709a73 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Fri, 5 Jun 2026 18:17:05 +0200 Subject: [PATCH 29/42] removing elpi warnings --- elpi/inductives/RsymK.elpi | 2 +- elpi/inductives/mRRmK.elpi | 2 +- elpi/inductives/mapn.elpi | 1 - elpi/inductives/mymap.elpi | 3 +-- elpi/inductives/relnm.elpi | 16 +++++++------- elpi/inductives/utils.elpi | 2 +- generic/inductives/Relnm.v | 6 +++--- generic/inductives/Rm.v | 6 +++--- generic/inductives/RsymK.v | 6 +++--- generic/inductives/injK.v | 4 ++-- generic/inductives/injection_lemmas.v | 4 ++-- generic/inductives/mR.v | 8 +++---- generic/inductives/mRRmK.v | 6 +++--- generic/inductives/mymap.v | 2 +- generic/inductives/sym.v | 6 +++--- generic/inductives/symK.v | 6 +++--- generic/inductives/test.v | 31 --------------------------- 17 files changed, 39 insertions(+), 72 deletions(-) delete mode 100644 generic/inductives/test.v diff --git a/elpi/inductives/RsymK.elpi b/elpi/inductives/RsymK.elpi index 2285ce78..2f2104de 100644 --- a/elpi/inductives/RsymK.elpi +++ b/elpi/inductives/RsymK.elpi @@ -31,7 +31,7 @@ implement-rsymK N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ - coq.env.indt GR _ TyParamNo _ _ KNs KTys, + coq.env.indt GR _ TyParamNo _ _ _ _, coq.env.global (indt GR) Ind, std.assert! (param Ind Ind TR) "derive.rsymK: use derive.param2 before", coq.typecheck TR TRTy _, diff --git a/elpi/inductives/mRRmK.elpi b/elpi/inductives/mRRmK.elpi index 4847671b..0a27d241 100644 --- a/elpi/inductives/mRRmK.elpi +++ b/elpi/inductives/mRRmK.elpi @@ -132,7 +132,7 @@ process-args Ksrc Kdest 0 InitArgs TyArgsNo _ Goal _ KR InjKs _ MRRMKEq R:- collect-arguments TyArgsNo InitArgs MRRM TyArgsDest Args1 Args2 Paths, %paths are all feed-injKs InjKs TyArgsDest Args1 Args2 Paths Eqs, invert-eqs Eqs IEqs, - std.map MRRMKEq (x\ r\ sigma TMP\ @keepunivs! => coq.elaborate-skeleton x _ TMP ok, r = TMP) MRRMKElab, + std.map MRRMKEq (x\ r\ sigma TMP\ (@keepunivs! => coq.elaborate-skeleton x _ TMP ok), r = TMP) MRRMKElab, invert-eqs {std.rev MRRMKElab} IEqs2, End = {{ lib:@trocq.idpath lp:IRTy lp:IR }}, coq.mk-app HD [IRTy,{whd1 MRRM},IR] RGoal, % KR a1 a2 ar1[I_Rm] b1 b2 br[I_Rm] diff --git a/elpi/inductives/mapn.elpi b/elpi/inductives/mapn.elpi index 8eeb89ed..0f1b8545 100644 --- a/elpi/inductives/mapn.elpi +++ b/elpi/inductives/mapn.elpi @@ -87,7 +87,6 @@ implement-mapM M GR RMapn :- func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ - coq.env.global (indt GR) Ind, std.fold {map-class.all-of-kind all} [] (M\ C\ C'\ sigma RMapn NameMapn FNameMapn CMapn Entry\ implement-mapM M GR RMapn, NameMapn is Prefix ^ "map" ^ {map-class.to_string M}, diff --git a/elpi/inductives/mymap.elpi b/elpi/inductives/mymap.elpi index 50d863d5..eadbff81 100644 --- a/elpi/inductives/mymap.elpi +++ b/elpi/inductives/mymap.elpi @@ -77,9 +77,8 @@ bo-k-args.aux K IndGR [A|As] [T|Ts] (prod _ S Ty) R :- coq.mk-app F [A] FA, bo-k-args.aux {coq.mk-app K [FA]} IndGR As Ts (Ty FA) R. bo-k-args.aux K IndGR [A|As] [T|Ts] (prod _ _ Ty) R :- - coq.safe-dest-app T IndT ArgsIndT, + coq.safe-dest-app T IndT _, coq.env.global IndGR IndT, !, - coq.mk-app IndT Args2 TDest, mymap-db IndT IndT F, coq.mk-app F [A] FA, bo-k-args.aux {coq.mk-app K [FA]} IndGR As Ts (Ty FA) R. diff --git a/elpi/inductives/relnm.elpi b/elpi/inductives/relnm.elpi index a8aeb9d3..c0d7d401 100644 --- a/elpi/inductives/relnm.elpi +++ b/elpi/inductives/relnm.elpi @@ -5,14 +5,14 @@ namespace derive.relnm { pred refine-covariant-tyargs i: list term, i:term, i:list term, o: list term. refine-covariant-tyargs [] _ L L. -refine-covariant-tyargs [A1, A2, AR | L2] Refiner Acc R :- +refine-covariant-tyargs [A1, A2, AR | L2] Refiner Acc R :- coq.mk-app Refiner [A1,A2,AR] Refined, std.append Acc [A1, A2, AR, Refined] NewAcc, refine-covariant-tyargs L2 Refiner NewAcc R. pred refine-Lsym i: list term, i:list term, i:term, i:list term, o: list term. refine-Lsym [] [] _ L L. -refine-Lsym [A1, A2, AR | L2] [_,_,_,Refined | L2Ref] Refiner Acc R :- +refine-Lsym [A1, A2, AR | L2] [_,_,_,Refined | L2Ref] Refiner Acc R :- coq.safe-dest-app Refined _ Lref, coq.mk-app Refiner Lref RefinedContra, std.append Acc [A1, A2, AR, RefinedContra] NewAcc, @@ -20,7 +20,7 @@ refine-Lsym [A1, A2, AR | L2] [_,_,_,Refined | L2Ref] Refiner Acc R :- % TyargNo, relnm Type, mapnCov, mapmContra, eq_map, rsymK, list of args pred implement-relnm i:int, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:term, i:list term, o:term. -implement-relnm 0 _ +implement-relnm 0 _ MapNCov MapMContra Eq_map RsymK CovariantNN ContravariantNN BuildNN LRev R :- !, std.rev LRev L, @@ -31,7 +31,7 @@ implement-relnm 0 _ coq.mk-app MapMContra LContra MapContravariant, coq.mk-app RsymK LSym RsymKSym, R = {{ lp:BuildNN _ _ _ lp:MapCovariant (lp:Eq_map lp:RsymKSym lp:MapContravariant )}}. -implement-relnm N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) +implement-relnm N (prod AN1 ATy1 a1\ prod AN2 ATy2 a2\ prod ARN (ARTy a1 a2) ar\ (Bo a1 a2 ar)) MapNCov MapMContra Eq_map RsymK CovariantNN ContravariantNN BuildNN L (fun AN1 ATy1 a1\ fun AN2 ATy2 a2\ fun ARN (ARTy a1 a2) ar\ (R a1 a2 ar)) :- M is N - 1, @@ -52,7 +52,7 @@ get-eq-map map4 {{ lib:trocq.eq_map4 }}. pred generate-relNM i:inductive, i:param-class, o: term, o: term. generate-relNM GR (pc N M as PC) ReTy Re :- - coq.env.indt GR _ TyParamNo _ _ KNs KTys, + coq.env.indt GR _ TyParamNo _ _ _ _, coq.env.global (indt GR) Ind, std.assert! (param Ind Ind TR) "derive.relNM: use derive.param2 before", coq.typecheck TR TRTy _, @@ -69,15 +69,15 @@ generate-relNM GR (pc N M as PC) ReTy Re :- func main inductive, string -> list prop. main GR Prefix Clauses :- std.do! [ coq.env.global (indt GR) I, - std.fold {param-class.all-of-kind all} [] - (PC\ Cls\ Cls'\ + std.fold {param-class.all-of-kind all} [] + (PC\ Cls\ Cls'\ sigma N M C ReTy Re Name FName\ (pc N M) = PC, generate-relNM GR PC ReTy Re, Name is Prefix ^ "rel" ^ {map-class.to_string N} ^ {map-class.to_string M}, coq.ensure-fresh-global-id Name FName, coq.env.add-const FName Re ReTy _ C, - Cls' = [trocq.db.param-ind I PC (global (const C))| Cls]) + Cls' = [trocq.db.param-ind I PC (global (const C))| Cls]) RCls, Clauses = [trocq.db.param-ind-done GR | RCls], std.forall Clauses (x\ diff --git a/elpi/inductives/utils.elpi b/elpi/inductives/utils.elpi index c436cd41..e23e552d 100644 --- a/elpi/inductives/utils.elpi +++ b/elpi/inductives/utils.elpi @@ -209,7 +209,7 @@ rewrite-with [Eq|Eqs] [Pat|Pats] End R :- rewrite-with Eqs Pats End RestSkel, (@keepunivs! => coq.elaborate-skeleton RestSkel _ Rest ok), RSkel = (T Rest), - (@keepunivs! => coq.elaborate-skeleton RSkel _ R Err). + (@keepunivs! => coq.elaborate-skeleton RSkel _ R ok). % checks if two types refer to the same indt, and returns a canonical one. pred cmp-indt i:term, i:term, o:term, o:term. diff --git a/generic/inductives/Relnm.v b/generic/inductives/Relnm.v index fab5ccab..ecbb073c 100644 --- a/generic/inductives/Relnm.v +++ b/generic/inductives/Relnm.v @@ -1,8 +1,8 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) -From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. -From Trocq.Elpi Extra Dependency "inductives/relnm.elpi" as relnm. +From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) +From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as utils. +From Trocq.Elpi.inductives Extra Dependency "relnm.elpi" as relnm. From Trocq Require Import sym symK RsymK Param_lemmas mapn map4. Import HoTTNotations. diff --git a/generic/inductives/Rm.v b/generic/inductives/Rm.v index 68b2b83a..d654239b 100644 --- a/generic/inductives/Rm.v +++ b/generic/inductives/Rm.v @@ -1,7 +1,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Elpi Extra Dependency "inductives/Rm.elpi" as Rm. -From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. -From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. +From Trocq.Elpi.inductives Extra Dependency "Rm.elpi" as Rm. +From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. +From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as algo_utils. From elpi Require Import elpi. From Trocq Require Export Hierarchy Param_lemmas mymap. diff --git a/generic/inductives/RsymK.v b/generic/inductives/RsymK.v index b036deea..6b8e5b93 100644 --- a/generic/inductives/RsymK.v +++ b/generic/inductives/RsymK.v @@ -1,9 +1,9 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) -From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. -From Trocq.Elpi Extra Dependency "inductives/RsymK.elpi" as rsymK. +From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) +From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as utils. +From Trocq.Elpi.inductives Extra Dependency "RsymK.elpi" as rsymK. From Trocq Require Import sym symK. Import HoTTNotations. diff --git a/generic/inductives/injK.v b/generic/inductives/injK.v index 235841e1..993e0c5b 100644 --- a/generic/inductives/injK.v +++ b/generic/inductives/injK.v @@ -1,7 +1,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Elpi Extra Dependency "inductives/injK.elpi" as injK. -From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. +From Trocq.Elpi.inductives Extra Dependency "injK.elpi" as injK. +From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as algo_utils. From Trocq Require Export injection_lemmas. From Trocq Require Import DeriveLib HoTTNotations Stdlib Hierarchy. diff --git a/generic/inductives/injection_lemmas.v b/generic/inductives/injection_lemmas.v index e8bc3d76..6d9c4093 100644 --- a/generic/inductives/injection_lemmas.v +++ b/generic/inductives/injection_lemmas.v @@ -1,8 +1,8 @@ From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Elpi Extra Dependency "inductives/injection_lemmas.elpi" as injections. -From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. +From Trocq.Elpi.inductives Extra Dependency "injection_lemmas.elpi" as injections. +From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as algo_utils. From elpi.apps Require Export derive. From elpi.apps Require Export derive.projK. diff --git a/generic/inductives/mR.v b/generic/inductives/mR.v index 23e7b576..d3566473 100644 --- a/generic/inductives/mR.v +++ b/generic/inductives/mR.v @@ -1,9 +1,9 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. -From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. -From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. -From Trocq.Elpi Extra Dependency "inductives/mR.elpi" as mR. -From Trocq.Elpi Extra Dependency "inductives/injection_lemmas.elpi" as injections. +From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. +From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as utils. +From Trocq.Elpi.inductives Extra Dependency "mR.elpi" as mR. +From Trocq.Elpi.inductives Extra Dependency "injection_lemmas.elpi" as injections. From elpi Require Import elpi. From elpi.apps Require Export derive.param2 derive.isK. (* for isK db required by discriminate *) diff --git a/generic/inductives/mRRmK.v b/generic/inductives/mRRmK.v index 796c50d9..80a57880 100644 --- a/generic/inductives/mRRmK.v +++ b/generic/inductives/mRRmK.v @@ -1,7 +1,7 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Elpi Extra Dependency "inductives/mRRmK.elpi" as mRRmK. -From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. -From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. +From Trocq.Elpi.inductives Extra Dependency "mRRmK.elpi" as mRRmK. +From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. +From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as algo_utils. From Trocq Require Export mymap injK mR Rm. From elpi Require Import elpi. diff --git a/generic/inductives/mymap.v b/generic/inductives/mymap.v index bef8a04a..c0864a7a 100644 --- a/generic/inductives/mymap.v +++ b/generic/inductives/mymap.v @@ -1,5 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From Trocq.Elpi Extra Dependency "inductives/mymap.elpi" as mymap. +From Trocq.Elpi.inductives Extra Dependency "mymap.elpi" as mymap. From elpi Require Import elpi. From elpi.apps Require Import derive. diff --git a/generic/inductives/sym.v b/generic/inductives/sym.v index f3748a77..bac4f0b6 100644 --- a/generic/inductives/sym.v +++ b/generic/inductives/sym.v @@ -1,8 +1,8 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. -From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. -From Trocq.Elpi Extra Dependency "inductives/sym.elpi" as sym. +From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. +From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as utils. +From Trocq.Elpi.inductives Extra Dependency "sym.elpi" as sym. From elpi.apps Require Export derive derive.param2. From Trocq Require Export Hierarchy Stdlib. diff --git a/generic/inductives/symK.v b/generic/inductives/symK.v index eee2c5b5..069d1699 100644 --- a/generic/inductives/symK.v +++ b/generic/inductives/symK.v @@ -1,9 +1,9 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. -From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as utils. -From Trocq.Elpi Extra Dependency "inductives/symK.elpi" as symK. +From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. +From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as utils. +From Trocq.Elpi.inductives Extra Dependency "symK.elpi" as symK. From Trocq Require Import sym. From elpi.apps Require Import derive derive.param2. diff --git a/generic/inductives/test.v b/generic/inductives/test.v deleted file mode 100644 index 3c784e4f..00000000 --- a/generic/inductives/test.v +++ /dev/null @@ -1,31 +0,0 @@ -From elpi.apps Require Export derive. - -From elpi.apps Require Export - derive.param2. - -From Trocq Require Export HoTTNotations Hierarchy Stdlib. - -Unset Universe Polymorphism. -Inductive EmptyR : Empty -> Empty -> Type :=. -(* param2 does not handle universe polymorphic inductives. - Hence we have define EmptyR before seting Universe Polymorphism. *) -Elpi derive.param2.register "False" "EmptyR". - -Set Universe Polymorphism. - From Trocq Require Export injection_lemmas injK. - -#[verbose] Elpi derive Empty. -#[verbose] Elpi derive.injections Empty. -Elpi derive.injK Empty. -Elpi derive Empty. - - derive.projK. - -(* From Trocq Require Export sym symK RsymK. *) -(* From Trocq Require Export mymap mR Rm mRRmK mapn Relnm. *) - -Unset Universe Minimization ToSet. - -#[verbose] Elpi derive Empty. -Definition Param01_Empty := False_rel01. -Definition Param10_Empty := False_rel10. From 7d985053d041f9a910c36770e2e2fc5e43589dd4 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Mon, 22 Jun 2026 17:09:33 +0200 Subject: [PATCH 30/42] coq.typecheck ok --- elpi/inductives/Rm.elpi | 2 +- elpi/inductives/RsymK.elpi | 2 +- elpi/inductives/mR.elpi | 6 ++++-- elpi/inductives/mRRmK.elpi | 2 +- elpi/inductives/relnm.elpi | 2 +- elpi/inductives/symK.elpi | 2 +- 6 files changed, 9 insertions(+), 7 deletions(-) diff --git a/elpi/inductives/Rm.elpi b/elpi/inductives/Rm.elpi index bf79e5eb..aefd0baf 100644 --- a/elpi/inductives/Rm.elpi +++ b/elpi/inductives/Rm.elpi @@ -138,7 +138,7 @@ main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ KNs KTys, coq.env.global (indt GR) Ind, std.assert! (paramR Ind Ind TR) "derive.Rm: use derive.param2 before", - coq.typecheck TR TRTy _, + coq.typecheck TR TRTy ok, std.assert! (mymap-def (indt GR) IndMapGR) "derive.Rm: use derive.mymap before", mk-mR-type-Rm TyParamNo TRTy {coq.env.global IndMapGR} {{ Type }} TR MRTy, (@keepunivs! => std.assert-ok! (coq.elaborate-skeleton MRTy _ MRTyE) "derive.Rm generates illtyped type"), diff --git a/elpi/inductives/RsymK.elpi b/elpi/inductives/RsymK.elpi index 2f2104de..56a27221 100644 --- a/elpi/inductives/RsymK.elpi +++ b/elpi/inductives/RsymK.elpi @@ -34,7 +34,7 @@ main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ _ _, coq.env.global (indt GR) Ind, std.assert! (param Ind Ind TR) "derive.rsymK: use derive.param2 before", - coq.typecheck TR TRTy _, + coq.typecheck TR TRTy ok, mk-mR-type-rsymK TyParamNo TRTy TR {{ fun (A B : Type) => A <->> B }} SymKTy, std.assert-ok! (coq.elaborate-skeleton SymKTy _ SymKTyE) "derive.rsymK generates illtyped type", std.assert! (sym-db Ind SymInd) "derive.rsymK: use derive.sym before", diff --git a/elpi/inductives/mR.elpi b/elpi/inductives/mR.elpi index 1b2cf01f..49adbe38 100644 --- a/elpi/inductives/mR.elpi +++ b/elpi/inductives/mR.elpi @@ -22,7 +22,8 @@ sub-branch YTy TyParamNo K1 Args1 ArgTys1 K2 Args2 ArgTys2 Bo (fun `e` ETy e\ (R coq.mk-app K1 Args1 X, coq.mk-app K2 Args2 Y, BoXY = Bo X Y, - coq.elaborate-skeleton BoXY _ BoXYE _, + coq.elaborate-skeleton BoXY _ BoXYE ok, + !, BoXYE = prod _ ETy G, whd K1 [] Constr1 TypeArgs1, whd K2 [] Constr2 TypeArgs2, @@ -32,6 +33,7 @@ sub-branch YTy TyParamNo K1 Args1 ArgTys1 K2 Args2 ArgTys2 Bo (fun `e` ETy e\ (R % Each branch matches on Y as Y0, returning a term of type (Bo (K KArgs) Y0) given by matrix. pred mkBranch i:int, i:(term -> term -> term), i:term, i:term, i:term, i:term, i:list term, i:list term, o:term. mkBranch TyParamNo Bo Y YTy K _ Ts TYs R :- + !, coq.mk-app K Ts X, coq.build-match Y YTy (rty-2 Bo X) (k2\ _\ ts\ tys\ @@ -173,7 +175,7 @@ main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ UnifParamNo _ _ _ _, coq.env.global (indt GR) Ind, param Ind Ind TR, - coq.typecheck TR TRTy _, + coq.typecheck TR TRTy ok, mymap-def (indt GR) IndMapGR, mk-mR-type-mR UnifParamNo TRTy {coq.env.global IndMapGR} {{ Type }} TR MRTy, std.assert-ok! (coq.elaborate-skeleton MRTy _ MRTyE) "derive.mR generates illtyped type", diff --git a/elpi/inductives/mRRmK.elpi b/elpi/inductives/mRRmK.elpi index 0a27d241..6e077d20 100644 --- a/elpi/inductives/mRRmK.elpi +++ b/elpi/inductives/mRRmK.elpi @@ -266,7 +266,7 @@ main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ KNs KTys, coq.env.global (indt GR) Ind, param Ind Ind TR, - coq.typecheck TR TRTy _, + coq.typecheck TR TRTy ok, mymap-def (indt GR) IndMapGR, coq.env.global IndMapGR IndMap, coq.env.global {mR-def (indt GR)} MR, diff --git a/elpi/inductives/relnm.elpi b/elpi/inductives/relnm.elpi index c0d7d401..a4ff1fff 100644 --- a/elpi/inductives/relnm.elpi +++ b/elpi/inductives/relnm.elpi @@ -55,7 +55,7 @@ generate-relNM GR (pc N M as PC) ReTy Re :- coq.env.indt GR _ TyParamNo _ _ _ _, coq.env.global (indt GR) Ind, std.assert! (param Ind Ind TR) "derive.relNM: use derive.param2 before", - coq.typecheck TR TRTy _, + coq.typecheck TR TRTy ok, trocq.db.rel PC PRelNM BuildNM _ CovNM ContraNM, mk-mR-type-relnm TyParamNo TRTy TR (pglobal PRelNM _) RTy, std.assert-ok! (coq.elaborate-skeleton RTy _ ReTy) "derive.relNM generates illtyped type", diff --git a/elpi/inductives/symK.elpi b/elpi/inductives/symK.elpi index 53ef09ca..2c3f738a 100644 --- a/elpi/inductives/symK.elpi +++ b/elpi/inductives/symK.elpi @@ -141,7 +141,7 @@ main GR Prefix Clauses :- std.do! [ coq.env.indt GR _ TyParamNo _ _ KNs KTys, coq.env.global (indt GR) Ind, std.assert! (param Ind Ind TR) "derive.sym: use derive.param2 before", - coq.typecheck TR TRTy _, + coq.typecheck TR TRTy ok, std.assert! (sym-db Ind SymInd) "derive.sym: use derive.sym before", mk-mR-type-symK TyParamNo TRTy TR SymInd SymKTy, (@keepunivs! => std.assert-ok! (coq.elaborate-skeleton SymKTy _ SymKTyE) "derive.symK generates illtyped type"), From 06b97ef56c32cf1924a2ae1662fa7bf41eb8ce56 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Mon, 22 Jun 2026 17:20:46 +0200 Subject: [PATCH 31/42] rm comments --- elpi/inductives/mymap.elpi | 12 ------------ examples/std/Vector_tuple.v | 3 --- generic/inductives/Relnm.v | 10 ---------- hott/Stdlib.v | 1 - 4 files changed, 26 deletions(-) diff --git a/elpi/inductives/mymap.elpi b/elpi/inductives/mymap.elpi index eadbff81..a379fdeb 100644 --- a/elpi/inductives/mymap.elpi +++ b/elpi/inductives/mymap.elpi @@ -62,14 +62,6 @@ bo-k-args ParamsRev IndGR K _ Args Tys R :- (bo-k-args.aux {coq.mk-app {coq.env.global (indc GR)} Params} IndGR Args Tys KT R), !. % the first combination that typechecks -% pred map.aux i:term, o:term. -% map.aux (prod T N B) (prod T N B). -% map.aux FRel R :- -% coq.mk-app {{ map }} [FRel] R. -% pred bobo i:term, o:term. -% bobo T U :- -% mymap-db T U _. - pred bo-k-args.aux i:term, i:gref, 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 IndGR [A|As] [T|Ts] (prod _ S Ty) R :- @@ -118,8 +110,6 @@ bo-params N Lno Ity1 Ity2 (prod A Sty1 Rty1) (prod _ Sty2 Rty2) Ps R :- coq.name-suffix A "f" Af, N1 is N + 1, (pi a b r f \ mk-map-ty a Sty1 b Sty2 (RAB a b) r (FAB a b r) f _ (Clause a b r f)), - % todo: add fun for map - %R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Ar (RAB a b) r\ fun Af (FAB a b r) f\ Bo a b r f), R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Ar (RAB a b) r\ fun Af (FAB a b r) f\ Bo a b r f), pi a b r f\ sigma Ity1A Ity2A \ coq.mk-app Ity1 [a] Ity1A, @@ -168,7 +158,6 @@ mk-map-ty A (prod _ S1 T1) B (prod _ _ T2) RelTy RTerm (prod `x` S1 x\ R x) F N mk-map-ty Ax (T1 x) Bx (T2 x) RelTy RTerm (R x) {coq.mk-app F [x]} M (C x), N is M + 1), map-pi C C1. -% mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ {{ Param10.Rel lp:A lp:B }} (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ (prod `x` A _\ B) _ _ (app [G|GS] as F) 0 [mymap-db PLA PLB PLF,mymap-db A B F] :- drop-last 1 XS LA, drop-last 1 YS LB, @@ -177,7 +166,6 @@ mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ (prod `x` A _\ B) _ _ (app [G|GS coq.mk-app Y LB PLB, coq.mk-app G LF PLF. mk-map-ty A _ B _ RelTy RTerm Map F 0 [mymap-db A B {{ lp:M1mTerm lp:A lp:B _ lp:F }} ] :- - % todo: fix use of universe coq.env.global {{:gref lib:trocq.map1.map }} M1mTerm, RelTy = {{ lp:A -> lp:B -> Type }} , Map = {{ lib:trocq.map1 lp:RTerm }}. diff --git a/examples/std/Vector_tuple.v b/examples/std/Vector_tuple.v index c008e65e..aa4fde3a 100644 --- a/examples/std/Vector_tuple.v +++ b/examples/std/Vector_tuple.v @@ -350,9 +350,6 @@ Proof. - exact (@R_in_mapK_bv_bnat k). Defined. - -(* Set Printing All. -Set Printing Universes. *) Definition Param44_bnat_bv_d {k : nat} : Param44.Rel (bounded_nat k) (bitvector k). Proof. diff --git a/generic/inductives/Relnm.v b/generic/inductives/Relnm.v index ecbb073c..bb21913b 100644 --- a/generic/inductives/Relnm.v +++ b/generic/inductives/Relnm.v @@ -11,16 +11,6 @@ From elpi.apps Require Import derive derive.param2. From Trocq Require Export Stdlib Hierarchy Param_lemmas. Unset Uniform Inductive Parameters. -(* Elpi Db derive.rel44.db lp:{{ - - % [rel44 I S] links I inductive type, - % with the function showing i1 i2, [| I |]^ i2 i1 <->> [| I |] i1 i2 - pred rel44-db i:term, o:term. - - % [rel44-done T K] means T K was already derived - pred rel44-done o:inductive. -}}. *) - Elpi Command derive.relnm. Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. diff --git a/hott/Stdlib.v b/hott/Stdlib.v index aa8ab263..1f6c76fb 100644 --- a/hott/Stdlib.v +++ b/hott/Stdlib.v @@ -11,7 +11,6 @@ (* * see LICENSE file for the text of the license *) (*****************************************************************************) -(* From elpi Require Export elpi. *) From HoTT Require Export HoTT. From Trocq Require Export HoTT_additions. From e7b6084570e4d10efa7a9848605fbce0f9f889f3 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Tue, 23 Jun 2026 15:59:44 +0200 Subject: [PATCH 32/42] pi + decl into pi-decl + tail-cut --- elpi/inductives/mymap.elpi | 22 +++++++++++----------- tests/_CoqProject.hott | 2 +- tests/_CoqProject.std | 2 +- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/elpi/inductives/mymap.elpi b/elpi/inductives/mymap.elpi index a379fdeb..292c6daa 100644 --- a/elpi/inductives/mymap.elpi +++ b/elpi/inductives/mymap.elpi @@ -111,18 +111,18 @@ bo-params N Lno Ity1 Ity2 (prod A Sty1 Rty1) (prod _ Sty2 Rty2) Ps R :- N1 is N + 1, (pi a b r f \ mk-map-ty a Sty1 b Sty2 (RAB a b) r (FAB a b r) f _ (Clause a b r f)), R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Ar (RAB a b) r\ fun Af (FAB a b r) f\ Bo a b r f), - pi a b r f\ sigma Ity1A Ity2A \ - coq.mk-app Ity1 [a] Ity1A, - coq.mk-app Ity2 [b] Ity2A, - Clause a b r f ==> - decl a A1 Sty1 ==> - decl b A2 Sty2 ==> - (coq.elaborate-skeleton (RAB a b) _ (RABTy a b) ok, - decl r Ar (RABTy a b) ==> + @pi-decl A1 Sty1 a\ + @pi-decl A2 Sty2 b\ + coq.elaborate-skeleton (RAB a b) _ (RABTy a b) ok, + coq.mk-app Ity1 [a] (Ity1A a), + coq.mk-app Ity2 [b] (Ity2A b), + @pi-decl Ar (RABTy a b) r\ coq.elaborate-skeleton (FAB a b r) _ (FABTy a b r) ok, - decl f Af (FABTy a b r) ==> - mymap-db a b (FAB a b r)==> - bo-params N1 Lno Ity1A Ity2A (Rty1 a) (Rty2 b) [b|Ps] (Bo a b r f)). + pi f\ + decl f Af (FABTy a b r) =!=> + Clause a b r f =!=> + (mymap-db a b (FAB a b r)==> + bo-params N1 Lno (Ity1A a) (Ity2A b) (Rty1 a) (Rty2 b) [b|Ps] (Bo a b r f)). bo-params N Lno Ity1 Ity2 T OT Ps R :- whd1 T T1, whd1 OT OT1, !, diff --git a/tests/_CoqProject.hott b/tests/_CoqProject.hott index 3a63ca38..e002a367 100644 --- a/tests/_CoqProject.hott +++ b/tests/_CoqProject.hott @@ -3,7 +3,7 @@ -arg -w -arg +elpi.typechecker -R ../hott/ Trocq --R ../hott/generic/inductives Trocq +-R ../generic/inductives Trocq -R ../elpi/ Trocq.Elpi unit_arrow_contravariant.v diff --git a/tests/_CoqProject.std b/tests/_CoqProject.std index 2758bfad..dce87c4b 100644 --- a/tests/_CoqProject.std +++ b/tests/_CoqProject.std @@ -2,7 +2,7 @@ -arg -w -arg +elpi.typechecker -R ../std/ Trocq --R ../std/generic/inductives Trocq +-R ../generic/inductives Trocq -R ../elpi/ Trocq.Elpi unit_arrow_contravariant.v From 1705dd652499383377a72e67744c7625562bef8e Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Tue, 23 Jun 2026 22:33:05 +0200 Subject: [PATCH 33/42] cleaning outdated files + moving definition of RmmRK --- generic/demo.v | 272 ------- generic/exec_bool.v | 1498 ------------------------------------ generic/inductives/Gen.v | 10 - hott/Param_lemmas.v | 127 +++ hott/Stdlib.v | 13 +- std/Param_lemmas.v | 129 +++- std/Stdlib.v | 25 + std/algo/aignore/testing.v | 54 -- tests/inductives/rmmrK.v | 113 --- 9 files changed, 292 insertions(+), 1949 deletions(-) delete mode 100644 generic/demo.v delete mode 100644 generic/exec_bool.v delete mode 100644 generic/inductives/Gen.v delete mode 100644 std/algo/aignore/testing.v delete mode 100644 tests/inductives/rmmrK.v diff --git a/generic/demo.v b/generic/demo.v deleted file mode 100644 index 6be2659b..00000000 --- a/generic/demo.v +++ /dev/null @@ -1,272 +0,0 @@ -From HB Require Import structures. -From Coq Require Import ssreflect ssrfun ssrbool. -From mathcomp Require Import eqtype. -Require Import HoTT_additions Hierarchy. -From elpi.apps Require Import derive.std. - -Require Import param2_inhab. - -Set Universe Polymorphism. -Unset Universe Minimization ToSet. - -Section rel_uniq_refl. - - Variable A : eqType. - - Variable AR : A -> A -> Type. - Hypothesis AR_refl : forall a : A, AR a a. - Hypothesis AR_eqb : forall a1 a2 : A, AR a1 a2 -> eq_op a1 a2. - Hypothesis rel_refl_uniq : forall (a : A) (r1 : AR a a), r1 = (AR_refl a). - - Lemma eqb_AR (a1 a2 : A) : eq_op a1 a2 -> AR a1 a2. - Proof. by move=> /eqP->; apply AR_refl. Qed. - - Lemma AR_irrel : forall (a1 a2 : A) (r1 r2 : AR a1 a2), r1 = r2. - Proof. - move=> a1 a2 r. - have e : a1 = a2 by apply /eqP; apply AR_eqb. - move: r; rewrite {}e=> r1 r2. - by rewrite (rel_refl_uniq _ r1) (rel_refl_uniq _ r2). - Qed. - - Definition mapR : A -> A := idmap. - - Lemma mR : forall a1 a2 : A, mapR a1 = a2 -> AR a1 a2. - Proof. by move=> a1 a2; by rewrite /mapR=> ->; apply AR_refl. Qed. - - Lemma Rm : forall a1 a2 : A, AR a1 a2 -> idmap a1 = a2. - Proof. by move=> /= a1 a2 /AR_eqb /eqP ->. Qed. - - Lemma mRRmK : forall (a1 a2 : A) (r : AR a1 a2), mR a1 a2 (Rm a1 a2 r) = r. - Proof. by move=> a1 a2 r; apply AR_irrel. Qed. - - Lemma Map4_AR : Map4.Has AR. - Proof. - unshelve econstructor. - by apply mapR. - by apply mR. - by apply Rm. - by apply mRRmK. - Qed. - - Lemma AR_sym : forall a1 a2, AR a1 a2 -> AR a2 a1. - Proof. by move=> a1 a2 /AR_eqb/eqP ->; apply AR_refl. Qed. - - Lemma AR_sym_R : forall (a1 a2 : A), sym_rel AR a1 a2 <->> AR a1 a2. - Proof. - intros a1 a2; unshelve eexists _,_ . - - by apply AR_sym. - - by apply AR_sym. - - by move=> r; apply AR_irrel. - Qed. - - Lemma Param44_AR : Param44.Rel A A. - Proof. - unshelve econstructor. - - exact AR. - - exact Map4_AR. - - apply (fun e => @eq_Map4 _ _ (sym_rel AR) AR e Map4_AR). - apply AR_sym_R. - Qed. - -End rel_uniq_refl. - -Unset Universe Polymorphism. -Require Import Coq.Program.Equality. - -Inductive Bool := FF | TT. -Elpi derive Bool. -Elpi derive.param2.inhab Bool_R. - -HB.instance Definition _ := hasDecEq.Build Bool Bool_eqb_OK. - - Lemma Param44_Bool : Param44.Rel Bool Bool. - Proof. - unshelve eapply (@Param44_AR Bool Bool_R). - + exact: Bool_R_inhab. - + by move=> a1 a2 []. - + by move=> a r1 /=; dependent destruction r1. - Qed. - -(* Require Import test_param. *) - Module tests. - - Inductive empty := . - Elpi derive empty. - Elpi derive.param2.inhab empty_R. - - - HB.instance Definition _ := hasDecEq.Build empty empty_eqb_OK. - - Lemma Param44_empty : Param44.Rel empty empty. - Proof. - unshelve eapply (@Param44_AR empty empty_R). - + exact: empty_R_inhab. - + by move=> a1 a2 []. - + by move=> a r1 /=; dependent destruction r1. - Qed. - - Inductive peano := Zero | Succ (n : peano). - Elpi derive peano. - Elpi derive.param2.inhab peano_R. - HB.instance Definition _ := hasDecEq.Build peano peano_eqb_OK. - - - Lemma peano_R_irrel n1 n2 (r1 r2 : peano_R n1 n2) : r1 = r2. - Proof. by dependent induction r1=> [//|/=]; f_equal; dependent destruction r2=> //; f_equal; apply IHr1. Qed. - Lemma Param44_peano : Param44.Rel peano peano. - Proof. - unshelve eapply (@Param44_AR peano peano_R). - + exact: peano_R_inhab. - + by move=> a1 a2; elim=> [//| n1 n2 r'] /eqP->. - + by move=> a r1; apply peano_R_irrel. - Qed. - - (* Inductive option A := None | Some (_ : A). *) - - (* Inductive pair A B := Comma (a : A) (b : B). *) - - (* Inductive seq A := Nil | Cons (x : A) (xs : seq A). *) - - Inductive box_peano := Box (n:peano). - Elpi derive box_peano. - Elpi derive.param2.inhab box_peano_R. - HB.instance Definition _ := hasDecEq.Build box_peano box_peano_eqb_OK. - - Lemma Param44_box_peano : Param44.Rel box_peano box_peano. - Proof. - unshelve eapply (@Param44_AR box_peano box_peano_R). - + exact: box_peano_R_inhab. - + by move=> a1 a2; elim=> [n1 n2 r']; apply/eqP; f_equal; elim: r'=> [//| n1' n2' r''] ->. - + move=> a /= r1; dependent destruction r1=> []. - dependent destruction n_R=> [//|]; rewrite /=; f_equal. - by apply peano_R_irrel. - Qed. - - (* Inductive rose (A : Type) := Leaf (a : A) | Node (sib : seq (rose A)). *) - - (* Inductive rose_p (A B : Type) := Leafp (p : pair A B) | Nodep (sib : pair (rose_p A B) (rose_p A B)). *) - - (* Inductive rose_o (A : Type) := Leafo (a : A) | Nodeo (x: pair (rose A) (rose A)) (sib : option (seq (rose A))). *) - - (* Inductive nest A := NilN | ConsN (x : A) (xs : nest (pair A A)). *) - - (* Fail Inductive bush A := BNil | BCons (x : A) (xs : bush (bush A)). *) - - (* Inductive w A := via (f : A -> w A). *) - - (* Inductive vect A : peano -> Type := VNil : vect A Zero | VCons (x : A) n (xs : vect A n) : vect A (Succ n). *) - - (* Inductive dyn := box (T : Type) (t : T). *) - - (* Inductive zeta Sender (Receiver := Sender) := Envelope (a : Sender) (ReplyTo := a) (c : Receiver). *) - - (* Inductive beta (A : (fun x : Type => x) Type) := Redex (a : (fun x : Type => x) A). *) - - Inductive iota := Why n (a : match n in peano return Type with Zero => peano | Succ _ => unit end). - (* Check iota. *) - - Inductive large := - | K1 (_ : unit) - | K2 (_ : unit) (_ : unit) - | K3 (_ : unit) (_ : unit) (_ : unit) - | K4 (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K5 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K6 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K7 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K8 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K9 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K10(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K11(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K12(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K13(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K14(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K15(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K16(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K17(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K18(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K19(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K20(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K21(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K22(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K23(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K24(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K25(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) - | K26(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit). - - Inductive prim_int := PI (i : PrimInt63.int). - Inductive prim_float := PF (f : PrimFloat.float). - (* Inductive prim_string := PS (s : lib:elpi.pstring). *) - - Record fo_record := { f1 : peano; f2 : unit; }. - - (* Record pa_record A := { f3 : peano; f4 : A; }. *) - - (* Set Primitive Projections. *) - (* Record pr_record A := { pf3 : peano; pf4 : A; }. *) - (* Unset Primitive Projections. *) - - (* Record dep_record := { f5 : peano; f6 : vect unit f5; }. *) - - Variant enum := E1 | E2 | E3. - - - (* Record sigma_bool := { depn : peano; depeq : is_zero depn = true }. *) - - (* Record sigma_bool2 := { depn2 : peano; depeq2 : lib:elpi.is_true (is_zero depn2) }. *) - - Fixpoint is_leq (n m:peano) : bool := - match n, m with - | Zero, _ => true - | Succ n, Succ m => is_leq n m - | _, _ => false - end. - - Inductive ord (p : peano) := mkOrd (n : peano) (l : is_leq n p = true). - - Inductive ord2 (p : peano) := mkOrd2 (o1 o2 : ord p). - - Inductive val := V (p : peano) (oo : ord p). - - (* to make the coverage cound correct -Inductive eq := ... -Inductive bool := ... -we don't have a copy here because some DBs have special rules*) - - End tests. - - Elpi derive Inductive Peano := Zero | Succ (p : Peano). - - Section tests. - - Lemma RBool_refl (b : Bool) : BoolR b b. - Proof. by case b; constructor. Defined. - - Require Import Coq.Program.Equality. - - Lemma RBool_uniq : forall b (bR : BoolR b b), bR = RBool_refl b. - Proof. - move=> b bR. - by dependent induction bR. - Qed. - - Lemma BoolRcorrect_another (b b' : Bool) (r : BoolR b b') : eqb_bool b b'. - Proof. by apply BoolRcorrect. Defined. - - Lemma bool_eqDec : forall b1 b2, reflect (b1 = b2) (eqb_bool b1 b2). - Proof. - move=> b1 b2; apply (iffP idP). - + by case: b1; case: b2. - + by move=> ->; case: b2. - Qed. - - Lemma Param44_Bool_another : Param44.Rel Bool Bool. - Proof. - eapply (Param44_AR Bool eqb_bool BoolR). - - by apply BoolRcorrect_another. - - by apply bool_eqDec. - - exact RBool_uniq. - Qed. - - -End tests. diff --git a/generic/exec_bool.v b/generic/exec_bool.v deleted file mode 100644 index b3e0d50e..00000000 --- a/generic/exec_bool.v +++ /dev/null @@ -1,1498 +0,0 @@ - -(*****************************************************************************) -(* * Trocq *) -(* _______ * Copyright (C) 2023 Inria & MERCE *) -(* |__ __| * (Mitsubishi Electric R&D Centre Europe) *) -(* | |_ __ ___ ___ __ _ * Cyril Cohen *) -(* | | '__/ _ \ / __/ _` | * Enzo Crance *) -(* | | | | (_) | (_| (_| | * Assia Mahboubi *) -(* |_|_| \___/ \___\__, | ************************************************) -(* | | * This file is distributed under the terms of *) -(* |_| * GNU Lesser General Public License Version 3 *) -(* * see LICENSE file for the text of the license *) -(*****************************************************************************) - -From Coq Require Import ssreflect. -From elpi.apps.derive Require Import eqb_core_defs derive.std derive.legacy. -Require Import HoTT_additions Hierarchy. -Unset Uniform Inductive Parameters. -Unset Universe Polymorphism. - -Definition eqnn := @eq_ind_r_nP. -(* Inductive nums := *) -(* | ZZZ | NNN : nums -> nums. *) - -(* Inductive OhOh := *) -(* | C : (forall A, A -> A) -> OhOh. *) - -(* Elpi derive nums. *) -(* Elpi derive OhOh. *) - -(* Check OhOh_induction. *) - -(* Set Universe Polymorphism. *) -Unset Universe Minimization ToSet. - -Notation Unit := unit. - -Inductive UnitR : Unit -> Unit -> Type := - | ttR : UnitR tt tt. - -Definition m_unit : unit -> unit := idmap. -Definition mR_Unit (u1 u2 : Unit) : m_unit u1 = u2 -> UnitR u1 u2. -Proof. -refine (fun e => - match u1 with - | tt => match u2 with - | tt => ttR - end end -). -Defined. - -Definition Rm_Unit (u1 u2 : Unit) : UnitR u1 u2 -> m_unit u1 = u2. -Proof. -refine (fun r => - match r with - | ttR => 1 - end -). -Defined. - -Definition mRRmK_Unit (u1 u2 : Unit) (r1 : UnitR u1 u2) : mR_Unit u1 u2 (Rm_Unit u1 u2 r1) = r1. -Proof. -by elim: r1. -Qed. - -Notation Bool := bool. - -Inductive BoolR : Bool -> Bool -> Type := - | falseR : BoolR false false - | trueR : BoolR true true. - -Definition map_Bool : Bool -> Bool := id. - -Definition exF : forall T, true = false -> T := -fun T e => - match e in _ = t return - match t with - | false => T - | true => unit - end - with eq_refl => tt end. - -Definition exF' : forall T, false = true -> T := -fun T e => - match e in _ = t return - match t with - | true => T - | false => unit - end - with eq_refl => tt end. - - -Definition mR_Bool : forall (b b' : Bool) (e : map_Bool b = b'), BoolR b b' := - fun b b' => - match b as bb with - | true => match b' as bb' with - | true => fun e => trueR - | false => fun e => exF _ e - end - | false => match b' with - | true => fun e => exF' _ e - | false => fun e => falseR - end - end. - -Definition Rm_Bool : forall (b b' : Bool) (bR: BoolR b b'), (map_Bool b = b') := -fun b b' bR => - match bR with - | trueR => idpath - | falseR => idpath - end. - -Definition mRRmKBool : forall (b b' : Bool) (bR : BoolR b b'), - mR_Bool b b' (Rm_Bool b b' bR) = bR. -Proof. -move=> b b' []//=. -Qed. - -Inductive enum := -| K1 : unit -> enum -| K2 : Bool -> enum. - -Definition m_enum : enum -> enum := idmap. -Inductive enumR : enum -> enum -> Type := - | K1R : forall u1 u2, UnitR u1 u2 -> enumR (K1 u1) (K1 u2) - | K2R : forall b1 b2, BoolR b1 b2 -> enumR (K2 b1) (K2 b2). - -Definition K1_proj1 : forall u : unit, enum -> unit := -fun u e => match e with K1 u => u | K2 _ => u end. - - -Lemma K1_inj (u1 u2 : unit) : K1 u1 = K1 u2 -> u1 = u2. -Proof. -move=> e. -exact (ap (K1_proj1 u1) e). -Defined. - -Lemma K1_inj' (u1 u2 : unit) : K1 u1 = K1 u2 -> u1 = u2. -Proof. -by case. -Defined. - -Definition K1_inj'' (u1 u2 : unit) : K1 u1 = K1 u2 -> u1 = u2 := -let p := fun u e => match e with K1 u => u | K2 _ => u end in -fun e => ap (p u1) e. - - -Definition K2_proj1 : forall b : bool, enum -> bool := -fun b e => match e with K2 b => b | K1 _ => b end. - -Lemma K2_inj (b1 b2 : bool) : K2 b1 = K2 b2 -> b1 = b2. -Proof. -move=> e. exact (ap (K2_proj1 b1) e). -Defined. - -Lemma K1_K2_discr (T : Type) (u1 : unit)(b1 : bool) : K1 u1 = K2 b1 -> T. -Proof. - move=> e. -refine (match e in _ = t return - match t with - | K1 _ => unit - | K2 _ => T end - - with eq_refl => tt end - ). -Defined. - -Lemma K2_K1_discr (T : Type) (b : bool) (u : unit): K2 b = K1 u -> T. -Proof. -move=> e. -refine ( match e in _ = t return - match t with - | K1 _ => T - | K2 _ => unit - end - with eq_refl => tt end ). -Defined. - -Definition mR_enum : forall (e1 e2 : enum), m_enum e1 = e2 -> enumR e1 e2. -Proof. -move=> e1 e2. -elim: e1=> [u1|b1]; elim: e2=> [u2|b2]. -- move=> /K1_inj e; apply (K1R _ _ (mR_Unit _ _ e)). -- move=> /K1_K2_discr => /(_ False) []. -- move=> /K2_K1_discr => /(_ False) []. -- move=> /K2_inj e; apply (K2R _ _ (mR_Bool _ _ e)). -Defined. - -Print mR_enum. - -Definition mR_enum' : forall (e1 e2 : enum), m_enum e1 = e2 -> enumR e1 e2. -Proof. -refine (fun e1 e2 => - match e1 with - | K1 u1 => match e2 with - | K1 u2 => fun e => K1R _ _ (mR_Unit _ _ (K1_inj _ _ e)) - | K2 b2 => fun e => K1_K2_discr _ u1 b2 e - end - | K2 b1 => match e2 with - | K1 u2 => fun e => K2_K1_discr _ b1 u2 e - | K2 b2 => fun e => K2R _ _ (mR_Bool _ _ (K2_inj _ _ e)) - end - end -). -Defined. - -Definition Rm_enum : forall (e1 e2 : enum) (eR: enumR e1 e2), (m_enum e1 = e2). -Proof. -refine ( -fun e1 e2 eR => - match eR with - | K1R u1 u2 uR => (ap K1 (Rm_Unit _ _ uR)) (* match uR with ttR => idpath end *) - | K2R b1 b2 bR => (ap K2 (Rm_Bool _ _ bR)) - end). -Defined. - -Fixpoint eq_ind_r_n (T : tlist) : p_type T -> p_type T -> Prop := - match T return p_type T -> p_type T -> Prop with - | tnil => fun p q => p -> q - | tcons T Ts => fun p q => forall (x y : T), x = y -> @eq_ind_r_n Ts (p x) (q y) - end. - -Lemma eq_ind_r_nP (T : tlist) (p : p_type T) : @eq_ind_r_n T p p. -Proof. elim: T p => //= T Ts hrec f a1 a2 ->; apply hrec. Defined. - -Lemma eq_ind_r_nP' : forall (T : tlist) (p : p_type T), @eq_ind_r_n T p p. -Proof. -elim. -- refine (fun p H=> H). -- simpl. move=> T TS IH p x y e. -elim: (ap p e). -apply IH. -Defined. -Print eq_ind_r_nP'. -(* Lemma eq_ind_r_nP'' : forall (T : tlist) (p : p_type T), @eq_ind_r_n T p p. -refine (fix IH => fun T match T with - | tnil => _ - | tcons _ _ => _ - end). - -elim. -- move=> p. exact id. -- move=> T Ts hrec f a1 a2. - elim. apply hrec. -Defined. *) - -Definition eqnn_transp := @eq_ind_r_nP'. - -Definition Rm_enum' : forall (e1 e2 : enum) (eR: enumR e1 e2), (m_enum e1 = e2) := -fun e1 e2 eR => - match eR with - | K1R u1 u2 uR => - eqnn (tcons Unit tnil) (fun u1' => K1 u1 = K1 u1' ) _ _ (Rm_Unit _ _ uR) eq_refl - | K2R u1 u2 uR => - eqnn (tcons Bool tnil) (fun u1' => K2 u1 = K2 u1' ) _ _ (Rm_Bool _ _ uR) eq_refl - end. - -Definition Rm_enum'' : forall (e1 e2 : enum) (eR: enumR e1 e2), (m_enum e1 = e2) := -fun e1 e2 eR => - match eR with - | K1R u1 u2 uR => - eqnn_transp (tcons Unit tnil) (fun u1' => K1 u1 = K1 u1' ) _ _ (Rm_Unit _ _ uR) eq_refl - | K2R u1 u2 uR => - eqnn_transp (tcons Bool tnil) (fun u1' => K2 u1 = K2 u1' ) _ _ (Rm_Bool _ _ uR) eq_refl - end. - -Lemma inj_projK (u1 u2 : unit) (e : m_unit u1 = u2) : -(K1_inj u1 u2 (ap K1 e)) = e. -Proof. -by rewrite /K1_inj -ap_compose /= ap_idmap. Qed. - -Definition mRRmKEnum : forall (e1 e2 : enum) (eR : enumR e1 e2), - mR_enum _ _ (Rm_enum _ _ eR) = eR. -Proof. -move=> e1 e2 []//=. -- move=> u1 u2 uR. - by rewrite /K1_inj -ap_compose /= ap_idmap mRRmK_Unit. -- move=> b1 b2 bR. - by rewrite /K2_inj -ap_compose /= ap_idmap mRRmKBool. -Defined. - -Definition mRRmKEnum' : forall (e1 e2 : enum) (eR : enumR e1 e2), - mR_enum' _ _ (Rm_enum _ _ eR) = eR. -Proof. -move=> e1 e2 []//=. -- move=> u1 u2 uR. - by rewrite /K1_inj -ap_compose /= ap_idmap mRRmK_Unit. -- move=> b1 b2 bR. - by rewrite /K2_inj -ap_compose /= ap_idmap mRRmKBool. -Defined. -Print mRRmKEnum. - -Inductive enum3 := -| KK1 : unit -> unit -> enum3 -| KK2 : bool -> bool -> enum3. - -Inductive enum3R : enum3 -> enum3 -> Type := -| KK1R : forall (u1 u2 : unit), UnitR u1 u2 - -> forall (u3 u4 : unit), UnitR u3 u4 - -> enum3R (KK1 u1 u3) (KK1 u2 u4) -| KK2R : forall (b1 b2 : bool), BoolR b1 b2 - -> forall (b3 b4 : bool), BoolR b3 b4 - -> enum3R (KK2 b1 b3) (KK2 b2 b4). - -(* Elpi derive.map "pp". *) -Elpi derive.map "unit". -Elpi derive.map "bool". -Elpi derive.map "list". -Elpi derive.projK enum. -Print projK11. -Print projK21. -Elpi derive.projK list. -Print projcons1. -Print projcons2. - - -Elpi derive.projK enum3. -Print projKK11. - -Definition KK1_proj1 (u1 : unit) : enum3 -> unit:= - fun e => match e with KK1 u1 _ => u1 | _ => u1 end. - -Definition KK1_proj2 (u1 : unit) : enum3 -> unit:= - fun e => match e with KK1 _ u1 => u1 | _ => u1 end. - -Definition KK2_proj1 (b1 : bool) : enum3 -> bool:= - fun e => match e with KK2 b1 _ => b1 | _ => b1 end. - -Definition KK2_proj2 (b1 : bool) : enum3 -> bool:= - fun e => match e with KK2 _ b1 => b1 | _ => b1 end. - -Definition tr_ap {A : Type} {B : A -> Type} {C : Type} {D : C -> Type} - (f : A -> C) (g : forall (x : A) , B x -> D (f x)) - {x y : A} (p : x = y) (z : B x) : - transport D (ap f p) (g x z) = g y (transport B p z). -Proof. -exact (match p with eq_refl => eq_refl end). -Defined. - -Definition KK1_inj1 (u1 u2 u3 u4 : unit) : KK1 u1 u2 = KK1 u3 u4 -> u1 = u3. -Proof. - (* by refine (fun e => match e with eq_refl => eq_refl end). *) - move=> e. - (* sol1 *) - (* apply (ap (fun x=> KK1 x u4)). *) - exact: (ap (KK1_proj1 u1) e). - - (* eo sol1 *) - (* sol2 *) - (* have@ e' := (ap (KK1_proj2 u2) e) : u2 = u4. *) - (* have@ e'' := (ap (KK1_proj1 u1) e) : u1 = u3. *) - (* have@ e''' : KK1 u1 u4 = KK1 u3 u4. *) - (* have@ aux_transp1 : KK1 u1 u2 = KK1 u3 u2. *) - (* by apply (ap ( ( fun x => (KK1 x u2) ) ) e''). *) - (* (* by apply (ap ( ( fun x => (KK1 x u2) ) o (KK1_proj1 u1) ) e). *) *) - (* by have@ aux := (transport (fun x=> KK1 u1 x = KK1 u3 x) e' aux_transp1). *) - (* exact: (ap (KK1_proj1 u1) e'''). *) - (* Show Proof. *) - (* eo sol2 *) -Defined. - -Definition KK1_inj2 (u1 u2 u3 u4 : unit) : KK1 u1 u2 = KK1 u3 u4 -> u2 = u4. -exact: (fun e => (ap (KK1_proj2 u2) e)). -(* by refine (fun e => match e with eq_refl => eq_refl end). *) -Defined. - -Definition KK2_inj1 (u1 u2 u3 u4 : bool) : KK2 u1 u2 = KK2 u3 u4 -> u1 = u3. -exact: (fun e => (ap (KK2_proj1 _) e)). -Defined. - -Definition KK2_inj2 (u1 u2 u3 u4 : bool) : KK2 u1 u2 = KK2 u3 u4 -> u2 = u4. -exact: (fun e => (ap (KK2_proj2 u2) e)). -Defined. - -(* Definition KK2_inj1 (b1 b2 b3 b4 : bool) : KK2 b1 b2 = KK2 b3 b4 -> b1 = b3. *) -(* Proof. *) -(* by refine (fun e => match e with eq_refl => eq_refl end). *) -(* Defined. *) - -(* Definition KK2_inj2 (b1 b2 b3 b4 : bool) : KK2 b1 b2 = KK2 b3 b4 -> b2 = b4. *) -(* by refine (fun e => match e with eq_refl => eq_refl end). *) -(* Defined. *) - -Definition KK1_KK2 (T : Type) (u1 u2 : unit) (b1 b2 : bool) : - KK1 u1 u2 = KK2 b1 b2 -> T. -Proof. -refine (fun e => match e in _ = t return - match t with - | KK1 _ _ => unit - | KK2 _ _ => T end - with eq_refl => tt end). -Defined. - -Definition KK2_KK1 (T : Type) (b1 b2 : bool) (u1 u2 : unit) : - KK2 b1 b2 = KK1 u1 u2 -> T. -Proof. -refine (fun e => match e in _ = t return - match t with - | KK1 _ _ => T - | KK2 _ _ => unit end - with eq_refl => tt end). -Defined. - -Definition mR_enum3 (e1 e2 : enum3) : e1 = e2 -> enum3R e1 e2. -Proof. -refine ( -match e1 with -| KK1 u1 u2 => match e2 with - | KK1 u3 u4 => fun e => KK1R _ _ (mR_Unit _ _ (KK1_inj1 u1 u2 u3 u4 e)) _ _ (mR_Unit _ _ (KK1_inj2 u1 u2 u3 u4 e)) - | KK2 b1 b2 => fun e => KK1_KK2 _ _ _ _ _ e - end -| KK2 b1 b2 => match e2 with - | KK1 u1 u2 => fun e => KK2_KK1 _ _ _ _ _ e - | KK2 b3 b4 => fun e => KK2R _ _ (mR_Bool _ _ (KK2_inj1 _ _ _ _ e)) - _ _ (mR_Bool _ _ (KK2_inj2 _ _ _ _ e)) - end -end -). -Defined. - -Lemma KK1_curry : forall u1 u2, KK1 u1 u2 = (uncurry KK1) (u1,u2). -Proof. -reflexivity. -Defined. - -Definition Rm_enum3 (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2. -Proof. -elim. -- move=> u1 u2 uR1 u3 u4 uR2. - (* rewrite !KK1_curry. *) - (* apply ap. *) - (* apply ap. - pose F := uncurry KK1. *) - elim: (Rm_Unit _ _ uR1). - (* apply ap. *) - elim: (Rm_Unit _ _ uR2). - reflexivity. - (* by apply ap. *) -- move=> b1 b2 bR1 b3 b4 bR2. - elim: (Rm_Bool _ _ bR1). - elim: (Rm_Bool _ _ bR2). - by apply ap. -Defined. -Print Rm_enum3. -Print f_equal2. -(* Definition Rm_enum3' (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2. -Proof. -elim. -- move=> u1 u2 uR1 u3 u4 uR2. - apply (ap (KK1 u1) (Rm_Unit _ _ uR1)). - elim: (Rm_Unit _ _ uR1). - elim: (Rm_Unit _ _ uR2). - by apply ap. -- move=> b1 b2 bR1 b3 b4 bR2. - elim: (Rm_Bool _ _ bR1). - elim: (Rm_Bool _ _ bR2). - by apply ap. -Defined. *) - -Definition Rm_enum3' (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2. -Proof. -elim. -- move=> u1 u2 uR1 u3 u4 uR2. - by apply (eqnn (tcons Unit (tcons Unit tnil)) (fun u1' u2' => KK1 u1 u3 = KK1 u1' u2') u1 u2 (Rm_Unit u1 u2 uR1) u3 u4 (Rm_Unit u3 u4 uR2) ). -- move=> u1 u2 uR1 u3 u4 uR2. - by apply (eqnn (tcons Bool (tcons Bool tnil)) (fun u1' u2' => KK2 u1 u3 = KK2 u1' u2') u1 u2 (Rm_Bool u1 u2 uR1) u3 u4 (Rm_Bool u3 u4 uR2) ). -Defined. - -Definition Rm_enum3''' (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2. -Proof. - elim. - - move=> u1 u2 uR1 u3 u4 uR2. - (* have e := ap (fun u => KK1 u u3) (Rm_Unit _ _ uR1). *) - (* have e' := ap (fun u => KK1 u2 u) (Rm_Unit _ _ uR2). *) - (* exact: (e @ e'). *) - exact: (ap (fun u => KK1 u u3) (Rm_Unit _ _ uR1) @ ap (fun u => KK1 u2 u) (Rm_Unit _ _ uR2)). - - move=> u1 u2 uR1 u3 u4 uR2. - (* have e := ap (fun u => KK2 u u3) (Rm_Bool _ _ uR1). *) - (* have e' := ap (fun u => KK2 u2 u) (Rm_Bool _ _ uR2). *) - (* exact: (e @ e'). *) - exact: (ap (fun u => KK2 u u3) (Rm_Bool _ _ uR1) @ ap (fun u => KK2 u2 u) (Rm_Bool _ _ uR2)). -Defined. - -Definition Rm_enum3'''' (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2. -Proof. - elim. - - move=> u1 u2 uR1 u3 u4 uR2. - (* have e'' := ap (fun u => KK1 u1 u) (Rm_Unit _ _ uR2). *) - (* have e''' := ap (fun u => KK1 u u4) (Rm_Unit _ _ uR1). *) - (* exact: (e'' @ e'''). *) - exact: ( (ap (fun u => KK1 u1 u) (Rm_Unit _ _ uR2)) @ (ap (fun u => KK1 u u4) (Rm_Unit _ _ uR1))). - - move=> u1 u2 uR1 u3 u4 uR2. - (* have e := ap (fun u => KK2 u u3) (Rm_Bool _ _ uR1). *) - (* have e' := ap (fun u => KK2 u2 u) (Rm_Bool _ _ uR2). *) - (* exact: (e @ e'). *) - exact: ( (ap (fun u => KK2 u1 u) (Rm_Bool _ _ uR2)) @ (ap (fun u => KK2 u u4) (Rm_Bool _ _ uR1))). -Defined. - -Definition Rm_enum3'' (e1 e2 : enum3) : enum3R e1 e2 -> e1 = e2 := -fun eR => -match eR with -| KK1R u1 u2 uR1 u3 u4 uR2 => - (eqnn (tcons Unit (tcons Unit tnil)) - (fun u1' u2' => KK1 u1 u3 = KK1 u1' u2') - u1 u2 (Rm_Unit u1 u2 uR1) u3 u4 (Rm_Unit u3 u4 uR2) - eq_refl) -| KK2R u1 u2 uR1 u3 u4 uR2 => - (eqnn (tcons Bool (tcons Bool tnil)) - (fun u1' u2' => KK2 u1 u3 = KK2 u1' u2') - u1 u2 (Rm_Bool u1 u2 uR1) u3 u4 (Rm_Bool u3 u4 uR2) - eq_refl) -end. -Print f_equal. -Search f_equal f_equal2. - -Definition tr_id {A : Type} {B : A -> Type} {a : A} - (f : forall (x : A), a = x -> B x) - (x : A) (p : a = x) : f x p = transport B p (f a eq_refl). -Proof. - exact: (match p with eq_refl => eq_refl end). -Defined. - -Definition preserves_tr {I : Type} {A : I -> Type} {B : I -> Type} (f : forall (i : I), A i -> B i) - {i j : I} (p : i = j) (x : A i) : - f j (transport A p x) = transport B p (f i x). -Proof. - exact: (match p with eq_refl => eq_refl end). -Defined. - -Definition compute_preserves_tr {I : Type} {A : I -> Type} {B : I -> Type} - (f : forall (i : I), A i -> B i) - {i j : I} (p : i = j) (x : A i) : - preserves_tr _ p x = - (tr_ap id f p x)^ @ ap (fun q => transport B q (f i x)) (ap_idmap p). -Proof. - exact: (match p with eq_refl => eq_refl end). -Defined. - -Definition substitution_law_tr {X : Type} {A : Type} (B : A -> Type) (f : X -> A) - {x y : X} (p : x = y) {x' : B (f x)} : - transport B (ap f p) x' = transport (B o f) p x'. -Proof. - apply (tr_ap f (fun _ => idmap) p x'). -Defined. - -Definition tr_Id_left {A : Type} {a b c : A} (q : b = c) (p : b = a) : - transport (fun x => x = a) q p = q^ @ p. -Proof. - refine ((match q with eq_refl => _ end)). - by rewrite transport1 concat_1p. -Defined. - -Definition tr_Id_right {A : Type} {a b c : A} (q : b = c) (p : a = b) : - transport (fun x => a = x) q p = p @ q. -Proof. - refine ((match q with eq_refl => _ end)). - by rewrite transport1 concat_p1. -Defined. - -Definition KK1_proj1K : forall u1 u2 (p1 : u1 = u2) u3 u4 (p2 : u3 = u4), - (ap (KK1_proj1 u1) - (ap (fun u : Unit => KK1 u u3) p1 @ - ap (fun u : Unit => KK1 u2 u) p2)) = p1. -Proof. - refine (fun u1 u2 p1 => match p1 as p0 in _ = t - return - forall u3 u4 p2, (ap (KK1_proj1 u1) - (ap (fun u : Unit => KK1 u u3) p0 @ - ap (fun u : Unit => KK1 t u) p2)) = p0 - with eq_refl => _ end - - ). - refine (fun u3 u4 p2 => match p2 as p0 in _ = t - return - (ap (KK1_proj1 u1) - (ap (fun u : Unit => KK1 u u3) 1 @ - ap (fun u : Unit => KK1 u1 u) p0)) = 1 - with eq_refl => eq_refl end - ). -Defined. - -Definition KK1_proj2K : forall u1 u2 (p1 : u1 = u2) u3 u4 (p2 : u3 = u4), - (ap (KK1_proj2 u3) - (ap (fun u : Unit => KK1 u u3) p1 @ - ap (fun u : Unit => KK1 u2 u) p2)) = p2. -Proof. - refine (fun u1 u2 p1 => match p1 as p0 in _ = t - return - forall u3 u4 p2, (ap (KK1_proj2 u3) - (ap (fun u : Unit => KK1 u u3) p0 @ - ap (fun u : Unit => KK1 t u) p2)) = p2 - with eq_refl => _ end - - ). - refine (fun u3 u4 p2 => match p2 as p0 in _ = t - return - (ap (KK1_proj2 u3) - (ap (fun u : Unit => KK1 u u3) 1 @ - ap (fun u : Unit => KK1 u1 u) p0)) = p0 - with eq_refl => eq_refl end - ). -Defined. - -Definition KK2_proj1K : forall b1 b2 (p1 : b1 = b2), - forall b3 b4 (p2 : b3 = b4), - - (ap (KK2_proj1 b4) - (ap (fun u : Bool => KK2 u b3) p1 @ - ap (fun u : Bool => KK2 b2 u) p2)) = p1. -Proof. - refine ( - fun b1 b2 p1 => - match p1 as p0 in _ = t - return - forall b3 b4 p2, (ap (KK2_proj1 b4) - (ap (fun u : Bool => KK2 u b3) p0 @ - ap (fun u : Bool => KK2 t u) p2)) = p0 - with eq_refl => _ end - ). - refine ( - - fun b3 b4 p2 => - match p2 as p0 in _ = t - return - (ap (KK2_proj1 t) - (ap (fun u : Bool => KK2 u b3) 1 @ - ap (fun u : Bool => KK2 b1 u) p0)) = 1 - with eq_refl => eq_refl end - ). -Defined. - -Definition KK2_proj2K : forall b1 b2 (p1 : b1 = b2), - forall b3 b4 (p2 : b3 = b4), - (* (ap (KK2_proj2 b4) *) - KK2_inj2 b1 b3 b2 b4 ( - (ap (fun u : Bool => KK2 u b3) p1 @ - ap (fun u : Bool => KK2 b2 u) p2)) = p2. -Proof. - refine ( - fun b1 b2 p1 => - match p1 as p0 in _ = t - return - forall b3 b4 p2, - KK2_inj2 b1 b3 t b4 - ((ap (fun u : Bool => KK2 u b3) p0) @ (ap (fun u : Bool => KK2 t u) p2)) = p2 - with eq_refl => _ end - ). - refine ( - fun b3 b4 p2 => - match p2 as p0 in _ = t - return - KK2_inj2 b1 b3 b1 t - ((ap (fun u : Bool => KK2 u b3) 1 @ - ap (fun u : Bool => KK2 b1 u) p0)) = p0 - with eq_refl => eq_refl end - ). -Defined. - -Lemma mRRmK_enum3' (e1 e2 : enum3) (eR : enum3R e1 e2) : mR_enum3 _ _ (Rm_enum3''' _ _ eR) = eR. -Proof. - elim: eR=> /=. - - move=> u1 u2 uR1 u3 u4 uR2 /=. - by rewrite /KK1_inj1 KK1_proj1K /KK1_inj2 KK1_proj2K !mRRmK_Unit. - - move=> b1 b2 bR1 b3 b4 bR2 /=. - by rewrite /KK2_inj1 KK2_proj1K KK2_proj2K !mRRmKBool. -Defined. - -Inductive pp := -| Z -| S : pp -> pp. - -Inductive ppR : pp -> pp -> Type := -| ZR : ppR Z Z -| SR : forall pp1 pp2, ppR pp1 pp2 -> ppR (S pp1) (S pp2). - -Definition map_pp : pp -> pp := id. - -Fixpoint map_pp' (p : pp) : pp := - match p with - | Z => Z - | S p' => S (map_pp' p') - end. - -Definition S_proj (dflt : pp) (p1 : pp) : pp := -match p1 with -| Z => dflt -| S p1' => p1' -end. - -Definition S_inj (p1 p2 : pp) : (S p1) = S p2 -> p1 = p2. -by move=> /(ap (S_proj p1)). -Defined. - -Definition S_inj' (p1 p2 : pp) : map_pp (S p1) = S p2 -> map_pp p1 = p2. -by case. -Defined. - -Definition map_S_e (p1 p2 : pp) : p1 = p2 -> (S p1) = (S p2). -by apply (ap S). -Defined. - -Definition map_S_e' (p1 p2 : pp) : map_pp p1 = p2 -> map_pp (S p1) = (S p2). -by elim. -Defined. - -Definition inj_projK_pp (p1 p2 : pp) (e : p1 = p2): S_inj p1 p2 (map_S_e p1 p2 e) = e. -Proof. -by rewrite /S_inj/map_S_e -ap_compose ap_idmap. -Defined. - -Definition inj_projK_pp' (p1 p2 : pp) (e : p1 = p2): S_inj p1 p2 (ap S e) = e. -Proof. -by refine ( - match e as p0 in _ = t - return S_inj p1 t (ap S p0) = p0 - with eq_refl => eq_refl end - ). -Defined. - -Definition ex_falso_Z_pp (T : Type) (p1 : pp) : map_pp Z = S p1 -> T. -refine ( -fun e => match e in _ = t return - match t with - | Z => Unit - | S _ => T end - with eq_refl => tt end - -). -Defined. - -Definition ex_falso_pp_ZZ (T : Type) (p1 : pp) : map_pp (S p1) = Z -> T. -refine ( -fun e => match e in _ = t return - match t with - | Z => T - | S _ => Unit end - with eq_refl => tt end - -). -Defined. - -Definition mR_pp : forall p1 p2, (map_pp p1) = p2 -> ppR p1 p2. -elim=> [|p1' IHn]. -- case=> [|p2']. - + move=> e; exact: ZR. - + move=> /ex_falso_Z_pp contr; apply contr. -- case=> [|p2']. - + move=> /ex_falso_pp_ZZ contr; apply contr. - + move=> /S_inj e; exact: SR _ _ (IHn _ e). -Defined. - -Definition mR_pp' : forall p1 p2, (map_pp' p1) = p2 -> ppR p1 p2. -elim=> [|p1' IHn]. -- case=> [|p2']. - + move=> e; exact: ZR. - + move=> /ex_falso_Z_pp contr; apply contr. -- case=> [|p2']. - + move=> /ex_falso_pp_ZZ contr; apply contr. - + move=> /S_inj e; exact: SR _ _ (IHn _ e). -Defined. - -Print ppR_ind. -Definition Rm_pp : forall p1 p2, ppR p1 p2 -> map_pp p1 = p2. -move=> p1 p2 eR. -elim : eR => [| p1' p2' hR rec]. -- exact: idpath. -- by apply map_S_e. -Defined. - -Definition Rm_pp'' : forall p1 p2, ppR p1 p2 -> map_pp' p1 = p2. - move=> p1 p2 eR. - elim : eR => [| p1' p2' hR rec]. - - exact: idpath. - - by apply (ap S rec). -Defined. - -Definition Rm_pp' : forall p1 p2, ppR p1 p2 -> map_pp p1 = p2. -move=> p1 p2. -fix IH 1. -elim. -- exact: idpath. -- by move=> p1' p2' ppR' rec; apply: map_S_e. -Defined. - -Definition mRRmK_pp : forall p1 p2 (pR : ppR p1 p2), mR_pp _ _ (Rm_pp _ _ pR) = pR. -Proof. -move=> p1 p2; elim. -- reflexivity. -- move=> p1' p2' eR' rec. - move=> /=. apply ap. by rewrite inj_projK_pp rec. -Defined. - -(* with map <> id *) -Definition mRRmK_pp': forall p1 p2 (pR : ppR p1 p2), mR_pp' _ _ (Rm_pp'' _ _ pR) = pR. -Proof. - move=> p1 p2; elim. - - reflexivity. - - move=> p1' p2' eR' rec. - rewrite /=. - by rewrite inj_projK_pp' rec. -Defined. - -Module i. - Inductive issue (A B C : Type) := - | K1 : unit -> enum -> pp -> issue A B C - | K2 : A -> B -> C -> issue A B C - (* | K3 : A -> pp -> issue A *) - | K4 : issue A B C -> issue A B C -> issue A B C -> issue A B C. - -Elpi derive.map "issue". -Elpi derive.projK issue. -Print issue_map. -Print projK11. -Inductive issueR - (A A' : Type) (AR : A -> A' -> Type) - (B B' : Type) (BR : B -> B' -> Type) - (C C' : Type) (CR : C -> C' -> Type) - : issue A B C -> issue A' B' C' -> Type := -| K1R : - forall u1 u2 (uR : UnitR u1 u2), - forall e1 e2 (eR : enumR e1 e2), - forall p1 p2 (pR : ppR p1 p2), - issueR A A' AR B B' BR C C' CR (K1 A B C u1 e1 p1) (K1 A' B' C' u2 e2 p2) -| K2R : - forall a1 a2 (aR : AR a1 a2), - forall b1 b2 (bR : BR b1 b2), - forall c1 c2 (cR : CR c1 c2), - issueR A A' AR B B' BR C C' CR (K2 A B C a1 b1 c1) (K2 A' B' C' a2 b2 c2) -| K4R : - forall i1 i2 (iR1 : issueR A A' AR B B' BR C C' CR i1 i2), - forall i3 i4 (iR2 : issueR A A' AR B B' BR C C' CR i3 i4), - forall i5 i6 (iR3 : issueR A A' AR B B' BR C C' CR i5 i6), - issueR A A' AR B B' BR C C' CR (K4 A B C i1 i3 i5) (K4 A' B' C' i2 i4 i6). - -(* Definition issue_map *) -(* (A A' : Type) (AR : Param10.Rel A A') *) -(* (B B' : Type) (BR : Param10.Rel B B') *) -(* (C C' : Type) (CR : Param10.Rel C C') *) -(* : issue A B C -> issue A' B' C' := *) -(* let fix im (ia : issue A B C) {struct ia} : issue A' B' C' := *) -(* match ia with *) -(* | K1 _ _ _ u e p => K1 A' B' C' u e p *) -(* | K2 _ _ _ a b c => K2 A' B' C' (map AR a) (map BR b) (map CR c) *) -(* (* | K3 _ a pp => K3 A' (map AR a) pp *) *) -(* | K4 _ _ _ ia1 ia2 ia3 => K4 A' B' C' (im ia1) (im ia2) (im ia3) end in *) -(* fun ia => im ia. *) - -Fixpoint issue_map_fix - (A A' : Type) (AR : Param10.Rel A A') - (B B' : Type) (BR : Param10.Rel B B') - (C C' : Type) (CR : Param10.Rel C C') - (ia : issue A B C) : issue A' B' C' := - match ia with - | K1 _ _ _ u e p => K1 A' B' C' u e p - | K2 _ _ _ a b c => K2 A' B' C' (map AR a) (map BR b) (map CR c) - | K4 _ _ _ ia1 ia2 ia3 => K4 A' B' C' - (issue_map_fix A A' AR B B' BR C C' CR ia1) - (issue_map_fix A A' AR B B' BR C C' CR ia2) - (issue_map_fix A A' AR B B' BR C C' CR ia3) end. - -(* Definition issue_map_fix2 : *) -(* forall (A A' : Type) (AR : Param10.Rel A A') *) -(* (B B' : Type) (BR : Param10.Rel B B') *) -(* (C C' : Type) (CR : Param10.Rel C C') *) -(* (ia : issue A B C), issue A' B' C' := *) -(* let fix F A A' AR B B' BR C C' CR ia {struct ia} := *) -(* match ia with *) -(* | K1 _ _ _ u e p => K1 A' B' C' u e p *) -(* | K2 _ _ _ a b c => K2 A' B' C' (map AR a) (map BR b) (map CR c) *) -(* | K4 _ _ _ ia1 ia2 ia3 => K4 A' B' C' *) -(* (F A A' AR B B' BR C C' CR ia1) *) -(* (F A A' AR B B' BR C C' CR ia2) *) -(* (F A A' AR B B' BR C C' CR ia3) end in *) -(* fun A A' AR B B' BR C C' CR ia => F A A' AR B B' BR C C' CR ia. *) -(* Definition issue_mapE *) -(* (A A' : Type) (AR : Param10.Rel A A') *) -(* (B B' : Type) (BR : Param10.Rel B B') *) -(* (C C' : Type) (CR : Param10.Rel C C') *) -(* ia : *) -(* issue_map A A' AR *) -(* B B' BR *) -(* C C' CR *) -(* ia = ((fix im (ia0 : issue A B C) : issue A' B' C' := *) -(* match ia0 with *) -(* | K1 _ _ _ u e p => K1 A' B' C' u e p *) -(* | K2 _ _ _ a b c => K2 A' B' C' (map AR a) (map BR b) (map CR c) *) -(* | K4 _ _ _ ia7 ia8 ia9 => K4 A' B' C' (im ia7) (im ia8) (im ia9) *) -(* end) ia). *) -(* Proof. by []. Qed. *) - -Definition issue_k1_proj1 : forall (A B C : Type) (u : unit), issue A B C -> unit := -fun A B C u ia => - match ia with - | K1 _ _ _ u _ _ => u - | _ => u end. - -Definition issue_k1_proj2 : forall (A B C: Type) (e : enum), issue A B C -> enum := -fun A B C e ia => - match ia with - | K1 _ _ _ _ e _ => e - | _ => e end. - -Definition issue_k1_proj3 : forall (A B C: Type) (p : pp), issue A B C -> pp := -fun A B C p ia => - match ia with - | K1 _ _ _ _ _ p => p - | _ => p end. - -Definition issue_k2_proj1 : forall (A B C : Type) (a : A), issue A B C -> A := -fun A B C a ia => - match ia with - | K2 _ _ _ a _ _ => a - | _ => a end. - -Definition issue_k2_proj2 : forall (A B C : Type) (b : B), issue A B C -> B := -fun A B C b ia => - match ia with - | K2 _ _ _ _ b _ => b - | _ => b end. - -Definition issue_k2_proj3 : forall (A B C : Type) (c : C), issue A B C -> C := -fun A B C c ia => - match ia with - | K2 _ _ _ _ _ c => c - | _ => c end. - -Definition issue_k4_proj1 : forall (A B C : Type) (ia : issue A B C), issue A B C -> issue A B C := -fun A B C ia' ia => - match ia with - | K4 _ _ _ ia' _ _ => ia' - | _ => ia' end. - -Definition issue_k4_proj2 : forall (A B C : Type) (ia : issue A B C), issue A B C -> issue A B C := -fun A B C ia' ia => - match ia with - | K4 _ _ _ _ ia' _ => ia' - | _ => ia' end. - -Definition issue_k4_proj3 : forall (A B C : Type) (ia : issue A B C), issue A B C -> issue A B C := -fun A B C ia' ia => - match ia with - | K4 _ _ _ _ _ ia' => ia' - | _ => ia' end. - -Definition issue_k1_inj1 : forall (A B C : Type) (u1 u2 : unit) (e1 e2 : enum) (p1 p2 : pp), K1 A B C u1 e1 p1 = K1 A B C u2 e2 p2 -> u1 = u2. - move=> A B C u1 u2 e1 e2 p1 p2 E. - injection E. - Show Proof. - move=> P1 P2 P3; exact: P3. - Show Proof. - Defined. - (* fun A B C u1 u2 e1 e2 p1 p2 E => ap (issue_k1_proj1 A B C u1) E. *) - -Definition issue_k1_inj2 : forall (A B C : Type) (u1 u2 : unit) (e1 e2 : enum) (p1 p2 : pp), K1 A B C u1 e1 p1 = K1 A B C u2 e2 p2 -> e1 = e2 := - fun A B C u1 u2 e1 e2 p1 p2 E => ap (issue_k1_proj2 A B C e1) E. - -Definition issue_k1_inj3 : forall (A B C : Type) (u1 u2 : unit) (e1 e2 : enum) (p1 p2 : pp), K1 A B C u1 e1 p1 = K1 A B C u2 e2 p2 -> p1 = p2 := - fun A B C u1 u2 e1 e2 p1 p2 E => ap (issue_k1_proj3 A B C p1) E. - -Definition issue_k2_inj1 : forall (A B C : Type) (a1 a2 : A) (b1 b2 : B) (c1 c2 : C), K2 A B C a1 b1 c1= K2 A B C a2 b2 c2 -> a1 = a2 := - fun A B C a1 a2 b1 b2 c1 c2 E => ap (issue_k2_proj1 A B C a1) E. - -Definition issue_k2_inj2 : forall (A B C : Type) (a1 a2 : A) (b1 b2 : B) (c1 c2 : C), K2 A B C a1 b1 c1= K2 A B C a2 b2 c2 -> b1 = b2 := - fun A B C a1 a2 b1 b2 c1 c2 E => ap (issue_k2_proj2 A B C b1) E. - -Definition issue_k2_inj3 : forall (A B C : Type) (a1 a2 : A) (b1 b2 : B) (c1 c2 : C), K2 A B C a1 b1 c1= K2 A B C a2 b2 c2 -> c1 = c2 := - fun A B C a1 a2 b1 b2 c1 c2 E => ap (issue_k2_proj3 A B C c1) E. - -Definition issue_k4_inj1 : forall (A B C : Type) (ia1 ia2 : issue A B C) (ia3 ia4 : issue A B C) (ia5 ia6 : issue A B C), K4 A B C ia1 ia3 ia5 = K4 A B C ia2 ia4 ia6 -> ia1 = ia2 := - fun A B C ia1 ia2 ia3 ia4 ia5 ia6 E => ap (issue_k4_proj1 A B C ia1) E. - -Definition issue_k4_inj2 : forall (A B C : Type) (ia1 ia2 : issue A B C) (ia3 ia4 : issue A B C) (ia5 ia6 : issue A B C), K4 A B C ia1 ia3 ia5 = K4 A B C ia2 ia4 ia6 -> ia3 = ia4 := - fun A B C ia1 ia2 ia3 ia4 ia5 ia6 E => ap (issue_k4_proj2 A B C ia3) E. - -Definition issue_k4_inj3 : forall (A B C : Type) (ia1 ia2 : issue A B C) (ia3 ia4 : issue A B C) (ia5 ia6 : issue A B C), K4 A B C ia1 ia3 ia5 = K4 A B C ia2 ia4 ia6 -> ia5 = ia6 := - fun A B C ia1 ia2 ia3 ia4 ia5 ia6 E => ap (issue_k4_proj3 A B C ia5) E. - -Definition issue_ex_falso_k1_k2 : forall (A B C A' : Type) u1 e1 p1 a2 b2 c2, - K1 A B C u1 e1 p1 = K2 A B C a2 b2 c2 -> A' := - fun A B C A' u1 e1 p1 a2 b2 c2 e => - match e in _ = t return - match t with - | K2 _ _ _ _ _ _ => A' - | _ => Unit end - with eq_refl => tt end. - -Definition issue_ex_falso_k1_k4 : forall (A B C A' : Type) u1 e1 p1 ia2 ia4 ia6 , K1 A B C u1 e1 p1 = K4 A B C ia2 ia4 ia6 -> A' := - fun A B C A' u1 e1 p1 ia2 ia4 ia6 e => - match e in _ = t return - match t with - | K4 _ _ _ _ _ _ => A' - | _ => Unit end - with eq_refl => tt end. - -Definition issue_ex_falso_k2_k1 : forall (A B C A' : Type) a1 b1 c1 u2 e2 p2, K2 A B C a1 b1 c1 = K1 A B C u2 e2 p2 -> A' := - fun A B C A' a1 b1 c1 u1 e1 p1 e => - match e in _ = t return - match t with - | K1 _ _ _ _ _ _ => A' - | _ => Unit end - with eq_refl => tt end. - -Definition issue_ex_falso_k2_k4 : forall (A B C A' : Type) a1 b1 c1 ia2 ia4 ia6 , K2 A B C a1 b1 c1 = K4 A B C ia2 ia4 ia6 -> A' := - fun A B C A' a1 b1 c1 ia2 ia4 ia6 e => - match e in _ = t return - match t with - | K4 _ _ _ _ _ _ => A' - | _ => Unit end - with eq_refl => tt end. - -Definition issue_ex_falso_k4_k1 : forall (A B C A' : Type) ia1 ia3 ia5 u2 e2 p2 , K4 A B C ia1 ia3 ia5 = K1 A B C u2 e2 p2 -> A' := - fun A B C A' ia1 ia3 ia5 u1 e1 p1 e => - match e in _ = t return - match t with - | K1 _ _ _ _ _ _ => A' - | _ => Unit end - with eq_refl => tt end. - -Definition issue_ex_falso_k4_k2 : forall (A B C A' : Type) ia1 ia3 ia5 a2 b2 c2 , K4 A B C ia1 ia3 ia5 = K2 A B C a2 b2 c2 -> A' := - fun A B C A' ia1 ia3 ia5 a2 b2 c2 e => - match e in _ = t return - match t with - | K2 _ _ _ _ _ _ => A' - | _ => Unit end - with eq_refl => tt end. - -Fixpoint issue_mR - (A A' : Type) (AR : Param2a0.Rel A A') - (B B' : Type) (BR : Param2a0.Rel B B') - (C C' : Type) (CR : Param2a0.Rel C C') - - ia {struct ia} : forall ia', issue_map_fix A A' AR B B' BR C C' CR ia = ia' -> issueR A A' AR B B' BR C C' CR ia ia'. -Proof. - (* fix F 1. *) - case: ia => [u1 e1 p1 | a1 b1 c1 | ia1 ia3 ia5 ]; case=> [u2 e2 p2 | a2 b2 c2 | ia2 ia4 ia6] e. - (* Set Printing All. *) - (* rewrite /= in e. *) - + by apply (K1R _ _ _ _ _ _ _ _ _ - _ _ (mR_Unit _ _ (issue_k1_inj1 _ _ _ _ _ _ _ _ _ e)) - _ _ (mR_enum _ _ (issue_k1_inj2 _ _ _ _ _ _ _ _ _ e)) - _ _ (mR_pp _ _ (issue_k1_inj3 _ _ _ _ _ _ _ _ _ e))). - + by apply (issue_ex_falso_k1_k2 A' B' C' _ u1 e1 p1 a2 b2 c2). - + by apply (issue_ex_falso_k1_k4 A' B' C' _ u1 e1 p1 ia2 ia4 ia6). - - + by apply (issue_ex_falso_k2_k1 A' B' C' _ (map AR a1) (map BR b1) (map CR c1) u2 e2 p2). - + - (* simpl [issue_map]in e. *) - by apply (K2R _ _ _ _ _ _ _ _ _ - - _ _ (map_in_R AR _ _ (issue_k2_inj1 _ _ _ _ _ _ _ _ _ e)) - _ _ (map_in_R BR _ _ (issue_k2_inj2 _ _ _ _ _ _ _ _ _ e)) - _ _ (map_in_R CR _ _ (issue_k2_inj3 _ _ _ _ _ _ _ _ _ e))). - + by apply (issue_ex_falso_k2_k4 A' B' C' _(map AR a1) (map BR b1) (map CR c1) ia2 ia4 ia6). - - + by apply (issue_ex_falso_k4_k1 A' B' C' _ - (issue_map_fix A A' AR B B' BR C C' CR ia1) - (issue_map_fix A A' AR B B' BR C C' CR ia3) - (issue_map_fix A A' AR B B' BR C C' CR ia5) u2 e2 p2). - + by apply (issue_ex_falso_k4_k2 A' B' C' _ - (issue_map_fix A A' AR B B' BR C C' CR ia1) - (issue_map_fix A A' AR B B' BR C C' CR ia3) - (issue_map_fix A A' AR B B' BR C C' CR ia5) a2 b2 c2). - + by apply (K4R _ _ _ _ _ _ _ _ _ - _ _ (issue_mR _ _ AR _ _ BR _ _ CR ia1 ia2 (issue_k4_inj1 _ _ _ _ _ _ _ _ _ e)) - _ _ (issue_mR _ _ AR _ _ BR _ _ CR ia3 ia4 (issue_k4_inj2 _ _ _ _ _ _ _ _ _ e)) - _ _ (issue_mR _ _ AR _ _ BR _ _ CR ia5 ia6 (issue_k4_inj3 _ _ _ _ _ _ _ _ _ e))). -Defined. - -Fixpoint issue_Rm - (A A' : Type) (AR : Param2b0.Rel A A') - (B B' : Type) (BR : Param2b0.Rel B B') - (C C' : Type) (CR : Param2b0.Rel C C') - ia ia' (iaR : issueR A A' AR B B' BR C C' CR ia ia') {struct iaR}: issue_map_fix A A' AR B B' BR C C' CR ia = ia'. -Proof. - (* move: iaR. *) - (* Set Printing All. *) - (* rewrite /=. *) - (* move=> iaR; *) - (* elim: iaR. *) - (* move: ia. *) - (* refine (fun ia ia' => _). *) - elim: iaR=> [u1 u2 uR e1 e2 eR p1 p2 pR | a1 a2 aR b1 b2 bR c1 c2 cR | ia1 ia2 iaR1 iaRm1 ia3 ia4 iaR2 iaRm2 ia5 ia6 iaR3 iaRm3 ]. - + - rewrite /=. - (* have E' := (ap (fun x => K1 A' B' C' x e1 p1) (Rm_Unit u1 u2 uR)). *) - (* have E'' := (ap (fun x => K1 A' B' C' u2 x p1) (Rm_enum e1 e2 eR)). *) - (* have E''' := (ap (fun x => K1 A' B' C' u2 e2 x) (Rm_pp p1 p2 pR)). *) - (* exact: (E' @ E'' @ E'''). *) - exact: ((ap (fun x => K1 A' B' C' x e1 p1) (Rm_Unit u1 u2 uR))@ - (ap (fun x => K1 A' B' C' u2 x p1) (Rm_enum e1 e2 eR))@ - (ap (fun x => K1 A' B' C' u2 e2 x) (Rm_pp p1 p2 pR))). - + - (* rewrite /=. *) - (* have E' := (ap (fun x => K2 A' B' C' x (map BR b1) (map CR c1)) (R_in_map AR a1 a2 aR)). *) - (* have E'' := (ap (fun x => K2 A' B' C' a2 x (map CR c1)) (R_in_map BR b1 b2 bR)). *) - (* have E''' := (ap (fun x => K2 A' B' C' a2 b2 x) (R_in_map CR c1 c2 cR)). *) - (* exact: (E' @ E'' @ E'''). *) - exact ((ap (fun x => K2 A' B' C' x (map BR b1) (map CR c1)) (R_in_map AR a1 a2 aR)) @ - (ap (fun x => K2 A' B' C' a2 x (map CR c1)) (R_in_map BR b1 b2 bR)) @ - (ap (fun x => K2 A' B' C' a2 b2 x) (R_in_map CR c1 c2 cR))). - - (* rewrite /=. *) - (* have /= E' := (ap (fun x => K4 A' B' C' x (issue_map A A' AR B B' BR C C' CR ia3) (issue_map A A' AR B B' BR C C' CR ia5)) (F _ _ iaR1)). *) - (* have /= E'' := (ap (fun x => K4 A' B' C' ia2 x (issue_map A A' AR B B' BR C C' CR ia5)) (F _ _ iaR2)). *) - (* have /= E''' := (ap (fun x => K4 A' B' C' ia2 ia4 x) (F _ _ iaR3)). *) - + exact ((ap (fun x => K4 A' B' C' x (issue_map_fix A A' AR B B' BR C C' CR ia3) (issue_map_fix A A' AR B B' BR C C' CR ia5)) (issue_Rm A A' AR B B' BR C C' CR _ _ iaR1)) @ - (ap (fun x => K4 A' B' C' ia2 x (issue_map_fix A A' AR B B' BR C C' CR ia5)) (issue_Rm A A' AR B B' BR C C' CR _ _ iaR2)) @ - (ap (fun x => K4 A' B' C' ia2 ia4 x) (issue_Rm A A' AR B B' BR C C' CR _ _ iaR3))). - Defined. - -(* Lemma HH A' B' C' u1 u2 e1 e2 p1 p2 E E' : *) -(* (issue_k1_inj1 A' B' C' u1 u2 e1 e2 p1 p2 *) -(* ((ap (fun x : Unit => K1 A' B' C' x e1 p1) E @ *) -(* E'))) = E. *) -(* Proof. *) -(* move: u1 u2 E E'. *) -(* refine (fun u1 u2 E => match E as p0 in _ = t return *) -(* forall E', issue_k1_inj1 A' B' C' u1 t e1 e2 p1 p2 (ap (fun x : Unit => K1 A' B' C' x e1 p1) p0 @ E') = p0 *) -(* with eq_refl => _ end *) -(* ). *) -(* refine( fun E' => match E' as p0 in _ = t return *) -(* issue_k1_inj1 A' B' C' u1 u1 e1 e1 p1 p1 (ap (fun x : Unit => K1 A' B' C' x e1 p1) 1 @ p0) = 1 *) -(* with eq_refl => _ end *) -(* ). *) -(* rewrite /issue_k1_inj1. *) -(* (* rewrite /issue_k1_proj1. *) *) -(* rewrite ap_pp. *) -(* (* rewrite -ap_compose /= ap_idmap. *) *) -(* (* (* move: E; elim: u1. elim: u2. *) *) *) - -Definition issue_k1_inj1K : forall A' B' C' u1 u2 (p1 : u1 = u2) e1 e2 (p2 : e1 = e2) pp1 pp2 (p3 : pp1 = pp2), - issue_k1_inj1 A' B' C' u1 u2 e1 e2 pp1 pp2 - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p1 @ - ap (fun x : enum => K1 A' B' C' u2 x pp1) p2) @ - ap (fun x : pp => K1 A' B' C' u2 e2 x) p3) = p1 . -Proof. - move=> A' B' C'. - refine (fun u1 u2 p1 => match p1 as p0 in _ = t return - forall (e1 e2 : enum) (p2 : e1 = e2) (pp1 pp2 : pp) (p3 : pp1 = pp2), - issue_k1_inj1 A' B' C' u1 t e1 e2 pp1 pp2 - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p0 @ ap (fun x : enum => K1 A' B' C' t x pp1) p2) @ - ap (fun x : pp => K1 A' B' C' t e2 x) p3) = p0 - with eq_refl => _ end - ). - refine (fun e1 e2 p2 => match p2 as p0 in _ = t return - forall (pp1 pp2 : pp) (p3 : pp1 = pp2), - issue_k1_inj1 A' B' C' u1 u1 e1 t pp1 pp2 - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 - @ ap (fun x : enum => K1 A' B' C' u1 x pp1) p0) @ - ap (fun x : pp => K1 A' B' C' u1 t x) p3) = 1 - with eq_refl => _ end - ). - refine (fun pp1 pp2 p3 => match p3 as p0 in _ = t return - issue_k1_inj1 A' B' C' u1 u1 e1 e1 pp1 t - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 - @ ap (fun x : enum => K1 A' B' C' u1 x pp1) 1) @ - ap (fun x : pp => K1 A' B' C' u1 e1 x) p0) = 1 - with eq_refl => eq_refl end - ). -Defined. - -Definition issue_k1_inj2K : forall A' B' C' u1 u2 (p1 : u1 = u2) e1 e2 (p2 : e1 = e2) pp1 pp2 (p3 : pp1 = pp2), - (issue_k1_inj2 A' B' C' u1 u2 e1 e2 pp1 pp2 - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p1 @ - ap (fun x : enum => K1 A' B' C' u2 x pp1) p2) @ - ap (fun x : pp => K1 A' B' C' u2 e2 x) p3)) = p2. -Proof. -move=> A' B' C'. -refine (fun u1 u2 p1 => match p1 as p0 in _ = t - return - forall (e1 e2 : enum) (p2 : e1 = e2) - (pp1 pp2 : pp) (p3 : pp1 = pp2), - issue_k1_inj2 A' B' C' u1 t e1 e2 pp1 pp2 - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p0 @ ap (fun x : enum => K1 A' B' C' t x pp1) p2) @ - ap (fun x : pp => K1 A' B' C' t e2 x) p3) = p2 - with eq_refl => _ end - ). -refine (fun e1 e2 p2 => match p2 as p0 in _ = t - return - forall (pp1 pp2 : pp) (p3 : pp1 = pp2), - issue_k1_inj2 A' B' C' u1 u1 e1 t pp1 pp2 - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 @ ap (fun x : enum => K1 A' B' C' u1 x pp1) p0) @ - ap (fun x : pp => K1 A' B' C' u1 t x) p3) = p0 - with eq_refl => _ end - ). -refine (fun pp1 pp2 p3 => match p3 as p0 in _ = t - return - issue_k1_inj2 A' B' C' u1 u1 e1 e1 pp1 t - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 @ ap (fun x : enum => K1 A' B' C' u1 x pp1) 1) @ - ap (fun x : pp => K1 A' B' C' u1 e1 x) p0) = 1 - with eq_refl => eq_refl end - ). -Defined. - -Definition issue_k1_inj3K : forall A' B' C' u1 u2 (p1 : u1 = u2) e1 e2 (p2 : e1 = e2) pp1 pp2 (p3 : pp1 = pp2), - (issue_k1_inj3 A' B' C' u1 u2 e1 e2 pp1 pp2 - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p1 @ - ap (fun x : enum => K1 A' B' C' u2 x pp1) p2) @ - ap (fun x : pp => K1 A' B' C' u2 e2 x) p3)) = p3. -Proof. - move=> A' B' C'. - refine ( - fun u1 u2 p1 => match p1 as p0 in _ = t return - forall e1 e2 p2 pp1 pp2 p3, - (issue_k1_inj3 A' B' C' u1 t e1 e2 pp1 pp2 - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) p0 @ - ap (fun x : enum => K1 A' B' C' t x pp1) p2) @ - ap (fun x : pp => K1 A' B' C' t e2 x) p3)) = p3 - with eq_refl => _ end ). - refine ( - fun e1 e2 p2 => match p2 as p0 in _ = t return - forall pp1 pp2 p3, - (issue_k1_inj3 A' B' C' u1 u1 e1 t pp1 pp2 - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 @ - ap (fun x : enum => K1 A' B' C' u1 x pp1) p0) @ - ap (fun x : pp => K1 A' B' C' u1 t x) p3)) = p3 - with eq_refl => _ end ). - refine ( - fun pp1 pp2 p3 => match p3 as p0 in _ = t return - (issue_k1_inj3 A' B' C' u1 u1 e1 e1 pp1 t - ((ap (fun x : Unit => K1 A' B' C' x e1 pp1) 1 @ - ap (fun x : enum => K1 A' B' C' u1 x pp1) 1) @ - ap (fun x : pp => K1 A' B' C' u1 e1 x) p0)) = p0 - with eq_refl => eq_refl end ). - Defined. - -Definition issue_k2_inj1K : - forall A' B' C' - a1 a2 (p1 : a1 = a2) b1 b2 (p2 : b1 = b2) c1 c2 (p3 : c1 = c2), - (issue_k2_inj1 A' B' C' a1 a2 b1 b2 c1 c2 - ((ap (fun x : A' => K2 A' B' C' x b1 c1) p1 @ - ap (fun x : B' => K2 A' B' C' a2 x c1) p2) @ - ap (fun x : C' => K2 A' B' C' a2 b2 x) p3)) = p1 . -Proof. -move=> A' B' C'. -refine (fun a1 a2 p1 => match p1 as p0 in _ = t return -forall (b1 b2 : B') (p2 : b1 = b2) (c1 c2 : C') (p3 : c1 = c2), - issue_k2_inj1 A' B' C' a1 t b1 b2 c1 c2 - ((ap (fun x : A' => K2 A' B' C' x b1 c1) p0 @ ap (fun x : B' => K2 A' B' C' t x c1) p2) @ - ap (fun x : C' => K2 A' B' C' t b2 x) p3) = p0 - with eq_refl => _ end). -refine (fun b1 b2 p2 => match p2 as p0 in _ = t return -forall (c1 c2 : C') (p3 : c1 = c2), - issue_k2_inj1 A' B' C' a1 a1 b1 t c1 c2 - ((ap (fun x : A' => K2 A' B' C' x b1 c1) 1 @ ap (fun x : B' => K2 A' B' C' a1 x c1) p0) @ - ap (fun x : C' => K2 A' B' C' a1 t x) p3) = 1 - with eq_refl => _ end). -refine (fun c1 c2 p3 => match p3 as p0 in _ = t return - issue_k2_inj1 A' B' C' a1 a1 b1 b1 c1 t - ((ap (fun x : A' => K2 A' B' C' x b1 c1) 1 @ ap (fun x : B' => K2 A' B' C' a1 x c1) 1) @ - ap (fun x : C' => K2 A' B' C' a1 b1 x) p0) = 1 - with eq_refl => eq_refl end). -Defined. - - -Definition issue_k2_inj2K : - forall A' B' C' - a1 a2 (p1 : a1 = a2) b1 b2 (p2 : b1 = b2) c1 c2 (p3 : c1 = c2), - (issue_k2_inj2 A' B' C' (a1) a2 (b1) b2 (c1) c2 - ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) p1 @ - ap (fun x : B' => K2 A' B' C' a2 x (c1)) p2) @ - ap (fun x : C' => K2 A' B' C' a2 b2 x) p3)) = p2. - move=> A' B' C'. - refine ( - fun a1 a2 (p1 : a1 = a2)=> match p1 as p0 in _ = t return - forall b1 b2 (p2 : b1 = b2) c1 c2 (p3 : c1 = c2), -(issue_k2_inj2 A' B' C' (a1) t (b1) b2 (c1) c2 - ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) p0 @ - ap (fun x : B' => K2 A' B' C' t x (c1)) p2) @ - ap (fun x : C' => K2 A' B' C' t b2 x) p3)) = p2 - with eq_refl => _ end - ). - refine ( - fun b1 b2 (p2 : b1 = b2)=> match p2 as p0 in _ = t return - forall c1 c2 (p3 : c1 = c2), -(issue_k2_inj2 A' B' C' (a1) (a1) (b1) t (c1) c2 - ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) 1 @ - ap (fun x : B' => K2 A' B' C' (a1) x (c1)) p0) @ - ap (fun x : C' => K2 A' B' C' (a1) t x) p3)) = p0 - with eq_refl => _ end - ). - refine ( - fun c1 c2 (p3 : c1 = c2)=> match p3 as p0 in _ = t return -(issue_k2_inj2 A' B' C' (a1) (a1) (b1) (b1) (c1) t - ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) 1 @ - ap (fun x : B' => K2 A' B' C' (a1) x (c1)) 1) @ - ap (fun x : C' => K2 A' B' C' (a1) (b1) x) p0)) = 1 - with eq_refl => eq_refl end - ). -Defined. - -Definition issue_k2_inj3K : - forall A' B' C' - a1 a2 (p1 : a1 = a2) b1 b2 (p2 : b1 = b2) c1 c2 (p3 : c1 = c2), - (issue_k2_inj3 A' B' C' (a1) a2 (b1) b2 (c1) c2 - ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) p1 @ - ap (fun x : B' => K2 A' B' C' a2 x (c1)) p2) @ - ap (fun x : C' => K2 A' B' C' a2 b2 x) p3)) = p3. - move=> A' B' C'. - refine ( - fun a1 a2 (p1 : a1 = a2)=> match p1 as p0 in _ = t return - forall b1 b2 (p2 : b1 = b2) c1 c2 (p3 : c1 = c2), -(issue_k2_inj3 A' B' C' (a1) t (b1) b2 (c1) c2 - ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) p0 @ - ap (fun x : B' => K2 A' B' C' t x (c1)) p2) @ - ap (fun x : C' => K2 A' B' C' t b2 x) p3)) = p3 - with eq_refl => _ end - ). - refine ( - fun b1 b2 (p2 : b1 = b2)=> match p2 as p0 in _ = t return - forall c1 c2 (p3 : c1 = c2), -(issue_k2_inj3 A' B' C' (a1) (a1) (b1) t (c1) c2 - ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) 1 @ - ap (fun x : B' => K2 A' B' C' (a1) x (c1)) p0) @ - ap (fun x : C' => K2 A' B' C' (a1) t x) p3)) = p3 - with eq_refl => _ end - ). - refine ( - fun c1 c2 (p3 : c1 = c2)=> match p3 as p0 in _ = t return -(issue_k2_inj3 A' B' C' (a1) (a1) (b1) (b1) (c1) t - ((ap (fun x : A' => K2 A' B' C' x (b1) (c1)) 1 @ - ap (fun x : B' => K2 A' B' C' (a1) x (c1)) 1) @ - ap (fun x : C' => K2 A' B' C' (a1) (b1) x) p0)) = p0 - with eq_refl => eq_refl end - ). - Defined. - -Definition issue_k4_inj1K : - forall A' B' C', - forall ia1 ia2 (p1 : ia1 = ia2) ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), - (issue_k4_inj1 A' B' C' ( ia1) ia2 ( ia3) ia4 ( ia5) ia6 - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - p1 @ - ap (fun x : issue A' B' C' => K4 A' B' C' ia2 x (ia5)) - p2) @ - ap (fun x : issue A' B' C' => K4 A' B' C' ia2 ia4 x) p3)) = p1. -Proof. - move=> A' B' C'. - refine (fun ia1 ia2 p1 => match p1 as p0 in _ = t return - forall ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), - (issue_k4_inj1 A' B' C' ( ia1) t ( ia3) ia4 ( ia5) ia6 - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - p0 @ - ap (fun x : issue A' B' C' => K4 A' B' C' t x (ia5)) - p2) @ - ap (fun x : issue A' B' C' => K4 A' B' C' t ia4 x) p3)) = p0 - with eq_refl => _ end - ). - refine (fun ia3 ia4 p2 => match p2 as p0 in _ = t return - forall ia5 ia6 (p3 : ia5 = ia6), - (issue_k4_inj1 A' B' C' ( ia1) ( ia1) ( ia3) t ( ia5) ia6 - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - 1 @ - ap (fun x : issue A' B' C' => K4 A' B' C' ( ia1) x (ia5)) - p0) @ - ap (fun x : issue A' B' C' => K4 A' B' C' ( ia1) t x) p3)) = 1 - with eq_refl => _ end - ). - refine (fun ia5 ia6 p3 => match p3 as p0 in _ = t return - (issue_k4_inj1 A' B' C' ( ia1) ( ia1) ( ia3) ( ia3) ( ia5) t - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - 1 @ - ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) x (ia5)) - 1) @ - ap (fun x : issue A' B' C' => K4 A' B' C' ( ia1) ( ia3) x) p0)) = 1 - with eq_refl => eq_refl end - ). -Defined. - -Definition issue_k4_inj2K : forall A' B' C', - forall ia1 ia2 (p1 : ia1 = ia2) ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), - (issue_k4_inj2 A' B' C' (ia1) ia2 (ia3) ia4 (ia5) ia6 - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - p1 @ - ap (fun x : issue A' B' C' => K4 A' B' C' ia2 x (ia5)) - p2) @ - ap (fun x : issue A' B' C' => K4 A' B' C' ia2 ia4 x) p3)) = p2. -Proof. - move=> A' B' C'. - refine (fun ia1 ia2 p1 => match p1 as p0 in _ = t return - forall ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), - (issue_k4_inj2 A' B' C' (ia1) t (ia3) ia4 (ia5) ia6 - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - p0 @ - ap (fun x : issue A' B' C' => K4 A' B' C' t x (ia5)) - p2) @ - ap (fun x : issue A' B' C' => K4 A' B' C' t ia4 x) p3)) = p2 - with eq_refl => _ end - ). - refine (fun ia3 ia4 p2 => match p2 as p0 in _ = t return - forall ia5 ia6 (p3 : ia5 = ia6), - (issue_k4_inj2 A' B' C' (ia1) (ia1) (ia3) t (ia5) ia6 - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - 1 @ - ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) x (ia5)) - p0) @ - ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) t x) p3)) = p0 - with eq_refl => _ end - ). - refine (fun ia5 ia6 p3 => match p3 as p0 in _ = t return - (issue_k4_inj2 A' B' C' (ia1) (ia1) (ia3) (ia3) (ia5) t - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - 1 @ - ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) x (ia5)) - 1) @ - ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) (ia3) x) p0)) = 1 - with eq_refl => eq_refl end - ). -Defined. - -Definition issue_k4_inj3K : forall A' B' C', - forall ia1 ia2 (p1 : ia1 = ia2) ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), - (issue_k4_inj3 A' B' C' (ia1) ia2 (ia3) ia4 (ia5) ia6 - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - p1 @ - ap (fun x : issue A' B' C' => K4 A' B' C' ia2 x (ia5)) - p2) @ - ap (fun x : issue A' B' C' => K4 A' B' C' ia2 ia4 x) p3)) = p3. -Proof. - move=> A' B' C'. - refine (fun ia1 ia2 p1 => match p1 as p0 in _ = t return - forall ia3 ia4 (p2 : ia3 = ia4) ia5 ia6 (p3 : ia5 = ia6), - (issue_k4_inj3 A' B' C' (ia1) t (ia3) ia4 (ia5) ia6 - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - p0 @ - ap (fun x : issue A' B' C' => K4 A' B' C' t x (ia5)) - p2) @ - ap (fun x : issue A' B' C' => K4 A' B' C' t ia4 x) p3)) = p3 - with eq_refl => _ end - ). - refine (fun ia3 ia4 p2 => match p2 as p0 in _ = t return - forall ia5 ia6 (p3 : ia5 = ia6), - (issue_k4_inj3 A' B' C' (ia1) (ia1) (ia3) t (ia5) ia6 - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - 1 @ - ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) x (ia5)) - p0) @ - ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) t x) p3)) = p3 - with eq_refl => _ end - ). - refine (fun ia5 ia6 p3 => match p3 as p0 in _ = t return - (issue_k4_inj3 A' B' C' (ia1) (ia1) (ia3) (ia3) (ia5) t - ((ap - (fun x : issue A' B' C' => - K4 A' B' C' x (ia3) (ia5)) - 1 @ - ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) x (ia5)) - 1) @ - ap (fun x : issue A' B' C' => K4 A' B' C' (ia1) (ia3) x) p0)) = p0 - with eq_refl => eq_refl end - ). - Defined. - -Definition mRRmKIssue - (A A' : Type) (AR : Param40.Rel A A') - (B B' : Type) (BR : Param40.Rel B B') - (C C' : Type) (CR : Param40.Rel C C') - : forall ia ia' (iaR : issueR A A' AR B B' BR C C' CR ia ia'), - issue_mR A A' AR B B' BR C C' CR _ _ (issue_Rm A A' AR B B' BR C C' CR _ _ iaR) = iaR. -Proof. - move=> ia ia'. - elim=> [u1 u2 uR e1 e2 eR p1 p2 pR /= | a1 a2 aR b1 b2 bR c1 c2 cR /= | ia1 ia2 iaR1 IH1 ia3 ia4 iaR2 IH2 ia5 ia6 iaR3 IH3 /=]. - + rewrite issue_k1_inj1K issue_k1_inj2K issue_k1_inj3K. - by rewrite mRRmK_Unit mRRmKEnum mRRmK_pp. - + rewrite issue_k2_inj1K issue_k2_inj2K issue_k2_inj3K. - by rewrite !R_in_mapK. - + rewrite issue_k4_inj1K issue_k4_inj2K issue_k4_inj3K. - by rewrite IH1 IH2 IH3. - Qed. -Inductive enum3R : enum3 -> enum3 -> Type := -| KK1R : forall (u1 u2 : unit), UnitR u1 u2 - -> forall (u3 u4 : unit), UnitR u3 u4 - -> enum3R (KK1 u1 u3) (KK1 u2 u4) -| KK2R : forall (b1 b2 : bool), BoolR b1 b2 - -> forall (b3 b4 : bool), BoolR b3 b4 - -> enum3R (KK2 b1 b3) (KK2 b2 b4). diff --git a/generic/inductives/Gen.v b/generic/inductives/Gen.v deleted file mode 100644 index df30c9d4..00000000 --- a/generic/inductives/Gen.v +++ /dev/null @@ -1,10 +0,0 @@ -From elpi.apps Require Export derive. - -From elpi.apps Require Export - derive.param2 - derive.projK. - -From Trocq Require Export HoTTNotations Hierarchy Stdlib. -From Trocq Require Export sym symK RsymK. -From Trocq Require Export injection_lemmas injK. -From Trocq Require Export mymap mR Rm mRRmK mapn Relnm. \ No newline at end of file diff --git a/hott/Param_lemmas.v b/hott/Param_lemmas.v index ab4fd81c..7aebbd78 100644 --- a/hott/Param_lemmas.v +++ b/hott/Param_lemmas.v @@ -175,6 +175,133 @@ Register eq_Map2b as trocq.eq_map2b. Register eq_Map3 as trocq.eq_map3. Register eq_Map4 as trocq.eq_map4. +Section rel_uniq_refl. + + Variable A : Type. + + Variable AR : A -> A -> Type. + Hypothesis AR_refl : forall a : A, AR a a. + Hypothesis AR_eqb : forall a1 a2 : A, AR a1 a2 -> a1 = a2. + Hypothesis rel_refl_uniq : forall (a : A) (r1 : AR a a), r1 = (AR_refl a). + + Lemma eqb_AR (a1 a2 : A) : a1 = a2 -> AR a1 a2. + Proof. by move=> ->; apply AR_refl. Qed. + + Lemma AR_irrel : forall (a1 a2 : A) (r1 r2 : AR a1 a2), r1 = r2. + Proof. + move=> a1 a2 r. + have e : a1 = a2 by apply AR_eqb. + move: r; rewrite {}e=> r1 r2. + by rewrite (rel_refl_uniq _ r1) (rel_refl_uniq _ r2). + Qed. + + Definition mapR : A -> A := idmap. + + Lemma mR : forall a1 a2 : A, mapR a1 = a2 -> AR a1 a2. + Proof. by move=> a1 a2; by rewrite /mapR=> ->; apply AR_refl. Qed. + + Lemma Rm : forall a1 a2 : A, AR a1 a2 -> idmap a1 = a2. + Proof. by move=> /= a1 a2 /AR_eqb ->. Qed. + + Lemma mRRmK : forall (a1 a2 : A) (r : AR a1 a2), mR a1 a2 (Rm a1 a2 r) = r. + Proof. by move=> a1 a2 r; apply AR_irrel. Qed. + + Lemma Map4_AR : Map4.Has AR. + Proof. + unshelve econstructor. + - by apply mapR. + - by apply mR. + - by apply Rm. + - by apply mRRmK. + Qed. + + Lemma AR_sym : forall a1 a2, AR a1 a2 -> AR a2 a1. + Proof. by move=> a1 a2 /AR_eqb ->; apply AR_refl. Qed. + + Lemma AR_sym_R : forall (a1 a2 : A), sym_rel AR a1 a2 <->> AR a1 a2. + Proof. + move=> a1 a2; unshelve eexists _,_ . + - by apply AR_sym. + - by apply AR_sym. + - by move=> r; apply AR_irrel. + Qed. + + Lemma Param44_AR : Param44.Rel A A. + Proof. + unshelve econstructor. + - exact AR. + - exact Map4_AR. + - apply (fun e => @eq_Map4 _ _ (sym_rel AR) AR e Map4_AR). + apply AR_sym_R. + Qed. + +End rel_uniq_refl. + +Section RmmRK. + + Variable A B : Type. + Variable R : A -> B -> Type. + Variable map : A -> B. + Variable map_in_R : forall x y, map x = y -> R x y. + Variable R_in_map : forall x y, R x y -> map x = y. + Variable mRRmK : forall x y (r : R x y), map_in_R _ _ (R_in_map _ _ r) = r. + + Definition F {x : A} {y : B} (p : map x = y) := apD (R_in_map x) p. + + Definition inverses_concat_tr : forall x y, + forall p : map x = y, + R_in_map x (map x) (map_in_R x (map x) 1) @ p + = R_in_map x y (transport _ p (map_in_R x (map x) 1)). + Proof. + move=> x y p. + rewrite -transport_paths_r. + apply Wdpath_arrow. + exact: F. + Defined. + + Definition path_shape {x y} : + forall p : map x = y, + p = (R_in_map x (map x) (map_in_R x (map x) 1))^ + @ R_in_map x y (transport _ p (map_in_R x (map x) 1)). + Proof. + move=> p. + rewrite -[X in X = _](concat_1p p). + rewrite -[X in X @ p](concat_Vp (R_in_map x (map x) (map_in_R x (map x) 1))). + rewrite concat_pp_p; apply ap. + apply inverses_concat_tr. + Defined. + + Lemma tr_1 : forall (x : A) y (p : map x = y), + transport (fun y=> R x y) p (map_in_R _ _ 1) = (map_in_R x y p). + Proof. + move=> x y p. + by case: _ / p . + Defined. + + Lemma Rm_concat : forall a b b' + (e : map a = b) + (e1 : b = b'), + R_in_map a b' (map_in_R a b' (e @ e1)) = + R_in_map a b (map_in_R a b e) @ e1. + Proof. + move=> a b1 b2 e e1. + by case: _ / e1; rewrite !concat_p1. + Defined. + + Definition RmmRK : forall a b (e : map a = b), + R_in_map _ _ (map_in_R _ _ e) = e. + Proof. + move=> a b e. + rewrite [X in _ = X](path_shape e). + rewrite tr_1. + set q := R_in_map a b _. + set p := R_in_map _ _ _. + apply (moveL_Vp q q p). + rewrite -Rm_concat concat_1p. + by rewrite /q mRRmK. + Defined. + +End RmmRK. (************************) (* Proofs about Param44 *) diff --git a/hott/Stdlib.v b/hott/Stdlib.v index 1f6c76fb..1f6c1b05 100644 --- a/hott/Stdlib.v +++ b/hott/Stdlib.v @@ -27,4 +27,15 @@ Register exist as trocq.exist. Register ap as trocq.ap. Definition paths_nondep (A : Type) (x : A) (P : A -> Type) : P x -> forall y : A, x = y -> P y := - fun w y e=> paths_rect A x (fun a0 e => P a0) w y e. \ No newline at end of file + fun w y e=> paths_rect A x (fun a0 e => P a0) w y e. + +(* Weak HoTT.Types.Arrow.dpath_arrow. *) +Lemma Wdpath_arrow : forall {T : Type}{P Q : T -> Type} {x y : T} (p : x = y) + (f : P x -> Q x) (g : P y -> Q y), + transport (fun x => P x -> Q x) p f = g -> + forall x, transport _ p (f x) = g (transport _ p x). +Proof. +intros T P Q x y p. +destruct p; simpl; intros f g ->. +reflexivity. +Defined. diff --git a/std/Param_lemmas.v b/std/Param_lemmas.v index 4050523f..bc053fbf 100644 --- a/std/Param_lemmas.v +++ b/std/Param_lemmas.v @@ -174,4 +174,131 @@ Register eq_Map1 as trocq.eq_map1. Register eq_Map2a as trocq.eq_map2a. Register eq_Map2b as trocq.eq_map2b. Register eq_Map3 as trocq.eq_map3. -Register eq_Map4 as trocq.eq_map4. \ No newline at end of file +Register eq_Map4 as trocq.eq_map4. + +Section propRel. + + Variable A : Type. + + Variable AR : A -> A -> Type. + Hypothesis AR_refl : forall a : A, AR a a. + Hypothesis AR_eqb : forall a1 a2 : A, AR a1 a2 -> a1 = a2. + Hypothesis rel_refl_uniq : forall (a : A) (r1 : AR a a), r1 = (AR_refl a). + + Lemma eqb_AR (a1 a2 : A) : a1 = a2 -> AR a1 a2. + Proof. by move=> ->; apply AR_refl. Qed. + + Lemma AR_irrel : forall (a1 a2 : A) (r1 r2 : AR a1 a2), r1 = r2. + Proof. + move=> a1 a2 r. + have e : a1 = a2 by apply AR_eqb. + move: r; rewrite {}e=> r1 r2. + by rewrite (rel_refl_uniq _ r1) (rel_refl_uniq _ r2). + Qed. + + Definition mapR : A -> A := idmap. + + Lemma mR : forall a1 a2 : A, mapR a1 = a2 -> AR a1 a2. + Proof. by move=> a1 a2; by rewrite /mapR=> ->; apply AR_refl. Qed. + + Lemma Rm : forall a1 a2 : A, AR a1 a2 -> idmap a1 = a2. + Proof. by move=> /= a1 a2 /AR_eqb ->. Qed. + + Lemma mRRmK : forall (a1 a2 : A) (r : AR a1 a2), mR a1 a2 (Rm a1 a2 r) = r. + Proof. by move=> a1 a2 r; apply AR_irrel. Qed. + + Lemma Map4_AR : Map4.Has AR. + Proof. + unshelve econstructor. + - by apply mapR. + - by apply mR. + - by apply Rm. + - by apply mRRmK. + Qed. + + Lemma AR_sym : forall a1 a2, AR a1 a2 -> AR a2 a1. + Proof. by move=> a1 a2 /AR_eqb ->; apply AR_refl. Qed. + + Lemma AR_sym_R : forall (a1 a2 : A), sym_rel AR a1 a2 <->> AR a1 a2. + Proof. + move=> a1 a2; unshelve eexists _,_ . + - by apply AR_sym. + - by apply AR_sym. + - by move=> r; apply AR_irrel. + Qed. + + Lemma Param44_AR : Param44.Rel A A. + Proof. + unshelve econstructor. + - exact AR. + - exact Map4_AR. + - apply (fun e => @eq_Map4 _ _ (sym_rel AR) AR e Map4_AR). + apply AR_sym_R. + Qed. + +End propRel. + +Section RmmRK. + + Variable A B : Type. + Variable R : A -> B -> Type. + Variable map : A -> B. + Variable map_in_R : forall x y, map x = y -> R x y. + Variable R_in_map : forall x y, R x y -> map x = y. + Variable mRRmK : forall x y (r : R x y), map_in_R _ _ (R_in_map _ _ r) = r. + + Definition F {x : A} {y : B} (p : map x = y) := apd (R_in_map x) p. + + Definition inverses_concat_tr : forall x y, + forall p : map x = y, + R_in_map x (map x) (map_in_R x (map x) 1) @ p + = R_in_map x y (transport _ p (map_in_R x (map x) 1)). + Proof. + move=> x y p. + rewrite -tr_concat. + apply Wdpath_arrow. + exact: F. + Defined. + + Definition path_shape {x y} : + forall p : map x = y, + p = (R_in_map x (map x) (map_in_R x (map x) 1))^ + @ R_in_map x y (transport _ p (map_in_R x (map x) 1)). + Proof. + move=> p. + rewrite -[LHS](concat_1p p). + rewrite -[X in X @ p](concat_Vp (R_in_map x (map x) (map_in_R x (map x) 1))). + rewrite concat_pp_p; apply ap. + by apply inverses_concat_tr. + Defined. + + Lemma tr_1 : forall (x : A) y (p : map x = y), + transport (fun y=> R x y) p (map_in_R _ _ 1) = (map_in_R x y p). + Proof. + move=> x y p. + by case: _ / p . + Defined. + + Lemma Rm_concat : forall a b b' + (e : map a = b) + (e1 : b = b'), + R_in_map a b' (map_in_R a b' (e @ e1)) = + R_in_map a b (map_in_R a b e) @ e1. + Proof. + move=> a b1 b2 e e1. + by case: _ / e1. + Defined. + + Definition RmmRK : forall a b (e : map a = b), + R_in_map _ _ (map_in_R _ _ e) = e. + Proof. + move=> a b e. + rewrite [RHS](path_shape e) tr_1. + set q := R_in_map a b _. + set p := R_in_map _ _ _. + apply (moveL_Vp p q q). + rewrite -Rm_concat concat_1p. + by rewrite /q mRRmK. + Defined. + +End RmmRK. \ No newline at end of file diff --git a/std/Stdlib.v b/std/Stdlib.v index 3a3a30ca..e850d07f 100644 --- a/std/Stdlib.v +++ b/std/Stdlib.v @@ -168,3 +168,28 @@ Definition is_true: Bool -> Type := | false => Empty end. +Definition apd {T : Type}{P : T -> Type} (f : forall x, P x) {x y : T} (p : x = y) : + transport _ p (f x) = f y. +Proof. by case: _ / p. Defined. + +Lemma tr_concat {T : Type} {x y z : T} (p : x = y) (q : y = z) : transport _ q p = p @ q. +Proof. by case: _ /q; case: _ /p. Defined. + +Lemma moveL_Vp : forall {T : Type} + {x y : T} (p : x = y) {z : T} (q : y = z) (r : x = z), + p @ q = r -> q = p^ @ r. +Proof. +move=> T x y p. +case : _ / p => /= z q r. +by rewrite !concat_1p. +Defined. + +Lemma Wdpath_arrow : forall {T : Type}{P Q : T -> Type} {x y : T} (p : x = y) + (f : P x -> Q x) (g : P y -> Q y), + transport (fun x => P x -> Q x) p f = g -> + forall x, transport _ p (f x) = g (transport _ p x). +Proof. +move=> T P Q x y p. +case: _ / p. +by rewrite /transport/eq_rect_r/= => f g -> //. +Defined. \ No newline at end of file diff --git a/std/algo/aignore/testing.v b/std/algo/aignore/testing.v deleted file mode 100644 index 7308b4bc..00000000 --- a/std/algo/aignore/testing.v +++ /dev/null @@ -1,54 +0,0 @@ -From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -(* From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as inject. *) -(* From elpi.apps.derive.elpi Extra Dependency "bcongr.elpi" as bcongr. *) -From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. -From elpi Require Import elpi. -From elpi Require Import derive derive.bcongr derive.eqK derive.isK. - -(* use elpi.rewrite to implement - forall n m, n = m -> S n = S m. -*) -(* build a function of type forall n1, n1 = 0 -> n1 = 0. -implementing it by case on n1. -O => eq_refl -S n => discriminate. *) -Elpi Command test4. -Elpi Accumulate File discr. -Elpi Accumulate Db derive.isK.db. -Elpi Accumulate lp:{{ - - pred mkty i:(term -> term), i:term, i:list term, i:list term, o:term. - mkty Bo _ Ts _ (Bo X):- - std.last Ts X. - - pred mkBranch i:(term -> term), i:term, i:term, i:term, i:list term, i:list term, o:term. - mkBranch _ K T _ _ _ {{ fun e => eq_refl }} :- - coq.safe-dest-app T K _, !. - mkBranch ((n\ prod (En n) (ETy n) (G n))) _ T _ Ts _ (fun (En Curr) (ETy Curr) e\ (R e)) :- - coq.mk-app T Ts Curr, - coq.elaborate-skeleton (ETy Curr) _ ETyE _, - pi e\ - sigma GE\ - coq.elaborate-skeleton (G Curr e) _ GE _, - ltac.discriminate e ETyE GE (R e). - - % given the type build the function - % Bo n1 = n1 = 0 -> n1 = 0 - pred build i: term, o:term. - build (prod N1 {{nat}} n1\ (Bo n1)) - (fun N1 {{nat}} n1\ (R n1)) :- - @pi-decl N1 {{ nat }} n1\ - coq.build-match n1 {{ nat }} {{ _ }} (mkBranch Bo {{ 0 }}) (R n1). - - main _ :- - RTy = {{ forall (n1 : nat), n1 = 0 -> n1 = 0 }}, - build RTy R, - FName is "def4", - coq.elaborate-skeleton R RTy RE _, - coq.env.add-const FName RE _ _ _. - -}}. -Elpi derive.isK nat. -Elpi Query lp:{{ - main R. -}}. \ No newline at end of file diff --git a/tests/inductives/rmmrK.v b/tests/inductives/rmmrK.v deleted file mode 100644 index 662baf4b..00000000 --- a/tests/inductives/rmmrK.v +++ /dev/null @@ -1,113 +0,0 @@ -Require Import ssreflect. -From Trocq Require Import Trocq. - -Require Import HoTTNotations. - -Section Preliminary. - - Definition tr {T : Type}{x y : T} (P : T -> Type) (p : x = y) : P x -> P y. - refine (match p with eq_refl => fun P => P end). - Defined. - - Definition apd {T : Type}{P : T -> Type} (f : forall x, P x) {x y : T} (p : x = y) : - tr _ p (f x) = f y. - Proof. - refine (match p with eq_refl => eq_refl end). - Defined. - - Lemma tr_concat {T : Type} {x y z : T} (p : x = y) (q : y = z) : tr _ q p = p @ q. - Proof. - move: q. - refine (match p as p0 in _ = t return forall (q : t = z), tr _ q p0 = p0 @ q with eq_refl => _ end). - exact (fun q => match q with eq_refl => 1 end). - Defined. - - Lemma left_transpose_eq_concat : forall {T : Type} - {x y : T} (p : x = y) {z : T} (q : y = z) (r : x = z), - p @ q = r -> q = p^ @ r. - Proof. - move=> T x y p. - case : _ / p => /= z q r. - by rewrite !concat_1p. - Defined. - -(*Lemma 2.9.6 in the HoTT BooK weakened *) -Lemma L : forall {T : Type}{P Q : T -> Type} {x y : T} (p : x = y) (f : P x -> Q x) (g : P y -> Q y) - ,tr (fun x => P x -> Q x) p f = g -> forall x, tr _ p (f x) = g (tr _ p x). -Proof. -move=> T P Q x y p. -case: _ / p. -move=> f g /= -> //. -Defined. - -End Preliminary. - -Section RmmRK. - - Variable A B : Type. - Variable R : A -> B -> Type. - Variable map : A -> B. - Variable map_in_R : forall x y, map x = y -> R x y. - Variable R_in_map : forall x y, R x y -> map x = y. - Variable mRRmK : forall x y (r : R x y), map_in_R _ _ (R_in_map _ _ r) = r. - - Definition F {x : A} {y : B} (p : map x = y) := apd (R_in_map x) p. - - Definition inverses_concat_tr : forall x y, - forall p : map x = y, - R_in_map x (map x) (map_in_R x (map x) 1) @ p - = R_in_map x y (tr _ p (map_in_R x (map x) 1)). - Proof. - move=> x y p. - rewrite -tr_concat. - apply L. - exact: F. - Defined. - - Definition path_shape {x y} : - forall p : map x = y, - p = (R_in_map x (map x) (map_in_R x (map x) 1))^ - @ R_in_map x y (tr _ p (map_in_R x (map x) 1)). - Proof. - move=> p. - rewrite -[LHS](concat_1p p). - rewrite -[X in X @ p](concat_Vp (R_in_map x (map x) (map_in_R x (map x) 1))). - rewrite concat_pp_p. - apply ap. - apply inverses_concat_tr. - Defined. - - Lemma tr_id : forall (x : A) y (p : map x = y), - tr (fun y=> R x y) p (map_in_R _ _ 1) = (map_in_R x y p). - Proof. - move=> x y p. - by case: _ / p . - Defined. - - Lemma Rm_concat : forall a b b' - (e : map a = b) - (e1 : b = b'), - R_in_map a b' (map_in_R a b' (e @ e1)) = - R_in_map a b (map_in_R a b e) @ e1. - Proof. - move=> a b1 b2 e e1. - by case: _ / e1. - Defined. - - Definition RmmRK : forall a b (e : map a = b), - R_in_map _ _ (map_in_R _ _ e) = e. - Proof. - move=> a b e. - rewrite [RHS](path_shape e). - rewrite tr_id. - set q := R_in_map a b _. - set p := R_in_map _ _ _. - apply (left_transpose_eq_concat p q q). - rewrite -Rm_concat. - rewrite concat_1p. - rewrite mRRmK. - reflexivity. - Defined. - -End RmmRK. - From 87c5d261782b9bc680c79748f9d1ec474aaf86bc Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 24 Jun 2026 00:26:46 +0200 Subject: [PATCH 34/42] tidying generalization thm 7.2.2 --- hott/Param_lemmas.v | 80 +++++++++ std/Param_lemmas.v | 82 +++++++++- tests/inductives/merely_inhabited_relation.v | 161 ------------------- 3 files changed, 161 insertions(+), 162 deletions(-) delete mode 100644 tests/inductives/merely_inhabited_relation.v diff --git a/hott/Param_lemmas.v b/hott/Param_lemmas.v index 7aebbd78..11a7a7a6 100644 --- a/hott/Param_lemmas.v +++ b/hott/Param_lemmas.v @@ -302,6 +302,86 @@ Section RmmRK. Defined. End RmmRK. +Section Genthm722. + + Variable A B : Type. + Variable R : A -> B -> Type. + Variable m : A -> B. + Variable Rrefl : forall x y, m x = y -> R x y. (* 2a *) + Variable imp : forall x y, R x y -> m x = y. (* 2b *) + Variable MereR : forall x y (r1 r2 : R x y), r1 = r2. + + Definition inverses_concat_tr' : forall x, + forall p : m x = m x, + imp x (m x) (Rrefl x _ 1) @ p = imp x (m x) (transport _ p (Rrefl x _ 1)). + Proof. + move=> x p. + rewrite -transport_paths_r. + apply Wdpath_arrow. + exact: F. + Defined. + + Definition path_shape' : forall x, + forall p : m x = m x, + p = (imp x (m x) (Rrefl x _ 1))^ @ imp x (m x) (@transport _ _ _ _ p (Rrefl x _ 1)). + Proof. + move=> x p. + rewrite -[X in X = _](concat_1p p). + rewrite -[X in X @ p](concat_Vp (imp x (m x) (Rrefl x _ 1))). + rewrite concat_pp_p. + apply ap. + apply inverses_concat_tr. + Defined. + + Lemma tr_id : forall (x : A) (p : m x = m x), + transport (fun y=> R x y) p (Rrefl x _ 1) = (Rrefl x _ 1). + Proof. move=> x p; apply MereR. Qed. + + Definition UIP_MA {x y : A} (p q : m x = m y): p = q. + Proof. + move: q. + case: _ /p. + move=> q. + rewrite (path_shape' x 1) /=. + rewrite (path_shape' x q). + by rewrite !tr_id. + Defined. + + Section surj. + + Hypothesis comap : B -> A. + Hypothesis corefl : forall b, R (comap b) b. + + Lemma UIP_B : forall (x y : B) (p q : x = y), p = q. + Proof. + move=> x y. + rewrite -(imp _ _ (corefl x)). + rewrite -(imp _ _ (corefl y)). + apply UIP_MA. + Qed. + + End surj. + +End Genthm722. + +Section thm722. + + Variable A : Type. + Variable R : A -> A -> Type. + Variable rrefl : forall x, R x x. (* 2a *) + Definition rrefl' : forall x y, x = y -> R x y. + by move=> x y p; case: _ /p; apply rrefl. + Defined. + Variable imp : forall x y, R x y -> x = y. (* 2b *) + Variable mereR : forall x y (r1 r2 : R x y), r1 = r2. + + Lemma uip_a (x y : A) (p q : x = y) : p = q. + Proof. + apply (UIP_MA A A R (idmap) (rrefl') imp). + by move=> e ?; apply mereR. + Qed. + +End thm722. (************************) (* Proofs about Param44 *) diff --git a/std/Param_lemmas.v b/std/Param_lemmas.v index bc053fbf..861264a2 100644 --- a/std/Param_lemmas.v +++ b/std/Param_lemmas.v @@ -301,4 +301,84 @@ Section RmmRK. by rewrite /q mRRmK. Defined. -End RmmRK. \ No newline at end of file +End RmmRK. +Section Genthm722. + + Variable A B : Type. + Variable R : A -> B -> Type. + Variable m : A -> B. + Variable Rrefl : forall x y, m x = y -> R x y. (* 2a *) + Variable imp : forall x y, R x y -> m x = y. (* 2b *) + Variable MereR : forall x y (r1 r2 : R x y), r1 = r2. + + Definition inverses_concat_tr' : forall x, + forall p : m x = m x, + imp x (m x) (Rrefl x _ 1) @ p = imp x (m x) (transport _ p (Rrefl x _ 1)). + Proof. + move=> x p. + rewrite -tr_concat. + apply Wdpath_arrow. + exact: F. + Defined. + + Definition path_shape' : forall x, + forall p : m x = m x, + p = (imp x (m x) (Rrefl x _ 1))^ @ imp x (m x) (@transport _ _ _ _ p (Rrefl x _ 1)). + Proof. + move=> x p. + rewrite -[LHS](concat_1p p). + rewrite -[X in X @ p = _](concat_Vp (imp x (m x) (Rrefl x _ 1))). + rewrite concat_pp_p. + apply ap. + apply inverses_concat_tr. + Defined. + + Lemma tr_id : forall (x : A) (p : m x = m x), + transport (fun y=> R x y) p (Rrefl x _ 1) = (Rrefl x _ 1). + Proof. move=> x p; apply MereR. Qed. + + Definition UIP_MA {x y : A} (p q : m x = m y): p = q. + Proof. + move: q. + case: _ / p. + move=> q. + rewrite (path_shape' x 1) /=. + rewrite (path_shape' x q). + by rewrite !tr_id. + Defined. + + Section surj. + + Hypothesis comap : B -> A. + Hypothesis corefl : forall b, R (comap b) b. + + Lemma UIP_B : forall (x y : B) (p q : x = y), p = q. + Proof. + move=> x y. + rewrite -(imp _ _ (corefl x)). + rewrite -(imp _ _ (corefl y)). + apply UIP_MA. + Qed. + + End surj. + +End Genthm722. + +Section thm722. + + Variable A : Type. + Variable R : A -> A -> Type. + Variable rrefl : forall x, R x x. (* 2a *) + Definition rrefl' : forall x y, x = y -> R x y. + by move=> x y p; case: _ /p; apply rrefl. + Defined. + Variable imp : forall x y, R x y -> x = y. (* 2b *) + Variable mereR : forall x y (r1 r2 : R x y), r1 = r2. + + Lemma uip_a (x y : A) (p q : x = y) : p = q. + Proof. + apply (UIP_MA A A R (@id A) (rrefl') imp). + by move=> e ?; apply mereR. + Qed. + +End thm722. \ No newline at end of file diff --git a/tests/inductives/merely_inhabited_relation.v b/tests/inductives/merely_inhabited_relation.v deleted file mode 100644 index 3754298f..00000000 --- a/tests/inductives/merely_inhabited_relation.v +++ /dev/null @@ -1,161 +0,0 @@ - -Require Import ssreflect. -From Trocq Require Import Trocq. - -Require Import HoTTNotations. - -Section Trocqlib. - (* Lemma MereM4 `{Funext} (A B : Type) (R : A -> B -> Type) (map : A -> B) : - {f : forall x : A, R x (map x) & - forall (x : A) (y : B) (r : R x y), {e : map x = y & transport (R x) e (f x) = r}} <~> - {f : forall x : A, R x (map x) & forall (x : A) (y : B) (r : R x y), -(map x; f x) = (y; r)}. *) -End Trocqlib. - -Require Import Stdlib.Program.Equality. - -Section Preliminary. - - Definition tr {T : Type}{x y : T} (P : T -> Type) (p : x = y) : P x -> P y. - refine (match p with eq_refl => fun P => P end). - Defined. - - Definition apd {T : Type}{P : T -> Type} (f : forall x, P x) {x y : T} (p : x = y) : - tr _ p (f x) = f y. - Proof. - refine (match p with eq_refl => eq_refl end). - Defined. - - Lemma tr_concat {T : Type} {x y z : T} (p : x = y) (q : y = z) : tr _ q p = p @ q. - Proof. - move: q. - refine (match p as p0 in _ = t return forall (q : t = z), tr _ q p0 = p0 @ q with eq_refl => _ end). - exact (fun q => match q with eq_refl => 1 end). - Defined. - -End Preliminary. - -(*Lemma 2.9.6 in the HoTT BooK weakened *) -Axiom L : forall {T : Type}{P Q : T -> Type} {x y : T} (p : x = y) (f : P x -> Q x) (g : P y -> Q y) - ,tr (fun x => P x -> Q x) p f = g -> forall x, tr _ p (f x) = g (tr _ p x). - -Section Genthm722. - - Variable A B : Type. - Variable R : A -> B -> Type. - Variable m : A -> B. - Variable Rrefl : forall x, R x (m x). (* 2a *) - Variable imp : forall x y, R x y -> m x = y. (* 2b *) - Variable MereR : forall x y (r1 r2 : R x y), r1 = r2. - - Definition F {x : A} {y : B} (p : m x = y) := apd (imp x) p. - - Definition inverses_concat_tr : forall x, - forall p : m x = m x, - imp x (m x) (Rrefl x) @ p = imp x (m x) (tr _ p (Rrefl x)). - Proof. move=> x p. - rewrite -tr_concat. - apply L. - exact: F. - Defined. - - Definition path_shape : forall x, - forall p : m x = m x, - p = (imp x (m x) (Rrefl x))^ @ imp x (m x) (@tr _ _ _ _ p (Rrefl x)). - Proof. - move=> x p. - rewrite -[LHS](concat_1p p). - rewrite -(concat_Vp (imp x (m x) (Rrefl x))). - rewrite concat_pp_p. - apply ap. - apply inverses_concat_tr. - Defined. - - Lemma tr_id : forall (x : A) (p : m x = m x), tr (fun y=> R x y) p (Rrefl x) = (Rrefl x). - Proof. move=> x p; apply MereR. Qed. - - Definition UIP_MA {x y : A} (p q : m x = m y): p = q. - Proof. - move: q. - refine (match p as p0 return forall q, p0 = q with eq_refl => _ end). - move=> q. - rewrite (path_shape x 1) /=. - rewrite (path_shape x q). - (* rewrite -uniqr. *) - by rewrite tr_id. - Defined. - - Section inj. - Definition injective {A B : Type} (f : A -> B) := forall x y, f x = f y -> x = y. - Hypothesis m_inj : injective m. - - Lemma ap_inj {C D : Type} (f : C -> D) (inj_f : injective f) : forall x y, injective (@f_equal _ _ f x y). - Proof. - move=> x y p1 p2. - dependent destruction p1. - dependent destruction p2. - move=> _ ; exact: eq_refl. - Defined. - Print JMeq_refl. - - Definition UIP_A {x y : A} (p q : x = y) : p = q. - Proof. - set mp := @f_equal _ _ m _ _ p. - set mq := @f_equal _ _ m _ _ q. - have : mp = mq. by apply UIP_MA. - by apply: ap_inj. - Defined. - - End inj. - - Section surj. - - Definition fiber {C D : Type} (f : C -> D) (d : D) := { c & f c = d}. - Definition isContr (A : Type) := { t & forall t1 : A, t = t1}. - Definition isProp (A : Type) := forall (x y : A), isContr(x = y). - Definition surjection {C D : Type} (f : C -> D) := forall y, isProp (fiber f y). - Hypothesis m_surj : surjection m. - - Lemma UIP_B : forall (x y : B) (p q : x = y), p = q. - Proof. - move=> x y. - have := m_surj x. - Abort. - - End surj. - Section surj2. - - Hypothesis comap : B -> A. - Hypothesis corefl : forall b, R (comap b) b. - - Lemma UIP_B : forall (x y : B) (p q : x = y), p = q. - Proof. - move=> x y. - have := (imp _ _ (corefl x)). - have := (imp _ _ (corefl y)). - elim. - elim. - apply UIP_MA. - Qed. - - End surj2. - -End Genthm722. - -Section thm722. - - Variable A : Type. - Variable R : A -> A -> Type. - Variable rrefl : forall x, R x x. (* 2a *) - Variable imp : forall x y, R x y -> x = y. (* 2b *) - Variable mereR : forall x y (r1 r2 : R x y), r1 = r2. - Variable M4 : forall x (r1 r2 : {y & R x y} ), r1 = r2. - - Lemma uip_a (x y : A) (p q : x = y) : p = q. - Proof. - apply (UIP_MA A A R (@id A) rrefl imp). - by move=> e ?; apply mereR. - Qed. - -End thm722. - From 7275ff58f8c7e41891dbe0584e9f0eb622793b9f Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 24 Jun 2026 10:54:09 +0200 Subject: [PATCH 35/42] accumulating db headers, then files, then dbs --- generic/inductives/Relnm.v | 14 +++++++------- generic/inductives/Rm.v | 13 +++++++------ generic/inductives/RsymK.v | 22 +++++++++++----------- generic/inductives/injK.v | 8 +++++--- generic/inductives/injection_lemmas.v | 9 +++++---- generic/inductives/mR.v | 16 ++++++++++------ generic/inductives/mRRmK.v | 19 ++++++++++--------- generic/inductives/mapn.v | 18 +++++++++--------- generic/inductives/mymap.v | 14 ++++---------- generic/inductives/sym.v | 10 +++++----- generic/inductives/symK.v | 16 ++++++++-------- 11 files changed, 81 insertions(+), 78 deletions(-) diff --git a/generic/inductives/Relnm.v b/generic/inductives/Relnm.v index bb21913b..c860a2ec 100644 --- a/generic/inductives/Relnm.v +++ b/generic/inductives/Relnm.v @@ -12,16 +12,16 @@ From Trocq Require Export Stdlib Hierarchy Param_lemmas. Unset Uniform Inductive Parameters. Elpi Command derive.relnm. -Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db Header derive.rsymK.db. -Elpi Accumulate Db derive.rsymK.db. -Elpi Accumulate Db trocq.db. +Elpi Accumulate Db Header trocq.db. +Elpi Accumulate File derive_hook. Elpi Accumulate File common. Elpi Accumulate File utils. -Elpi Accumulate Db trocq.db. Elpi Accumulate File relnm. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.rsymK.db. +Elpi Accumulate Db trocq.db. Elpi Accumulate lp:{{ main [str I] :- !, @@ -38,11 +38,11 @@ Elpi Accumulate lp:{{ (* hook into derive *) Elpi Accumulate Db Header derive.rsymK.db. -Elpi Accumulate Db derive.rsymK.db. -Elpi Accumulate Db trocq.db. Elpi Accumulate derive File common. Elpi Accumulate derive File utils. Elpi Accumulate derive File relnm. +Elpi Accumulate Db derive.rsymK.db. +Elpi Accumulate Db trocq.db. Elpi Accumulate derive lp:{{ dep1 "relnm" "rsymK". diff --git a/generic/inductives/Rm.v b/generic/inductives/Rm.v index d654239b..99fdead2 100644 --- a/generic/inductives/Rm.v +++ b/generic/inductives/Rm.v @@ -32,15 +32,16 @@ Elpi Db derive.Rm.db lp:{{ }}. Elpi Command derive.Rm. -Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate Db derive.param2.db. -Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate Db Header derive.mymap.db. +Elpi Accumulate Db Header derive.Rm.db. +Elpi Accumulate File derive_hook. Elpi Accumulate File common. Elpi Accumulate File algo_utils. -Elpi Accumulate Db Header derive.Rm.db. -Elpi Accumulate Db derive.Rm.db. Elpi Accumulate File Rm. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate Db derive.Rm.db. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), @@ -55,10 +56,10 @@ Elpi Accumulate lp:{{ (* hook into derive *) Elpi Accumulate derive Db Header derive.Rm.db. -Elpi Accumulate derive Db derive.Rm.db. Elpi Accumulate derive File common. Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File Rm. +Elpi Accumulate derive Db derive.Rm.db. Elpi Accumulate derive lp:{{ dep1 "Rm" "mymap". diff --git a/generic/inductives/RsymK.v b/generic/inductives/RsymK.v index 6b8e5b93..a20c3a16 100644 --- a/generic/inductives/RsymK.v +++ b/generic/inductives/RsymK.v @@ -24,18 +24,18 @@ Elpi Db derive.rsymK.db lp:{{ }}. Elpi Command derive.rsymK. -Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db Header derive.sym.db. -Elpi Accumulate Db derive.sym.db. Elpi Accumulate Db Header derive.symK.db. -Elpi Accumulate Db derive.symK.db. +Elpi Accumulate Db Header derive.rsymK.db. +Elpi Accumulate File derive_hook. Elpi Accumulate File common. Elpi Accumulate File utils. -Elpi Accumulate Db Header derive.rsymK.db. -Elpi Accumulate Db derive.rsymK.db. Elpi Accumulate File rsymK. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.sym.db. +Elpi Accumulate Db derive.symK.db. +Elpi Accumulate Db derive.rsymK.db. Elpi Accumulate lp:{{ main [str I] :- !, @@ -61,14 +61,14 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) Elpi Accumulate derive Db Header derive.rsymK.db. -Elpi Accumulate derive Db derive.rsymK.db. -Elpi Accumulate Db Header derive.sym.db. -Elpi Accumulate Db derive.sym.db. -Elpi Accumulate Db Header derive.symK.db. -Elpi Accumulate Db derive.symK.db. +Elpi Accumulate derive Db Header derive.sym.db. +Elpi Accumulate derive Db Header derive.symK.db. Elpi Accumulate derive File common. Elpi Accumulate derive File utils. Elpi Accumulate derive File rsymK. +Elpi Accumulate derive Db derive.rsymK.db. +Elpi Accumulate derive Db derive.sym.db. +Elpi Accumulate derive Db derive.symK.db. Elpi Accumulate derive lp:{{ diff --git a/generic/inductives/injK.v b/generic/inductives/injK.v index 993e0c5b..f46b7f9f 100644 --- a/generic/inductives/injK.v +++ b/generic/inductives/injK.v @@ -32,11 +32,13 @@ Elpi Db derive.injectionsK.db lp:{{ }}. Elpi Command derive.injK. +Elpi Accumulate Db Header derive.injections.db. +Elpi Accumulate Db Header derive.injectionsK.db. Elpi Accumulate File derive_hook. Elpi Accumulate File algo_utils. -Elpi Accumulate Db derive.injectionsK.db. -Elpi Accumulate Db derive.injections.db. Elpi Accumulate File injK. +Elpi Accumulate Db derive.injections.db. +Elpi Accumulate Db derive.injectionsK.db. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, @@ -58,9 +60,9 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -Elpi Accumulate derive Db derive.injectionsK.db. Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File injK. +Elpi Accumulate derive Db derive.injectionsK.db. Elpi Accumulate derive lp:{{ diff --git a/generic/inductives/injection_lemmas.v b/generic/inductives/injection_lemmas.v index 6d9c4093..40bbff7c 100644 --- a/generic/inductives/injection_lemmas.v +++ b/generic/inductives/injection_lemmas.v @@ -25,13 +25,14 @@ Elpi Db derive.injections.db lp:{{ }}. Elpi Command derive.injections. -Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.projK.db. -Elpi Accumulate Db derive.projK.db. +Elpi Accumulate Db Header derive.injections.db. +Elpi Accumulate File derive_hook. Elpi Accumulate File injection. -Elpi Accumulate Db derive.injections.db. Elpi Accumulate File algo_utils. Elpi Accumulate File injections. +Elpi Accumulate Db derive.projK.db. +Elpi Accumulate Db derive.injections.db. Elpi Accumulate lp:{{ main [str I] :- !, @@ -56,10 +57,10 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -Elpi Accumulate derive Db derive.injections.db. Elpi Accumulate derive File injection. Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File injections. +Elpi Accumulate derive Db derive.injections.db. Elpi Accumulate derive lp:{{ diff --git a/generic/inductives/mR.v b/generic/inductives/mR.v index d3566473..0e036d93 100644 --- a/generic/inductives/mR.v +++ b/generic/inductives/mR.v @@ -35,17 +35,21 @@ Elpi Db derive.mR.db lp:{{ }}. Elpi Command derive.mR. -Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. +Elpi Accumulate Db Header derive.isK.db. +Elpi Accumulate Db Header derive.mymap.db. +Elpi Accumulate Db Header derive.injections.db. +Elpi Accumulate Db Header derive.mR.db. +Elpi Accumulate File derive_hook. +Elpi Accumulate File discr. +Elpi Accumulate File common. +Elpi Accumulate File utils. +Elpi Accumulate File mR. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.mymap.db. Elpi Accumulate Db derive.isK.db. -Elpi Accumulate File discr. Elpi Accumulate Db derive.injections.db. -Elpi Accumulate File common. -Elpi Accumulate File utils. Elpi Accumulate Db derive.mR.db. -Elpi Accumulate File mR. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), @@ -59,11 +63,11 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -Elpi Accumulate derive Db derive.mR.db. Elpi Accumulate derive File discr. Elpi Accumulate derive File common. Elpi Accumulate derive File injections. Elpi Accumulate derive File mR. +Elpi Accumulate derive Db derive.mR.db. #[phases="both"] Elpi Accumulate derive lp:{{ dep1 "mR" "param2". diff --git a/generic/inductives/mRRmK.v b/generic/inductives/mRRmK.v index 80a57880..9ff3af5e 100644 --- a/generic/inductives/mRRmK.v +++ b/generic/inductives/mRRmK.v @@ -33,22 +33,23 @@ Elpi Db derive.mRRmK.db lp:{{ }}. Elpi Command derive.mRRmK. -Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate Db derive.param2.db. -Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate Db Header derive.injectionsK.db. +Elpi Accumulate Db Header derive.mymap.db. +Elpi Accumulate Db Header derive.mR.db. +Elpi Accumulate Db Header derive.Rm.db. +Elpi Accumulate Db Header derive.mRRmK.db. +Elpi Accumulate File derive_hook. Elpi Accumulate File common. Elpi Accumulate File algo_utils. -Elpi Accumulate Db Header derive.injectionsK.db. +Elpi Accumulate File mRRmK. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.mymap.db. Elpi Accumulate Db derive.injectionsK.db. -Elpi Accumulate Db Header derive.mR.db. Elpi Accumulate Db derive.mR.db. -Elpi Accumulate Db Header derive.Rm.db. Elpi Accumulate Db derive.Rm.db. -Elpi Accumulate Db Header derive.mRRmK.db. Elpi Accumulate Db derive.mRRmK.db. -Elpi Accumulate File mRRmK. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), @@ -63,10 +64,10 @@ Elpi Accumulate lp:{{ (* hook into derive *) -Elpi Accumulate derive Db derive.mRRmK.db. Elpi Accumulate derive File common. Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File mRRmK. +Elpi Accumulate derive Db derive.mRRmK.db. Elpi Accumulate derive lp:{{ diff --git a/generic/inductives/mapn.v b/generic/inductives/mapn.v index 8e819b8f..5b9b1889 100644 --- a/generic/inductives/mapn.v +++ b/generic/inductives/mapn.v @@ -20,22 +20,22 @@ Unset Uniform Inductive Parameters. }}. *) Elpi Command derive.mapn. -Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db Header derive.mymap.db. -Elpi Accumulate Db derive.mymap.db. Elpi Accumulate Db Header derive.mR.db. -Elpi Accumulate Db derive.mR.db. Elpi Accumulate Db Header derive.Rm.db. -Elpi Accumulate Db derive.Rm.db. Elpi Accumulate Db Header derive.mRRmK.db. -Elpi Accumulate Db derive.mRRmK.db. +Elpi Accumulate Db Header trocq.db. +Elpi Accumulate File derive_hook. Elpi Accumulate File common. Elpi Accumulate File algo_utils. - -Elpi Accumulate Db trocq.db. Elpi Accumulate File mapn. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.mymap.db. +Elpi Accumulate Db derive.mR.db. +Elpi Accumulate Db derive.Rm.db. +Elpi Accumulate Db derive.mRRmK.db. +Elpi Accumulate Db trocq.db. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, @@ -55,10 +55,10 @@ Elpi Accumulate lp:{{ coq.env.global GRR R. }}. -Elpi Accumulate derive Db trocq.db. Elpi Accumulate derive File common. Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File mapn. +Elpi Accumulate derive Db trocq.db. Elpi Accumulate derive lp:{{ diff --git a/generic/inductives/mymap.v b/generic/inductives/mymap.v index c0864a7a..242bef47 100644 --- a/generic/inductives/mymap.v +++ b/generic/inductives/mymap.v @@ -18,22 +18,15 @@ Elpi Db derive.mymap.db lp:{{ }}. Elpi Command derive.mymap. +Elpi Accumulate Db Header derive.mymap.db. Elpi Accumulate File derive_hook. -Elpi Accumulate Db derive.mymap.db. Elpi Accumulate File mymap. +Elpi Accumulate Db derive.mymap.db. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, Prefix is Tname ^ "_", - %derive.mymap.main GR Prefix _. - - % derive.mymap.mk-map-ty A _ B _ {{ Param10.Rel lp:A lp:B }} F 0 [mymap-db A B F] => - % (derive.mymap.bo-k-args.aux K [A|As] [T|Ts] (prod _ S Ty) R :- - % mymap-db T S FRel, - % coq.mk-app {{ map }} [FRel] F, - % coq.mk-app F [A] FA, - % bo-k-args.aux {coq.mk-app K [FA]} As Ts (Ty FA) R) => derive.mymap.main GR Prefix _. main _ :- usage. @@ -43,8 +36,9 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -Elpi Accumulate derive Db derive.mymap.db. +Elpi Accumulate derive Db Header derive.mymap.db. Elpi Accumulate derive File mymap. +Elpi Accumulate derive Db derive.mymap.db. Elpi Accumulate derive lp:{{ diff --git a/generic/inductives/sym.v b/generic/inductives/sym.v index bac4f0b6..1bcd10f7 100644 --- a/generic/inductives/sym.v +++ b/generic/inductives/sym.v @@ -30,14 +30,14 @@ Elpi Db derive.sym.db lp:{{ }}. Elpi Command derive.sym. -Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db Header derive.sym.db. +Elpi Accumulate File derive_hook. Elpi Accumulate File common. Elpi Accumulate File utils. -Elpi Accumulate Db Header derive.sym.db. -Elpi Accumulate Db derive.sym.db. Elpi Accumulate File sym. +Elpi Accumulate Db derive.sym.db. +Elpi Accumulate Db derive.param2.db. Elpi Accumulate lp:{{ main [str I] :- !, @@ -56,10 +56,10 @@ Elpi Accumulate lp:{{ Elpi Accumulate derive Db Header derive.sym.db. -Elpi Accumulate derive Db derive.sym.db. Elpi Accumulate derive File common. Elpi Accumulate derive File utils. Elpi Accumulate derive File sym. +Elpi Accumulate derive Db derive.sym.db. Elpi Accumulate derive lp:{{ diff --git a/generic/inductives/symK.v b/generic/inductives/symK.v index 069d1699..3e52c977 100644 --- a/generic/inductives/symK.v +++ b/generic/inductives/symK.v @@ -32,16 +32,16 @@ Elpi Db derive.symK.db lp:{{ }}. Elpi Command derive.symK. -Elpi Accumulate File derive_hook. Elpi Accumulate Db Header derive.param2.db. -Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db Header derive.sym.db. -Elpi Accumulate Db derive.sym.db. +Elpi Accumulate Db Header derive.symK.db. +Elpi Accumulate File derive_hook. Elpi Accumulate File common. Elpi Accumulate File utils. -Elpi Accumulate Db Header derive.symK.db. -Elpi Accumulate Db derive.symK.db. Elpi Accumulate File symK. +Elpi Accumulate Db derive.param2.db. +Elpi Accumulate Db derive.sym.db. +Elpi Accumulate Db derive.symK.db. Elpi Accumulate lp:{{ main [str I] :- !, @@ -58,12 +58,12 @@ Elpi Accumulate lp:{{ (* hook into derive *) Elpi Accumulate derive Db Header derive.symK.db. -Elpi Accumulate derive Db derive.symK.db. -Elpi Accumulate Db Header derive.sym.db. -Elpi Accumulate Db derive.sym.db. +Elpi Accumulate derive Db Header derive.sym.db. Elpi Accumulate derive File common. Elpi Accumulate derive File utils. Elpi Accumulate derive File symK. +Elpi Accumulate derive Db derive.symK.db. +Elpi Accumulate derive Db derive.sym.db. Elpi Accumulate derive lp:{{ From 4534d4bd57d7a7ef88b7826eed161a46b0750e81 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 24 Jun 2026 13:48:23 +0200 Subject: [PATCH 36/42] elpi's accumulate system --- elpi/inductives/Rm.elpi | 3 +++ elpi/inductives/RsymK.elpi | 2 ++ elpi/inductives/injK.elpi | 2 ++ elpi/inductives/injection_lemmas.elpi | 3 +++ elpi/inductives/mR.elpi | 4 ++++ elpi/inductives/mRRmK.elpi | 3 +++ elpi/inductives/mapn.elpi | 2 ++ elpi/inductives/relnm.elpi | 3 +++ elpi/inductives/sym.elpi | 2 ++ elpi/inductives/symK.elpi | 3 +++ generic/inductives/Relnm.v | 6 ------ generic/inductives/Rm.v | 6 ------ generic/inductives/RsymK.v | 6 ------ generic/inductives/injK.v | 3 --- generic/inductives/injection_lemmas.v | 6 ------ generic/inductives/mR.v | 10 ---------- generic/inductives/mRRmK.v | 6 ------ generic/inductives/mapn.v | 6 ------ generic/inductives/sym.v | 6 ------ generic/inductives/symK.v | 6 ------ 20 files changed, 27 insertions(+), 61 deletions(-) diff --git a/elpi/inductives/Rm.elpi b/elpi/inductives/Rm.elpi index aefd0baf..4335a2ab 100644 --- a/elpi/inductives/Rm.elpi +++ b/elpi/inductives/Rm.elpi @@ -1,3 +1,6 @@ +accumulate "Trocq.Elpi.inductives/common_algo". +accumulate "Trocq.Elpi.inductives/utils". + shorten derive.common-algo.{mk-mR-type-Rm}. shorten derive.algo-utils.{mk-chain, type-of-args, elim-into-path-suffix}. shorten derive.algo-utils.{cmp-indt}. diff --git a/elpi/inductives/RsymK.elpi b/elpi/inductives/RsymK.elpi index 56a27221..d9ef050a 100644 --- a/elpi/inductives/RsymK.elpi +++ b/elpi/inductives/RsymK.elpi @@ -1,3 +1,5 @@ +accumulate "Trocq.Elpi.inductives/common_algo". +accumulate "Trocq.Elpi.inductives/utils". shorten derive.algo-utils.{type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with}. shorten derive.common-algo.{mk-mR-type-rsymK, sym-tyargs}. diff --git a/elpi/inductives/injK.elpi b/elpi/inductives/injK.elpi index 1467d68b..d03fa377 100644 --- a/elpi/inductives/injK.elpi +++ b/elpi/inductives/injK.elpi @@ -1,3 +1,5 @@ +accumulate "Trocq.Elpi.inductives/utils". + shorten derive.algo-utils.{duplicate-arguments,count-args, name-prefix, mk-chain, name-ijs}. namespace derive.injK { diff --git a/elpi/inductives/injection_lemmas.elpi b/elpi/inductives/injection_lemmas.elpi index 4a14db08..77f59b67 100644 --- a/elpi/inductives/injection_lemmas.elpi +++ b/elpi/inductives/injection_lemmas.elpi @@ -1,3 +1,6 @@ +accumulate "Trocq.Elpi.inductives/utils". +accumulate "elpi.apps.derive.elpi/injection". + shorten derive.algo-utils.{duplicate-arguments, count-args, name-ijs, for-K-get-KI}. namespace derive.injections { diff --git a/elpi/inductives/mR.elpi b/elpi/inductives/mR.elpi index 49adbe38..ea0ac7ac 100644 --- a/elpi/inductives/mR.elpi +++ b/elpi/inductives/mR.elpi @@ -1,3 +1,7 @@ +accumulate "Trocq.Elpi.inductives/common_algo". +accumulate "Trocq.Elpi.inductives/utils". +accumulate "Trocq.Elpi.inductives/injection_lemmas". +accumulate "elpi.apps.derive.elpi/discriminate". shorten derive.common-algo.{mk-mR-type-mR}. shorten derive.algo-utils.{cmp-indt}. diff --git a/elpi/inductives/mRRmK.elpi b/elpi/inductives/mRRmK.elpi index 6e077d20..e57022a5 100644 --- a/elpi/inductives/mRRmK.elpi +++ b/elpi/inductives/mRRmK.elpi @@ -1,3 +1,6 @@ +accumulate "Trocq.Elpi.inductives/common_algo". +accumulate "Trocq.Elpi.inductives/utils". + shorten derive.common-algo.{mk-mR-type-mRRmK}. shorten derive.algo-utils.{mk-chain, for-K-get-KI,type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with, elim-into-path-suffix, cmp-indt}. diff --git a/elpi/inductives/mapn.elpi b/elpi/inductives/mapn.elpi index 0f1b8545..c6129f8e 100644 --- a/elpi/inductives/mapn.elpi +++ b/elpi/inductives/mapn.elpi @@ -1,3 +1,5 @@ +accumulate "Trocq.Elpi.inductives/common_algo". +accumulate "Trocq.Elpi.inductives/utils". shorten derive.algo-utils.{gen-names-map}. namespace derive.mapn { diff --git a/elpi/inductives/relnm.elpi b/elpi/inductives/relnm.elpi index a4ff1fff..d19ed64f 100644 --- a/elpi/inductives/relnm.elpi +++ b/elpi/inductives/relnm.elpi @@ -1,3 +1,6 @@ +accumulate "Trocq.Elpi.inductives/common_algo". +accumulate "Trocq.Elpi.inductives/utils". + shorten derive.algo-utils.{type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with}. shorten derive.common-algo.{mk-mR-type-relnm,sym-tyargs}. diff --git a/elpi/inductives/sym.elpi b/elpi/inductives/sym.elpi index 3352420d..83f77021 100644 --- a/elpi/inductives/sym.elpi +++ b/elpi/inductives/sym.elpi @@ -1,3 +1,5 @@ +accumulate "Trocq.Elpi.inductives/common_algo". +accumulate "Trocq.Elpi.inductives/utils". shorten derive.common-algo.{mk-mR-type-sym}. shorten derive.algo-utils.{cmp-indt}. diff --git a/elpi/inductives/symK.elpi b/elpi/inductives/symK.elpi index 2c3f738a..9cdcb684 100644 --- a/elpi/inductives/symK.elpi +++ b/elpi/inductives/symK.elpi @@ -1,3 +1,6 @@ +accumulate "Trocq.Elpi.inductives/common_algo". +accumulate "Trocq.Elpi.inductives/utils". + shorten derive.algo-utils.{type-of-args, whd-fuel, iota-step, invert-eqs, rewrite-with}. shorten derive.common-algo.{mk-mR-type-symK}. shorten derive.algo-utils.{cmp-indt}. diff --git a/generic/inductives/Relnm.v b/generic/inductives/Relnm.v index c860a2ec..33c2bc31 100644 --- a/generic/inductives/Relnm.v +++ b/generic/inductives/Relnm.v @@ -1,7 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) -From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as utils. From Trocq.Elpi.inductives Extra Dependency "relnm.elpi" as relnm. From Trocq Require Import sym symK RsymK Param_lemmas mapn map4. Import HoTTNotations. @@ -16,8 +14,6 @@ Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db Header derive.rsymK.db. Elpi Accumulate Db Header trocq.db. Elpi Accumulate File derive_hook. -Elpi Accumulate File common. -Elpi Accumulate File utils. Elpi Accumulate File relnm. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.rsymK.db. @@ -38,8 +34,6 @@ Elpi Accumulate lp:{{ (* hook into derive *) Elpi Accumulate Db Header derive.rsymK.db. -Elpi Accumulate derive File common. -Elpi Accumulate derive File utils. Elpi Accumulate derive File relnm. Elpi Accumulate Db derive.rsymK.db. Elpi Accumulate Db trocq.db. diff --git a/generic/inductives/Rm.v b/generic/inductives/Rm.v index 99fdead2..fb467995 100644 --- a/generic/inductives/Rm.v +++ b/generic/inductives/Rm.v @@ -1,7 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From Trocq.Elpi.inductives Extra Dependency "Rm.elpi" as Rm. -From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. -From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as algo_utils. From elpi Require Import elpi. From Trocq Require Export Hierarchy Param_lemmas mymap. @@ -36,8 +34,6 @@ Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db Header derive.mymap.db. Elpi Accumulate Db Header derive.Rm.db. Elpi Accumulate File derive_hook. -Elpi Accumulate File common. -Elpi Accumulate File algo_utils. Elpi Accumulate File Rm. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.mymap.db. @@ -56,8 +52,6 @@ Elpi Accumulate lp:{{ (* hook into derive *) Elpi Accumulate derive Db Header derive.Rm.db. -Elpi Accumulate derive File common. -Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File Rm. Elpi Accumulate derive Db derive.Rm.db. diff --git a/generic/inductives/RsymK.v b/generic/inductives/RsymK.v index a20c3a16..d321a672 100644 --- a/generic/inductives/RsymK.v +++ b/generic/inductives/RsymK.v @@ -1,8 +1,6 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. (* TODO: check if common/utils is used in rsymK *) -From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as utils. From Trocq.Elpi.inductives Extra Dependency "RsymK.elpi" as rsymK. From Trocq Require Import sym symK. Import HoTTNotations. @@ -29,8 +27,6 @@ Elpi Accumulate Db Header derive.sym.db. Elpi Accumulate Db Header derive.symK.db. Elpi Accumulate Db Header derive.rsymK.db. Elpi Accumulate File derive_hook. -Elpi Accumulate File common. -Elpi Accumulate File utils. Elpi Accumulate File rsymK. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.sym.db. @@ -63,8 +59,6 @@ Elpi Accumulate lp:{{ Elpi Accumulate derive Db Header derive.rsymK.db. Elpi Accumulate derive Db Header derive.sym.db. Elpi Accumulate derive Db Header derive.symK.db. -Elpi Accumulate derive File common. -Elpi Accumulate derive File utils. Elpi Accumulate derive File rsymK. Elpi Accumulate derive Db derive.rsymK.db. Elpi Accumulate derive Db derive.sym.db. diff --git a/generic/inductives/injK.v b/generic/inductives/injK.v index f46b7f9f..51c64406 100644 --- a/generic/inductives/injK.v +++ b/generic/inductives/injK.v @@ -1,7 +1,6 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From Trocq.Elpi.inductives Extra Dependency "injK.elpi" as injK. -From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as algo_utils. From Trocq Require Export injection_lemmas. From Trocq Require Import DeriveLib HoTTNotations Stdlib Hierarchy. @@ -35,7 +34,6 @@ Elpi Command derive.injK. Elpi Accumulate Db Header derive.injections.db. Elpi Accumulate Db Header derive.injectionsK.db. Elpi Accumulate File derive_hook. -Elpi Accumulate File algo_utils. Elpi Accumulate File injK. Elpi Accumulate Db derive.injections.db. Elpi Accumulate Db derive.injectionsK.db. @@ -60,7 +58,6 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File injK. Elpi Accumulate derive Db derive.injectionsK.db. diff --git a/generic/inductives/injection_lemmas.v b/generic/inductives/injection_lemmas.v index 40bbff7c..a1386b8e 100644 --- a/generic/inductives/injection_lemmas.v +++ b/generic/inductives/injection_lemmas.v @@ -1,8 +1,6 @@ -From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From Trocq.Elpi.inductives Extra Dependency "injection_lemmas.elpi" as injections. -From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as algo_utils. From elpi.apps Require Export derive. From elpi.apps Require Export derive.projK. @@ -28,8 +26,6 @@ Elpi Command derive.injections. Elpi Accumulate Db Header derive.projK.db. Elpi Accumulate Db Header derive.injections.db. Elpi Accumulate File derive_hook. -Elpi Accumulate File injection. -Elpi Accumulate File algo_utils. Elpi Accumulate File injections. Elpi Accumulate Db derive.projK.db. Elpi Accumulate Db derive.injections.db. @@ -57,8 +53,6 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -Elpi Accumulate derive File injection. -Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File injections. Elpi Accumulate derive Db derive.injections.db. diff --git a/generic/inductives/mR.v b/generic/inductives/mR.v index 0e036d93..f57fb6bd 100644 --- a/generic/inductives/mR.v +++ b/generic/inductives/mR.v @@ -1,9 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From elpi.apps.derive.elpi Extra Dependency "discriminate.elpi" as discr. -From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. -From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as utils. From Trocq.Elpi.inductives Extra Dependency "mR.elpi" as mR. -From Trocq.Elpi.inductives Extra Dependency "injection_lemmas.elpi" as injections. From elpi Require Import elpi. From elpi.apps Require Export derive.param2 derive.isK. (* for isK db required by discriminate *) @@ -41,9 +37,6 @@ Elpi Accumulate Db Header derive.mymap.db. Elpi Accumulate Db Header derive.injections.db. Elpi Accumulate Db Header derive.mR.db. Elpi Accumulate File derive_hook. -Elpi Accumulate File discr. -Elpi Accumulate File common. -Elpi Accumulate File utils. Elpi Accumulate File mR. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.mymap.db. @@ -63,9 +56,6 @@ Elpi Accumulate lp:{{ }}. (* hook into derive *) -Elpi Accumulate derive File discr. -Elpi Accumulate derive File common. -Elpi Accumulate derive File injections. Elpi Accumulate derive File mR. Elpi Accumulate derive Db derive.mR.db. diff --git a/generic/inductives/mRRmK.v b/generic/inductives/mRRmK.v index 9ff3af5e..180def93 100644 --- a/generic/inductives/mRRmK.v +++ b/generic/inductives/mRRmK.v @@ -1,7 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From Trocq.Elpi.inductives Extra Dependency "mRRmK.elpi" as mRRmK. -From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. -From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as algo_utils. From Trocq Require Export mymap injK mR Rm. From elpi Require Import elpi. @@ -40,8 +38,6 @@ Elpi Accumulate Db Header derive.mR.db. Elpi Accumulate Db Header derive.Rm.db. Elpi Accumulate Db Header derive.mRRmK.db. Elpi Accumulate File derive_hook. -Elpi Accumulate File common. -Elpi Accumulate File algo_utils. Elpi Accumulate File mRRmK. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.mymap.db. @@ -64,8 +60,6 @@ Elpi Accumulate lp:{{ (* hook into derive *) -Elpi Accumulate derive File common. -Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File mRRmK. Elpi Accumulate derive Db derive.mRRmK.db. diff --git a/generic/inductives/mapn.v b/generic/inductives/mapn.v index 5b9b1889..55908250 100644 --- a/generic/inductives/mapn.v +++ b/generic/inductives/mapn.v @@ -1,7 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From Trocq.Elpi Extra Dependency "inductives/mapn.elpi" as mapn. -From Trocq.Elpi Extra Dependency "inductives/common_algo.elpi" as common. -From Trocq.Elpi Extra Dependency "inductives/utils.elpi" as algo_utils. From Trocq Require Import Database map4. Unset Uniform Inductive Parameters. @@ -27,8 +25,6 @@ Elpi Accumulate Db Header derive.Rm.db. Elpi Accumulate Db Header derive.mRRmK.db. Elpi Accumulate Db Header trocq.db. Elpi Accumulate File derive_hook. -Elpi Accumulate File common. -Elpi Accumulate File algo_utils. Elpi Accumulate File mapn. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.mymap.db. @@ -55,8 +51,6 @@ Elpi Accumulate lp:{{ coq.env.global GRR R. }}. -Elpi Accumulate derive File common. -Elpi Accumulate derive File algo_utils. Elpi Accumulate derive File mapn. Elpi Accumulate derive Db trocq.db. diff --git a/generic/inductives/sym.v b/generic/inductives/sym.v index 1bcd10f7..a6f38bd9 100644 --- a/generic/inductives/sym.v +++ b/generic/inductives/sym.v @@ -1,7 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. -From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as utils. From Trocq.Elpi.inductives Extra Dependency "sym.elpi" as sym. From elpi.apps Require Export derive derive.param2. @@ -33,8 +31,6 @@ Elpi Command derive.sym. Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db Header derive.sym.db. Elpi Accumulate File derive_hook. -Elpi Accumulate File common. -Elpi Accumulate File utils. Elpi Accumulate File sym. Elpi Accumulate Db derive.sym.db. Elpi Accumulate Db derive.param2.db. @@ -56,8 +52,6 @@ Elpi Accumulate lp:{{ Elpi Accumulate derive Db Header derive.sym.db. -Elpi Accumulate derive File common. -Elpi Accumulate derive File utils. Elpi Accumulate derive File sym. Elpi Accumulate derive Db derive.sym.db. diff --git a/generic/inductives/symK.v b/generic/inductives/symK.v index 3e52c977..aeeaedad 100644 --- a/generic/inductives/symK.v +++ b/generic/inductives/symK.v @@ -1,8 +1,6 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. -From Trocq.Elpi.inductives Extra Dependency "common_algo.elpi" as common. -From Trocq.Elpi.inductives Extra Dependency "utils.elpi" as utils. From Trocq.Elpi.inductives Extra Dependency "symK.elpi" as symK. From Trocq Require Import sym. @@ -36,8 +34,6 @@ Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db Header derive.sym.db. Elpi Accumulate Db Header derive.symK.db. Elpi Accumulate File derive_hook. -Elpi Accumulate File common. -Elpi Accumulate File utils. Elpi Accumulate File symK. Elpi Accumulate Db derive.param2.db. Elpi Accumulate Db derive.sym.db. @@ -59,8 +55,6 @@ Elpi Accumulate lp:{{ (* hook into derive *) Elpi Accumulate derive Db Header derive.symK.db. Elpi Accumulate derive Db Header derive.sym.db. -Elpi Accumulate derive File common. -Elpi Accumulate derive File utils. Elpi Accumulate derive File symK. Elpi Accumulate derive Db derive.symK.db. Elpi Accumulate derive Db derive.sym.db. From 61e4672cdd72682410ae9fe49a1db7b87345b64c Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 24 Jun 2026 16:38:58 +0200 Subject: [PATCH 37/42] add rocq-elpi to nix --- .github/workflows/nix-action-rocq-9.0.yml | 54 +++++++++++++++++++++++ .github/workflows/nix-action-rocq-9.1.yml | 54 +++++++++++++++++++++++ .nix/config.nix | 8 +++- 3 files changed, 114 insertions(+), 2 deletions(-) diff --git a/.github/workflows/nix-action-rocq-9.0.yml b/.github/workflows/nix-action-rocq-9.0.yml index 2993504f..1b5ca251 100644 --- a/.github/workflows/nix-action-rocq-9.0.yml +++ b/.github/workflows/nix-action-rocq-9.0.yml @@ -171,6 +171,60 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "rocq-core" + rocq-elpi: + needs: [] + runs-on: ubuntu-latest + steps: + - name: Determine which commit to initially checkout + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ + github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha + }}\" >> $GITHUB_ENV\nfi\n" + - name: Git checkout + uses: actions/checkout@v6 + with: + fetch-depth: 0 + ref: ${{ env.target_commit }} + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ + github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url + }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git + merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null + 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ + \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha + }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ + \ fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v6 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v31 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup coq-community + uses: cachix/cachix-action@v16 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq, math-comp + name: coq-community + - id: stepGetDerivation + name: Getting derivation for current job (rocq-elpi) + run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle + \"rocq-9.0\" --argstr job \"rocq-elpi\" \\\n --dry-run 2> err > out || (touch + fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting derivation + failed\"; exit 1; fi\n" + - id: stepCheck + name: Checking presence of CI target for current job + run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs + actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ + ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ + \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ + status=fetched\" >> $GITHUB_OUTPUT\nfi\n" + - if: steps.stepCheck.outputs.status != 'fetched' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.0" --argstr job "rocq-elpi" trocq: needs: - trocq-std diff --git a/.github/workflows/nix-action-rocq-9.1.yml b/.github/workflows/nix-action-rocq-9.1.yml index 9ded0a27..a701ef88 100644 --- a/.github/workflows/nix-action-rocq-9.1.yml +++ b/.github/workflows/nix-action-rocq-9.1.yml @@ -230,6 +230,60 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.1" --argstr job "rocq-core" + rocq-elpi: + needs: [] + runs-on: ubuntu-latest + steps: + - name: Determine which commit to initially checkout + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ + github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha + }}\" >> $GITHUB_ENV\nfi\n" + - name: Git checkout + uses: actions/checkout@v6 + with: + fetch-depth: 0 + ref: ${{ env.target_commit }} + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ + github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url + }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git + merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null + 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ + \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha + }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ + \ fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v6 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v31 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup coq-community + uses: cachix/cachix-action@v16 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq, math-comp + name: coq-community + - id: stepGetDerivation + name: Getting derivation for current job (rocq-elpi) + run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle + \"rocq-9.1\" --argstr job \"rocq-elpi\" \\\n --dry-run 2> err > out || (touch + fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting derivation + failed\"; exit 1; fi\n" + - id: stepCheck + name: Checking presence of CI target for current job + run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs + actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ + ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ + \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ + status=fetched\" >> $GITHUB_OUTPUT\nfi\n" + - if: steps.stepCheck.outputs.status != 'fetched' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.1" --argstr job "rocq-elpi" trocq: needs: - trocq-std diff --git a/.nix/config.nix b/.nix/config.nix index 2a87d801..fa46d8fb 100644 --- a/.nix/config.nix +++ b/.nix/config.nix @@ -15,14 +15,18 @@ }; in { "rocq-9.0" = { - rocqPackages = { rocq-core.override.version = "9.0"; }; + rocqPackages = { rocq-core.override.version = "9.0"; + rocq-elpi.override.version = "ba3cc750eda486c85d94e3eb35fb0eba77609338"; # 3.4.0. is enough for trocq-std, trocq-hott needs https://github.com/LPCIC/coq-elpi/pull/1030 + }; coqPackages = common-bundles // { coq.override.version = "9.0"; coq-elpi.override.version = "ba3cc750eda486c85d94e3eb35fb0eba77609338"; # 3.4.0. is enough for trocq-std, trocq-hott needs https://github.com/LPCIC/coq-elpi/pull/1030 }; }; "rocq-9.1" = { - rocqPackages = { rocq-core.override.version = "9.1"; }; + rocqPackages = { rocq-core.override.version = "9.1"; + rocq-elpi.override.version = "ba3cc750eda486c85d94e3eb35fb0eba77609338"; # 3.4.0. is enough for trocq-std, trocq-hott needs https://github.com/LPCIC/coq-elpi/pull/1030 + }; coqPackages = common-bundles // { coq.override.version = "9.1"; HoTT.override.version = "9dbe413246b53352d4891efb85cd2ea1a8d01c12"; # HoTT isn't available yet for 9.1 From 64d6e904d328a7c65f77fa0d6cb8f673ca304827 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 24 Jun 2026 16:57:33 +0200 Subject: [PATCH 38/42] rm mathcomp ssreflect build inputs nix --- .nix/coq-overlays/trocq-std-examples/default.nix | 1 - 1 file changed, 1 deletion(-) diff --git a/.nix/coq-overlays/trocq-std-examples/default.nix b/.nix/coq-overlays/trocq-std-examples/default.nix index a6355c4c..fdd3e573 100644 --- a/.nix/coq-overlays/trocq-std-examples/default.nix +++ b/.nix/coq-overlays/trocq-std-examples/default.nix @@ -40,7 +40,6 @@ mkCoqDerivation { propagatedBuildInputs = [ trocq.std - mathcomp.ssreflect mathcomp.algebra ]; } From 6fde77a8cb799c9070b69f53623ee05c99343709 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Wed, 24 Jun 2026 16:58:47 +0200 Subject: [PATCH 39/42] update actions --- .github/workflows/nix-action-rocq-9.0.yml | 4 ---- .github/workflows/nix-action-rocq-9.1.yml | 4 ---- 2 files changed, 8 deletions(-) diff --git a/.github/workflows/nix-action-rocq-9.0.yml b/.github/workflows/nix-action-rocq-9.0.yml index 1b5ca251..d3dcf6db 100644 --- a/.github/workflows/nix-action-rocq-9.0.yml +++ b/.github/workflows/nix-action-rocq-9.0.yml @@ -553,10 +553,6 @@ jobs: name: 'Building/fetching previous CI target: trocq-std' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "trocq-std" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-ssreflect' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.0" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status != 'fetched' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle diff --git a/.github/workflows/nix-action-rocq-9.1.yml b/.github/workflows/nix-action-rocq-9.1.yml index a701ef88..368041ae 100644 --- a/.github/workflows/nix-action-rocq-9.1.yml +++ b/.github/workflows/nix-action-rocq-9.1.yml @@ -613,10 +613,6 @@ jobs: name: 'Building/fetching previous CI target: trocq-std' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.1" --argstr job "trocq-std" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-ssreflect' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status != 'fetched' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle From 339409a30bd0347494f144a837802797e7fdd734 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Thu, 25 Jun 2026 10:09:24 +0200 Subject: [PATCH 40/42] rm outdated db --- generic/inductives/mapn.v | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/generic/inductives/mapn.v b/generic/inductives/mapn.v index 55908250..e21cc3d5 100644 --- a/generic/inductives/mapn.v +++ b/generic/inductives/mapn.v @@ -3,20 +3,6 @@ From Trocq.Elpi Extra Dependency "inductives/mapn.elpi" as mapn. From Trocq Require Import Database map4. Unset Uniform Inductive Parameters. -(* I have to use Trocq db due to a dependency of type declaration of predicates in umap-db *) -(* if the class file is accumulated in umap-db then accumulating trocq.db is an issue *) -(* Elpi Db derive.umap.db lp:{{ }}. *) - -(* Elpi Accumulate derive.umap.db Db trocq.db. *) -(* Elpi Accumulate derive Db trocq.db. *) -(* Elpi Db derive.umap.db lp:{{ - % [umap-db T D] - pred umap-db i:term, i:map-class, o:term. - - % [umap-done T D] - pred umap-done o:inductive, o:map-class. -}}. *) - Elpi Command derive.mapn. Elpi Accumulate Db Header derive.param2.db. Elpi Accumulate Db Header derive.mymap.db. From 26961c20d16923c7e3b99807eb3e0a213a930267 Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Thu, 25 Jun 2026 15:03:59 +0200 Subject: [PATCH 41/42] rm superglobal when possible --- generic/inductives/Rm.v | 3 --- generic/inductives/RsymK.v | 16 +++++++--------- generic/inductives/injK.v | 15 ++++++--------- generic/inductives/injection_lemmas.v | 14 ++++++-------- generic/inductives/mR.v | 4 ---- generic/inductives/mRRmK.v | 3 --- generic/inductives/sym.v | 3 --- generic/inductives/symK.v | 2 -- 8 files changed, 19 insertions(+), 41 deletions(-) diff --git a/generic/inductives/Rm.v b/generic/inductives/Rm.v index fb467995..6ea2bb95 100644 --- a/generic/inductives/Rm.v +++ b/generic/inductives/Rm.v @@ -17,9 +17,6 @@ Elpi Db derive.Rm.db lp:{{ % [Rm-done T] mean T was already derived pred rm-done o:inductive. -}}. - -#[superglobal] Elpi Accumulate derive.Rm.db lp:{{ % refactor db dispatchers rm-db I _ R :- diff --git a/generic/inductives/RsymK.v b/generic/inductives/RsymK.v index d321a672..7d697fbc 100644 --- a/generic/inductives/RsymK.v +++ b/generic/inductives/RsymK.v @@ -19,6 +19,13 @@ Elpi Db derive.rsymK.db lp:{{ % [rsymK-done T K] means T K was already derived pred rsymK-done o:inductive. + + % refactor db dispatchers + rsymK-db I R :- + coq.env.global (indt GRI) I, + rsymK-def (indt GRI) GRR, + coq.env.global GRR R. + }}. Elpi Command derive.rsymK. @@ -46,15 +53,6 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.rsymK ". }}. -#[superglobal] Elpi Accumulate derive.rsymK.db lp:{{ - - % refactor db dispatchers - rsymK-db I R :- - coq.env.global (indt GRI) I, - rsymK-def (indt GRI) GRR, - coq.env.global GRR R. - -}}. (* hook into derive *) Elpi Accumulate derive Db Header derive.rsymK.db. Elpi Accumulate derive Db Header derive.sym.db. diff --git a/generic/inductives/injK.v b/generic/inductives/injK.v index 51c64406..3f161980 100644 --- a/generic/inductives/injK.v +++ b/generic/inductives/injK.v @@ -28,6 +28,12 @@ Elpi Db derive.injectionsK.db lp:{{ % [injectionsK-done T K] means T K was already derived pred injectionsK-done o:inductive. + + injectionsK-db K N R :- + coq.env.global (indc GRK) K, + injectionsK-def (indc GRK) N GRR, + coq.env.global GRR R. + }}. Elpi Command derive.injK. @@ -48,15 +54,6 @@ Elpi Accumulate lp:{{ usage :- coq.error "Usage: derive.Rm ". }}. -#[superglobal] Elpi Accumulate derive.injectionsK.db lp:{{ - - injectionsK-db K N R :- - coq.env.global (indc GRK) K, - injectionsK-def (indc GRK) N GRR, - coq.env.global GRR R. - -}}. - (* hook into derive *) Elpi Accumulate derive File injK. Elpi Accumulate derive Db derive.injectionsK.db. diff --git a/generic/inductives/injection_lemmas.v b/generic/inductives/injection_lemmas.v index a1386b8e..5265a5e3 100644 --- a/generic/inductives/injection_lemmas.v +++ b/generic/inductives/injection_lemmas.v @@ -20,6 +20,12 @@ Elpi Db derive.injections.db lp:{{ % [injections-done T K] means T K was already derived pred injections-done o:inductive. + + injections-db K N R :- + coq.env.global (indc GRK) K, + injections-def (indc GRK) N GRR, + coq.env.global GRR R. + }}. Elpi Command derive.injections. @@ -41,14 +47,6 @@ Elpi Accumulate lp:{{ pred usage. usage :- coq.error "Usage: derive.injections ". -}}. - -#[superglobal] Elpi Accumulate derive.injections.db lp:{{ - - injections-db K N R :- - coq.env.global (indc GRK) K, - injections-def (indc GRK) N GRR, - coq.env.global GRR R. }}. diff --git a/generic/inductives/mR.v b/generic/inductives/mR.v index f57fb6bd..d9b9e373 100644 --- a/generic/inductives/mR.v +++ b/generic/inductives/mR.v @@ -18,16 +18,12 @@ Elpi Db derive.mR.db lp:{{ % [mR-done T] mean T was already derived pred mR-done o:inductive. -}}. - -#[superglobal] Elpi Accumulate derive.mR.db lp:{{ % refactor db dispatchers mR-db I _ R :- coq.env.global (indt GRI) I, mR-def (indt GRI) GRR, coq.env.global GRR R. - }}. Elpi Command derive.mR. diff --git a/generic/inductives/mRRmK.v b/generic/inductives/mRRmK.v index 180def93..b52ea0b8 100644 --- a/generic/inductives/mRRmK.v +++ b/generic/inductives/mRRmK.v @@ -18,10 +18,7 @@ Elpi Db derive.mRRmK.db lp:{{ % [mRRmK-done T] mean T was already derived pred mRRmK-done o:inductive. -}}. -#[superglobal] Elpi Accumulate derive.mRRmK.db lp:{{ - % refactor db dispatchers mRRmK-db I _ R :- coq.env.global (indt GRI) I, diff --git a/generic/inductives/sym.v b/generic/inductives/sym.v index a6f38bd9..dd9aaeef 100644 --- a/generic/inductives/sym.v +++ b/generic/inductives/sym.v @@ -15,9 +15,6 @@ Elpi Db derive.sym.db lp:{{ % [sym-done T K] means T K was already derived pred sym-done o:inductive. -}}. - -#[superglobal] Elpi Accumulate derive.sym.db lp:{{ % refactor db dispatchers sym-db I R :- diff --git a/generic/inductives/symK.v b/generic/inductives/symK.v index aeeaedad..03a3f26d 100644 --- a/generic/inductives/symK.v +++ b/generic/inductives/symK.v @@ -18,8 +18,6 @@ Elpi Db derive.symK.db lp:{{ % [symK-done T K] means T K was already derived pred symK-done o:inductive. -}}. -#[superglobal] Elpi Accumulate derive.symK.db lp:{{ % refactor db dispatchers symK-db I R :- From e04a747d4b0dd13e769579ec2806d5ff4d48e59b Mon Sep 17 00:00:00 2001 From: Tomas Vallejos Date: Fri, 26 Jun 2026 09:41:27 +0200 Subject: [PATCH 42/42] rm synterp hooks require --- generic/inductives/Relnm.v | 1 - generic/inductives/RsymK.v | 1 - generic/inductives/injection_lemmas.v | 1 - generic/inductives/sym.v | 1 - generic/inductives/symK.v | 1 - 5 files changed, 5 deletions(-) diff --git a/generic/inductives/Relnm.v b/generic/inductives/Relnm.v index 33c2bc31..5dc5fb00 100644 --- a/generic/inductives/Relnm.v +++ b/generic/inductives/Relnm.v @@ -1,5 +1,4 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From Trocq.Elpi.inductives Extra Dependency "relnm.elpi" as relnm. From Trocq Require Import sym symK RsymK Param_lemmas mapn map4. Import HoTTNotations. diff --git a/generic/inductives/RsymK.v b/generic/inductives/RsymK.v index 7d697fbc..09307fc6 100644 --- a/generic/inductives/RsymK.v +++ b/generic/inductives/RsymK.v @@ -1,6 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From Trocq.Elpi.inductives Extra Dependency "RsymK.elpi" as rsymK. From Trocq Require Import sym symK. Import HoTTNotations. diff --git a/generic/inductives/injection_lemmas.v b/generic/inductives/injection_lemmas.v index 5265a5e3..f9008b63 100644 --- a/generic/inductives/injection_lemmas.v +++ b/generic/inductives/injection_lemmas.v @@ -1,5 +1,4 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From Trocq.Elpi.inductives Extra Dependency "injection_lemmas.elpi" as injections. From elpi.apps Require Export derive. diff --git a/generic/inductives/sym.v b/generic/inductives/sym.v index dd9aaeef..6cab0cc5 100644 --- a/generic/inductives/sym.v +++ b/generic/inductives/sym.v @@ -1,5 +1,4 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From Trocq.Elpi.inductives Extra Dependency "sym.elpi" as sym. From elpi.apps Require Export derive derive.param2. diff --git a/generic/inductives/symK.v b/generic/inductives/symK.v index 03a3f26d..97860bdd 100644 --- a/generic/inductives/symK.v +++ b/generic/inductives/symK.v @@ -1,6 +1,5 @@ From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. -From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From Trocq.Elpi.inductives Extra Dependency "symK.elpi" as symK. From Trocq Require Import sym.