src/Pure/Proof/extraction.ML
changeset 23178 07ba6b58b3d2
parent 22924 17f1d7af43bd
child 24219 e558fe311376
equal deleted inserted replaced
23177:3004310c95b1 23178:07ba6b58b3d2
    82   {next = next - 1, rs = r :: rs, net = Net.insert_term (K false)
    82   {next = next - 1, rs = r :: rs, net = Net.insert_term (K false)
    83      (Envir.eta_contract lhs, (next, r)) net};
    83      (Envir.eta_contract lhs, (next, r)) net};
    84 
    84 
    85 fun merge_rules
    85 fun merge_rules
    86   ({next, rs = rs1, net} : rules) ({next = next2, rs = rs2, ...} : rules) =
    86   ({next, rs = rs1, net} : rules) ({next = next2, rs = rs2, ...} : rules) =
    87   foldr add_rule {next = next, rs = rs1, net = net} (subtract (op =) rs1 rs2);
    87   List.foldr add_rule {next = next, rs = rs1, net = net} (subtract (op =) rs1 rs2);
    88 
    88 
    89 fun condrew thy rules procs =
    89 fun condrew thy rules procs =
    90   let
    90   let
    91     fun rew tm =
    91     fun rew tm =
    92       Pattern.rewrite_term thy [] (condrew' :: procs) tm
    92       Pattern.rewrite_term thy [] (condrew' :: procs) tm
   134 
   134 
   135 fun forall_intr_prf (t, prf) =
   135 fun forall_intr_prf (t, prf) =
   136   let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
   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;
   137   in Abst (a, SOME T, prf_abstract_over t prf) end;
   138 
   138 
   139 val mkabs = foldr (fn (v, t) => Abs ("x", fastype_of v, abstract_over (v, t)));
   139 val mkabs = List.foldr (fn (v, t) => Abs ("x", fastype_of v, abstract_over (v, t)));
   140 
   140 
   141 fun strip_abs 0 t = t
   141 fun strip_abs 0 t = t
   142   | strip_abs n (Abs (_, _, t)) = strip_abs (n-1) t
   142   | strip_abs n (Abs (_, _, t)) = strip_abs (n-1) t
   143   | strip_abs _ _ = error "strip_abs: not an abstraction";
   143   | strip_abs _ _ = error "strip_abs: not an abstraction";
   144 
   144 
   145 fun prf_subst_TVars tye =
   145 fun prf_subst_TVars tye =
   146   map_proof_terms (subst_TVars tye) (typ_subst_TVars tye);
   146   map_proof_terms (subst_TVars tye) (typ_subst_TVars tye);
   147 
   147 
   148 fun relevant_vars types prop = foldr (fn
   148 fun relevant_vars types prop = List.foldr (fn
   149       (Var ((a, i), T), vs) => (case strip_type T of
   149       (Var ((a, i), T), vs) => (case strip_type T of
   150         (_, Type (s, _)) => if member (op =) types s then a :: vs else vs
   150         (_, Type (s, _)) => if member (op =) types s then a :: vs else vs
   151       | _ => vs)
   151       | _ => vs)
   152     | (_, vs) => vs) [] (vars_of prop);
   152     | (_, vs) => vs) [] (vars_of prop);
   153 
   153 
   235 fun gen_add_realizes_eqns prep_eq eqns thy =
   235 fun gen_add_realizes_eqns prep_eq eqns thy =
   236   let val {realizes_eqns, typeof_eqns, types, realizers,
   236   let val {realizes_eqns, typeof_eqns, types, realizers,
   237     defs, expand, prep} = ExtractionData.get thy;
   237     defs, expand, prep} = ExtractionData.get thy;
   238   in
   238   in
   239     ExtractionData.put
   239     ExtractionData.put
   240       {realizes_eqns = foldr add_rule realizes_eqns (map (prep_eq thy) eqns),
   240       {realizes_eqns = List.foldr add_rule realizes_eqns (map (prep_eq thy) eqns),
   241        typeof_eqns = typeof_eqns, types = types, realizers = realizers,
   241        typeof_eqns = typeof_eqns, types = types, realizers = realizers,
   242        defs = defs, expand = expand, prep = prep} thy
   242        defs = defs, expand = expand, prep = prep} thy
   243   end
   243   end
   244 
   244 
   245 val add_realizes_eqns_i = gen_add_realizes_eqns (K I);
   245 val add_realizes_eqns_i = gen_add_realizes_eqns (K I);
   253       defs, expand, prep} = ExtractionData.get thy;
   253       defs, expand, prep} = ExtractionData.get thy;
   254     val eqns' = map (prep_eq thy) eqns
   254     val eqns' = map (prep_eq thy) eqns
   255   in
   255   in
   256     ExtractionData.put
   256     ExtractionData.put
   257       {realizes_eqns = realizes_eqns, realizers = realizers,
   257       {realizes_eqns = realizes_eqns, realizers = realizers,
   258        typeof_eqns = foldr add_rule typeof_eqns eqns',
   258        typeof_eqns = List.foldr add_rule typeof_eqns eqns',
   259        types = types, defs = defs, expand = expand, prep = prep} thy
   259        types = types, defs = defs, expand = expand, prep = prep} thy
   260   end
   260   end
   261 
   261 
   262 val add_typeof_eqns_i = gen_add_typeof_eqns (K I);
   262 val add_typeof_eqns_i = gen_add_typeof_eqns (K I);
   263 val add_typeof_eqns = gen_add_typeof_eqns read_condeq;
   263 val add_typeof_eqns = gen_add_typeof_eqns read_condeq;
   322       val t = map_types thw (Sign.simple_read_term thy' T' s1);
   322       val t = map_types thw (Sign.simple_read_term thy' T' s1);
   323       val r' = freeze_thaw (condrew thy' eqns
   323       val r' = freeze_thaw (condrew thy' eqns
   324         (procs @ [typeof_proc (Sign.defaultS thy') vs, rlz_proc]))
   324         (procs @ [typeof_proc (Sign.defaultS thy') vs, rlz_proc]))
   325           (Const ("realizes", T --> propT --> propT) $
   325           (Const ("realizes", T --> propT --> propT) $
   326             (if T = nullT then t else list_comb (t, vars')) $ prop);
   326             (if T = nullT then t else list_comb (t, vars')) $ prop);
   327       val r = foldr forall_intr r' (map (get_var_type r') vars);
   327       val r = List.foldr forall_intr r' (map (get_var_type r') vars);
   328       val prf = Reconstruct.reconstruct_proof thy' r (rd s2);
   328       val prf = Reconstruct.reconstruct_proof thy' r (rd s2);
   329     in (name, (vs, (t, prf))) end
   329     in (name, (vs, (t, prf))) end
   330   end;
   330   end;
   331 
   331 
   332 val add_realizers_i = gen_add_realizers
   332 val add_realizers_i = gen_add_realizers
   472             in if T = nullT then (vs', tye)
   472             in if T = nullT then (vs', tye)
   473                else (a :: vs', (("'" ^ a, i), T) :: tye)
   473                else (a :: vs', (("'" ^ a, i), T) :: tye)
   474             end
   474             end
   475           else (vs', tye)
   475           else (vs', tye)
   476 
   476 
   477       in foldr add_args ([], []) (Library.take (n, vars) ~~ Library.take (n, ts)) end;
   477       in List.foldr add_args ([], []) (Library.take (n, vars) ~~ Library.take (n, ts)) end;
   478 
   478 
   479     fun find (vs: string list) = Option.map snd o find_first (curry (gen_eq_set (op =)) vs o fst);
   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)
   480     fun find' s = map snd o List.filter (equal s o fst)
   481 
   481 
   482     fun app_rlz_rews Ts vs t = strip_abs (length Ts) (freeze_thaw
   482     fun app_rlz_rews Ts vs t = strip_abs (length Ts) (freeze_thaw
   567                        else " (relevant variables: " ^ commas_quote vs' ^ ")"));
   567                        else " (relevant variables: " ^ commas_quote vs' ^ ")"));
   568                     val prf' = prep (Reconstruct.reconstruct_proof thy' prop prf);
   568                     val prf' = prep (Reconstruct.reconstruct_proof thy' prop prf);
   569                     val (defs'', corr_prf) =
   569                     val (defs'', corr_prf) =
   570                       corr (d + 1) defs' vs' [] [] [] prf' prf' NONE;
   570                       corr (d + 1) defs' vs' [] [] [] prf' prf' NONE;
   571                     val corr_prop = Reconstruct.prop_of corr_prf;
   571                     val corr_prop = Reconstruct.prop_of corr_prf;
   572                     val corr_prf' = foldr forall_intr_prf
   572                     val corr_prf' = List.foldr forall_intr_prf
   573                       (proof_combt
   573                       (proof_combt
   574                          (PThm (corr_name name vs', corr_prf, corr_prop,
   574                          (PThm (corr_name name vs', corr_prf, corr_prop,
   575                              SOME (map TVar (term_tvars corr_prop))), vfs_of corr_prop))
   575                              SOME (map TVar (term_tvars corr_prop))), vfs_of corr_prop))
   576                       (map (get_var_type corr_prop) (vfs_of prop))
   576                       (map (get_var_type corr_prop) (vfs_of prop))
   577                   in
   577                   in
   676                          (chtype [propT, T] combination_axm %> f %> f %> c %> t' %%
   676                          (chtype [propT, T] combination_axm %> f %> f %> c %> t' %%
   677                            (chtype [T --> propT] reflexive_axm %> f) %%
   677                            (chtype [T --> propT] reflexive_axm %> f) %%
   678                            PAxm (cname ^ "_def", eqn,
   678                            PAxm (cname ^ "_def", eqn,
   679                              SOME (map TVar (term_tvars eqn))))) %% corr_prf;
   679                              SOME (map TVar (term_tvars eqn))))) %% corr_prf;
   680                     val corr_prop = Reconstruct.prop_of corr_prf';
   680                     val corr_prop = Reconstruct.prop_of corr_prf';
   681                     val corr_prf'' = foldr forall_intr_prf
   681                     val corr_prf'' = List.foldr forall_intr_prf
   682                       (proof_combt
   682                       (proof_combt
   683                         (PThm (corr_name s vs', corr_prf', corr_prop,
   683                         (PThm (corr_name s vs', corr_prf', corr_prop,
   684                           SOME (map TVar (term_tvars corr_prop))),  vfs_of corr_prop))
   684                           SOME (map TVar (term_tvars corr_prop))),  vfs_of corr_prop))
   685                       (map (get_var_type corr_prop) (vfs_of prop));
   685                       (map (get_var_type corr_prop) (vfs_of prop));
   686                   in
   686                   in