src/Pure/Proof/extraction.ML
author wenzelm
Tue May 31 11:53:40 2005 +0200 (2005-05-31)
changeset 16149 d8cac577493c
parent 15801 d2f5ca3c048d
child 16195 0eb3c15298cd
permissions -rw-r--r--
Theory.restore_naming;
tuned fold;
     1 (*  Title:      Pure/Proof/extraction.ML
     2     ID:         $Id$
     3     Author:     Stefan Berghofer, TU Muenchen
     4 
     5 Extraction of programs from proofs.
     6 *)
     7 
     8 signature EXTRACTION =
     9 sig
    10   val set_preprocessor : (Sign.sg -> Proofterm.proof -> Proofterm.proof) -> theory -> theory
    11   val add_realizes_eqns_i : ((term * term) list * (term * term)) list -> theory -> theory
    12   val add_realizes_eqns : string list -> theory -> theory
    13   val add_typeof_eqns_i : ((term * term) list * (term * term)) list -> theory -> theory
    14   val add_typeof_eqns : string list -> theory -> theory
    15   val add_realizers_i : (string * (string list * term * Proofterm.proof)) list
    16     -> theory -> theory
    17   val add_realizers : (thm * (string list * string * string)) list
    18     -> theory -> theory
    19   val add_expand_thms : thm list -> theory -> theory
    20   val add_types : (xstring * ((term -> term option) list *
    21     (term -> typ -> term -> typ -> term) option)) list -> theory -> theory
    22   val extract : (thm * string list) list -> theory -> theory
    23   val nullT : typ
    24   val nullt : term
    25   val mk_typ : typ -> term
    26   val etype_of : theory -> string list -> typ list -> term -> typ
    27   val realizes_of: theory -> string list -> term -> term -> term
    28 end;
    29 
    30 structure Extraction : EXTRACTION =
    31 struct
    32 
    33 open Proofterm;
    34 
    35 (**** tools ****)
    36 
    37 fun add_syntax thy =
    38   thy
    39   |> Theory.copy
    40   |> Theory.root_path
    41   |> Theory.add_types [("Type", 0, NoSyn), ("Null", 0, NoSyn)]
    42   |> Theory.add_consts
    43       [("typeof", "'b::{} => Type", NoSyn),
    44        ("Type", "'a::{} itself => Type", NoSyn),
    45        ("Null", "Null", NoSyn),
    46        ("realizes", "'a::{} => 'b::{} => 'b", NoSyn)];
    47 
    48 val nullT = Type ("Null", []);
    49 val nullt = Const ("Null", nullT);
    50 
    51 fun mk_typ T =
    52   Const ("Type", itselfT T --> Type ("Type", [])) $ Logic.mk_type T;
    53 
    54 fun typeof_proc defaultS vs (Const ("typeof", _) $ u) =
    55       SOME (mk_typ (case strip_comb u of
    56           (Var ((a, i), _), _) =>
    57             if a mem vs then TFree ("'" ^ a ^ ":" ^ string_of_int i, defaultS)
    58             else nullT
    59         | (Free (a, _), _) =>
    60             if a mem vs then TFree ("'" ^ a, defaultS) else nullT
    61         | _ => nullT))
    62   | typeof_proc _ _ _ = NONE;
    63 
    64 fun rlz_proc (Const ("realizes", Type (_, [Type ("Null", []), _])) $ r $ t) = SOME t
    65   | rlz_proc (Const ("realizes", Type (_, [T, _])) $ r $ t) =
    66       (case strip_comb t of
    67          (Var (ixn, U), ts) => SOME (list_comb (Var (ixn, T --> U), r :: ts))
    68        | (Free (s, U), ts) => SOME (list_comb (Free (s, T --> U), r :: ts))
    69        | _ => NONE)
    70   | rlz_proc _ = NONE;
    71 
    72 val unpack_ixn = apfst implode o apsnd (fst o read_int o tl) o
    73   take_prefix (not o equal ":") o explode;
    74 
    75 type rules =
    76   {next: int, rs: ((term * term) list * (term * term)) list,
    77    net: (int * ((term * term) list * (term * term))) Net.net};
    78 
    79 val empty_rules : rules = {next = 0, rs = [], net = Net.empty};
    80 
    81 fun add_rule (r as (_, (lhs, _)), {next, rs, net} : rules) =
    82   {next = next - 1, rs = r :: rs, net = Net.insert_term
    83      ((Pattern.eta_contract lhs, (next, r)), net, K false)};
    84 
    85 fun merge_rules
    86   ({next, rs = rs1, net} : rules) ({next = next2, rs = rs2, ...} : rules) =
    87   foldr add_rule {next = next, rs = rs1, net = net} (rs2 \\ rs1);
    88 
    89 fun condrew sign rules procs =
    90   let
    91     val tsig = Sign.tsig_of sign;
    92 
    93     fun rew tm =
    94       Pattern.rewrite_term tsig [] (condrew' :: procs) tm
    95     and condrew' tm =
    96       let
    97         val cache = ref ([] : (term * term) list);
    98         fun lookup f x = (case assoc (!cache, x) of
    99             NONE =>
   100               let val y = f x
   101               in (cache := (x, y) :: !cache; y) end
   102           | SOME y => y);
   103       in
   104         get_first (fn (_, (prems, (tm1, tm2))) =>
   105         let
   106           fun ren t = getOpt (Term.rename_abs tm1 tm t, t);
   107           val inc = Logic.incr_indexes ([], maxidx_of_term tm + 1);
   108           val env as (Tenv, tenv) = Pattern.match tsig (inc tm1, tm);
   109           val prems' = map (pairself (Envir.subst_vars env o inc o ren)) prems;
   110           val env' = Envir.Envir
   111             {maxidx = Library.foldl Int.max
   112               (~1, map (Int.max o pairself maxidx_of_term) prems'),
   113              iTs = Tenv, asol = tenv};
   114           val env'' = Library.foldl (fn (env, p) =>
   115             Pattern.unify (sign, env, [pairself (lookup rew) p])) (env', prems')
   116         in SOME (Envir.norm_term env'' (inc (ren tm2)))
   117         end handle Pattern.MATCH => NONE | Pattern.Unif => NONE)
   118           (sort (Int.compare o pairself fst)
   119             (Net.match_term rules (Pattern.eta_contract tm)))
   120       end;
   121 
   122   in rew end;
   123 
   124 val chtype = change_type o SOME;
   125 
   126 fun add_prefix a b = NameSpace.pack (a :: NameSpace.unpack b);
   127 
   128 fun corr_name s vs =
   129   add_prefix "extr" (space_implode "_" (s :: vs)) ^ "_correctness";
   130 
   131 fun extr_name s vs = add_prefix "extr" (space_implode "_" (s :: vs));
   132 
   133 fun msg d s = priority (implode (replicate d " ") ^ s);
   134 
   135 fun vars_of t = rev (foldl_aterms
   136   (fn (vs, v as Var _) => v ins vs | (vs, _) => vs) ([], t));
   137 
   138 fun vfs_of t = vars_of t @ sort (make_ord atless) (term_frees t);
   139 
   140 fun forall_intr (t, prop) =
   141   let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
   142   in all T $ Abs (a, T, abstract_over (t, prop)) end;
   143 
   144 fun forall_intr_prf (t, prf) =
   145   let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
   146   in Abst (a, SOME T, prf_abstract_over t prf) end;
   147 
   148 val mkabs = foldr (fn (v, t) => Abs ("x", fastype_of v, abstract_over (v, t)));
   149 
   150 fun strip_abs 0 t = t
   151   | strip_abs n (Abs (_, _, t)) = strip_abs (n-1) t
   152   | strip_abs _ _ = error "strip_abs: not an abstraction";
   153 
   154 fun prf_subst_TVars tye =
   155   map_proof_terms (subst_TVars tye) (typ_subst_TVars tye);
   156 
   157 fun relevant_vars types prop = foldr (fn
   158       (Var ((a, i), T), vs) => (case strip_type T of
   159         (_, Type (s, _)) => if s mem types then a :: vs else vs
   160       | _ => vs)
   161     | (_, vs) => vs) [] (vars_of prop);
   162 
   163 fun tname_of (Type (s, _)) = s
   164   | tname_of _ = "";
   165 
   166 fun get_var_type t =
   167   let
   168     val vs = Term.add_vars ([], t);
   169     val fs = Term.add_frees ([], t)
   170   in fn 
   171       Var (ixn, _) => (case assoc (Term.add_vars ([], t), ixn) of
   172           NONE => error "get_var_type: no such variable in term"
   173         | SOME T => Var (ixn, T))
   174     | Free (s, _) => (case assoc (Term.add_frees ([], t), s) of
   175           NONE => error "get_var_type: no such variable in term"
   176         | SOME T => Free (s, T))
   177     | _ => error "get_var_type: not a variable"
   178   end;
   179 
   180 
   181 (**** theory data ****)
   182 
   183 (* data kind 'Pure/extraction' *)
   184 
   185 structure ExtractionArgs =
   186 struct
   187   val name = "Pure/extraction";
   188   type T =
   189     {realizes_eqns : rules,
   190      typeof_eqns : rules,
   191      types : (string * ((term -> term option) list *
   192        (term -> typ -> term -> typ -> term) option)) list,
   193      realizers : (string list * (term * proof)) list Symtab.table,
   194      defs : thm list,
   195      expand : (string * term) list,
   196      prep : (Sign.sg -> proof -> proof) option}
   197 
   198   val empty =
   199     {realizes_eqns = empty_rules,
   200      typeof_eqns = empty_rules,
   201      types = [],
   202      realizers = Symtab.empty,
   203      defs = [],
   204      expand = [],
   205      prep = NONE};
   206   val copy = I;
   207   val prep_ext = I;
   208 
   209   fun merge
   210     (({realizes_eqns = realizes_eqns1, typeof_eqns = typeof_eqns1, types = types1,
   211        realizers = realizers1, defs = defs1, expand = expand1, prep = prep1},
   212       {realizes_eqns = realizes_eqns2, typeof_eqns = typeof_eqns2, types = types2,
   213        realizers = realizers2, defs = defs2, expand = expand2, prep = prep2}) : T * T) =
   214     {realizes_eqns = merge_rules realizes_eqns1 realizes_eqns2,
   215      typeof_eqns = merge_rules typeof_eqns1 typeof_eqns2,
   216      types = merge_alists types1 types2,
   217      realizers = Symtab.merge_multi' (eq_set o pairself #1)
   218        (realizers1, realizers2),
   219      defs = gen_merge_lists eq_thm defs1 defs2,
   220      expand = merge_lists expand1 expand2,
   221      prep = (case prep1 of NONE => prep2 | _ => prep1)};
   222 
   223   fun print sg (x : T) = ();
   224 end;
   225 
   226 structure ExtractionData = TheoryDataFun(ExtractionArgs);
   227 val _ = Context.add_setup [ExtractionData.init];
   228 
   229 fun read_condeq thy =
   230   let val sg = sign_of (add_syntax thy)
   231   in fn s =>
   232     let val t = Logic.varify (term_of (read_cterm sg (s, propT)))
   233     in (map Logic.dest_equals (Logic.strip_imp_prems t),
   234       Logic.dest_equals (Logic.strip_imp_concl t))
   235     end handle TERM _ => error ("Not a (conditional) meta equality:\n" ^ s)
   236   end;
   237 
   238 (** preprocessor **)
   239 
   240 fun set_preprocessor prep thy =
   241   let val {realizes_eqns, typeof_eqns, types, realizers,
   242     defs, expand, ...} = ExtractionData.get thy
   243   in
   244     ExtractionData.put
   245       {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
   246        realizers = realizers, defs = defs, expand = expand, prep = SOME prep} thy
   247   end;
   248 
   249 (** equations characterizing realizability **)
   250 
   251 fun gen_add_realizes_eqns prep_eq eqns thy =
   252   let val {realizes_eqns, typeof_eqns, types, realizers,
   253     defs, expand, prep} = ExtractionData.get thy;
   254   in
   255     ExtractionData.put
   256       {realizes_eqns = foldr add_rule realizes_eqns (map (prep_eq thy) eqns),
   257        typeof_eqns = typeof_eqns, types = types, realizers = realizers,
   258        defs = defs, expand = expand, prep = prep} thy
   259   end
   260 
   261 val add_realizes_eqns_i = gen_add_realizes_eqns (K I);
   262 val add_realizes_eqns = gen_add_realizes_eqns read_condeq;
   263 
   264 (** equations characterizing type of extracted program **)
   265 
   266 fun gen_add_typeof_eqns prep_eq eqns thy =
   267   let
   268     val {realizes_eqns, typeof_eqns, types, realizers,
   269       defs, expand, prep} = ExtractionData.get thy;
   270     val eqns' = map (prep_eq thy) eqns
   271   in
   272     ExtractionData.put
   273       {realizes_eqns = realizes_eqns, realizers = realizers,
   274        typeof_eqns = foldr add_rule typeof_eqns eqns',
   275        types = types, defs = defs, expand = expand, prep = prep} thy
   276   end
   277 
   278 val add_typeof_eqns_i = gen_add_typeof_eqns (K I);
   279 val add_typeof_eqns = gen_add_typeof_eqns read_condeq;
   280 
   281 fun thaw (T as TFree (a, S)) =
   282       if ":" mem explode a then TVar (unpack_ixn a, S) else T
   283   | thaw (Type (a, Ts)) = Type (a, map thaw Ts)
   284   | thaw T = T;
   285 
   286 fun freeze (TVar ((a, i), S)) = TFree (a ^ ":" ^ string_of_int i, S)
   287   | freeze (Type (a, Ts)) = Type (a, map freeze Ts)
   288   | freeze T = T;
   289 
   290 fun freeze_thaw f x =
   291   map_term_types thaw (f (map_term_types freeze x));
   292 
   293 fun etype_of sg vs Ts t =
   294   let
   295     val {typeof_eqns, ...} = ExtractionData.get_sg sg;
   296     fun err () = error ("Unable to determine type of extracted program for\n" ^
   297       Sign.string_of_term sg t)
   298   in case strip_abs_body (freeze_thaw (condrew sg (#net typeof_eqns)
   299     [typeof_proc (Sign.defaultS sg) vs]) (list_abs (map (pair "x") (rev Ts),
   300       Const ("typeof", fastype_of1 (Ts, t) --> Type ("Type", [])) $ t))) of
   301       Const ("Type", _) $ u => (Logic.dest_type u handle TERM _ => err ())
   302     | _ => err ()
   303   end;
   304 
   305 (** realizers for axioms / theorems, together with correctness proofs **)
   306 
   307 fun gen_add_realizers prep_rlz rs thy =
   308   let val {realizes_eqns, typeof_eqns, types, realizers,
   309     defs, expand, prep} = ExtractionData.get thy
   310   in
   311     ExtractionData.put
   312       {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
   313        realizers = foldr Symtab.update_multi
   314          realizers (map (prep_rlz thy) (rev rs)),
   315        defs = defs, expand = expand, prep = prep} thy
   316   end
   317 
   318 fun prep_realizer thy =
   319   let
   320     val {realizes_eqns, typeof_eqns, defs, types, ...} =
   321       ExtractionData.get thy;
   322     val procs = List.concat (map (fst o snd) types);
   323     val rtypes = map fst types;
   324     val eqns = Net.merge (#net realizes_eqns, #net typeof_eqns, K false);
   325     val thy' = add_syntax thy;
   326     val sign = sign_of thy';
   327     val tsg = Sign.tsig_of sign;
   328     val rd = ProofSyntax.read_proof thy' false
   329   in fn (thm, (vs, s1, s2)) =>
   330     let
   331       val name = Thm.name_of_thm thm;
   332       val _ = assert (name <> "") "add_realizers: unnamed theorem";
   333       val prop = Pattern.rewrite_term tsg
   334         (map (Logic.dest_equals o prop_of) defs) [] (prop_of thm);
   335       val vars = vars_of prop;
   336       val vars' = filter_out (fn v =>
   337         tname_of (body_type (fastype_of v)) mem rtypes) vars;
   338       val T = etype_of sign vs [] prop;
   339       val (T', thw) = Type.freeze_thaw_type
   340         (if T = nullT then nullT else map fastype_of vars' ---> T);
   341       val t = map_term_types thw (term_of (read_cterm sign (s1, T')));
   342       val r' = freeze_thaw (condrew sign eqns
   343         (procs @ [typeof_proc (Sign.defaultS sign) vs, rlz_proc]))
   344           (Const ("realizes", T --> propT --> propT) $
   345             (if T = nullT then t else list_comb (t, vars')) $ prop);
   346       val r = foldr forall_intr r' (map (get_var_type r') vars);
   347       val prf = Reconstruct.reconstruct_proof sign r (rd s2);
   348     in (name, (vs, (t, prf))) end
   349   end;
   350 
   351 val add_realizers_i = gen_add_realizers
   352   (fn _ => fn (name, (vs, t, prf)) => (name, (vs, (t, prf))));
   353 val add_realizers = gen_add_realizers prep_realizer;
   354 
   355 fun realizes_of thy vs t prop =
   356   let
   357     val thy' = add_syntax thy;
   358     val sign = sign_of thy';
   359     val {realizes_eqns, typeof_eqns, defs, types, ...} =
   360       ExtractionData.get thy';
   361     val procs = List.concat (map (fst o snd) types);
   362     val eqns = Net.merge (#net realizes_eqns, #net typeof_eqns, K false);
   363     val prop' = Pattern.rewrite_term (Sign.tsig_of sign)
   364       (map (Logic.dest_equals o prop_of) defs) [] prop;
   365   in freeze_thaw (condrew sign eqns
   366     (procs @ [typeof_proc (Sign.defaultS sign) vs, rlz_proc]))
   367       (Const ("realizes", fastype_of t --> propT --> propT) $ t $ prop')
   368   end;
   369 
   370 (** expanding theorems / definitions **)
   371 
   372 fun add_expand_thm (thy, thm) =
   373   let
   374     val {realizes_eqns, typeof_eqns, types, realizers,
   375       defs, expand, prep} = ExtractionData.get thy;
   376 
   377     val name = Thm.name_of_thm thm;
   378     val _ = assert (name <> "") "add_expand_thms: unnamed theorem";
   379 
   380     val is_def =
   381       (case strip_comb (fst (Logic.dest_equals (prop_of thm))) of
   382          (Const _, ts) => forall is_Var ts andalso null (duplicates ts)
   383            andalso exists (fn thy =>
   384                isSome (Symtab.lookup (#axioms (rep_theory thy), name)))
   385              (thy :: ancestors_of thy)
   386        | _ => false) handle TERM _ => false;
   387 
   388     val name = Thm.name_of_thm thm;
   389     val _ = assert (name <> "") "add_expand_thms: unnamed theorem";
   390   in
   391     (ExtractionData.put (if is_def then
   392         {realizes_eqns = realizes_eqns,
   393          typeof_eqns = add_rule (([],
   394            Logic.dest_equals (prop_of (Drule.abs_def thm))), typeof_eqns),
   395          types = types,
   396          realizers = realizers, defs = gen_ins eq_thm (thm, defs),
   397          expand = expand, prep = prep}
   398       else
   399         {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
   400          realizers = realizers, defs = defs,
   401          expand = (name, prop_of thm) ins expand, prep = prep}) thy, thm)
   402   end;
   403 
   404 fun add_expand_thms thms thy = Library.foldl (fst o add_expand_thm) (thy, thms);
   405 
   406 
   407 (** types with computational content **)
   408 
   409 fun add_types tys thy =
   410   let val {realizes_eqns, typeof_eqns, types, realizers,
   411     defs, expand, prep} = ExtractionData.get thy;
   412   in
   413     ExtractionData.put
   414       {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns,
   415        types = map (apfst (Sign.intern_tycon (sign_of thy))) tys @ types,
   416        realizers = realizers, defs = defs, expand = expand, prep = prep} thy
   417   end;
   418 
   419 
   420 (** Pure setup **)
   421 
   422 val _ = Context.add_setup
   423   [add_types [("prop", ([], NONE))],
   424 
   425    add_typeof_eqns
   426      ["(typeof (PROP P)) == (Type (TYPE(Null))) ==>  \
   427     \  (typeof (PROP Q)) == (Type (TYPE('Q))) ==>  \
   428     \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE('Q)))",
   429 
   430       "(typeof (PROP Q)) == (Type (TYPE(Null))) ==>  \
   431     \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE(Null)))",
   432 
   433       "(typeof (PROP P)) == (Type (TYPE('P))) ==>  \
   434     \  (typeof (PROP Q)) == (Type (TYPE('Q))) ==>  \
   435     \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE('P => 'Q)))",
   436 
   437       "(%x. typeof (PROP P (x))) == (%x. Type (TYPE(Null))) ==>  \
   438     \    (typeof (!!x. PROP P (x))) == (Type (TYPE(Null)))",
   439 
   440       "(%x. typeof (PROP P (x))) == (%x. Type (TYPE('P))) ==>  \
   441     \    (typeof (!!x::'a. PROP P (x))) == (Type (TYPE('a => 'P)))",
   442 
   443       "(%x. typeof (f (x))) == (%x. Type (TYPE('f))) ==>  \
   444     \    (typeof (f)) == (Type (TYPE('f)))"],
   445 
   446    add_realizes_eqns
   447      ["(typeof (PROP P)) == (Type (TYPE(Null))) ==>  \
   448     \    (realizes (r) (PROP P ==> PROP Q)) ==  \
   449     \    (PROP realizes (Null) (PROP P) ==> PROP realizes (r) (PROP Q))",
   450 
   451       "(typeof (PROP P)) == (Type (TYPE('P))) ==>  \
   452     \  (typeof (PROP Q)) == (Type (TYPE(Null))) ==>  \
   453     \    (realizes (r) (PROP P ==> PROP Q)) ==  \
   454     \    (!!x::'P. PROP realizes (x) (PROP P) ==> PROP realizes (Null) (PROP Q))",
   455 
   456       "(realizes (r) (PROP P ==> PROP Q)) ==  \
   457     \  (!!x. PROP realizes (x) (PROP P) ==> PROP realizes (r (x)) (PROP Q))",
   458 
   459       "(%x. typeof (PROP P (x))) == (%x. Type (TYPE(Null))) ==>  \
   460     \    (realizes (r) (!!x. PROP P (x))) ==  \
   461     \    (!!x. PROP realizes (Null) (PROP P (x)))",
   462 
   463       "(realizes (r) (!!x. PROP P (x))) ==  \
   464     \  (!!x. PROP realizes (r (x)) (PROP P (x)))"],
   465 
   466    Attrib.add_attributes
   467      [("extraction_expand",
   468        (Attrib.no_args add_expand_thm, K Attrib.undef_local_attribute),
   469        "specify theorems / definitions to be expanded during extraction")]];
   470 
   471 
   472 (**** extract program ****)
   473 
   474 val dummyt = Const ("dummy", dummyT);
   475 
   476 fun extract thms thy =
   477   let
   478     val sg = sign_of (add_syntax thy);
   479     val tsg = Sign.tsig_of sg;
   480     val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} =
   481       ExtractionData.get thy;
   482     val procs = List.concat (map (fst o snd) types);
   483     val rtypes = map fst types;
   484     val typroc = typeof_proc (Sign.defaultS sg);
   485     val prep = getOpt (prep, K I) sg o ProofRewriteRules.elim_defs sg false defs o
   486       Reconstruct.expand_proof sg (("", NONE) :: map (apsnd SOME) expand);
   487     val rrews = Net.merge (#net realizes_eqns, #net typeof_eqns, K false);
   488 
   489     fun find_inst prop Ts ts vs =
   490       let
   491         val rvs = relevant_vars rtypes prop;
   492         val vars = vars_of prop;
   493         val n = Int.min (length vars, length ts);
   494 
   495         fun add_args ((Var ((a, i), _), t), (vs', tye)) =
   496           if a mem rvs then
   497             let val T = etype_of sg vs Ts t
   498             in if T = nullT then (vs', tye)
   499                else (a :: vs', (("'" ^ a, i), T) :: tye)
   500             end
   501           else (vs', tye)
   502 
   503       in foldr add_args ([], []) (Library.take (n, vars) ~~ Library.take (n, ts)) end;
   504 
   505     fun find vs = Option.map snd o find_first (curry eq_set vs o fst);
   506     fun find' s = map snd o List.filter (equal s o fst)
   507 
   508     fun app_rlz_rews Ts vs t = strip_abs (length Ts) (freeze_thaw
   509       (condrew sg rrews (procs @ [typroc vs, rlz_proc])) (list_abs
   510         (map (pair "x") (rev Ts), t)));
   511 
   512     fun realizes_null vs prop = app_rlz_rews [] vs
   513       (Const ("realizes", nullT --> propT --> propT) $ nullt $ prop);
   514 
   515     fun corr d defs vs ts Ts hs (PBound i) _ _ = (defs, PBound i)
   516 
   517       | corr d defs vs ts Ts hs (Abst (s, SOME T, prf)) (Abst (_, _, prf')) t =
   518           let val (defs', corr_prf) = corr d defs vs [] (T :: Ts)
   519             (dummyt :: hs) prf (incr_pboundvars 1 0 prf')
   520             (case t of SOME (Abs (_, _, u)) => SOME u | _ => NONE)
   521           in (defs', Abst (s, SOME T, corr_prf)) end
   522 
   523       | corr d defs vs ts Ts hs (AbsP (s, SOME prop, prf)) (AbsP (_, _, prf')) t =
   524           let
   525             val T = etype_of sg vs Ts prop;
   526             val u = if T = nullT then 
   527                 (case t of SOME u => SOME (incr_boundvars 1 u) | NONE => NONE)
   528               else (case t of SOME (Abs (_, _, u)) => SOME u | _ => NONE);
   529             val (defs', corr_prf) = corr d defs vs [] (T :: Ts) (prop :: hs)
   530               (incr_pboundvars 0 1 prf) (incr_pboundvars 0 1 prf') u;
   531             val rlz = Const ("realizes", T --> propT --> propT)
   532           in (defs',
   533             if T = nullT then AbsP ("R",
   534               SOME (app_rlz_rews Ts vs (rlz $ nullt $ prop)),
   535                 prf_subst_bounds [nullt] corr_prf)
   536             else Abst (s, SOME T, AbsP ("R",
   537               SOME (app_rlz_rews (T :: Ts) vs
   538                 (rlz $ Bound 0 $ incr_boundvars 1 prop)), corr_prf)))
   539           end
   540 
   541       | corr d defs vs ts Ts hs (prf % SOME t) (prf' % _) t' =
   542           let
   543             val (Us, T) = strip_type (fastype_of1 (Ts, t));
   544             val (defs', corr_prf) = corr d defs vs (t :: ts) Ts hs prf prf'
   545               (if tname_of T mem rtypes then t'
   546                else (case t' of SOME (u $ _) => SOME u | _ => NONE));
   547             val u = if not (tname_of T mem rtypes) then t else
   548               let
   549                 val eT = etype_of sg vs Ts t;
   550                 val (r, Us') = if eT = nullT then (nullt, Us) else
   551                   (Bound (length Us), eT :: Us);
   552                 val u = list_comb (incr_boundvars (length Us') t,
   553                   map Bound (length Us - 1 downto 0));
   554                 val u' = (case assoc (types, tname_of T) of
   555                     SOME ((_, SOME f)) => f r eT u T
   556                   | _ => Const ("realizes", eT --> T --> T) $ r $ u)
   557               in app_rlz_rews Ts vs (list_abs (map (pair "x") Us', u')) end
   558           in (defs', corr_prf % SOME u) end
   559 
   560       | corr d defs vs ts Ts hs (prf1 %% prf2) (prf1' %% prf2') t =
   561           let
   562             val prop = Reconstruct.prop_of' hs prf2';
   563             val T = etype_of sg vs Ts prop;
   564             val (defs1, f, u) = if T = nullT then (defs, t, NONE) else
   565               (case t of
   566                  SOME (f $ u) => (defs, SOME f, SOME u)
   567                | _ =>
   568                  let val (defs1, u) = extr d defs vs [] Ts hs prf2'
   569                  in (defs1, NONE, SOME u) end)
   570             val (defs2, corr_prf1) = corr d defs1 vs [] Ts hs prf1 prf1' f;
   571             val (defs3, corr_prf2) = corr d defs2 vs [] Ts hs prf2 prf2' u;
   572           in
   573             if T = nullT then (defs3, corr_prf1 %% corr_prf2) else
   574               (defs3, corr_prf1 % u %% corr_prf2)
   575           end
   576 
   577       | corr d defs vs ts Ts hs (prf0 as PThm ((name, _), prf, prop, SOME Ts')) _ _ =
   578           let
   579             val (vs', tye) = find_inst prop Ts ts vs;
   580             val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye;
   581             val T = etype_of sg vs' [] prop;
   582             val defs' = if T = nullT then defs
   583               else fst (extr d defs vs ts Ts hs prf0)
   584           in
   585             if T = nullT andalso realizes_null vs' prop aconv prop then (defs, prf0)
   586             else case Symtab.lookup (realizers, name) of
   587               NONE => (case find vs' (find' name defs') of
   588                 NONE =>
   589                   let
   590                     val _ = assert (T = nullT) "corr: internal error";
   591                     val _ = msg d ("Building correctness proof for " ^ quote name ^
   592                       (if null vs' then ""
   593                        else " (relevant variables: " ^ commas_quote vs' ^ ")"));
   594                     val prf' = prep (Reconstruct.reconstruct_proof sg prop prf);
   595                     val (defs'', corr_prf) =
   596                       corr (d + 1) defs' vs' [] [] [] prf' prf' NONE;
   597                     val corr_prop = Reconstruct.prop_of corr_prf;
   598                     val corr_prf' = foldr forall_intr_prf
   599                       (proof_combt
   600                          (PThm ((corr_name name vs', []), corr_prf, corr_prop,
   601                              SOME (map TVar (term_tvars corr_prop))), vfs_of corr_prop))
   602 		      (map (get_var_type corr_prop) (vfs_of prop))
   603                   in
   604                     ((name, (vs', ((nullt, nullt), (corr_prf, corr_prf')))) :: defs'',
   605                      prf_subst_TVars tye' corr_prf')
   606                   end
   607               | SOME (_, (_, prf')) => (defs', prf_subst_TVars tye' prf'))
   608             | SOME rs => (case find vs' rs of
   609                 SOME (_, prf') => (defs', prf_subst_TVars tye' prf')
   610               | NONE => error ("corr: no realizer for instance of theorem " ^
   611                   quote name ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   612                     (Reconstruct.prop_of (proof_combt (prf0, ts))))))
   613           end
   614 
   615       | corr d defs vs ts Ts hs (prf0 as PAxm (s, prop, SOME Ts')) _ _ =
   616           let
   617             val (vs', tye) = find_inst prop Ts ts vs;
   618             val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye
   619           in
   620             if etype_of sg vs' [] prop = nullT andalso
   621               realizes_null vs' prop aconv prop then (defs, prf0)
   622             else case find vs' (Symtab.lookup_multi (realizers, s)) of
   623               SOME (_, prf) => (defs, prf_subst_TVars tye' prf)
   624             | NONE => error ("corr: no realizer for instance of axiom " ^
   625                 quote s ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   626                   (Reconstruct.prop_of (proof_combt (prf0, ts)))))
   627           end
   628 
   629       | corr d defs vs ts Ts hs _ _ _ = error "corr: bad proof"
   630 
   631     and extr d defs vs ts Ts hs (PBound i) = (defs, Bound i)
   632 
   633       | extr d defs vs ts Ts hs (Abst (s, SOME T, prf)) =
   634           let val (defs', t) = extr d defs vs []
   635             (T :: Ts) (dummyt :: hs) (incr_pboundvars 1 0 prf)
   636           in (defs', Abs (s, T, t)) end
   637 
   638       | extr d defs vs ts Ts hs (AbsP (s, SOME t, prf)) =
   639           let
   640             val T = etype_of sg vs Ts t;
   641             val (defs', t) = extr d defs vs [] (T :: Ts) (t :: hs)
   642               (incr_pboundvars 0 1 prf)
   643           in (defs',
   644             if T = nullT then subst_bound (nullt, t) else Abs (s, T, t))
   645           end
   646 
   647       | extr d defs vs ts Ts hs (prf % SOME t) =
   648           let val (defs', u) = extr d defs vs (t :: ts) Ts hs prf
   649           in (defs',
   650             if tname_of (body_type (fastype_of1 (Ts, t))) mem rtypes then u
   651             else u $ t)
   652           end
   653 
   654       | extr d defs vs ts Ts hs (prf1 %% prf2) =
   655           let
   656             val (defs', f) = extr d defs vs [] Ts hs prf1;
   657             val prop = Reconstruct.prop_of' hs prf2;
   658             val T = etype_of sg vs Ts prop
   659           in
   660             if T = nullT then (defs', f) else
   661               let val (defs'', t) = extr d defs' vs [] Ts hs prf2
   662               in (defs'', f $ t) end
   663           end
   664 
   665       | extr d defs vs ts Ts hs (prf0 as PThm ((s, _), prf, prop, SOME Ts')) =
   666           let
   667             val (vs', tye) = find_inst prop Ts ts vs;
   668             val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye
   669           in
   670             case Symtab.lookup (realizers, s) of
   671               NONE => (case find vs' (find' s defs) of
   672                 NONE =>
   673                   let
   674                     val _ = msg d ("Extracting " ^ quote s ^
   675                       (if null vs' then ""
   676                        else " (relevant variables: " ^ commas_quote vs' ^ ")"));
   677                     val prf' = prep (Reconstruct.reconstruct_proof sg prop prf);
   678                     val (defs', t) = extr (d + 1) defs vs' [] [] [] prf';
   679                     val (defs'', corr_prf) =
   680                       corr (d + 1) defs' vs' [] [] [] prf' prf' (SOME t);
   681 
   682                     val nt = Envir.beta_norm t;
   683                     val args = filter_out (fn v => tname_of (body_type
   684                       (fastype_of v)) mem rtypes) (vfs_of prop);
   685                     val args' = List.filter (fn v => Logic.occs (v, nt)) args;
   686                     val t' = mkabs nt args';
   687                     val T = fastype_of t';
   688                     val cname = extr_name s vs';
   689                     val c = Const (cname, T);
   690                     val u = mkabs (list_comb (c, args')) args;
   691                     val eqn = Logic.mk_equals (c, t');
   692                     val rlz =
   693                       Const ("realizes", fastype_of nt --> propT --> propT);
   694                     val lhs = app_rlz_rews [] vs' (rlz $ nt $ prop);
   695                     val rhs = app_rlz_rews [] vs' (rlz $ list_comb (c, args') $ prop);
   696                     val f = app_rlz_rews [] vs'
   697                       (Abs ("x", T, rlz $ list_comb (Bound 0, args') $ prop));
   698 
   699                     val corr_prf' =
   700                       chtype [] equal_elim_axm %> lhs %> rhs %%
   701                        (chtype [propT] symmetric_axm %> rhs %> lhs %%
   702                          (chtype [propT, T] combination_axm %> f %> f %> c %> t' %%
   703                            (chtype [T --> propT] reflexive_axm %> f) %%
   704                            PAxm (cname ^ "_def", eqn,
   705                              SOME (map TVar (term_tvars eqn))))) %% corr_prf;
   706                     val corr_prop = Reconstruct.prop_of corr_prf';
   707                     val corr_prf'' = foldr forall_intr_prf
   708                       (proof_combt
   709                         (PThm ((corr_name s vs', []), corr_prf', corr_prop,
   710                           SOME (map TVar (term_tvars corr_prop))),  vfs_of corr_prop))
   711 		      (map (get_var_type corr_prop) (vfs_of prop));
   712                   in
   713                     ((s, (vs', ((t', u), (corr_prf', corr_prf'')))) :: defs'',
   714                      subst_TVars tye' u)
   715                   end
   716               | SOME ((_, u), _) => (defs, subst_TVars tye' u))
   717             | SOME rs => (case find vs' rs of
   718                 SOME (t, _) => (defs, subst_TVars tye' t)
   719               | NONE => error ("extr: no realizer for instance of theorem " ^
   720                   quote s ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   721                     (Reconstruct.prop_of (proof_combt (prf0, ts))))))
   722           end
   723 
   724       | extr d defs vs ts Ts hs (prf0 as PAxm (s, prop, SOME Ts')) =
   725           let
   726             val (vs', tye) = find_inst prop Ts ts vs;
   727             val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye
   728           in
   729             case find vs' (Symtab.lookup_multi (realizers, s)) of
   730               SOME (t, _) => (defs, subst_TVars tye' t)
   731             | NONE => error ("extr: no realizer for instance of axiom " ^
   732                 quote s ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   733                   (Reconstruct.prop_of (proof_combt (prf0, ts)))))
   734           end
   735 
   736       | extr d defs vs ts Ts hs _ = error "extr: bad proof";
   737 
   738     fun prep_thm (thm, vs) =
   739       let
   740         val {prop, der = (_, prf), sign, ...} = rep_thm thm;
   741         val name = Thm.name_of_thm thm;
   742         val _ = assert (name <> "") "extraction: unnamed theorem";
   743         val _ = assert (etype_of sg vs [] prop <> nullT) ("theorem " ^
   744           quote name ^ " has no computational content")
   745       in (Reconstruct.reconstruct_proof sign prop prf, vs) end;
   746 
   747     val defs = Library.foldl (fn (defs, (prf, vs)) =>
   748       fst (extr 0 defs vs [] [] [] prf)) ([], map prep_thm thms);
   749 
   750     fun add_def (s, (vs, ((t, u), (prf, _)))) thy =
   751       (case Sign.const_type (sign_of thy) (extr_name s vs) of
   752          NONE =>
   753            let
   754              val corr_prop = Reconstruct.prop_of prf;
   755              val ft = fst (Type.freeze_thaw t);
   756              val fu = fst (Type.freeze_thaw u);
   757              val thy' = if t = nullt then thy else thy |>
   758                Theory.add_consts_i [(extr_name s vs, fastype_of ft, NoSyn)] |>
   759                fst o PureThy.add_defs_i false [((extr_name s vs ^ "_def",
   760                  Logic.mk_equals (head_of (strip_abs_body fu), ft)), [])];
   761            in
   762              fst (PureThy.store_thm ((corr_name s vs,
   763                Thm.varifyT (funpow (length (term_vars corr_prop))
   764                  (forall_elim_var 0) (forall_intr_frees
   765                    (ProofChecker.thm_of_proof thy'
   766                      (fst (Proofterm.freeze_thaw_prf prf)))))), []) thy')
   767            end
   768        | SOME _ => thy);
   769 
   770   in
   771     thy
   772     |> Theory.absolute_path
   773     |> fold_rev add_def defs
   774     |> Theory.restore_naming thy
   775   end;
   776 
   777 
   778 (**** interface ****)
   779 
   780 structure P = OuterParse and K = OuterSyntax.Keyword;
   781 
   782 val parse_vars = Scan.optional (P.$$$ "(" |-- P.list1 P.name --| P.$$$ ")") [];
   783 
   784 val realizersP =
   785   OuterSyntax.command "realizers"
   786   "specify realizers for primitive axioms / theorems, together with correctness proof"
   787   K.thy_decl
   788     (Scan.repeat1 (P.xname -- parse_vars --| P.$$$ ":" -- P.string -- P.string) >>
   789      (fn xs => Toplevel.theory (fn thy => add_realizers
   790        (map (fn (((a, vs), s1), s2) =>
   791          (PureThy.get_thm thy (a, NONE), (vs, s1, s2))) xs) thy)));
   792 
   793 val realizabilityP =
   794   OuterSyntax.command "realizability"
   795   "add equations characterizing realizability" K.thy_decl
   796   (Scan.repeat1 P.string >> (Toplevel.theory o add_realizes_eqns));
   797 
   798 val typeofP =
   799   OuterSyntax.command "extract_type"
   800   "add equations characterizing type of extracted program" K.thy_decl
   801   (Scan.repeat1 P.string >> (Toplevel.theory o add_typeof_eqns));
   802 
   803 val extractP =
   804   OuterSyntax.command "extract" "extract terms from proofs" K.thy_decl
   805     (Scan.repeat1 (P.xname -- parse_vars) >> (fn xs => Toplevel.theory
   806       (fn thy => extract (map (apfst (PureThy.get_thm thy o rpair NONE)) xs) thy)));
   807 
   808 val _ = OuterSyntax.add_parsers [realizersP, realizabilityP, typeofP, extractP];
   809 
   810 val etype_of = etype_of o sign_of o add_syntax;
   811 
   812 end;