47 ((bstring * Attrib.src list) * string) list -> (thmref * Attrib.src list) list -> |
47 ((bstring * Attrib.src list) * string) list -> (thmref * Attrib.src list) list -> |
48 local_theory -> inductive_result * local_theory |
48 local_theory -> inductive_result * local_theory |
49 val add_inductive_global: bool -> bstring -> bool -> bool -> bool -> |
49 val add_inductive_global: bool -> bstring -> bool -> bool -> bool -> |
50 (string * typ option * mixfix) list -> (string * typ option) list -> |
50 (string * typ option * mixfix) list -> (string * typ option) list -> |
51 ((bstring * Attrib.src list) * term) list -> thm list -> theory -> inductive_result * theory |
51 ((bstring * Attrib.src list) * term) list -> thm list -> theory -> inductive_result * theory |
|
52 val arities_of: thm -> (string * int) list |
|
53 val params_of: thm -> term list |
|
54 val partition_rules: thm -> thm list -> (string * thm list) list |
|
55 val unpartition_rules: thm list -> (string * 'a list) list -> 'a list |
|
56 val infer_intro_vars: thm -> int -> thm list -> term list list |
52 val setup: theory -> theory |
57 val setup: theory -> theory |
53 end; |
58 end; |
54 |
59 |
55 structure InductivePackage: INDUCTIVE_PACKAGE = |
60 structure InductivePackage: INDUCTIVE_PACKAGE = |
56 struct |
61 struct |
825 (#2 (the_inductive (LocalTheory.target_of lthy) |
830 (#2 (the_inductive (LocalTheory.target_of lthy) |
826 (LocalTheory.target_name lthy (#1 (hd cnames_syn)))), |
831 (LocalTheory.target_name lthy (#1 (hd cnames_syn)))), |
827 ProofContext.theory_of (LocalTheory.exit lthy))); |
832 ProofContext.theory_of (LocalTheory.exit lthy))); |
828 |
833 |
829 |
834 |
|
835 (* read off arities of inductive predicates from raw induction rule *) |
|
836 fun arities_of induct = |
|
837 map (fn (_ $ t $ u) => |
|
838 (fst (dest_Const (head_of t)), length (snd (strip_comb u)))) |
|
839 (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct))); |
|
840 |
|
841 (* read off parameters of inductive predicate from raw induction rule *) |
|
842 fun params_of induct = |
|
843 let |
|
844 val (_ $ t $ u :: _) = |
|
845 HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)); |
|
846 val (_, ts) = strip_comb t; |
|
847 val (_, us) = strip_comb u |
|
848 in |
|
849 List.take (ts, length ts - length us) |
|
850 end; |
|
851 |
|
852 val pname_of_intr = |
|
853 concl_of #> HOLogic.dest_Trueprop #> head_of #> dest_Const #> fst; |
|
854 |
|
855 (* partition introduction rules according to predicate name *) |
|
856 fun partition_rules induct intros = |
|
857 fold_rev (fn r => AList.map_entry op = (pname_of_intr r) (cons r)) intros |
|
858 (map (rpair [] o fst) (arities_of induct)); |
|
859 |
|
860 fun unpartition_rules intros xs = |
|
861 fold_map (fn r => AList.map_entry_yield op = (pname_of_intr r) |
|
862 (fn x :: xs => (x, xs)) #>> the) intros xs |> fst; |
|
863 |
|
864 (* infer order of variables in intro rules from order of quantifiers in elim rule *) |
|
865 fun infer_intro_vars elim arity intros = |
|
866 let |
|
867 val thy = theory_of_thm elim; |
|
868 val _ :: cases = prems_of elim; |
|
869 val used = map (fst o fst) (Term.add_vars (prop_of elim) []); |
|
870 fun mtch (t, u) = |
|
871 let |
|
872 val params = Logic.strip_params t; |
|
873 val vars = map (Var o apfst (rpair 0)) |
|
874 (Name.variant_list used (map fst params) ~~ map snd params); |
|
875 val ts = map (curry subst_bounds (rev vars)) |
|
876 (List.drop (Logic.strip_assums_hyp t, arity)); |
|
877 val us = Logic.strip_imp_prems u; |
|
878 val tab = fold (Pattern.first_order_match thy) (ts ~~ us) |
|
879 (Vartab.empty, Vartab.empty); |
|
880 in |
|
881 map (Envir.subst_vars tab) vars |
|
882 end |
|
883 in |
|
884 map (mtch o apsnd prop_of) (cases ~~ intros) |
|
885 end; |
|
886 |
|
887 |
830 (** package setup **) |
888 (** package setup **) |
831 |
889 |
832 (* setup theory *) |
890 (* setup theory *) |
833 |
891 |
834 val setup = |
892 val setup = |