src/HOL/Tools/Sledgehammer/sledgehammer_atp_translate.ML
changeset 42994 fe291ab75eb5
parent 42966 4e2d6c1e5392
child 42998 1c80902d0456
equal deleted inserted replaced
42993:da014b00d7a4 42994:fe291ab75eb5
    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
    97 val app_op_name = "hAPP"
    97 val app_op_name = "hAPP"
    98 val type_pred_name = "is"
    98 val type_pred_name = "is"
    99 val simple_type_prefix = "ty_"
    99 val simple_type_prefix = "ty_"
   100 
   100 
   101 fun make_simple_type s =
   101 fun make_simple_type s =
   102   if s = tptp_bool_type orelse s = tptp_fun_type then s
   102   if s = tptp_bool_type orelse s = tptp_fun_type orelse
   103   else simple_type_prefix ^ ascii_of s
   103      s = tptp_individual_type then
       
   104     s
       
   105   else
       
   106     simple_type_prefix ^ ascii_of s
   104 
   107 
   105 (* Freshness almost guaranteed! *)
   108 (* Freshness almost guaranteed! *)
   106 val sledgehammer_weak_prefix = "Sledgehammer:"
   109 val sledgehammer_weak_prefix = "Sledgehammer:"
   107 
   110 
   108 datatype polymorphism = Polymorphic | Monomorphic | Mangled_Monomorphic
   111 datatype polymorphism = Polymorphic | Monomorphic | Mangled_Monomorphic
   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)]
   465         Free (sledgehammer_weak_prefix ^ s ^ "_" ^ string_of_int i, T)
   479         Free (sledgehammer_weak_prefix ^ s ^ "_" ^ string_of_int i, T)
   466       | aux t = t
   480       | aux t = t
   467   in t |> exists_subterm is_Var t ? aux end
   481   in t |> exists_subterm is_Var t ? aux end
   468 
   482 
   469 (* making fact and conjecture formulas *)
   483 (* making fact and conjecture formulas *)
   470 fun make_formula ctxt format eq_as_iff presimp name loc kind t =
   484 fun make_formula ctxt format type_sys eq_as_iff presimp name loc kind t =
   471   let
   485   let
   472     val thy = Proof_Context.theory_of ctxt
   486     val thy = Proof_Context.theory_of ctxt
   473     val t = t |> Envir.beta_eta_contract
   487     val t = t |> Envir.beta_eta_contract
   474               |> transform_elim_prop
   488               |> transform_elim_prop
   475               |> Object_Logic.atomize_term thy
   489               |> Object_Logic.atomize_term thy
   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
   506                  else
   521                  else
   507                    (prem_kind,
   522                    (prem_kind,
   508                     if prem_kind = Conjecture then update_combformula mk_anot
   523                     if prem_kind = Conjecture then update_combformula mk_anot
   509                     else I)
   524                     else I)
   510               in
   525               in
   511                 t |> make_formula ctxt format true true (string_of_int j)
   526                 t |> make_formula ctxt format type_sys true true
   512                                   General kind
   527                                   (string_of_int j) General kind
   513                   |> maybe_negate
   528                   |> maybe_negate
   514               end)
   529               end)
   515          (0 upto last) ts
   530          (0 upto last) ts
   516   end
   531   end
   517 
   532 
   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}
   689                               NONE)
   708                               NONE)
   690         end
   709         end
   691     end
   710     end
   692     handle TYPE _ => T_args
   711     handle TYPE _ => T_args
   693 
   712 
   694 fun enforce_type_arg_policy_in_combterm ctxt format nonmono_Ts type_sys =
   713 fun enforce_type_arg_policy_in_combterm ctxt nonmono_Ts type_sys =
   695   let
   714   let
   696     val thy = Proof_Context.theory_of ctxt
   715     val thy = Proof_Context.theory_of ctxt
   697     fun aux arity (CombApp (tm1, tm2)) =
   716     fun aux arity (CombApp (tm1, tm2)) =
   698         CombApp (aux (arity + 1) tm1, aux 0 tm2)
   717         CombApp (aux (arity + 1) tm1, aux 0 tm2)
   699       | aux arity (CombConst (name as (s, _), T, T_args)) =
   718       | aux arity (CombConst (name as (s, _), T, T_args)) =
   706                since it leads to too many unsound proofs. *)
   725                since it leads to too many unsound proofs. *)
   707             if s = const_prefix ^ app_op_name andalso
   726             if s = const_prefix ^ app_op_name andalso
   708                length T_args = 2 andalso
   727                length T_args = 2 andalso
   709                not (is_type_sys_virtually_sound type_sys) andalso
   728                not (is_type_sys_virtually_sound type_sys) andalso
   710                heaviness_of_type_sys type_sys = Heavy then
   729                heaviness_of_type_sys type_sys = Heavy then
   711               T_args |> map (homogenized_type ctxt nonmono_Ts level)
   730               T_args |> map (homogenized_type ctxt nonmono_Ts level 0)
   712                      |> (fn Ts => let val T = hd Ts --> nth Ts 1 in
   731                      |> (fn Ts => let val T = hd Ts --> nth Ts 1 in
   713                                     (T --> T, tl Ts)
   732                                     (T --> T, tl Ts)
   714                                   end)
   733                                   end)
   715             else
   734             else
   716               (T, T_args)
   735               (T, T_args)
   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 **)
   775                 ? (case typ of
   794                 ? (case typ of
   776                      SOME T => specialize_type thy (invert_const unmangled_s, T)
   795                      SOME T => specialize_type thy (invert_const unmangled_s, T)
   777                    | NONE => I)
   796                    | NONE => I)
   778          end)
   797          end)
   779       fun make_facts eq_as_iff =
   798       fun make_facts eq_as_iff =
   780         map_filter (make_fact ctxt format false eq_as_iff false)
   799         map_filter (make_fact ctxt format type_sys false eq_as_iff false)
   781       val fairly_sound = is_type_sys_fairly_sound type_sys
   800       val fairly_sound = is_type_sys_fairly_sound type_sys
   782     in
   801     in
   783       metis_helpers
   802       metis_helpers
   784       |> maps (fn (metis_s, (needs_fairly_sound, ths)) =>
   803       |> maps (fn (metis_s, (needs_fairly_sound, ths)) =>
   785                   if metis_s <> unmangled_s orelse
   804                   if metis_s <> unmangled_s orelse
   793   | NONE => []
   812   | NONE => []
   794 fun helper_facts_for_sym_table ctxt format type_sys sym_tab =
   813 fun helper_facts_for_sym_table ctxt format type_sys sym_tab =
   795   Symtab.fold_rev (append o helper_facts_for_sym ctxt format type_sys) sym_tab
   814   Symtab.fold_rev (append o helper_facts_for_sym ctxt format type_sys) sym_tab
   796                   []
   815                   []
   797 
   816 
   798 fun translate_atp_fact ctxt format keep_trivial =
   817 fun translate_atp_fact ctxt format type_sys keep_trivial =
   799   `(make_fact ctxt format keep_trivial true true o apsnd prop_of)
   818   `(make_fact ctxt format type_sys keep_trivial true true o apsnd prop_of)
   800 
   819 
   801 fun translate_formulas ctxt format prem_kind type_sys hyp_ts concl_t
   820 fun translate_formulas ctxt format prem_kind type_sys hyp_ts concl_t
   802                        rich_facts =
   821                        rich_facts =
   803   let
   822   let
   804     val thy = Proof_Context.theory_of ctxt
   823     val thy = Proof_Context.theory_of ctxt
   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