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 |