src/HOL/Tools/Sledgehammer/sledgehammer_atp_translate.ML
changeset 42956 9aeb0f6ad971
parent 42951 40bf0173fbed
child 42962 3b50fdeb6cfc
equal deleted inserted replaced
42955:576bd30cc4ea 42956:9aeb0f6ad971
   238       level_of_type_sys type_sys = Const_Arg_Types) then
   238       level_of_type_sys type_sys = Const_Arg_Types) then
   239     No_Type_Args
   239     No_Type_Args
   240   else
   240   else
   241     general_type_arg_policy type_sys
   241     general_type_arg_policy type_sys
   242 
   242 
   243 fun atp_type_literals_for_types type_sys kind Ts =
   243 fun atp_type_literals_for_types format type_sys kind Ts =
   244   if level_of_type_sys type_sys = No_Types then
   244   if level_of_type_sys type_sys = No_Types orelse format = CNF_UEQ then
   245     []
   245     []
   246   else
   246   else
   247     Ts |> type_literals_for_types
   247     Ts |> type_literals_for_types
   248        |> filter (fn TyLitVar _ => kind <> Conjecture
   248        |> filter (fn TyLitVar _ => kind <> Conjecture
   249                    | TyLitFree _ => kind = Conjecture)
   249                    | TyLitFree _ => kind = Conjecture)
   878         end
   878         end
   879       | do_formula pos (AConn conn) = aconn_map pos do_formula conn
   879       | do_formula pos (AConn conn) = aconn_map pos do_formula conn
   880       | do_formula _ (AAtom tm) = AAtom (do_term tm)
   880       | do_formula _ (AAtom tm) = AAtom (do_term tm)
   881   in do_formula o SOME end
   881   in do_formula o SOME end
   882 
   882 
   883 fun bound_atomic_types type_sys Ts =
   883 fun bound_atomic_types format type_sys Ts =
   884   mk_ahorn (map (formula_from_fo_literal o fo_literal_from_type_literal)
   884   mk_ahorn (map (formula_from_fo_literal o fo_literal_from_type_literal)
   885                 (atp_type_literals_for_types type_sys Axiom Ts))
   885                 (atp_type_literals_for_types format type_sys Axiom Ts))
   886 
   886 
   887 fun formula_for_fact ctxt nonmono_Ts type_sys
   887 fun formula_for_fact ctxt format nonmono_Ts type_sys
   888                      ({combformula, atomic_types, ...} : translated_formula) =
   888                      ({combformula, atomic_types, ...} : translated_formula) =
   889   combformula
   889   combformula
   890   |> close_combformula_universally
   890   |> close_combformula_universally
   891   |> formula_from_combformula ctxt nonmono_Ts type_sys
   891   |> formula_from_combformula ctxt nonmono_Ts type_sys
   892                               is_var_nonmonotonic_in_formula true
   892                               is_var_nonmonotonic_in_formula true
   893   |> bound_atomic_types type_sys atomic_types
   893   |> bound_atomic_types format type_sys atomic_types
   894   |> close_formula_universally
   894   |> close_formula_universally
   895 
   895 
   896 (* Each fact is given a unique fact number to avoid name clashes (e.g., because
   896 (* Each fact is given a unique fact number to avoid name clashes (e.g., because
   897    of monomorphization). The TPTP explicitly forbids name clashes, and some of
   897    of monomorphization). The TPTP explicitly forbids name clashes, and some of
   898    the remote provers might care. *)
   898    the remote provers might care. *)
   899 fun formula_line_for_fact ctxt prefix nonmono_Ts type_sys
   899 fun formula_line_for_fact ctxt format prefix nonmono_Ts type_sys
   900                           (j, formula as {name, locality, kind, ...}) =
   900                           (j, formula as {name, locality, kind, ...}) =
   901   Formula (prefix ^ (if polymorphism_of_type_sys type_sys = Polymorphic then ""
   901   Formula (prefix ^ (if polymorphism_of_type_sys type_sys = Polymorphic then ""
   902                      else string_of_int j ^ "_") ^
   902                      else string_of_int j ^ "_") ^
   903            ascii_of name,
   903            ascii_of name,
   904            kind, formula_for_fact ctxt nonmono_Ts type_sys formula, NONE,
   904            kind, formula_for_fact ctxt format nonmono_Ts type_sys formula, NONE,
   905            case locality of
   905            case locality of
   906              Intro => intro_info
   906              Intro => intro_info
   907            | Elim => elim_info
   907            | Elim => elim_info
   908            | Simp => simp_info
   908            | Simp => simp_info
   909            | _ => NONE)
   909            | _ => NONE)
   937            formula_from_combformula ctxt nonmono_Ts type_sys
   937            formula_from_combformula ctxt nonmono_Ts type_sys
   938                is_var_nonmonotonic_in_formula false
   938                is_var_nonmonotonic_in_formula false
   939                (close_combformula_universally combformula)
   939                (close_combformula_universally combformula)
   940            |> close_formula_universally, NONE, NONE)
   940            |> close_formula_universally, NONE, NONE)
   941 
   941 
   942 fun free_type_literals type_sys ({atomic_types, ...} : translated_formula) =
   942 fun free_type_literals format type_sys
   943   atomic_types |> atp_type_literals_for_types type_sys Conjecture
   943                        ({atomic_types, ...} : translated_formula) =
       
   944   atomic_types |> atp_type_literals_for_types format type_sys Conjecture
   944                |> map fo_literal_from_type_literal
   945                |> map fo_literal_from_type_literal
   945 
   946 
   946 fun formula_line_for_free_type j lit =
   947 fun formula_line_for_free_type j lit =
   947   Formula (tfree_prefix ^ string_of_int j, Hypothesis,
   948   Formula (tfree_prefix ^ string_of_int j, Hypothesis,
   948            formula_from_fo_literal lit, NONE, NONE)
   949            formula_from_fo_literal lit, NONE, NONE)
   949 fun formula_lines_for_free_types type_sys facts =
   950 fun formula_lines_for_free_types format type_sys facts =
   950   let
   951   let
   951     val litss = map (free_type_literals type_sys) facts
   952     val litss = map (free_type_literals format type_sys) facts
   952     val lits = fold (union (op =)) litss []
   953     val lits = fold (union (op =)) litss []
   953   in map2 formula_line_for_free_type (0 upto length lits - 1) lits end
   954   in map2 formula_line_for_free_type (0 upto length lits - 1) lits end
   954 
   955 
   955 (** Symbol declarations **)
   956 (** Symbol declarations **)
   956 
   957 
  1037           if pred_sym then `I tptp_tff_bool_type else res_ty)
  1038           if pred_sym then `I tptp_tff_bool_type else res_ty)
  1038   end
  1039   end
  1039 
  1040 
  1040 fun is_polymorphic_type T = fold_atyps (fn TVar _ => K true | _ => I) T false
  1041 fun is_polymorphic_type T = fold_atyps (fn TVar _ => K true | _ => I) T false
  1041 
  1042 
  1042 fun formula_line_for_pred_sym_decl ctxt conj_sym_kind nonmono_Ts type_sys n s j
  1043 fun formula_line_for_pred_sym_decl ctxt format conj_sym_kind nonmono_Ts type_sys
  1043                                    (s', T_args, T, _, ary, in_conj) =
  1044                                    n s j (s', T_args, T, _, ary, in_conj) =
  1044   let
  1045   let
  1045     val (kind, maybe_negate) =
  1046     val (kind, maybe_negate) =
  1046       if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
  1047       if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
  1047       else (Axiom, I)
  1048       else (Axiom, I)
  1048     val (arg_Ts, res_T) = chop_fun ary T
  1049     val (arg_Ts, res_T) = chop_fun ary T
  1061              |> type_pred_combterm ctxt nonmono_Ts type_sys res_T
  1062              |> type_pred_combterm ctxt nonmono_Ts type_sys res_T
  1062              |> AAtom
  1063              |> AAtom
  1063              |> mk_aquant AForall (bound_names ~~ bound_Ts)
  1064              |> mk_aquant AForall (bound_names ~~ bound_Ts)
  1064              |> formula_from_combformula ctxt nonmono_Ts type_sys
  1065              |> formula_from_combformula ctxt nonmono_Ts type_sys
  1065                                          (K (K (K (K true)))) true
  1066                                          (K (K (K (K true)))) true
  1066              |> n > 1 ? bound_atomic_types type_sys (atyps_of T)
  1067              |> n > 1 ? bound_atomic_types format type_sys (atyps_of T)
  1067              |> close_formula_universally
  1068              |> close_formula_universally
  1068              |> maybe_negate,
  1069              |> maybe_negate,
  1069              intro_info, NONE)
  1070              intro_info, NONE)
  1070   end
  1071   end
  1071 
  1072 
  1072 fun formula_lines_for_tag_sym_decl ctxt conj_sym_kind nonmono_Ts type_sys n s
  1073 fun formula_lines_for_tag_sym_decl ctxt format conj_sym_kind nonmono_Ts type_sys
  1073                                   (j, (s', T_args, T, pred_sym, ary, in_conj)) =
  1074         n s (j, (s', T_args, T, pred_sym, ary, in_conj)) =
  1074   let
  1075   let
  1075     val ident_base =
  1076     val ident_base =
  1076       sym_decl_prefix ^ s ^ (if n > 1 then "_" ^ string_of_int j else "")
  1077       sym_decl_prefix ^ s ^ (if n > 1 then "_" ^ string_of_int j else "")
  1077     val (kind, maybe_negate) =
  1078     val (kind, maybe_negate) =
  1078       if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
  1079       if in_conj then (conj_sym_kind, conj_sym_kind = Conjecture ? mk_anot)
  1084     fun const args = ATerm ((s, s'), map fo_term_from_typ T_args @ args)
  1085     fun const args = ATerm ((s, s'), map fo_term_from_typ T_args @ args)
  1085     val atomic_Ts = atyps_of T
  1086     val atomic_Ts = atyps_of T
  1086     fun eq tms =
  1087     fun eq tms =
  1087       (if pred_sym then AConn (AIff, map AAtom tms)
  1088       (if pred_sym then AConn (AIff, map AAtom tms)
  1088        else AAtom (ATerm (`I "equal", tms)))
  1089        else AAtom (ATerm (`I "equal", tms)))
  1089       |> bound_atomic_types type_sys atomic_Ts
  1090       |> bound_atomic_types format type_sys atomic_Ts
  1090       |> close_formula_universally
  1091       |> close_formula_universally
  1091       |> maybe_negate
  1092       |> maybe_negate
  1092     val should_encode = should_encode_type ctxt nonmono_Ts All_Types
  1093     val should_encode = should_encode_type ctxt nonmono_Ts All_Types
  1093     val tag_with = tag_with_type ctxt nonmono_Ts type_sys
  1094     val tag_with = tag_with_type ctxt nonmono_Ts type_sys
  1094     val add_formula_for_res =
  1095     val add_formula_for_res =
  1117        |> fold add_formula_for_arg (ary - 1 downto 0)
  1118        |> fold add_formula_for_arg (ary - 1 downto 0)
  1118   end
  1119   end
  1119 
  1120 
  1120 fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd
  1121 fun result_type_of_decl (_, _, T, _, ary, _) = chop_fun ary T |> snd
  1121 
  1122 
  1122 fun problem_lines_for_sym_decls ctxt conj_sym_kind nonmono_Ts type_sys
  1123 fun problem_lines_for_sym_decls ctxt format conj_sym_kind nonmono_Ts type_sys
  1123                                 (s, decls) =
  1124                                 (s, decls) =
  1124   case type_sys of
  1125   case type_sys of
  1125     Simple_Types level => map (decl_line_for_sym ctxt nonmono_Ts level s) decls
  1126     Simple_Types level => map (decl_line_for_sym ctxt nonmono_Ts level s) decls
  1126   | Preds _ =>
  1127   | Preds _ =>
  1127     let
  1128     let
  1141         decls
  1142         decls
  1142         |> filter (should_predicate_on_type ctxt nonmono_Ts type_sys (K true)
  1143         |> filter (should_predicate_on_type ctxt nonmono_Ts type_sys (K true)
  1143                    o result_type_of_decl)
  1144                    o result_type_of_decl)
  1144     in
  1145     in
  1145       (0 upto length decls - 1, decls)
  1146       (0 upto length decls - 1, decls)
  1146       |-> map2 (formula_line_for_pred_sym_decl ctxt conj_sym_kind nonmono_Ts
  1147       |-> map2 (formula_line_for_pred_sym_decl ctxt format conj_sym_kind
  1147                                                type_sys n s)
  1148                                                nonmono_Ts type_sys n s)
  1148     end
  1149     end
  1149   | Tags (_, _, heaviness) =>
  1150   | Tags (_, _, heaviness) =>
  1150     (case heaviness of
  1151     (case heaviness of
  1151        Heavy => []
  1152        Heavy => []
  1152      | Light =>
  1153      | Light =>
  1153        let val n = length decls in
  1154        let val n = length decls in
  1154          (0 upto n - 1 ~~ decls)
  1155          (0 upto n - 1 ~~ decls)
  1155          |> maps (formula_lines_for_tag_sym_decl ctxt conj_sym_kind nonmono_Ts
  1156          |> maps (formula_lines_for_tag_sym_decl ctxt format conj_sym_kind
  1156                                                  type_sys n s)
  1157                                                  nonmono_Ts type_sys n s)
  1157        end)
  1158        end)
  1158 
  1159 
  1159 fun problem_lines_for_sym_decl_table ctxt conj_sym_kind nonmono_Ts type_sys
  1160 fun problem_lines_for_sym_decl_table ctxt format conj_sym_kind nonmono_Ts
  1160                                      sym_decl_tab =
  1161                                      type_sys sym_decl_tab =
  1161   Symtab.fold_rev (append o problem_lines_for_sym_decls ctxt conj_sym_kind
  1162   Symtab.fold_rev
  1162                                                         nonmono_Ts type_sys)
  1163       (append o problem_lines_for_sym_decls ctxt format conj_sym_kind nonmono_Ts
  1163                   sym_decl_tab []
  1164                                             type_sys)
       
  1165       sym_decl_tab []
  1164 
  1166 
  1165 fun add_tff_types_in_formula (AQuant (_, xs, phi)) =
  1167 fun add_tff_types_in_formula (AQuant (_, xs, phi)) =
  1166     union (op =) (map_filter snd xs) #> add_tff_types_in_formula phi
  1168     union (op =) (map_filter snd xs) #> add_tff_types_in_formula phi
  1167   | add_tff_types_in_formula (AConn (_, phis)) =
  1169   | add_tff_types_in_formula (AConn (_, phis)) =
  1168     fold add_tff_types_in_formula phis
  1170     fold add_tff_types_in_formula phis
  1216       else
  1218       else
  1217         [TVar (("'a", 0), HOLogic.typeS)]
  1219         [TVar (("'a", 0), HOLogic.typeS)]
  1218     val sym_decl_lines =
  1220     val sym_decl_lines =
  1219       (conjs, helpers @ facts)
  1221       (conjs, helpers @ facts)
  1220       |> sym_decl_table_for_facts ctxt type_sys repaired_sym_tab
  1222       |> sym_decl_table_for_facts ctxt type_sys repaired_sym_tab
  1221       |> problem_lines_for_sym_decl_table ctxt conj_sym_kind lavish_nonmono_Ts
  1223       |> problem_lines_for_sym_decl_table ctxt format conj_sym_kind
  1222                                           type_sys
  1224                                           lavish_nonmono_Ts type_sys
  1223     val helper_lines =
  1225     val helper_lines =
  1224       map (formula_line_for_fact ctxt helper_prefix lavish_nonmono_Ts type_sys)
  1226       0 upto length helpers - 1 ~~ helpers
  1225           (0 upto length helpers - 1 ~~ helpers)
  1227       |> map (formula_line_for_fact ctxt format helper_prefix lavish_nonmono_Ts
  1226       |> (if should_add_ti_ti_helper type_sys then
  1228                                     type_sys)
  1227             cons (ti_ti_helper_fact ())
  1229       |> (if should_add_ti_ti_helper type_sys then cons (ti_ti_helper_fact ())
  1228           else
  1230           else I)
  1229             I)
       
  1230     (* Reordering these might confuse the proof reconstruction code or the SPASS
  1231     (* Reordering these might confuse the proof reconstruction code or the SPASS
  1231        Flotter hack. *)
  1232        Flotter hack. *)
  1232     val problem =
  1233     val problem =
  1233       [(sym_declsN, sym_decl_lines),
  1234       [(sym_declsN, sym_decl_lines),
  1234        (factsN, map (formula_line_for_fact ctxt fact_prefix nonmono_Ts type_sys)
  1235        (factsN,
  1235                     (0 upto length facts - 1 ~~ facts)),
  1236         map (formula_line_for_fact ctxt format fact_prefix nonmono_Ts type_sys)
       
  1237             (0 upto length facts - 1 ~~ facts)),
  1236        (class_relsN, map formula_line_for_class_rel_clause class_rel_clauses),
  1238        (class_relsN, map formula_line_for_class_rel_clause class_rel_clauses),
  1237        (aritiesN, map formula_line_for_arity_clause arity_clauses),
  1239        (aritiesN, map formula_line_for_arity_clause arity_clauses),
  1238        (helpersN, helper_lines),
  1240        (helpersN, helper_lines),
  1239        (conjsN, map (formula_line_for_conjecture ctxt nonmono_Ts type_sys)
  1241        (conjsN, map (formula_line_for_conjecture ctxt nonmono_Ts type_sys)
  1240                     conjs),
  1242                     conjs),
  1241        (free_typesN, formula_lines_for_free_types type_sys (facts @ conjs))]
  1243        (free_typesN,
       
  1244         formula_lines_for_free_types format type_sys (facts @ conjs))]
  1242     val problem =
  1245     val problem =
  1243       problem
  1246       problem
  1244       |> (case type_sys of
  1247       |> (case type_sys of
  1245             Simple_Types _ =>
  1248             Simple_Types _ =>
  1246             cons (type_declsN,
  1249             cons (type_declsN,