1643 cut_rules_tac [split_meta RS Drule.equal_elim_rule2] 1 THEN |
1643 cut_rules_tac [split_meta RS Drule.equal_elim_rule2] 1 THEN |
1644 resolve_tac prems 2 THEN |
1644 resolve_tac prems 2 THEN |
1645 asm_simp_tac HOL_ss 1) |
1645 asm_simp_tac HOL_ss 1) |
1646 end); |
1646 end); |
1647 |
1647 |
1648 val ([induct', inject', surjective', split_meta'], thm_thy) = |
1648 val ([(_, [induct']), (_, [inject']), (_, [surjective']), (_, [split_meta'])], thm_thy) = |
1649 defs_thy |
1649 defs_thy |
1650 |> Global_Theory.add_thms (map (Thm.no_attributes o apfst Binding.name) |
1650 |> Global_Theory.note_thmss "" |
1651 [("ext_induct", induct), |
1651 [((Binding.name "ext_induct", []), [([induct], [])]), |
1652 ("ext_inject", inject), |
1652 ((Binding.name "ext_inject", []), [([inject], [])]), |
1653 ("ext_surjective", surject), |
1653 ((Binding.name "ext_surjective", []), [([surject], [])]), |
1654 ("ext_split", split_meta)]); |
1654 ((Binding.name "ext_split", []), [([split_meta], [])])]; |
1655 |
|
1656 in |
1655 in |
1657 (((ext_name, ext_type), (ext_tyco, alphas_zeta), |
1656 (((ext_name, ext_type), (ext_tyco, alphas_zeta), |
1658 extT, induct', inject', surjective', split_meta', ext_def), thm_thy) |
1657 extT, induct', inject', surjective', split_meta', ext_def), thm_thy) |
1659 end; |
1658 end; |
1660 |
1659 |
2179 |
2178 |
2180 val equality = timeit_msg ctxt "record equality proof:" (fn () => |
2179 val equality = timeit_msg ctxt "record equality proof:" (fn () => |
2181 Skip_Proof.prove_global defs_thy [] [] equality_prop |
2180 Skip_Proof.prove_global defs_thy [] [] equality_prop |
2182 (fn _ => asm_full_simp_tac (record_ss addsimps (split_meta :: sel_convs)) 1)); |
2181 (fn _ => asm_full_simp_tac (record_ss addsimps (split_meta :: sel_convs)) 1)); |
2183 |
2182 |
2184 val ((([sel_convs', upd_convs', sel_defs', upd_defs', |
2183 val ([(_, sel_convs'), (_, upd_convs'), (_, sel_defs'), (_, upd_defs'), |
2185 fold_congs', unfold_congs', |
2184 (_, fold_congs'), (_, unfold_congs'), |
2186 splits' as [split_meta', split_object', split_ex'], derived_defs'], |
2185 (_, splits' as [split_meta', split_object', split_ex']), (_, derived_defs'), |
2187 [surjective', equality']), |
2186 (_, [surjective']), (_, [equality']), (_, [induct_scheme']), (_, [induct']), |
2188 [induct_scheme', induct', cases_scheme', cases']), thms_thy) = |
2187 (_, [cases_scheme']), (_, [cases'])], thms_thy) = defs_thy |
2189 defs_thy |
2188 |> Global_Theory.note_thmss "" |
2190 |> (Global_Theory.add_thmss o map (Thm.no_attributes o apfst Binding.name)) |
2189 [((Binding.name "select_convs", []), [(sel_convs, [])]), |
2191 [("select_convs", sel_convs), |
2190 ((Binding.name "update_convs", []), [(upd_convs, [])]), |
2192 ("update_convs", upd_convs), |
2191 ((Binding.name "select_defs", []), [(sel_defs, [])]), |
2193 ("select_defs", sel_defs), |
2192 ((Binding.name "update_defs", []), [(upd_defs, [])]), |
2194 ("update_defs", upd_defs), |
2193 ((Binding.name "fold_congs", []), [(fold_congs, [])]), |
2195 ("fold_congs", fold_congs), |
2194 ((Binding.name "unfold_congs", []), [(unfold_congs, [])]), |
2196 ("unfold_congs", unfold_congs), |
2195 ((Binding.name "splits", []), [([split_meta, split_object, split_ex], [])]), |
2197 ("splits", [split_meta, split_object, split_ex]), |
2196 ((Binding.name "defs", []), [(derived_defs, [])]), |
2198 ("defs", derived_defs)] |
2197 ((Binding.name "surjective", []), [([surjective], [])]), |
2199 ||>> (Global_Theory.add_thms o map (Thm.no_attributes o apfst Binding.name)) |
2198 ((Binding.name "equality", []), [([equality], [])]), |
2200 [("surjective", surjective), |
2199 ((Binding.name "induct_scheme", induct_type_global (suffix schemeN name)), |
2201 ("equality", equality)] |
2200 [([induct_scheme], [])]), |
2202 ||>> (Global_Theory.add_thms o (map o apfst o apfst) Binding.name) |
2201 ((Binding.name "induct", induct_type_global name), [([induct], [])]), |
2203 [(("induct_scheme", induct_scheme), induct_type_global (suffix schemeN name)), |
2202 ((Binding.name "cases_scheme", cases_type_global (suffix schemeN name)), |
2204 (("induct", induct), induct_type_global name), |
2203 [([cases_scheme], [])]), |
2205 (("cases_scheme", cases_scheme), cases_type_global (suffix schemeN name)), |
2204 ((Binding.name "cases", cases_type_global name), [([cases], [])])]; |
2206 (("cases", cases), cases_type_global name)]; |
|
2207 |
2205 |
2208 val sel_upd_simps = sel_convs' @ upd_convs'; |
2206 val sel_upd_simps = sel_convs' @ upd_convs'; |
2209 val sel_upd_defs = sel_defs' @ upd_defs'; |
2207 val sel_upd_defs = sel_defs' @ upd_defs'; |
2210 val depth = parent_len + 1; |
2208 val depth = parent_len + 1; |
2211 |
2209 |
2212 val ([simps', iffs'], thms_thy') = |
2210 val ([(_, simps'), (_, iffs')], thms_thy') = thms_thy |
2213 thms_thy |
2211 |> Global_Theory.note_thmss "" |
2214 |> Global_Theory.add_thmss |
2212 [((Binding.name "simps", [Simplifier.simp_add]), [(sel_upd_simps, [])]), |
2215 [((Binding.name "simps", sel_upd_simps), [Simplifier.simp_add]), |
2213 ((Binding.name "iffs", [iff_add]), [([ext_inject], [])])]; |
2216 ((Binding.name "iffs", [ext_inject]), [iff_add])]; |
|
2217 |
2214 |
2218 val info = |
2215 val info = |
2219 make_info alphas parent fields extension |
2216 make_info alphas parent fields extension |
2220 ext_induct ext_inject ext_surjective ext_split ext_def |
2217 ext_induct ext_inject ext_surjective ext_split ext_def |
2221 sel_convs' upd_convs' sel_defs' upd_defs' fold_congs' unfold_congs' splits' derived_defs' |
2218 sel_convs' upd_convs' sel_defs' upd_defs' fold_congs' unfold_congs' splits' derived_defs' |