1 (* Title: HOL/Tools/Quotient/quotient_term.ML
2 Author: Cezary Kaliszyk and Christian Urban
4 Constructs terms corresponding to goals from lifting theorems to
8 signature QUOTIENT_TERM =
10 exception LIFT_MATCH of string
12 datatype flag = AbsF | RepF
14 val absrep_fun: flag -> Proof.context -> typ * typ -> term
15 val absrep_fun_chk: flag -> Proof.context -> typ * typ -> term
17 (* Allows Nitpick to represent quotient types as single elements from raw type *)
18 val absrep_const_chk: flag -> Proof.context -> string -> term
20 val equiv_relation: Proof.context -> typ * typ -> term
21 val equiv_relation_chk: Proof.context -> typ * typ -> term
23 val regularize_trm: Proof.context -> term * term -> term
24 val regularize_trm_chk: Proof.context -> term * term -> term
26 val inj_repabs_trm: Proof.context -> term * term -> term
27 val inj_repabs_trm_chk: Proof.context -> term * term -> term
29 val derive_qtyp: Proof.context -> typ list -> typ -> typ
30 val derive_qtrm: Proof.context -> typ list -> term -> term
31 val derive_rtyp: Proof.context -> typ list -> typ -> typ
32 val derive_rtrm: Proof.context -> typ list -> term -> term
35 structure Quotient_Term: QUOTIENT_TERM =
38 exception LIFT_MATCH of string
42 (*** Aggregate Rep/Abs Function ***)
45 (* The flag RepF is for types in negative position; AbsF is for types
46 in positive position. Because of this, function types need to be
47 treated specially, since there the polarity changes.
50 datatype flag = AbsF | RepF
55 fun is_identity (Const (@{const_name id}, _)) = true
56 | is_identity _ = false
58 fun mk_identity ty = Const (@{const_name id}, ty --> ty)
60 fun mk_fun_compose flag (trm1, trm2) =
62 AbsF => Const (@{const_name comp}, dummyT) $ trm1 $ trm2
63 | RepF => Const (@{const_name comp}, dummyT) $ trm2 $ trm1
65 fun get_mapfun ctxt s =
67 val thy = Proof_Context.theory_of ctxt
68 val mapfun = #mapfun (Quotient_Info.maps_lookup thy s) handle Quotient_Info.NotFound =>
69 raise LIFT_MATCH ("No map function for type " ^ quote s ^ " found.")
71 Const (mapfun, dummyT)
74 (* makes a Free out of a TVar *)
75 fun mk_Free (TVar ((x, i), _)) = Free (unprefix "'" x ^ string_of_int i, dummyT)
77 (* produces an aggregate map function for the
78 rty-part of a quotient definition; abstracts
79 over all variables listed in vs (these variables
80 correspond to the type variables in rty)
82 for example for: (?'a list * ?'b)
83 it produces: %a b. prod_map (map a) b
85 fun mk_mapfun ctxt vs rty =
87 val vs' = map mk_Free vs
89 fun mk_mapfun_aux rty =
92 | Type (_, []) => mk_identity rty
93 | Type (s, tys) => list_comb (get_mapfun ctxt s, map mk_mapfun_aux tys)
94 | _ => raise LIFT_MATCH "mk_mapfun (default)"
96 fold_rev Term.lambda vs' (mk_mapfun_aux rty)
99 (* looks up the (varified) rty and qty for
100 a quotient definition
102 fun get_rty_qty ctxt s =
104 val thy = Proof_Context.theory_of ctxt
105 val qdata = Quotient_Info.quotdata_lookup thy s handle Quotient_Info.NotFound =>
106 raise LIFT_MATCH ("No quotient type " ^ quote s ^ " found.")
108 (#rtyp qdata, #qtyp qdata)
111 (* takes two type-environments and looks
112 up in both of them the variable v, which
113 must be listed in the environment
115 fun double_lookup rtyenv qtyenv v =
117 val v' = fst (dest_TVar v)
119 (snd (the (Vartab.lookup rtyenv v')), snd (the (Vartab.lookup qtyenv v')))
122 (* matches a type pattern with a type *)
123 fun match ctxt err ty_pat ty =
125 val thy = Proof_Context.theory_of ctxt
127 Sign.typ_match thy (ty_pat, ty) Vartab.empty
128 handle Type.TYPE_MATCH => err ctxt ty_pat ty
131 (* produces the rep or abs constant for a qty *)
132 fun absrep_const flag ctxt qty_str =
134 val qty_name = Long_Name.base_name qty_str
135 val qualifier = Long_Name.qualifier qty_str
138 AbsF => Const (Long_Name.qualify qualifier ("abs_" ^ qty_name), dummyT)
139 | RepF => Const (Long_Name.qualify qualifier ("rep_" ^ qty_name), dummyT)
142 (* Lets Nitpick represent elements of quotient types as elements of the raw type *)
143 fun absrep_const_chk flag ctxt qty_str =
144 Syntax.check_term ctxt (absrep_const flag ctxt qty_str)
146 fun absrep_match_err ctxt ty_pat ty =
148 val ty_pat_str = Syntax.string_of_typ ctxt ty_pat
149 val ty_str = Syntax.string_of_typ ctxt ty
151 raise LIFT_MATCH (space_implode " "
152 ["absrep_fun (Types ", quote ty_pat_str, "and", quote ty_str, " do not match.)"])
156 (** generation of an aggregate absrep function **)
158 (* - In case of equal types we just return the identity.
160 - In case of TFrees we also return the identity.
162 - In case of function types we recurse taking
163 the polarity change into account.
165 - If the type constructors are equal, we recurse for the
166 arguments and build the appropriate map function.
168 - If the type constructors are unequal, there must be an
169 instance of quotient types:
171 - we first look up the corresponding rty_pat and qty_pat
172 from the quotient definition; the arguments of qty_pat
173 must be some distinct TVars
174 - we then match the rty_pat with rty and qty_pat with qty;
175 if matching fails the types do not correspond -> error
176 - the matching produces two environments; we look up the
177 assignments for the qty_pat variables and recurse on the
179 - we prefix the aggregate map function for the rty_pat,
180 which is an abstraction over all type variables
181 - finally we compose the result with the appropriate
182 absrep function in case at least one argument produced
183 a non-identity function /
184 otherwise we just return the appropriate absrep
187 The composition is necessary for types like
189 ('a list) list / ('a foo) foo
191 The matching is necessary for types like
193 ('a * 'a) list / 'a bar
195 The test is necessary in order to eliminate superfluous
199 fun absrep_fun flag ctxt (rty, qty) =
204 (Type ("fun", [ty1, ty2]), Type ("fun", [ty1', ty2'])) =>
206 val arg1 = absrep_fun (negF flag) ctxt (ty1, ty1')
207 val arg2 = absrep_fun flag ctxt (ty2, ty2')
209 list_comb (get_mapfun ctxt "fun", [arg1, arg2])
211 (* FIXME: use type_name antiquotation if set type becomes explicit *)
212 | (Type ("Set.set", [ty]), Type ("Set.set", [ty'])) =>
214 val arg = absrep_fun (negF flag) ctxt (ty, ty')
216 get_mapfun ctxt "Set.set" $ arg
218 | (Type (s, tys), Type (s', tys')) =>
222 val args = map (absrep_fun flag ctxt) (tys ~~ tys')
224 list_comb (get_mapfun ctxt s, args)
228 val (rty_pat, qty_pat as Type (_, vs)) = get_rty_qty ctxt s'
229 val rtyenv = match ctxt absrep_match_err rty_pat rty
230 val qtyenv = match ctxt absrep_match_err qty_pat qty
231 val args_aux = map (double_lookup rtyenv qtyenv) vs
232 val args = map (absrep_fun flag ctxt) args_aux
234 if forall is_identity args
235 then absrep_const flag ctxt s'
238 val map_fun = mk_mapfun ctxt vs rty_pat
239 val result = list_comb (map_fun, args)
241 mk_fun_compose flag (absrep_const flag ctxt s', result)
244 | (TFree x, TFree x') =>
247 else raise (LIFT_MATCH "absrep_fun (frees)")
248 | (TVar _, TVar _) => raise (LIFT_MATCH "absrep_fun (vars)")
249 | _ => raise (LIFT_MATCH "absrep_fun (default)")
251 fun absrep_fun_chk flag ctxt (rty, qty) =
252 absrep_fun flag ctxt (rty, qty)
253 |> Syntax.check_term ctxt
258 (*** Aggregate Equivalence Relation ***)
261 (* works very similar to the absrep generation,
262 except there is no need for polarities
265 (* instantiates TVars so that the term is of type ty *)
266 fun force_typ ctxt trm ty =
268 val thy = Proof_Context.theory_of ctxt
269 val trm_ty = fastype_of trm
270 val ty_inst = Sign.typ_match thy (trm_ty, ty) Vartab.empty
272 map_types (Envir.subst_type ty_inst) trm
275 fun is_eq (Const (@{const_name HOL.eq}, _)) = true
278 fun mk_rel_compose (trm1, trm2) =
279 Const (@{const_abbrev "rel_conj"}, dummyT) $ trm1 $ trm2
281 fun get_relmap ctxt s =
283 val thy = Proof_Context.theory_of ctxt
284 val relmap = #relmap (Quotient_Info.maps_lookup thy s) handle Quotient_Info.NotFound =>
285 raise LIFT_MATCH ("get_relmap (no relation map function found for type " ^ s ^ ")")
287 Const (relmap, dummyT)
290 fun mk_relmap ctxt vs rty =
292 val vs' = map (mk_Free) vs
294 fun mk_relmap_aux rty =
296 TVar _ => mk_Free rty
297 | Type (_, []) => HOLogic.eq_const rty
298 | Type (s, tys) => list_comb (get_relmap ctxt s, map mk_relmap_aux tys)
299 | _ => raise LIFT_MATCH ("mk_relmap (default)")
301 fold_rev Term.lambda vs' (mk_relmap_aux rty)
304 fun get_equiv_rel ctxt s =
306 val thy = Proof_Context.theory_of ctxt
308 #equiv_rel (Quotient_Info.quotdata_lookup thy s) handle Quotient_Info.NotFound =>
309 raise LIFT_MATCH ("get_quotdata (no quotient found for type " ^ s ^ ")")
312 fun equiv_match_err ctxt ty_pat ty =
314 val ty_pat_str = Syntax.string_of_typ ctxt ty_pat
315 val ty_str = Syntax.string_of_typ ctxt ty
317 raise LIFT_MATCH (space_implode " "
318 ["equiv_relation (Types ", quote ty_pat_str, "and", quote ty_str, " do not match.)"])
321 (* builds the aggregate equivalence relation
322 that will be the argument of Respects
324 fun equiv_relation ctxt (rty, qty) =
326 then HOLogic.eq_const rty
329 (Type (s, tys), Type (s', tys')) =>
333 val args = map (equiv_relation ctxt) (tys ~~ tys')
335 list_comb (get_relmap ctxt s, args)
339 val (rty_pat, qty_pat as Type (_, vs)) = get_rty_qty ctxt s'
340 val rtyenv = match ctxt equiv_match_err rty_pat rty
341 val qtyenv = match ctxt equiv_match_err qty_pat qty
342 val args_aux = map (double_lookup rtyenv qtyenv) vs
343 val args = map (equiv_relation ctxt) args_aux
344 val eqv_rel = get_equiv_rel ctxt s'
345 val eqv_rel' = force_typ ctxt eqv_rel ([rty, rty] ---> @{typ bool})
351 val rel_map = mk_relmap ctxt vs rty_pat
352 val result = list_comb (rel_map, args)
354 mk_rel_compose (result, eqv_rel')
357 | _ => HOLogic.eq_const rty
359 fun equiv_relation_chk ctxt (rty, qty) =
360 equiv_relation ctxt (rty, qty)
361 |> Syntax.check_term ctxt
365 (*** Regularization ***)
367 (* Regularizing an rtrm means:
369 - Quantifiers over types that need lifting are replaced
370 by bounded quantifiers, for example:
372 All P ----> All (Respects R) P
374 where the aggregate relation R is given by the rty and qty;
376 - Abstractions over types that need lifting are replaced
377 by bounded abstractions, for example:
379 %x. P ----> Ball (Respects R) %x. P
381 - Equalities over types that need lifting are replaced by
382 corresponding equivalence relations, for example:
388 A = B ----> (R ===> R) A B
390 for more complicated types of A and B
393 The regularize_trm accepts raw theorems in which equalities
394 and quantifiers match exactly the ones in the lifted theorem
395 but also accepts partially regularized terms.
397 This means that the raw theorems can have:
398 Ball (Respects R), Bex (Respects R), Bex1_rel (Respects R), Babs, R
400 All, Ex, Ex1, %, (op =)
401 is required the lifted theorem.
405 val mk_babs = Const (@{const_name Babs}, dummyT)
406 val mk_ball = Const (@{const_name Ball}, dummyT)
407 val mk_bex = Const (@{const_name Bex}, dummyT)
408 val mk_bex1_rel = Const (@{const_name Bex1_rel}, dummyT)
409 val mk_resp = Const (@{const_name Respects}, dummyT)
411 (* - applies f to the subterm of an abstraction,
412 otherwise to the given term,
413 - used by regularize, therefore abstracted
414 variables do not have to be treated specially
416 fun apply_subt f (trm1, trm2) =
418 (Abs (x, T, t), Abs (_ , _, t')) => Abs (x, T, f (t, t'))
419 | _ => f (trm1, trm2)
421 fun term_mismatch str ctxt t1 t2 =
423 val t1_str = Syntax.string_of_term ctxt t1
424 val t2_str = Syntax.string_of_term ctxt t2
425 val t1_ty_str = Syntax.string_of_typ ctxt (fastype_of t1)
426 val t2_ty_str = Syntax.string_of_typ ctxt (fastype_of t2)
428 raise LIFT_MATCH (cat_lines [str, t1_str ^ "::" ^ t1_ty_str, t2_str ^ "::" ^ t2_ty_str])
431 (* the major type of All and Ex quantifiers *)
432 fun qnt_typ ty = domain_type (domain_type ty)
434 (* Checks that two types match, for example:
435 rty -> rty matches qty -> qty *)
436 fun matches_typ thy rT qT =
440 (Type (rs, rtys), Type (qs, qtys)) =>
442 if length rtys <> length qtys then false
443 else forall (fn x => x = true) (map2 (matches_typ thy) rtys qtys)
445 (case Quotient_Info.quotdata_lookup_raw thy qs of
446 SOME quotinfo => Sign.typ_instance thy (rT, #rtyp quotinfo)
451 (* produces a regularized version of rtrm
453 - the result might contain dummyTs
455 - for regularization we do not need any
456 special treatment of bound variables
458 fun regularize_trm ctxt (rtrm, qtrm) =
460 (Abs (x, ty, t), Abs (_, ty', t')) =>
462 val subtrm = Abs(x, ty, regularize_trm ctxt (t, t'))
464 if ty = ty' then subtrm
465 else mk_babs $ (mk_resp $ equiv_relation ctxt (ty, ty')) $ subtrm
467 | (Const (@{const_name Babs}, T) $ resrel $ (t as (Abs (_, ty, _))), t' as (Abs (_, ty', _))) =>
469 val subtrm = regularize_trm ctxt (t, t')
470 val needres = mk_resp $ equiv_relation_chk ctxt (ty, ty')
473 then term_mismatch "regularize (Babs)" ctxt resrel needres
474 else mk_babs $ resrel $ subtrm
477 | (Const (@{const_name All}, ty) $ t, Const (@{const_name All}, ty') $ t') =>
479 val subtrm = apply_subt (regularize_trm ctxt) (t, t')
481 if ty = ty' then Const (@{const_name All}, ty) $ subtrm
482 else mk_ball $ (mk_resp $ equiv_relation ctxt (qnt_typ ty, qnt_typ ty')) $ subtrm
485 | (Const (@{const_name Ex}, ty) $ t, Const (@{const_name Ex}, ty') $ t') =>
487 val subtrm = apply_subt (regularize_trm ctxt) (t, t')
489 if ty = ty' then Const (@{const_name Ex}, ty) $ subtrm
490 else mk_bex $ (mk_resp $ equiv_relation ctxt (qnt_typ ty, qnt_typ ty')) $ subtrm
493 | (Const (@{const_name Ex1}, ty) $ (Abs (_, _,
494 (Const (@{const_name HOL.conj}, _) $ (Const (@{const_name Set.member}, _) $ _ $
495 (Const (@{const_name Respects}, _) $ resrel)) $ (t $ _)))),
496 Const (@{const_name Ex1}, ty') $ t') =>
498 val t_ = incr_boundvars (~1) t
499 val subtrm = apply_subt (regularize_trm ctxt) (t_, t')
500 val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty')
503 then term_mismatch "regularize (Bex1)" ctxt resrel needrel
504 else mk_bex1_rel $ resrel $ subtrm
507 | (Const (@{const_name Ex1}, ty) $ t, Const (@{const_name Ex1}, ty') $ t') =>
509 val subtrm = apply_subt (regularize_trm ctxt) (t, t')
511 if ty = ty' then Const (@{const_name Ex1}, ty) $ subtrm
512 else mk_bex1_rel $ (equiv_relation ctxt (qnt_typ ty, qnt_typ ty')) $ subtrm
515 | (Const (@{const_name Ball}, ty) $ (Const (@{const_name Respects}, _) $ resrel) $ t,
516 Const (@{const_name All}, ty') $ t') =>
518 val subtrm = apply_subt (regularize_trm ctxt) (t, t')
519 val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty')
522 then term_mismatch "regularize (Ball)" ctxt resrel needrel
523 else mk_ball $ (mk_resp $ resrel) $ subtrm
526 | (Const (@{const_name Bex}, ty) $ (Const (@{const_name Respects}, _) $ resrel) $ t,
527 Const (@{const_name Ex}, ty') $ t') =>
529 val subtrm = apply_subt (regularize_trm ctxt) (t, t')
530 val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty')
533 then term_mismatch "regularize (Bex)" ctxt resrel needrel
534 else mk_bex $ (mk_resp $ resrel) $ subtrm
537 | (Const (@{const_name Bex1_rel}, ty) $ resrel $ t, Const (@{const_name Ex1}, ty') $ t') =>
539 val subtrm = apply_subt (regularize_trm ctxt) (t, t')
540 val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty')
543 then term_mismatch "regularize (Bex1_res)" ctxt resrel needrel
544 else mk_bex1_rel $ resrel $ subtrm
547 | (* equalities need to be replaced by appropriate equivalence relations *)
548 (Const (@{const_name HOL.eq}, ty), Const (@{const_name HOL.eq}, ty')) =>
549 if ty = ty' then rtrm
550 else equiv_relation ctxt (domain_type ty, domain_type ty')
552 | (* in this case we just check whether the given equivalence relation is correct *)
553 (rel, Const (@{const_name HOL.eq}, ty')) =>
555 val rel_ty = fastype_of rel
556 val rel' = equiv_relation_chk ctxt (domain_type rel_ty, domain_type ty')
558 if rel' aconv rel then rtrm
559 else term_mismatch "regularize (relation mismatch)" ctxt rel rel'
564 val thy = Proof_Context.theory_of ctxt
565 fun same_const (Const (s, T)) (Const (s', T')) = (s = s') andalso matches_typ thy T T'
566 | same_const _ _ = false
568 if same_const rtrm qtrm then rtrm
571 val rtrm' = #rconst (Quotient_Info.qconsts_lookup thy qtrm)
572 handle Quotient_Info.NotFound =>
573 term_mismatch "regularize (constant not found)" ctxt rtrm qtrm
575 if Pattern.matches thy (rtrm', rtrm)
576 then rtrm else term_mismatch "regularize (constant mismatch)" ctxt rtrm qtrm
580 | (((t1 as Const (@{const_name prod_case}, _)) $ Abs (v1, ty, Abs(v1', ty', s1))),
581 ((t2 as Const (@{const_name prod_case}, _)) $ Abs (v2, _ , Abs(v2', _ , s2)))) =>
582 regularize_trm ctxt (t1, t2) $ Abs (v1, ty, Abs (v1', ty', regularize_trm ctxt (s1, s2)))
584 | (((t1 as Const (@{const_name prod_case}, _)) $ Abs (v1, ty, s1)),
585 ((t2 as Const (@{const_name prod_case}, _)) $ Abs (v2, _ , s2))) =>
586 regularize_trm ctxt (t1, t2) $ Abs (v1, ty, regularize_trm ctxt (s1, s2))
588 | (t1 $ t2, t1' $ t2') =>
589 regularize_trm ctxt (t1, t1') $ regularize_trm ctxt (t2, t2')
591 | (Bound i, Bound i') =>
593 else raise (LIFT_MATCH "regularize (bounds mismatch)")
597 val rtrm_str = Syntax.string_of_term ctxt rtrm
598 val qtrm_str = Syntax.string_of_term ctxt qtrm
600 raise (LIFT_MATCH ("regularize failed (default: " ^ rtrm_str ^ "," ^ qtrm_str ^ ")"))
603 fun regularize_trm_chk ctxt (rtrm, qtrm) =
604 regularize_trm ctxt (rtrm, qtrm)
605 |> Syntax.check_term ctxt
609 (*** Rep/Abs Injection ***)
612 Injection of Rep/Abs means:
616 * If the type of the abstraction needs lifting, then we add Rep/Abs
617 around the abstraction; otherwise we leave it unchanged.
621 * If the application involves a bounded quantifier, we recurse on
622 the second argument. If the application is a bounded abstraction,
623 we always put an Rep/Abs around it (since bounded abstractions
624 are assumed to always need lifting). Otherwise we recurse on both
629 * If the constant is (op =), we leave it always unchanged.
630 Otherwise the type of the constant needs lifting, we put
631 and Rep/Abs around it.
635 * We put a Rep/Abs around it if the type needs lifting.
637 Vars case cannot occur.
640 fun mk_repabs ctxt (T, T') trm =
641 absrep_fun RepF ctxt (T, T') $ (absrep_fun AbsF ctxt (T, T') $ trm)
643 fun inj_repabs_err ctxt msg rtrm qtrm =
645 val rtrm_str = Syntax.string_of_term ctxt rtrm
646 val qtrm_str = Syntax.string_of_term ctxt qtrm
648 raise LIFT_MATCH (space_implode " " [msg, quote rtrm_str, "and", quote qtrm_str])
652 (* bound variables need to be treated properly,
653 as the type of subterms needs to be calculated *)
654 fun inj_repabs_trm ctxt (rtrm, qtrm) =
656 (Const (@{const_name Ball}, T) $ r $ t, Const (@{const_name All}, _) $ t') =>
657 Const (@{const_name Ball}, T) $ r $ (inj_repabs_trm ctxt (t, t'))
659 | (Const (@{const_name Bex}, T) $ r $ t, Const (@{const_name Ex}, _) $ t') =>
660 Const (@{const_name Bex}, T) $ r $ (inj_repabs_trm ctxt (t, t'))
662 | (Const (@{const_name Babs}, T) $ r $ t, t' as (Abs _)) =>
664 val rty = fastype_of rtrm
665 val qty = fastype_of qtrm
667 mk_repabs ctxt (rty, qty) (Const (@{const_name Babs}, T) $ r $ (inj_repabs_trm ctxt (t, t')))
670 | (Abs (x, T, t), Abs (x', T', t')) =>
672 val rty = fastype_of rtrm
673 val qty = fastype_of qtrm
674 val (y, s) = Term.dest_abs (x, T, t)
675 val (_, s') = Term.dest_abs (x', T', t')
676 val yvar = Free (y, T)
677 val result = Term.lambda_name (y, yvar) (inj_repabs_trm ctxt (s, s'))
679 if rty = qty then result
680 else mk_repabs ctxt (rty, qty) result
683 | (t $ s, t' $ s') =>
684 (inj_repabs_trm ctxt (t, t')) $ (inj_repabs_trm ctxt (s, s'))
686 | (Free (_, T), Free (_, T')) =>
688 else mk_repabs ctxt (T, T') rtrm
690 | (_, Const (@{const_name HOL.eq}, _)) => rtrm
692 | (_, Const (_, T')) =>
694 val rty = fastype_of rtrm
696 if rty = T' then rtrm
697 else mk_repabs ctxt (rty, T') rtrm
700 | _ => inj_repabs_err ctxt "injection (default):" rtrm qtrm
702 fun inj_repabs_trm_chk ctxt (rtrm, qtrm) =
703 inj_repabs_trm ctxt (rtrm, qtrm)
704 |> Syntax.check_term ctxt
708 (*** Wrapper for automatically transforming an rthm into a qthm ***)
710 (* substitutions functions for r/q-types and
711 r/q-constants, respectively
713 fun subst_typ ctxt ty_subst rty =
717 val thy = Proof_Context.theory_of ctxt
718 val rty' = Type (s, map (subst_typ ctxt ty_subst) rtys)
720 fun matches [] = rty'
721 | matches ((rty, qty)::tail) =
722 case try (Sign.typ_match thy (rty, rty')) Vartab.empty of
724 | SOME inst => Envir.subst_type inst qty
730 fun subst_trm ctxt ty_subst trm_subst rtrm =
732 t1 $ t2 => (subst_trm ctxt ty_subst trm_subst t1) $ (subst_trm ctxt ty_subst trm_subst t2)
733 | Abs (x, ty, t) => Abs (x, subst_typ ctxt ty_subst ty, subst_trm ctxt ty_subst trm_subst t)
734 | Free(n, ty) => Free(n, subst_typ ctxt ty_subst ty)
735 | Var(n, ty) => Var(n, subst_typ ctxt ty_subst ty)
739 val thy = Proof_Context.theory_of ctxt
741 fun matches [] = Const (a, subst_typ ctxt ty_subst ty)
742 | matches ((rconst, qconst)::tail) =
743 case try (Pattern.match thy (rconst, rtrm)) (Vartab.empty, Vartab.empty) of
745 | SOME inst => Envir.subst_term inst qconst
750 (* generate type and term substitutions out of the
751 qtypes involved in a quotient; the direction flag
752 indicates in which direction the substitutions work:
754 true: quotient -> raw
755 false: raw -> quotient
757 fun mk_ty_subst qtys direction ctxt =
759 val thy = Proof_Context.theory_of ctxt
761 Quotient_Info.quotdata_dest ctxt
762 |> map (fn x => (#rtyp x, #qtyp x))
763 |> filter (fn (_, qty) => member (Sign.typ_instance thy o swap) qtys qty)
764 |> map (if direction then swap else I)
767 fun mk_trm_subst qtys direction ctxt =
769 val subst_typ' = subst_typ ctxt (mk_ty_subst qtys direction ctxt)
770 fun proper (t1, t2) = subst_typ' (fastype_of t1) = fastype_of t2
773 Quotient_Info.qconsts_dest ctxt
774 |> map (fn x => (#rconst x, #qconst x))
775 |> map (if direction then swap else I)
778 Quotient_Info.quotdata_dest ctxt
779 |> map (fn x => (#equiv_rel x, HOLogic.eq_const (#qtyp x)))
780 |> map (if direction then swap else I)
782 filter proper (const_substs @ rel_substs)
786 (* derives a qtyp and qtrm out of a rtyp and rtrm,
789 fun derive_qtyp ctxt qtys rty =
790 subst_typ ctxt (mk_ty_subst qtys false ctxt) rty
792 fun derive_qtrm ctxt qtys rtrm =
793 subst_trm ctxt (mk_ty_subst qtys false ctxt) (mk_trm_subst qtys false ctxt) rtrm
795 (* derives a rtyp and rtrm out of a qtyp and qtrm,
798 fun derive_rtyp ctxt qtys qty =
799 subst_typ ctxt (mk_ty_subst qtys true ctxt) qty
801 fun derive_rtrm ctxt qtys qtrm =
802 subst_trm ctxt (mk_ty_subst qtys true ctxt) (mk_trm_subst qtys true ctxt) qtrm