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