Added program extraction module.
authorberghofe
Sun Jul 21 15:37:04 2002 +0200 (2002-07-21)
changeset 13402e6e826bb8c3c
parent 13401 ea1b3afb147e
child 13403 bc2b32ee62fd
Added program extraction module.
src/Pure/IsaMakefile
src/Pure/Proof/extraction.ML
src/Pure/ROOT.ML
src/Pure/pure.ML
     1.1 --- a/src/Pure/IsaMakefile	Fri Jul 19 18:44:37 2002 +0200
     1.2 +++ b/src/Pure/IsaMakefile	Sun Jul 21 15:37:04 2002 +0200
     1.3 @@ -40,7 +40,8 @@
     1.4    Isar/thy_header.ML Isar/toplevel.ML ML-Systems/mlworks.ML		\
     1.5    ML-Systems/polyml-3.x.ML ML-Systems/polyml.ML				\
     1.6    ML-Systems/smlnj-0.93.ML ML-Systems/smlnj-compiler.ML			\
     1.7 -  ML-Systems/smlnj.ML Proof/ROOT.ML Proof/proof_rewrite_rules.ML	\
     1.8 +  ML-Systems/smlnj.ML Proof/ROOT.ML Proof/extraction.ML			\
     1.9 +  Proof/proof_rewrite_rules.ML						\
    1.10    Proof/proof_syntax.ML Proof/proofchecker.ML Proof/reconstruct.ML	\
    1.11    ROOT.ML Syntax/ROOT.ML Syntax/ast.ML Syntax/lexicon.ML		\
    1.12    Syntax/mixfix.ML Syntax/parser.ML Syntax/printer.ML			\
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/Pure/Proof/extraction.ML	Sun Jul 21 15:37:04 2002 +0200
     2.3 @@ -0,0 +1,714 @@
     2.4 +(*  Title:      Pure/Proof/extraction.ML
     2.5 +    ID:         $Id$
     2.6 +    Author:     Stefan Berghofer, TU Muenchen
     2.7 +    License:    GPL (GNU GENERAL PUBLIC LICENSE)
     2.8 +
     2.9 +Extraction of programs from proofs.
    2.10 +*)
    2.11 +
    2.12 +signature EXTRACTION =
    2.13 +sig
    2.14 +  val set_preprocessor : (Sign.sg -> Proofterm.proof -> Proofterm.proof) -> theory -> theory
    2.15 +  val add_realizes_eqns_i : ((term * term) list * (term * term)) list -> theory -> theory
    2.16 +  val add_realizes_eqns : string list -> theory -> theory
    2.17 +  val add_typeof_eqns_i : ((term * term) list * (term * term)) list -> theory -> theory
    2.18 +  val add_typeof_eqns : string list -> theory -> theory
    2.19 +  val add_realizers_i : (string * (string list * term * Proofterm.proof)) list
    2.20 +    -> theory -> theory
    2.21 +  val add_realizers : (thm * (string list * string * string)) list
    2.22 +    -> theory -> theory
    2.23 +  val add_expand_thms : thm list -> theory -> theory
    2.24 +  val extract : thm list -> theory -> theory
    2.25 +  val nullT : typ
    2.26 +  val nullt : term
    2.27 +  val parsers: OuterSyntax.parser list
    2.28 +  val setup: (theory -> theory) list
    2.29 +end;
    2.30 +
    2.31 +structure Extraction : EXTRACTION =
    2.32 +struct
    2.33 +
    2.34 +open Proofterm;
    2.35 +
    2.36 +(**** tools ****)
    2.37 +
    2.38 +fun add_syntax thy =
    2.39 +  thy
    2.40 +  |> Theory.copy
    2.41 +  |> Theory.root_path
    2.42 +  |> Theory.add_types [("Type", 0, NoSyn), ("Null", 0, NoSyn)]
    2.43 +  |> Theory.add_arities [("Type", [], "logic"), ("Null", [], "logic")]
    2.44 +  |> Theory.add_consts
    2.45 +      [("typeof", "'b::logic => Type", NoSyn),
    2.46 +       ("Type", "'a::logic itself => Type", NoSyn),
    2.47 +       ("Null", "Null", NoSyn),
    2.48 +       ("realizes", "'a::logic => 'b::logic => 'b", NoSyn)];
    2.49 +
    2.50 +val nullT = Type ("Null", []);
    2.51 +val nullt = Const ("Null", nullT);
    2.52 +
    2.53 +fun mk_typ T =
    2.54 +  Const ("Type", itselfT T --> Type ("Type", [])) $ Logic.mk_type T;
    2.55 +
    2.56 +fun typeof_proc defaultS vs (Const ("typeof", _) $ u) =
    2.57 +      Some (mk_typ (case strip_comb u of
    2.58 +          (Var ((a, i), _), _) =>
    2.59 +            if a mem vs then TFree ("'" ^ a ^ ":" ^ string_of_int i, defaultS)
    2.60 +            else nullT
    2.61 +        | (Free (a, _), _) =>
    2.62 +            if a mem vs then TFree ("'" ^ a, defaultS) else nullT
    2.63 +        | _ => nullT))
    2.64 +  | typeof_proc _ _ _ = None;
    2.65 +
    2.66 +fun rlz_proc (Const ("realizes", Type (_, [Type ("Null", []), _])) $ _ $ t) =
    2.67 +  (case strip_comb t of (Const _, _) => Some t | _ => None)
    2.68 +  | rlz_proc _ = None;
    2.69 +
    2.70 +fun rlz_proc' (Const ("realizes", _) $ _ $ t) = Some t
    2.71 +  | rlz_proc' _ = None;
    2.72 +
    2.73 +val unpack_ixn = apfst implode o apsnd (fst o read_int o tl) o
    2.74 +  take_prefix (not o equal ":") o explode;
    2.75 +
    2.76 +type rules =
    2.77 +  {next: int, rs: ((term * term) list * (term * term)) list,
    2.78 +   net: (int * ((term * term) list * (term * term))) Net.net};
    2.79 +
    2.80 +val empty_rules : rules = {next = 0, rs = [], net = Net.empty};
    2.81 +
    2.82 +fun add_rule (r as (_, (lhs, _)), {next, rs, net} : rules) =
    2.83 +  {next = next - 1, rs = r :: rs, net = Net.insert_term
    2.84 +     ((Pattern.eta_contract lhs, (next, r)), net, K false)};
    2.85 +
    2.86 +fun (merge_rules : rules -> rules -> rules)
    2.87 +  {next, rs = rs1, net} {next = next2, rs = rs2, ...} =
    2.88 +  foldr add_rule (rs2 \\ rs1, {next = next, rs = rs1, net = net});
    2.89 +
    2.90 +fun condrew sign rules procs =
    2.91 +  let
    2.92 +    val tsig = Sign.tsig_of sign;
    2.93 +
    2.94 +    fun rew tm =
    2.95 +      Pattern.rewrite_term tsig [] (condrew' :: procs) tm
    2.96 +    and condrew' tm = get_first (fn (_, (prems, (tm1, tm2))) =>
    2.97 +      let
    2.98 +        fun ren t = if_none (Term.rename_abs tm1 tm t) t;
    2.99 +        val inc = Logic.incr_indexes ([], maxidx_of_term tm + 1);
   2.100 +        val env as (Tenv, tenv) = Pattern.match tsig (inc tm1, tm);
   2.101 +        val prems' = map (pairself (rew o subst_vars env o inc o ren)) prems;
   2.102 +        val env' = Envir.Envir
   2.103 +          {maxidx = foldl Int.max
   2.104 +            (~1, map (Int.max o pairself maxidx_of_term) prems'),
   2.105 +           iTs = Vartab.make Tenv, asol = Vartab.make tenv}
   2.106 +      in Some (Envir.norm_term
   2.107 +        (Pattern.unify (sign, env', prems')) (inc (ren tm2)))
   2.108 +      end handle Pattern.MATCH => None | Pattern.Unif => None)
   2.109 +        (sort (int_ord o pairself fst)
   2.110 +          (Net.match_term rules (Pattern.eta_contract tm)));
   2.111 +
   2.112 +  in rew end;
   2.113 +
   2.114 +val chtype = change_type o Some;
   2.115 +
   2.116 +fun add_prefix a b = NameSpace.pack (a :: NameSpace.unpack b);
   2.117 +
   2.118 +fun msg d s = priority (implode (replicate d " ") ^ s);
   2.119 +
   2.120 +fun vars_of t = rev (foldl_aterms
   2.121 +  (fn (vs, v as Var _) => v ins vs | (vs, _) => vs) ([], t));
   2.122 +
   2.123 +fun vfs_of t = vars_of t @ sort (make_ord atless) (term_frees t);
   2.124 +
   2.125 +fun forall_intr (t, prop) =
   2.126 +  let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
   2.127 +  in all T $ Abs (a, T, abstract_over (t, prop)) end;
   2.128 +
   2.129 +fun forall_intr_prf (t, prf) =
   2.130 +  let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
   2.131 +  in Abst (a, Some T, prf_abstract_over t prf) end;
   2.132 +
   2.133 +val mkabs = foldr (fn (v, t) => Abs ("x", fastype_of v, abstract_over (v, t)));
   2.134 +
   2.135 +fun prf_subst_TVars tye =
   2.136 +  map_proof_terms (subst_TVars tye) (typ_subst_TVars tye);
   2.137 +
   2.138 +fun add_types (Const ("typeof", Type (_, [T, _])), xs) =
   2.139 +      (case strip_type T of (_, Type (s, _)) => s ins xs | _ => xs)
   2.140 +  | add_types (t $ u, xs) = add_types (t, add_types (u, xs))
   2.141 +  | add_types (Abs (_, _, t), xs) = add_types (t, xs)
   2.142 +  | add_types (_, xs) = xs;
   2.143 +
   2.144 +fun relevant_vars types prop = foldr (fn
   2.145 +      (Var ((a, i), T), vs) => (case strip_type T of
   2.146 +        (_, Type (s, _)) => if s mem types then a :: vs else vs
   2.147 +      | _ => vs)
   2.148 +    | (_, vs) => vs) (vars_of prop, []);
   2.149 +
   2.150 +
   2.151 +(**** theory data ****)
   2.152 +
   2.153 +(* data kind 'Pure/extraction' *)
   2.154 +
   2.155 +structure ExtractionArgs =
   2.156 +struct
   2.157 +  val name = "Pure/extraction";
   2.158 +  type T =
   2.159 +    {realizes_eqns : rules,
   2.160 +     typeof_eqns : rules,
   2.161 +     types : string list,
   2.162 +     realizers : (string list * (term * proof)) list Symtab.table,
   2.163 +     defs : thm list,
   2.164 +     expand : (string * term) list,
   2.165 +     prep : (Sign.sg -> proof -> proof) option}
   2.166 +
   2.167 +  val empty =
   2.168 +    {realizes_eqns = empty_rules,
   2.169 +     typeof_eqns = empty_rules,
   2.170 +     types = [],
   2.171 +     realizers = Symtab.empty,
   2.172 +     defs = [],
   2.173 +     expand = [],
   2.174 +     prep = None};
   2.175 +  val copy = I;
   2.176 +  val prep_ext = I;
   2.177 +
   2.178 +  fun merge
   2.179 +    (({realizes_eqns = realizes_eqns1, typeof_eqns = typeof_eqns1, types = types1,
   2.180 +       realizers = realizers1, defs = defs1, expand = expand1, prep = prep1},
   2.181 +      {realizes_eqns = realizes_eqns2, typeof_eqns = typeof_eqns2, types = types2,
   2.182 +       realizers = realizers2, defs = defs2, expand = expand2, prep = prep2}) : T * T) =
   2.183 +    {realizes_eqns = merge_rules realizes_eqns1 realizes_eqns2,
   2.184 +     typeof_eqns = merge_rules typeof_eqns1 typeof_eqns2,
   2.185 +     types = types1 union types2,
   2.186 +     realizers = Symtab.merge_multi' (eq_set o pairself #1)
   2.187 +       (realizers1, realizers2),
   2.188 +     defs = gen_merge_lists eq_thm defs1 defs2,
   2.189 +     expand = merge_lists expand1 expand2,
   2.190 +     prep = (case prep1 of None => prep2 | _ => prep1)};
   2.191 +
   2.192 +  fun print sg (x : T) = ();
   2.193 +end;
   2.194 +
   2.195 +structure ExtractionData = TheoryDataFun(ExtractionArgs);
   2.196 +
   2.197 +fun read_condeq thy =
   2.198 +  let val sg = sign_of (add_syntax thy)
   2.199 +  in fn s =>
   2.200 +    let val t = Logic.varify (term_of (read_cterm sg (s, propT)))
   2.201 +    in (map Logic.dest_equals (Logic.strip_imp_prems t),
   2.202 +      Logic.dest_equals (Logic.strip_imp_concl t))
   2.203 +    end handle TERM _ => error ("Not a (conditional) meta equality:\n" ^ s)
   2.204 +  end;
   2.205 +
   2.206 +(** preprocessor **)
   2.207 +
   2.208 +fun set_preprocessor prep thy =
   2.209 +  let val {realizes_eqns, typeof_eqns, types, realizers,
   2.210 +    defs, expand, ...} = ExtractionData.get thy
   2.211 +  in
   2.212 +    ExtractionData.put
   2.213 +      {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
   2.214 +       realizers = realizers, defs = defs, expand = expand, prep = Some prep} thy
   2.215 +  end;
   2.216 +
   2.217 +(** equations characterizing realizability **)
   2.218 +
   2.219 +fun gen_add_realizes_eqns prep_eq eqns thy =
   2.220 +  let val {realizes_eqns, typeof_eqns, types, realizers,
   2.221 +    defs, expand, prep} = ExtractionData.get thy;
   2.222 +  in
   2.223 +    ExtractionData.put
   2.224 +      {realizes_eqns = foldr add_rule (map (prep_eq thy) eqns, realizes_eqns),
   2.225 +       typeof_eqns = typeof_eqns, types = types, realizers = realizers,
   2.226 +       defs = defs, expand = expand, prep = prep} thy
   2.227 +  end
   2.228 +
   2.229 +val add_realizes_eqns_i = gen_add_realizes_eqns (K I);
   2.230 +val add_realizes_eqns = gen_add_realizes_eqns read_condeq;
   2.231 +
   2.232 +(** equations characterizing type of extracted program **)
   2.233 +
   2.234 +fun gen_add_typeof_eqns prep_eq eqns thy =
   2.235 +  let
   2.236 +    val {realizes_eqns, typeof_eqns, types, realizers,
   2.237 +      defs, expand, prep} = ExtractionData.get thy;
   2.238 +    val eqns' = map (prep_eq thy) eqns;
   2.239 +    val ts = flat (flat
   2.240 +      (map (fn (ps, p) => map (fn (x, y) => [x, y]) (p :: ps)) eqns'))
   2.241 +  in
   2.242 +    ExtractionData.put
   2.243 +      {realizes_eqns = realizes_eqns, realizers = realizers,
   2.244 +       typeof_eqns = foldr add_rule (eqns', typeof_eqns),
   2.245 +       types = foldr add_types (ts, types),
   2.246 +       defs = defs, expand = expand, prep = prep} thy
   2.247 +  end
   2.248 +
   2.249 +val add_typeof_eqns_i = gen_add_typeof_eqns (K I);
   2.250 +val add_typeof_eqns = gen_add_typeof_eqns read_condeq;
   2.251 +
   2.252 +fun thaw (T as TFree (a, S)) =
   2.253 +      if ":" mem explode a then TVar (unpack_ixn a, S) else T
   2.254 +  | thaw (Type (a, Ts)) = Type (a, map thaw Ts)
   2.255 +  | thaw T = T;
   2.256 +
   2.257 +fun freeze (TVar ((a, i), S)) = TFree (a ^ ":" ^ string_of_int i, S)
   2.258 +  | freeze (Type (a, Ts)) = Type (a, map freeze Ts)
   2.259 +  | freeze T = T;
   2.260 +
   2.261 +fun freeze_thaw f x =
   2.262 +  map_term_types thaw (f (map_term_types freeze x));
   2.263 +
   2.264 +fun etype_of sg vs Ts t =
   2.265 +  let
   2.266 +    val {typeof_eqns, ...} = ExtractionData.get_sg sg;
   2.267 +    fun err () = error ("Unable to determine type of extracted program for\n" ^
   2.268 +      Sign.string_of_term sg t);
   2.269 +    val abs = foldr (fn (T, u) => Abs ("x", T, u))
   2.270 +  in case strip_abs_body (freeze_thaw (condrew sg (#net typeof_eqns)
   2.271 +    [typeof_proc (Sign.defaultS sg) vs]) (abs (Ts,
   2.272 +      Const ("typeof", fastype_of1 (Ts, t) --> Type ("Type", [])) $ t))) of
   2.273 +      Const ("Type", _) $ u => (Logic.dest_type u handle TERM _ => err ())
   2.274 +    | _ => err ()
   2.275 +  end;
   2.276 +
   2.277 +(** realizers for axioms / theorems, together with correctness proofs **)
   2.278 +
   2.279 +fun gen_add_realizers prep_rlz rs thy =
   2.280 +  let val {realizes_eqns, typeof_eqns, types, realizers,
   2.281 +    defs, expand, prep} = ExtractionData.get thy
   2.282 +  in
   2.283 +    ExtractionData.put
   2.284 +      {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
   2.285 +       realizers = foldr Symtab.update_multi
   2.286 +         (map (prep_rlz thy) (rev rs), realizers),
   2.287 +       defs = defs, expand = expand, prep = prep} thy
   2.288 +  end
   2.289 +
   2.290 +fun prep_realizer thy =
   2.291 +  let
   2.292 +    val {realizes_eqns, typeof_eqns, defs, ...} =
   2.293 +      ExtractionData.get thy;
   2.294 +    val eqns = Net.merge (#net realizes_eqns, #net typeof_eqns, K false);
   2.295 +    val thy' = add_syntax thy;
   2.296 +    val sign = sign_of thy';
   2.297 +    val tsg = Sign.tsig_of sign;
   2.298 +    val rd = ProofSyntax.read_proof thy' false
   2.299 +  in fn (thm, (vs, s1, s2)) =>
   2.300 +    let
   2.301 +      val name = Thm.name_of_thm thm;
   2.302 +      val _ = assert (name <> "") "add_realizers: unnamed theorem";
   2.303 +      val prop = Pattern.rewrite_term tsg
   2.304 +        (map (Logic.dest_equals o prop_of) defs) [] (prop_of thm);
   2.305 +      val vars = vars_of prop;
   2.306 +      val T = etype_of sign vs [] prop;
   2.307 +      val (T', thw) = Type.freeze_thaw_type
   2.308 +        (if T = nullT then nullT else map fastype_of vars ---> T);
   2.309 +      val t = map_term_types thw (term_of (read_cterm sign (s1, T')));
   2.310 +      val r = foldr forall_intr (vars, freeze_thaw
   2.311 +        (condrew sign eqns [typeof_proc (Sign.defaultS sign) vs, rlz_proc])
   2.312 +          (Const ("realizes", T --> propT --> propT) $
   2.313 +            (if T = nullT then t else list_comb (t, vars)) $ prop));
   2.314 +      val prf = Reconstruct.reconstruct_proof sign r (rd s2);
   2.315 +    in (name, (vs, (t, prf))) end
   2.316 +  end;
   2.317 +
   2.318 +val add_realizers_i = gen_add_realizers
   2.319 +  (fn _ => fn (name, (vs, t, prf)) => (name, (vs, (t, prf))));
   2.320 +val add_realizers = gen_add_realizers prep_realizer;
   2.321 +
   2.322 +(** expanding theorems / definitions **)
   2.323 +
   2.324 +fun add_expand_thm (thy, thm) =
   2.325 +  let
   2.326 +    val {realizes_eqns, typeof_eqns, types, realizers,
   2.327 +      defs, expand, prep} = ExtractionData.get thy;
   2.328 +
   2.329 +    val name = Thm.name_of_thm thm;
   2.330 +    val _ = assert (name <> "") "add_expand_thms: unnamed theorem";
   2.331 +
   2.332 +    val is_def =
   2.333 +      (case strip_comb (fst (Logic.dest_equals (prop_of thm))) of
   2.334 +         (Const _, ts) => forall is_Var ts andalso null (duplicates ts)
   2.335 +           andalso exists (fn thy =>
   2.336 +               is_some (Symtab.lookup (#axioms (rep_theory thy), name)))
   2.337 +             (thy :: ancestors_of thy)
   2.338 +       | _ => false) handle TERM _ => false;
   2.339 +
   2.340 +    val name = Thm.name_of_thm thm;
   2.341 +    val _ = assert (name <> "") "add_expand_thms: unnamed theorem";
   2.342 +  in
   2.343 +    (ExtractionData.put (if is_def then
   2.344 +        {realizes_eqns = realizes_eqns,
   2.345 +         typeof_eqns = add_rule (([],
   2.346 +           Logic.dest_equals (prop_of (Drule.abs_def thm))), typeof_eqns),
   2.347 +         types = types,
   2.348 +         realizers = realizers, defs = gen_ins eq_thm (thm, defs),
   2.349 +         expand = expand, prep = prep}
   2.350 +      else
   2.351 +        {realizes_eqns = realizes_eqns, typeof_eqns = typeof_eqns, types = types,
   2.352 +         realizers = realizers, defs = defs,
   2.353 +         expand = (name, prop_of thm) ins expand, prep = prep}) thy, thm)
   2.354 +  end;
   2.355 +
   2.356 +fun add_expand_thms thms thy = foldl (fst o add_expand_thm) (thy, thms);
   2.357 +
   2.358 +
   2.359 +(**** extract program ****)
   2.360 +
   2.361 +val dummyt = Const ("dummy", dummyT);
   2.362 +
   2.363 +fun extract thms thy =
   2.364 +  let
   2.365 +    val sg = sign_of (add_syntax thy);
   2.366 +    val tsg = Sign.tsig_of sg;
   2.367 +    val {realizes_eqns, typeof_eqns, types, realizers, defs, expand, prep} =
   2.368 +      ExtractionData.get thy;
   2.369 +    val typroc = typeof_proc (Sign.defaultS sg);
   2.370 +    val prep = if_none prep (K I) sg o ProofRewriteRules.elim_defs sg false defs o
   2.371 +      Reconstruct.expand_proof sg (("", None) :: map (apsnd Some) expand);
   2.372 +    val rrews = Net.merge (#net realizes_eqns, #net typeof_eqns, K false);
   2.373 +
   2.374 +    fun find_inst prop Ts ts vs =
   2.375 +      let
   2.376 +        val rvs = relevant_vars types prop;
   2.377 +        val vars = vars_of prop;
   2.378 +        val n = Int.min (length vars, length ts);
   2.379 +
   2.380 +        fun add_args ((Var ((a, i), _), t), (vs', tye)) =
   2.381 +          if a mem rvs then
   2.382 +            let val T = etype_of sg vs Ts t
   2.383 +            in if T = nullT then (vs', tye)
   2.384 +               else (a :: vs', (("'" ^ a, i), T) :: tye)
   2.385 +            end
   2.386 +          else (vs', tye)
   2.387 +
   2.388 +      in foldr add_args (take (n, vars) ~~ take (n, ts), ([], [])) end;
   2.389 +
   2.390 +    fun find vs = apsome snd o find_first (curry eq_set vs o fst);
   2.391 +    fun find' s = map snd o filter (equal s o fst)
   2.392 +
   2.393 +    fun realizes_null vs prop =
   2.394 +      freeze_thaw (condrew sg rrews [typroc vs, rlz_proc])
   2.395 +        (Const ("realizes", nullT --> propT --> propT) $ nullt $ prop);
   2.396 +
   2.397 +    fun corr d defs vs ts Ts hs (PBound i) _ _ = (defs, PBound i)
   2.398 +
   2.399 +      | corr d defs vs ts Ts hs (Abst (s, Some T, prf)) (Abst (_, _, prf')) t =
   2.400 +          let val (defs', corr_prf) = corr d defs vs [] (T :: Ts)
   2.401 +            (dummyt :: hs) prf (incr_pboundvars 1 0 prf')
   2.402 +            (case t of Some (Abs (_, _, u)) => Some u | _ => None)
   2.403 +          in (defs', Abst (s, Some T, corr_prf)) end
   2.404 +
   2.405 +      | corr d defs vs ts Ts hs (AbsP (s, Some prop, prf)) (AbsP (_, _, prf')) t =
   2.406 +          let
   2.407 +            val T = etype_of sg vs Ts prop;
   2.408 +            val u = if T = nullT then 
   2.409 +                (case t of Some u => Some (incr_boundvars 1 u) | None => None)
   2.410 +              else (case t of Some (Abs (_, _, u)) => Some u | _ => None);
   2.411 +            val (defs', corr_prf) = corr d defs vs [] (T :: Ts) (prop :: hs)
   2.412 +              (incr_pboundvars 0 1 prf) (incr_pboundvars 0 1 prf') u;
   2.413 +            val rlz = Const ("realizes", T --> propT --> propT)
   2.414 +          in (defs',
   2.415 +            if T = nullT then AbsP ("R", Some (rlz $ nullt $ prop),
   2.416 +              prf_subst_bounds [nullt] corr_prf)
   2.417 +            else Abst (s, Some T, AbsP ("R",
   2.418 +              Some (rlz $ Bound 0 $ incr_boundvars 1 prop), corr_prf)))
   2.419 +          end
   2.420 +
   2.421 +      | corr d defs vs ts Ts hs (prf % Some t) (prf' % _) t' =
   2.422 +          let val (defs', corr_prf) = corr d defs vs (t :: ts) Ts hs prf prf'
   2.423 +            (case t' of Some (u $ _) => Some u | _ => None)
   2.424 +          in (defs', corr_prf % Some t) end
   2.425 +
   2.426 +      | corr d defs vs ts Ts hs (prf1 %% prf2) (prf1' %% prf2') t =
   2.427 +          let
   2.428 +            val prop = Reconstruct.prop_of' hs prf2';
   2.429 +            val T = etype_of sg vs Ts prop;
   2.430 +            val (defs1, f, u) = if T = nullT then (defs, t, None) else
   2.431 +              (case t of
   2.432 +                 Some (f $ u) => (defs, Some f, Some u)
   2.433 +               | _ =>
   2.434 +                 let val (defs1, u) = extr d defs vs [] Ts hs prf2'
   2.435 +                 in (defs1, None, Some u) end)
   2.436 +            val (defs2, corr_prf1) = corr d defs1 vs [] Ts hs prf1 prf1' f;
   2.437 +            val (defs3, corr_prf2) = corr d defs2 vs [] Ts hs prf2 prf2' u;
   2.438 +          in
   2.439 +            if T = nullT then (defs3, corr_prf1 %% corr_prf2) else
   2.440 +              (defs3, corr_prf1 % u %% corr_prf2)
   2.441 +          end
   2.442 +
   2.443 +      | corr d defs vs ts Ts hs (prf0 as PThm ((name, _), prf, prop, Some Ts')) _ _ =
   2.444 +          let
   2.445 +            val (vs', tye) = find_inst prop Ts ts vs;
   2.446 +            val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye;
   2.447 +            val T = etype_of sg vs' [] prop;
   2.448 +            val defs' = if T = nullT then defs
   2.449 +              else fst (extr d defs vs ts Ts hs prf0)
   2.450 +          in
   2.451 +            if T = nullT andalso realizes_null vs' prop = prop then (defs, prf0)
   2.452 +            else case Symtab.lookup (realizers, name) of
   2.453 +              None => (case find vs' (find' name defs') of
   2.454 +                None =>
   2.455 +                  let
   2.456 +                    val _ = assert (T = nullT) "corr: internal error";
   2.457 +                    val _ = msg d ("Building correctness proof for " ^ quote name ^
   2.458 +                      (if null vs' then ""
   2.459 +                       else " (relevant variables: " ^ commas_quote vs' ^ ")"));
   2.460 +                    val prf' = prep (Reconstruct.reconstruct_proof sg prop prf);
   2.461 +                    val (defs'', corr_prf) =
   2.462 +                      corr (d + 1) defs' vs' [] [] [] prf' prf' None;
   2.463 +                    val args = vfs_of prop;
   2.464 +                    val corr_prf' = foldr forall_intr_prf (args, corr_prf);
   2.465 +                  in
   2.466 +                    ((name, (vs', ((nullt, nullt), corr_prf'))) :: defs',
   2.467 +                     prf_subst_TVars tye' corr_prf')
   2.468 +                  end
   2.469 +              | Some (_, prf') => (defs', prf_subst_TVars tye' prf'))
   2.470 +            | Some rs => (case find vs' rs of
   2.471 +                Some (_, prf') => (defs', prf_subst_TVars tye' prf')
   2.472 +              | None => error ("corr: no realizer for instance of theorem " ^
   2.473 +                  quote name ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   2.474 +                    (Reconstruct.prop_of (proof_combt (prf0, ts))))))
   2.475 +          end
   2.476 +
   2.477 +      | corr d defs vs ts Ts hs (prf0 as PAxm (s, prop, Some Ts')) _ _ =
   2.478 +          let
   2.479 +            val (vs', tye) = find_inst prop Ts ts vs;
   2.480 +            val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye
   2.481 +          in
   2.482 +            case find vs' (Symtab.lookup_multi (realizers, s)) of
   2.483 +              Some (_, prf) => (defs, prf_subst_TVars tye' prf)
   2.484 +            | None => error ("corr: no realizer for instance of axiom " ^
   2.485 +                quote s ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   2.486 +                  (Reconstruct.prop_of (proof_combt (prf0, ts)))))
   2.487 +          end
   2.488 +
   2.489 +      | corr d defs vs ts Ts hs _ _ _ = error "corr: bad proof"
   2.490 +
   2.491 +    and extr d defs vs ts Ts hs (PBound i) = (defs, Bound i)
   2.492 +
   2.493 +      | extr d defs vs ts Ts hs (Abst (s, Some T, prf)) =
   2.494 +          let val (defs', t) = extr d defs vs []
   2.495 +            (T :: Ts) (dummyt :: hs) (incr_pboundvars 1 0 prf)
   2.496 +          in (defs', Abs (s, T, t)) end
   2.497 +
   2.498 +      | extr d defs vs ts Ts hs (AbsP (s, Some t, prf)) =
   2.499 +          let
   2.500 +            val T = etype_of sg vs Ts t;
   2.501 +            val (defs', t) = extr d defs vs [] (T :: Ts) (t :: hs)
   2.502 +              (incr_pboundvars 0 1 prf)
   2.503 +          in (defs',
   2.504 +            if T = nullT then subst_bound (nullt, t) else Abs (s, T, t))
   2.505 +          end
   2.506 +
   2.507 +      | extr d defs vs ts Ts hs (prf % Some t) =
   2.508 +          let val (defs', u) = extr d defs vs (t :: ts) Ts hs prf
   2.509 +          in (defs', u $ t) end
   2.510 +
   2.511 +      | extr d defs vs ts Ts hs (prf1 %% prf2) =
   2.512 +          let
   2.513 +            val (defs', f) = extr d defs vs [] Ts hs prf1;
   2.514 +            val prop = Reconstruct.prop_of' hs prf2;
   2.515 +            val T = etype_of sg vs Ts prop
   2.516 +          in
   2.517 +            if T = nullT then (defs', f) else
   2.518 +              let val (defs'', t) = extr d defs' vs [] Ts hs prf2
   2.519 +              in (defs'', f $ t) end
   2.520 +          end
   2.521 +
   2.522 +      | extr d defs vs ts Ts hs (prf0 as PThm ((s, _), prf, prop, Some Ts')) =
   2.523 +          let
   2.524 +            val (vs', tye) = find_inst prop Ts ts vs;
   2.525 +            val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye
   2.526 +          in
   2.527 +            case Symtab.lookup (realizers, s) of
   2.528 +              None => (case find vs' (find' s defs) of
   2.529 +                None =>
   2.530 +                  let
   2.531 +                    val _ = msg d ("Extracting " ^ quote s ^
   2.532 +                      (if null vs' then ""
   2.533 +                       else " (relevant variables: " ^ commas_quote vs' ^ ")"));
   2.534 +                    val prf' = prep (Reconstruct.reconstruct_proof sg prop prf);
   2.535 +                    val (defs', t) = extr (d + 1) defs vs' [] [] [] prf';
   2.536 +                    val (defs'', corr_prf) =
   2.537 +                      corr (d + 1) defs' vs' [] [] [] prf' prf' (Some t);
   2.538 +
   2.539 +                    val nt = Envir.beta_norm t;
   2.540 +                    val args = vfs_of prop;
   2.541 +                    val args' = filter (fn v => Logic.occs (v, nt)) args;
   2.542 +                    val t' = mkabs (args', nt);
   2.543 +                    val T = fastype_of t';
   2.544 +                    val cname = add_prefix "extr" (space_implode "_" (s :: vs'));
   2.545 +                    val c = Const (cname, T);
   2.546 +                    val u = mkabs (args, list_comb (c, args'));
   2.547 +                    val eqn = Logic.mk_equals (c, t');
   2.548 +                    val rlz =
   2.549 +                      Const ("realizes", fastype_of nt --> propT --> propT);
   2.550 +                    val lhs = rlz $ nt $ prop;
   2.551 +                    val rhs = rlz $ list_comb (c, args') $ prop;
   2.552 +                    val f = Abs ("x", T, rlz $ list_comb (Bound 0, args') $ prop);
   2.553 +
   2.554 +                    val corr_prf' = foldr forall_intr_prf (args,
   2.555 +                      ProofRewriteRules.rewrite_terms
   2.556 +                        (freeze_thaw (condrew sg rrews [typroc vs', rlz_proc]))
   2.557 +                        (Proofterm.rewrite_proof_notypes ([], [])
   2.558 +                          (chtype [] equal_elim_axm %> lhs %> rhs %%
   2.559 +                            (chtype [propT] symmetric_axm %> rhs %> lhs %%
   2.560 +                              (chtype [propT, T] combination_axm %> f %> f %> c %> t' %%
   2.561 +                                (chtype [T --> propT] reflexive_axm %> f) %%
   2.562 +                                PAxm (cname ^ "_def", eqn,
   2.563 +                                  Some (map TVar (term_tvars eqn))))) %%
   2.564 +                            corr_prf)))
   2.565 +                  in
   2.566 +                    ((s, (vs', ((t', u), corr_prf'))) :: defs',
   2.567 +                     subst_TVars tye' u)
   2.568 +                  end
   2.569 +              | Some ((_, u), _) => (defs, subst_TVars tye' u))
   2.570 +            | Some rs => (case find vs' rs of
   2.571 +                Some (t, _) => (defs, subst_TVars tye' t)
   2.572 +              | None => error ("extr: no realizer for instance of theorem " ^
   2.573 +                  quote s ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   2.574 +                    (Reconstruct.prop_of (proof_combt (prf0, ts))))))
   2.575 +          end
   2.576 +
   2.577 +      | extr d defs vs ts Ts hs (prf0 as PAxm (s, prop, Some Ts')) =
   2.578 +          let
   2.579 +            val (vs', tye) = find_inst prop Ts ts vs;
   2.580 +            val tye' = (map fst (term_tvars prop) ~~ Ts') @ tye
   2.581 +          in
   2.582 +            case find vs' (Symtab.lookup_multi (realizers, s)) of
   2.583 +              Some (t, _) => (defs, subst_TVars tye' t)
   2.584 +            | None => error ("no realizer for instance of axiom " ^
   2.585 +                quote s ^ ":\n" ^ Sign.string_of_term sg (Envir.beta_norm
   2.586 +                  (Reconstruct.prop_of (proof_combt (prf0, ts)))))
   2.587 +          end
   2.588 +
   2.589 +      | extr d defs vs ts Ts hs _ = error "extr: bad proof";
   2.590 +
   2.591 +    fun prep_thm thm =
   2.592 +      let
   2.593 +        val {prop, der = (_, prf), sign, ...} = rep_thm thm;
   2.594 +        val name = Thm.name_of_thm thm;
   2.595 +        val _ = assert (name <> "") "extraction: unnamed theorem";
   2.596 +        val _ = assert (etype_of sg [] [] prop <> nullT) ("theorem " ^
   2.597 +          quote name ^ " has no computational content")
   2.598 +      in (name, Reconstruct.reconstruct_proof sign prop prf) end;
   2.599 +
   2.600 +    val (names, prfs) = ListPair.unzip (map prep_thm thms);
   2.601 +    val defs = foldl (fn (defs, prf) =>
   2.602 +      fst (extr 0 defs [] [] [] [] prf)) ([], prfs);
   2.603 +    val {path, ...} = Sign.rep_sg sg;
   2.604 +
   2.605 +    fun add_def ((s, (vs, ((t, u), _))), thy) = 
   2.606 +      let
   2.607 +        val ft = fst (Type.freeze_thaw t);
   2.608 +        val fu = fst (Type.freeze_thaw u);
   2.609 +        val name = add_prefix "extr" (space_implode "_" (s :: vs))
   2.610 +      in case Sign.const_type (sign_of thy) name of
   2.611 +          None => if t = nullt then thy else thy |>
   2.612 +            Theory.add_consts_i [(name, fastype_of ft, NoSyn)] |>
   2.613 +            fst o PureThy.add_defs_i false [((name ^ "_def",
   2.614 +              Logic.mk_equals (head_of (strip_abs_body fu), ft)), [])]
   2.615 +        | Some _ => thy
   2.616 +      end;
   2.617 +
   2.618 +    fun add_thm ((s, (vs, (_, prf))), thy) = fst (PureThy.store_thm
   2.619 +          ((add_prefix "extr" (space_implode "_" (s :: vs)) ^
   2.620 +            "_correctness", standard (gen_all (ProofChecker.thm_of_proof thy
   2.621 +              (fst (Proofterm.freeze_thaw_prf (ProofRewriteRules.rewrite_terms
   2.622 +                (Pattern.rewrite_term (Sign.tsig_of (sign_of thy)) []
   2.623 +                  [rlz_proc']) prf)))))), []) thy)
   2.624 +      | add_thm (_, thy) = thy
   2.625 +
   2.626 +  in thy |>
   2.627 +    Theory.absolute_path |>
   2.628 +    curry (foldr add_def) defs |>
   2.629 +    curry (foldr add_thm) (filter (fn (s, _) => s mem names) defs) |>
   2.630 +    Theory.add_path (NameSpace.pack (if_none path []))
   2.631 +  end;
   2.632 +
   2.633 +
   2.634 +(**** interface ****)
   2.635 +
   2.636 +structure P = OuterParse and K = OuterSyntax.Keyword;
   2.637 +
   2.638 +val realizersP =
   2.639 +  OuterSyntax.command "realizers"
   2.640 +  "specify realizers for primitive axioms / theorems, together with correctness proof"
   2.641 +  K.thy_decl
   2.642 +    (Scan.repeat1 (P.xname --
   2.643 +       Scan.optional (P.$$$ "(" |-- P.list1 P.name --| P.$$$ ")") [] --|
   2.644 +       P.$$$ ":" -- P.string -- P.string) >>
   2.645 +     (fn xs => Toplevel.theory (fn thy => add_realizers
   2.646 +       (map (fn (((a, vs), s1), s2) =>
   2.647 +         (PureThy.get_thm thy a, (vs, s1, s2))) xs) thy)));
   2.648 +
   2.649 +val realizabilityP =
   2.650 +  OuterSyntax.command "realizability"
   2.651 +  "add equations characterizing realizability" K.thy_decl
   2.652 +  (Scan.repeat1 P.string >> (Toplevel.theory o add_realizes_eqns));
   2.653 +
   2.654 +val typeofP =
   2.655 +  OuterSyntax.command "extract_type"
   2.656 +  "add equations characterizing type of extracted program" K.thy_decl
   2.657 +  (Scan.repeat1 P.string >> (Toplevel.theory o add_typeof_eqns));
   2.658 +
   2.659 +val extractP =
   2.660 +  OuterSyntax.command "extract" "extract terms from proofs" K.thy_decl
   2.661 +    (Scan.repeat1 P.xname >> (fn xs => Toplevel.theory
   2.662 +      (fn thy => extract (map (PureThy.get_thm thy) xs) thy)));
   2.663 +
   2.664 +val parsers = [realizersP, realizabilityP, typeofP, extractP];
   2.665 +
   2.666 +val setup =
   2.667 +  [ExtractionData.init,
   2.668 +
   2.669 +   add_typeof_eqns
   2.670 +     ["(typeof (PROP P)) == (Type (TYPE(Null))) ==>  \
   2.671 +    \  (typeof (PROP Q)) == (Type (TYPE('Q))) ==>  \
   2.672 +    \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE('Q)))",
   2.673 +
   2.674 +      "(typeof (PROP Q)) == (Type (TYPE(Null))) ==>  \
   2.675 +    \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE(Null)))",
   2.676 +
   2.677 +      "(typeof (PROP P)) == (Type (TYPE('P))) ==>  \
   2.678 +    \  (typeof (PROP Q)) == (Type (TYPE('Q))) ==>  \
   2.679 +    \    (typeof (PROP P ==> PROP Q)) == (Type (TYPE('P => 'Q)))",
   2.680 +
   2.681 +      "(%x. typeof (PROP P (x))) == (%x. Type (TYPE(Null))) ==>  \
   2.682 +    \    (typeof (!!x. PROP P (x))) == (Type (TYPE(Null)))",
   2.683 +
   2.684 +      "(%x. typeof (PROP P (x))) == (%x. Type (TYPE('P))) ==>  \
   2.685 +    \    (typeof (!!x::'a. PROP P (x))) == (Type (TYPE('a => 'P)))",
   2.686 +
   2.687 +      "(%x. typeof (f (x))) == (%x. Type (TYPE('f))) ==>  \
   2.688 +    \    (typeof (f)) == (Type (TYPE('f)))"],
   2.689 +
   2.690 +   add_realizes_eqns
   2.691 +     ["(typeof (PROP P)) == (Type (TYPE(Null))) ==>  \
   2.692 +    \    (realizes (r) (PROP P ==> PROP Q)) ==  \
   2.693 +    \    (PROP realizes (Null) (PROP P) ==> PROP realizes (r) (PROP Q))",
   2.694 +
   2.695 +      "(typeof (PROP P)) == (Type (TYPE('P))) ==>  \
   2.696 +    \  (typeof (PROP Q)) == (Type (TYPE(Null))) ==>  \
   2.697 +    \    (realizes (r) (PROP P ==> PROP Q)) ==  \
   2.698 +    \    (!!x::'P. PROP realizes (x) (PROP P) ==> PROP realizes (Null) (PROP Q))",
   2.699 +
   2.700 +      "(realizes (r) (PROP P ==> PROP Q)) ==  \
   2.701 +    \  (!!x. PROP realizes (x) (PROP P) ==> PROP realizes (r (x)) (PROP Q))",
   2.702 +
   2.703 +      "(%x. typeof (PROP P (x))) == (%x. Type (TYPE(Null))) ==>  \
   2.704 +    \    (realizes (r) (!!x. PROP P (x))) ==  \
   2.705 +    \    (!!x. PROP realizes (Null) (PROP P (x)))",
   2.706 +
   2.707 +      "(realizes (r) (!!x. PROP P (x))) ==  \
   2.708 +    \  (!!x. PROP realizes (r (x)) (PROP P (x)))"],
   2.709 +
   2.710 +   Attrib.add_attributes
   2.711 +     [("extraction_expand",
   2.712 +       (Attrib.no_args add_expand_thm, K Attrib.undef_local_attribute),
   2.713 +       "specify theorems / definitions to be expanded during extraction")]];
   2.714 +
   2.715 +end;
   2.716 +
   2.717 +OuterSyntax.add_parsers Extraction.parsers;
     3.1 --- a/src/Pure/ROOT.ML	Fri Jul 19 18:44:37 2002 +0200
     3.2 +++ b/src/Pure/ROOT.ML	Sun Jul 21 15:37:04 2002 +0200
     3.3 @@ -61,6 +61,7 @@
     3.4  
     3.5  use "axclass.ML";
     3.6  use "codegen.ML";
     3.7 +use "Proof/extraction.ML";
     3.8  
     3.9  (*old-style goal package*)
    3.10  use "goals.ML";
     4.1 --- a/src/Pure/pure.ML	Fri Jul 19 18:44:37 2002 +0200
     4.2 +++ b/src/Pure/pure.ML	Sun Jul 21 15:37:04 2002 +0200
     4.3 @@ -23,6 +23,7 @@
     4.4      Present.setup @
     4.5      ProofGeneral.setup @
     4.6      Codegen.setup @
     4.7 +    Extraction.setup @
     4.8      Goals.setup;
     4.9  in
    4.10    structure Pure =