src/HOL/Tools/inductive_realizer.ML
author berghofe
Wed Nov 13 15:32:41 2002 +0100 (2002-11-13)
changeset 13710 75bec2c1bfd5
child 13725 12404b452034
permissions -rw-r--r--
New package for constructing realizers for introduction and elimination
rules of inductive predicates.
     1 (*  Title:      HOL/Tools/inductive_realizer.ML
     2     ID:         $Id$
     3     Author:     Stefan Berghofer, TU Muenchen
     4     License:    GPL (GNU GENERAL PUBLIC LICENSE)
     5 
     6 Porgram extraction from proofs involving inductive predicates:
     7 Realizers for induction and elimination rules
     8 *)
     9 
    10 signature INDUCTIVE_REALIZER =
    11 sig
    12   val add_ind_realizers: string -> string list -> theory -> theory
    13   val setup: (theory -> theory) list
    14 end;
    15 
    16 structure InductiveRealizer : INDUCTIVE_REALIZER =
    17 struct
    18 
    19 val all_simps = map (symmetric o mk_meta_eq) (thms "HOL.all_simps");
    20 
    21 fun prf_of thm =
    22   let val {sign, prop, der = (_, prf), ...} = rep_thm thm
    23   in Reconstruct.reconstruct_proof sign prop prf end;
    24 
    25 fun forall_intr_prf (t, prf) =
    26   let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
    27   in Abst (a, Some T, Proofterm.prf_abstract_over t prf) end;
    28 
    29 fun subsets [] = [[]]
    30   | subsets (x::xs) =
    31       let val ys = subsets xs
    32       in ys @ map (cons x) ys end;
    33 
    34 val set_of = fst o dest_Const o head_of o snd o HOLogic.dest_mem;
    35 
    36 fun strip_all t =
    37   let
    38     fun strip used (Const ("all", _) $ Abs (s, T, t)) =
    39           let val s' = variant used s
    40           in strip (s'::used) (subst_bound (Free (s', T), t)) end
    41       | strip used ((t as Const ("==>", _) $ P) $ Q) = t $ strip used Q
    42       | strip _ t = t;
    43   in strip (add_term_free_names (t, [])) t end;
    44 
    45 fun relevant_vars prop = foldr (fn
    46       (Var ((a, i), T), vs) => (case strip_type T of
    47         (_, Type (s, _)) => if s mem ["bool", "set"] then (a, T) :: vs else vs
    48       | _ => vs)
    49     | (_, vs) => vs) (term_vars prop, []);
    50 
    51 fun params_of intr = map (fst o fst o dest_Var) (term_vars
    52   (snd (HOLogic.dest_mem (HOLogic.dest_Trueprop
    53     (Logic.strip_imp_concl intr)))));
    54 
    55 fun dt_of_intrs thy vs intrs =
    56   let
    57     val iTs = term_tvars (prop_of (hd intrs));
    58     val Tvs = map TVar iTs;
    59     val (_ $ (_ $ _ $ S)) = Logic.strip_imp_concl (prop_of (hd intrs));
    60     val (Const (s, _), ts) = strip_comb S;
    61     val params = map dest_Var ts;
    62     val tname = space_implode "_" (Sign.base_name s ^ "T" :: vs);
    63     fun constr_of_intr intr = (Sign.base_name (Thm.name_of_thm intr),
    64       map (Type.unvarifyT o snd) (rev (Term.add_vars ([], prop_of intr)) \\ params) @
    65         filter_out (equal Extraction.nullT) (map
    66           (Type.unvarifyT o Extraction.etype_of thy vs []) (prems_of intr)),
    67             NoSyn);
    68   in (map (fn a => "'" ^ a) vs @ map (fst o fst) iTs, tname, NoSyn,
    69     map constr_of_intr intrs)
    70   end;
    71 
    72 fun gen_realizes (Const ("realizes", Type ("fun", [T, _])) $ t $
    73       (Const ("op :", Type ("fun", [U, _])) $ x $ Var (ixn, _))) =
    74         Var (ixn, [T, U] ---> HOLogic.boolT) $ t $ x
    75   | gen_realizes (Const ("op :", Type ("fun", [U, _])) $ x $ Var (ixn, _)) =
    76       Var (ixn, U --> HOLogic.boolT) $ x
    77   | gen_realizes (bla as Const ("realizes", Type ("fun", [T, _])) $ t $ P) =
    78       if T = Extraction.nullT then P
    79       else (case strip_comb P of
    80           (Var (ixn, U), ts) => list_comb (Var (ixn, T --> U), t :: ts)
    81         | _ => error "gen_realizes: variable expected")
    82   | gen_realizes (t $ u) = gen_realizes t $ gen_realizes u
    83   | gen_realizes (Abs (s, T, t)) = Abs (s, T, gen_realizes t)
    84   | gen_realizes t = t;
    85 
    86 fun mk_rlz T = Const ("realizes", [T, HOLogic.boolT] ---> HOLogic.boolT);
    87 fun mk_rlz' T = Const ("realizes", [T, propT] ---> propT);
    88 
    89 (** turn "P" into "%r x. realizes r (P x)" or "%r x. realizes r (x : P)" **)
    90 
    91 fun gen_rvar vs (t as Var ((a, 0), T)) =
    92       let val U = TVar (("'" ^ a, 0), HOLogic.typeS)
    93       in case try HOLogic.dest_setT T of
    94           None => if body_type T <> HOLogic.boolT then t else
    95             let
    96               val Ts = binder_types T;
    97               val i = length Ts;
    98               val xs = map (pair "x") Ts;
    99               val u = list_comb (t, map Bound (i - 1 downto 0))
   100             in 
   101               if a mem vs then
   102                 list_abs (("r", U) :: xs, mk_rlz U $ Bound i $ u)
   103               else list_abs (xs, mk_rlz Extraction.nullT $ Extraction.nullt $ u)
   104             end
   105         | Some T' => if a mem vs then
   106               Abs ("r", U, Abs ("x", T', mk_rlz U $ Bound 1 $
   107                 (HOLogic.mk_mem (Bound 0, t))))
   108             else Abs ("x", T', mk_rlz Extraction.nullT $ Extraction.nullt $
   109               (HOLogic.mk_mem (Bound 0, t)))
   110       end
   111   | gen_rvar _ t = t;
   112 
   113 fun mk_realizes_eqn n vs intrs =
   114   let
   115     val iTs = term_tvars (prop_of (hd intrs));
   116     val Tvs = map TVar iTs;
   117     val _ $ (_ $ _ $ S) = concl_of (hd intrs);
   118     val (Const (s, T), ts') = strip_comb S;
   119     val setT = body_type T;
   120     val elT = HOLogic.dest_setT setT;
   121     val x = Var (("x", 0), elT);
   122     val rT = if n then Extraction.nullT
   123       else Type (space_implode "_" (s ^ "T" :: vs),
   124         map (fn a => TVar (("'" ^ a, 0), HOLogic.typeS)) vs @ Tvs);
   125     val r = if n then Extraction.nullt else Var ((Sign.base_name s, 0), rT);
   126     val rvs = relevant_vars S;
   127     val vs' = map fst rvs \\ vs;
   128     val rname = space_implode "_" (s ^ "R" :: vs);
   129 
   130     fun mk_Tprem n v =
   131       let val Some T = assoc (rvs, v)
   132       in (Const ("typeof", T --> Type ("Type", [])) $ Var ((v, 0), T),
   133         Extraction.mk_typ (if n then Extraction.nullT
   134           else TVar (("'" ^ v, 0), HOLogic.typeS)))
   135       end;
   136 
   137     val prems = map (mk_Tprem true) vs' @ map (mk_Tprem false) vs;
   138     val ts = map (gen_rvar vs) ts';
   139     val argTs = map fastype_of ts;
   140 
   141   in ((prems, (Const ("typeof", setT --> Type ("Type", [])) $ S,
   142        Extraction.mk_typ rT)),
   143     (prems, (mk_rlz rT $ r $ HOLogic.mk_mem (x, S),
   144        if n then
   145          HOLogic.mk_mem (x, list_comb (Const (rname, argTs ---> setT), ts))
   146        else HOLogic.mk_mem (HOLogic.mk_prod (r, x), list_comb (Const (rname,
   147          argTs ---> HOLogic.mk_setT (HOLogic.mk_prodT (rT, elT))), ts)))))
   148   end;
   149 
   150 fun fun_of_prem thy rsets vs params rule intr =
   151   let
   152     (* add_term_vars and Term.add_vars may return variables in different order *)
   153     val args = map (Free o apfst fst o dest_Var)
   154       (add_term_vars (prop_of intr, []) \\ map Var params);
   155     val args' = map (Free o apfst fst)
   156       (Term.add_vars ([], prop_of intr) \\ params);
   157     val rule' = strip_all rule;
   158     val conclT = Extraction.etype_of thy vs [] (Logic.strip_imp_concl rule');
   159     val used = map (fst o dest_Free) args;
   160 
   161     fun is_rec t = not (null (term_consts t inter rsets));
   162 
   163     fun is_meta (Const ("all", _) $ Abs (s, _, P)) = is_meta P
   164       | is_meta (Const ("==>", _) $ _ $ Q) = is_meta Q
   165       | is_meta (Const ("Trueprop", _) $ (Const ("op :", _) $ _ $ _)) = true
   166       | is_meta _ = false;
   167 
   168     fun fun_of ts rts args used (prem :: prems) =
   169           let
   170             val T = Extraction.etype_of thy vs [] prem;
   171             val [x, r] = variantlist (["x", "r"], used)
   172           in if T = Extraction.nullT
   173             then fun_of ts rts args used prems
   174             else if is_rec prem then
   175               if is_meta prem then
   176                 let
   177                   val prem' :: prems' = prems;
   178                   val U = Extraction.etype_of thy vs [] prem';
   179                 in if U = Extraction.nullT
   180                   then fun_of (Free (x, T) :: ts)
   181                     (Free (r, binder_types T ---> HOLogic.unitT) :: rts)
   182                     (Free (x, T) :: args) (x :: r :: used) prems'
   183                   else fun_of (Free (x, T) :: ts) (Free (r, U) :: rts)
   184                     (Free (r, U) :: Free (x, T) :: args) (x :: r :: used) prems'
   185                 end
   186               else (case strip_type T of
   187                   (Ts, Type ("*", [T1, T2])) =>
   188                     let
   189                       val fx = Free (x, Ts ---> T1);
   190                       val fr = Free (r, Ts ---> T2);
   191                       val bs = map Bound (length Ts - 1 downto 0);
   192                       val t = list_abs (map (pair "z") Ts,
   193                         HOLogic.mk_prod (list_comb (fx, bs), list_comb (fr, bs)))
   194                     in fun_of (fx :: ts) (fr :: rts) (t::args)
   195                       (x :: r :: used) prems
   196                     end
   197                 | (Ts, U) => fun_of (Free (x, T) :: ts)
   198                     (Free (r, binder_types T ---> HOLogic.unitT) :: rts)
   199                     (Free (x, T) :: args) (x :: r :: used) prems)
   200             else fun_of (Free (x, T) :: ts) rts (Free (x, T) :: args)
   201               (x :: used) prems
   202           end
   203       | fun_of ts rts args used [] =
   204           let val xs = rev (rts @ ts)
   205           in if conclT = Extraction.nullT
   206             then list_abs_free (map dest_Free xs, HOLogic.unit)
   207             else list_abs_free (map dest_Free xs, list_comb
   208               (Free ("r" ^ Sign.base_name (Thm.name_of_thm intr),
   209                 map fastype_of (rev args) ---> conclT), rev args))
   210           end
   211 
   212   in fun_of (rev args) [] args' used (Logic.strip_imp_prems rule') end;
   213 
   214 fun indrule_realizer thy induct raw_induct rsets params vs rec_names rss intrs dummies =
   215   let
   216     val concls = HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of raw_induct));
   217     val premss = mapfilter (fn (s, rs) => if s mem rsets then
   218       Some (map (fn r => nth_elem (find_index_eq (prop_of r) (map prop_of intrs),
   219         prems_of raw_induct)) rs) else None) rss;
   220     val concls' = mapfilter (fn (s, _) => if s mem rsets then
   221         find_first (fn concl => s mem term_consts concl) concls
   222       else None) rss;
   223     val fs = flat (snd (foldl_map (fn (intrs, (prems, dummy)) =>
   224       let
   225         val (intrs1, intrs2) = splitAt (length prems, intrs);
   226         val fs = map (fn (rule, intr) =>
   227           fun_of_prem thy rsets vs params rule intr) (prems ~~ intrs1)
   228       in (intrs2, if dummy then Const ("arbitrary",
   229           HOLogic.unitT --> body_type (fastype_of (hd fs))) :: fs
   230         else fs)
   231       end) (intrs, (premss ~~ dummies))));
   232     val frees = foldl Term.add_frees ([], fs);
   233     val Ts = map fastype_of fs;
   234     val rlzs = mapfilter (fn (a, concl) =>
   235       let val T = Extraction.etype_of thy vs [] concl
   236       in if T = Extraction.nullT then None
   237         else Some (list_comb (Const (a, Ts ---> T), fs))
   238       end) (rec_names ~~ concls')
   239   in if null rlzs then Extraction.nullt else
   240     let
   241       val r = foldr1 HOLogic.mk_prod rlzs;
   242       val x = Free ("x", Extraction.etype_of thy vs [] (hd (prems_of induct)));
   243       fun name_of_fn intr = "r" ^ Sign.base_name (Thm.name_of_thm intr);
   244       val r' = list_abs_free (mapfilter (fn intr =>
   245         apsome (pair (name_of_fn intr)) (assoc (frees, name_of_fn intr))) intrs,
   246           if length concls = 1 then r $ x else r)
   247     in
   248       if length concls = 1 then lambda x r' else r'
   249     end
   250   end;
   251 
   252 val nonempty_msg = explode "Nonemptiness check failed for datatype ";
   253 
   254 fun add_dummy name dname (x as (_, (vs, s, mfx, cs))) =
   255   if name = s then (true, (vs, s, mfx, (dname, [HOLogic.unitT], NoSyn) :: cs))
   256   else x;
   257 
   258 fun add_dummies f dts used thy =
   259   apsnd (pair (map fst dts)) (transform_error (f (map snd dts)) thy)
   260   handle ERROR_MESSAGE msg => if nonempty_msg prefix explode msg then
   261       let
   262         val name = Sign.base_name
   263           (implode (drop (length nonempty_msg, explode msg)));
   264         val dname = variant used "Dummy"
   265       in add_dummies f (map (add_dummy name dname) dts) (dname :: used) thy
   266       end
   267     else error msg;
   268 
   269 fun mk_realizer thy vs params ((rule, rrule), rt) =
   270   let
   271     val prems = prems_of rule;
   272     val xs = rev (Term.add_vars ([], prop_of rule));
   273     val rs = gen_rems (op = o pairself fst)
   274       (rev (Term.add_vars ([], prop_of rrule)), xs);
   275 
   276     fun mk_prf _ [] prf = prf
   277       | mk_prf rs (prem :: prems) prf =
   278           let val T = Extraction.etype_of thy vs [] prem
   279           in if T = Extraction.nullT
   280             then AbsP ("H", Some (mk_rlz' T $ Extraction.nullt $ prem),
   281               mk_prf rs prems prf)
   282             else forall_intr_prf (Var (hd rs), AbsP ("H", Some (mk_rlz' T $
   283               Var (hd rs) $ prem), mk_prf (tl rs) prems prf))
   284           end;
   285 
   286     val subst = map (fn v as (ixn, _) => (ixn, gen_rvar vs (Var v))) xs;
   287     val prf = Proofterm.map_proof_terms
   288       (subst_vars ([], subst)) I (prf_of rrule);
   289 
   290   in (Thm.name_of_thm rule, (vs,
   291     if rt = Extraction.nullt then rt else
   292       foldr (uncurry lambda) (map Var xs, rt),
   293     foldr forall_intr_prf (map Var xs, mk_prf rs prems (Proofterm.proof_combP
   294       (prf, map PBound (length prems - 1 downto 0))))))
   295   end;
   296 
   297 fun add_rule (rss, r) =
   298   let
   299     val _ $ (_ $ _ $ S) = concl_of r;
   300     val (Const (s, _), _) = strip_comb S;
   301     val rs = if_none (assoc (rss, s)) [];
   302   in overwrite (rss, (s, rs @ [r])) end;
   303 
   304 fun add_ind_realizer rsets intrs induct raw_induct elims (thy, vs) =
   305   let
   306     val iTs = term_tvars (prop_of (hd intrs));
   307     val ar = length vs + length iTs;
   308     val (_ $ (_ $ _ $ S)) = Logic.strip_imp_concl (prop_of (hd intrs));
   309     val (_, params) = strip_comb S;
   310     val params' = map dest_Var params;
   311     val rss = foldl add_rule ([], intrs);
   312     val (prfx, _) = split_last (NameSpace.unpack (fst (hd rss)));
   313     val tnames = map (fn s => space_implode "_" (s ^ "T" :: vs)) rsets;
   314     val {path, ...} = Sign.rep_sg (sign_of thy);
   315     val thy1 = thy |>
   316       Theory.root_path |>
   317       Theory.add_path (NameSpace.pack prfx);
   318     val (ty_eqs, rlz_eqs) = split_list
   319       (map (fn (s, rs) => mk_realizes_eqn (not (s mem rsets)) vs rs) rss);
   320 
   321     val thy1' = thy1 |>
   322       Theory.copy |>
   323       Theory.add_types (map (fn s => (Sign.base_name s, ar, NoSyn)) tnames) |>
   324       Theory.add_arities_i (map (fn s =>
   325         (s, replicate ar HOLogic.typeS, HOLogic.typeS)) tnames) |>
   326         Extraction.add_typeof_eqns_i ty_eqs;
   327     val dts = mapfilter (fn (s, rs) => if s mem rsets then
   328       Some (dt_of_intrs thy1' vs rs) else None) rss;
   329 
   330     (** datatype representing computational content of inductive set **)
   331 
   332     val (thy2, (dummies, dt_info)) = thy1 |>
   333       (if null dts then rpair ([], None) else
   334         apsnd (apsnd Some) o add_dummies (DatatypePackage.add_datatype_i false
   335           (map #2 dts)) (map (pair false) dts) []) |>>
   336       Extraction.add_typeof_eqns_i ty_eqs |>>
   337       Extraction.add_realizes_eqns_i rlz_eqs;
   338     fun get f x = if_none (apsome f x) [];
   339     val rec_names = distinct (map (fst o dest_Const o head_of o fst o
   340       HOLogic.dest_eq o HOLogic.dest_Trueprop o prop_of) (get #rec_thms dt_info));
   341     val (_, constrss) = foldl_map (fn ((recs, dummies), (s, rs)) =>
   342       if s mem rsets then
   343         let
   344           val (d :: dummies') = dummies;
   345           val (recs1, recs2) = splitAt (length rs, if d then tl recs else recs)
   346         in ((recs2, dummies'), map (head_of o hd o rev o snd o strip_comb o
   347           fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o prop_of) recs1)
   348         end
   349       else ((recs, dummies), replicate (length rs) Extraction.nullt))
   350         ((get #rec_thms dt_info, dummies), rss);
   351     val rintrs = map (fn (intr, c) => Pattern.eta_contract (gen_realizes
   352       (Extraction.realizes_of thy2 vs
   353         c (prop_of (forall_intr_list (map (cterm_of (sign_of thy2) o Var)
   354           (rev (Term.add_vars ([], prop_of intr)) \\ params')) intr)))))
   355             (intrs ~~ flat constrss);
   356     val rlzsets = distinct (map (fn rintr => snd (HOLogic.dest_mem
   357       (HOLogic.dest_Trueprop (Logic.strip_assums_concl rintr)))) rintrs);
   358 
   359     (** realizability predicate **)
   360 
   361     val (thy3', ind_info) = thy2 |>
   362       InductivePackage.add_inductive_i false true "" false false false
   363         (map Logic.unvarify rlzsets) (map (fn (rintr, intr) =>
   364           ((Sign.base_name (Thm.name_of_thm intr), strip_all
   365             (Logic.unvarify rintr)), [])) (rintrs ~~ intrs)) [] |>>
   366       Theory.absolute_path;
   367     val thy3 = PureThy.hide_thms false
   368       (map Thm.name_of_thm (#intrs ind_info)) thy3';
   369 
   370     (** realizer for induction rule **)
   371 
   372     val Ps = mapfilter (fn _ $ M $ P => if set_of M mem rsets then
   373       Some (fst (fst (dest_Var (head_of P)))) else None)
   374         (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of raw_induct)));
   375 
   376     fun add_ind_realizer (thy, Ps) =
   377       let
   378         val r = indrule_realizer thy induct raw_induct rsets params'
   379           (vs @ Ps) rec_names rss intrs dummies;
   380         val rlz = strip_all (Logic.unvarify (gen_realizes
   381           (Extraction.realizes_of thy (vs @ Ps) r (prop_of induct))));
   382         val rews = map mk_meta_eq
   383           (fst_conv :: snd_conv :: get #rec_thms dt_info);
   384         val thm = simple_prove_goal_cterm (cterm_of (sign_of thy) rlz) (fn prems =>
   385           [if length rss = 1 then
   386              cut_facts_tac [hd prems] 1 THEN etac (#induct ind_info) 1
   387            else EVERY [rewrite_goals_tac (rews @ all_simps),
   388              REPEAT (rtac allI 1), rtac (#induct ind_info) 1],
   389            rewrite_goals_tac rews,
   390            REPEAT ((resolve_tac prems THEN_ALL_NEW EVERY'
   391              [K (rewrite_goals_tac rews), ObjectLogic.atomize_tac,
   392               DEPTH_SOLVE_1 o FIRST' [atac, etac allE, etac impE]]) 1)]);
   393         val (thy', thm') = PureThy.store_thm ((space_implode "_"
   394           (Thm.name_of_thm induct :: vs @ Ps @ ["correctness"]), thm), []) thy
   395       in
   396         Extraction.add_realizers_i
   397           [mk_realizer thy' (vs @ Ps) params' ((induct, thm'), r)] thy'
   398       end;
   399 
   400     (** realizer for elimination rules **)
   401 
   402     val case_names = map (fst o dest_Const o head_of o fst o HOLogic.dest_eq o
   403       HOLogic.dest_Trueprop o prop_of o hd) (get #case_thms dt_info);
   404 
   405     fun add_elim_realizer Ps ((((elim, elimR), case_thms), case_name), dummy) thy =
   406       let
   407         val (prem :: prems) = prems_of elim;
   408         val p = Logic.list_implies (prems @ [prem], concl_of elim);
   409         val T' = Extraction.etype_of thy (vs @ Ps) [] p;
   410         val T = if dummy then (HOLogic.unitT --> body_type T') --> T' else T';
   411         val Ts = filter_out (equal Extraction.nullT)
   412           (map (Extraction.etype_of thy (vs @ Ps) []) (prems_of elim));
   413         val r = if null Ps then Extraction.nullt
   414           else list_abs (map (pair "x") Ts, list_comb (Const (case_name, T),
   415             (if dummy then
   416                [Abs ("x", HOLogic.unitT, Const ("arbitrary", body_type T))]
   417              else []) @
   418             map Bound ((length prems - 1 downto 0) @ [length prems])));
   419         val rlz = strip_all (Logic.unvarify (gen_realizes
   420           (Extraction.realizes_of thy (vs @ Ps) r (prop_of elim))));
   421         val rews = map mk_meta_eq case_thms;
   422         val thm = simple_prove_goal_cterm (cterm_of (sign_of thy) rlz) (fn prems =>
   423           [cut_facts_tac [hd prems] 1,
   424            etac elimR 1,
   425            ALLGOALS (EVERY' [etac Pair_inject, asm_simp_tac HOL_basic_ss]),
   426            rewrite_goals_tac rews,
   427            REPEAT ((resolve_tac prems THEN_ALL_NEW (ObjectLogic.atomize_tac THEN'
   428              DEPTH_SOLVE_1 o FIRST' [atac, etac allE, etac impE])) 1)]);
   429         val (thy', thm') = PureThy.store_thm ((space_implode "_"
   430           (Thm.name_of_thm elim :: vs @ Ps @ ["correctness"]), thm), []) thy
   431       in
   432         Extraction.add_realizers_i
   433           [mk_realizer thy' (vs @ Ps) params' ((elim, thm'), r)] thy'
   434       end;
   435 
   436     (** add realizers to theory **)
   437 
   438     val rintr_thms = flat (map (fn (_, rs) => map (fn r => nth_elem
   439       (find_index_eq r intrs, #intrs ind_info)) rs) rss);
   440     val thy4 = foldl add_ind_realizer (thy3, subsets Ps);
   441     val thy5 = Extraction.add_realizers_i
   442       (map (mk_realizer thy4 vs params')
   443          (map (fn ((rule, rrule), c) => ((rule, rrule), list_comb (c,
   444             map Var (rev (Term.add_vars ([], prop_of rule)) \\ params')))) 
   445               (flat (map snd rss) ~~ rintr_thms ~~ flat constrss))) thy4;
   446     val elimps = mapfilter (fn (s, _) => if s mem rsets then
   447         find_first (fn (thm, _) => s mem term_consts (hd (prems_of thm)))
   448           (elims ~~ #elims ind_info)
   449       else None) rss;
   450     val thy6 = foldl (fn (thy, p as ((((elim, _), _), _), _)) => thy |>
   451       add_elim_realizer [] p |> add_elim_realizer [fst (fst (dest_Var
   452         (HOLogic.dest_Trueprop (concl_of elim))))] p) (thy5,
   453            elimps ~~ get #case_thms dt_info ~~ case_names ~~ dummies)
   454 
   455   in Theory.add_path (NameSpace.pack (if_none path [])) thy6 end;
   456 
   457 fun add_ind_realizers name rsets thy =
   458   let
   459     val (_, {intrs, induct, raw_induct, elims, ...}) =
   460       (case InductivePackage.get_inductive thy name of
   461          None => error ("Unknown inductive set " ^ quote name)
   462        | Some info => info);
   463     val _ $ (_ $ _ $ S) = concl_of (hd intrs);
   464     val vss = sort (int_ord o pairself length)
   465       (subsets (map fst (relevant_vars S)))
   466   in
   467     foldl (add_ind_realizer rsets intrs induct raw_induct elims) (thy, vss)
   468   end
   469 
   470 fun rlz_attrib arg (thy, thm) =
   471   let
   472     fun err () = error "ind_realizer: bad rule";
   473     val sets =
   474       (case HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of thm)) of
   475            [_] => [set_of (HOLogic.dest_Trueprop (hd (prems_of thm)))]
   476          | xs => map (set_of o fst o HOLogic.dest_imp) xs)
   477          handle TERM _ => err () | LIST _ => err ();
   478   in 
   479     (add_ind_realizers (hd sets) (case arg of
   480         None => sets | Some None => []
   481       | Some (Some sets') => sets \\ map (Sign.intern_const (sign_of thy)) sets')
   482       thy, thm)
   483   end;
   484 
   485 val rlz_attrib_global = Attrib.syntax (Scan.lift
   486   (Scan.option (Args.$$$ "irrelevant" |--
   487     Scan.option (Args.colon |-- Scan.repeat1 Args.name))) >> rlz_attrib);
   488 
   489 val setup = [Attrib.add_attributes [("ind_realizer",
   490   (rlz_attrib_global, K Attrib.undef_local_attribute),
   491   "add realizers for inductive set")]];
   492 
   493 end;