271 fun rename tab = map (fn x => the_default x (AList.lookup op = tab x)); |
271 fun rename tab = map (fn x => the_default x (AList.lookup op = tab x)); |
272 |
272 |
273 fun add_ind_realizer rsets intrs induct raw_induct elims vs thy = |
273 fun add_ind_realizer rsets intrs induct raw_induct elims vs thy = |
274 let |
274 let |
275 val qualifier = Long_Name.qualifier (name_of_thm induct); |
275 val qualifier = Long_Name.qualifier (name_of_thm induct); |
276 val inducts = PureThy.get_thms thy (Long_Name.qualify qualifier "inducts"); |
276 val inducts = Global_Theory.get_thms thy (Long_Name.qualify qualifier "inducts"); |
277 val iTs = rev (Term.add_tvars (prop_of (hd intrs)) []); |
277 val iTs = rev (Term.add_tvars (prop_of (hd intrs)) []); |
278 val ar = length vs + length iTs; |
278 val ar = length vs + length iTs; |
279 val params = Inductive.params_of raw_induct; |
279 val params = Inductive.params_of raw_induct; |
280 val arities = Inductive.arities_of raw_induct; |
280 val arities = Inductive.arities_of raw_induct; |
281 val nparms = length params; |
281 val nparms = length params; |
354 rlzpreds rlzparams (map (fn (rintr, intr) => |
354 rlzpreds rlzparams (map (fn (rintr, intr) => |
355 ((Binding.name (Long_Name.base_name (name_of_thm intr)), []), |
355 ((Binding.name (Long_Name.base_name (name_of_thm intr)), []), |
356 subst_atomic rlzpreds' (Logic.unvarify_global rintr))) |
356 subst_atomic rlzpreds' (Logic.unvarify_global rintr))) |
357 (rintrs ~~ maps snd rss)) [] ||> |
357 (rintrs ~~ maps snd rss)) [] ||> |
358 Sign.root_path; |
358 Sign.root_path; |
359 val thy3 = fold (PureThy.hide_fact false o name_of_thm) (#intrs ind_info) thy3'; |
359 val thy3 = fold (Global_Theory.hide_fact false o name_of_thm) (#intrs ind_info) thy3'; |
360 |
360 |
361 (** realizer for induction rule **) |
361 (** realizer for induction rule **) |
362 |
362 |
363 val Ps = map_filter (fn _ $ M $ P => if member (op =) rsets (pred_of M) then |
363 val Ps = map_filter (fn _ $ M $ P => if member (op =) rsets (pred_of M) then |
364 SOME (fst (fst (dest_Var (head_of P)))) else NONE) |
364 SOME (fst (fst (dest_Var (head_of P)))) else NONE) |
393 [rtac (#raw_induct ind_info) 1, |
393 [rtac (#raw_induct ind_info) 1, |
394 rewrite_goals_tac rews, |
394 rewrite_goals_tac rews, |
395 REPEAT ((resolve_tac prems THEN_ALL_NEW EVERY' |
395 REPEAT ((resolve_tac prems THEN_ALL_NEW EVERY' |
396 [K (rewrite_goals_tac rews), Object_Logic.atomize_prems_tac, |
396 [K (rewrite_goals_tac rews), Object_Logic.atomize_prems_tac, |
397 DEPTH_SOLVE_1 o FIRST' [atac, etac allE, etac impE]]) 1)]); |
397 DEPTH_SOLVE_1 o FIRST' [atac, etac allE, etac impE]]) 1)]); |
398 val (thm', thy') = PureThy.store_thm (Binding.qualified_name (space_implode "_" |
398 val (thm', thy') = Global_Theory.store_thm (Binding.qualified_name (space_implode "_" |
399 (Long_Name.qualify qualifier "induct" :: vs' @ Ps @ ["correctness"])), thm) thy; |
399 (Long_Name.qualify qualifier "induct" :: vs' @ Ps @ ["correctness"])), thm) thy; |
400 val thms = map (fn th => zero_var_indexes (rotate_prems ~1 (th RS mp))) |
400 val thms = map (fn th => zero_var_indexes (rotate_prems ~1 (th RS mp))) |
401 (Datatype_Aux.split_conj_thm thm'); |
401 (Datatype_Aux.split_conj_thm thm'); |
402 val ([thms'], thy'') = PureThy.add_thmss |
402 val ([thms'], thy'') = Global_Theory.add_thmss |
403 [((Binding.qualified_name (space_implode "_" |
403 [((Binding.qualified_name (space_implode "_" |
404 (Long_Name.qualify qualifier "inducts" :: vs' @ Ps @ |
404 (Long_Name.qualify qualifier "inducts" :: vs' @ Ps @ |
405 ["correctness"])), thms), [])] thy'; |
405 ["correctness"])), thms), [])] thy'; |
406 val realizers = inducts ~~ thms' ~~ rlzs ~~ rs; |
406 val realizers = inducts ~~ thms' ~~ rlzs ~~ rs; |
407 in |
407 in |
452 etac elimR 1, |
452 etac elimR 1, |
453 ALLGOALS (asm_simp_tac HOL_basic_ss), |
453 ALLGOALS (asm_simp_tac HOL_basic_ss), |
454 rewrite_goals_tac rews, |
454 rewrite_goals_tac rews, |
455 REPEAT ((resolve_tac prems THEN_ALL_NEW (Object_Logic.atomize_prems_tac THEN' |
455 REPEAT ((resolve_tac prems THEN_ALL_NEW (Object_Logic.atomize_prems_tac THEN' |
456 DEPTH_SOLVE_1 o FIRST' [atac, etac allE, etac impE])) 1)]); |
456 DEPTH_SOLVE_1 o FIRST' [atac, etac allE, etac impE])) 1)]); |
457 val (thm', thy') = PureThy.store_thm (Binding.qualified_name (space_implode "_" |
457 val (thm', thy') = Global_Theory.store_thm (Binding.qualified_name (space_implode "_" |
458 (name_of_thm elim :: vs @ Ps @ ["correctness"])), thm) thy |
458 (name_of_thm elim :: vs @ Ps @ ["correctness"])), thm) thy |
459 in |
459 in |
460 Extraction.add_realizers_i |
460 Extraction.add_realizers_i |
461 [mk_realizer thy' (vs @ Ps) (name_of_thm elim, elim, thm', rlz, r)] thy' |
461 [mk_realizer thy' (vs @ Ps) (name_of_thm elim, elim, thm', rlz, r)] thy' |
462 end; |
462 end; |