src/HOL/Tools/inductive_realizer.ML
changeset 39557 fe5722fce758
parent 37678 0040bafffdef
child 42361 23f352990944
equal deleted inserted replaced
39556:32a00ff29d1a 39557:fe5722fce758
   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;