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