40 val level_of_type_sys : type_system -> type_level |
40 val level_of_type_sys : type_system -> type_level |
41 val is_type_sys_virtually_sound : type_system -> bool |
41 val is_type_sys_virtually_sound : type_system -> bool |
42 val is_type_sys_fairly_sound : type_system -> bool |
42 val is_type_sys_fairly_sound : type_system -> bool |
43 val unmangled_const : string -> string * string fo_term list |
43 val unmangled_const : string -> string * string fo_term list |
44 val translate_atp_fact : |
44 val translate_atp_fact : |
45 Proof.context -> format -> bool -> (string * locality) * thm |
45 Proof.context -> format -> type_system -> bool -> (string * locality) * thm |
46 -> translated_formula option * ((string * locality) * thm) |
46 -> translated_formula option * ((string * locality) * thm) |
47 val prepare_atp_problem : |
47 val prepare_atp_problem : |
48 Proof.context -> format -> formula_kind -> formula_kind -> type_system |
48 Proof.context -> format -> formula_kind -> formula_kind -> type_system |
49 -> bool -> term list -> term |
49 -> bool -> term list -> term |
50 -> (translated_formula option * ((string * 'a) * thm)) list |
50 -> (translated_formula option * ((string * 'a) * thm)) list |
176 |
179 |
177 fun is_type_level_fairly_sound level = |
180 fun is_type_level_fairly_sound level = |
178 is_type_level_virtually_sound level orelse level = Finite_Types |
181 is_type_level_virtually_sound level orelse level = Finite_Types |
179 val is_type_sys_fairly_sound = is_type_level_fairly_sound o level_of_type_sys |
182 val is_type_sys_fairly_sound = is_type_level_fairly_sound o level_of_type_sys |
180 |
183 |
|
184 fun is_setting_higher_order THF (Simple_Types _) = true |
|
185 | is_setting_higher_order _ _ = false |
|
186 |
181 fun aconn_fold pos f (ANot, [phi]) = f (Option.map not pos) phi |
187 fun aconn_fold pos f (ANot, [phi]) = f (Option.map not pos) phi |
182 | aconn_fold pos f (AImplies, [phi1, phi2]) = |
188 | aconn_fold pos f (AImplies, [phi1, phi2]) = |
183 f (Option.map not pos) phi1 #> f pos phi2 |
189 f (Option.map not pos) phi1 #> f pos phi2 |
184 | aconn_fold pos f (AAnd, phis) = fold (f pos) phis |
190 | aconn_fold pos f (AAnd, phis) = fold (f pos) phis |
185 | aconn_fold pos f (AOr, phis) = fold (f pos) phis |
191 | aconn_fold pos f (AOr, phis) = fold (f pos) phis |
278 fun term_vars (ATerm (name as (s, _), tms)) = |
284 fun term_vars (ATerm (name as (s, _), tms)) = |
279 is_atp_variable s ? insert (op =) (name, NONE) |
285 is_atp_variable s ? insert (op =) (name, NONE) |
280 #> fold term_vars tms |
286 #> fold term_vars tms |
281 fun close_formula_universally phi = close_universally term_vars phi |
287 fun close_formula_universally phi = close_universally term_vars phi |
282 |
288 |
283 fun fo_term_from_typ format (Type (s, Ts)) = |
289 val homo_infinite_type_name = @{type_name ind} (* any infinite type *) |
284 ATerm (case (format, s) of |
290 val homo_infinite_type = Type (homo_infinite_type_name, []) |
285 (THF, @{type_name bool}) => `I tptp_bool_type |
291 |
286 | (THF, @{type_name fun}) => `I tptp_fun_type |
292 fun fo_term_from_typ higher_order = |
287 | _ => `make_fixed_type_const s, |
293 let |
288 map (fo_term_from_typ format) Ts) |
294 fun term (Type (s, Ts)) = |
289 | fo_term_from_typ _ (TFree (s, _)) = ATerm (`make_fixed_type_var s, []) |
295 ATerm (case (higher_order, s) of |
290 | fo_term_from_typ _ (TVar ((x as (s, _)), _)) = |
296 (true, @{type_name bool}) => `I tptp_bool_type |
291 ATerm ((make_schematic_type_var x, s), []) |
297 | (true, @{type_name fun}) => `I tptp_fun_type |
|
298 | _ => if s = homo_infinite_type_name then `I tptp_individual_type |
|
299 else `make_fixed_type_const s, |
|
300 map term Ts) |
|
301 | term (TFree (s, _)) = ATerm (`make_fixed_type_var s, []) |
|
302 | term (TVar ((x as (s, _)), _)) = |
|
303 ATerm ((make_schematic_type_var x, s), []) |
|
304 in term end |
292 |
305 |
293 (* This shouldn't clash with anything else. *) |
306 (* This shouldn't clash with anything else. *) |
294 val mangled_type_sep = "\000" |
307 val mangled_type_sep = "\000" |
295 |
308 |
296 fun generic_mangled_type_name f (ATerm (name, [])) = f name |
309 fun generic_mangled_type_name f (ATerm (name, [])) = f name |
297 | generic_mangled_type_name f (ATerm (name, tys)) = |
310 | generic_mangled_type_name f (ATerm (name, tys)) = |
298 f name ^ "(" ^ space_implode "," (map (generic_mangled_type_name f) tys) |
311 f name ^ "(" ^ space_implode "," (map (generic_mangled_type_name f) tys) |
299 ^ ")" |
312 ^ ")" |
300 |
313 |
301 fun ho_type_from_fo_term format pred_sym ary = |
314 fun ho_type_from_fo_term higher_order pred_sym ary = |
302 let |
315 let |
303 fun to_atype ty = |
316 fun to_atype ty = |
304 AType ((make_simple_type (generic_mangled_type_name fst ty), |
317 AType ((make_simple_type (generic_mangled_type_name fst ty), |
305 generic_mangled_type_name snd ty)) |
318 generic_mangled_type_name snd ty)) |
306 fun to_afun f1 f2 tys = AFun (f1 (hd tys), f2 (nth tys 1)) |
319 fun to_afun f1 f2 tys = AFun (f1 (hd tys), f2 (nth tys 1)) |
307 fun to_tff 0 ty = |
320 fun to_fo 0 ty = |
308 if pred_sym then AType (`I tptp_bool_type) else to_atype ty |
321 if pred_sym then AType (`I tptp_bool_type) else to_atype ty |
309 | to_tff ary (ATerm (_, tys)) = to_afun to_atype (to_tff (ary - 1)) tys |
322 | to_fo ary (ATerm (_, tys)) = to_afun to_atype (to_fo (ary - 1)) tys |
310 fun to_thf (ty as ATerm ((s, _), tys)) = |
323 fun to_ho (ty as ATerm ((s, _), tys)) = |
311 if s = tptp_fun_type then to_afun to_thf to_thf tys else to_atype ty |
324 if s = tptp_fun_type then to_afun to_ho to_ho tys else to_atype ty |
312 in if format = THF then to_thf else to_tff ary end |
325 in if higher_order then to_ho else to_fo ary end |
313 |
326 |
314 fun mangled_type format pred_sym ary = |
327 fun mangled_type higher_order pred_sym ary = |
315 ho_type_from_fo_term format pred_sym ary o fo_term_from_typ format |
328 ho_type_from_fo_term higher_order pred_sym ary o fo_term_from_typ higher_order |
316 |
329 |
317 fun mangled_const_name format T_args (s, s') = |
330 fun mangled_const_name T_args (s, s') = |
318 let |
331 let |
319 val ty_args = map (fo_term_from_typ format) T_args |
332 val ty_args = map (fo_term_from_typ false) T_args |
320 fun type_suffix f g = |
333 fun type_suffix f g = |
321 fold_rev (curry (op ^) o g o prefix mangled_type_sep |
334 fold_rev (curry (op ^) o g o prefix mangled_type_sep |
322 o generic_mangled_type_name f) ty_args "" |
335 o generic_mangled_type_name f) ty_args "" |
323 in (s ^ type_suffix fst ascii_of, s' ^ type_suffix snd I) end |
336 in (s ^ type_suffix fst ascii_of, s' ^ type_suffix snd I) end |
324 |
337 |
343 fun unmangled_const s = |
356 fun unmangled_const s = |
344 let val ss = space_explode mangled_type_sep s in |
357 let val ss = space_explode mangled_type_sep s in |
345 (hd ss, map unmangled_type (tl ss)) |
358 (hd ss, map unmangled_type (tl ss)) |
346 end |
359 end |
347 |
360 |
348 fun introduce_proxies format tm = |
361 fun introduce_proxies format type_sys tm = |
349 let |
362 let |
350 fun aux ary top_level (CombApp (tm1, tm2)) = |
363 fun aux ary top_level (CombApp (tm1, tm2)) = |
351 CombApp (aux (ary + 1) top_level tm1, aux 0 false tm2) |
364 CombApp (aux (ary + 1) top_level tm1, aux 0 false tm2) |
352 | aux ary top_level (CombConst (name as (s, s'), T, T_args)) = |
365 | aux ary top_level (CombConst (name as (s, s'), T, T_args)) = |
353 (case proxify_const s of |
366 (case proxify_const s of |
354 SOME proxy_base => |
367 SOME proxy_base => |
355 (* Proxies are not needed in THF, except for partially applied |
368 (* Proxies are not needed in THF, except for partially applied |
356 equality since THF does not provide any syntax for it. *) |
369 equality since THF does not provide any syntax for it. *) |
357 if top_level orelse |
370 if top_level orelse |
358 (format = THF andalso (s <> "equal" orelse ary = 2)) then |
371 (is_setting_higher_order format type_sys andalso |
|
372 (s <> "equal" orelse ary = 2)) then |
359 (case s of |
373 (case s of |
360 "c_False" => (tptp_false, s') |
374 "c_False" => (tptp_false, s') |
361 | "c_True" => (tptp_true, s') |
375 | "c_True" => (tptp_true, s') |
362 | _ => name, []) |
376 | _ => name, []) |
363 else |
377 else |
365 | NONE => (name, T_args)) |
379 | NONE => (name, T_args)) |
366 |> (fn (name, T_args) => CombConst (name, T, T_args)) |
380 |> (fn (name, T_args) => CombConst (name, T, T_args)) |
367 | aux _ _ tm = tm |
381 | aux _ _ tm = tm |
368 in aux 0 true tm end |
382 in aux 0 true tm end |
369 |
383 |
370 fun combformula_from_prop thy format eq_as_iff = |
384 fun combformula_from_prop thy format type_sys eq_as_iff = |
371 let |
385 let |
372 fun do_term bs t atomic_types = |
386 fun do_term bs t atomic_types = |
373 combterm_from_term thy bs (Envir.eta_contract t) |
387 combterm_from_term thy bs (Envir.eta_contract t) |
374 |>> (introduce_proxies format #> AAtom) |
388 |>> (introduce_proxies format type_sys #> AAtom) |
375 ||> union (op =) atomic_types |
389 ||> union (op =) atomic_types |
376 fun do_quant bs q s T t' = |
390 fun do_quant bs q s T t' = |
377 let val s = Name.variant (map fst bs) s in |
391 let val s = Name.variant (map fst bs) s in |
378 do_formula ((s, T) :: bs) t' |
392 do_formula ((s, T) :: bs) t' |
379 #>> mk_aquant q [(`make_bound_var s, SOME T)] |
393 #>> mk_aquant q [(`make_bound_var s, SOME T)] |
481 |> presimp ? presimplify_term ctxt |
495 |> presimp ? presimplify_term ctxt |
482 |> perhaps (try (HOLogic.dest_Trueprop)) |
496 |> perhaps (try (HOLogic.dest_Trueprop)) |
483 |> introduce_combinators_in_term ctxt kind |
497 |> introduce_combinators_in_term ctxt kind |
484 |> kind <> Axiom ? freeze_term |
498 |> kind <> Axiom ? freeze_term |
485 val (combformula, atomic_types) = |
499 val (combformula, atomic_types) = |
486 combformula_from_prop thy format eq_as_iff t [] |
500 combformula_from_prop thy format type_sys eq_as_iff t [] |
487 in |
501 in |
488 {name = name, locality = loc, kind = kind, combformula = combformula, |
502 {name = name, locality = loc, kind = kind, combformula = combformula, |
489 atomic_types = atomic_types} |
503 atomic_types = atomic_types} |
490 end |
504 end |
491 |
505 |
492 fun make_fact ctxt format keep_trivial eq_as_iff presimp ((name, loc), t) = |
506 fun make_fact ctxt format type_sys keep_trivial eq_as_iff presimp |
|
507 ((name, loc), t) = |
493 case (keep_trivial, |
508 case (keep_trivial, |
494 make_formula ctxt format eq_as_iff presimp name loc Axiom t) of |
509 make_formula ctxt format type_sys eq_as_iff presimp name loc Axiom t) of |
495 (false, {combformula = AAtom (CombConst (("c_True", _), _, _)), ...}) => |
510 (false, {combformula = AAtom (CombConst (("c_True", _), _, _)), ...}) => |
496 NONE |
511 NONE |
497 | (_, formula) => SOME formula |
512 | (_, formula) => SOME formula |
498 |
513 |
499 fun make_conjecture ctxt format prem_kind ts = |
514 fun make_conjecture ctxt format prem_kind type_sys ts = |
500 let val last = length ts - 1 in |
515 let val last = length ts - 1 in |
501 map2 (fn j => fn t => |
516 map2 (fn j => fn t => |
502 let |
517 let |
503 val (kind, maybe_negate) = |
518 val (kind, maybe_negate) = |
504 if j = last then |
519 if j = last then |
555 case (site, is_var_or_bound_var u) of |
570 case (site, is_var_or_bound_var u) of |
556 (Eq_Arg, true) => should_encode_type ctxt nonmono_Ts level T |
571 (Eq_Arg, true) => should_encode_type ctxt nonmono_Ts level T |
557 | _ => false) |
572 | _ => false) |
558 | should_tag_with_type _ _ _ _ _ _ = false |
573 | should_tag_with_type _ _ _ _ _ _ = false |
559 |
574 |
560 val homo_infinite_T = @{typ ind} (* any infinite type *) |
575 fun homogenized_type ctxt nonmono_Ts level = |
561 |
576 let |
562 fun homogenized_type ctxt nonmono_Ts level T = |
577 val should_encode = should_encode_type ctxt nonmono_Ts level |
563 if should_encode_type ctxt nonmono_Ts level T then T else homo_infinite_T |
578 fun homo 0 T = if should_encode T then T else homo_infinite_type |
|
579 | homo ary (Type (@{type_name fun}, [T1, T2])) = |
|
580 homo 0 T1 --> homo (ary - 1) T2 |
|
581 | homo _ _ = raise Fail "expected function type" |
|
582 in homo end |
564 |
583 |
565 (** "hBOOL" and "hAPP" **) |
584 (** "hBOOL" and "hAPP" **) |
566 |
585 |
567 type sym_info = |
586 type sym_info = |
568 {pred_sym : bool, min_ary : int, max_ary : int, typ : typ option} |
587 {pred_sym : bool, min_ary : int, max_ary : int, typ : typ option} |
725 in |
744 in |
726 case type_arg_policy type_sys s'' of |
745 case type_arg_policy type_sys s'' of |
727 Explicit_Type_Args drop_args => |
746 Explicit_Type_Args drop_args => |
728 (name, filtered_T_args drop_args) |
747 (name, filtered_T_args drop_args) |
729 | Mangled_Type_Args drop_args => |
748 | Mangled_Type_Args drop_args => |
730 (mangled_const_name format (filtered_T_args drop_args) name, |
749 (mangled_const_name (filtered_T_args drop_args) name, []) |
731 []) |
|
732 | No_Type_Args => (name, []) |
750 | No_Type_Args => (name, []) |
733 end) |
751 end) |
734 |> (fn (name, T_args) => CombConst (name, T, T_args)) |
752 |> (fn (name, T_args) => CombConst (name, T, T_args)) |
735 end |
753 end |
736 | aux _ tm = tm |
754 | aux _ tm = tm |
737 in aux 0 end |
755 in aux 0 end |
738 |
756 |
739 fun repair_combterm ctxt format nonmono_Ts type_sys sym_tab = |
757 fun repair_combterm ctxt format nonmono_Ts type_sys sym_tab = |
740 format <> THF ? (introduce_explicit_apps_in_combterm sym_tab |
758 not (is_setting_higher_order format type_sys) |
741 #> introduce_predicators_in_combterm sym_tab) |
759 ? (introduce_explicit_apps_in_combterm sym_tab |
742 #> enforce_type_arg_policy_in_combterm ctxt format nonmono_Ts type_sys |
760 #> introduce_predicators_in_combterm sym_tab) |
|
761 #> enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys |
743 fun repair_fact ctxt format nonmono_Ts type_sys sym_tab = |
762 fun repair_fact ctxt format nonmono_Ts type_sys sym_tab = |
744 update_combformula (formula_map |
763 update_combformula (formula_map |
745 (repair_combterm ctxt format nonmono_Ts type_sys sym_tab)) |
764 (repair_combterm ctxt format nonmono_Ts type_sys sym_tab)) |
746 |
765 |
747 (** Helper facts **) |
766 (** Helper facts **) |
814 val goal_t = Logic.list_implies (hyp_ts, concl_t) |
833 val goal_t = Logic.list_implies (hyp_ts, concl_t) |
815 val all_ts = goal_t :: fact_ts |
834 val all_ts = goal_t :: fact_ts |
816 val subs = tfree_classes_of_terms all_ts |
835 val subs = tfree_classes_of_terms all_ts |
817 val supers = tvar_classes_of_terms all_ts |
836 val supers = tvar_classes_of_terms all_ts |
818 val tycons = type_consts_of_terms thy all_ts |
837 val tycons = type_consts_of_terms thy all_ts |
819 val conjs = make_conjecture ctxt format prem_kind (hyp_ts @ [concl_t]) |
838 val conjs = |
|
839 hyp_ts @ [concl_t] |> make_conjecture ctxt format prem_kind type_sys |
820 val (supers', arity_clauses) = |
840 val (supers', arity_clauses) = |
821 if level_of_type_sys type_sys = No_Types then ([], []) |
841 if level_of_type_sys type_sys = No_Types then ([], []) |
822 else make_arity_clauses thy tycons supers |
842 else make_arity_clauses thy tycons supers |
823 val class_rel_clauses = make_class_rel_clauses thy subs supers' |
843 val class_rel_clauses = make_class_rel_clauses thy subs supers' |
824 in |
844 in |
830 | fo_literal_from_type_literal (TyLitFree (class, name)) = |
850 | fo_literal_from_type_literal (TyLitFree (class, name)) = |
831 (true, ATerm (class, [ATerm (name, [])])) |
851 (true, ATerm (class, [ATerm (name, [])])) |
832 |
852 |
833 fun formula_from_fo_literal (pos, t) = AAtom t |> not pos ? mk_anot |
853 fun formula_from_fo_literal (pos, t) = AAtom t |> not pos ? mk_anot |
834 |
854 |
835 fun type_pred_combterm ctxt format nonmono_Ts type_sys T tm = |
855 fun type_pred_combterm ctxt nonmono_Ts type_sys T tm = |
836 CombApp (CombConst (`make_fixed_const type_pred_name, T --> @{typ bool}, [T]) |
856 CombApp (CombConst (`make_fixed_const type_pred_name, T --> @{typ bool}, [T]) |
837 |> enforce_type_arg_policy_in_combterm ctxt format nonmono_Ts |
857 |> enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys, |
838 type_sys, |
|
839 tm) |
858 tm) |
840 |
859 |
841 fun var_occurs_positively_naked_in_term _ (SOME false) _ accum = accum |
860 fun var_occurs_positively_naked_in_term _ (SOME false) _ accum = accum |
842 | var_occurs_positively_naked_in_term name _ (ATerm ((s, _), tms)) accum = |
861 | var_occurs_positively_naked_in_term name _ (ATerm ((s, _), tms)) accum = |
843 accum orelse (s = "equal" andalso member (op =) tms (ATerm (name, []))) |
862 accum orelse (s = "equal" andalso member (op =) tms (ATerm (name, []))) |
844 fun is_var_nonmonotonic_in_formula _ _ (SOME false) _ = false |
863 fun is_var_nonmonotonic_in_formula _ _ (SOME false) _ = false |
845 | is_var_nonmonotonic_in_formula pos phi _ name = |
864 | is_var_nonmonotonic_in_formula pos phi _ name = |
846 formula_fold pos (var_occurs_positively_naked_in_term name) phi false |
865 formula_fold pos (var_occurs_positively_naked_in_term name) phi false |
847 |
866 |
|
867 fun mk_const_aterm x T_args args = |
|
868 ATerm (x, map (fo_term_from_typ false) T_args @ args) |
|
869 |
848 fun tag_with_type ctxt format nonmono_Ts type_sys T tm = |
870 fun tag_with_type ctxt format nonmono_Ts type_sys T tm = |
849 CombConst (`make_fixed_const type_tag_name, T --> T, [T]) |
871 CombConst (`make_fixed_const type_tag_name, T --> T, [T]) |
850 |> enforce_type_arg_policy_in_combterm ctxt format nonmono_Ts type_sys |
872 |> enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys |
851 |> term_from_combterm ctxt format nonmono_Ts type_sys Top_Level |
873 |> term_from_combterm ctxt format nonmono_Ts type_sys Top_Level |
852 |> (fn ATerm (s, tms) => ATerm (s, tms @ [tm])) |
874 |> (fn ATerm (s, tms) => ATerm (s, tms @ [tm])) |
853 and term_from_combterm ctxt format nonmono_Ts type_sys = |
875 and term_from_combterm ctxt format nonmono_Ts type_sys = |
854 let |
876 let |
855 fun aux site u = |
877 fun aux site u = |
860 CombConst (name, _, T_args) => (name, T_args) |
882 CombConst (name, _, T_args) => (name, T_args) |
861 | CombVar (name, _) => (name, []) |
883 | CombVar (name, _) => (name, []) |
862 | CombApp _ => raise Fail "impossible \"CombApp\"" |
884 | CombApp _ => raise Fail "impossible \"CombApp\"" |
863 val arg_site = if site = Top_Level andalso s = "equal" then Eq_Arg |
885 val arg_site = if site = Top_Level andalso s = "equal" then Eq_Arg |
864 else Elsewhere |
886 else Elsewhere |
865 val t = ATerm (x, map (fo_term_from_typ format) T_args @ |
887 val t = mk_const_aterm x T_args (map (aux arg_site) args) |
866 map (aux arg_site) args) |
|
867 val T = combtyp_of u |
888 val T = combtyp_of u |
868 in |
889 in |
869 t |> (if should_tag_with_type ctxt nonmono_Ts type_sys site u T then |
890 t |> (if should_tag_with_type ctxt nonmono_Ts type_sys site u T then |
870 tag_with_type ctxt format nonmono_Ts type_sys T |
891 tag_with_type ctxt format nonmono_Ts type_sys T |
871 else |
892 else |
873 end |
894 end |
874 in aux end |
895 in aux end |
875 and formula_from_combformula ctxt format nonmono_Ts type_sys |
896 and formula_from_combformula ctxt format nonmono_Ts type_sys |
876 should_predicate_on_var = |
897 should_predicate_on_var = |
877 let |
898 let |
|
899 val higher_order = is_setting_higher_order format type_sys |
878 val do_term = term_from_combterm ctxt format nonmono_Ts type_sys Top_Level |
900 val do_term = term_from_combterm ctxt format nonmono_Ts type_sys Top_Level |
879 val do_bound_type = |
901 val do_bound_type = |
880 case type_sys of |
902 case type_sys of |
881 Simple_Types level => |
903 Simple_Types level => |
882 homogenized_type ctxt nonmono_Ts level |
904 homogenized_type ctxt nonmono_Ts level 0 |
883 #> mangled_type format false 0 #> SOME |
905 #> mangled_type higher_order false 0 #> SOME |
884 | _ => K NONE |
906 | _ => K NONE |
885 fun do_out_of_bound_type pos phi universal (name, T) = |
907 fun do_out_of_bound_type pos phi universal (name, T) = |
886 if should_predicate_on_type ctxt nonmono_Ts type_sys |
908 if should_predicate_on_type ctxt nonmono_Ts type_sys |
887 (fn () => should_predicate_on_var pos phi universal name) T then |
909 (fn () => should_predicate_on_var pos phi universal name) T then |
888 CombVar (name, T) |
910 CombVar (name, T) |
889 |> type_pred_combterm ctxt format nonmono_Ts type_sys T |
911 |> type_pred_combterm ctxt nonmono_Ts type_sys T |
890 |> do_term |> AAtom |> SOME |
912 |> do_term |> AAtom |> SOME |
891 else |
913 else |
892 NONE |
914 NONE |
893 fun do_formula pos (AQuant (q, xs, phi)) = |
915 fun do_formula pos (AQuant (q, xs, phi)) = |
894 let |
916 let |
1054 |> insert_type ctxt I @{typ bool} |
1076 |> insert_type ctxt I @{typ bool} |
1055 else |
1077 else |
1056 [] |
1078 [] |
1057 end |
1079 end |
1058 |
1080 |
1059 fun decl_line_for_sym ctxt format nonmono_Ts level s |
1081 fun decl_line_for_sym ctxt format nonmono_Ts type_sys s |
1060 (s', _, T, pred_sym, ary, _) = |
1082 (s', T_args, T, pred_sym, ary, _) = |
1061 Decl (sym_decl_prefix ^ s, (s, s'), |
1083 let |
1062 T |> homogenized_type ctxt nonmono_Ts level |
1084 val (higher_order, T_arg_Ts, level) = |
1063 |> mangled_type format pred_sym ary) |
1085 case type_sys of |
|
1086 Simple_Types level => (format = THF, [], level) |
|
1087 | _ => (false, replicate (length T_args) homo_infinite_type, No_Types) |
|
1088 in |
|
1089 Decl (type_decl_prefix ^ s, (s, s'), |
|
1090 (T_arg_Ts ---> (T |> homogenized_type ctxt nonmono_Ts level ary)) |
|
1091 |> mangled_type higher_order pred_sym (length T_arg_Ts + ary)) |
|
1092 end |
1064 |
1093 |
1065 fun is_polymorphic_type T = fold_atyps (fn TVar _ => K true | _ => I) T false |
1094 fun is_polymorphic_type T = fold_atyps (fn TVar _ => K true | _ => I) T false |
1066 |
1095 |
1067 fun formula_line_for_pred_sym_decl ctxt format conj_sym_kind nonmono_Ts type_sys |
1096 fun formula_line_for_pred_sym_decl ctxt format conj_sym_kind nonmono_Ts type_sys |
1068 n s j (s', T_args, T, _, ary, in_conj) = |
1097 n s j (s', T_args, T, _, ary, in_conj) = |
1081 in |
1110 in |
1082 Formula (sym_decl_prefix ^ s ^ |
1111 Formula (sym_decl_prefix ^ s ^ |
1083 (if n > 1 then "_" ^ string_of_int j else ""), kind, |
1112 (if n > 1 then "_" ^ string_of_int j else ""), kind, |
1084 CombConst ((s, s'), T, T_args) |
1113 CombConst ((s, s'), T, T_args) |
1085 |> fold (curry (CombApp o swap)) bounds |
1114 |> fold (curry (CombApp o swap)) bounds |
1086 |> type_pred_combterm ctxt format nonmono_Ts type_sys res_T |
1115 |> type_pred_combterm ctxt nonmono_Ts type_sys res_T |
1087 |> AAtom |> mk_aquant AForall (bound_names ~~ bound_Ts) |
1116 |> AAtom |> mk_aquant AForall (bound_names ~~ bound_Ts) |
1088 |> formula_from_combformula ctxt format nonmono_Ts type_sys |
1117 |> formula_from_combformula ctxt format nonmono_Ts type_sys |
1089 (K (K (K (K true)))) true |
1118 (K (K (K (K true)))) true |
1090 |> n > 1 ? bound_atomic_types format type_sys (atyps_of T) |
1119 |> n > 1 ? bound_atomic_types format type_sys (atyps_of T) |
1091 |> close_formula_universally |
1120 |> close_formula_universally |
1103 else (Axiom, I) |
1132 else (Axiom, I) |
1104 val (arg_Ts, res_T) = chop_fun ary T |
1133 val (arg_Ts, res_T) = chop_fun ary T |
1105 val bound_names = |
1134 val bound_names = |
1106 1 upto length arg_Ts |> map (`I o make_bound_var o string_of_int) |
1135 1 upto length arg_Ts |> map (`I o make_bound_var o string_of_int) |
1107 val bounds = bound_names |> map (fn name => ATerm (name, [])) |
1136 val bounds = bound_names |> map (fn name => ATerm (name, [])) |
1108 fun const args = |
1137 val cst = mk_const_aterm (s, s') T_args |
1109 ATerm ((s, s'), map (fo_term_from_typ format) T_args @ args) |
|
1110 val atomic_Ts = atyps_of T |
1138 val atomic_Ts = atyps_of T |
1111 fun eq tms = |
1139 fun eq tms = |
1112 (if pred_sym then AConn (AIff, map AAtom tms) |
1140 (if pred_sym then AConn (AIff, map AAtom tms) |
1113 else AAtom (ATerm (`I "equal", tms))) |
1141 else AAtom (ATerm (`I "equal", tms))) |
1114 |> bound_atomic_types format type_sys atomic_Ts |
1142 |> bound_atomic_types format type_sys atomic_Ts |
1117 val should_encode = should_encode_type ctxt nonmono_Ts All_Types |
1145 val should_encode = should_encode_type ctxt nonmono_Ts All_Types |
1118 val tag_with = tag_with_type ctxt format nonmono_Ts type_sys |
1146 val tag_with = tag_with_type ctxt format nonmono_Ts type_sys |
1119 val add_formula_for_res = |
1147 val add_formula_for_res = |
1120 if should_encode res_T then |
1148 if should_encode res_T then |
1121 cons (Formula (ident_base ^ "_res", kind, |
1149 cons (Formula (ident_base ^ "_res", kind, |
1122 eq [tag_with res_T (const bounds), const bounds], |
1150 eq [tag_with res_T (cst bounds), cst bounds], |
1123 simp_info, NONE)) |
1151 simp_info, NONE)) |
1124 else |
1152 else |
1125 I |
1153 I |
1126 fun add_formula_for_arg k = |
1154 fun add_formula_for_arg k = |
1127 let val arg_T = nth arg_Ts k in |
1155 let val arg_T = nth arg_Ts k in |
1128 if should_encode arg_T then |
1156 if should_encode arg_T then |
1129 case chop k bounds of |
1157 case chop k bounds of |
1130 (bounds1, bound :: bounds2) => |
1158 (bounds1, bound :: bounds2) => |
1131 cons (Formula (ident_base ^ "_arg" ^ string_of_int (k + 1), kind, |
1159 cons (Formula (ident_base ^ "_arg" ^ string_of_int (k + 1), kind, |
1132 eq [const (bounds1 @ tag_with arg_T bound :: |
1160 eq [cst (bounds1 @ tag_with arg_T bound :: bounds2), |
1133 bounds2), |
1161 cst bounds], |
1134 const bounds], |
|
1135 simp_info, NONE)) |
1162 simp_info, NONE)) |
1136 | _ => raise Fail "expected nonempty tail" |
1163 | _ => raise Fail "expected nonempty tail" |
1137 else |
1164 else |
1138 I |
1165 I |
1139 end |
1166 end |
1144 |
1171 |
1145 fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd |
1172 fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd |
1146 |
1173 |
1147 fun problem_lines_for_sym_decls ctxt format conj_sym_kind nonmono_Ts type_sys |
1174 fun problem_lines_for_sym_decls ctxt format conj_sym_kind nonmono_Ts type_sys |
1148 (s, decls) = |
1175 (s, decls) = |
1149 case type_sys of |
1176 (if member (op =) [TFF, THF] format then |
1150 Simple_Types level => |
1177 decls |> map (decl_line_for_sym ctxt format nonmono_Ts type_sys s) |
1151 map (decl_line_for_sym ctxt format nonmono_Ts level s) decls |
1178 else |
1152 | Preds _ => |
1179 []) @ |
1153 let |
1180 (case type_sys of |
1154 val decls = |
1181 Simple_Types _ => [] |
1155 case decls of |
1182 | Preds _ => |
1156 decl :: (decls' as _ :: _) => |
1183 let |
1157 let val T = result_type_of_decl decl in |
1184 val decls = |
1158 if forall (curry (type_instance ctxt o swap) T |
1185 case decls of |
1159 o result_type_of_decl) decls' then |
1186 decl :: (decls' as _ :: _) => |
1160 [decl] |
1187 let val T = result_type_of_decl decl in |
1161 else |
1188 if forall (curry (type_instance ctxt o swap) T |
1162 decls |
1189 o result_type_of_decl) decls' then |
1163 end |
1190 [decl] |
1164 | _ => decls |
1191 else |
1165 val n = length decls |
1192 decls |
1166 val decls = |
1193 end |
1167 decls |
1194 | _ => decls |
1168 |> filter (should_predicate_on_type ctxt nonmono_Ts type_sys (K true) |
1195 val n = length decls |
1169 o result_type_of_decl) |
1196 val decls = |
1170 in |
1197 decls |
1171 (0 upto length decls - 1, decls) |
1198 |> filter (should_predicate_on_type ctxt nonmono_Ts type_sys (K true) |
1172 |-> map2 (formula_line_for_pred_sym_decl ctxt format conj_sym_kind |
1199 o result_type_of_decl) |
1173 nonmono_Ts type_sys n s) |
1200 in |
1174 end |
1201 (0 upto length decls - 1, decls) |
1175 | Tags (_, _, heaviness) => |
1202 |-> map2 (formula_line_for_pred_sym_decl ctxt format conj_sym_kind |
1176 (case heaviness of |
1203 nonmono_Ts type_sys n s) |
1177 Heavy => [] |
1204 end |
1178 | Light => |
1205 | Tags (_, _, heaviness) => |
1179 let val n = length decls in |
1206 (case heaviness of |
1180 (0 upto n - 1 ~~ decls) |
1207 Heavy => [] |
1181 |> maps (formula_lines_for_tag_sym_decl ctxt format conj_sym_kind |
1208 | Light => |
1182 nonmono_Ts type_sys n s) |
1209 let val n = length decls in |
1183 end) |
1210 (0 upto n - 1 ~~ decls) |
|
1211 |> maps (formula_lines_for_tag_sym_decl ctxt format conj_sym_kind |
|
1212 nonmono_Ts type_sys n s) |
|
1213 end)) |
1184 |
1214 |
1185 fun problem_lines_for_sym_decl_table ctxt format conj_sym_kind nonmono_Ts |
1215 fun problem_lines_for_sym_decl_table ctxt format conj_sym_kind nonmono_Ts |
1186 type_sys sym_decl_tab = |
1216 type_sys sym_decl_tab = |
1187 Symtab.fold_rev |
1217 Symtab.fold_rev |
1188 (append o problem_lines_for_sym_decls ctxt format conj_sym_kind nonmono_Ts |
1218 (append o problem_lines_for_sym_decls ctxt format conj_sym_kind nonmono_Ts |