move Sledgehammer files in a directory of their own
authorblanchet
Wed Mar 17 18:16:31 2010 +0100 (2010-03-17)
changeset 35825a6aad5a70ed4
parent 35814 234eaa508359
child 35826 1590abc3d42a
move Sledgehammer files in a directory of their own
src/HOL/ATP_Linkup.thy
src/HOL/IsaMakefile
src/HOL/Tools/Sledgehammer/metis_tactics.ML
src/HOL/Tools/Sledgehammer/sledgehammer_fact_filter.ML
src/HOL/Tools/Sledgehammer/sledgehammer_fact_preprocessor.ML
src/HOL/Tools/Sledgehammer/sledgehammer_fol_clause.ML
src/HOL/Tools/Sledgehammer/sledgehammer_hol_clause.ML
src/HOL/Tools/Sledgehammer/sledgehammer_proof_reconstruct.ML
src/HOL/Tools/metis_tools.ML
src/HOL/Tools/res_atp.ML
src/HOL/Tools/res_axioms.ML
src/HOL/Tools/res_clause.ML
src/HOL/Tools/res_hol_clause.ML
src/HOL/Tools/res_reconstruct.ML
     1.1 --- a/src/HOL/ATP_Linkup.thy	Wed Mar 17 17:23:45 2010 +0100
     1.2 +++ b/src/HOL/ATP_Linkup.thy	Wed Mar 17 18:16:31 2010 +0100
     1.3 @@ -10,16 +10,16 @@
     1.4  imports Plain Hilbert_Choice
     1.5  uses
     1.6    "Tools/polyhash.ML"
     1.7 -  "Tools/res_clause.ML"
     1.8 -  ("Tools/res_axioms.ML")
     1.9 -  ("Tools/res_hol_clause.ML")
    1.10 -  ("Tools/res_reconstruct.ML")
    1.11 -  ("Tools/res_atp.ML")
    1.12 +  "Tools/Sledgehammer/sledgehammer_fol_clause.ML"
    1.13 +  ("Tools/Sledgehammer/sledgehammer_fact_preprocessor.ML")
    1.14 +  ("Tools/Sledgehammer/sledgehammer_hol_clause.ML")
    1.15 +  ("Tools/Sledgehammer/sledgehammer_proof_reconstruct.ML")
    1.16 +  ("Tools/Sledgehammer/sledgehammer_fact_filter.ML")
    1.17    ("Tools/ATP_Manager/atp_manager.ML")
    1.18    ("Tools/ATP_Manager/atp_wrapper.ML")
    1.19    ("Tools/ATP_Manager/atp_minimal.ML")
    1.20    "~~/src/Tools/Metis/metis.ML"
    1.21 -  ("Tools/metis_tools.ML")
    1.22 +  ("Tools/Sledgehammer/metis_tactics.ML")
    1.23  begin
    1.24  
    1.25  definition COMBI :: "'a => 'a"
    1.26 @@ -91,12 +91,15 @@
    1.27  
    1.28  subsection {* Setup of external ATPs *}
    1.29  
    1.30 -use "Tools/res_axioms.ML" setup Res_Axioms.setup
    1.31 -use "Tools/res_hol_clause.ML"
    1.32 -use "Tools/res_reconstruct.ML" setup Res_Reconstruct.setup
    1.33 -use "Tools/res_atp.ML"
    1.34 +use "Tools/Sledgehammer/sledgehammer_fact_preprocessor.ML"
    1.35 +setup Res_Axioms.setup
    1.36 +use "Tools/Sledgehammer/sledgehammer_hol_clause.ML"
    1.37 +use "Tools/Sledgehammer/sledgehammer_proof_reconstruct.ML"
    1.38 +setup Res_Reconstruct.setup
    1.39 +use "Tools/Sledgehammer/sledgehammer_fact_filter.ML"
    1.40  
    1.41 -use "Tools/ATP_Manager/atp_wrapper.ML" setup ATP_Wrapper.setup
    1.42 +use "Tools/ATP_Manager/atp_wrapper.ML"
    1.43 +setup ATP_Wrapper.setup
    1.44  use "Tools/ATP_Manager/atp_manager.ML"
    1.45  use "Tools/ATP_Manager/atp_minimal.ML"
    1.46  
    1.47 @@ -121,7 +124,7 @@
    1.48  
    1.49  subsection {* The Metis prover *}
    1.50  
    1.51 -use "Tools/metis_tools.ML"
    1.52 +use "Tools/Sledgehammer/metis_tactics.ML"
    1.53  setup MetisTools.setup
    1.54  
    1.55  end
     2.1 --- a/src/HOL/IsaMakefile	Wed Mar 17 17:23:45 2010 +0100
     2.2 +++ b/src/HOL/IsaMakefile	Wed Mar 17 18:16:31 2010 +0100
     2.3 @@ -290,7 +290,6 @@
     2.4    Tools/int_arith.ML \
     2.5    Tools/list_code.ML \
     2.6    Tools/meson.ML \
     2.7 -  Tools/metis_tools.ML \
     2.8    Tools/nat_numeral_simprocs.ML \
     2.9    Tools/numeral.ML \
    2.10    Tools/numeral_simprocs.ML \
    2.11 @@ -315,12 +314,13 @@
    2.12    Tools/Quotient/quotient_term.ML \
    2.13    Tools/Quotient/quotient_typ.ML \
    2.14    Tools/recdef.ML \
    2.15 -  Tools/res_atp.ML \
    2.16 -  Tools/res_axioms.ML \
    2.17    Tools/res_blacklist.ML \
    2.18 -  Tools/res_clause.ML \
    2.19 -  Tools/res_hol_clause.ML \
    2.20 -  Tools/res_reconstruct.ML \
    2.21 +  Tools/Sledgehammer/metis_tactics.ML \
    2.22 +  Tools/Sledgehammer/sledgehammer_fact_filter.ML \
    2.23 +  Tools/Sledgehammer/sledgehammer_fact_preprocessor.ML \
    2.24 +  Tools/Sledgehammer/sledgehammer_fol_clause.ML \
    2.25 +  Tools/Sledgehammer/sledgehammer_hol_clause.ML \
    2.26 +  Tools/Sledgehammer/sledgehammer_proof_reconstruct.ML \
    2.27    Tools/string_code.ML \
    2.28    Tools/string_syntax.ML \
    2.29    Tools/transfer.ML \
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/Tools/Sledgehammer/metis_tactics.ML	Wed Mar 17 18:16:31 2010 +0100
     3.3 @@ -0,0 +1,742 @@
     3.4 +(*  Title:      HOL/Tools/metis_tools.ML
     3.5 +    Author:     Kong W. Susanto and Lawrence C. Paulson, CU Computer Laboratory
     3.6 +    Copyright   Cambridge University 2007
     3.7 +
     3.8 +HOL setup for the Metis prover.
     3.9 +*)
    3.10 +
    3.11 +signature METIS_TOOLS =
    3.12 +sig
    3.13 +  val trace: bool Unsynchronized.ref
    3.14 +  val type_lits: bool Config.T
    3.15 +  val metis_tac: Proof.context -> thm list -> int -> tactic
    3.16 +  val metisF_tac: Proof.context -> thm list -> int -> tactic
    3.17 +  val metisFT_tac: Proof.context -> thm list -> int -> tactic
    3.18 +  val setup: theory -> theory
    3.19 +end
    3.20 +
    3.21 +structure MetisTools: METIS_TOOLS =
    3.22 +struct
    3.23 +
    3.24 +val trace = Unsynchronized.ref false;
    3.25 +fun trace_msg msg = if ! trace then tracing (msg ()) else ();
    3.26 +
    3.27 +val (type_lits, type_lits_setup) = Attrib.config_bool "metis_type_lits" true;
    3.28 +
    3.29 +datatype mode = FO | HO | FT  (*first-order, higher-order, fully-typed*)
    3.30 +
    3.31 +(* ------------------------------------------------------------------------- *)
    3.32 +(* Useful Theorems                                                           *)
    3.33 +(* ------------------------------------------------------------------------- *)
    3.34 +val EXCLUDED_MIDDLE = @{lemma "P ==> ~ P ==> False" by (rule notE)}
    3.35 +val REFL_THM = incr_indexes 2 @{lemma "t ~= t ==> False" by simp}
    3.36 +val subst_em = @{lemma "s = t ==> P s ==> ~ P t ==> False" by simp}
    3.37 +val ssubst_em = @{lemma "s = t ==> P t ==> ~ P s ==> False" by simp}
    3.38 +
    3.39 +(* ------------------------------------------------------------------------- *)
    3.40 +(* Useful Functions                                                          *)
    3.41 +(* ------------------------------------------------------------------------- *)
    3.42 +
    3.43 +(* match untyped terms*)
    3.44 +fun untyped_aconv (Const(a,_))   (Const(b,_))   = (a=b)
    3.45 +  | untyped_aconv (Free(a,_))    (Free(b,_))    = (a=b)
    3.46 +  | untyped_aconv (Var((a,_),_)) (Var((b,_),_)) = (a=b)   (*the index is ignored!*)
    3.47 +  | untyped_aconv (Bound i)      (Bound j)      = (i=j)
    3.48 +  | untyped_aconv (Abs(a,_,t))  (Abs(b,_,u))    = (a=b) andalso untyped_aconv t u
    3.49 +  | untyped_aconv (t1$t2) (u1$u2)  = untyped_aconv t1 u1 andalso untyped_aconv t2 u2
    3.50 +  | untyped_aconv _              _              = false;
    3.51 +
    3.52 +(* Finding the relative location of an untyped term within a list of terms *)
    3.53 +fun get_index lit =
    3.54 +  let val lit = Envir.eta_contract lit
    3.55 +      fun get n [] = raise Empty
    3.56 +        | get n (x::xs) = if untyped_aconv lit (Envir.eta_contract (HOLogic.dest_Trueprop x))
    3.57 +                          then n  else get (n+1) xs
    3.58 +  in get 1 end;
    3.59 +
    3.60 +(* ------------------------------------------------------------------------- *)
    3.61 +(* HOL to FOL  (Isabelle to Metis)                                           *)
    3.62 +(* ------------------------------------------------------------------------- *)
    3.63 +
    3.64 +fun fn_isa_to_met "equal" = "="
    3.65 +  | fn_isa_to_met x       = x;
    3.66 +
    3.67 +fun metis_lit b c args = (b, (c, args));
    3.68 +
    3.69 +fun hol_type_to_fol (Res_Clause.AtomV x) = Metis.Term.Var x
    3.70 +  | hol_type_to_fol (Res_Clause.AtomF x) = Metis.Term.Fn(x,[])
    3.71 +  | hol_type_to_fol (Res_Clause.Comp(tc,tps)) = Metis.Term.Fn(tc, map hol_type_to_fol tps);
    3.72 +
    3.73 +(*These two functions insert type literals before the real literals. That is the
    3.74 +  opposite order from TPTP linkup, but maybe OK.*)
    3.75 +
    3.76 +fun hol_term_to_fol_FO tm =
    3.77 +  case Res_HOL_Clause.strip_comb tm of
    3.78 +      (Res_HOL_Clause.CombConst(c,_,tys), tms) =>
    3.79 +        let val tyargs = map hol_type_to_fol tys
    3.80 +            val args   = map hol_term_to_fol_FO tms
    3.81 +        in Metis.Term.Fn (c, tyargs @ args) end
    3.82 +    | (Res_HOL_Clause.CombVar(v,_), []) => Metis.Term.Var v
    3.83 +    | _ => error "hol_term_to_fol_FO";
    3.84 +
    3.85 +fun hol_term_to_fol_HO (Res_HOL_Clause.CombVar (a, _)) = Metis.Term.Var a
    3.86 +  | hol_term_to_fol_HO (Res_HOL_Clause.CombConst (a, _, tylist)) =
    3.87 +      Metis.Term.Fn (fn_isa_to_met a, map hol_type_to_fol tylist)
    3.88 +  | hol_term_to_fol_HO (Res_HOL_Clause.CombApp (tm1, tm2)) =
    3.89 +       Metis.Term.Fn (".", map hol_term_to_fol_HO [tm1, tm2]);
    3.90 +
    3.91 +(*The fully-typed translation, to avoid type errors*)
    3.92 +fun wrap_type (tm, ty) = Metis.Term.Fn("ti", [tm, hol_type_to_fol ty]);
    3.93 +
    3.94 +fun hol_term_to_fol_FT (Res_HOL_Clause.CombVar(a, ty)) =
    3.95 +      wrap_type (Metis.Term.Var a, ty)
    3.96 +  | hol_term_to_fol_FT (Res_HOL_Clause.CombConst(a, ty, _)) =
    3.97 +      wrap_type (Metis.Term.Fn(fn_isa_to_met a, []), ty)
    3.98 +  | hol_term_to_fol_FT (tm as Res_HOL_Clause.CombApp(tm1,tm2)) =
    3.99 +       wrap_type (Metis.Term.Fn(".", map hol_term_to_fol_FT [tm1,tm2]),
   3.100 +                  Res_HOL_Clause.type_of_combterm tm);
   3.101 +
   3.102 +fun hol_literal_to_fol FO (Res_HOL_Clause.Literal (pol, tm)) =
   3.103 +      let val (Res_HOL_Clause.CombConst(p,_,tys), tms) = Res_HOL_Clause.strip_comb tm
   3.104 +          val tylits = if p = "equal" then [] else map hol_type_to_fol tys
   3.105 +          val lits = map hol_term_to_fol_FO tms
   3.106 +      in metis_lit pol (fn_isa_to_met p) (tylits @ lits) end
   3.107 +  | hol_literal_to_fol HO (Res_HOL_Clause.Literal (pol, tm)) =
   3.108 +     (case Res_HOL_Clause.strip_comb tm of
   3.109 +          (Res_HOL_Clause.CombConst("equal",_,_), tms) =>
   3.110 +            metis_lit pol "=" (map hol_term_to_fol_HO tms)
   3.111 +        | _ => metis_lit pol "{}" [hol_term_to_fol_HO tm])   (*hBOOL*)
   3.112 +  | hol_literal_to_fol FT (Res_HOL_Clause.Literal (pol, tm)) =
   3.113 +     (case Res_HOL_Clause.strip_comb tm of
   3.114 +          (Res_HOL_Clause.CombConst("equal",_,_), tms) =>
   3.115 +            metis_lit pol "=" (map hol_term_to_fol_FT tms)
   3.116 +        | _ => metis_lit pol "{}" [hol_term_to_fol_FT tm])   (*hBOOL*);
   3.117 +
   3.118 +fun literals_of_hol_thm thy mode t =
   3.119 +      let val (lits, types_sorts) = Res_HOL_Clause.literals_of_term thy t
   3.120 +      in  (map (hol_literal_to_fol mode) lits, types_sorts) end;
   3.121 +
   3.122 +(*Sign should be "true" for conjecture type constraints, "false" for type lits in clauses.*)
   3.123 +fun metis_of_typeLit pos (Res_Clause.LTVar (s,x))  = metis_lit pos s [Metis.Term.Var x]
   3.124 +  | metis_of_typeLit pos (Res_Clause.LTFree (s,x)) = metis_lit pos s [Metis.Term.Fn(x,[])];
   3.125 +
   3.126 +fun default_sort _ (TVar _) = false
   3.127 +  | default_sort ctxt (TFree (x, s)) = (s = the_default [] (Variable.def_sort ctxt (x, ~1)));
   3.128 +
   3.129 +fun metis_of_tfree tf =
   3.130 +  Metis.Thm.axiom (Metis.LiteralSet.singleton (metis_of_typeLit true tf));
   3.131 +
   3.132 +fun hol_thm_to_fol is_conjecture ctxt mode th =
   3.133 +  let val thy = ProofContext.theory_of ctxt
   3.134 +      val (mlits, types_sorts) =
   3.135 +             (literals_of_hol_thm thy mode o HOLogic.dest_Trueprop o prop_of) th
   3.136 +  in
   3.137 +      if is_conjecture then
   3.138 +          (Metis.Thm.axiom (Metis.LiteralSet.fromList mlits), Res_Clause.add_typs types_sorts)
   3.139 +      else
   3.140 +        let val tylits = Res_Clause.add_typs
   3.141 +                           (filter (not o default_sort ctxt) types_sorts)
   3.142 +            val mtylits = if Config.get ctxt type_lits
   3.143 +                          then map (metis_of_typeLit false) tylits else []
   3.144 +        in
   3.145 +          (Metis.Thm.axiom (Metis.LiteralSet.fromList(mtylits @ mlits)), [])
   3.146 +        end
   3.147 +  end;
   3.148 +
   3.149 +(* ARITY CLAUSE *)
   3.150 +
   3.151 +fun m_arity_cls (Res_Clause.TConsLit (c,t,args)) =
   3.152 +      metis_lit true (Res_Clause.make_type_class c) [Metis.Term.Fn(t, map Metis.Term.Var args)]
   3.153 +  | m_arity_cls (Res_Clause.TVarLit (c,str))     =
   3.154 +      metis_lit false (Res_Clause.make_type_class c) [Metis.Term.Var str];
   3.155 +
   3.156 +(*TrueI is returned as the Isabelle counterpart because there isn't any.*)
   3.157 +fun arity_cls (Res_Clause.ArityClause{conclLit,premLits,...}) =
   3.158 +  (TrueI,
   3.159 +   Metis.Thm.axiom (Metis.LiteralSet.fromList (map m_arity_cls (conclLit :: premLits))));
   3.160 +
   3.161 +(* CLASSREL CLAUSE *)
   3.162 +
   3.163 +fun m_classrel_cls subclass superclass =
   3.164 +  [metis_lit false subclass [Metis.Term.Var "T"], metis_lit true superclass [Metis.Term.Var "T"]];
   3.165 +
   3.166 +fun classrel_cls (Res_Clause.ClassrelClause {subclass, superclass, ...}) =
   3.167 +  (TrueI, Metis.Thm.axiom (Metis.LiteralSet.fromList (m_classrel_cls subclass superclass)));
   3.168 +
   3.169 +(* ------------------------------------------------------------------------- *)
   3.170 +(* FOL to HOL  (Metis to Isabelle)                                           *)
   3.171 +(* ------------------------------------------------------------------------- *)
   3.172 +
   3.173 +datatype term_or_type = Term of Term.term | Type of Term.typ;
   3.174 +
   3.175 +fun terms_of [] = []
   3.176 +  | terms_of (Term t :: tts) = t :: terms_of tts
   3.177 +  | terms_of (Type _ :: tts) = terms_of tts;
   3.178 +
   3.179 +fun types_of [] = []
   3.180 +  | types_of (Term (Term.Var ((a,idx), _)) :: tts) =
   3.181 +      if String.isPrefix "_" a then
   3.182 +          (*Variable generated by Metis, which might have been a type variable.*)
   3.183 +          TVar (("'" ^ a, idx), HOLogic.typeS) :: types_of tts
   3.184 +      else types_of tts
   3.185 +  | types_of (Term _ :: tts) = types_of tts
   3.186 +  | types_of (Type T :: tts) = T :: types_of tts;
   3.187 +
   3.188 +fun apply_list rator nargs rands =
   3.189 +  let val trands = terms_of rands
   3.190 +  in  if length trands = nargs then Term (list_comb(rator, trands))
   3.191 +      else error
   3.192 +        ("apply_list: wrong number of arguments: " ^ Syntax.string_of_term_global Pure.thy rator ^
   3.193 +          " expected " ^ Int.toString nargs ^
   3.194 +          " received " ^ commas (map (Syntax.string_of_term_global Pure.thy) trands))
   3.195 +  end;
   3.196 +
   3.197 +fun infer_types ctxt =
   3.198 +  Syntax.check_terms (ProofContext.set_mode ProofContext.mode_pattern ctxt);
   3.199 +
   3.200 +(*We use 1 rather than 0 because variable references in clauses may otherwise conflict
   3.201 +  with variable constraints in the goal...at least, type inference often fails otherwise.
   3.202 +  SEE ALSO axiom_inf below.*)
   3.203 +fun mk_var (w,T) = Term.Var((w,1), T);
   3.204 +
   3.205 +(*include the default sort, if available*)
   3.206 +fun mk_tfree ctxt w =
   3.207 +  let val ww = "'" ^ w
   3.208 +  in  TFree(ww, the_default HOLogic.typeS (Variable.def_sort ctxt (ww, ~1)))  end;
   3.209 +
   3.210 +(*Remove the "apply" operator from an HO term*)
   3.211 +fun strip_happ args (Metis.Term.Fn(".",[t,u])) = strip_happ (u::args) t
   3.212 +  | strip_happ args x = (x, args);
   3.213 +
   3.214 +fun fol_type_to_isa _ (Metis.Term.Var v) =
   3.215 +     (case Res_Reconstruct.strip_prefix Res_Clause.tvar_prefix v of
   3.216 +          SOME w => Res_Reconstruct.make_tvar w
   3.217 +        | NONE   => Res_Reconstruct.make_tvar v)
   3.218 +  | fol_type_to_isa ctxt (Metis.Term.Fn(x, tys)) =
   3.219 +     (case Res_Reconstruct.strip_prefix Res_Clause.tconst_prefix x of
   3.220 +          SOME tc => Term.Type (Res_Reconstruct.invert_type_const tc, map (fol_type_to_isa ctxt) tys)
   3.221 +        | NONE    =>
   3.222 +      case Res_Reconstruct.strip_prefix Res_Clause.tfree_prefix x of
   3.223 +          SOME tf => mk_tfree ctxt tf
   3.224 +        | NONE    => error ("fol_type_to_isa: " ^ x));
   3.225 +
   3.226 +(*Maps metis terms to isabelle terms*)
   3.227 +fun fol_term_to_hol_RAW ctxt fol_tm =
   3.228 +  let val thy = ProofContext.theory_of ctxt
   3.229 +      val _ = trace_msg (fn () => "fol_term_to_hol: " ^ Metis.Term.toString fol_tm)
   3.230 +      fun tm_to_tt (Metis.Term.Var v) =
   3.231 +             (case Res_Reconstruct.strip_prefix Res_Clause.tvar_prefix v of
   3.232 +                  SOME w => Type (Res_Reconstruct.make_tvar w)
   3.233 +                | NONE =>
   3.234 +              case Res_Reconstruct.strip_prefix Res_Clause.schematic_var_prefix v of
   3.235 +                  SOME w => Term (mk_var (w, HOLogic.typeT))
   3.236 +                | NONE   => Term (mk_var (v, HOLogic.typeT)) )
   3.237 +                    (*Var from Metis with a name like _nnn; possibly a type variable*)
   3.238 +        | tm_to_tt (Metis.Term.Fn ("{}", [arg])) = tm_to_tt arg   (*hBOOL*)
   3.239 +        | tm_to_tt (t as Metis.Term.Fn (".",_)) =
   3.240 +            let val (rator,rands) = strip_happ [] t
   3.241 +            in  case rator of
   3.242 +                    Metis.Term.Fn(fname,ts) => applic_to_tt (fname, ts @ rands)
   3.243 +                  | _ => case tm_to_tt rator of
   3.244 +                             Term t => Term (list_comb(t, terms_of (map tm_to_tt rands)))
   3.245 +                           | _ => error "tm_to_tt: HO application"
   3.246 +            end
   3.247 +        | tm_to_tt (Metis.Term.Fn (fname, args)) = applic_to_tt (fname,args)
   3.248 +      and applic_to_tt ("=",ts) =
   3.249 +            Term (list_comb(Const ("op =", HOLogic.typeT), terms_of (map tm_to_tt ts)))
   3.250 +        | applic_to_tt (a,ts) =
   3.251 +            case Res_Reconstruct.strip_prefix Res_Clause.const_prefix a of
   3.252 +                SOME b =>
   3.253 +                  let val c = Res_Reconstruct.invert_const b
   3.254 +                      val ntypes = Res_Reconstruct.num_typargs thy c
   3.255 +                      val nterms = length ts - ntypes
   3.256 +                      val tts = map tm_to_tt ts
   3.257 +                      val tys = types_of (List.take(tts,ntypes))
   3.258 +                      val ntyargs = Res_Reconstruct.num_typargs thy c
   3.259 +                  in if length tys = ntyargs then
   3.260 +                         apply_list (Const (c, dummyT)) nterms (List.drop(tts,ntypes))
   3.261 +                     else error ("Constant " ^ c ^ " expects " ^ Int.toString ntyargs ^
   3.262 +                                 " but gets " ^ Int.toString (length tys) ^
   3.263 +                                 " type arguments\n" ^
   3.264 +                                 cat_lines (map (Syntax.string_of_typ ctxt) tys) ^
   3.265 +                                 " the terms are \n" ^
   3.266 +                                 cat_lines (map (Syntax.string_of_term ctxt) (terms_of tts)))
   3.267 +                     end
   3.268 +              | NONE => (*Not a constant. Is it a type constructor?*)
   3.269 +            case Res_Reconstruct.strip_prefix Res_Clause.tconst_prefix a of
   3.270 +                SOME b =>
   3.271 +                  Type (Term.Type (Res_Reconstruct.invert_type_const b, types_of (map tm_to_tt ts)))
   3.272 +              | NONE => (*Maybe a TFree. Should then check that ts=[].*)
   3.273 +            case Res_Reconstruct.strip_prefix Res_Clause.tfree_prefix a of
   3.274 +                SOME b => Type (mk_tfree ctxt b)
   3.275 +              | NONE => (*a fixed variable? They are Skolem functions.*)
   3.276 +            case Res_Reconstruct.strip_prefix Res_Clause.fixed_var_prefix a of
   3.277 +                SOME b =>
   3.278 +                  let val opr = Term.Free(b, HOLogic.typeT)
   3.279 +                  in  apply_list opr (length ts) (map tm_to_tt ts)  end
   3.280 +              | NONE => error ("unexpected metis function: " ^ a)
   3.281 +  in  case tm_to_tt fol_tm of Term t => t | _ => error "fol_tm_to_tt: Term expected"  end;
   3.282 +
   3.283 +(*Maps fully-typed metis terms to isabelle terms*)
   3.284 +fun fol_term_to_hol_FT ctxt fol_tm =
   3.285 +  let val _ = trace_msg (fn () => "fol_term_to_hol_FT: " ^ Metis.Term.toString fol_tm)
   3.286 +      fun cvt (Metis.Term.Fn ("ti", [Metis.Term.Var v, _])) =
   3.287 +             (case Res_Reconstruct.strip_prefix Res_Clause.schematic_var_prefix v of
   3.288 +                  SOME w =>  mk_var(w, dummyT)
   3.289 +                | NONE   => mk_var(v, dummyT))
   3.290 +        | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn ("=",[]), _])) =
   3.291 +            Const ("op =", HOLogic.typeT)
   3.292 +        | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (x,[]), ty])) =
   3.293 +           (case Res_Reconstruct.strip_prefix Res_Clause.const_prefix x of
   3.294 +                SOME c => Const (Res_Reconstruct.invert_const c, dummyT)
   3.295 +              | NONE => (*Not a constant. Is it a fixed variable??*)
   3.296 +            case Res_Reconstruct.strip_prefix Res_Clause.fixed_var_prefix x of
   3.297 +                SOME v => Free (v, fol_type_to_isa ctxt ty)
   3.298 +              | NONE => error ("fol_term_to_hol_FT bad constant: " ^ x))
   3.299 +        | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (".",[tm1,tm2]), _])) =
   3.300 +            cvt tm1 $ cvt tm2
   3.301 +        | cvt (Metis.Term.Fn (".",[tm1,tm2])) = (*untyped application*)
   3.302 +            cvt tm1 $ cvt tm2
   3.303 +        | cvt (Metis.Term.Fn ("{}", [arg])) = cvt arg   (*hBOOL*)
   3.304 +        | cvt (Metis.Term.Fn ("=", [tm1,tm2])) =
   3.305 +            list_comb(Const ("op =", HOLogic.typeT), map cvt [tm1,tm2])
   3.306 +        | cvt (t as Metis.Term.Fn (x, [])) =
   3.307 +           (case Res_Reconstruct.strip_prefix Res_Clause.const_prefix x of
   3.308 +                SOME c => Const (Res_Reconstruct.invert_const c, dummyT)
   3.309 +              | NONE => (*Not a constant. Is it a fixed variable??*)
   3.310 +            case Res_Reconstruct.strip_prefix Res_Clause.fixed_var_prefix x of
   3.311 +                SOME v => Free (v, dummyT)
   3.312 +              | NONE => (trace_msg (fn () => "fol_term_to_hol_FT bad const: " ^ x);
   3.313 +                  fol_term_to_hol_RAW ctxt t))
   3.314 +        | cvt t = (trace_msg (fn () => "fol_term_to_hol_FT bad term: " ^ Metis.Term.toString t);
   3.315 +            fol_term_to_hol_RAW ctxt t)
   3.316 +  in  cvt fol_tm   end;
   3.317 +
   3.318 +fun fol_term_to_hol ctxt FO = fol_term_to_hol_RAW ctxt
   3.319 +  | fol_term_to_hol ctxt HO = fol_term_to_hol_RAW ctxt
   3.320 +  | fol_term_to_hol ctxt FT = fol_term_to_hol_FT ctxt;
   3.321 +
   3.322 +fun fol_terms_to_hol ctxt mode fol_tms =
   3.323 +  let val ts = map (fol_term_to_hol ctxt mode) fol_tms
   3.324 +      val _ = trace_msg (fn () => "  calling type inference:")
   3.325 +      val _ = app (fn t => trace_msg (fn () => Syntax.string_of_term ctxt t)) ts
   3.326 +      val ts' = infer_types ctxt ts;
   3.327 +      val _ = app (fn t => trace_msg
   3.328 +                    (fn () => "  final term: " ^ Syntax.string_of_term ctxt t ^
   3.329 +                              "  of type  " ^ Syntax.string_of_typ ctxt (type_of t)))
   3.330 +                  ts'
   3.331 +  in  ts'  end;
   3.332 +
   3.333 +fun mk_not (Const ("Not", _) $ b) = b
   3.334 +  | mk_not b = HOLogic.mk_not b;
   3.335 +
   3.336 +val metis_eq = Metis.Term.Fn ("=", []);
   3.337 +
   3.338 +(* ------------------------------------------------------------------------- *)
   3.339 +(* FOL step Inference Rules                                                  *)
   3.340 +(* ------------------------------------------------------------------------- *)
   3.341 +
   3.342 +(*for debugging only*)
   3.343 +fun print_thpair (fth,th) =
   3.344 +  (trace_msg (fn () => "=============================================");
   3.345 +   trace_msg (fn () => "Metis: " ^ Metis.Thm.toString fth);
   3.346 +   trace_msg (fn () => "Isabelle: " ^ Display.string_of_thm_without_context th));
   3.347 +
   3.348 +fun lookth thpairs (fth : Metis.Thm.thm) =
   3.349 +  the (AList.lookup (uncurry Metis.Thm.equal) thpairs fth)
   3.350 +  handle Option => error ("Failed to find a Metis theorem " ^ Metis.Thm.toString fth);
   3.351 +
   3.352 +fun is_TrueI th = Thm.eq_thm(TrueI,th);
   3.353 +
   3.354 +fun cterm_incr_types thy idx = cterm_of thy o (map_types (Logic.incr_tvar idx));
   3.355 +
   3.356 +fun inst_excluded_middle thy i_atm =
   3.357 +  let val th = EXCLUDED_MIDDLE
   3.358 +      val [vx] = Term.add_vars (prop_of th) []
   3.359 +      val substs = [(cterm_of thy (Var vx), cterm_of thy i_atm)]
   3.360 +  in  cterm_instantiate substs th  end;
   3.361 +
   3.362 +(* INFERENCE RULE: AXIOM *)
   3.363 +fun axiom_inf thpairs th = incr_indexes 1 (lookth thpairs th);
   3.364 +    (*This causes variables to have an index of 1 by default. SEE ALSO mk_var above.*)
   3.365 +
   3.366 +(* INFERENCE RULE: ASSUME *)
   3.367 +fun assume_inf ctxt mode atm =
   3.368 +  inst_excluded_middle
   3.369 +    (ProofContext.theory_of ctxt)
   3.370 +    (singleton (fol_terms_to_hol ctxt mode) (Metis.Term.Fn atm));
   3.371 +
   3.372 +(* INFERENCE RULE: INSTANTIATE (Subst). Type instantiations are ignored. Trying to reconstruct
   3.373 +   them admits new possibilities of errors, e.g. concerning sorts. Instead we try to arrange
   3.374 +   that new TVars are distinct and that types can be inferred from terms.*)
   3.375 +fun inst_inf ctxt mode thpairs fsubst th =
   3.376 +  let val thy = ProofContext.theory_of ctxt
   3.377 +      val i_th   = lookth thpairs th
   3.378 +      val i_th_vars = Term.add_vars (prop_of i_th) []
   3.379 +      fun find_var x = the (List.find (fn ((a,_),_) => a=x) i_th_vars)
   3.380 +      fun subst_translation (x,y) =
   3.381 +            let val v = find_var x
   3.382 +                val t = fol_term_to_hol ctxt mode y (*we call infer_types below*)
   3.383 +            in  SOME (cterm_of thy (Var v), t)  end
   3.384 +            handle Option =>
   3.385 +                (trace_msg (fn() => "List.find failed for the variable " ^ x ^
   3.386 +                                       " in " ^ Display.string_of_thm ctxt i_th);
   3.387 +                 NONE)
   3.388 +      fun remove_typeinst (a, t) =
   3.389 +            case Res_Reconstruct.strip_prefix Res_Clause.schematic_var_prefix a of
   3.390 +                SOME b => SOME (b, t)
   3.391 +              | NONE   => case Res_Reconstruct.strip_prefix Res_Clause.tvar_prefix a of
   3.392 +                SOME _ => NONE          (*type instantiations are forbidden!*)
   3.393 +              | NONE   => SOME (a,t)    (*internal Metis var?*)
   3.394 +      val _ = trace_msg (fn () => "  isa th: " ^ Display.string_of_thm ctxt i_th)
   3.395 +      val substs = map_filter remove_typeinst (Metis.Subst.toList fsubst)
   3.396 +      val (vars,rawtms) = ListPair.unzip (map_filter subst_translation substs)
   3.397 +      val tms = infer_types ctxt rawtms;
   3.398 +      val ctm_of = cterm_incr_types thy (1 + Thm.maxidx_of i_th)
   3.399 +      val substs' = ListPair.zip (vars, map ctm_of tms)
   3.400 +      val _ = trace_msg (fn () =>
   3.401 +        cat_lines ("subst_translations:" ::
   3.402 +          (substs' |> map (fn (x, y) =>
   3.403 +            Syntax.string_of_term ctxt (term_of x) ^ " |-> " ^
   3.404 +            Syntax.string_of_term ctxt (term_of y)))));
   3.405 +  in  cterm_instantiate substs' i_th
   3.406 +      handle THM (msg, _, _) => error ("metis error (inst_inf): " ^ msg)
   3.407 +  end;
   3.408 +
   3.409 +(* INFERENCE RULE: RESOLVE *)
   3.410 +
   3.411 +(*Like RSN, but we rename apart only the type variables. Vars here typically have an index
   3.412 +  of 1, and the use of RSN would increase this typically to 3. Instantiations of those Vars
   3.413 +  could then fail. See comment on mk_var.*)
   3.414 +fun resolve_inc_tyvars(tha,i,thb) =
   3.415 +  let val tha = Drule.incr_type_indexes (1 + Thm.maxidx_of thb) tha
   3.416 +      val ths = Seq.list_of (Thm.bicompose false (false,tha,nprems_of tha) i thb)
   3.417 +  in
   3.418 +      case distinct Thm.eq_thm ths of
   3.419 +        [th] => th
   3.420 +      | _ => raise THM ("resolve_inc_tyvars: unique result expected", i, [tha,thb])
   3.421 +  end;
   3.422 +
   3.423 +fun resolve_inf ctxt mode thpairs atm th1 th2 =
   3.424 +  let
   3.425 +    val i_th1 = lookth thpairs th1 and i_th2 = lookth thpairs th2
   3.426 +    val _ = trace_msg (fn () => "  isa th1 (pos): " ^ Display.string_of_thm ctxt i_th1)
   3.427 +    val _ = trace_msg (fn () => "  isa th2 (neg): " ^ Display.string_of_thm ctxt i_th2)
   3.428 +  in
   3.429 +    if is_TrueI i_th1 then i_th2 (*Trivial cases where one operand is type info*)
   3.430 +    else if is_TrueI i_th2 then i_th1
   3.431 +    else
   3.432 +      let
   3.433 +        val i_atm = singleton (fol_terms_to_hol ctxt mode) (Metis.Term.Fn atm)
   3.434 +        val _ = trace_msg (fn () => "  atom: " ^ Syntax.string_of_term ctxt i_atm)
   3.435 +        val prems_th1 = prems_of i_th1
   3.436 +        val prems_th2 = prems_of i_th2
   3.437 +        val index_th1 = get_index (mk_not i_atm) prems_th1
   3.438 +              handle Empty => error "Failed to find literal in th1"
   3.439 +        val _ = trace_msg (fn () => "  index_th1: " ^ Int.toString index_th1)
   3.440 +        val index_th2 = get_index i_atm prems_th2
   3.441 +              handle Empty => error "Failed to find literal in th2"
   3.442 +        val _ = trace_msg (fn () => "  index_th2: " ^ Int.toString index_th2)
   3.443 +    in  resolve_inc_tyvars (Meson.select_literal index_th1 i_th1, index_th2, i_th2)  end
   3.444 +  end;
   3.445 +
   3.446 +(* INFERENCE RULE: REFL *)
   3.447 +val refl_x = cterm_of @{theory} (Var (hd (Term.add_vars (prop_of REFL_THM) [])));
   3.448 +val refl_idx = 1 + Thm.maxidx_of REFL_THM;
   3.449 +
   3.450 +fun refl_inf ctxt mode t =
   3.451 +  let val thy = ProofContext.theory_of ctxt
   3.452 +      val i_t = singleton (fol_terms_to_hol ctxt mode) t
   3.453 +      val _ = trace_msg (fn () => "  term: " ^ Syntax.string_of_term ctxt i_t)
   3.454 +      val c_t = cterm_incr_types thy refl_idx i_t
   3.455 +  in  cterm_instantiate [(refl_x, c_t)] REFL_THM  end;
   3.456 +
   3.457 +fun get_ty_arg_size _ (Const ("op =", _)) = 0  (*equality has no type arguments*)
   3.458 +  | get_ty_arg_size thy (Const (c, _)) = (Res_Reconstruct.num_typargs thy c handle TYPE _ => 0)
   3.459 +  | get_ty_arg_size _ _ = 0;
   3.460 +
   3.461 +(* INFERENCE RULE: EQUALITY *)
   3.462 +fun equality_inf ctxt mode (pos, atm) fp fr =
   3.463 +  let val thy = ProofContext.theory_of ctxt
   3.464 +      val m_tm = Metis.Term.Fn atm
   3.465 +      val [i_atm,i_tm] = fol_terms_to_hol ctxt mode [m_tm, fr]
   3.466 +      val _ = trace_msg (fn () => "sign of the literal: " ^ Bool.toString pos)
   3.467 +      fun replace_item_list lx 0 (_::ls) = lx::ls
   3.468 +        | replace_item_list lx i (l::ls) = l :: replace_item_list lx (i-1) ls
   3.469 +      fun path_finder_FO tm [] = (tm, Term.Bound 0)
   3.470 +        | path_finder_FO tm (p::ps) =
   3.471 +            let val (tm1,args) = Term.strip_comb tm
   3.472 +                val adjustment = get_ty_arg_size thy tm1
   3.473 +                val p' = if adjustment > p then p else p-adjustment
   3.474 +                val tm_p = List.nth(args,p')
   3.475 +                  handle Subscript => error ("equality_inf: " ^ Int.toString p ^ " adj " ^
   3.476 +                    Int.toString adjustment  ^ " term " ^  Syntax.string_of_term ctxt tm)
   3.477 +                val _ = trace_msg (fn () => "path_finder: " ^ Int.toString p ^
   3.478 +                                      "  " ^ Syntax.string_of_term ctxt tm_p)
   3.479 +                val (r,t) = path_finder_FO tm_p ps
   3.480 +            in
   3.481 +                (r, list_comb (tm1, replace_item_list t p' args))
   3.482 +            end
   3.483 +      fun path_finder_HO tm [] = (tm, Term.Bound 0)
   3.484 +        | path_finder_HO (t$u) (0::ps) = (fn(x,y) => (x, y$u)) (path_finder_HO t ps)
   3.485 +        | path_finder_HO (t$u) (_::ps) = (fn(x,y) => (x, t$y)) (path_finder_HO u ps)
   3.486 +      fun path_finder_FT tm [] _ = (tm, Term.Bound 0)
   3.487 +        | path_finder_FT tm (0::ps) (Metis.Term.Fn ("ti", [t1, _])) =
   3.488 +            path_finder_FT tm ps t1
   3.489 +        | path_finder_FT (t$u) (0::ps) (Metis.Term.Fn (".", [t1, _])) =
   3.490 +            (fn(x,y) => (x, y$u)) (path_finder_FT t ps t1)
   3.491 +        | path_finder_FT (t$u) (1::ps) (Metis.Term.Fn (".", [_, t2])) =
   3.492 +            (fn(x,y) => (x, t$y)) (path_finder_FT u ps t2)
   3.493 +        | path_finder_FT tm ps t = error ("equality_inf, path_finder_FT: path = " ^
   3.494 +                                        space_implode " " (map Int.toString ps) ^
   3.495 +                                        " isa-term: " ^  Syntax.string_of_term ctxt tm ^
   3.496 +                                        " fol-term: " ^ Metis.Term.toString t)
   3.497 +      fun path_finder FO tm ps _ = path_finder_FO tm ps
   3.498 +        | path_finder HO (tm as Const("op =",_) $ _ $ _) (p::ps) _ =
   3.499 +             (*equality: not curried, as other predicates are*)
   3.500 +             if p=0 then path_finder_HO tm (0::1::ps)  (*select first operand*)
   3.501 +             else path_finder_HO tm (p::ps)        (*1 selects second operand*)
   3.502 +        | path_finder HO tm (_ :: ps) (Metis.Term.Fn ("{}", [_])) =
   3.503 +             path_finder_HO tm ps      (*if not equality, ignore head to skip hBOOL*)
   3.504 +        | path_finder FT (tm as Const("op =",_) $ _ $ _) (p::ps)
   3.505 +                            (Metis.Term.Fn ("=", [t1,t2])) =
   3.506 +             (*equality: not curried, as other predicates are*)
   3.507 +             if p=0 then path_finder_FT tm (0::1::ps)
   3.508 +                          (Metis.Term.Fn (".", [Metis.Term.Fn (".", [metis_eq,t1]), t2]))
   3.509 +                          (*select first operand*)
   3.510 +             else path_finder_FT tm (p::ps)
   3.511 +                   (Metis.Term.Fn (".", [metis_eq,t2]))
   3.512 +                   (*1 selects second operand*)
   3.513 +        | path_finder FT tm (_ :: ps) (Metis.Term.Fn ("{}", [t1])) = path_finder_FT tm ps t1
   3.514 +             (*if not equality, ignore head to skip the hBOOL predicate*)
   3.515 +        | path_finder FT tm ps t = path_finder_FT tm ps t  (*really an error case!*)
   3.516 +      fun path_finder_lit ((nt as Term.Const ("Not", _)) $ tm_a) idx =
   3.517 +            let val (tm, tm_rslt) = path_finder mode tm_a idx m_tm
   3.518 +            in (tm, nt $ tm_rslt) end
   3.519 +        | path_finder_lit tm_a idx = path_finder mode tm_a idx m_tm
   3.520 +      val (tm_subst, body) = path_finder_lit i_atm fp
   3.521 +      val tm_abs = Term.Abs("x", Term.type_of tm_subst, body)
   3.522 +      val _ = trace_msg (fn () => "abstraction: " ^ Syntax.string_of_term ctxt tm_abs)
   3.523 +      val _ = trace_msg (fn () => "i_tm: " ^ Syntax.string_of_term ctxt i_tm)
   3.524 +      val _ = trace_msg (fn () => "located term: " ^ Syntax.string_of_term ctxt tm_subst)
   3.525 +      val imax = maxidx_of_term (i_tm $ tm_abs $ tm_subst)  (*ill typed but gives right max*)
   3.526 +      val subst' = incr_indexes (imax+1) (if pos then subst_em else ssubst_em)
   3.527 +      val _ = trace_msg (fn () => "subst' " ^ Display.string_of_thm ctxt subst')
   3.528 +      val eq_terms = map (pairself (cterm_of thy))
   3.529 +        (ListPair.zip (OldTerm.term_vars (prop_of subst'), [tm_abs, tm_subst, i_tm]))
   3.530 +  in  cterm_instantiate eq_terms subst'  end;
   3.531 +
   3.532 +val factor = Seq.hd o distinct_subgoals_tac;
   3.533 +
   3.534 +fun step _ _ thpairs (fol_th, Metis.Proof.Axiom _) = factor (axiom_inf thpairs fol_th)
   3.535 +  | step ctxt mode _ (_, Metis.Proof.Assume f_atm) = assume_inf ctxt mode f_atm
   3.536 +  | step ctxt mode thpairs (_, Metis.Proof.Subst (f_subst, f_th1)) =
   3.537 +      factor (inst_inf ctxt mode thpairs f_subst f_th1)
   3.538 +  | step ctxt mode thpairs (_, Metis.Proof.Resolve(f_atm, f_th1, f_th2)) =
   3.539 +      factor (resolve_inf ctxt mode thpairs f_atm f_th1 f_th2)
   3.540 +  | step ctxt mode _ (_, Metis.Proof.Refl f_tm) = refl_inf ctxt mode f_tm
   3.541 +  | step ctxt mode _ (_, Metis.Proof.Equality (f_lit, f_p, f_r)) =
   3.542 +      equality_inf ctxt mode f_lit f_p f_r;
   3.543 +
   3.544 +fun real_literal (_, (c, _)) = not (String.isPrefix Res_Clause.class_prefix c);
   3.545 +
   3.546 +fun translate _ _ thpairs [] = thpairs
   3.547 +  | translate mode ctxt thpairs ((fol_th, inf) :: infpairs) =
   3.548 +      let val _ = trace_msg (fn () => "=============================================")
   3.549 +          val _ = trace_msg (fn () => "METIS THM: " ^ Metis.Thm.toString fol_th)
   3.550 +          val _ = trace_msg (fn () => "INFERENCE: " ^ Metis.Proof.inferenceToString inf)
   3.551 +          val th = Meson.flexflex_first_order (step ctxt mode thpairs (fol_th, inf))
   3.552 +          val _ = trace_msg (fn () => "ISABELLE THM: " ^ Display.string_of_thm ctxt th)
   3.553 +          val _ = trace_msg (fn () => "=============================================")
   3.554 +          val n_metis_lits =
   3.555 +            length (filter real_literal (Metis.LiteralSet.toList (Metis.Thm.clause fol_th)))
   3.556 +      in
   3.557 +          if nprems_of th = n_metis_lits then ()
   3.558 +          else error "Metis: proof reconstruction has gone wrong";
   3.559 +          translate mode ctxt ((fol_th, th) :: thpairs) infpairs
   3.560 +      end;
   3.561 +
   3.562 +(*Determining which axiom clauses are actually used*)
   3.563 +fun used_axioms axioms (th, Metis.Proof.Axiom _) = SOME (lookth axioms th)
   3.564 +  | used_axioms _ _ = NONE;
   3.565 +
   3.566 +(* ------------------------------------------------------------------------- *)
   3.567 +(* Translation of HO Clauses                                                 *)
   3.568 +(* ------------------------------------------------------------------------- *)
   3.569 +
   3.570 +fun cnf_th thy th = hd (Res_Axioms.cnf_axiom thy th);
   3.571 +
   3.572 +val equal_imp_fequal' = cnf_th @{theory} @{thm equal_imp_fequal};
   3.573 +val fequal_imp_equal' = cnf_th @{theory} @{thm fequal_imp_equal};
   3.574 +
   3.575 +val comb_I = cnf_th @{theory} Res_HOL_Clause.comb_I;
   3.576 +val comb_K = cnf_th @{theory} Res_HOL_Clause.comb_K;
   3.577 +val comb_B = cnf_th @{theory} Res_HOL_Clause.comb_B;
   3.578 +val comb_C = cnf_th @{theory} Res_HOL_Clause.comb_C;
   3.579 +val comb_S = cnf_th @{theory} Res_HOL_Clause.comb_S;
   3.580 +
   3.581 +fun type_ext thy tms =
   3.582 +  let val subs = Res_ATP.tfree_classes_of_terms tms
   3.583 +      val supers = Res_ATP.tvar_classes_of_terms tms
   3.584 +      and tycons = Res_ATP.type_consts_of_terms thy tms
   3.585 +      val (supers', arity_clauses) = Res_Clause.make_arity_clauses thy tycons supers
   3.586 +      val classrel_clauses = Res_Clause.make_classrel_clauses thy subs supers'
   3.587 +  in  map classrel_cls classrel_clauses @ map arity_cls arity_clauses
   3.588 +  end;
   3.589 +
   3.590 +(* ------------------------------------------------------------------------- *)
   3.591 +(* Logic maps manage the interface between HOL and first-order logic.        *)
   3.592 +(* ------------------------------------------------------------------------- *)
   3.593 +
   3.594 +type logic_map =
   3.595 +  {axioms : (Metis.Thm.thm * thm) list,
   3.596 +   tfrees : Res_Clause.type_literal list};
   3.597 +
   3.598 +fun const_in_metis c (pred, tm_list) =
   3.599 +  let
   3.600 +    fun in_mterm (Metis.Term.Var _) = false
   3.601 +      | in_mterm (Metis.Term.Fn (".", tm_list)) = exists in_mterm tm_list
   3.602 +      | in_mterm (Metis.Term.Fn (nm, tm_list)) = c=nm orelse exists in_mterm tm_list
   3.603 +  in  c = pred orelse exists in_mterm tm_list  end;
   3.604 +
   3.605 +(*Extract TFree constraints from context to include as conjecture clauses*)
   3.606 +fun init_tfrees ctxt =
   3.607 +  let fun add ((a,i),s) Ts = if i = ~1 then TFree(a,s) :: Ts else Ts
   3.608 +  in  Res_Clause.add_typs (Vartab.fold add (#2 (Variable.constraints_of ctxt)) []) end;
   3.609 +
   3.610 +(*transform isabelle type / arity clause to metis clause *)
   3.611 +fun add_type_thm [] lmap = lmap
   3.612 +  | add_type_thm ((ith, mth) :: cls) {axioms, tfrees} =
   3.613 +      add_type_thm cls {axioms = (mth, ith) :: axioms,
   3.614 +                        tfrees = tfrees}
   3.615 +
   3.616 +(*Insert non-logical axioms corresponding to all accumulated TFrees*)
   3.617 +fun add_tfrees {axioms, tfrees} : logic_map =
   3.618 +     {axioms = (map (fn tf => (metis_of_tfree tf, TrueI)) (distinct op= tfrees)) @ axioms,
   3.619 +      tfrees = tfrees};
   3.620 +
   3.621 +fun string_of_mode FO = "FO"
   3.622 +  | string_of_mode HO = "HO"
   3.623 +  | string_of_mode FT = "FT"
   3.624 +
   3.625 +(* Function to generate metis clauses, including comb and type clauses *)
   3.626 +fun build_map mode0 ctxt cls ths =
   3.627 +  let val thy = ProofContext.theory_of ctxt
   3.628 +      (*The modes FO and FT are sticky. HO can be downgraded to FO.*)
   3.629 +      fun set_mode FO = FO
   3.630 +        | set_mode HO = if forall (Meson.is_fol_term thy o prop_of) (cls@ths) then FO else HO
   3.631 +        | set_mode FT = FT
   3.632 +      val mode = set_mode mode0
   3.633 +      (*transform isabelle clause to metis clause *)
   3.634 +      fun add_thm is_conjecture ith {axioms, tfrees} : logic_map =
   3.635 +        let val (mth, tfree_lits) = hol_thm_to_fol is_conjecture ctxt mode ith
   3.636 +        in
   3.637 +           {axioms = (mth, Meson.make_meta_clause ith) :: axioms,
   3.638 +            tfrees = union (op =) tfree_lits tfrees}
   3.639 +        end;
   3.640 +      val lmap0 = fold (add_thm true) cls {axioms = [], tfrees = init_tfrees ctxt}
   3.641 +      val lmap = fold (add_thm false) ths (add_tfrees lmap0)
   3.642 +      val clause_lists = map (Metis.Thm.clause o #1) (#axioms lmap)
   3.643 +      fun used c = exists (Metis.LiteralSet.exists (const_in_metis c o #2)) clause_lists
   3.644 +      (*Now check for the existence of certain combinators*)
   3.645 +      val thI  = if used "c_COMBI" then [comb_I] else []
   3.646 +      val thK  = if used "c_COMBK" then [comb_K] else []
   3.647 +      val thB   = if used "c_COMBB" then [comb_B] else []
   3.648 +      val thC   = if used "c_COMBC" then [comb_C] else []
   3.649 +      val thS   = if used "c_COMBS" then [comb_S] else []
   3.650 +      val thEQ  = if used "c_fequal" then [fequal_imp_equal', equal_imp_fequal'] else []
   3.651 +      val lmap' = if mode=FO then lmap
   3.652 +                  else fold (add_thm false) (thEQ @ thS @ thC @ thB @ thK @ thI) lmap
   3.653 +  in
   3.654 +      (mode, add_type_thm (type_ext thy (map prop_of (cls @ ths))) lmap')
   3.655 +  end;
   3.656 +
   3.657 +fun refute cls =
   3.658 +    Metis.Resolution.loop (Metis.Resolution.new Metis.Resolution.default cls);
   3.659 +
   3.660 +fun is_false t = t aconv (HOLogic.mk_Trueprop HOLogic.false_const);
   3.661 +
   3.662 +fun common_thm ths1 ths2 = exists (member Thm.eq_thm ths1) (map Meson.make_meta_clause ths2);
   3.663 +
   3.664 +exception METIS of string;
   3.665 +
   3.666 +(* Main function to start metis prove and reconstruction *)
   3.667 +fun FOL_SOLVE mode ctxt cls ths0 =
   3.668 +  let val thy = ProofContext.theory_of ctxt
   3.669 +      val th_cls_pairs = map (fn th => (Thm.get_name_hint th, Res_Axioms.cnf_axiom thy th)) ths0
   3.670 +      val ths = maps #2 th_cls_pairs
   3.671 +      val _ = trace_msg (fn () => "FOL_SOLVE: CONJECTURE CLAUSES")
   3.672 +      val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) cls
   3.673 +      val _ = trace_msg (fn () => "THEOREM CLAUSES")
   3.674 +      val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) ths
   3.675 +      val (mode, {axioms,tfrees}) = build_map mode ctxt cls ths
   3.676 +      val _ = if null tfrees then ()
   3.677 +              else (trace_msg (fn () => "TFREE CLAUSES");
   3.678 +                    app (fn tf => trace_msg (fn _ => Res_Clause.tptp_of_typeLit true tf)) tfrees)
   3.679 +      val _ = trace_msg (fn () => "CLAUSES GIVEN TO METIS")
   3.680 +      val thms = map #1 axioms
   3.681 +      val _ = app (fn th => trace_msg (fn () => Metis.Thm.toString th)) thms
   3.682 +      val _ = trace_msg (fn () => "mode = " ^ string_of_mode mode)
   3.683 +      val _ = trace_msg (fn () => "START METIS PROVE PROCESS")
   3.684 +  in
   3.685 +      case filter (is_false o prop_of) cls of
   3.686 +          false_th::_ => [false_th RS @{thm FalseE}]
   3.687 +        | [] =>
   3.688 +      case refute thms of
   3.689 +          Metis.Resolution.Contradiction mth =>
   3.690 +            let val _ = trace_msg (fn () => "METIS RECONSTRUCTION START: " ^
   3.691 +                          Metis.Thm.toString mth)
   3.692 +                val ctxt' = fold Variable.declare_constraints (map prop_of cls) ctxt
   3.693 +                             (*add constraints arising from converting goal to clause form*)
   3.694 +                val proof = Metis.Proof.proof mth
   3.695 +                val result = translate mode ctxt' axioms proof
   3.696 +                and used = map_filter (used_axioms axioms) proof
   3.697 +                val _ = trace_msg (fn () => "METIS COMPLETED...clauses actually used:")
   3.698 +                val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) used
   3.699 +                val unused = th_cls_pairs |> map_filter (fn (name, cls) =>
   3.700 +                  if common_thm used cls then NONE else SOME name)
   3.701 +            in
   3.702 +                if null unused then ()
   3.703 +                else warning ("Metis: unused theorems " ^ commas_quote unused);
   3.704 +                case result of
   3.705 +                    (_,ith)::_ =>
   3.706 +                        (trace_msg (fn () => "success: " ^ Display.string_of_thm ctxt ith);
   3.707 +                         [ith])
   3.708 +                  | _ => (trace_msg (fn () => "Metis: no result");
   3.709 +                          [])
   3.710 +            end
   3.711 +        | Metis.Resolution.Satisfiable _ =>
   3.712 +            (trace_msg (fn () => "Metis: No first-order proof with the lemmas supplied");
   3.713 +             [])
   3.714 +  end;
   3.715 +
   3.716 +fun metis_general_tac mode ctxt ths i st0 =
   3.717 +  let val _ = trace_msg (fn () =>
   3.718 +        "Metis called with theorems " ^ cat_lines (map (Display.string_of_thm ctxt) ths))
   3.719 +  in
   3.720 +    if exists_type Res_Axioms.type_has_topsort (prop_of st0)
   3.721 +    then raise METIS "Metis: Proof state contains the universal sort {}"
   3.722 +    else
   3.723 +      (Meson.MESON Res_Axioms.neg_clausify
   3.724 +        (fn cls => resolve_tac (FOL_SOLVE mode ctxt cls ths) 1) ctxt i
   3.725 +          THEN Res_Axioms.expand_defs_tac st0) st0
   3.726 +  end
   3.727 +  handle METIS s => (warning ("Metis: " ^ s); Seq.empty);
   3.728 +
   3.729 +val metis_tac = metis_general_tac HO;
   3.730 +val metisF_tac = metis_general_tac FO;
   3.731 +val metisFT_tac = metis_general_tac FT;
   3.732 +
   3.733 +fun method name mode comment = Method.setup name (Attrib.thms >> (fn ths => fn ctxt =>
   3.734 +  SIMPLE_METHOD' (CHANGED_PROP o metis_general_tac mode ctxt ths))) comment;
   3.735 +
   3.736 +val setup =
   3.737 +  type_lits_setup #>
   3.738 +  method @{binding metis} HO "METIS for FOL & HOL problems" #>
   3.739 +  method @{binding metisF} FO "METIS for FOL problems" #>
   3.740 +  method @{binding metisFT} FT "METIS with fully-typed translation" #>
   3.741 +  Method.setup @{binding finish_clausify}
   3.742 +    (Scan.succeed (K (SIMPLE_METHOD (Res_Axioms.expand_defs_tac refl))))
   3.743 +    "cleanup after conversion to clauses";
   3.744 +
   3.745 +end;
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_fact_filter.ML	Wed Mar 17 18:16:31 2010 +0100
     4.3 @@ -0,0 +1,559 @@
     4.4 +(*  Title:      HOL/Tools/res_atp.ML
     4.5 +    Author:     Jia Meng, Cambridge University Computer Laboratory, NICTA
     4.6 +*)
     4.7 +
     4.8 +signature RES_ATP =
     4.9 +sig
    4.10 +  datatype mode = Auto | Fol | Hol
    4.11 +  val tvar_classes_of_terms : term list -> string list
    4.12 +  val tfree_classes_of_terms : term list -> string list
    4.13 +  val type_consts_of_terms : theory -> term list -> string list
    4.14 +  val get_relevant : int -> bool -> Proof.context * (thm list * 'a) -> thm list ->
    4.15 +    (thm * (string * int)) list
    4.16 +  val prepare_clauses : bool -> thm list -> thm list ->
    4.17 +    (thm * (Res_HOL_Clause.axiom_name * Res_HOL_Clause.clause_id)) list ->
    4.18 +    (thm * (Res_HOL_Clause.axiom_name * Res_HOL_Clause.clause_id)) list -> theory ->
    4.19 +    Res_HOL_Clause.axiom_name vector *
    4.20 +      (Res_HOL_Clause.clause list * Res_HOL_Clause.clause list * Res_HOL_Clause.clause list *
    4.21 +      Res_HOL_Clause.clause list * Res_Clause.classrelClause list * Res_Clause.arityClause list)
    4.22 +end;
    4.23 +
    4.24 +structure Res_ATP: RES_ATP =
    4.25 +struct
    4.26 +
    4.27 +
    4.28 +(********************************************************************)
    4.29 +(* some settings for both background automatic ATP calling procedure*)
    4.30 +(* and also explicit ATP invocation methods                         *)
    4.31 +(********************************************************************)
    4.32 +
    4.33 +(*Translation mode can be auto-detected, or forced to be first-order or higher-order*)
    4.34 +datatype mode = Auto | Fol | Hol;
    4.35 +
    4.36 +val linkup_logic_mode = Auto;
    4.37 +
    4.38 +(*** background linkup ***)
    4.39 +val run_blacklist_filter = true;
    4.40 +
    4.41 +(*** relevance filter parameters ***)
    4.42 +val run_relevance_filter = true;
    4.43 +val pass_mark = 0.5;
    4.44 +val convergence = 3.2;    (*Higher numbers allow longer inference chains*)
    4.45 +val follow_defs = false;  (*Follow definitions. Makes problems bigger.*)
    4.46 +  
    4.47 +(***************************************************************)
    4.48 +(* Relevance Filtering                                         *)
    4.49 +(***************************************************************)
    4.50 +
    4.51 +fun strip_Trueprop (Const("Trueprop",_) $ t) = t
    4.52 +  | strip_Trueprop t = t;
    4.53 +
    4.54 +(*A surprising number of theorems contain only a few significant constants.
    4.55 +  These include all induction rules, and other general theorems. Filtering
    4.56 +  theorems in clause form reveals these complexities in the form of Skolem 
    4.57 +  functions. If we were instead to filter theorems in their natural form,
    4.58 +  some other method of measuring theorem complexity would become necessary.*)
    4.59 +
    4.60 +fun log_weight2 (x:real) = 1.0 + 2.0/Math.ln (x+1.0);
    4.61 +
    4.62 +(*The default seems best in practice. A constant function of one ignores
    4.63 +  the constant frequencies.*)
    4.64 +val weight_fn = log_weight2;
    4.65 +
    4.66 +
    4.67 +(*Including equality in this list might be expected to stop rules like subset_antisym from
    4.68 +  being chosen, but for some reason filtering works better with them listed. The
    4.69 +  logical signs All, Ex, &, and --> are omitted because any remaining occurrrences
    4.70 +  must be within comprehensions.*)
    4.71 +val standard_consts = ["Trueprop","==>","all","==","op |","Not","op ="];
    4.72 +
    4.73 +
    4.74 +(*** constants with types ***)
    4.75 +
    4.76 +(*An abstraction of Isabelle types*)
    4.77 +datatype const_typ =  CTVar | CType of string * const_typ list
    4.78 +
    4.79 +(*Is the second type an instance of the first one?*)
    4.80 +fun match_type (CType(con1,args1)) (CType(con2,args2)) = 
    4.81 +      con1=con2 andalso match_types args1 args2
    4.82 +  | match_type CTVar _ = true
    4.83 +  | match_type _ CTVar = false
    4.84 +and match_types [] [] = true
    4.85 +  | match_types (a1::as1) (a2::as2) = match_type a1 a2 andalso match_types as1 as2;
    4.86 +
    4.87 +(*Is there a unifiable constant?*)
    4.88 +fun uni_mem gctab (c,c_typ) =
    4.89 +  case Symtab.lookup gctab c of
    4.90 +      NONE => false
    4.91 +    | SOME ctyps_list => exists (match_types c_typ) ctyps_list;
    4.92 +  
    4.93 +(*Maps a "real" type to a const_typ*)
    4.94 +fun const_typ_of (Type (c,typs)) = CType (c, map const_typ_of typs) 
    4.95 +  | const_typ_of (TFree _) = CTVar
    4.96 +  | const_typ_of (TVar _) = CTVar
    4.97 +
    4.98 +(*Pairs a constant with the list of its type instantiations (using const_typ)*)
    4.99 +fun const_with_typ thy (c,typ) = 
   4.100 +    let val tvars = Sign.const_typargs thy (c,typ)
   4.101 +    in (c, map const_typ_of tvars) end
   4.102 +    handle TYPE _ => (c,[]);   (*Variable (locale constant): monomorphic*)   
   4.103 +
   4.104 +(*Add a const/type pair to the table, but a [] entry means a standard connective,
   4.105 +  which we ignore.*)
   4.106 +fun add_const_typ_table ((c,ctyps), tab) =
   4.107 +  Symtab.map_default (c, [ctyps]) (fn [] => [] | ctyps_list => insert (op =) ctyps ctyps_list) 
   4.108 +    tab;
   4.109 +
   4.110 +(*Free variables are included, as well as constants, to handle locales*)
   4.111 +fun add_term_consts_typs_rm thy (Const(c, typ), tab) =
   4.112 +      add_const_typ_table (const_with_typ thy (c,typ), tab) 
   4.113 +  | add_term_consts_typs_rm thy (Free(c, typ), tab) =
   4.114 +      add_const_typ_table (const_with_typ thy (c,typ), tab) 
   4.115 +  | add_term_consts_typs_rm thy (t $ u, tab) =
   4.116 +      add_term_consts_typs_rm thy (t, add_term_consts_typs_rm thy (u, tab))
   4.117 +  | add_term_consts_typs_rm thy (Abs(_,_,t), tab) = add_term_consts_typs_rm thy (t, tab)
   4.118 +  | add_term_consts_typs_rm _ (_, tab) = tab;
   4.119 +
   4.120 +(*The empty list here indicates that the constant is being ignored*)
   4.121 +fun add_standard_const (s,tab) = Symtab.update (s,[]) tab;
   4.122 +
   4.123 +val null_const_tab : const_typ list list Symtab.table = 
   4.124 +    List.foldl add_standard_const Symtab.empty standard_consts;
   4.125 +
   4.126 +fun get_goal_consts_typs thy = List.foldl (add_term_consts_typs_rm thy) null_const_tab;
   4.127 +
   4.128 +(*Inserts a dummy "constant" referring to the theory name, so that relevance
   4.129 +  takes the given theory into account.*)
   4.130 +fun const_prop_of theory_const th =
   4.131 + if theory_const then
   4.132 +  let val name = Context.theory_name (theory_of_thm th)
   4.133 +      val t = Const (name ^ ". 1", HOLogic.boolT)
   4.134 +  in  t $ prop_of th  end
   4.135 + else prop_of th;
   4.136 +
   4.137 +(**** Constant / Type Frequencies ****)
   4.138 +
   4.139 +(*A two-dimensional symbol table counts frequencies of constants. It's keyed first by
   4.140 +  constant name and second by its list of type instantiations. For the latter, we need
   4.141 +  a linear ordering on type const_typ list.*)
   4.142 +  
   4.143 +local
   4.144 +
   4.145 +fun cons_nr CTVar = 0
   4.146 +  | cons_nr (CType _) = 1;
   4.147 +
   4.148 +in
   4.149 +
   4.150 +fun const_typ_ord TU =
   4.151 +  case TU of
   4.152 +    (CType (a, Ts), CType (b, Us)) =>
   4.153 +      (case fast_string_ord(a,b) of EQUAL => dict_ord const_typ_ord (Ts,Us) | ord => ord)
   4.154 +  | (T, U) => int_ord (cons_nr T, cons_nr U);
   4.155 +
   4.156 +end;
   4.157 +
   4.158 +structure CTtab = Table(type key = const_typ list val ord = dict_ord const_typ_ord);
   4.159 +
   4.160 +fun count_axiom_consts theory_const thy ((thm,_), tab) = 
   4.161 +  let fun count_const (a, T, tab) =
   4.162 +        let val (c, cts) = const_with_typ thy (a,T)
   4.163 +        in  (*Two-dimensional table update. Constant maps to types maps to count.*)
   4.164 +            Symtab.map_default (c, CTtab.empty) 
   4.165 +                               (CTtab.map_default (cts,0) (fn n => n+1)) tab
   4.166 +        end
   4.167 +      fun count_term_consts (Const(a,T), tab) = count_const(a,T,tab)
   4.168 +        | count_term_consts (Free(a,T), tab) = count_const(a,T,tab)
   4.169 +        | count_term_consts (t $ u, tab) =
   4.170 +            count_term_consts (t, count_term_consts (u, tab))
   4.171 +        | count_term_consts (Abs(_,_,t), tab) = count_term_consts (t, tab)
   4.172 +        | count_term_consts (_, tab) = tab
   4.173 +  in  count_term_consts (const_prop_of theory_const thm, tab)  end;
   4.174 +
   4.175 +
   4.176 +(**** Actual Filtering Code ****)
   4.177 +
   4.178 +(*The frequency of a constant is the sum of those of all instances of its type.*)
   4.179 +fun const_frequency ctab (c, cts) =
   4.180 +  let val pairs = CTtab.dest (the (Symtab.lookup ctab c))
   4.181 +      fun add ((cts',m), n) = if match_types cts cts' then m+n else n
   4.182 +  in  List.foldl add 0 pairs  end;
   4.183 +
   4.184 +(*Add in a constant's weight, as determined by its frequency.*)
   4.185 +fun add_ct_weight ctab ((c,T), w) =
   4.186 +  w + weight_fn (real (const_frequency ctab (c,T)));
   4.187 +
   4.188 +(*Relevant constants are weighted according to frequency, 
   4.189 +  but irrelevant constants are simply counted. Otherwise, Skolem functions,
   4.190 +  which are rare, would harm a clause's chances of being picked.*)
   4.191 +fun clause_weight ctab gctyps consts_typs =
   4.192 +    let val rel = filter (uni_mem gctyps) consts_typs
   4.193 +        val rel_weight = List.foldl (add_ct_weight ctab) 0.0 rel
   4.194 +    in
   4.195 +        rel_weight / (rel_weight + real (length consts_typs - length rel))
   4.196 +    end;
   4.197 +    
   4.198 +(*Multiplies out to a list of pairs: 'a * 'b list -> ('a * 'b) list -> ('a * 'b) list*)
   4.199 +fun add_expand_pairs (x,ys) xys = List.foldl (fn (y,acc) => (x,y)::acc) xys ys;
   4.200 +
   4.201 +fun consts_typs_of_term thy t = 
   4.202 +  let val tab = add_term_consts_typs_rm thy (t, null_const_tab)
   4.203 +  in  Symtab.fold add_expand_pairs tab []  end;
   4.204 +
   4.205 +fun pair_consts_typs_axiom theory_const thy (thm,name) =
   4.206 +    ((thm,name), (consts_typs_of_term thy (const_prop_of theory_const thm)));
   4.207 +
   4.208 +exception ConstFree;
   4.209 +fun dest_ConstFree (Const aT) = aT
   4.210 +  | dest_ConstFree (Free aT) = aT
   4.211 +  | dest_ConstFree _ = raise ConstFree;
   4.212 +
   4.213 +(*Look for definitions of the form f ?x1 ... ?xn = t, but not reversed.*)
   4.214 +fun defines thy thm gctypes =
   4.215 +    let val tm = prop_of thm
   4.216 +        fun defs lhs rhs =
   4.217 +            let val (rator,args) = strip_comb lhs
   4.218 +                val ct = const_with_typ thy (dest_ConstFree rator)
   4.219 +            in
   4.220 +              forall is_Var args andalso uni_mem gctypes ct andalso
   4.221 +                subset (op =) (Term.add_vars rhs [], Term.add_vars lhs [])
   4.222 +            end
   4.223 +            handle ConstFree => false
   4.224 +    in    
   4.225 +        case tm of Const ("Trueprop",_) $ (Const("op =",_) $ lhs $ rhs) => 
   4.226 +                   defs lhs rhs 
   4.227 +                 | _ => false
   4.228 +    end;
   4.229 +
   4.230 +type annotd_cls = (thm * (string * int)) * ((string * const_typ list) list);
   4.231 +       
   4.232 +(*For a reverse sort, putting the largest values first.*)
   4.233 +fun compare_pairs ((_,w1),(_,w2)) = Real.compare (w2,w1);
   4.234 +
   4.235 +(*Limit the number of new clauses, to prevent runaway acceptance.*)
   4.236 +fun take_best max_new (newpairs : (annotd_cls*real) list) =
   4.237 +  let val nnew = length newpairs
   4.238 +  in
   4.239 +    if nnew <= max_new then (map #1 newpairs, [])
   4.240 +    else 
   4.241 +      let val cls = sort compare_pairs newpairs
   4.242 +          val accepted = List.take (cls, max_new)
   4.243 +      in
   4.244 +        Res_Axioms.trace_msg (fn () => ("Number of candidates, " ^ Int.toString nnew ^ 
   4.245 +                       ", exceeds the limit of " ^ Int.toString (max_new)));
   4.246 +        Res_Axioms.trace_msg (fn () => ("Effective pass mark: " ^ Real.toString (#2 (List.last accepted))));
   4.247 +        Res_Axioms.trace_msg (fn () => "Actually passed: " ^
   4.248 +          space_implode ", " (map (fn (((_,(name,_)),_),_) => name) accepted));
   4.249 +
   4.250 +        (map #1 accepted, map #1 (List.drop (cls, max_new)))
   4.251 +      end
   4.252 +  end;
   4.253 +
   4.254 +fun relevant_clauses max_new thy ctab p rel_consts =
   4.255 +  let fun relevant ([],_) [] = [] : (thm * (string * int)) list  (*Nothing added this iteration*)
   4.256 +        | relevant (newpairs,rejects) [] =
   4.257 +            let val (newrels,more_rejects) = take_best max_new newpairs
   4.258 +                val new_consts = maps #2 newrels
   4.259 +                val rel_consts' = List.foldl add_const_typ_table rel_consts new_consts
   4.260 +                val newp = p + (1.0-p) / convergence
   4.261 +            in
   4.262 +              Res_Axioms.trace_msg (fn () => "relevant this iteration: " ^ Int.toString (length newrels));
   4.263 +               (map #1 newrels) @ 
   4.264 +               (relevant_clauses max_new thy ctab newp rel_consts' (more_rejects@rejects))
   4.265 +            end
   4.266 +        | relevant (newrels,rejects) ((ax as (clsthm as (_,(name,n)),consts_typs)) :: axs) =
   4.267 +            let val weight = clause_weight ctab rel_consts consts_typs
   4.268 +            in
   4.269 +              if p <= weight orelse (follow_defs andalso defines thy (#1 clsthm) rel_consts)
   4.270 +              then (Res_Axioms.trace_msg (fn () => (name ^ " clause " ^ Int.toString n ^ 
   4.271 +                                            " passes: " ^ Real.toString weight));
   4.272 +                    relevant ((ax,weight)::newrels, rejects) axs)
   4.273 +              else relevant (newrels, ax::rejects) axs
   4.274 +            end
   4.275 +    in  Res_Axioms.trace_msg (fn () => ("relevant_clauses, current pass mark = " ^ Real.toString p));
   4.276 +        relevant ([],[]) 
   4.277 +    end;
   4.278 +        
   4.279 +fun relevance_filter max_new theory_const thy axioms goals = 
   4.280 + if run_relevance_filter andalso pass_mark >= 0.1
   4.281 + then
   4.282 +  let val const_tab = List.foldl (count_axiom_consts theory_const thy) Symtab.empty axioms
   4.283 +      val goal_const_tab = get_goal_consts_typs thy goals
   4.284 +      val _ = Res_Axioms.trace_msg (fn () => ("Initial constants: " ^
   4.285 +                                 space_implode ", " (Symtab.keys goal_const_tab)));
   4.286 +      val rels = relevant_clauses max_new thy const_tab (pass_mark) 
   4.287 +                   goal_const_tab  (map (pair_consts_typs_axiom theory_const thy) axioms)
   4.288 +  in
   4.289 +      Res_Axioms.trace_msg (fn () => ("Total relevant: " ^ Int.toString (length rels)));
   4.290 +      rels
   4.291 +  end
   4.292 + else axioms;
   4.293 +
   4.294 +(***************************************************************)
   4.295 +(* Retrieving and filtering lemmas                             *)
   4.296 +(***************************************************************)
   4.297 +
   4.298 +(*** retrieve lemmas and filter them ***)
   4.299 +
   4.300 +(*Hashing to detect duplicate and variant clauses, e.g. from the [iff] attribute*)
   4.301 +
   4.302 +fun setinsert (x,s) = Symtab.update (x,()) s;
   4.303 +
   4.304 +(*Reject theorems with names like "List.filter.filter_list_def" or
   4.305 +  "Accessible_Part.acc.defs", as these are definitions arising from packages.*)
   4.306 +fun is_package_def a =
   4.307 +  let val names = Long_Name.explode a
   4.308 +  in
   4.309 +     length names > 2 andalso
   4.310 +     not (hd names = "local") andalso
   4.311 +     String.isSuffix "_def" a  orelse  String.isSuffix "_defs" a
   4.312 +  end;
   4.313 +
   4.314 +(** a hash function from Term.term to int, and also a hash table **)
   4.315 +val xor_words = List.foldl Word.xorb 0w0;
   4.316 +
   4.317 +fun hashw_term ((Const(c,_)), w) = Polyhash.hashw_string (c,w)
   4.318 +  | hashw_term ((Free(a,_)), w) = Polyhash.hashw_string (a,w)
   4.319 +  | hashw_term ((Var(_,_)), w) = w
   4.320 +  | hashw_term ((Bound i), w) = Polyhash.hashw_int(i,w)
   4.321 +  | hashw_term ((Abs(_,_,t)), w) = hashw_term (t, w)
   4.322 +  | hashw_term ((P$Q), w) = hashw_term (Q, (hashw_term (P, w)));
   4.323 +
   4.324 +fun hash_literal (Const("Not",_)$P) = Word.notb(hashw_term(P,0w0))
   4.325 +  | hash_literal P = hashw_term(P,0w0);
   4.326 +
   4.327 +fun hash_term t = Word.toIntX (xor_words (map hash_literal (HOLogic.disjuncts (strip_Trueprop t))));
   4.328 +
   4.329 +fun equal_thm (thm1,thm2) = Term.aconv(prop_of thm1, prop_of thm2);
   4.330 +
   4.331 +exception HASH_CLAUSE;
   4.332 +
   4.333 +(*Create a hash table for clauses, of the given size*)
   4.334 +fun mk_clause_table n =
   4.335 +      Polyhash.mkTable (hash_term o prop_of, equal_thm)
   4.336 +                       (n, HASH_CLAUSE);
   4.337 +
   4.338 +(*Use a hash table to eliminate duplicates from xs. Argument is a list of
   4.339 +  (thm * (string * int)) tuples. The theorems are hashed into the table. *)
   4.340 +fun make_unique xs =
   4.341 +  let val ht = mk_clause_table 7000
   4.342 +  in
   4.343 +      Res_Axioms.trace_msg (fn () => ("make_unique gets " ^ Int.toString (length xs) ^ " clauses"));
   4.344 +      app (ignore o Polyhash.peekInsert ht) xs;
   4.345 +      Polyhash.listItems ht
   4.346 +  end;
   4.347 +
   4.348 +(*Remove existing axiom clauses from the conjecture clauses, as this can dramatically
   4.349 +  boost an ATP's performance (for some reason)*)
   4.350 +fun subtract_cls c_clauses ax_clauses =
   4.351 +  let val ht = mk_clause_table 2200
   4.352 +      fun known x = is_some (Polyhash.peek ht x)
   4.353 +  in
   4.354 +      app (ignore o Polyhash.peekInsert ht) ax_clauses;
   4.355 +      filter (not o known) c_clauses
   4.356 +  end;
   4.357 +
   4.358 +fun all_valid_thms ctxt =
   4.359 +  let
   4.360 +    val global_facts = PureThy.facts_of (ProofContext.theory_of ctxt);
   4.361 +    val local_facts = ProofContext.facts_of ctxt;
   4.362 +    val full_space =
   4.363 +      Name_Space.merge (Facts.space_of global_facts, Facts.space_of local_facts);
   4.364 +
   4.365 +    fun valid_facts facts =
   4.366 +      (facts, []) |-> Facts.fold_static (fn (name, ths0) =>
   4.367 +        let
   4.368 +          fun check_thms a =
   4.369 +            (case try (ProofContext.get_thms ctxt) a of
   4.370 +              NONE => false
   4.371 +            | SOME ths1 => Thm.eq_thms (ths0, ths1));
   4.372 +
   4.373 +          val name1 = Facts.extern facts name;
   4.374 +          val name2 = Name_Space.extern full_space name;
   4.375 +          val ths = filter_out Res_Axioms.bad_for_atp ths0;
   4.376 +        in
   4.377 +          if Facts.is_concealed facts name orelse null ths orelse
   4.378 +            run_blacklist_filter andalso is_package_def name then I
   4.379 +          else
   4.380 +            (case find_first check_thms [name1, name2, name] of
   4.381 +              NONE => I
   4.382 +            | SOME a => cons (a, ths))
   4.383 +        end);
   4.384 +  in valid_facts global_facts @ valid_facts local_facts end;
   4.385 +
   4.386 +fun multi_name a th (n, pairs) =
   4.387 +  (n + 1, (a ^ "(" ^ Int.toString n ^ ")", th) :: pairs);
   4.388 +
   4.389 +fun add_single_names (a, []) pairs = pairs
   4.390 +  | add_single_names (a, [th]) pairs = (a, th) :: pairs
   4.391 +  | add_single_names (a, ths) pairs = #2 (fold (multi_name a) ths (1, pairs));
   4.392 +
   4.393 +(*Ignore blacklisted basenames*)
   4.394 +fun add_multi_names (a, ths) pairs =
   4.395 +  if (Long_Name.base_name a) mem_string Res_Axioms.multi_base_blacklist then pairs
   4.396 +  else add_single_names (a, ths) pairs;
   4.397 +
   4.398 +fun is_multi (a, ths) = length ths > 1 orelse String.isSuffix ".axioms" a;
   4.399 +
   4.400 +(*The single theorems go BEFORE the multiple ones. Blacklist is applied to all.*)
   4.401 +fun name_thm_pairs ctxt =
   4.402 +  let
   4.403 +    val (mults, singles) = List.partition is_multi (all_valid_thms ctxt)
   4.404 +    fun blacklisted (_, th) =
   4.405 +      run_blacklist_filter andalso Res_Blacklist.blacklisted ctxt th
   4.406 +  in
   4.407 +    filter_out blacklisted
   4.408 +      (fold add_single_names singles (fold add_multi_names mults []))
   4.409 +  end;
   4.410 +
   4.411 +fun check_named ("", th) =
   4.412 +      (warning ("No name for theorem " ^ Display.string_of_thm_without_context th); false)
   4.413 +  | check_named _ = true;
   4.414 +
   4.415 +fun get_all_lemmas ctxt =
   4.416 +  let val included_thms =
   4.417 +        tap (fn ths => Res_Axioms.trace_msg
   4.418 +                     (fn () => ("Including all " ^ Int.toString (length ths) ^ " theorems")))
   4.419 +            (name_thm_pairs ctxt)
   4.420 +  in
   4.421 +    filter check_named included_thms
   4.422 +  end;
   4.423 +
   4.424 +(***************************************************************)
   4.425 +(* Type Classes Present in the Axiom or Conjecture Clauses     *)
   4.426 +(***************************************************************)
   4.427 +
   4.428 +fun add_classes (sorts, cset) = List.foldl setinsert cset (flat sorts);
   4.429 +
   4.430 +(*Remove this trivial type class*)
   4.431 +fun delete_type cset = Symtab.delete_safe "HOL.type" cset;
   4.432 +
   4.433 +fun tvar_classes_of_terms ts =
   4.434 +  let val sorts_list = map (map #2 o OldTerm.term_tvars) ts
   4.435 +  in  Symtab.keys (delete_type (List.foldl add_classes Symtab.empty sorts_list))  end;
   4.436 +
   4.437 +fun tfree_classes_of_terms ts =
   4.438 +  let val sorts_list = map (map #2 o OldTerm.term_tfrees) ts
   4.439 +  in  Symtab.keys (delete_type (List.foldl add_classes Symtab.empty sorts_list))  end;
   4.440 +
   4.441 +(*fold type constructors*)
   4.442 +fun fold_type_consts f (Type (a, Ts)) x = fold (fold_type_consts f) Ts (f (a,x))
   4.443 +  | fold_type_consts _ _ x = x;
   4.444 +
   4.445 +val add_type_consts_in_type = fold_type_consts setinsert;
   4.446 +
   4.447 +(*Type constructors used to instantiate overloaded constants are the only ones needed.*)
   4.448 +fun add_type_consts_in_term thy =
   4.449 +  let val const_typargs = Sign.const_typargs thy
   4.450 +      fun add_tcs (Const cT) x = fold add_type_consts_in_type (const_typargs cT) x
   4.451 +        | add_tcs (Abs (_, _, u)) x = add_tcs u x
   4.452 +        | add_tcs (t $ u) x = add_tcs t (add_tcs u x)
   4.453 +        | add_tcs _ x = x
   4.454 +  in  add_tcs  end
   4.455 +
   4.456 +fun type_consts_of_terms thy ts =
   4.457 +  Symtab.keys (fold (add_type_consts_in_term thy) ts Symtab.empty);
   4.458 +
   4.459 +
   4.460 +(***************************************************************)
   4.461 +(* ATP invocation methods setup                                *)
   4.462 +(***************************************************************)
   4.463 +
   4.464 +(*Ensures that no higher-order theorems "leak out"*)
   4.465 +fun restrict_to_logic thy true cls = filter (Meson.is_fol_term thy o prop_of o fst) cls
   4.466 +  | restrict_to_logic thy false cls = cls;
   4.467 +
   4.468 +(**** Predicates to detect unwanted clauses (prolific or likely to cause unsoundness) ****)
   4.469 +
   4.470 +(** Too general means, positive equality literal with a variable X as one operand,
   4.471 +  when X does not occur properly in the other operand. This rules out clearly
   4.472 +  inconsistent clauses such as V=a|V=b, though it by no means guarantees soundness. **)
   4.473 +
   4.474 +fun occurs ix =
   4.475 +    let fun occ(Var (jx,_)) = (ix=jx)
   4.476 +          | occ(t1$t2)      = occ t1 orelse occ t2
   4.477 +          | occ(Abs(_,_,t)) = occ t
   4.478 +          | occ _           = false
   4.479 +    in occ end;
   4.480 +
   4.481 +fun is_recordtype T = not (null (Record.dest_recTs T));
   4.482 +
   4.483 +(*Unwanted equalities include
   4.484 +  (1) those between a variable that does not properly occur in the second operand,
   4.485 +  (2) those between a variable and a record, since these seem to be prolific "cases" thms
   4.486 +*)
   4.487 +fun too_general_eqterms (Var (ix,T), t) = not (occurs ix t) orelse is_recordtype T
   4.488 +  | too_general_eqterms _ = false;
   4.489 +
   4.490 +fun too_general_equality (Const ("op =", _) $ x $ y) =
   4.491 +      too_general_eqterms (x,y) orelse too_general_eqterms(y,x)
   4.492 +  | too_general_equality _ = false;
   4.493 +
   4.494 +(* tautologous? *)
   4.495 +fun is_taut (Const ("Trueprop", _) $ Const ("True", _)) = true
   4.496 +  | is_taut _ = false;
   4.497 +
   4.498 +fun has_typed_var tycons = exists_subterm
   4.499 +  (fn Var (_, Type (a, _)) => member (op =) tycons a | _ => false);
   4.500 +
   4.501 +(*Clauses are forbidden to contain variables of these types. The typical reason is that
   4.502 +  they lead to unsoundness. Note that "unit" satisfies numerous equations like ?X=().
   4.503 +  The resulting clause will have no type constraint, yielding false proofs. Even "bool"
   4.504 +  leads to many unsound proofs, though (obviously) only for higher-order problems.*)
   4.505 +val unwanted_types = ["Product_Type.unit","bool"];
   4.506 +
   4.507 +fun unwanted t =
   4.508 +  is_taut t orelse has_typed_var unwanted_types t orelse
   4.509 +  forall too_general_equality (HOLogic.disjuncts (strip_Trueprop t));
   4.510 +
   4.511 +(*Clauses containing variables of type "unit" or "bool" are unlikely to be useful and
   4.512 +  likely to lead to unsound proofs.*)
   4.513 +fun remove_unwanted_clauses cls = filter (not o unwanted o prop_of o fst) cls;
   4.514 +
   4.515 +fun isFO thy goal_cls = case linkup_logic_mode of
   4.516 +      Auto => forall (Meson.is_fol_term thy) (map prop_of goal_cls)
   4.517 +    | Fol => true
   4.518 +    | Hol => false
   4.519 +
   4.520 +fun get_relevant max_new theory_const (ctxt, (chain_ths, th)) goal_cls =
   4.521 +  let
   4.522 +    val thy = ProofContext.theory_of ctxt
   4.523 +    val isFO = isFO thy goal_cls
   4.524 +    val included_cls = get_all_lemmas ctxt
   4.525 +      |> Res_Axioms.cnf_rules_pairs thy |> make_unique
   4.526 +      |> restrict_to_logic thy isFO
   4.527 +      |> remove_unwanted_clauses
   4.528 +  in
   4.529 +    relevance_filter max_new theory_const thy included_cls (map prop_of goal_cls) 
   4.530 +  end;
   4.531 +
   4.532 +(* prepare for passing to writer,
   4.533 +   create additional clauses based on the information from extra_cls *)
   4.534 +fun prepare_clauses dfg goal_cls chain_ths axcls extra_cls thy =
   4.535 +  let
   4.536 +    (* add chain thms *)
   4.537 +    val chain_cls =
   4.538 +      Res_Axioms.cnf_rules_pairs thy (filter check_named (map Res_Axioms.pairname chain_ths))
   4.539 +    val axcls = chain_cls @ axcls
   4.540 +    val extra_cls = chain_cls @ extra_cls
   4.541 +    val isFO = isFO thy goal_cls
   4.542 +    val ccls = subtract_cls goal_cls extra_cls
   4.543 +    val _ = app (fn th => Res_Axioms.trace_msg (fn _ => Display.string_of_thm_global thy th)) ccls
   4.544 +    val ccltms = map prop_of ccls
   4.545 +    and axtms = map (prop_of o #1) extra_cls
   4.546 +    val subs = tfree_classes_of_terms ccltms
   4.547 +    and supers = tvar_classes_of_terms axtms
   4.548 +    and tycons = type_consts_of_terms thy (ccltms@axtms)
   4.549 +    (*TFrees in conjecture clauses; TVars in axiom clauses*)
   4.550 +    val conjectures = Res_HOL_Clause.make_conjecture_clauses dfg thy ccls
   4.551 +    val (_, extra_clauses) = ListPair.unzip (Res_HOL_Clause.make_axiom_clauses dfg thy extra_cls)
   4.552 +    val (clnames,axiom_clauses) = ListPair.unzip (Res_HOL_Clause.make_axiom_clauses dfg thy axcls)
   4.553 +    val helper_clauses = Res_HOL_Clause.get_helper_clauses dfg thy isFO (conjectures, extra_cls, [])
   4.554 +    val (supers',arity_clauses) = Res_Clause.make_arity_clauses_dfg dfg thy tycons supers
   4.555 +    val classrel_clauses = Res_Clause.make_classrel_clauses thy subs supers'
   4.556 +  in
   4.557 +    (Vector.fromList clnames,
   4.558 +      (conjectures, axiom_clauses, extra_clauses, helper_clauses, classrel_clauses, arity_clauses))
   4.559 +  end
   4.560 +
   4.561 +end;
   4.562 +
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_fact_preprocessor.ML	Wed Mar 17 18:16:31 2010 +0100
     5.3 @@ -0,0 +1,545 @@
     5.4 +(*  Title:      HOL/Tools/res_axioms.ML
     5.5 +    Author:     Jia Meng, Cambridge University Computer Laboratory
     5.6 +
     5.7 +Transformation of axiom rules (elim/intro/etc) into CNF forms.
     5.8 +*)
     5.9 +
    5.10 +signature RES_AXIOMS =
    5.11 +sig
    5.12 +  val trace: bool Unsynchronized.ref
    5.13 +  val trace_msg: (unit -> string) -> unit
    5.14 +  val cnf_axiom: theory -> thm -> thm list
    5.15 +  val pairname: thm -> string * thm
    5.16 +  val multi_base_blacklist: string list
    5.17 +  val bad_for_atp: thm -> bool
    5.18 +  val type_has_topsort: typ -> bool
    5.19 +  val cnf_rules_pairs: theory -> (string * thm) list -> (thm * (string * int)) list
    5.20 +  val neg_clausify: thm list -> thm list
    5.21 +  val expand_defs_tac: thm -> tactic
    5.22 +  val combinators: thm -> thm
    5.23 +  val neg_conjecture_clauses: Proof.context -> thm -> int -> thm list * (string * typ) list
    5.24 +  val suppress_endtheory: bool Unsynchronized.ref
    5.25 +    (*for emergency use where endtheory causes problems*)
    5.26 +  val setup: theory -> theory
    5.27 +end;
    5.28 +
    5.29 +structure Res_Axioms: RES_AXIOMS =
    5.30 +struct
    5.31 +
    5.32 +val trace = Unsynchronized.ref false;
    5.33 +fun trace_msg msg = if ! trace then tracing (msg ()) else ();
    5.34 +
    5.35 +fun freeze_thm th = #1 (Drule.legacy_freeze_thaw th);
    5.36 +
    5.37 +val type_has_topsort = Term.exists_subtype
    5.38 +  (fn TFree (_, []) => true
    5.39 +    | TVar (_, []) => true
    5.40 +    | _ => false);
    5.41 +
    5.42 +
    5.43 +(**** Transformation of Elimination Rules into First-Order Formulas****)
    5.44 +
    5.45 +val cfalse = cterm_of @{theory HOL} HOLogic.false_const;
    5.46 +val ctp_false = cterm_of @{theory HOL} (HOLogic.mk_Trueprop HOLogic.false_const);
    5.47 +
    5.48 +(*Converts an elim-rule into an equivalent theorem that does not have the
    5.49 +  predicate variable.  Leaves other theorems unchanged.  We simply instantiate the
    5.50 +  conclusion variable to False.*)
    5.51 +fun transform_elim th =
    5.52 +  case concl_of th of    (*conclusion variable*)
    5.53 +       Const("Trueprop",_) $ (v as Var(_,Type("bool",[]))) =>
    5.54 +           Thm.instantiate ([], [(cterm_of @{theory HOL} v, cfalse)]) th
    5.55 +    | v as Var(_, Type("prop",[])) =>
    5.56 +           Thm.instantiate ([], [(cterm_of @{theory HOL} v, ctp_false)]) th
    5.57 +    | _ => th;
    5.58 +
    5.59 +(*To enforce single-threading*)
    5.60 +exception Clausify_failure of theory;
    5.61 +
    5.62 +
    5.63 +(**** SKOLEMIZATION BY INFERENCE (lcp) ****)
    5.64 +
    5.65 +fun rhs_extra_types lhsT rhs =
    5.66 +  let val lhs_vars = Term.add_tfreesT lhsT []
    5.67 +      fun add_new_TFrees (TFree v) =
    5.68 +            if member (op =) lhs_vars v then I else insert (op =) (TFree v)
    5.69 +        | add_new_TFrees _ = I
    5.70 +      val rhs_consts = fold_aterms (fn Const c => insert (op =) c | _ => I) rhs []
    5.71 +  in fold (#2 #> Term.fold_atyps add_new_TFrees) rhs_consts [] end;
    5.72 +
    5.73 +(*Traverse a theorem, declaring Skolem function definitions. String s is the suggested
    5.74 +  prefix for the Skolem constant.*)
    5.75 +fun declare_skofuns s th =
    5.76 +  let
    5.77 +    val nref = Unsynchronized.ref 0    (* FIXME ??? *)
    5.78 +    fun dec_sko (Const ("Ex",_) $ (xtp as Abs (_, T, p))) (axs, thy) =
    5.79 +          (*Existential: declare a Skolem function, then insert into body and continue*)
    5.80 +          let
    5.81 +            val cname = "sko_" ^ s ^ "_" ^ Int.toString (Unsynchronized.inc nref)
    5.82 +            val args0 = OldTerm.term_frees xtp  (*get the formal parameter list*)
    5.83 +            val Ts = map type_of args0
    5.84 +            val extraTs = rhs_extra_types (Ts ---> T) xtp
    5.85 +            val argsx = map (fn T => Free (gensym "vsk", T)) extraTs
    5.86 +            val args = argsx @ args0
    5.87 +            val cT = extraTs ---> Ts ---> T
    5.88 +            val rhs = list_abs_free (map dest_Free args, HOLogic.choice_const T $ xtp)
    5.89 +                    (*Forms a lambda-abstraction over the formal parameters*)
    5.90 +            val (c, thy') =
    5.91 +              Sign.declare_const ((Binding.conceal (Binding.name cname), cT), NoSyn) thy
    5.92 +            val cdef = cname ^ "_def"
    5.93 +            val thy'' =
    5.94 +              Theory.add_defs_i true false [(Binding.name cdef, Logic.mk_equals (c, rhs))] thy'
    5.95 +            val ax = Thm.axiom thy'' (Sign.full_bname thy'' cdef)
    5.96 +          in dec_sko (subst_bound (list_comb (c, args), p)) (ax :: axs, thy'') end
    5.97 +      | dec_sko (Const ("All", _) $ (Abs (a, T, p))) thx =
    5.98 +          (*Universal quant: insert a free variable into body and continue*)
    5.99 +          let val fname = Name.variant (OldTerm.add_term_names (p, [])) a
   5.100 +          in dec_sko (subst_bound (Free (fname, T), p)) thx end
   5.101 +      | dec_sko (Const ("op &", _) $ p $ q) thx = dec_sko q (dec_sko p thx)
   5.102 +      | dec_sko (Const ("op |", _) $ p $ q) thx = dec_sko q (dec_sko p thx)
   5.103 +      | dec_sko (Const ("Trueprop", _) $ p) thx = dec_sko p thx
   5.104 +      | dec_sko t thx = thx (*Do nothing otherwise*)
   5.105 +  in fn thy => dec_sko (Thm.prop_of th) ([], thy) end;
   5.106 +
   5.107 +(*Traverse a theorem, accumulating Skolem function definitions.*)
   5.108 +fun assume_skofuns s th =
   5.109 +  let val sko_count = Unsynchronized.ref 0   (* FIXME ??? *)
   5.110 +      fun dec_sko (Const ("Ex",_) $ (xtp as Abs(_,T,p))) defs =
   5.111 +            (*Existential: declare a Skolem function, then insert into body and continue*)
   5.112 +            let val skos = map (#1 o Logic.dest_equals) defs  (*existing sko fns*)
   5.113 +                val args = subtract (op =) skos (OldTerm.term_frees xtp) (*the formal parameters*)
   5.114 +                val Ts = map type_of args
   5.115 +                val cT = Ts ---> T
   5.116 +                val id = "sko_" ^ s ^ "_" ^ Int.toString (Unsynchronized.inc sko_count)
   5.117 +                val c = Free (id, cT)
   5.118 +                val rhs = list_abs_free (map dest_Free args,
   5.119 +                                         HOLogic.choice_const T $ xtp)
   5.120 +                      (*Forms a lambda-abstraction over the formal parameters*)
   5.121 +                val def = Logic.mk_equals (c, rhs)
   5.122 +            in dec_sko (subst_bound (list_comb(c,args), p))
   5.123 +                       (def :: defs)
   5.124 +            end
   5.125 +        | dec_sko (Const ("All",_) $ Abs (a, T, p)) defs =
   5.126 +            (*Universal quant: insert a free variable into body and continue*)
   5.127 +            let val fname = Name.variant (OldTerm.add_term_names (p,[])) a
   5.128 +            in dec_sko (subst_bound (Free(fname,T), p)) defs end
   5.129 +        | dec_sko (Const ("op &", _) $ p $ q) defs = dec_sko q (dec_sko p defs)
   5.130 +        | dec_sko (Const ("op |", _) $ p $ q) defs = dec_sko q (dec_sko p defs)
   5.131 +        | dec_sko (Const ("Trueprop", _) $ p) defs = dec_sko p defs
   5.132 +        | dec_sko t defs = defs (*Do nothing otherwise*)
   5.133 +  in  dec_sko (prop_of th) []  end;
   5.134 +
   5.135 +
   5.136 +(**** REPLACING ABSTRACTIONS BY COMBINATORS ****)
   5.137 +
   5.138 +(*Returns the vars of a theorem*)
   5.139 +fun vars_of_thm th =
   5.140 +  map (Thm.cterm_of (theory_of_thm th) o Var) (Thm.fold_terms Term.add_vars th []);
   5.141 +
   5.142 +(*Make a version of fun_cong with a given variable name*)
   5.143 +local
   5.144 +    val fun_cong' = fun_cong RS asm_rl; (*renumber f, g to prevent clashes with (a,0)*)
   5.145 +    val cx = hd (vars_of_thm fun_cong');
   5.146 +    val ty = typ_of (ctyp_of_term cx);
   5.147 +    val thy = theory_of_thm fun_cong;
   5.148 +    fun mkvar a = cterm_of thy (Var((a,0),ty));
   5.149 +in
   5.150 +fun xfun_cong x = Thm.instantiate ([], [(cx, mkvar x)]) fun_cong'
   5.151 +end;
   5.152 +
   5.153 +(*Removes the lambdas from an equation of the form t = (%x. u).  A non-negative n,
   5.154 +  serves as an upper bound on how many to remove.*)
   5.155 +fun strip_lambdas 0 th = th
   5.156 +  | strip_lambdas n th =
   5.157 +      case prop_of th of
   5.158 +          _ $ (Const ("op =", _) $ _ $ Abs (x,_,_)) =>
   5.159 +              strip_lambdas (n-1) (freeze_thm (th RS xfun_cong x))
   5.160 +        | _ => th;
   5.161 +
   5.162 +val lambda_free = not o Term.has_abs;
   5.163 +
   5.164 +val [f_B,g_B] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_B}));
   5.165 +val [g_C,f_C] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_C}));
   5.166 +val [f_S,g_S] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_S}));
   5.167 +
   5.168 +(*FIXME: requires more use of cterm constructors*)
   5.169 +fun abstract ct =
   5.170 +  let
   5.171 +      val thy = theory_of_cterm ct
   5.172 +      val Abs(x,_,body) = term_of ct
   5.173 +      val Type("fun",[xT,bodyT]) = typ_of (ctyp_of_term ct)
   5.174 +      val cxT = ctyp_of thy xT and cbodyT = ctyp_of thy bodyT
   5.175 +      fun makeK() = instantiate' [SOME cxT, SOME cbodyT] [SOME (cterm_of thy body)] @{thm abs_K}
   5.176 +  in
   5.177 +      case body of
   5.178 +          Const _ => makeK()
   5.179 +        | Free _ => makeK()
   5.180 +        | Var _ => makeK()  (*though Var isn't expected*)
   5.181 +        | Bound 0 => instantiate' [SOME cxT] [] @{thm abs_I} (*identity: I*)
   5.182 +        | rator$rand =>
   5.183 +            if loose_bvar1 (rator,0) then (*C or S*)
   5.184 +               if loose_bvar1 (rand,0) then (*S*)
   5.185 +                 let val crator = cterm_of thy (Abs(x,xT,rator))
   5.186 +                     val crand = cterm_of thy (Abs(x,xT,rand))
   5.187 +                     val abs_S' = cterm_instantiate [(f_S,crator),(g_S,crand)] @{thm abs_S}
   5.188 +                     val (_,rhs) = Thm.dest_equals (cprop_of abs_S')
   5.189 +                 in
   5.190 +                   Thm.transitive abs_S' (Conv.binop_conv abstract rhs)
   5.191 +                 end
   5.192 +               else (*C*)
   5.193 +                 let val crator = cterm_of thy (Abs(x,xT,rator))
   5.194 +                     val abs_C' = cterm_instantiate [(f_C,crator),(g_C,cterm_of thy rand)] @{thm abs_C}
   5.195 +                     val (_,rhs) = Thm.dest_equals (cprop_of abs_C')
   5.196 +                 in
   5.197 +                   Thm.transitive abs_C' (Conv.fun_conv (Conv.arg_conv abstract) rhs)
   5.198 +                 end
   5.199 +            else if loose_bvar1 (rand,0) then (*B or eta*)
   5.200 +               if rand = Bound 0 then eta_conversion ct
   5.201 +               else (*B*)
   5.202 +                 let val crand = cterm_of thy (Abs(x,xT,rand))
   5.203 +                     val crator = cterm_of thy rator
   5.204 +                     val abs_B' = cterm_instantiate [(f_B,crator),(g_B,crand)] @{thm abs_B}
   5.205 +                     val (_,rhs) = Thm.dest_equals (cprop_of abs_B')
   5.206 +                 in
   5.207 +                   Thm.transitive abs_B' (Conv.arg_conv abstract rhs)
   5.208 +                 end
   5.209 +            else makeK()
   5.210 +        | _ => error "abstract: Bad term"
   5.211 +  end;
   5.212 +
   5.213 +(*Traverse a theorem, declaring abstraction function definitions. String s is the suggested
   5.214 +  prefix for the constants.*)
   5.215 +fun combinators_aux ct =
   5.216 +  if lambda_free (term_of ct) then reflexive ct
   5.217 +  else
   5.218 +  case term_of ct of
   5.219 +      Abs _ =>
   5.220 +        let val (cv, cta) = Thm.dest_abs NONE ct
   5.221 +            val (v, _) = dest_Free (term_of cv)
   5.222 +            val u_th = combinators_aux cta
   5.223 +            val cu = Thm.rhs_of u_th
   5.224 +            val comb_eq = abstract (Thm.cabs cv cu)
   5.225 +        in transitive (abstract_rule v cv u_th) comb_eq end
   5.226 +    | _ $ _ =>
   5.227 +        let val (ct1, ct2) = Thm.dest_comb ct
   5.228 +        in  combination (combinators_aux ct1) (combinators_aux ct2)  end;
   5.229 +
   5.230 +fun combinators th =
   5.231 +  if lambda_free (prop_of th) then th
   5.232 +  else
   5.233 +    let val th = Drule.eta_contraction_rule th
   5.234 +        val eqth = combinators_aux (cprop_of th)
   5.235 +    in  equal_elim eqth th   end
   5.236 +    handle THM (msg,_,_) =>
   5.237 +      (warning (cat_lines
   5.238 +        ["Error in the combinator translation of " ^ Display.string_of_thm_without_context th,
   5.239 +          "  Exception message: " ^ msg]);
   5.240 +       TrueI);  (*A type variable of sort {} will cause make abstraction fail.*)
   5.241 +
   5.242 +(*cterms are used throughout for efficiency*)
   5.243 +val cTrueprop = Thm.cterm_of @{theory HOL} HOLogic.Trueprop;
   5.244 +
   5.245 +(*cterm version of mk_cTrueprop*)
   5.246 +fun c_mkTrueprop A = Thm.capply cTrueprop A;
   5.247 +
   5.248 +(*Given an abstraction over n variables, replace the bound variables by free
   5.249 +  ones. Return the body, along with the list of free variables.*)
   5.250 +fun c_variant_abs_multi (ct0, vars) =
   5.251 +      let val (cv,ct) = Thm.dest_abs NONE ct0
   5.252 +      in  c_variant_abs_multi (ct, cv::vars)  end
   5.253 +      handle CTERM _ => (ct0, rev vars);
   5.254 +
   5.255 +(*Given the definition of a Skolem function, return a theorem to replace
   5.256 +  an existential formula by a use of that function.
   5.257 +   Example: "EX x. x : A & x ~: B ==> sko A B : A & sko A B ~: B"  [.] *)
   5.258 +fun skolem_of_def def =
   5.259 +  let val (c,rhs) = Thm.dest_equals (cprop_of (freeze_thm def))
   5.260 +      val (ch, frees) = c_variant_abs_multi (rhs, [])
   5.261 +      val (chilbert,cabs) = Thm.dest_comb ch
   5.262 +      val thy = Thm.theory_of_cterm chilbert
   5.263 +      val t = Thm.term_of chilbert
   5.264 +      val T = case t of Const ("Hilbert_Choice.Eps", Type("fun",[_,T])) => T
   5.265 +                      | _ => raise THM ("skolem_of_def: expected Eps", 0, [def])
   5.266 +      val cex = Thm.cterm_of thy (HOLogic.exists_const T)
   5.267 +      val ex_tm = c_mkTrueprop (Thm.capply cex cabs)
   5.268 +      and conc =  c_mkTrueprop (Drule.beta_conv cabs (Drule.list_comb(c,frees)));
   5.269 +      fun tacf [prem] = rewrite_goals_tac [def] THEN rtac (prem RS @{thm someI_ex}) 1
   5.270 +  in  Goal.prove_internal [ex_tm] conc tacf
   5.271 +       |> forall_intr_list frees
   5.272 +       |> Thm.forall_elim_vars 0  (*Introduce Vars, but don't discharge defs.*)
   5.273 +       |> Thm.varifyT
   5.274 +  end;
   5.275 +
   5.276 +
   5.277 +(*Converts an Isabelle theorem (intro, elim or simp format, even higher-order) into NNF.*)
   5.278 +fun to_nnf th ctxt0 =
   5.279 +  let val th1 = th |> transform_elim |> zero_var_indexes
   5.280 +      val ((_, [th2]), ctxt) = Variable.import true [th1] ctxt0
   5.281 +      val th3 = th2
   5.282 +        |> Conv.fconv_rule Object_Logic.atomize
   5.283 +        |> Meson.make_nnf ctxt |> strip_lambdas ~1
   5.284 +  in  (th3, ctxt)  end;
   5.285 +
   5.286 +(*Generate Skolem functions for a theorem supplied in nnf*)
   5.287 +fun assume_skolem_of_def s th =
   5.288 +  map (skolem_of_def o assume o (cterm_of (theory_of_thm th))) (assume_skofuns s th);
   5.289 +
   5.290 +
   5.291 +(*** Blacklisting (duplicated in Res_ATP?) ***)
   5.292 +
   5.293 +val max_lambda_nesting = 3;
   5.294 +
   5.295 +fun excessive_lambdas (f$t, k) = excessive_lambdas (f,k) orelse excessive_lambdas (t,k)
   5.296 +  | excessive_lambdas (Abs(_,_,t), k) = k=0 orelse excessive_lambdas (t,k-1)
   5.297 +  | excessive_lambdas _ = false;
   5.298 +
   5.299 +fun is_formula_type T = (T = HOLogic.boolT orelse T = propT);
   5.300 +
   5.301 +(*Don't count nested lambdas at the level of formulas, as they are quantifiers*)
   5.302 +fun excessive_lambdas_fm Ts (Abs(_,T,t)) = excessive_lambdas_fm (T::Ts) t
   5.303 +  | excessive_lambdas_fm Ts t =
   5.304 +      if is_formula_type (fastype_of1 (Ts, t))
   5.305 +      then exists (excessive_lambdas_fm Ts) (#2 (strip_comb t))
   5.306 +      else excessive_lambdas (t, max_lambda_nesting);
   5.307 +
   5.308 +(*The max apply_depth of any metis call in Metis_Examples (on 31-10-2007) was 11.*)
   5.309 +val max_apply_depth = 15;
   5.310 +
   5.311 +fun apply_depth (f$t) = Int.max (apply_depth f, apply_depth t + 1)
   5.312 +  | apply_depth (Abs(_,_,t)) = apply_depth t
   5.313 +  | apply_depth _ = 0;
   5.314 +
   5.315 +fun too_complex t =
   5.316 +  apply_depth t > max_apply_depth orelse
   5.317 +  Meson.too_many_clauses NONE t orelse
   5.318 +  excessive_lambdas_fm [] t;
   5.319 +
   5.320 +fun is_strange_thm th =
   5.321 +  case head_of (concl_of th) of
   5.322 +      Const (a, _) => (a <> "Trueprop" andalso a <> "==")
   5.323 +    | _ => false;
   5.324 +
   5.325 +fun bad_for_atp th =
   5.326 +  too_complex (prop_of th)
   5.327 +  orelse exists_type type_has_topsort (prop_of th)
   5.328 +  orelse is_strange_thm th;
   5.329 +
   5.330 +val multi_base_blacklist =
   5.331 +  ["defs","select_defs","update_defs","induct","inducts","split","splits","split_asm",
   5.332 +   "cases","ext_cases"];  (* FIXME put other record thms here, or declare as "noatp" *)
   5.333 +
   5.334 +(*Keep the full complexity of the original name*)
   5.335 +fun flatten_name s = space_implode "_X" (Long_Name.explode s);
   5.336 +
   5.337 +fun fake_name th =
   5.338 +  if Thm.has_name_hint th then flatten_name (Thm.get_name_hint th)
   5.339 +  else gensym "unknown_thm_";
   5.340 +
   5.341 +(*Skolemize a named theorem, with Skolem functions as additional premises.*)
   5.342 +fun skolem_thm (s, th) =
   5.343 +  if member (op =) multi_base_blacklist (Long_Name.base_name s) orelse bad_for_atp th then []
   5.344 +  else
   5.345 +    let
   5.346 +      val ctxt0 = Variable.thm_context th
   5.347 +      val (nnfth, ctxt1) = to_nnf th ctxt0
   5.348 +      val (cnfs, ctxt2) = Meson.make_cnf (assume_skolem_of_def s nnfth) nnfth ctxt1
   5.349 +    in  cnfs |> map combinators |> Variable.export ctxt2 ctxt0 |> Meson.finish_cnf  end
   5.350 +    handle THM _ => [];
   5.351 +
   5.352 +(*The cache prevents repeated clausification of a theorem, and also repeated declaration of
   5.353 +  Skolem functions.*)
   5.354 +structure ThmCache = Theory_Data
   5.355 +(
   5.356 +  type T = thm list Thmtab.table * unit Symtab.table;
   5.357 +  val empty = (Thmtab.empty, Symtab.empty);
   5.358 +  val extend = I;
   5.359 +  fun merge ((cache1, seen1), (cache2, seen2)) : T =
   5.360 +    (Thmtab.merge (K true) (cache1, cache2), Symtab.merge (K true) (seen1, seen2));
   5.361 +);
   5.362 +
   5.363 +val lookup_cache = Thmtab.lookup o #1 o ThmCache.get;
   5.364 +val already_seen = Symtab.defined o #2 o ThmCache.get;
   5.365 +
   5.366 +val update_cache = ThmCache.map o apfst o Thmtab.update;
   5.367 +fun mark_seen name = ThmCache.map (apsnd (Symtab.update (name, ())));
   5.368 +
   5.369 +(*Exported function to convert Isabelle theorems into axiom clauses*)
   5.370 +fun cnf_axiom thy th0 =
   5.371 +  let val th = Thm.transfer thy th0 in
   5.372 +    case lookup_cache thy th of
   5.373 +      NONE => map Thm.close_derivation (skolem_thm (fake_name th, th))
   5.374 +    | SOME cls => cls
   5.375 +  end;
   5.376 +
   5.377 +
   5.378 +(**** Rules from the context ****)
   5.379 +
   5.380 +fun pairname th = (Thm.get_name_hint th, th);
   5.381 +
   5.382 +
   5.383 +(**** Translate a set of theorems into CNF ****)
   5.384 +
   5.385 +fun pair_name_cls k (n, []) = []
   5.386 +  | pair_name_cls k (n, cls::clss) = (cls, (n,k)) :: pair_name_cls (k+1) (n, clss)
   5.387 +
   5.388 +fun cnf_rules_pairs_aux _ pairs [] = pairs
   5.389 +  | cnf_rules_pairs_aux thy pairs ((name,th)::ths) =
   5.390 +      let val pairs' = (pair_name_cls 0 (name, cnf_axiom thy th)) @ pairs
   5.391 +                       handle THM _ => pairs | Res_Clause.CLAUSE _ => pairs
   5.392 +      in  cnf_rules_pairs_aux thy pairs' ths  end;
   5.393 +
   5.394 +(*The combination of rev and tail recursion preserves the original order*)
   5.395 +fun cnf_rules_pairs thy l = cnf_rules_pairs_aux thy [] (rev l);
   5.396 +
   5.397 +
   5.398 +(**** Convert all facts of the theory into clauses (Res_Clause.clause, or Res_HOL_Clause.clause) ****)
   5.399 +
   5.400 +local
   5.401 +
   5.402 +fun skolem_def (name, th) thy =
   5.403 +  let val ctxt0 = Variable.thm_context th in
   5.404 +    (case try (to_nnf th) ctxt0 of
   5.405 +      NONE => (NONE, thy)
   5.406 +    | SOME (nnfth, ctxt1) =>
   5.407 +        let val (defs, thy') = declare_skofuns (flatten_name name) nnfth thy
   5.408 +        in (SOME (th, ctxt0, ctxt1, nnfth, defs), thy') end)
   5.409 +  end;
   5.410 +
   5.411 +fun skolem_cnfs (th, ctxt0, ctxt1, nnfth, defs) =
   5.412 +  let
   5.413 +    val (cnfs, ctxt2) = Meson.make_cnf (map skolem_of_def defs) nnfth ctxt1;
   5.414 +    val cnfs' = cnfs
   5.415 +      |> map combinators
   5.416 +      |> Variable.export ctxt2 ctxt0
   5.417 +      |> Meson.finish_cnf
   5.418 +      |> map Thm.close_derivation;
   5.419 +    in (th, cnfs') end;
   5.420 +
   5.421 +in
   5.422 +
   5.423 +fun saturate_skolem_cache thy =
   5.424 +  let
   5.425 +    val facts = PureThy.facts_of thy;
   5.426 +    val new_facts = (facts, []) |-> Facts.fold_static (fn (name, ths) =>
   5.427 +      if Facts.is_concealed facts name orelse already_seen thy name then I
   5.428 +      else cons (name, ths));
   5.429 +    val new_thms = (new_facts, []) |-> fold (fn (name, ths) =>
   5.430 +      if member (op =) multi_base_blacklist (Long_Name.base_name name) then I
   5.431 +      else fold_index (fn (i, th) =>
   5.432 +        if bad_for_atp th orelse is_some (lookup_cache thy th) then I
   5.433 +        else cons (name ^ "_" ^ string_of_int (i + 1), Thm.transfer thy th)) ths);
   5.434 +  in
   5.435 +    if null new_facts then NONE
   5.436 +    else
   5.437 +      let
   5.438 +        val (defs, thy') = thy
   5.439 +          |> fold (mark_seen o #1) new_facts
   5.440 +          |> fold_map skolem_def (sort_distinct (Thm.thm_ord o pairself snd) new_thms)
   5.441 +          |>> map_filter I;
   5.442 +        val cache_entries = Par_List.map skolem_cnfs defs;
   5.443 +      in SOME (fold update_cache cache_entries thy') end
   5.444 +  end;
   5.445 +
   5.446 +end;
   5.447 +
   5.448 +val suppress_endtheory = Unsynchronized.ref false;
   5.449 +
   5.450 +fun clause_cache_endtheory thy =
   5.451 +  if ! suppress_endtheory then NONE
   5.452 +  else saturate_skolem_cache thy;
   5.453 +
   5.454 +
   5.455 +(*The cache can be kept smaller by inspecting the prop of each thm. Can ignore all that are
   5.456 +  lambda_free, but then the individual theory caches become much bigger.*)
   5.457 +
   5.458 +
   5.459 +(*** meson proof methods ***)
   5.460 +
   5.461 +(*Expand all new definitions of abstraction or Skolem functions in a proof state.*)
   5.462 +fun is_absko (Const ("==", _) $ Free (a,_) $ u) = String.isPrefix "sko_" a
   5.463 +  | is_absko _ = false;
   5.464 +
   5.465 +fun is_okdef xs (Const ("==", _) $ t $ u) =   (*Definition of Free, not in certain terms*)
   5.466 +      is_Free t andalso not (member (op aconv) xs t)
   5.467 +  | is_okdef _ _ = false
   5.468 +
   5.469 +(*This function tries to cope with open locales, which introduce hypotheses of the form
   5.470 +  Free == t, conjecture clauses, which introduce various hypotheses, and also definitions
   5.471 +  of sko_ functions. *)
   5.472 +fun expand_defs_tac st0 st =
   5.473 +  let val hyps0 = #hyps (rep_thm st0)
   5.474 +      val hyps = #hyps (crep_thm st)
   5.475 +      val newhyps = filter_out (member (op aconv) hyps0 o Thm.term_of) hyps
   5.476 +      val defs = filter (is_absko o Thm.term_of) newhyps
   5.477 +      val remaining_hyps = filter_out (member (op aconv) (map Thm.term_of defs))
   5.478 +                                      (map Thm.term_of hyps)
   5.479 +      val fixed = OldTerm.term_frees (concl_of st) @
   5.480 +                  fold (union (op aconv)) (map OldTerm.term_frees remaining_hyps) []
   5.481 +  in Seq.of_list [Local_Defs.expand (filter (is_okdef fixed o Thm.term_of) defs) st] end;
   5.482 +
   5.483 +
   5.484 +fun meson_general_tac ctxt ths i st0 =
   5.485 +  let
   5.486 +    val thy = ProofContext.theory_of ctxt
   5.487 +    val ctxt0 = Classical.put_claset HOL_cs ctxt
   5.488 +  in (Meson.meson_tac ctxt0 (maps (cnf_axiom thy) ths) i THEN expand_defs_tac st0) st0 end;
   5.489 +
   5.490 +val meson_method_setup =
   5.491 +  Method.setup @{binding meson} (Attrib.thms >> (fn ths => fn ctxt =>
   5.492 +    SIMPLE_METHOD' (CHANGED_PROP o meson_general_tac ctxt ths)))
   5.493 +    "MESON resolution proof procedure";
   5.494 +
   5.495 +
   5.496 +(*** Converting a subgoal into negated conjecture clauses. ***)
   5.497 +
   5.498 +fun neg_skolemize_tac ctxt =
   5.499 +  EVERY' [rtac ccontr, Object_Logic.atomize_prems_tac, Meson.skolemize_tac ctxt];
   5.500 +
   5.501 +val neg_clausify = Meson.make_clauses #> map combinators #> Meson.finish_cnf;
   5.502 +
   5.503 +fun neg_conjecture_clauses ctxt st0 n =
   5.504 +  let
   5.505 +    val st = Seq.hd (neg_skolemize_tac ctxt n st0)
   5.506 +    val ({params, prems, ...}, _) = Subgoal.focus (Variable.set_body false ctxt) n st
   5.507 +  in (neg_clausify prems, map (Term.dest_Free o Thm.term_of o #2) params) end;
   5.508 +
   5.509 +(*Conversion of a subgoal to conjecture clauses. Each clause has
   5.510 +  leading !!-bound universal variables, to express generality. *)
   5.511 +fun neg_clausify_tac ctxt =
   5.512 +  neg_skolemize_tac ctxt THEN'
   5.513 +  SUBGOAL (fn (prop, i) =>
   5.514 +    let val ts = Logic.strip_assums_hyp prop in
   5.515 +      EVERY'
   5.516 +       [Subgoal.FOCUS
   5.517 +         (fn {prems, ...} =>
   5.518 +           (Method.insert_tac
   5.519 +             (map forall_intr_vars (neg_clausify prems)) i)) ctxt,
   5.520 +        REPEAT_DETERM_N (length ts) o etac thin_rl] i
   5.521 +     end);
   5.522 +
   5.523 +val neg_clausify_setup =
   5.524 +  Method.setup @{binding neg_clausify} (Scan.succeed (SIMPLE_METHOD' o neg_clausify_tac))
   5.525 +  "conversion of goal to conjecture clauses";
   5.526 +
   5.527 +
   5.528 +(** Attribute for converting a theorem into clauses **)
   5.529 +
   5.530 +val clausify_setup =
   5.531 +  Attrib.setup @{binding clausify}
   5.532 +    (Scan.lift OuterParse.nat >>
   5.533 +      (fn i => Thm.rule_attribute (fn context => fn th =>
   5.534 +          Meson.make_meta_clause (nth (cnf_axiom (Context.theory_of context) th) i))))
   5.535 +  "conversion of theorem to clauses";
   5.536 +
   5.537 +
   5.538 +
   5.539 +(** setup **)
   5.540 +
   5.541 +val setup =
   5.542 +  meson_method_setup #>
   5.543 +  neg_clausify_setup #>
   5.544 +  clausify_setup #>
   5.545 +  perhaps saturate_skolem_cache #>
   5.546 +  Theory.at_end clause_cache_endtheory;
   5.547 +
   5.548 +end;
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_fol_clause.ML	Wed Mar 17 18:16:31 2010 +0100
     6.3 @@ -0,0 +1,534 @@
     6.4 +(*  Title:      HOL/Tools/res_clause.ML
     6.5 +    Author:     Jia Meng, Cambridge University Computer Laboratory
     6.6 +
     6.7 +Storing/printing FOL clauses and arity clauses.  Typed equality is
     6.8 +treated differently.
     6.9 +
    6.10 +FIXME: combine with res_hol_clause!
    6.11 +*)
    6.12 +
    6.13 +signature RES_CLAUSE =
    6.14 +sig
    6.15 +  val schematic_var_prefix: string
    6.16 +  val fixed_var_prefix: string
    6.17 +  val tvar_prefix: string
    6.18 +  val tfree_prefix: string
    6.19 +  val clause_prefix: string
    6.20 +  val const_prefix: string
    6.21 +  val tconst_prefix: string
    6.22 +  val class_prefix: string
    6.23 +  val union_all: ''a list list -> ''a list
    6.24 +  val const_trans_table: string Symtab.table
    6.25 +  val type_const_trans_table: string Symtab.table
    6.26 +  val ascii_of: string -> string
    6.27 +  val undo_ascii_of: string -> string
    6.28 +  val paren_pack : string list -> string
    6.29 +  val make_schematic_var : string * int -> string
    6.30 +  val make_fixed_var : string -> string
    6.31 +  val make_schematic_type_var : string * int -> string
    6.32 +  val make_fixed_type_var : string -> string
    6.33 +  val make_fixed_const : bool -> string -> string
    6.34 +  val make_fixed_type_const : bool -> string -> string
    6.35 +  val make_type_class : string -> string
    6.36 +  datatype kind = Axiom | Conjecture
    6.37 +  type axiom_name = string
    6.38 +  datatype fol_type =
    6.39 +      AtomV of string
    6.40 +    | AtomF of string
    6.41 +    | Comp of string * fol_type list
    6.42 +  val string_of_fol_type : fol_type -> string
    6.43 +  datatype type_literal = LTVar of string * string | LTFree of string * string
    6.44 +  exception CLAUSE of string * term
    6.45 +  val add_typs : typ list -> type_literal list
    6.46 +  val get_tvar_strs: typ list -> string list
    6.47 +  datatype arLit =
    6.48 +      TConsLit of class * string * string list
    6.49 +    | TVarLit of class * string
    6.50 +  datatype arityClause = ArityClause of
    6.51 +   {axiom_name: axiom_name, conclLit: arLit, premLits: arLit list}
    6.52 +  datatype classrelClause = ClassrelClause of
    6.53 +   {axiom_name: axiom_name, subclass: class, superclass: class}
    6.54 +  val make_classrel_clauses: theory -> class list -> class list -> classrelClause list
    6.55 +  val make_arity_clauses_dfg: bool -> theory -> string list -> class list -> class list * arityClause list
    6.56 +  val make_arity_clauses: theory -> string list -> class list -> class list * arityClause list
    6.57 +  val add_type_sort_preds: typ * int Symtab.table -> int Symtab.table
    6.58 +  val add_classrelClause_preds : classrelClause * int Symtab.table -> int Symtab.table
    6.59 +  val class_of_arityLit: arLit -> class
    6.60 +  val add_arityClause_preds: arityClause * int Symtab.table -> int Symtab.table
    6.61 +  val add_foltype_funcs: fol_type * int Symtab.table -> int Symtab.table
    6.62 +  val add_arityClause_funcs: arityClause * int Symtab.table -> int Symtab.table
    6.63 +  val init_functab: int Symtab.table
    6.64 +  val dfg_sign: bool -> string -> string
    6.65 +  val dfg_of_typeLit: bool -> type_literal -> string
    6.66 +  val gen_dfg_cls: int * string * kind * string list * string list * string list -> string
    6.67 +  val string_of_preds: (string * Int.int) list -> string
    6.68 +  val string_of_funcs: (string * int) list -> string
    6.69 +  val string_of_symbols: string -> string -> string
    6.70 +  val string_of_start: string -> string
    6.71 +  val string_of_descrip : string -> string
    6.72 +  val dfg_tfree_clause : string -> string
    6.73 +  val dfg_classrelClause: classrelClause -> string
    6.74 +  val dfg_arity_clause: arityClause -> string
    6.75 +  val tptp_sign: bool -> string -> string
    6.76 +  val tptp_of_typeLit : bool -> type_literal -> string
    6.77 +  val gen_tptp_cls : int * string * kind * string list * string list -> string
    6.78 +  val tptp_tfree_clause : string -> string
    6.79 +  val tptp_arity_clause : arityClause -> string
    6.80 +  val tptp_classrelClause : classrelClause -> string
    6.81 +end
    6.82 +
    6.83 +structure Res_Clause: RES_CLAUSE =
    6.84 +struct
    6.85 +
    6.86 +val schematic_var_prefix = "V_";
    6.87 +val fixed_var_prefix = "v_";
    6.88 +
    6.89 +val tvar_prefix = "T_";
    6.90 +val tfree_prefix = "t_";
    6.91 +
    6.92 +val clause_prefix = "cls_";
    6.93 +val arclause_prefix = "clsarity_"
    6.94 +val clrelclause_prefix = "clsrel_";
    6.95 +
    6.96 +val const_prefix = "c_";
    6.97 +val tconst_prefix = "tc_";
    6.98 +val class_prefix = "class_";
    6.99 +
   6.100 +fun union_all xss = List.foldl (uncurry (union (op =))) [] xss;
   6.101 +
   6.102 +(*Provide readable names for the more common symbolic functions*)
   6.103 +val const_trans_table =
   6.104 +      Symtab.make [(@{const_name "op ="}, "equal"),
   6.105 +                   (@{const_name Orderings.less_eq}, "lessequals"),
   6.106 +                   (@{const_name "op &"}, "and"),
   6.107 +                   (@{const_name "op |"}, "or"),
   6.108 +                   (@{const_name "op -->"}, "implies"),
   6.109 +                   (@{const_name "op :"}, "in"),
   6.110 +                   ("ATP_Linkup.fequal", "fequal"),
   6.111 +                   ("ATP_Linkup.COMBI", "COMBI"),
   6.112 +                   ("ATP_Linkup.COMBK", "COMBK"),
   6.113 +                   ("ATP_Linkup.COMBB", "COMBB"),
   6.114 +                   ("ATP_Linkup.COMBC", "COMBC"),
   6.115 +                   ("ATP_Linkup.COMBS", "COMBS"),
   6.116 +                   ("ATP_Linkup.COMBB'", "COMBB_e"),
   6.117 +                   ("ATP_Linkup.COMBC'", "COMBC_e"),
   6.118 +                   ("ATP_Linkup.COMBS'", "COMBS_e")];
   6.119 +
   6.120 +val type_const_trans_table =
   6.121 +      Symtab.make [("*", "prod"),
   6.122 +                   ("+", "sum"),
   6.123 +                   ("~=>", "map")];
   6.124 +
   6.125 +(*Escaping of special characters.
   6.126 +  Alphanumeric characters are left unchanged.
   6.127 +  The character _ goes to __
   6.128 +  Characters in the range ASCII space to / go to _A to _P, respectively.
   6.129 +  Other printing characters go to _nnn where nnn is the decimal ASCII code.*)
   6.130 +val A_minus_space = Char.ord #"A" - Char.ord #" ";
   6.131 +
   6.132 +fun stringN_of_int 0 _ = ""
   6.133 +  | stringN_of_int k n = stringN_of_int (k-1) (n div 10) ^ Int.toString (n mod 10);
   6.134 +
   6.135 +fun ascii_of_c c =
   6.136 +  if Char.isAlphaNum c then String.str c
   6.137 +  else if c = #"_" then "__"
   6.138 +  else if #" " <= c andalso c <= #"/"
   6.139 +       then "_" ^ String.str (Char.chr (Char.ord c + A_minus_space))
   6.140 +  else if Char.isPrint c
   6.141 +       then ("_" ^ stringN_of_int 3 (Char.ord c))  (*fixed width, in case more digits follow*)
   6.142 +  else ""
   6.143 +
   6.144 +val ascii_of = String.translate ascii_of_c;
   6.145 +
   6.146 +(** Remove ASCII armouring from names in proof files **)
   6.147 +
   6.148 +(*We don't raise error exceptions because this code can run inside the watcher.
   6.149 +  Also, the errors are "impossible" (hah!)*)
   6.150 +fun undo_ascii_aux rcs [] = String.implode(rev rcs)
   6.151 +  | undo_ascii_aux rcs [#"_"] = undo_ascii_aux (#"_"::rcs) []  (*ERROR*)
   6.152 +      (*Three types of _ escapes: __, _A to _P, _nnn*)
   6.153 +  | undo_ascii_aux rcs (#"_" :: #"_" :: cs) = undo_ascii_aux (#"_"::rcs) cs
   6.154 +  | undo_ascii_aux rcs (#"_" :: c :: cs) =
   6.155 +      if #"A" <= c andalso c<= #"P"  (*translation of #" " to #"/"*)
   6.156 +      then undo_ascii_aux (Char.chr(Char.ord c - A_minus_space) :: rcs) cs
   6.157 +      else
   6.158 +        let val digits = List.take (c::cs, 3) handle Subscript => []
   6.159 +        in
   6.160 +            case Int.fromString (String.implode digits) of
   6.161 +                NONE => undo_ascii_aux (c:: #"_"::rcs) cs  (*ERROR*)
   6.162 +              | SOME n => undo_ascii_aux (Char.chr n :: rcs) (List.drop (cs, 2))
   6.163 +        end
   6.164 +  | undo_ascii_aux rcs (c::cs) = undo_ascii_aux (c::rcs) cs;
   6.165 +
   6.166 +val undo_ascii_of = undo_ascii_aux [] o String.explode;
   6.167 +
   6.168 +(* convert a list of strings into one single string; surrounded by brackets *)
   6.169 +fun paren_pack [] = ""   (*empty argument list*)
   6.170 +  | paren_pack strings = "(" ^ commas strings ^ ")";
   6.171 +
   6.172 +(*TSTP format uses (...) rather than the old [...]*)
   6.173 +fun tptp_pack strings = "(" ^ space_implode " | " strings ^ ")";
   6.174 +
   6.175 +
   6.176 +(*Remove the initial ' character from a type variable, if it is present*)
   6.177 +fun trim_type_var s =
   6.178 +  if s <> "" andalso String.sub(s,0) = #"'" then String.extract(s,1,NONE)
   6.179 +  else error ("trim_type: Malformed type variable encountered: " ^ s);
   6.180 +
   6.181 +fun ascii_of_indexname (v,0) = ascii_of v
   6.182 +  | ascii_of_indexname (v,i) = ascii_of v ^ "_" ^ Int.toString i;
   6.183 +
   6.184 +fun make_schematic_var v = schematic_var_prefix ^ (ascii_of_indexname v);
   6.185 +fun make_fixed_var x = fixed_var_prefix ^ (ascii_of x);
   6.186 +
   6.187 +fun make_schematic_type_var (x,i) =
   6.188 +      tvar_prefix ^ (ascii_of_indexname (trim_type_var x,i));
   6.189 +fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (trim_type_var x));
   6.190 +
   6.191 +(*HACK because SPASS truncates identifiers to 63 characters :-(( *)
   6.192 +(*32-bit hash,so we expect no collisions unless there are around 65536 long identifiers...*)
   6.193 +fun controlled_length dfg_format s =
   6.194 +  if size s > 60 andalso dfg_format
   6.195 +  then Word.toString (Polyhash.hashw_string(s,0w0))
   6.196 +  else s;
   6.197 +
   6.198 +fun lookup_const dfg c =
   6.199 +    case Symtab.lookup const_trans_table c of
   6.200 +        SOME c' => c'
   6.201 +      | NONE => controlled_length dfg (ascii_of c);
   6.202 +
   6.203 +fun lookup_type_const dfg c =
   6.204 +    case Symtab.lookup type_const_trans_table c of
   6.205 +        SOME c' => c'
   6.206 +      | NONE => controlled_length dfg (ascii_of c);
   6.207 +
   6.208 +fun make_fixed_const _ "op =" = "equal"   (*MUST BE "equal" because it's built-in to ATPs*)
   6.209 +  | make_fixed_const dfg c      = const_prefix ^ lookup_const dfg c;
   6.210 +
   6.211 +fun make_fixed_type_const dfg c = tconst_prefix ^ lookup_type_const dfg c;
   6.212 +
   6.213 +fun make_type_class clas = class_prefix ^ ascii_of clas;
   6.214 +
   6.215 +
   6.216 +(***** definitions and functions for FOL clauses, for conversion to TPTP or DFG format. *****)
   6.217 +
   6.218 +datatype kind = Axiom | Conjecture;
   6.219 +
   6.220 +type axiom_name = string;
   6.221 +
   6.222 +(**** Isabelle FOL clauses ****)
   6.223 +
   6.224 +(*FIXME: give the constructors more sensible names*)
   6.225 +datatype fol_type = AtomV of string
   6.226 +                  | AtomF of string
   6.227 +                  | Comp of string * fol_type list;
   6.228 +
   6.229 +fun string_of_fol_type (AtomV x) = x
   6.230 +  | string_of_fol_type (AtomF x) = x
   6.231 +  | string_of_fol_type (Comp(tcon,tps)) =
   6.232 +      tcon ^ (paren_pack (map string_of_fol_type tps));
   6.233 +
   6.234 +(*First string is the type class; the second is a TVar or TFfree*)
   6.235 +datatype type_literal = LTVar of string * string | LTFree of string * string;
   6.236 +
   6.237 +exception CLAUSE of string * term;
   6.238 +
   6.239 +fun atomic_type (TFree (a,_)) = AtomF(make_fixed_type_var a)
   6.240 +  | atomic_type (TVar (v,_))  = AtomV(make_schematic_type_var v);
   6.241 +
   6.242 +(*Flatten a type to a fol_type while accumulating sort constraints on the TFrees and
   6.243 +  TVars it contains.*)
   6.244 +fun type_of dfg (Type (a, Ts)) =
   6.245 +      let val (folTyps, ts) = types_of dfg Ts
   6.246 +          val t = make_fixed_type_const dfg a
   6.247 +      in (Comp(t,folTyps), ts) end
   6.248 +  | type_of dfg T = (atomic_type T, [T])
   6.249 +and types_of dfg Ts =
   6.250 +      let val (folTyps,ts) = ListPair.unzip (map (type_of dfg) Ts)
   6.251 +      in (folTyps, union_all ts) end;
   6.252 +
   6.253 +(*Make literals for sorted type variables*)
   6.254 +fun sorts_on_typs_aux (_, [])   = []
   6.255 +  | sorts_on_typs_aux ((x,i),  s::ss) =
   6.256 +      let val sorts = sorts_on_typs_aux ((x,i), ss)
   6.257 +      in
   6.258 +          if s = "HOL.type" then sorts
   6.259 +          else if i = ~1 then LTFree(make_type_class s, make_fixed_type_var x) :: sorts
   6.260 +          else LTVar(make_type_class s, make_schematic_type_var (x,i)) :: sorts
   6.261 +      end;
   6.262 +
   6.263 +fun sorts_on_typs (TFree (a,s)) = sorts_on_typs_aux ((a,~1),s)
   6.264 +  | sorts_on_typs (TVar (v,s))  = sorts_on_typs_aux (v,s);
   6.265 +
   6.266 +fun pred_of_sort (LTVar (s,ty)) = (s,1)
   6.267 +  | pred_of_sort (LTFree (s,ty)) = (s,1)
   6.268 +
   6.269 +(*Given a list of sorted type variables, return a list of type literals.*)
   6.270 +fun add_typs Ts = List.foldl (uncurry (union (op =))) [] (map sorts_on_typs Ts);
   6.271 +
   6.272 +(*The correct treatment of TFrees like 'a in lemmas (axiom clauses) is not clear.
   6.273 +  * Ignoring them leads to unsound proofs, since we do nothing to ensure that 'a
   6.274 +    in a lemma has the same sort as 'a in the conjecture.
   6.275 +  * Deleting such clauses will lead to problems with locales in other use of local results
   6.276 +    where 'a is fixed. Probably we should delete clauses unless the sorts agree.
   6.277 +  * Currently we include a class constraint in the clause, exactly as with TVars.
   6.278 +*)
   6.279 +
   6.280 +(** make axiom and conjecture clauses. **)
   6.281 +
   6.282 +fun get_tvar_strs [] = []
   6.283 +  | get_tvar_strs ((TVar (indx,s))::Ts) =
   6.284 +      insert (op =) (make_schematic_type_var indx) (get_tvar_strs Ts)
   6.285 +  | get_tvar_strs((TFree _)::Ts) = get_tvar_strs Ts
   6.286 +
   6.287 +
   6.288 +
   6.289 +(**** Isabelle arities ****)
   6.290 +
   6.291 +exception ARCLAUSE of string;
   6.292 +
   6.293 +datatype arLit = TConsLit of class * string * string list
   6.294 +               | TVarLit of class * string;
   6.295 +
   6.296 +datatype arityClause =
   6.297 +         ArityClause of {axiom_name: axiom_name,
   6.298 +                         conclLit: arLit,
   6.299 +                         premLits: arLit list};
   6.300 +
   6.301 +
   6.302 +fun gen_TVars 0 = []
   6.303 +  | gen_TVars n = ("T_" ^ Int.toString n) :: gen_TVars (n-1);
   6.304 +
   6.305 +fun pack_sort(_,[])  = []
   6.306 +  | pack_sort(tvar, "HOL.type"::srt) = pack_sort(tvar, srt)   (*IGNORE sort "type"*)
   6.307 +  | pack_sort(tvar, cls::srt) =  (cls, tvar) :: pack_sort(tvar, srt);
   6.308 +
   6.309 +(*Arity of type constructor tcon :: (arg1,...,argN)res*)
   6.310 +fun make_axiom_arity_clause dfg (tcons, axiom_name, (cls,args)) =
   6.311 +   let val tvars = gen_TVars (length args)
   6.312 +       val tvars_srts = ListPair.zip (tvars,args)
   6.313 +   in
   6.314 +      ArityClause {axiom_name = axiom_name, 
   6.315 +                   conclLit = TConsLit (cls, make_fixed_type_const dfg tcons, tvars),
   6.316 +                   premLits = map TVarLit (union_all(map pack_sort tvars_srts))}
   6.317 +   end;
   6.318 +
   6.319 +
   6.320 +(**** Isabelle class relations ****)
   6.321 +
   6.322 +datatype classrelClause =
   6.323 +         ClassrelClause of {axiom_name: axiom_name,
   6.324 +                            subclass: class,
   6.325 +                            superclass: class};
   6.326 +
   6.327 +(*Generate all pairs (sub,super) such that sub is a proper subclass of super in theory thy.*)
   6.328 +fun class_pairs thy [] supers = []
   6.329 +  | class_pairs thy subs supers =
   6.330 +      let val class_less = Sorts.class_less(Sign.classes_of thy)
   6.331 +          fun add_super sub (super,pairs) =
   6.332 +                if class_less (sub,super) then (sub,super)::pairs else pairs
   6.333 +          fun add_supers (sub,pairs) = List.foldl (add_super sub) pairs supers
   6.334 +      in  List.foldl add_supers [] subs  end;
   6.335 +
   6.336 +fun make_classrelClause (sub,super) =
   6.337 +  ClassrelClause {axiom_name = clrelclause_prefix ^ ascii_of sub ^ "_" ^ ascii_of super,
   6.338 +                  subclass = make_type_class sub,
   6.339 +                  superclass = make_type_class super};
   6.340 +
   6.341 +fun make_classrel_clauses thy subs supers =
   6.342 +  map make_classrelClause (class_pairs thy subs supers);
   6.343 +
   6.344 +
   6.345 +(** Isabelle arities **)
   6.346 +
   6.347 +fun arity_clause dfg _ _ (tcons, []) = []
   6.348 +  | arity_clause dfg seen n (tcons, ("HOL.type",_)::ars) =  (*ignore*)
   6.349 +      arity_clause dfg seen n (tcons,ars)
   6.350 +  | arity_clause dfg seen n (tcons, (ar as (class,_)) :: ars) =
   6.351 +      if class mem_string seen then (*multiple arities for the same tycon, class pair*)
   6.352 +          make_axiom_arity_clause dfg (tcons, lookup_type_const dfg tcons ^ "_" ^ class ^ "_" ^ Int.toString n, ar) ::
   6.353 +          arity_clause dfg seen (n+1) (tcons,ars)
   6.354 +      else
   6.355 +          make_axiom_arity_clause dfg (tcons, lookup_type_const dfg tcons ^ "_" ^ class, ar) ::
   6.356 +          arity_clause dfg (class::seen) n (tcons,ars)
   6.357 +
   6.358 +fun multi_arity_clause dfg [] = []
   6.359 +  | multi_arity_clause dfg ((tcons,ars) :: tc_arlists) =
   6.360 +      arity_clause dfg [] 1 (tcons, ars)  @  multi_arity_clause dfg tc_arlists
   6.361 +
   6.362 +(*Generate all pairs (tycon,class,sorts) such that tycon belongs to class in theory thy
   6.363 +  provided its arguments have the corresponding sorts.*)
   6.364 +fun type_class_pairs thy tycons classes =
   6.365 +  let val alg = Sign.classes_of thy
   6.366 +      fun domain_sorts (tycon,class) = Sorts.mg_domain alg tycon [class]
   6.367 +      fun add_class tycon (class,pairs) =
   6.368 +            (class, domain_sorts(tycon,class))::pairs
   6.369 +            handle Sorts.CLASS_ERROR _ => pairs
   6.370 +      fun try_classes tycon = (tycon, List.foldl (add_class tycon) [] classes)
   6.371 +  in  map try_classes tycons  end;
   6.372 +
   6.373 +(*Proving one (tycon, class) membership may require proving others, so iterate.*)
   6.374 +fun iter_type_class_pairs thy tycons [] = ([], [])
   6.375 +  | iter_type_class_pairs thy tycons classes =
   6.376 +      let val cpairs = type_class_pairs thy tycons classes
   6.377 +          val newclasses = union_all (union_all (union_all (map (map #2 o #2) cpairs)))
   6.378 +            |> subtract (op =) classes |> subtract (op =) HOLogic.typeS
   6.379 +          val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses
   6.380 +      in (union (op =) classes' classes, union (op =) cpairs' cpairs) end;
   6.381 +
   6.382 +fun make_arity_clauses_dfg dfg thy tycons classes =
   6.383 +  let val (classes', cpairs) = iter_type_class_pairs thy tycons classes
   6.384 +  in  (classes', multi_arity_clause dfg cpairs)  end;
   6.385 +val make_arity_clauses = make_arity_clauses_dfg false;
   6.386 +
   6.387 +(**** Find occurrences of predicates in clauses ****)
   6.388 +
   6.389 +(*FIXME: multiple-arity checking doesn't work, as update_new is the wrong
   6.390 +  function (it flags repeated declarations of a function, even with the same arity)*)
   6.391 +
   6.392 +fun update_many (tab, keypairs) = List.foldl (uncurry Symtab.update) tab keypairs;
   6.393 +
   6.394 +fun add_type_sort_preds (T, preds) =
   6.395 +      update_many (preds, map pred_of_sort (sorts_on_typs T));
   6.396 +
   6.397 +fun add_classrelClause_preds (ClassrelClause {subclass,superclass,...}, preds) =
   6.398 +  Symtab.update (subclass,1) (Symtab.update (superclass,1) preds);
   6.399 +
   6.400 +fun class_of_arityLit (TConsLit (tclass, _, _)) = tclass
   6.401 +  | class_of_arityLit (TVarLit (tclass, _)) = tclass;
   6.402 +
   6.403 +fun add_arityClause_preds (ArityClause {conclLit,premLits,...}, preds) =
   6.404 +  let val classes = map (make_type_class o class_of_arityLit) (conclLit::premLits)
   6.405 +      fun upd (class,preds) = Symtab.update (class,1) preds
   6.406 +  in  List.foldl upd preds classes  end;
   6.407 +
   6.408 +(*** Find occurrences of functions in clauses ***)
   6.409 +
   6.410 +fun add_foltype_funcs (AtomV _, funcs) = funcs
   6.411 +  | add_foltype_funcs (AtomF a, funcs) = Symtab.update (a,0) funcs
   6.412 +  | add_foltype_funcs (Comp(a,tys), funcs) =
   6.413 +      List.foldl add_foltype_funcs (Symtab.update (a, length tys) funcs) tys;
   6.414 +
   6.415 +(*TFrees are recorded as constants*)
   6.416 +fun add_type_sort_funcs (TVar _, funcs) = funcs
   6.417 +  | add_type_sort_funcs (TFree (a, _), funcs) =
   6.418 +      Symtab.update (make_fixed_type_var a, 0) funcs
   6.419 +
   6.420 +fun add_arityClause_funcs (ArityClause {conclLit,...}, funcs) =
   6.421 +  let val TConsLit (_, tcons, tvars) = conclLit
   6.422 +  in  Symtab.update (tcons, length tvars) funcs  end;
   6.423 +
   6.424 +(*This type can be overlooked because it is built-in...*)
   6.425 +val init_functab = Symtab.update ("tc_itself", 1) Symtab.empty;
   6.426 +
   6.427 +
   6.428 +(**** String-oriented operations ****)
   6.429 +
   6.430 +fun string_of_clausename (cls_id,ax_name) =
   6.431 +    clause_prefix ^ ascii_of ax_name ^ "_" ^ Int.toString cls_id;
   6.432 +
   6.433 +fun string_of_type_clsname (cls_id,ax_name,idx) =
   6.434 +    string_of_clausename (cls_id,ax_name) ^ "_tcs" ^ (Int.toString idx);
   6.435 +
   6.436 +
   6.437 +(**** Producing DFG files ****)
   6.438 +
   6.439 +(*Attach sign in DFG syntax: false means negate.*)
   6.440 +fun dfg_sign true s = s
   6.441 +  | dfg_sign false s = "not(" ^ s ^ ")"
   6.442 +
   6.443 +fun dfg_of_typeLit pos (LTVar (s,ty))  = dfg_sign pos (s ^ "(" ^ ty ^ ")")
   6.444 +  | dfg_of_typeLit pos (LTFree (s,ty)) = dfg_sign pos (s ^ "(" ^ ty ^ ")");
   6.445 +
   6.446 +(*Enclose the clause body by quantifiers, if necessary*)
   6.447 +fun dfg_forall [] body = body
   6.448 +  | dfg_forall vars body = "forall([" ^ commas vars ^ "],\n" ^ body ^ ")"
   6.449 +
   6.450 +fun gen_dfg_cls (cls_id, ax_name, Axiom, lits, tylits, vars) =
   6.451 +      "clause( %(axiom)\n" ^
   6.452 +      dfg_forall vars ("or(" ^ commas (tylits@lits) ^ ")") ^ ",\n" ^
   6.453 +      string_of_clausename (cls_id,ax_name) ^  ").\n\n"
   6.454 +  | gen_dfg_cls (cls_id, ax_name, Conjecture, lits, _, vars) =
   6.455 +      "clause( %(negated_conjecture)\n" ^
   6.456 +      dfg_forall vars ("or(" ^ commas lits ^ ")") ^ ",\n" ^
   6.457 +      string_of_clausename (cls_id,ax_name) ^  ").\n\n";
   6.458 +
   6.459 +fun string_of_arity (name, num) =  "(" ^ name ^ "," ^ Int.toString num ^ ")"
   6.460 +
   6.461 +fun string_of_preds [] = ""
   6.462 +  | string_of_preds preds = "predicates[" ^ commas(map string_of_arity preds) ^ "].\n";
   6.463 +
   6.464 +fun string_of_funcs [] = ""
   6.465 +  | string_of_funcs funcs = "functions[" ^ commas(map string_of_arity funcs) ^ "].\n" ;
   6.466 +
   6.467 +fun string_of_symbols predstr funcstr =
   6.468 +  "list_of_symbols.\n" ^ predstr  ^ funcstr  ^ "end_of_list.\n\n";
   6.469 +
   6.470 +fun string_of_start name = "begin_problem(" ^ name ^ ").\n\n";
   6.471 +
   6.472 +fun string_of_descrip name =
   6.473 +  "list_of_descriptions.\nname({*" ^ name ^
   6.474 +  "*}).\nauthor({*Isabelle*}).\nstatus(unknown).\ndescription({*auto-generated*}).\nend_of_list.\n\n"
   6.475 +
   6.476 +fun dfg_tfree_clause tfree_lit =
   6.477 +  "clause( %(negated_conjecture)\n" ^ "or( " ^ tfree_lit ^ "),\n" ^ "tfree_tcs" ^ ").\n\n"
   6.478 +
   6.479 +fun dfg_of_arLit (TConsLit (c,t,args)) =
   6.480 +      dfg_sign true (make_type_class c ^ "(" ^ t ^ paren_pack args ^ ")")
   6.481 +  | dfg_of_arLit (TVarLit (c,str)) =
   6.482 +      dfg_sign false (make_type_class c ^ "(" ^ str ^ ")")
   6.483 +
   6.484 +fun dfg_classrelLits sub sup =  "not(" ^ sub ^ "(T)), " ^ sup ^ "(T)";
   6.485 +
   6.486 +fun dfg_classrelClause (ClassrelClause {axiom_name,subclass,superclass,...}) =
   6.487 +  "clause(forall([T],\nor( " ^ dfg_classrelLits subclass superclass ^ ")),\n" ^
   6.488 +  axiom_name ^ ").\n\n";
   6.489 +
   6.490 +fun string_of_ar axiom_name = arclause_prefix ^ ascii_of axiom_name;
   6.491 +
   6.492 +fun dfg_arity_clause (ArityClause{axiom_name,conclLit,premLits,...}) =
   6.493 +  let val TConsLit (_,_,tvars) = conclLit
   6.494 +      val lits = map dfg_of_arLit (conclLit :: premLits)
   6.495 +  in
   6.496 +      "clause( %(axiom)\n" ^
   6.497 +      dfg_forall tvars ("or( " ^ commas lits ^ ")") ^ ",\n" ^
   6.498 +      string_of_ar axiom_name ^ ").\n\n"
   6.499 +  end;
   6.500 +
   6.501 +
   6.502 +(**** Produce TPTP files ****)
   6.503 +
   6.504 +(*Attach sign in TPTP syntax: false means negate.*)
   6.505 +fun tptp_sign true s = s
   6.506 +  | tptp_sign false s = "~ " ^ s
   6.507 +
   6.508 +fun tptp_of_typeLit pos (LTVar (s,ty))  = tptp_sign pos (s ^ "(" ^ ty ^ ")")
   6.509 +  | tptp_of_typeLit pos (LTFree (s,ty)) = tptp_sign pos  (s ^ "(" ^ ty ^ ")");
   6.510 +
   6.511 +fun gen_tptp_cls (cls_id,ax_name,Axiom,lits,tylits) =
   6.512 +      "cnf(" ^ string_of_clausename (cls_id,ax_name) ^ ",axiom," ^ 
   6.513 +               tptp_pack (tylits@lits) ^ ").\n"
   6.514 +  | gen_tptp_cls (cls_id,ax_name,Conjecture,lits,_) =
   6.515 +      "cnf(" ^ string_of_clausename (cls_id,ax_name) ^ ",negated_conjecture," ^ 
   6.516 +               tptp_pack lits ^ ").\n";
   6.517 +
   6.518 +fun tptp_tfree_clause tfree_lit =
   6.519 +    "cnf(" ^ "tfree_tcs," ^ "negated_conjecture" ^ "," ^ tptp_pack[tfree_lit] ^ ").\n";
   6.520 +
   6.521 +fun tptp_of_arLit (TConsLit (c,t,args)) =
   6.522 +      tptp_sign true (make_type_class c ^ "(" ^ t ^ paren_pack args ^ ")")
   6.523 +  | tptp_of_arLit (TVarLit (c,str)) =
   6.524 +      tptp_sign false (make_type_class c ^ "(" ^ str ^ ")")
   6.525 +
   6.526 +fun tptp_arity_clause (ArityClause{axiom_name,conclLit,premLits,...}) =
   6.527 +  "cnf(" ^ string_of_ar axiom_name ^ ",axiom," ^
   6.528 +  tptp_pack (map tptp_of_arLit (conclLit :: premLits)) ^ ").\n";
   6.529 +
   6.530 +fun tptp_classrelLits sub sup =
   6.531 +  let val tvar = "(T)"
   6.532 +  in  tptp_pack [tptp_sign false (sub^tvar), tptp_sign true (sup^tvar)]  end;
   6.533 +
   6.534 +fun tptp_classrelClause (ClassrelClause {axiom_name,subclass,superclass,...}) =
   6.535 +  "cnf(" ^ axiom_name ^ ",axiom," ^ tptp_classrelLits subclass superclass ^ ").\n"
   6.536 +
   6.537 +end;
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_hol_clause.ML	Wed Mar 17 18:16:31 2010 +0100
     7.3 @@ -0,0 +1,531 @@
     7.4 +(*  Title:      HOL/Tools/res_hol_clause.ML
     7.5 +    Author:     Jia Meng, NICTA
     7.6 +
     7.7 +FOL clauses translated from HOL formulae.
     7.8 +*)
     7.9 +
    7.10 +signature RES_HOL_CLAUSE =
    7.11 +sig
    7.12 +  val ext: thm
    7.13 +  val comb_I: thm
    7.14 +  val comb_K: thm
    7.15 +  val comb_B: thm
    7.16 +  val comb_C: thm
    7.17 +  val comb_S: thm
    7.18 +  val minimize_applies: bool
    7.19 +  type axiom_name = string
    7.20 +  type polarity = bool
    7.21 +  type clause_id = int
    7.22 +  datatype combterm =
    7.23 +      CombConst of string * Res_Clause.fol_type * Res_Clause.fol_type list (*Const and Free*)
    7.24 +    | CombVar of string * Res_Clause.fol_type
    7.25 +    | CombApp of combterm * combterm
    7.26 +  datatype literal = Literal of polarity * combterm
    7.27 +  datatype clause = Clause of {clause_id: clause_id, axiom_name: axiom_name, th: thm,
    7.28 +                    kind: Res_Clause.kind,literals: literal list, ctypes_sorts: typ list}
    7.29 +  val type_of_combterm: combterm -> Res_Clause.fol_type
    7.30 +  val strip_comb: combterm -> combterm * combterm list
    7.31 +  val literals_of_term: theory -> term -> literal list * typ list
    7.32 +  exception TOO_TRIVIAL
    7.33 +  val make_conjecture_clauses:  bool -> theory -> thm list -> clause list
    7.34 +  val make_axiom_clauses: bool ->
    7.35 +       theory ->
    7.36 +       (thm * (axiom_name * clause_id)) list -> (axiom_name * clause) list
    7.37 +  val get_helper_clauses: bool ->
    7.38 +       theory ->
    7.39 +       bool ->
    7.40 +       clause list * (thm * (axiom_name * clause_id)) list * string list ->
    7.41 +       clause list
    7.42 +  val tptp_write_file: bool -> Path.T ->
    7.43 +    clause list * clause list * clause list * clause list *
    7.44 +    Res_Clause.classrelClause list * Res_Clause.arityClause list ->
    7.45 +    int * int
    7.46 +  val dfg_write_file: bool -> Path.T ->
    7.47 +    clause list * clause list * clause list * clause list *
    7.48 +    Res_Clause.classrelClause list * Res_Clause.arityClause list ->
    7.49 +    int * int
    7.50 +end
    7.51 +
    7.52 +structure Res_HOL_Clause: RES_HOL_CLAUSE =
    7.53 +struct
    7.54 +
    7.55 +structure RC = Res_Clause;   (* FIXME avoid structure alias *)
    7.56 +
    7.57 +(* theorems for combinators and function extensionality *)
    7.58 +val ext = thm "HOL.ext";
    7.59 +val comb_I = thm "ATP_Linkup.COMBI_def";
    7.60 +val comb_K = thm "ATP_Linkup.COMBK_def";
    7.61 +val comb_B = thm "ATP_Linkup.COMBB_def";
    7.62 +val comb_C = thm "ATP_Linkup.COMBC_def";
    7.63 +val comb_S = thm "ATP_Linkup.COMBS_def";
    7.64 +val fequal_imp_equal = thm "ATP_Linkup.fequal_imp_equal";
    7.65 +val equal_imp_fequal = thm "ATP_Linkup.equal_imp_fequal";
    7.66 +
    7.67 +
    7.68 +(* Parameter t_full below indicates that full type information is to be
    7.69 +exported *)
    7.70 +
    7.71 +(*If true, each function will be directly applied to as many arguments as possible, avoiding
    7.72 +  use of the "apply" operator. Use of hBOOL is also minimized.*)
    7.73 +val minimize_applies = true;
    7.74 +
    7.75 +fun min_arity_of const_min_arity c = the_default 0 (Symtab.lookup const_min_arity c);
    7.76 +
    7.77 +(*True if the constant ever appears outside of the top-level position in literals.
    7.78 +  If false, the constant always receives all of its arguments and is used as a predicate.*)
    7.79 +fun needs_hBOOL const_needs_hBOOL c =
    7.80 +  not minimize_applies orelse
    7.81 +    the_default false (Symtab.lookup const_needs_hBOOL c);
    7.82 +
    7.83 +
    7.84 +(******************************************************)
    7.85 +(* data types for typed combinator expressions        *)
    7.86 +(******************************************************)
    7.87 +
    7.88 +type axiom_name = string;
    7.89 +type polarity = bool;
    7.90 +type clause_id = int;
    7.91 +
    7.92 +datatype combterm = CombConst of string * RC.fol_type * RC.fol_type list (*Const and Free*)
    7.93 +                  | CombVar of string * RC.fol_type
    7.94 +                  | CombApp of combterm * combterm
    7.95 +
    7.96 +datatype literal = Literal of polarity * combterm;
    7.97 +
    7.98 +datatype clause =
    7.99 +         Clause of {clause_id: clause_id,
   7.100 +                    axiom_name: axiom_name,
   7.101 +                    th: thm,
   7.102 +                    kind: RC.kind,
   7.103 +                    literals: literal list,
   7.104 +                    ctypes_sorts: typ list};
   7.105 +
   7.106 +
   7.107 +(*********************************************************************)
   7.108 +(* convert a clause with type Term.term to a clause with type clause *)
   7.109 +(*********************************************************************)
   7.110 +
   7.111 +fun isFalse (Literal(pol, CombConst(c,_,_))) =
   7.112 +      (pol andalso c = "c_False") orelse
   7.113 +      (not pol andalso c = "c_True")
   7.114 +  | isFalse _ = false;
   7.115 +
   7.116 +fun isTrue (Literal (pol, CombConst(c,_,_))) =
   7.117 +      (pol andalso c = "c_True") orelse
   7.118 +      (not pol andalso c = "c_False")
   7.119 +  | isTrue _ = false;
   7.120 +
   7.121 +fun isTaut (Clause {literals,...}) = exists isTrue literals;
   7.122 +
   7.123 +fun type_of dfg (Type (a, Ts)) =
   7.124 +      let val (folTypes,ts) = types_of dfg Ts
   7.125 +      in  (RC.Comp(RC.make_fixed_type_const dfg a, folTypes), ts)  end
   7.126 +  | type_of _ (tp as TFree (a, _)) =
   7.127 +      (RC.AtomF (RC.make_fixed_type_var a), [tp])
   7.128 +  | type_of _ (tp as TVar (v, _)) =
   7.129 +      (RC.AtomV (RC.make_schematic_type_var v), [tp])
   7.130 +and types_of dfg Ts =
   7.131 +      let val (folTyps,ts) = ListPair.unzip (map (type_of dfg) Ts)
   7.132 +      in  (folTyps, RC.union_all ts)  end;
   7.133 +
   7.134 +(* same as above, but no gathering of sort information *)
   7.135 +fun simp_type_of dfg (Type (a, Ts)) =
   7.136 +      RC.Comp(RC.make_fixed_type_const dfg a, map (simp_type_of dfg) Ts)
   7.137 +  | simp_type_of _ (TFree (a, _)) = RC.AtomF(RC.make_fixed_type_var a)
   7.138 +  | simp_type_of _ (TVar (v, _)) = RC.AtomV(RC.make_schematic_type_var v);
   7.139 +
   7.140 +
   7.141 +fun const_type_of dfg thy (c,t) =
   7.142 +      let val (tp,ts) = type_of dfg t
   7.143 +      in  (tp, ts, map (simp_type_of dfg) (Sign.const_typargs thy (c,t))) end;
   7.144 +
   7.145 +(* convert a Term.term (with combinators) into a combterm, also accummulate sort info *)
   7.146 +fun combterm_of dfg thy (Const(c,t)) =
   7.147 +      let val (tp,ts,tvar_list) = const_type_of dfg thy (c,t)
   7.148 +          val c' = CombConst(RC.make_fixed_const dfg c, tp, tvar_list)
   7.149 +      in  (c',ts)  end
   7.150 +  | combterm_of dfg _ (Free(v,t)) =
   7.151 +      let val (tp,ts) = type_of dfg t
   7.152 +          val v' = CombConst(RC.make_fixed_var v, tp, [])
   7.153 +      in  (v',ts)  end
   7.154 +  | combterm_of dfg _ (Var(v,t)) =
   7.155 +      let val (tp,ts) = type_of dfg t
   7.156 +          val v' = CombVar(RC.make_schematic_var v,tp)
   7.157 +      in  (v',ts)  end
   7.158 +  | combterm_of dfg thy (P $ Q) =
   7.159 +      let val (P',tsP) = combterm_of dfg thy P
   7.160 +          val (Q',tsQ) = combterm_of dfg thy Q
   7.161 +      in  (CombApp(P',Q'), union (op =) tsP tsQ)  end
   7.162 +  | combterm_of _ _ (t as Abs _) = raise RC.CLAUSE ("HOL CLAUSE", t);
   7.163 +
   7.164 +fun predicate_of dfg thy ((Const("Not",_) $ P), polarity) = predicate_of dfg thy (P, not polarity)
   7.165 +  | predicate_of dfg thy (t,polarity) = (combterm_of dfg thy (Envir.eta_contract t), polarity);
   7.166 +
   7.167 +fun literals_of_term1 dfg thy args (Const("Trueprop",_) $ P) = literals_of_term1 dfg thy args P
   7.168 +  | literals_of_term1 dfg thy args (Const("op |",_) $ P $ Q) =
   7.169 +      literals_of_term1 dfg thy (literals_of_term1 dfg thy args P) Q
   7.170 +  | literals_of_term1 dfg thy (lits,ts) P =
   7.171 +      let val ((pred,ts'),pol) = predicate_of dfg thy (P,true)
   7.172 +      in
   7.173 +          (Literal(pol,pred)::lits, union (op =) ts ts')
   7.174 +      end;
   7.175 +
   7.176 +fun literals_of_term_dfg dfg thy P = literals_of_term1 dfg thy ([],[]) P;
   7.177 +val literals_of_term = literals_of_term_dfg false;
   7.178 +
   7.179 +(* Problem too trivial for resolution (empty clause) *)
   7.180 +exception TOO_TRIVIAL;
   7.181 +
   7.182 +(* making axiom and conjecture clauses *)
   7.183 +fun make_clause dfg thy (clause_id,axiom_name,kind,th) =
   7.184 +    let val (lits,ctypes_sorts) = literals_of_term_dfg dfg thy (prop_of th)
   7.185 +    in
   7.186 +        if forall isFalse lits
   7.187 +        then raise TOO_TRIVIAL
   7.188 +        else
   7.189 +            Clause {clause_id = clause_id, axiom_name = axiom_name, th = th, kind = kind,
   7.190 +                    literals = lits, ctypes_sorts = ctypes_sorts}
   7.191 +    end;
   7.192 +
   7.193 +
   7.194 +fun add_axiom_clause dfg thy ((th,(name,id)), pairs) =
   7.195 +  let val cls = make_clause dfg thy (id, name, RC.Axiom, th)
   7.196 +  in
   7.197 +      if isTaut cls then pairs else (name,cls)::pairs
   7.198 +  end;
   7.199 +
   7.200 +fun make_axiom_clauses dfg thy = List.foldl (add_axiom_clause dfg thy) [];
   7.201 +
   7.202 +fun make_conjecture_clauses_aux _ _ _ [] = []
   7.203 +  | make_conjecture_clauses_aux dfg thy n (th::ths) =
   7.204 +      make_clause dfg thy (n,"conjecture", RC.Conjecture, th) ::
   7.205 +      make_conjecture_clauses_aux dfg thy (n+1) ths;
   7.206 +
   7.207 +fun make_conjecture_clauses dfg thy = make_conjecture_clauses_aux dfg thy 0;
   7.208 +
   7.209 +
   7.210 +(**********************************************************************)
   7.211 +(* convert clause into ATP specific formats:                          *)
   7.212 +(* TPTP used by Vampire and E                                         *)
   7.213 +(* DFG used by SPASS                                                  *)
   7.214 +(**********************************************************************)
   7.215 +
   7.216 +(*Result of a function type; no need to check that the argument type matches.*)
   7.217 +fun result_type (RC.Comp ("tc_fun", [_, tp2])) = tp2
   7.218 +  | result_type _ = error "result_type"
   7.219 +
   7.220 +fun type_of_combterm (CombConst (_, tp, _)) = tp
   7.221 +  | type_of_combterm (CombVar (_, tp)) = tp
   7.222 +  | type_of_combterm (CombApp (t1, _)) = result_type (type_of_combterm t1);
   7.223 +
   7.224 +(*gets the head of a combinator application, along with the list of arguments*)
   7.225 +fun strip_comb u =
   7.226 +    let fun stripc (CombApp(t,u), ts) = stripc (t, u::ts)
   7.227 +        |   stripc  x =  x
   7.228 +    in  stripc(u,[])  end;
   7.229 +
   7.230 +val type_wrapper = "ti";
   7.231 +
   7.232 +fun head_needs_hBOOL const_needs_hBOOL (CombConst(c,_,_)) = needs_hBOOL const_needs_hBOOL c
   7.233 +  | head_needs_hBOOL _ _ = true;
   7.234 +
   7.235 +fun wrap_type t_full (s, tp) =
   7.236 +  if t_full then
   7.237 +      type_wrapper ^ RC.paren_pack [s, RC.string_of_fol_type tp]
   7.238 +  else s;
   7.239 +
   7.240 +fun apply ss = "hAPP" ^ RC.paren_pack ss;
   7.241 +
   7.242 +fun rev_apply (v, []) = v
   7.243 +  | rev_apply (v, arg::args) = apply [rev_apply (v, args), arg];
   7.244 +
   7.245 +fun string_apply (v, args) = rev_apply (v, rev args);
   7.246 +
   7.247 +(*Apply an operator to the argument strings, using either the "apply" operator or
   7.248 +  direct function application.*)
   7.249 +fun string_of_applic t_full cma (CombConst (c, _, tvars), args) =
   7.250 +      let val c = if c = "equal" then "c_fequal" else c
   7.251 +          val nargs = min_arity_of cma c
   7.252 +          val args1 = List.take(args, nargs)
   7.253 +            handle Subscript => error ("string_of_applic: " ^ c ^ " has arity " ^
   7.254 +                                         Int.toString nargs ^ " but is applied to " ^
   7.255 +                                         space_implode ", " args)
   7.256 +          val args2 = List.drop(args, nargs)
   7.257 +          val targs = if not t_full then map RC.string_of_fol_type tvars
   7.258 +                      else []
   7.259 +      in
   7.260 +          string_apply (c ^ RC.paren_pack (args1@targs), args2)
   7.261 +      end
   7.262 +  | string_of_applic _ _ (CombVar (v, _), args) = string_apply (v, args)
   7.263 +  | string_of_applic _ _ _ = error "string_of_applic";
   7.264 +
   7.265 +fun wrap_type_if t_full cnh (head, s, tp) =
   7.266 +  if head_needs_hBOOL cnh head then wrap_type t_full (s, tp) else s;
   7.267 +
   7.268 +fun string_of_combterm (params as (t_full, cma, cnh)) t =
   7.269 +  let val (head, args) = strip_comb t
   7.270 +  in  wrap_type_if t_full cnh (head,
   7.271 +                    string_of_applic t_full cma (head, map (string_of_combterm (params)) args),
   7.272 +                    type_of_combterm t)
   7.273 +  end;
   7.274 +
   7.275 +(*Boolean-valued terms are here converted to literals.*)
   7.276 +fun boolify params t =
   7.277 +  "hBOOL" ^ RC.paren_pack [string_of_combterm params t];
   7.278 +
   7.279 +fun string_of_predicate (params as (_,_,cnh)) t =
   7.280 +  case t of
   7.281 +      (CombApp(CombApp(CombConst("equal",_,_), t1), t2)) =>
   7.282 +          (*DFG only: new TPTP prefers infix equality*)
   7.283 +          ("equal" ^ RC.paren_pack [string_of_combterm params t1, string_of_combterm params t2])
   7.284 +    | _ =>
   7.285 +          case #1 (strip_comb t) of
   7.286 +              CombConst(c,_,_) => if needs_hBOOL cnh c then boolify params t else string_of_combterm params t
   7.287 +            | _ => boolify params t;
   7.288 +
   7.289 +
   7.290 +(*** tptp format ***)
   7.291 +
   7.292 +fun tptp_of_equality params pol (t1,t2) =
   7.293 +  let val eqop = if pol then " = " else " != "
   7.294 +  in  string_of_combterm params t1 ^ eqop ^ string_of_combterm params t2  end;
   7.295 +
   7.296 +fun tptp_literal params (Literal(pol, CombApp(CombApp(CombConst("equal",_,_), t1), t2))) =
   7.297 +      tptp_of_equality params pol (t1,t2)
   7.298 +  | tptp_literal params (Literal(pol,pred)) =
   7.299 +      RC.tptp_sign pol (string_of_predicate params pred);
   7.300 +
   7.301 +(*Given a clause, returns its literals paired with a list of literals concerning TFrees;
   7.302 +  the latter should only occur in conjecture clauses.*)
   7.303 +fun tptp_type_lits params pos (Clause{literals, ctypes_sorts, ...}) =
   7.304 +      (map (tptp_literal params) literals, 
   7.305 +       map (RC.tptp_of_typeLit pos) (RC.add_typs ctypes_sorts));
   7.306 +
   7.307 +fun clause2tptp params (cls as Clause {axiom_name, clause_id, kind, ...}) =
   7.308 +  let val (lits,tylits) = tptp_type_lits params (kind = RC.Conjecture) cls
   7.309 +  in
   7.310 +      (RC.gen_tptp_cls(clause_id,axiom_name,kind,lits,tylits), tylits)
   7.311 +  end;
   7.312 +
   7.313 +
   7.314 +(*** dfg format ***)
   7.315 +
   7.316 +fun dfg_literal params (Literal(pol,pred)) = RC.dfg_sign pol (string_of_predicate params pred);
   7.317 +
   7.318 +fun dfg_type_lits params pos (Clause{literals, ctypes_sorts, ...}) =
   7.319 +      (map (dfg_literal params) literals, 
   7.320 +       map (RC.dfg_of_typeLit pos) (RC.add_typs ctypes_sorts));
   7.321 +
   7.322 +fun get_uvars (CombConst _) vars = vars
   7.323 +  | get_uvars (CombVar(v,_)) vars = (v::vars)
   7.324 +  | get_uvars (CombApp(P,Q)) vars = get_uvars P (get_uvars Q vars);
   7.325 +
   7.326 +fun get_uvars_l (Literal(_,c)) = get_uvars c [];
   7.327 +
   7.328 +fun dfg_vars (Clause {literals,...}) = RC.union_all (map get_uvars_l literals);
   7.329 +
   7.330 +fun clause2dfg params (cls as Clause{axiom_name,clause_id,kind,ctypes_sorts,...}) =
   7.331 +  let val (lits,tylits) = dfg_type_lits params (kind = RC.Conjecture) cls
   7.332 +      val vars = dfg_vars cls
   7.333 +      val tvars = RC.get_tvar_strs ctypes_sorts
   7.334 +  in
   7.335 +      (RC.gen_dfg_cls(clause_id, axiom_name, kind, lits, tylits, tvars@vars), tylits)
   7.336 +  end;
   7.337 +
   7.338 +
   7.339 +(** For DFG format: accumulate function and predicate declarations **)
   7.340 +
   7.341 +fun addtypes tvars tab = List.foldl RC.add_foltype_funcs tab tvars;
   7.342 +
   7.343 +fun add_decls (t_full, cma, cnh) (CombConst (c, _, tvars), (funcs, preds)) =
   7.344 +      if c = "equal" then (addtypes tvars funcs, preds)
   7.345 +      else
   7.346 +        let val arity = min_arity_of cma c
   7.347 +            val ntys = if not t_full then length tvars else 0
   7.348 +            val addit = Symtab.update(c, arity+ntys)
   7.349 +        in
   7.350 +            if needs_hBOOL cnh c then (addtypes tvars (addit funcs), preds)
   7.351 +            else (addtypes tvars funcs, addit preds)
   7.352 +        end
   7.353 +  | add_decls _ (CombVar(_,ctp), (funcs,preds)) =
   7.354 +      (RC.add_foltype_funcs (ctp,funcs), preds)
   7.355 +  | add_decls params (CombApp(P,Q),decls) = add_decls params (P,add_decls params (Q,decls));
   7.356 +
   7.357 +fun add_literal_decls params (Literal(_,c), decls) = add_decls params (c,decls);
   7.358 +
   7.359 +fun add_clause_decls params (Clause {literals, ...}, decls) =
   7.360 +    List.foldl (add_literal_decls params) decls literals
   7.361 +    handle Symtab.DUP a => error ("function " ^ a ^ " has multiple arities")
   7.362 +
   7.363 +fun decls_of_clauses params clauses arity_clauses =
   7.364 +  let val init_functab = Symtab.update (type_wrapper,2) (Symtab.update ("hAPP",2) RC.init_functab)
   7.365 +      val init_predtab = Symtab.update ("hBOOL",1) Symtab.empty
   7.366 +      val (functab,predtab) = (List.foldl (add_clause_decls params) (init_functab, init_predtab) clauses)
   7.367 +  in
   7.368 +      (Symtab.dest (List.foldl RC.add_arityClause_funcs functab arity_clauses),
   7.369 +       Symtab.dest predtab)
   7.370 +  end;
   7.371 +
   7.372 +fun add_clause_preds (Clause {ctypes_sorts, ...}, preds) =
   7.373 +  List.foldl RC.add_type_sort_preds preds ctypes_sorts
   7.374 +  handle Symtab.DUP a => error ("predicate " ^ a ^ " has multiple arities")
   7.375 +
   7.376 +(*Higher-order clauses have only the predicates hBOOL and type classes.*)
   7.377 +fun preds_of_clauses clauses clsrel_clauses arity_clauses =
   7.378 +    Symtab.dest
   7.379 +        (List.foldl RC.add_classrelClause_preds
   7.380 +               (List.foldl RC.add_arityClause_preds
   7.381 +                      (List.foldl add_clause_preds Symtab.empty clauses)
   7.382 +                      arity_clauses)
   7.383 +               clsrel_clauses)
   7.384 +
   7.385 +
   7.386 +(**********************************************************************)
   7.387 +(* write clauses to files                                             *)
   7.388 +(**********************************************************************)
   7.389 +
   7.390 +val init_counters =
   7.391 +    Symtab.make [("c_COMBI", 0), ("c_COMBK", 0),
   7.392 +                 ("c_COMBB", 0), ("c_COMBC", 0),
   7.393 +                 ("c_COMBS", 0)];
   7.394 +
   7.395 +fun count_combterm (CombConst (c, _, _), ct) =
   7.396 +     (case Symtab.lookup ct c of NONE => ct  (*no counter*)
   7.397 +                               | SOME n => Symtab.update (c,n+1) ct)
   7.398 +  | count_combterm (CombVar _, ct) = ct
   7.399 +  | count_combterm (CombApp(t1,t2), ct) = count_combterm(t1, count_combterm(t2, ct));
   7.400 +
   7.401 +fun count_literal (Literal(_,t), ct) = count_combterm(t,ct);
   7.402 +
   7.403 +fun count_clause (Clause{literals,...}, ct) = List.foldl count_literal ct literals;
   7.404 +
   7.405 +fun count_user_clause user_lemmas (Clause{axiom_name,literals,...}, ct) =
   7.406 +  if axiom_name mem_string user_lemmas then List.foldl count_literal ct literals
   7.407 +  else ct;
   7.408 +
   7.409 +fun cnf_helper_thms thy =
   7.410 +  Res_Axioms.cnf_rules_pairs thy o map Res_Axioms.pairname
   7.411 +
   7.412 +fun get_helper_clauses dfg thy isFO (conjectures, axcls, user_lemmas) =
   7.413 +  if isFO then []  (*first-order*)
   7.414 +  else
   7.415 +    let
   7.416 +        val axclauses = map #2 (make_axiom_clauses dfg thy axcls)
   7.417 +        val ct0 = List.foldl count_clause init_counters conjectures
   7.418 +        val ct = List.foldl (count_user_clause user_lemmas) ct0 axclauses
   7.419 +        fun needed c = the (Symtab.lookup ct c) > 0
   7.420 +        val IK = if needed "c_COMBI" orelse needed "c_COMBK"
   7.421 +                 then cnf_helper_thms thy [comb_I,comb_K]
   7.422 +                 else []
   7.423 +        val BC = if needed "c_COMBB" orelse needed "c_COMBC"
   7.424 +                 then cnf_helper_thms thy [comb_B,comb_C]
   7.425 +                 else []
   7.426 +        val S = if needed "c_COMBS"
   7.427 +                then cnf_helper_thms thy [comb_S]
   7.428 +                else []
   7.429 +        val other = cnf_helper_thms thy [fequal_imp_equal,equal_imp_fequal]
   7.430 +    in
   7.431 +        map #2 (make_axiom_clauses dfg thy (other @ IK @ BC @ S))
   7.432 +    end;
   7.433 +
   7.434 +(*Find the minimal arity of each function mentioned in the term. Also, note which uses
   7.435 +  are not at top level, to see if hBOOL is needed.*)
   7.436 +fun count_constants_term toplev t (const_min_arity, const_needs_hBOOL) =
   7.437 +  let val (head, args) = strip_comb t
   7.438 +      val n = length args
   7.439 +      val (const_min_arity, const_needs_hBOOL) = fold (count_constants_term false) args (const_min_arity, const_needs_hBOOL)
   7.440 +  in
   7.441 +      case head of
   7.442 +          CombConst (a,_,_) => (*predicate or function version of "equal"?*)
   7.443 +            let val a = if a="equal" andalso not toplev then "c_fequal" else a
   7.444 +            val const_min_arity = Symtab.map_default (a, n) (Integer.min n) const_min_arity
   7.445 +            in
   7.446 +              if toplev then (const_min_arity, const_needs_hBOOL)
   7.447 +              else (const_min_arity, Symtab.update (a,true) (const_needs_hBOOL))
   7.448 +            end
   7.449 +        | _ => (const_min_arity, const_needs_hBOOL)
   7.450 +  end;
   7.451 +
   7.452 +(*A literal is a top-level term*)
   7.453 +fun count_constants_lit (Literal (_,t)) (const_min_arity, const_needs_hBOOL) =
   7.454 +  count_constants_term true t (const_min_arity, const_needs_hBOOL);
   7.455 +
   7.456 +fun count_constants_clause (Clause{literals,...}) (const_min_arity, const_needs_hBOOL) =
   7.457 +  fold count_constants_lit literals (const_min_arity, const_needs_hBOOL);
   7.458 +
   7.459 +fun display_arity const_needs_hBOOL (c,n) =
   7.460 +  Res_Axioms.trace_msg (fn () => "Constant: " ^ c ^ " arity:\t" ^ Int.toString n ^
   7.461 +                (if needs_hBOOL const_needs_hBOOL c then " needs hBOOL" else ""));
   7.462 +
   7.463 +fun count_constants (conjectures, _, extra_clauses, helper_clauses, _, _) =
   7.464 +  if minimize_applies then
   7.465 +     let val (const_min_arity, const_needs_hBOOL) =
   7.466 +          fold count_constants_clause conjectures (Symtab.empty, Symtab.empty)
   7.467 +       |> fold count_constants_clause extra_clauses
   7.468 +       |> fold count_constants_clause helper_clauses
   7.469 +     val _ = List.app (display_arity const_needs_hBOOL) (Symtab.dest (const_min_arity))
   7.470 +     in (const_min_arity, const_needs_hBOOL) end
   7.471 +  else (Symtab.empty, Symtab.empty);
   7.472 +
   7.473 +(* tptp format *)
   7.474 +
   7.475 +fun tptp_write_file t_full file clauses =
   7.476 +  let
   7.477 +    val (conjectures, axclauses, _, helper_clauses,
   7.478 +      classrel_clauses, arity_clauses) = clauses
   7.479 +    val (cma, cnh) = count_constants clauses
   7.480 +    val params = (t_full, cma, cnh)
   7.481 +    val (tptp_clss,tfree_litss) = ListPair.unzip (map (clause2tptp params) conjectures)
   7.482 +    val tfree_clss = map RC.tptp_tfree_clause (List.foldl (uncurry (union (op =))) [] tfree_litss)
   7.483 +    val _ =
   7.484 +      File.write_list file (
   7.485 +        map (#1 o (clause2tptp params)) axclauses @
   7.486 +        tfree_clss @
   7.487 +        tptp_clss @
   7.488 +        map RC.tptp_classrelClause classrel_clauses @
   7.489 +        map RC.tptp_arity_clause arity_clauses @
   7.490 +        map (#1 o (clause2tptp params)) helper_clauses)
   7.491 +    in (length axclauses + 1, length tfree_clss + length tptp_clss)
   7.492 +  end;
   7.493 +
   7.494 +
   7.495 +(* dfg format *)
   7.496 +
   7.497 +fun dfg_write_file t_full file clauses =
   7.498 +  let
   7.499 +    val (conjectures, axclauses, _, helper_clauses,
   7.500 +      classrel_clauses, arity_clauses) = clauses
   7.501 +    val (cma, cnh) = count_constants clauses
   7.502 +    val params = (t_full, cma, cnh)
   7.503 +    val (dfg_clss, tfree_litss) = ListPair.unzip (map (clause2dfg params) conjectures)
   7.504 +    and probname = Path.implode (Path.base file)
   7.505 +    val axstrs = map (#1 o (clause2dfg params)) axclauses
   7.506 +    val tfree_clss = map RC.dfg_tfree_clause (RC.union_all tfree_litss)
   7.507 +    val helper_clauses_strs = map (#1 o (clause2dfg params)) helper_clauses
   7.508 +    val (funcs,cl_preds) = decls_of_clauses params (helper_clauses @ conjectures @ axclauses) arity_clauses
   7.509 +    and ty_preds = preds_of_clauses axclauses classrel_clauses arity_clauses
   7.510 +    val _ =
   7.511 +      File.write_list file (
   7.512 +        RC.string_of_start probname ::
   7.513 +        RC.string_of_descrip probname ::
   7.514 +        RC.string_of_symbols (RC.string_of_funcs funcs)
   7.515 +          (RC.string_of_preds (cl_preds @ ty_preds)) ::
   7.516 +        "list_of_clauses(axioms,cnf).\n" ::
   7.517 +        axstrs @
   7.518 +        map RC.dfg_classrelClause classrel_clauses @
   7.519 +        map RC.dfg_arity_clause arity_clauses @
   7.520 +        helper_clauses_strs @
   7.521 +        ["end_of_list.\n\nlist_of_clauses(conjectures,cnf).\n"] @
   7.522 +        tfree_clss @
   7.523 +        dfg_clss @
   7.524 +        ["end_of_list.\n\n",
   7.525 +        (*VarWeight=3 helps the HO problems, probably by counteracting the presence of hAPP*)
   7.526 +         "list_of_settings(SPASS).\n{*\nset_flag(VarWeight,3).\n*}\nend_of_list.\n\n",
   7.527 +         "end_problem.\n"])
   7.528 +
   7.529 +    in (length axclauses + length classrel_clauses + length arity_clauses +
   7.530 +      length helper_clauses + 1, length tfree_clss + length dfg_clss)
   7.531 +  end;
   7.532 +
   7.533 +end;
   7.534 +
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_proof_reconstruct.ML	Wed Mar 17 18:16:31 2010 +0100
     8.3 @@ -0,0 +1,584 @@
     8.4 +(*  Title:      HOL/Tools/res_reconstruct.ML
     8.5 +    Author:     Lawrence C Paulson and Claire Quigley, Cambridge University Computer Laboratory
     8.6 +
     8.7 +Transfer of proofs from external provers.
     8.8 +*)
     8.9 +
    8.10 +signature RES_RECONSTRUCT =
    8.11 +sig
    8.12 +  val chained_hint: string
    8.13 +
    8.14 +  val fix_sorts: sort Vartab.table -> term -> term
    8.15 +  val invert_const: string -> string
    8.16 +  val invert_type_const: string -> string
    8.17 +  val num_typargs: theory -> string -> int
    8.18 +  val make_tvar: string -> typ
    8.19 +  val strip_prefix: string -> string -> string option
    8.20 +  val setup: theory -> theory
    8.21 +  (* extracting lemma list*)
    8.22 +  val find_failure: string -> string option
    8.23 +  val lemma_list: bool -> string ->
    8.24 +    string * string vector * (int * int) * Proof.context * thm * int -> string * string list
    8.25 +  (* structured proofs *)
    8.26 +  val structured_proof: string ->
    8.27 +    string * string vector * (int * int) * Proof.context * thm * int -> string * string list
    8.28 +end;
    8.29 +
    8.30 +structure Res_Reconstruct : RES_RECONSTRUCT =
    8.31 +struct
    8.32 +
    8.33 +val trace_path = Path.basic "atp_trace";
    8.34 +
    8.35 +fun trace s =
    8.36 +  if ! Res_Axioms.trace then File.append (File.tmp_path trace_path) s
    8.37 +  else ();
    8.38 +
    8.39 +fun string_of_thm ctxt = PrintMode.setmp [] (Display.string_of_thm ctxt);
    8.40 +
    8.41 +(*For generating structured proofs: keep every nth proof line*)
    8.42 +val (modulus, modulus_setup) = Attrib.config_int "sledgehammer_modulus" 1;
    8.43 +
    8.44 +(*Indicates whether to include sort information in generated proofs*)
    8.45 +val (recon_sorts, recon_sorts_setup) = Attrib.config_bool "sledgehammer_sorts" true;
    8.46 +
    8.47 +(*Indicated whether to generate full proofs or just lemma lists - now via setup of atps*)
    8.48 +(* val (full_proofs, full_proofs_setup) = Attrib.config_bool "sledgehammer_full" false; *)
    8.49 +
    8.50 +val setup = modulus_setup #> recon_sorts_setup;
    8.51 +
    8.52 +(**** PARSING OF TSTP FORMAT ****)
    8.53 +
    8.54 +(*Syntax trees, either termlist or formulae*)
    8.55 +datatype stree = Int of int | Br of string * stree list;
    8.56 +
    8.57 +fun atom x = Br(x,[]);
    8.58 +
    8.59 +fun scons (x,y) = Br("cons", [x,y]);
    8.60 +val listof = List.foldl scons (atom "nil");
    8.61 +
    8.62 +(*Strings enclosed in single quotes, e.g. filenames*)
    8.63 +val quoted = $$"'" |-- Scan.repeat (~$$"'") --| $$"'" >> implode;
    8.64 +
    8.65 +(*Intended for $true and $false*)
    8.66 +fun tf s = "c_" ^ str (Char.toUpper (String.sub(s,0))) ^ String.extract(s,1,NONE);
    8.67 +val truefalse = $$"$" |-- Symbol.scan_id >> (atom o tf);
    8.68 +
    8.69 +(*Integer constants, typically proof line numbers*)
    8.70 +fun is_digit s = Char.isDigit (String.sub(s,0));
    8.71 +val integer = Scan.many1 is_digit >> (the o Int.fromString o implode);
    8.72 +
    8.73 +(*Generalized FO terms, which include filenames, numbers, etc.*)
    8.74 +fun termlist x = (term ::: Scan.repeat ($$"," |-- term)) x
    8.75 +and term x = (quoted >> atom || integer>>Int || truefalse ||
    8.76 +              Symbol.scan_id -- Scan.optional ($$"(" |-- termlist --| $$")") [] >> Br ||
    8.77 +              $$"(" |-- term --| $$")" ||
    8.78 +              $$"[" |-- Scan.optional termlist [] --| $$"]" >> listof) x;
    8.79 +
    8.80 +fun negate t = Br("c_Not", [t]);
    8.81 +fun equate (t1,t2) = Br("c_equal", [t1,t2]);
    8.82 +
    8.83 +(*Apply equal or not-equal to a term*)
    8.84 +fun syn_equal (t, NONE) = t
    8.85 +  | syn_equal (t1, SOME (NONE, t2)) = equate (t1,t2)
    8.86 +  | syn_equal (t1, SOME (SOME _, t2)) = negate (equate (t1,t2));
    8.87 +
    8.88 +(*Literals can involve negation, = and !=.*)
    8.89 +fun literal x = ($$"~" |-- literal >> negate ||
    8.90 +                 (term -- Scan.option (Scan.option ($$"!") --| $$"=" -- term) >> syn_equal)) x;
    8.91 +
    8.92 +val literals = literal ::: Scan.repeat ($$"|" |-- literal);
    8.93 +
    8.94 +(*Clause: a list of literals separated by the disjunction sign*)
    8.95 +val clause = $$"(" |-- literals --| $$")" || Scan.single literal;
    8.96 +
    8.97 +val annotations = $$"," |-- term -- Scan.option ($$"," |-- termlist);
    8.98 +
    8.99 +(*<cnf_annotated> ::= cnf(<name>,<formula_role>,<cnf_formula><annotations>).
   8.100 +  The <name> could be an identifier, but we assume integers.*)
   8.101 +val tstp_line = (Scan.this_string "cnf" -- $$"(") |--
   8.102 +                integer --| $$"," -- Symbol.scan_id --| $$"," --
   8.103 +                clause -- Scan.option annotations --| $$ ")";
   8.104 +
   8.105 +
   8.106 +(**** INTERPRETATION OF TSTP SYNTAX TREES ****)
   8.107 +
   8.108 +exception STREE of stree;
   8.109 +
   8.110 +(*If string s has the prefix s1, return the result of deleting it.*)
   8.111 +fun strip_prefix s1 s =
   8.112 +  if String.isPrefix s1 s
   8.113 +  then SOME (Res_Clause.undo_ascii_of (String.extract (s, size s1, NONE)))
   8.114 +  else NONE;
   8.115 +
   8.116 +(*Invert the table of translations between Isabelle and ATPs*)
   8.117 +val type_const_trans_table_inv =
   8.118 +      Symtab.make (map swap (Symtab.dest Res_Clause.type_const_trans_table));
   8.119 +
   8.120 +fun invert_type_const c =
   8.121 +    case Symtab.lookup type_const_trans_table_inv c of
   8.122 +        SOME c' => c'
   8.123 +      | NONE => c;
   8.124 +
   8.125 +fun make_tvar b = TVar(("'" ^ b, 0), HOLogic.typeS);
   8.126 +fun make_var (b,T) = Var((b,0),T);
   8.127 +
   8.128 +(*Type variables are given the basic sort, HOL.type. Some will later be constrained
   8.129 +  by information from type literals, or by type inference.*)
   8.130 +fun type_of_stree t =
   8.131 +  case t of
   8.132 +      Int _ => raise STREE t
   8.133 +    | Br (a,ts) =>
   8.134 +        let val Ts = map type_of_stree ts
   8.135 +        in
   8.136 +          case strip_prefix Res_Clause.tconst_prefix a of
   8.137 +              SOME b => Type(invert_type_const b, Ts)
   8.138 +            | NONE =>
   8.139 +                if not (null ts) then raise STREE t  (*only tconsts have type arguments*)
   8.140 +                else
   8.141 +                case strip_prefix Res_Clause.tfree_prefix a of
   8.142 +                    SOME b => TFree("'" ^ b, HOLogic.typeS)
   8.143 +                  | NONE =>
   8.144 +                case strip_prefix Res_Clause.tvar_prefix a of
   8.145 +                    SOME b => make_tvar b
   8.146 +                  | NONE => make_tvar a   (*Variable from the ATP, say X1*)
   8.147 +        end;
   8.148 +
   8.149 +(*Invert the table of translations between Isabelle and ATPs*)
   8.150 +val const_trans_table_inv =
   8.151 +      Symtab.update ("fequal", "op =")
   8.152 +        (Symtab.make (map swap (Symtab.dest Res_Clause.const_trans_table)));
   8.153 +
   8.154 +fun invert_const c =
   8.155 +    case Symtab.lookup const_trans_table_inv c of
   8.156 +        SOME c' => c'
   8.157 +      | NONE => c;
   8.158 +
   8.159 +(*The number of type arguments of a constant, zero if it's monomorphic*)
   8.160 +fun num_typargs thy s = length (Sign.const_typargs thy (s, Sign.the_const_type thy s));
   8.161 +
   8.162 +(*Generates a constant, given its type arguments*)
   8.163 +fun const_of thy (a,Ts) = Const(a, Sign.const_instance thy (a,Ts));
   8.164 +
   8.165 +(*First-order translation. No types are known for variables. HOLogic.typeT should allow
   8.166 +  them to be inferred.*)
   8.167 +fun term_of_stree args thy t =
   8.168 +  case t of
   8.169 +      Int _ => raise STREE t
   8.170 +    | Br ("hBOOL",[t]) => term_of_stree [] thy t  (*ignore hBOOL*)
   8.171 +    | Br ("hAPP",[t,u]) => term_of_stree (u::args) thy t
   8.172 +    | Br (a,ts) =>
   8.173 +        case strip_prefix Res_Clause.const_prefix a of
   8.174 +            SOME "equal" =>
   8.175 +              list_comb(Const ("op =", HOLogic.typeT), List.map (term_of_stree [] thy) ts)
   8.176 +          | SOME b =>
   8.177 +              let val c = invert_const b
   8.178 +                  val nterms = length ts - num_typargs thy c
   8.179 +                  val us = List.map (term_of_stree [] thy) (List.take(ts,nterms) @ args)
   8.180 +                  (*Extra args from hAPP come AFTER any arguments given directly to the
   8.181 +                    constant.*)
   8.182 +                  val Ts = List.map type_of_stree (List.drop(ts,nterms))
   8.183 +              in  list_comb(const_of thy (c, Ts), us)  end
   8.184 +          | NONE => (*a variable, not a constant*)
   8.185 +              let val T = HOLogic.typeT
   8.186 +                  val opr = (*a Free variable is typically a Skolem function*)
   8.187 +                    case strip_prefix Res_Clause.fixed_var_prefix a of
   8.188 +                        SOME b => Free(b,T)
   8.189 +                      | NONE =>
   8.190 +                    case strip_prefix Res_Clause.schematic_var_prefix a of
   8.191 +                        SOME b => make_var (b,T)
   8.192 +                      | NONE => make_var (a,T)    (*Variable from the ATP, say X1*)
   8.193 +              in  list_comb (opr, List.map (term_of_stree [] thy) (ts@args))  end;
   8.194 +
   8.195 +(*Type class literal applied to a type. Returns triple of polarity, class, type.*)
   8.196 +fun constraint_of_stree pol (Br("c_Not",[t])) = constraint_of_stree (not pol) t
   8.197 +  | constraint_of_stree pol t = case t of
   8.198 +        Int _ => raise STREE t
   8.199 +      | Br (a,ts) =>
   8.200 +            (case (strip_prefix Res_Clause.class_prefix a, map type_of_stree ts) of
   8.201 +                 (SOME b, [T]) => (pol, b, T)
   8.202 +               | _ => raise STREE t);
   8.203 +
   8.204 +(** Accumulate type constraints in a clause: negative type literals **)
   8.205 +
   8.206 +fun addix (key,z)  = Vartab.map_default (key,[]) (cons z);
   8.207 +
   8.208 +fun add_constraint ((false, cl, TFree(a,_)), vt) = addix ((a,~1),cl) vt
   8.209 +  | add_constraint ((false, cl, TVar(ix,_)), vt) = addix (ix,cl) vt
   8.210 +  | add_constraint (_, vt) = vt;
   8.211 +
   8.212 +(*False literals (which E includes in its proofs) are deleted*)
   8.213 +val nofalses = filter (not o equal HOLogic.false_const);
   8.214 +
   8.215 +(*Final treatment of the list of "real" literals from a clause.*)
   8.216 +fun finish [] = HOLogic.true_const  (*No "real" literals means only type information*)
   8.217 +  | finish lits =
   8.218 +      case nofalses lits of
   8.219 +          [] => HOLogic.false_const  (*The empty clause, since we started with real literals*)
   8.220 +        | xs => foldr1 HOLogic.mk_disj (rev xs);
   8.221 +
   8.222 +(*Accumulate sort constraints in vt, with "real" literals in lits.*)
   8.223 +fun lits_of_strees _ (vt, lits) [] = (vt, finish lits)
   8.224 +  | lits_of_strees ctxt (vt, lits) (t::ts) =
   8.225 +      lits_of_strees ctxt (add_constraint (constraint_of_stree true t, vt), lits) ts
   8.226 +      handle STREE _ =>
   8.227 +      lits_of_strees ctxt (vt, term_of_stree [] (ProofContext.theory_of ctxt) t :: lits) ts;
   8.228 +
   8.229 +(*Update TVars/TFrees with detected sort constraints.*)
   8.230 +fun fix_sorts vt =
   8.231 +  let fun tysubst (Type (a, Ts)) = Type (a, map tysubst Ts)
   8.232 +        | tysubst (TVar (xi, s)) = TVar (xi, the_default s (Vartab.lookup vt xi))
   8.233 +        | tysubst (TFree (x, s)) = TFree (x, the_default s (Vartab.lookup vt (x, ~1)))
   8.234 +      fun tmsubst (Const (a, T)) = Const (a, tysubst T)
   8.235 +        | tmsubst (Free (a, T)) = Free (a, tysubst T)
   8.236 +        | tmsubst (Var (xi, T)) = Var (xi, tysubst T)
   8.237 +        | tmsubst (t as Bound _) = t
   8.238 +        | tmsubst (Abs (a, T, t)) = Abs (a, tysubst T, tmsubst t)
   8.239 +        | tmsubst (t $ u) = tmsubst t $ tmsubst u;
   8.240 +  in fn t => if Vartab.is_empty vt then t else tmsubst t end;
   8.241 +
   8.242 +(*Interpret a list of syntax trees as a clause, given by "real" literals and sort constraints.
   8.243 +  vt0 holds the initial sort constraints, from the conjecture clauses.*)
   8.244 +fun clause_of_strees ctxt vt0 ts =
   8.245 +  let val (vt, dt) = lits_of_strees ctxt (vt0,[]) ts in
   8.246 +    singleton (Syntax.check_terms ctxt) (TypeInfer.constrain HOLogic.boolT (fix_sorts vt dt))
   8.247 +  end;
   8.248 +
   8.249 +fun gen_all_vars t = fold_rev Logic.all (OldTerm.term_vars t) t;
   8.250 +
   8.251 +fun ints_of_stree_aux (Int n, ns) = n::ns
   8.252 +  | ints_of_stree_aux (Br(_,ts), ns) = List.foldl ints_of_stree_aux ns ts;
   8.253 +
   8.254 +fun ints_of_stree t = ints_of_stree_aux (t, []);
   8.255 +
   8.256 +fun decode_tstp vt0 (name, role, ts, annots) ctxt =
   8.257 +  let val deps = case annots of NONE => [] | SOME (source,_) => ints_of_stree source
   8.258 +      val cl = clause_of_strees ctxt vt0 ts
   8.259 +  in  ((name, role, cl, deps), fold Variable.declare_term (OldTerm.term_frees cl) ctxt)  end;
   8.260 +
   8.261 +fun dest_tstp ((((name, role), ts), annots), chs) =
   8.262 +  case chs of
   8.263 +          "."::_ => (name, role, ts, annots)
   8.264 +        | _ => error ("TSTP line not terminated by \".\": " ^ implode chs);
   8.265 +
   8.266 +
   8.267 +(** Global sort constraints on TFrees (from tfree_tcs) are positive unit clauses. **)
   8.268 +
   8.269 +fun add_tfree_constraint ((true, cl, TFree(a,_)), vt) = addix ((a,~1),cl) vt
   8.270 +  | add_tfree_constraint (_, vt) = vt;
   8.271 +
   8.272 +fun tfree_constraints_of_clauses vt [] = vt
   8.273 +  | tfree_constraints_of_clauses vt ([lit]::tss) =
   8.274 +      (tfree_constraints_of_clauses (add_tfree_constraint (constraint_of_stree true lit, vt)) tss
   8.275 +       handle STREE _ => (*not a positive type constraint: ignore*)
   8.276 +       tfree_constraints_of_clauses vt tss)
   8.277 +  | tfree_constraints_of_clauses vt (_::tss) = tfree_constraints_of_clauses vt tss;
   8.278 +
   8.279 +
   8.280 +(**** Translation of TSTP files to Isar Proofs ****)
   8.281 +
   8.282 +fun decode_tstp_list ctxt tuples =
   8.283 +  let val vt0 = tfree_constraints_of_clauses Vartab.empty (map #3 tuples)
   8.284 +  in  #1 (fold_map (decode_tstp vt0) tuples ctxt) end;
   8.285 +
   8.286 +(** Finding a matching assumption. The literals may be permuted, and variable names
   8.287 +    may disagree. We have to try all combinations of literals (quadratic!) and
   8.288 +    match up the variable names consistently. **)
   8.289 +
   8.290 +fun strip_alls_aux n (Const("all",_)$Abs(a,T,t))  =
   8.291 +      strip_alls_aux (n+1) (subst_bound (Var ((a,n), T), t))
   8.292 +  | strip_alls_aux _ t  =  t;
   8.293 +
   8.294 +val strip_alls = strip_alls_aux 0;
   8.295 +
   8.296 +exception MATCH_LITERAL;
   8.297 +
   8.298 +(*Ignore types: they are not to be trusted...*)
   8.299 +fun match_literal (t1$u1) (t2$u2) env =
   8.300 +      match_literal t1 t2 (match_literal u1 u2 env)
   8.301 +  | match_literal (Abs (_,_,t1)) (Abs (_,_,t2)) env =
   8.302 +      match_literal t1 t2 env
   8.303 +  | match_literal (Bound i1) (Bound i2) env =
   8.304 +      if i1=i2 then env else raise MATCH_LITERAL
   8.305 +  | match_literal (Const(a1,_)) (Const(a2,_)) env =
   8.306 +      if a1=a2 then env else raise MATCH_LITERAL
   8.307 +  | match_literal (Free(a1,_)) (Free(a2,_)) env =
   8.308 +      if a1=a2 then env else raise MATCH_LITERAL
   8.309 +  | match_literal (Var(ix1,_)) (Var(ix2,_)) env = insert (op =) (ix1,ix2) env
   8.310 +  | match_literal _ _ _ = raise MATCH_LITERAL;
   8.311 +
   8.312 +(*Checking that all variable associations are unique. The list env contains no
   8.313 +  repetitions, but does it contain say (x,y) and (y,y)? *)
   8.314 +fun good env =
   8.315 +  let val (xs,ys) = ListPair.unzip env
   8.316 +  in  not (has_duplicates (op=) xs orelse has_duplicates (op=) ys)  end;
   8.317 +
   8.318 +(*Match one list of literals against another, ignoring types and the order of
   8.319 +  literals. Sorting is unreliable because we don't have types or variable names.*)
   8.320 +fun matches_aux _ [] [] = true
   8.321 +  | matches_aux env (lit::lits) ts =
   8.322 +      let fun match1 us [] = false
   8.323 +            | match1 us (t::ts) =
   8.324 +                let val env' = match_literal lit t env
   8.325 +                in  (good env' andalso matches_aux env' lits (us@ts)) orelse
   8.326 +                    match1 (t::us) ts
   8.327 +                end
   8.328 +                handle MATCH_LITERAL => match1 (t::us) ts
   8.329 +      in  match1 [] ts  end;
   8.330 +
   8.331 +(*Is this length test useful?*)
   8.332 +fun matches (lits1,lits2) =
   8.333 +  length lits1 = length lits2  andalso
   8.334 +  matches_aux [] (map Envir.eta_contract lits1) (map Envir.eta_contract lits2);
   8.335 +
   8.336 +fun permuted_clause t =
   8.337 +  let val lits = HOLogic.disjuncts t
   8.338 +      fun perm [] = NONE
   8.339 +        | perm (ctm::ctms) =
   8.340 +            if matches (lits, HOLogic.disjuncts (HOLogic.dest_Trueprop (strip_alls ctm)))
   8.341 +            then SOME ctm else perm ctms
   8.342 +  in perm end;
   8.343 +
   8.344 +fun have_or_show "show " _ = "show \""
   8.345 +  | have_or_show have lname = have ^ lname ^ ": \""
   8.346 +
   8.347 +(*ctms is a list of conjecture clauses as yielded by Isabelle. Those returned by the
   8.348 +  ATP may have their literals reordered.*)
   8.349 +fun isar_lines ctxt ctms =
   8.350 +  let val string_of = PrintMode.setmp [] (fn term => Syntax.string_of_term ctxt term)
   8.351 +      val _ = trace ("\n\nisar_lines: start\n")
   8.352 +      fun doline _ (lname, t, []) =  (*No deps: it's a conjecture clause, with no proof.*)
   8.353 +           (case permuted_clause t ctms of
   8.354 +                SOME u => "assume " ^ lname ^ ": \"" ^ string_of u ^ "\"\n"
   8.355 +              | NONE => "assume? " ^ lname ^ ": \"" ^ string_of t ^ "\"\n")  (*no match!!*)
   8.356 +        | doline have (lname, t, deps) =
   8.357 +            have_or_show have lname ^ string_of (gen_all_vars (HOLogic.mk_Trueprop t)) ^
   8.358 +            "\"\n  by (metis " ^ space_implode " " deps ^ ")\n"
   8.359 +      fun dolines [(lname, t, deps)] = [doline "show " (lname, t, deps)]
   8.360 +        | dolines ((lname, t, deps)::lines) = doline "have " (lname, t, deps) :: dolines lines
   8.361 +  in setmp_CRITICAL show_sorts (Config.get ctxt recon_sorts) dolines end;
   8.362 +
   8.363 +fun notequal t (_,t',_) = not (t aconv t');
   8.364 +
   8.365 +(*No "real" literals means only type information*)
   8.366 +fun eq_types t = t aconv HOLogic.true_const;
   8.367 +
   8.368 +fun replace_dep (old:int, new) dep = if dep=old then new else [dep];
   8.369 +
   8.370 +fun replace_deps (old:int, new) (lno, t, deps) =
   8.371 +      (lno, t, List.foldl (uncurry (union (op =))) [] (map (replace_dep (old, new)) deps));
   8.372 +
   8.373 +(*Discard axioms; consolidate adjacent lines that prove the same clause, since they differ
   8.374 +  only in type information.*)
   8.375 +fun add_prfline ((lno, "axiom", t, []), lines) =  (*axioms are not proof lines*)
   8.376 +      if eq_types t (*must be clsrel/clsarity: type information, so delete refs to it*)
   8.377 +      then map (replace_deps (lno, [])) lines
   8.378 +      else
   8.379 +       (case take_prefix (notequal t) lines of
   8.380 +           (_,[]) => lines                  (*no repetition of proof line*)
   8.381 +         | (pre, (lno', _, _) :: post) =>   (*repetition: replace later line by earlier one*)
   8.382 +             pre @ map (replace_deps (lno', [lno])) post)
   8.383 +  | add_prfline ((lno, _, t, []), lines) =  (*no deps: conjecture clause*)
   8.384 +      (lno, t, []) :: lines
   8.385 +  | add_prfline ((lno, _, t, deps), lines) =
   8.386 +      if eq_types t then (lno, t, deps) :: lines
   8.387 +      (*Type information will be deleted later; skip repetition test.*)
   8.388 +      else (*FIXME: Doesn't this code risk conflating proofs involving different types??*)
   8.389 +      case take_prefix (notequal t) lines of
   8.390 +         (_,[]) => (lno, t, deps) :: lines  (*no repetition of proof line*)
   8.391 +       | (pre, (lno', t', _) :: post) =>
   8.392 +           (lno, t', deps) ::               (*repetition: replace later line by earlier one*)
   8.393 +           (pre @ map (replace_deps (lno', [lno])) post);
   8.394 +
   8.395 +(*Recursively delete empty lines (type information) from the proof.*)
   8.396 +fun add_nonnull_prfline ((lno, t, []), lines) = (*no dependencies, so a conjecture clause*)
   8.397 +     if eq_types t (*must be type information, tfree_tcs, clsrel, clsarity: delete refs to it*)
   8.398 +     then delete_dep lno lines
   8.399 +     else (lno, t, []) :: lines
   8.400 +  | add_nonnull_prfline ((lno, t, deps), lines) = (lno, t, deps) :: lines
   8.401 +and delete_dep lno lines = List.foldr add_nonnull_prfline [] (map (replace_deps (lno, [])) lines);
   8.402 +
   8.403 +fun bad_free (Free (a,_)) = String.isPrefix "sko_" a
   8.404 +  | bad_free _ = false;
   8.405 +
   8.406 +(*TVars are forbidden in goals. Also, we don't want lines with <2 dependencies.
   8.407 +  To further compress proofs, setting modulus:=n deletes every nth line, and nlines
   8.408 +  counts the number of proof lines processed so far.
   8.409 +  Deleted lines are replaced by their own dependencies. Note that the "add_nonnull_prfline"
   8.410 +  phase may delete some dependencies, hence this phase comes later.*)
   8.411 +fun add_wanted_prfline ctxt ((lno, t, []), (nlines, lines)) =
   8.412 +      (nlines, (lno, t, []) :: lines)   (*conjecture clauses must be kept*)
   8.413 +  | add_wanted_prfline ctxt ((lno, t, deps), (nlines, lines)) =
   8.414 +      if eq_types t orelse not (null (Term.add_tvars t [])) orelse
   8.415 +         exists_subterm bad_free t orelse
   8.416 +         (not (null lines) andalso   (*final line can't be deleted for these reasons*)
   8.417 +          (length deps < 2 orelse nlines mod (Config.get ctxt modulus) <> 0))
   8.418 +      then (nlines+1, map (replace_deps (lno, deps)) lines) (*Delete line*)
   8.419 +      else (nlines+1, (lno, t, deps) :: lines);
   8.420 +
   8.421 +(*Replace numeric proof lines by strings, either from thm_names or sequential line numbers*)
   8.422 +fun stringify_deps thm_names deps_map [] = []
   8.423 +  | stringify_deps thm_names deps_map ((lno, t, deps) :: lines) =
   8.424 +      if lno <= Vector.length thm_names  (*axiom*)
   8.425 +      then (Vector.sub(thm_names,lno-1), t, []) :: stringify_deps thm_names deps_map lines
   8.426 +      else let val lname = Int.toString (length deps_map)
   8.427 +               fun fix lno = if lno <= Vector.length thm_names
   8.428 +                             then SOME(Vector.sub(thm_names,lno-1))
   8.429 +                             else AList.lookup op= deps_map lno;
   8.430 +           in  (lname, t, map_filter fix (distinct (op=) deps)) ::
   8.431 +               stringify_deps thm_names ((lno,lname)::deps_map) lines
   8.432 +           end;
   8.433 +
   8.434 +val proofstart = "proof (neg_clausify)\n";
   8.435 +
   8.436 +fun isar_header [] = proofstart
   8.437 +  | isar_header ts = proofstart ^ "fix " ^ space_implode " " ts ^ "\n";
   8.438 +
   8.439 +fun decode_tstp_file cnfs ctxt th sgno thm_names =
   8.440 +  let val _ = trace "\ndecode_tstp_file: start\n"
   8.441 +      val tuples = map (dest_tstp o tstp_line o explode) cnfs
   8.442 +      val _ = trace (Int.toString (length tuples) ^ " tuples extracted\n")
   8.443 +      val ctxt = ProofContext.set_mode ProofContext.mode_schematic ctxt
   8.444 +      val raw_lines = List.foldr add_prfline [] (decode_tstp_list ctxt tuples)
   8.445 +      val _ = trace (Int.toString (length raw_lines) ^ " raw_lines extracted\n")
   8.446 +      val nonnull_lines = List.foldr add_nonnull_prfline [] raw_lines
   8.447 +      val _ = trace (Int.toString (length nonnull_lines) ^ " nonnull_lines extracted\n")
   8.448 +      val (_,lines) = List.foldr (add_wanted_prfline ctxt) (0,[]) nonnull_lines
   8.449 +      val _ = trace (Int.toString (length lines) ^ " lines extracted\n")
   8.450 +      val (ccls,fixes) = Res_Axioms.neg_conjecture_clauses ctxt th sgno
   8.451 +      val _ = trace (Int.toString (length ccls) ^ " conjecture clauses\n")
   8.452 +      val ccls = map forall_intr_vars ccls
   8.453 +      val _ =
   8.454 +        if ! Res_Axioms.trace then app (fn th => trace ("\nccl: " ^ string_of_thm ctxt th)) ccls
   8.455 +        else ()
   8.456 +      val ilines = isar_lines ctxt (map prop_of ccls) (stringify_deps thm_names [] lines)
   8.457 +      val _ = trace "\ndecode_tstp_file: finishing\n"
   8.458 +  in
   8.459 +    isar_header (map #1 fixes) ^ implode ilines ^ "qed\n"
   8.460 +  end handle STREE _ => error "Could not extract proof (ATP output malformed?)";
   8.461 +
   8.462 +
   8.463 +(*=== EXTRACTING PROOF-TEXT === *)
   8.464 +
   8.465 +val begin_proof_strings = ["# SZS output start CNFRefutation.",
   8.466 +  "=========== Refutation ==========",
   8.467 +  "Here is a proof"];
   8.468 +
   8.469 +val end_proof_strings = ["# SZS output end CNFRefutation",
   8.470 +  "======= End of refutation =======",
   8.471 +  "Formulae used in the proof"];
   8.472 +
   8.473 +fun get_proof_extract proof =
   8.474 +  let
   8.475 +    (*splits to_split by the first possible of a list of splitters*)
   8.476 +    val (begin_string, end_string) =
   8.477 +      (find_first (fn s => String.isSubstring s proof) begin_proof_strings,
   8.478 +      find_first (fn s => String.isSubstring s proof) end_proof_strings)
   8.479 +  in
   8.480 +    if is_none begin_string orelse is_none end_string
   8.481 +    then error "Could not extract proof (no substring indicating a proof)"
   8.482 +    else proof |> first_field (the begin_string) |> the |> snd
   8.483 +               |> first_field (the end_string) |> the |> fst
   8.484 +  end;
   8.485 +
   8.486 +(* ==== CHECK IF PROOF OF E OR VAMPIRE WAS SUCCESSFUL === *)
   8.487 +
   8.488 +val failure_strings_E = ["SZS status: Satisfiable","SZS status Satisfiable",
   8.489 +  "SZS status: ResourceOut","SZS status ResourceOut","# Cannot determine problem status"];
   8.490 +val failure_strings_vampire = ["Satisfiability detected", "Refutation not found", "CANNOT PROVE"];
   8.491 +val failure_strings_SPASS = ["SPASS beiseite: Completion found.",
   8.492 +  "SPASS beiseite: Ran out of time.", "SPASS beiseite: Maximal number of loops exceeded."];
   8.493 +val failure_strings_remote = ["Remote-script could not extract proof"];
   8.494 +fun find_failure proof =
   8.495 +  let val failures =
   8.496 +    map_filter (fn s => if String.isSubstring s proof then SOME s else NONE)
   8.497 +      (failure_strings_E @ failure_strings_vampire @ failure_strings_SPASS @ failure_strings_remote)
   8.498 +  val correct = null failures andalso
   8.499 +    exists (fn s => String.isSubstring s proof) begin_proof_strings andalso
   8.500 +    exists (fn s => String.isSubstring s proof) end_proof_strings
   8.501 +  in
   8.502 +    if correct then NONE
   8.503 +    else if null failures then SOME "Output of ATP not in proper format"
   8.504 +    else SOME (hd failures) end;
   8.505 +
   8.506 +(* === EXTRACTING LEMMAS === *)
   8.507 +(* lines have the form "cnf(108, axiom, ...",
   8.508 +the number (108) has to be extracted)*)
   8.509 +fun get_step_nums false proofextract =
   8.510 +  let val toks = String.tokens (not o Char.isAlphaNum)
   8.511 +  fun inputno ("cnf"::ntok::"axiom"::_) = Int.fromString ntok
   8.512 +    | inputno ("cnf"::ntok::"negated"::"conjecture"::_) = Int.fromString ntok
   8.513 +    | inputno _ = NONE
   8.514 +  val lines = split_lines proofextract
   8.515 +  in  map_filter (inputno o toks) lines  end
   8.516 +(*String contains multiple lines. We want those of the form
   8.517 +  "253[0:Inp] et cetera..."
   8.518 +  A list consisting of the first number in each line is returned. *)
   8.519 +|  get_step_nums true proofextract =
   8.520 +  let val toks = String.tokens (not o Char.isAlphaNum)
   8.521 +  fun inputno (ntok::"0"::"Inp"::_) = Int.fromString ntok
   8.522 +    | inputno _ = NONE
   8.523 +  val lines = split_lines proofextract
   8.524 +  in  map_filter (inputno o toks) lines  end
   8.525 +  
   8.526 +(*extracting lemmas from tstp-output between the lines from above*)
   8.527 +fun extract_lemmas get_step_nums (proof, thm_names, conj_count, _, _, _) =
   8.528 +  let
   8.529 +  (* get the names of axioms from their numbers*)
   8.530 +  fun get_axiom_names thm_names step_nums =
   8.531 +    let
   8.532 +    val last_axiom = Vector.length thm_names
   8.533 +    fun is_axiom n = n <= last_axiom
   8.534 +    fun is_conj n = n >= fst conj_count andalso n < fst conj_count + snd conj_count
   8.535 +    fun getname i = Vector.sub(thm_names, i-1)
   8.536 +    in
   8.537 +      (sort_distinct string_ord (filter (fn x => x <> "??.unknown")
   8.538 +        (map getname (filter is_axiom step_nums))),
   8.539 +      exists is_conj step_nums)
   8.540 +    end
   8.541 +  val proofextract = get_proof_extract proof
   8.542 +  in
   8.543 +    get_axiom_names thm_names (get_step_nums proofextract)
   8.544 +  end;
   8.545 +
   8.546 +(*Used to label theorems chained into the sledgehammer call*)
   8.547 +val chained_hint = "CHAINED";
   8.548 +val nochained = filter_out (fn y => y = chained_hint)
   8.549 +  
   8.550 +(* metis-command *)
   8.551 +fun metis_line [] = "apply metis"
   8.552 +  | metis_line xs = "apply (metis " ^ space_implode " " xs ^ ")"
   8.553 +
   8.554 +(* atp_minimize [atp=<prover>] <lemmas> *)
   8.555 +fun minimize_line _ [] = ""
   8.556 +  | minimize_line name lemmas = "For minimizing the number of lemmas try this command:\n" ^
   8.557 +        (Markup.markup Markup.sendback) ("atp_minimize [atp=" ^ name ^ "] " ^
   8.558 +                                         space_implode " " (nochained lemmas))
   8.559 +
   8.560 +fun sendback_metis_nochained lemmas =
   8.561 +  (Markup.markup Markup.sendback o metis_line) (nochained lemmas)
   8.562 +
   8.563 +fun lemma_list dfg name result =
   8.564 +  let val (lemmas, used_conj) = extract_lemmas (get_step_nums dfg) result
   8.565 +  in (sendback_metis_nochained lemmas ^ "\n" ^ minimize_line name lemmas ^
   8.566 +    (if used_conj then ""
   8.567 +     else "\nWarning: Goal is provable because context is inconsistent."),
   8.568 +     nochained lemmas)
   8.569 +  end;
   8.570 +
   8.571 +(* === Extracting structured Isar-proof === *)
   8.572 +fun structured_proof name (result as (proof, thm_names, conj_count, ctxt, goal, subgoalno)) =
   8.573 +  let
   8.574 +  (*Could use split_lines, but it can return blank lines...*)
   8.575 +  val lines = String.tokens (equal #"\n");
   8.576 +  val nospaces = String.translate (fn c => if Char.isSpace c then "" else str c)
   8.577 +  val proofextract = get_proof_extract proof
   8.578 +  val cnfs = filter (String.isPrefix "cnf(") (map nospaces (lines proofextract))
   8.579 +  val (one_line_proof, lemma_names) = lemma_list false name result
   8.580 +  val structured =
   8.581 +    if chained_hint mem_string (String.tokens (fn c => c = #" ") one_line_proof) then ""
   8.582 +    else decode_tstp_file cnfs ctxt goal subgoalno thm_names
   8.583 +  in
   8.584 +  (one_line_proof ^ "\n\n" ^ Markup.markup Markup.sendback structured, lemma_names)
   8.585 +end
   8.586 +
   8.587 +end;
     9.1 --- a/src/HOL/Tools/metis_tools.ML	Wed Mar 17 17:23:45 2010 +0100
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,742 +0,0 @@
     9.4 -(*  Title:      HOL/Tools/metis_tools.ML
     9.5 -    Author:     Kong W. Susanto and Lawrence C. Paulson, CU Computer Laboratory
     9.6 -    Copyright   Cambridge University 2007
     9.7 -
     9.8 -HOL setup for the Metis prover.
     9.9 -*)
    9.10 -
    9.11 -signature METIS_TOOLS =
    9.12 -sig
    9.13 -  val trace: bool Unsynchronized.ref
    9.14 -  val type_lits: bool Config.T
    9.15 -  val metis_tac: Proof.context -> thm list -> int -> tactic
    9.16 -  val metisF_tac: Proof.context -> thm list -> int -> tactic
    9.17 -  val metisFT_tac: Proof.context -> thm list -> int -> tactic
    9.18 -  val setup: theory -> theory
    9.19 -end
    9.20 -
    9.21 -structure MetisTools: METIS_TOOLS =
    9.22 -struct
    9.23 -
    9.24 -val trace = Unsynchronized.ref false;
    9.25 -fun trace_msg msg = if ! trace then tracing (msg ()) else ();
    9.26 -
    9.27 -val (type_lits, type_lits_setup) = Attrib.config_bool "metis_type_lits" true;
    9.28 -
    9.29 -datatype mode = FO | HO | FT  (*first-order, higher-order, fully-typed*)
    9.30 -
    9.31 -(* ------------------------------------------------------------------------- *)
    9.32 -(* Useful Theorems                                                           *)
    9.33 -(* ------------------------------------------------------------------------- *)
    9.34 -val EXCLUDED_MIDDLE = @{lemma "P ==> ~ P ==> False" by (rule notE)}
    9.35 -val REFL_THM = incr_indexes 2 @{lemma "t ~= t ==> False" by simp}
    9.36 -val subst_em = @{lemma "s = t ==> P s ==> ~ P t ==> False" by simp}
    9.37 -val ssubst_em = @{lemma "s = t ==> P t ==> ~ P s ==> False" by simp}
    9.38 -
    9.39 -(* ------------------------------------------------------------------------- *)
    9.40 -(* Useful Functions                                                          *)
    9.41 -(* ------------------------------------------------------------------------- *)
    9.42 -
    9.43 -(* match untyped terms*)
    9.44 -fun untyped_aconv (Const(a,_))   (Const(b,_))   = (a=b)
    9.45 -  | untyped_aconv (Free(a,_))    (Free(b,_))    = (a=b)
    9.46 -  | untyped_aconv (Var((a,_),_)) (Var((b,_),_)) = (a=b)   (*the index is ignored!*)
    9.47 -  | untyped_aconv (Bound i)      (Bound j)      = (i=j)
    9.48 -  | untyped_aconv (Abs(a,_,t))  (Abs(b,_,u))    = (a=b) andalso untyped_aconv t u
    9.49 -  | untyped_aconv (t1$t2) (u1$u2)  = untyped_aconv t1 u1 andalso untyped_aconv t2 u2
    9.50 -  | untyped_aconv _              _              = false;
    9.51 -
    9.52 -(* Finding the relative location of an untyped term within a list of terms *)
    9.53 -fun get_index lit =
    9.54 -  let val lit = Envir.eta_contract lit
    9.55 -      fun get n [] = raise Empty
    9.56 -        | get n (x::xs) = if untyped_aconv lit (Envir.eta_contract (HOLogic.dest_Trueprop x))
    9.57 -                          then n  else get (n+1) xs
    9.58 -  in get 1 end;
    9.59 -
    9.60 -(* ------------------------------------------------------------------------- *)
    9.61 -(* HOL to FOL  (Isabelle to Metis)                                           *)
    9.62 -(* ------------------------------------------------------------------------- *)
    9.63 -
    9.64 -fun fn_isa_to_met "equal" = "="
    9.65 -  | fn_isa_to_met x       = x;
    9.66 -
    9.67 -fun metis_lit b c args = (b, (c, args));
    9.68 -
    9.69 -fun hol_type_to_fol (Res_Clause.AtomV x) = Metis.Term.Var x
    9.70 -  | hol_type_to_fol (Res_Clause.AtomF x) = Metis.Term.Fn(x,[])
    9.71 -  | hol_type_to_fol (Res_Clause.Comp(tc,tps)) = Metis.Term.Fn(tc, map hol_type_to_fol tps);
    9.72 -
    9.73 -(*These two functions insert type literals before the real literals. That is the
    9.74 -  opposite order from TPTP linkup, but maybe OK.*)
    9.75 -
    9.76 -fun hol_term_to_fol_FO tm =
    9.77 -  case Res_HOL_Clause.strip_comb tm of
    9.78 -      (Res_HOL_Clause.CombConst(c,_,tys), tms) =>
    9.79 -        let val tyargs = map hol_type_to_fol tys
    9.80 -            val args   = map hol_term_to_fol_FO tms
    9.81 -        in Metis.Term.Fn (c, tyargs @ args) end
    9.82 -    | (Res_HOL_Clause.CombVar(v,_), []) => Metis.Term.Var v
    9.83 -    | _ => error "hol_term_to_fol_FO";
    9.84 -
    9.85 -fun hol_term_to_fol_HO (Res_HOL_Clause.CombVar (a, _)) = Metis.Term.Var a
    9.86 -  | hol_term_to_fol_HO (Res_HOL_Clause.CombConst (a, _, tylist)) =
    9.87 -      Metis.Term.Fn (fn_isa_to_met a, map hol_type_to_fol tylist)
    9.88 -  | hol_term_to_fol_HO (Res_HOL_Clause.CombApp (tm1, tm2)) =
    9.89 -       Metis.Term.Fn (".", map hol_term_to_fol_HO [tm1, tm2]);
    9.90 -
    9.91 -(*The fully-typed translation, to avoid type errors*)
    9.92 -fun wrap_type (tm, ty) = Metis.Term.Fn("ti", [tm, hol_type_to_fol ty]);
    9.93 -
    9.94 -fun hol_term_to_fol_FT (Res_HOL_Clause.CombVar(a, ty)) =
    9.95 -      wrap_type (Metis.Term.Var a, ty)
    9.96 -  | hol_term_to_fol_FT (Res_HOL_Clause.CombConst(a, ty, _)) =
    9.97 -      wrap_type (Metis.Term.Fn(fn_isa_to_met a, []), ty)
    9.98 -  | hol_term_to_fol_FT (tm as Res_HOL_Clause.CombApp(tm1,tm2)) =
    9.99 -       wrap_type (Metis.Term.Fn(".", map hol_term_to_fol_FT [tm1,tm2]),
   9.100 -                  Res_HOL_Clause.type_of_combterm tm);
   9.101 -
   9.102 -fun hol_literal_to_fol FO (Res_HOL_Clause.Literal (pol, tm)) =
   9.103 -      let val (Res_HOL_Clause.CombConst(p,_,tys), tms) = Res_HOL_Clause.strip_comb tm
   9.104 -          val tylits = if p = "equal" then [] else map hol_type_to_fol tys
   9.105 -          val lits = map hol_term_to_fol_FO tms
   9.106 -      in metis_lit pol (fn_isa_to_met p) (tylits @ lits) end
   9.107 -  | hol_literal_to_fol HO (Res_HOL_Clause.Literal (pol, tm)) =
   9.108 -     (case Res_HOL_Clause.strip_comb tm of
   9.109 -          (Res_HOL_Clause.CombConst("equal",_,_), tms) =>
   9.110 -            metis_lit pol "=" (map hol_term_to_fol_HO tms)
   9.111 -        | _ => metis_lit pol "{}" [hol_term_to_fol_HO tm])   (*hBOOL*)
   9.112 -  | hol_literal_to_fol FT (Res_HOL_Clause.Literal (pol, tm)) =
   9.113 -     (case Res_HOL_Clause.strip_comb tm of
   9.114 -          (Res_HOL_Clause.CombConst("equal",_,_), tms) =>
   9.115 -            metis_lit pol "=" (map hol_term_to_fol_FT tms)
   9.116 -        | _ => metis_lit pol "{}" [hol_term_to_fol_FT tm])   (*hBOOL*);
   9.117 -
   9.118 -fun literals_of_hol_thm thy mode t =
   9.119 -      let val (lits, types_sorts) = Res_HOL_Clause.literals_of_term thy t
   9.120 -      in  (map (hol_literal_to_fol mode) lits, types_sorts) end;
   9.121 -
   9.122 -(*Sign should be "true" for conjecture type constraints, "false" for type lits in clauses.*)
   9.123 -fun metis_of_typeLit pos (Res_Clause.LTVar (s,x))  = metis_lit pos s [Metis.Term.Var x]
   9.124 -  | metis_of_typeLit pos (Res_Clause.LTFree (s,x)) = metis_lit pos s [Metis.Term.Fn(x,[])];
   9.125 -
   9.126 -fun default_sort _ (TVar _) = false
   9.127 -  | default_sort ctxt (TFree (x, s)) = (s = the_default [] (Variable.def_sort ctxt (x, ~1)));
   9.128 -
   9.129 -fun metis_of_tfree tf =
   9.130 -  Metis.Thm.axiom (Metis.LiteralSet.singleton (metis_of_typeLit true tf));
   9.131 -
   9.132 -fun hol_thm_to_fol is_conjecture ctxt mode th =
   9.133 -  let val thy = ProofContext.theory_of ctxt
   9.134 -      val (mlits, types_sorts) =
   9.135 -             (literals_of_hol_thm thy mode o HOLogic.dest_Trueprop o prop_of) th
   9.136 -  in
   9.137 -      if is_conjecture then
   9.138 -          (Metis.Thm.axiom (Metis.LiteralSet.fromList mlits), Res_Clause.add_typs types_sorts)
   9.139 -      else
   9.140 -        let val tylits = Res_Clause.add_typs
   9.141 -                           (filter (not o default_sort ctxt) types_sorts)
   9.142 -            val mtylits = if Config.get ctxt type_lits
   9.143 -                          then map (metis_of_typeLit false) tylits else []
   9.144 -        in
   9.145 -          (Metis.Thm.axiom (Metis.LiteralSet.fromList(mtylits @ mlits)), [])
   9.146 -        end
   9.147 -  end;
   9.148 -
   9.149 -(* ARITY CLAUSE *)
   9.150 -
   9.151 -fun m_arity_cls (Res_Clause.TConsLit (c,t,args)) =
   9.152 -      metis_lit true (Res_Clause.make_type_class c) [Metis.Term.Fn(t, map Metis.Term.Var args)]
   9.153 -  | m_arity_cls (Res_Clause.TVarLit (c,str))     =
   9.154 -      metis_lit false (Res_Clause.make_type_class c) [Metis.Term.Var str];
   9.155 -
   9.156 -(*TrueI is returned as the Isabelle counterpart because there isn't any.*)
   9.157 -fun arity_cls (Res_Clause.ArityClause{conclLit,premLits,...}) =
   9.158 -  (TrueI,
   9.159 -   Metis.Thm.axiom (Metis.LiteralSet.fromList (map m_arity_cls (conclLit :: premLits))));
   9.160 -
   9.161 -(* CLASSREL CLAUSE *)
   9.162 -
   9.163 -fun m_classrel_cls subclass superclass =
   9.164 -  [metis_lit false subclass [Metis.Term.Var "T"], metis_lit true superclass [Metis.Term.Var "T"]];
   9.165 -
   9.166 -fun classrel_cls (Res_Clause.ClassrelClause {subclass, superclass, ...}) =
   9.167 -  (TrueI, Metis.Thm.axiom (Metis.LiteralSet.fromList (m_classrel_cls subclass superclass)));
   9.168 -
   9.169 -(* ------------------------------------------------------------------------- *)
   9.170 -(* FOL to HOL  (Metis to Isabelle)                                           *)
   9.171 -(* ------------------------------------------------------------------------- *)
   9.172 -
   9.173 -datatype term_or_type = Term of Term.term | Type of Term.typ;
   9.174 -
   9.175 -fun terms_of [] = []
   9.176 -  | terms_of (Term t :: tts) = t :: terms_of tts
   9.177 -  | terms_of (Type _ :: tts) = terms_of tts;
   9.178 -
   9.179 -fun types_of [] = []
   9.180 -  | types_of (Term (Term.Var ((a,idx), _)) :: tts) =
   9.181 -      if String.isPrefix "_" a then
   9.182 -          (*Variable generated by Metis, which might have been a type variable.*)
   9.183 -          TVar (("'" ^ a, idx), HOLogic.typeS) :: types_of tts
   9.184 -      else types_of tts
   9.185 -  | types_of (Term _ :: tts) = types_of tts
   9.186 -  | types_of (Type T :: tts) = T :: types_of tts;
   9.187 -
   9.188 -fun apply_list rator nargs rands =
   9.189 -  let val trands = terms_of rands
   9.190 -  in  if length trands = nargs then Term (list_comb(rator, trands))
   9.191 -      else error
   9.192 -        ("apply_list: wrong number of arguments: " ^ Syntax.string_of_term_global Pure.thy rator ^
   9.193 -          " expected " ^ Int.toString nargs ^
   9.194 -          " received " ^ commas (map (Syntax.string_of_term_global Pure.thy) trands))
   9.195 -  end;
   9.196 -
   9.197 -fun infer_types ctxt =
   9.198 -  Syntax.check_terms (ProofContext.set_mode ProofContext.mode_pattern ctxt);
   9.199 -
   9.200 -(*We use 1 rather than 0 because variable references in clauses may otherwise conflict
   9.201 -  with variable constraints in the goal...at least, type inference often fails otherwise.
   9.202 -  SEE ALSO axiom_inf below.*)
   9.203 -fun mk_var (w,T) = Term.Var((w,1), T);
   9.204 -
   9.205 -(*include the default sort, if available*)
   9.206 -fun mk_tfree ctxt w =
   9.207 -  let val ww = "'" ^ w
   9.208 -  in  TFree(ww, the_default HOLogic.typeS (Variable.def_sort ctxt (ww, ~1)))  end;
   9.209 -
   9.210 -(*Remove the "apply" operator from an HO term*)
   9.211 -fun strip_happ args (Metis.Term.Fn(".",[t,u])) = strip_happ (u::args) t
   9.212 -  | strip_happ args x = (x, args);
   9.213 -
   9.214 -fun fol_type_to_isa _ (Metis.Term.Var v) =
   9.215 -     (case Res_Reconstruct.strip_prefix Res_Clause.tvar_prefix v of
   9.216 -          SOME w => Res_Reconstruct.make_tvar w
   9.217 -        | NONE   => Res_Reconstruct.make_tvar v)
   9.218 -  | fol_type_to_isa ctxt (Metis.Term.Fn(x, tys)) =
   9.219 -     (case Res_Reconstruct.strip_prefix Res_Clause.tconst_prefix x of
   9.220 -          SOME tc => Term.Type (Res_Reconstruct.invert_type_const tc, map (fol_type_to_isa ctxt) tys)
   9.221 -        | NONE    =>
   9.222 -      case Res_Reconstruct.strip_prefix Res_Clause.tfree_prefix x of
   9.223 -          SOME tf => mk_tfree ctxt tf
   9.224 -        | NONE    => error ("fol_type_to_isa: " ^ x));
   9.225 -
   9.226 -(*Maps metis terms to isabelle terms*)
   9.227 -fun fol_term_to_hol_RAW ctxt fol_tm =
   9.228 -  let val thy = ProofContext.theory_of ctxt
   9.229 -      val _ = trace_msg (fn () => "fol_term_to_hol: " ^ Metis.Term.toString fol_tm)
   9.230 -      fun tm_to_tt (Metis.Term.Var v) =
   9.231 -             (case Res_Reconstruct.strip_prefix Res_Clause.tvar_prefix v of
   9.232 -                  SOME w => Type (Res_Reconstruct.make_tvar w)
   9.233 -                | NONE =>
   9.234 -              case Res_Reconstruct.strip_prefix Res_Clause.schematic_var_prefix v of
   9.235 -                  SOME w => Term (mk_var (w, HOLogic.typeT))
   9.236 -                | NONE   => Term (mk_var (v, HOLogic.typeT)) )
   9.237 -                    (*Var from Metis with a name like _nnn; possibly a type variable*)
   9.238 -        | tm_to_tt (Metis.Term.Fn ("{}", [arg])) = tm_to_tt arg   (*hBOOL*)
   9.239 -        | tm_to_tt (t as Metis.Term.Fn (".",_)) =
   9.240 -            let val (rator,rands) = strip_happ [] t
   9.241 -            in  case rator of
   9.242 -                    Metis.Term.Fn(fname,ts) => applic_to_tt (fname, ts @ rands)
   9.243 -                  | _ => case tm_to_tt rator of
   9.244 -                             Term t => Term (list_comb(t, terms_of (map tm_to_tt rands)))
   9.245 -                           | _ => error "tm_to_tt: HO application"
   9.246 -            end
   9.247 -        | tm_to_tt (Metis.Term.Fn (fname, args)) = applic_to_tt (fname,args)
   9.248 -      and applic_to_tt ("=",ts) =
   9.249 -            Term (list_comb(Const ("op =", HOLogic.typeT), terms_of (map tm_to_tt ts)))
   9.250 -        | applic_to_tt (a,ts) =
   9.251 -            case Res_Reconstruct.strip_prefix Res_Clause.const_prefix a of
   9.252 -                SOME b =>
   9.253 -                  let val c = Res_Reconstruct.invert_const b
   9.254 -                      val ntypes = Res_Reconstruct.num_typargs thy c
   9.255 -                      val nterms = length ts - ntypes
   9.256 -                      val tts = map tm_to_tt ts
   9.257 -                      val tys = types_of (List.take(tts,ntypes))
   9.258 -                      val ntyargs = Res_Reconstruct.num_typargs thy c
   9.259 -                  in if length tys = ntyargs then
   9.260 -                         apply_list (Const (c, dummyT)) nterms (List.drop(tts,ntypes))
   9.261 -                     else error ("Constant " ^ c ^ " expects " ^ Int.toString ntyargs ^
   9.262 -                                 " but gets " ^ Int.toString (length tys) ^
   9.263 -                                 " type arguments\n" ^
   9.264 -                                 cat_lines (map (Syntax.string_of_typ ctxt) tys) ^
   9.265 -                                 " the terms are \n" ^
   9.266 -                                 cat_lines (map (Syntax.string_of_term ctxt) (terms_of tts)))
   9.267 -                     end
   9.268 -              | NONE => (*Not a constant. Is it a type constructor?*)
   9.269 -            case Res_Reconstruct.strip_prefix Res_Clause.tconst_prefix a of
   9.270 -                SOME b =>
   9.271 -                  Type (Term.Type (Res_Reconstruct.invert_type_const b, types_of (map tm_to_tt ts)))
   9.272 -              | NONE => (*Maybe a TFree. Should then check that ts=[].*)
   9.273 -            case Res_Reconstruct.strip_prefix Res_Clause.tfree_prefix a of
   9.274 -                SOME b => Type (mk_tfree ctxt b)
   9.275 -              | NONE => (*a fixed variable? They are Skolem functions.*)
   9.276 -            case Res_Reconstruct.strip_prefix Res_Clause.fixed_var_prefix a of
   9.277 -                SOME b =>
   9.278 -                  let val opr = Term.Free(b, HOLogic.typeT)
   9.279 -                  in  apply_list opr (length ts) (map tm_to_tt ts)  end
   9.280 -              | NONE => error ("unexpected metis function: " ^ a)
   9.281 -  in  case tm_to_tt fol_tm of Term t => t | _ => error "fol_tm_to_tt: Term expected"  end;
   9.282 -
   9.283 -(*Maps fully-typed metis terms to isabelle terms*)
   9.284 -fun fol_term_to_hol_FT ctxt fol_tm =
   9.285 -  let val _ = trace_msg (fn () => "fol_term_to_hol_FT: " ^ Metis.Term.toString fol_tm)
   9.286 -      fun cvt (Metis.Term.Fn ("ti", [Metis.Term.Var v, _])) =
   9.287 -             (case Res_Reconstruct.strip_prefix Res_Clause.schematic_var_prefix v of
   9.288 -                  SOME w =>  mk_var(w, dummyT)
   9.289 -                | NONE   => mk_var(v, dummyT))
   9.290 -        | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn ("=",[]), _])) =
   9.291 -            Const ("op =", HOLogic.typeT)
   9.292 -        | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (x,[]), ty])) =
   9.293 -           (case Res_Reconstruct.strip_prefix Res_Clause.const_prefix x of
   9.294 -                SOME c => Const (Res_Reconstruct.invert_const c, dummyT)
   9.295 -              | NONE => (*Not a constant. Is it a fixed variable??*)
   9.296 -            case Res_Reconstruct.strip_prefix Res_Clause.fixed_var_prefix x of
   9.297 -                SOME v => Free (v, fol_type_to_isa ctxt ty)
   9.298 -              | NONE => error ("fol_term_to_hol_FT bad constant: " ^ x))
   9.299 -        | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (".",[tm1,tm2]), _])) =
   9.300 -            cvt tm1 $ cvt tm2
   9.301 -        | cvt (Metis.Term.Fn (".",[tm1,tm2])) = (*untyped application*)
   9.302 -            cvt tm1 $ cvt tm2
   9.303 -        | cvt (Metis.Term.Fn ("{}", [arg])) = cvt arg   (*hBOOL*)
   9.304 -        | cvt (Metis.Term.Fn ("=", [tm1,tm2])) =
   9.305 -            list_comb(Const ("op =", HOLogic.typeT), map cvt [tm1,tm2])
   9.306 -        | cvt (t as Metis.Term.Fn (x, [])) =
   9.307 -           (case Res_Reconstruct.strip_prefix Res_Clause.const_prefix x of
   9.308 -                SOME c => Const (Res_Reconstruct.invert_const c, dummyT)
   9.309 -              | NONE => (*Not a constant. Is it a fixed variable??*)
   9.310 -            case Res_Reconstruct.strip_prefix Res_Clause.fixed_var_prefix x of
   9.311 -                SOME v => Free (v, dummyT)
   9.312 -              | NONE => (trace_msg (fn () => "fol_term_to_hol_FT bad const: " ^ x);
   9.313 -                  fol_term_to_hol_RAW ctxt t))
   9.314 -        | cvt t = (trace_msg (fn () => "fol_term_to_hol_FT bad term: " ^ Metis.Term.toString t);
   9.315 -            fol_term_to_hol_RAW ctxt t)
   9.316 -  in  cvt fol_tm   end;
   9.317 -
   9.318 -fun fol_term_to_hol ctxt FO = fol_term_to_hol_RAW ctxt
   9.319 -  | fol_term_to_hol ctxt HO = fol_term_to_hol_RAW ctxt
   9.320 -  | fol_term_to_hol ctxt FT = fol_term_to_hol_FT ctxt;
   9.321 -
   9.322 -fun fol_terms_to_hol ctxt mode fol_tms =
   9.323 -  let val ts = map (fol_term_to_hol ctxt mode) fol_tms
   9.324 -      val _ = trace_msg (fn () => "  calling type inference:")
   9.325 -      val _ = app (fn t => trace_msg (fn () => Syntax.string_of_term ctxt t)) ts
   9.326 -      val ts' = infer_types ctxt ts;
   9.327 -      val _ = app (fn t => trace_msg
   9.328 -                    (fn () => "  final term: " ^ Syntax.string_of_term ctxt t ^
   9.329 -                              "  of type  " ^ Syntax.string_of_typ ctxt (type_of t)))
   9.330 -                  ts'
   9.331 -  in  ts'  end;
   9.332 -
   9.333 -fun mk_not (Const ("Not", _) $ b) = b
   9.334 -  | mk_not b = HOLogic.mk_not b;
   9.335 -
   9.336 -val metis_eq = Metis.Term.Fn ("=", []);
   9.337 -
   9.338 -(* ------------------------------------------------------------------------- *)
   9.339 -(* FOL step Inference Rules                                                  *)
   9.340 -(* ------------------------------------------------------------------------- *)
   9.341 -
   9.342 -(*for debugging only*)
   9.343 -fun print_thpair (fth,th) =
   9.344 -  (trace_msg (fn () => "=============================================");
   9.345 -   trace_msg (fn () => "Metis: " ^ Metis.Thm.toString fth);
   9.346 -   trace_msg (fn () => "Isabelle: " ^ Display.string_of_thm_without_context th));
   9.347 -
   9.348 -fun lookth thpairs (fth : Metis.Thm.thm) =
   9.349 -  the (AList.lookup (uncurry Metis.Thm.equal) thpairs fth)
   9.350 -  handle Option => error ("Failed to find a Metis theorem " ^ Metis.Thm.toString fth);
   9.351 -
   9.352 -fun is_TrueI th = Thm.eq_thm(TrueI,th);
   9.353 -
   9.354 -fun cterm_incr_types thy idx = cterm_of thy o (map_types (Logic.incr_tvar idx));
   9.355 -
   9.356 -fun inst_excluded_middle thy i_atm =
   9.357 -  let val th = EXCLUDED_MIDDLE
   9.358 -      val [vx] = Term.add_vars (prop_of th) []
   9.359 -      val substs = [(cterm_of thy (Var vx), cterm_of thy i_atm)]
   9.360 -  in  cterm_instantiate substs th  end;
   9.361 -
   9.362 -(* INFERENCE RULE: AXIOM *)
   9.363 -fun axiom_inf thpairs th = incr_indexes 1 (lookth thpairs th);
   9.364 -    (*This causes variables to have an index of 1 by default. SEE ALSO mk_var above.*)
   9.365 -
   9.366 -(* INFERENCE RULE: ASSUME *)
   9.367 -fun assume_inf ctxt mode atm =
   9.368 -  inst_excluded_middle
   9.369 -    (ProofContext.theory_of ctxt)
   9.370 -    (singleton (fol_terms_to_hol ctxt mode) (Metis.Term.Fn atm));
   9.371 -
   9.372 -(* INFERENCE RULE: INSTANTIATE (Subst). Type instantiations are ignored. Trying to reconstruct
   9.373 -   them admits new possibilities of errors, e.g. concerning sorts. Instead we try to arrange
   9.374 -   that new TVars are distinct and that types can be inferred from terms.*)
   9.375 -fun inst_inf ctxt mode thpairs fsubst th =
   9.376 -  let val thy = ProofContext.theory_of ctxt
   9.377 -      val i_th   = lookth thpairs th
   9.378 -      val i_th_vars = Term.add_vars (prop_of i_th) []
   9.379 -      fun find_var x = the (List.find (fn ((a,_),_) => a=x) i_th_vars)
   9.380 -      fun subst_translation (x,y) =
   9.381 -            let val v = find_var x
   9.382 -                val t = fol_term_to_hol ctxt mode y (*we call infer_types below*)
   9.383 -            in  SOME (cterm_of thy (Var v), t)  end
   9.384 -            handle Option =>
   9.385 -                (trace_msg (fn() => "List.find failed for the variable " ^ x ^
   9.386 -                                       " in " ^ Display.string_of_thm ctxt i_th);
   9.387 -                 NONE)
   9.388 -      fun remove_typeinst (a, t) =
   9.389 -            case Res_Reconstruct.strip_prefix Res_Clause.schematic_var_prefix a of
   9.390 -                SOME b => SOME (b, t)
   9.391 -              | NONE   => case Res_Reconstruct.strip_prefix Res_Clause.tvar_prefix a of
   9.392 -                SOME _ => NONE          (*type instantiations are forbidden!*)
   9.393 -              | NONE   => SOME (a,t)    (*internal Metis var?*)
   9.394 -      val _ = trace_msg (fn () => "  isa th: " ^ Display.string_of_thm ctxt i_th)
   9.395 -      val substs = map_filter remove_typeinst (Metis.Subst.toList fsubst)
   9.396 -      val (vars,rawtms) = ListPair.unzip (map_filter subst_translation substs)
   9.397 -      val tms = infer_types ctxt rawtms;
   9.398 -      val ctm_of = cterm_incr_types thy (1 + Thm.maxidx_of i_th)
   9.399 -      val substs' = ListPair.zip (vars, map ctm_of tms)
   9.400 -      val _ = trace_msg (fn () =>
   9.401 -        cat_lines ("subst_translations:" ::
   9.402 -          (substs' |> map (fn (x, y) =>
   9.403 -            Syntax.string_of_term ctxt (term_of x) ^ " |-> " ^
   9.404 -            Syntax.string_of_term ctxt (term_of y)))));
   9.405 -  in  cterm_instantiate substs' i_th
   9.406 -      handle THM (msg, _, _) => error ("metis error (inst_inf): " ^ msg)
   9.407 -  end;
   9.408 -
   9.409 -(* INFERENCE RULE: RESOLVE *)
   9.410 -
   9.411 -(*Like RSN, but we rename apart only the type variables. Vars here typically have an index
   9.412 -  of 1, and the use of RSN would increase this typically to 3. Instantiations of those Vars
   9.413 -  could then fail. See comment on mk_var.*)
   9.414 -fun resolve_inc_tyvars(tha,i,thb) =
   9.415 -  let val tha = Drule.incr_type_indexes (1 + Thm.maxidx_of thb) tha
   9.416 -      val ths = Seq.list_of (Thm.bicompose false (false,tha,nprems_of tha) i thb)
   9.417 -  in
   9.418 -      case distinct Thm.eq_thm ths of
   9.419 -        [th] => th
   9.420 -      | _ => raise THM ("resolve_inc_tyvars: unique result expected", i, [tha,thb])
   9.421 -  end;
   9.422 -
   9.423 -fun resolve_inf ctxt mode thpairs atm th1 th2 =
   9.424 -  let
   9.425 -    val i_th1 = lookth thpairs th1 and i_th2 = lookth thpairs th2
   9.426 -    val _ = trace_msg (fn () => "  isa th1 (pos): " ^ Display.string_of_thm ctxt i_th1)
   9.427 -    val _ = trace_msg (fn () => "  isa th2 (neg): " ^ Display.string_of_thm ctxt i_th2)
   9.428 -  in
   9.429 -    if is_TrueI i_th1 then i_th2 (*Trivial cases where one operand is type info*)
   9.430 -    else if is_TrueI i_th2 then i_th1
   9.431 -    else
   9.432 -      let
   9.433 -        val i_atm = singleton (fol_terms_to_hol ctxt mode) (Metis.Term.Fn atm)
   9.434 -        val _ = trace_msg (fn () => "  atom: " ^ Syntax.string_of_term ctxt i_atm)
   9.435 -        val prems_th1 = prems_of i_th1
   9.436 -        val prems_th2 = prems_of i_th2
   9.437 -        val index_th1 = get_index (mk_not i_atm) prems_th1
   9.438 -              handle Empty => error "Failed to find literal in th1"
   9.439 -        val _ = trace_msg (fn () => "  index_th1: " ^ Int.toString index_th1)
   9.440 -        val index_th2 = get_index i_atm prems_th2
   9.441 -              handle Empty => error "Failed to find literal in th2"
   9.442 -        val _ = trace_msg (fn () => "  index_th2: " ^ Int.toString index_th2)
   9.443 -    in  resolve_inc_tyvars (Meson.select_literal index_th1 i_th1, index_th2, i_th2)  end
   9.444 -  end;
   9.445 -
   9.446 -(* INFERENCE RULE: REFL *)
   9.447 -val refl_x = cterm_of @{theory} (Var (hd (Term.add_vars (prop_of REFL_THM) [])));
   9.448 -val refl_idx = 1 + Thm.maxidx_of REFL_THM;
   9.449 -
   9.450 -fun refl_inf ctxt mode t =
   9.451 -  let val thy = ProofContext.theory_of ctxt
   9.452 -      val i_t = singleton (fol_terms_to_hol ctxt mode) t
   9.453 -      val _ = trace_msg (fn () => "  term: " ^ Syntax.string_of_term ctxt i_t)
   9.454 -      val c_t = cterm_incr_types thy refl_idx i_t
   9.455 -  in  cterm_instantiate [(refl_x, c_t)] REFL_THM  end;
   9.456 -
   9.457 -fun get_ty_arg_size _ (Const ("op =", _)) = 0  (*equality has no type arguments*)
   9.458 -  | get_ty_arg_size thy (Const (c, _)) = (Res_Reconstruct.num_typargs thy c handle TYPE _ => 0)
   9.459 -  | get_ty_arg_size _ _ = 0;
   9.460 -
   9.461 -(* INFERENCE RULE: EQUALITY *)
   9.462 -fun equality_inf ctxt mode (pos, atm) fp fr =
   9.463 -  let val thy = ProofContext.theory_of ctxt
   9.464 -      val m_tm = Metis.Term.Fn atm
   9.465 -      val [i_atm,i_tm] = fol_terms_to_hol ctxt mode [m_tm, fr]
   9.466 -      val _ = trace_msg (fn () => "sign of the literal: " ^ Bool.toString pos)
   9.467 -      fun replace_item_list lx 0 (_::ls) = lx::ls
   9.468 -        | replace_item_list lx i (l::ls) = l :: replace_item_list lx (i-1) ls
   9.469 -      fun path_finder_FO tm [] = (tm, Term.Bound 0)
   9.470 -        | path_finder_FO tm (p::ps) =
   9.471 -            let val (tm1,args) = Term.strip_comb tm
   9.472 -                val adjustment = get_ty_arg_size thy tm1
   9.473 -                val p' = if adjustment > p then p else p-adjustment
   9.474 -                val tm_p = List.nth(args,p')
   9.475 -                  handle Subscript => error ("equality_inf: " ^ Int.toString p ^ " adj " ^
   9.476 -                    Int.toString adjustment  ^ " term " ^  Syntax.string_of_term ctxt tm)
   9.477 -                val _ = trace_msg (fn () => "path_finder: " ^ Int.toString p ^
   9.478 -                                      "  " ^ Syntax.string_of_term ctxt tm_p)
   9.479 -                val (r,t) = path_finder_FO tm_p ps
   9.480 -            in
   9.481 -                (r, list_comb (tm1, replace_item_list t p' args))
   9.482 -            end
   9.483 -      fun path_finder_HO tm [] = (tm, Term.Bound 0)
   9.484 -        | path_finder_HO (t$u) (0::ps) = (fn(x,y) => (x, y$u)) (path_finder_HO t ps)
   9.485 -        | path_finder_HO (t$u) (_::ps) = (fn(x,y) => (x, t$y)) (path_finder_HO u ps)
   9.486 -      fun path_finder_FT tm [] _ = (tm, Term.Bound 0)
   9.487 -        | path_finder_FT tm (0::ps) (Metis.Term.Fn ("ti", [t1, _])) =
   9.488 -            path_finder_FT tm ps t1
   9.489 -        | path_finder_FT (t$u) (0::ps) (Metis.Term.Fn (".", [t1, _])) =
   9.490 -            (fn(x,y) => (x, y$u)) (path_finder_FT t ps t1)
   9.491 -        | path_finder_FT (t$u) (1::ps) (Metis.Term.Fn (".", [_, t2])) =
   9.492 -            (fn(x,y) => (x, t$y)) (path_finder_FT u ps t2)
   9.493 -        | path_finder_FT tm ps t = error ("equality_inf, path_finder_FT: path = " ^
   9.494 -                                        space_implode " " (map Int.toString ps) ^
   9.495 -                                        " isa-term: " ^  Syntax.string_of_term ctxt tm ^
   9.496 -                                        " fol-term: " ^ Metis.Term.toString t)
   9.497 -      fun path_finder FO tm ps _ = path_finder_FO tm ps
   9.498 -        | path_finder HO (tm as Const("op =",_) $ _ $ _) (p::ps) _ =
   9.499 -             (*equality: not curried, as other predicates are*)
   9.500 -             if p=0 then path_finder_HO tm (0::1::ps)  (*select first operand*)
   9.501 -             else path_finder_HO tm (p::ps)        (*1 selects second operand*)
   9.502 -        | path_finder HO tm (_ :: ps) (Metis.Term.Fn ("{}", [_])) =
   9.503 -             path_finder_HO tm ps      (*if not equality, ignore head to skip hBOOL*)
   9.504 -        | path_finder FT (tm as Const("op =",_) $ _ $ _) (p::ps)
   9.505 -                            (Metis.Term.Fn ("=", [t1,t2])) =
   9.506 -             (*equality: not curried, as other predicates are*)
   9.507 -             if p=0 then path_finder_FT tm (0::1::ps)
   9.508 -                          (Metis.Term.Fn (".", [Metis.Term.Fn (".", [metis_eq,t1]), t2]))
   9.509 -                          (*select first operand*)
   9.510 -             else path_finder_FT tm (p::ps)
   9.511 -                   (Metis.Term.Fn (".", [metis_eq,t2]))
   9.512 -                   (*1 selects second operand*)
   9.513 -        | path_finder FT tm (_ :: ps) (Metis.Term.Fn ("{}", [t1])) = path_finder_FT tm ps t1
   9.514 -             (*if not equality, ignore head to skip the hBOOL predicate*)
   9.515 -        | path_finder FT tm ps t = path_finder_FT tm ps t  (*really an error case!*)
   9.516 -      fun path_finder_lit ((nt as Term.Const ("Not", _)) $ tm_a) idx =
   9.517 -            let val (tm, tm_rslt) = path_finder mode tm_a idx m_tm
   9.518 -            in (tm, nt $ tm_rslt) end
   9.519 -        | path_finder_lit tm_a idx = path_finder mode tm_a idx m_tm
   9.520 -      val (tm_subst, body) = path_finder_lit i_atm fp
   9.521 -      val tm_abs = Term.Abs("x", Term.type_of tm_subst, body)
   9.522 -      val _ = trace_msg (fn () => "abstraction: " ^ Syntax.string_of_term ctxt tm_abs)
   9.523 -      val _ = trace_msg (fn () => "i_tm: " ^ Syntax.string_of_term ctxt i_tm)
   9.524 -      val _ = trace_msg (fn () => "located term: " ^ Syntax.string_of_term ctxt tm_subst)
   9.525 -      val imax = maxidx_of_term (i_tm $ tm_abs $ tm_subst)  (*ill typed but gives right max*)
   9.526 -      val subst' = incr_indexes (imax+1) (if pos then subst_em else ssubst_em)
   9.527 -      val _ = trace_msg (fn () => "subst' " ^ Display.string_of_thm ctxt subst')
   9.528 -      val eq_terms = map (pairself (cterm_of thy))
   9.529 -        (ListPair.zip (OldTerm.term_vars (prop_of subst'), [tm_abs, tm_subst, i_tm]))
   9.530 -  in  cterm_instantiate eq_terms subst'  end;
   9.531 -
   9.532 -val factor = Seq.hd o distinct_subgoals_tac;
   9.533 -
   9.534 -fun step _ _ thpairs (fol_th, Metis.Proof.Axiom _) = factor (axiom_inf thpairs fol_th)
   9.535 -  | step ctxt mode _ (_, Metis.Proof.Assume f_atm) = assume_inf ctxt mode f_atm
   9.536 -  | step ctxt mode thpairs (_, Metis.Proof.Subst (f_subst, f_th1)) =
   9.537 -      factor (inst_inf ctxt mode thpairs f_subst f_th1)
   9.538 -  | step ctxt mode thpairs (_, Metis.Proof.Resolve(f_atm, f_th1, f_th2)) =
   9.539 -      factor (resolve_inf ctxt mode thpairs f_atm f_th1 f_th2)
   9.540 -  | step ctxt mode _ (_, Metis.Proof.Refl f_tm) = refl_inf ctxt mode f_tm
   9.541 -  | step ctxt mode _ (_, Metis.Proof.Equality (f_lit, f_p, f_r)) =
   9.542 -      equality_inf ctxt mode f_lit f_p f_r;
   9.543 -
   9.544 -fun real_literal (_, (c, _)) = not (String.isPrefix Res_Clause.class_prefix c);
   9.545 -
   9.546 -fun translate _ _ thpairs [] = thpairs
   9.547 -  | translate mode ctxt thpairs ((fol_th, inf) :: infpairs) =
   9.548 -      let val _ = trace_msg (fn () => "=============================================")
   9.549 -          val _ = trace_msg (fn () => "METIS THM: " ^ Metis.Thm.toString fol_th)
   9.550 -          val _ = trace_msg (fn () => "INFERENCE: " ^ Metis.Proof.inferenceToString inf)
   9.551 -          val th = Meson.flexflex_first_order (step ctxt mode thpairs (fol_th, inf))
   9.552 -          val _ = trace_msg (fn () => "ISABELLE THM: " ^ Display.string_of_thm ctxt th)
   9.553 -          val _ = trace_msg (fn () => "=============================================")
   9.554 -          val n_metis_lits =
   9.555 -            length (filter real_literal (Metis.LiteralSet.toList (Metis.Thm.clause fol_th)))
   9.556 -      in
   9.557 -          if nprems_of th = n_metis_lits then ()
   9.558 -          else error "Metis: proof reconstruction has gone wrong";
   9.559 -          translate mode ctxt ((fol_th, th) :: thpairs) infpairs
   9.560 -      end;
   9.561 -
   9.562 -(*Determining which axiom clauses are actually used*)
   9.563 -fun used_axioms axioms (th, Metis.Proof.Axiom _) = SOME (lookth axioms th)
   9.564 -  | used_axioms _ _ = NONE;
   9.565 -
   9.566 -(* ------------------------------------------------------------------------- *)
   9.567 -(* Translation of HO Clauses                                                 *)
   9.568 -(* ------------------------------------------------------------------------- *)
   9.569 -
   9.570 -fun cnf_th thy th = hd (Res_Axioms.cnf_axiom thy th);
   9.571 -
   9.572 -val equal_imp_fequal' = cnf_th @{theory} @{thm equal_imp_fequal};
   9.573 -val fequal_imp_equal' = cnf_th @{theory} @{thm fequal_imp_equal};
   9.574 -
   9.575 -val comb_I = cnf_th @{theory} Res_HOL_Clause.comb_I;
   9.576 -val comb_K = cnf_th @{theory} Res_HOL_Clause.comb_K;
   9.577 -val comb_B = cnf_th @{theory} Res_HOL_Clause.comb_B;
   9.578 -val comb_C = cnf_th @{theory} Res_HOL_Clause.comb_C;
   9.579 -val comb_S = cnf_th @{theory} Res_HOL_Clause.comb_S;
   9.580 -
   9.581 -fun type_ext thy tms =
   9.582 -  let val subs = Res_ATP.tfree_classes_of_terms tms
   9.583 -      val supers = Res_ATP.tvar_classes_of_terms tms
   9.584 -      and tycons = Res_ATP.type_consts_of_terms thy tms
   9.585 -      val (supers', arity_clauses) = Res_Clause.make_arity_clauses thy tycons supers
   9.586 -      val classrel_clauses = Res_Clause.make_classrel_clauses thy subs supers'
   9.587 -  in  map classrel_cls classrel_clauses @ map arity_cls arity_clauses
   9.588 -  end;
   9.589 -
   9.590 -(* ------------------------------------------------------------------------- *)
   9.591 -(* Logic maps manage the interface between HOL and first-order logic.        *)
   9.592 -(* ------------------------------------------------------------------------- *)
   9.593 -
   9.594 -type logic_map =
   9.595 -  {axioms : (Metis.Thm.thm * thm) list,
   9.596 -   tfrees : Res_Clause.type_literal list};
   9.597 -
   9.598 -fun const_in_metis c (pred, tm_list) =
   9.599 -  let
   9.600 -    fun in_mterm (Metis.Term.Var _) = false
   9.601 -      | in_mterm (Metis.Term.Fn (".", tm_list)) = exists in_mterm tm_list
   9.602 -      | in_mterm (Metis.Term.Fn (nm, tm_list)) = c=nm orelse exists in_mterm tm_list
   9.603 -  in  c = pred orelse exists in_mterm tm_list  end;
   9.604 -
   9.605 -(*Extract TFree constraints from context to include as conjecture clauses*)
   9.606 -fun init_tfrees ctxt =
   9.607 -  let fun add ((a,i),s) Ts = if i = ~1 then TFree(a,s) :: Ts else Ts
   9.608 -  in  Res_Clause.add_typs (Vartab.fold add (#2 (Variable.constraints_of ctxt)) []) end;
   9.609 -
   9.610 -(*transform isabelle type / arity clause to metis clause *)
   9.611 -fun add_type_thm [] lmap = lmap
   9.612 -  | add_type_thm ((ith, mth) :: cls) {axioms, tfrees} =
   9.613 -      add_type_thm cls {axioms = (mth, ith) :: axioms,
   9.614 -                        tfrees = tfrees}
   9.615 -
   9.616 -(*Insert non-logical axioms corresponding to all accumulated TFrees*)
   9.617 -fun add_tfrees {axioms, tfrees} : logic_map =
   9.618 -     {axioms = (map (fn tf => (metis_of_tfree tf, TrueI)) (distinct op= tfrees)) @ axioms,
   9.619 -      tfrees = tfrees};
   9.620 -
   9.621 -fun string_of_mode FO = "FO"
   9.622 -  | string_of_mode HO = "HO"
   9.623 -  | string_of_mode FT = "FT"
   9.624 -
   9.625 -(* Function to generate metis clauses, including comb and type clauses *)
   9.626 -fun build_map mode0 ctxt cls ths =
   9.627 -  let val thy = ProofContext.theory_of ctxt
   9.628 -      (*The modes FO and FT are sticky. HO can be downgraded to FO.*)
   9.629 -      fun set_mode FO = FO
   9.630 -        | set_mode HO = if forall (Meson.is_fol_term thy o prop_of) (cls@ths) then FO else HO
   9.631 -        | set_mode FT = FT
   9.632 -      val mode = set_mode mode0
   9.633 -      (*transform isabelle clause to metis clause *)
   9.634 -      fun add_thm is_conjecture ith {axioms, tfrees} : logic_map =
   9.635 -        let val (mth, tfree_lits) = hol_thm_to_fol is_conjecture ctxt mode ith
   9.636 -        in
   9.637 -           {axioms = (mth, Meson.make_meta_clause ith) :: axioms,
   9.638 -            tfrees = union (op =) tfree_lits tfrees}
   9.639 -        end;
   9.640 -      val lmap0 = fold (add_thm true) cls {axioms = [], tfrees = init_tfrees ctxt}
   9.641 -      val lmap = fold (add_thm false) ths (add_tfrees lmap0)
   9.642 -      val clause_lists = map (Metis.Thm.clause o #1) (#axioms lmap)
   9.643 -      fun used c = exists (Metis.LiteralSet.exists (const_in_metis c o #2)) clause_lists
   9.644 -      (*Now check for the existence of certain combinators*)
   9.645 -      val thI  = if used "c_COMBI" then [comb_I] else []
   9.646 -      val thK  = if used "c_COMBK" then [comb_K] else []
   9.647 -      val thB   = if used "c_COMBB" then [comb_B] else []
   9.648 -      val thC   = if used "c_COMBC" then [comb_C] else []
   9.649 -      val thS   = if used "c_COMBS" then [comb_S] else []
   9.650 -      val thEQ  = if used "c_fequal" then [fequal_imp_equal', equal_imp_fequal'] else []
   9.651 -      val lmap' = if mode=FO then lmap
   9.652 -                  else fold (add_thm false) (thEQ @ thS @ thC @ thB @ thK @ thI) lmap
   9.653 -  in
   9.654 -      (mode, add_type_thm (type_ext thy (map prop_of (cls @ ths))) lmap')
   9.655 -  end;
   9.656 -
   9.657 -fun refute cls =
   9.658 -    Metis.Resolution.loop (Metis.Resolution.new Metis.Resolution.default cls);
   9.659 -
   9.660 -fun is_false t = t aconv (HOLogic.mk_Trueprop HOLogic.false_const);
   9.661 -
   9.662 -fun common_thm ths1 ths2 = exists (member Thm.eq_thm ths1) (map Meson.make_meta_clause ths2);
   9.663 -
   9.664 -exception METIS of string;
   9.665 -
   9.666 -(* Main function to start metis prove and reconstruction *)
   9.667 -fun FOL_SOLVE mode ctxt cls ths0 =
   9.668 -  let val thy = ProofContext.theory_of ctxt
   9.669 -      val th_cls_pairs = map (fn th => (Thm.get_name_hint th, Res_Axioms.cnf_axiom thy th)) ths0
   9.670 -      val ths = maps #2 th_cls_pairs
   9.671 -      val _ = trace_msg (fn () => "FOL_SOLVE: CONJECTURE CLAUSES")
   9.672 -      val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) cls
   9.673 -      val _ = trace_msg (fn () => "THEOREM CLAUSES")
   9.674 -      val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) ths
   9.675 -      val (mode, {axioms,tfrees}) = build_map mode ctxt cls ths
   9.676 -      val _ = if null tfrees then ()
   9.677 -              else (trace_msg (fn () => "TFREE CLAUSES");
   9.678 -                    app (fn tf => trace_msg (fn _ => Res_Clause.tptp_of_typeLit true tf)) tfrees)
   9.679 -      val _ = trace_msg (fn () => "CLAUSES GIVEN TO METIS")
   9.680 -      val thms = map #1 axioms
   9.681 -      val _ = app (fn th => trace_msg (fn () => Metis.Thm.toString th)) thms
   9.682 -      val _ = trace_msg (fn () => "mode = " ^ string_of_mode mode)
   9.683 -      val _ = trace_msg (fn () => "START METIS PROVE PROCESS")
   9.684 -  in
   9.685 -      case filter (is_false o prop_of) cls of
   9.686 -          false_th::_ => [false_th RS @{thm FalseE}]
   9.687 -        | [] =>
   9.688 -      case refute thms of
   9.689 -          Metis.Resolution.Contradiction mth =>
   9.690 -            let val _ = trace_msg (fn () => "METIS RECONSTRUCTION START: " ^
   9.691 -                          Metis.Thm.toString mth)
   9.692 -                val ctxt' = fold Variable.declare_constraints (map prop_of cls) ctxt
   9.693 -                             (*add constraints arising from converting goal to clause form*)
   9.694 -                val proof = Metis.Proof.proof mth
   9.695 -                val result = translate mode ctxt' axioms proof
   9.696 -                and used = map_filter (used_axioms axioms) proof
   9.697 -                val _ = trace_msg (fn () => "METIS COMPLETED...clauses actually used:")
   9.698 -                val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) used
   9.699 -                val unused = th_cls_pairs |> map_filter (fn (name, cls) =>
   9.700 -                  if common_thm used cls then NONE else SOME name)
   9.701 -            in
   9.702 -                if null unused then ()
   9.703 -                else warning ("Metis: unused theorems " ^ commas_quote unused);
   9.704 -                case result of
   9.705 -                    (_,ith)::_ =>
   9.706 -                        (trace_msg (fn () => "success: " ^ Display.string_of_thm ctxt ith);
   9.707 -                         [ith])
   9.708 -                  | _ => (trace_msg (fn () => "Metis: no result");
   9.709 -                          [])
   9.710 -            end
   9.711 -        | Metis.Resolution.Satisfiable _ =>
   9.712 -            (trace_msg (fn () => "Metis: No first-order proof with the lemmas supplied");
   9.713 -             [])
   9.714 -  end;
   9.715 -
   9.716 -fun metis_general_tac mode ctxt ths i st0 =
   9.717 -  let val _ = trace_msg (fn () =>
   9.718 -        "Metis called with theorems " ^ cat_lines (map (Display.string_of_thm ctxt) ths))
   9.719 -  in
   9.720 -    if exists_type Res_Axioms.type_has_topsort (prop_of st0)
   9.721 -    then raise METIS "Metis: Proof state contains the universal sort {}"
   9.722 -    else
   9.723 -      (Meson.MESON Res_Axioms.neg_clausify
   9.724 -        (fn cls => resolve_tac (FOL_SOLVE mode ctxt cls ths) 1) ctxt i
   9.725 -          THEN Res_Axioms.expand_defs_tac st0) st0
   9.726 -  end
   9.727 -  handle METIS s => (warning ("Metis: " ^ s); Seq.empty);
   9.728 -
   9.729 -val metis_tac = metis_general_tac HO;
   9.730 -val metisF_tac = metis_general_tac FO;
   9.731 -val metisFT_tac = metis_general_tac FT;
   9.732 -
   9.733 -fun method name mode comment = Method.setup name (Attrib.thms >> (fn ths => fn ctxt =>
   9.734 -  SIMPLE_METHOD' (CHANGED_PROP o metis_general_tac mode ctxt ths))) comment;
   9.735 -
   9.736 -val setup =
   9.737 -  type_lits_setup #>
   9.738 -  method @{binding metis} HO "METIS for FOL & HOL problems" #>
   9.739 -  method @{binding metisF} FO "METIS for FOL problems" #>
   9.740 -  method @{binding metisFT} FT "METIS with fully-typed translation" #>
   9.741 -  Method.setup @{binding finish_clausify}
   9.742 -    (Scan.succeed (K (SIMPLE_METHOD (Res_Axioms.expand_defs_tac refl))))
   9.743 -    "cleanup after conversion to clauses";
   9.744 -
   9.745 -end;
    10.1 --- a/src/HOL/Tools/res_atp.ML	Wed Mar 17 17:23:45 2010 +0100
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,559 +0,0 @@
    10.4 -(*  Title:      HOL/Tools/res_atp.ML
    10.5 -    Author:     Jia Meng, Cambridge University Computer Laboratory, NICTA
    10.6 -*)
    10.7 -
    10.8 -signature RES_ATP =
    10.9 -sig
   10.10 -  datatype mode = Auto | Fol | Hol
   10.11 -  val tvar_classes_of_terms : term list -> string list
   10.12 -  val tfree_classes_of_terms : term list -> string list
   10.13 -  val type_consts_of_terms : theory -> term list -> string list
   10.14 -  val get_relevant : int -> bool -> Proof.context * (thm list * 'a) -> thm list ->
   10.15 -    (thm * (string * int)) list
   10.16 -  val prepare_clauses : bool -> thm list -> thm list ->
   10.17 -    (thm * (Res_HOL_Clause.axiom_name * Res_HOL_Clause.clause_id)) list ->
   10.18 -    (thm * (Res_HOL_Clause.axiom_name * Res_HOL_Clause.clause_id)) list -> theory ->
   10.19 -    Res_HOL_Clause.axiom_name vector *
   10.20 -      (Res_HOL_Clause.clause list * Res_HOL_Clause.clause list * Res_HOL_Clause.clause list *
   10.21 -      Res_HOL_Clause.clause list * Res_Clause.classrelClause list * Res_Clause.arityClause list)
   10.22 -end;
   10.23 -
   10.24 -structure Res_ATP: RES_ATP =
   10.25 -struct
   10.26 -
   10.27 -
   10.28 -(********************************************************************)
   10.29 -(* some settings for both background automatic ATP calling procedure*)
   10.30 -(* and also explicit ATP invocation methods                         *)
   10.31 -(********************************************************************)
   10.32 -
   10.33 -(*Translation mode can be auto-detected, or forced to be first-order or higher-order*)
   10.34 -datatype mode = Auto | Fol | Hol;
   10.35 -
   10.36 -val linkup_logic_mode = Auto;
   10.37 -
   10.38 -(*** background linkup ***)
   10.39 -val run_blacklist_filter = true;
   10.40 -
   10.41 -(*** relevance filter parameters ***)
   10.42 -val run_relevance_filter = true;
   10.43 -val pass_mark = 0.5;
   10.44 -val convergence = 3.2;    (*Higher numbers allow longer inference chains*)
   10.45 -val follow_defs = false;  (*Follow definitions. Makes problems bigger.*)
   10.46 -  
   10.47 -(***************************************************************)
   10.48 -(* Relevance Filtering                                         *)
   10.49 -(***************************************************************)
   10.50 -
   10.51 -fun strip_Trueprop (Const("Trueprop",_) $ t) = t
   10.52 -  | strip_Trueprop t = t;
   10.53 -
   10.54 -(*A surprising number of theorems contain only a few significant constants.
   10.55 -  These include all induction rules, and other general theorems. Filtering
   10.56 -  theorems in clause form reveals these complexities in the form of Skolem 
   10.57 -  functions. If we were instead to filter theorems in their natural form,
   10.58 -  some other method of measuring theorem complexity would become necessary.*)
   10.59 -
   10.60 -fun log_weight2 (x:real) = 1.0 + 2.0/Math.ln (x+1.0);
   10.61 -
   10.62 -(*The default seems best in practice. A constant function of one ignores
   10.63 -  the constant frequencies.*)
   10.64 -val weight_fn = log_weight2;
   10.65 -
   10.66 -
   10.67 -(*Including equality in this list might be expected to stop rules like subset_antisym from
   10.68 -  being chosen, but for some reason filtering works better with them listed. The
   10.69 -  logical signs All, Ex, &, and --> are omitted because any remaining occurrrences
   10.70 -  must be within comprehensions.*)
   10.71 -val standard_consts = ["Trueprop","==>","all","==","op |","Not","op ="];
   10.72 -
   10.73 -
   10.74 -(*** constants with types ***)
   10.75 -
   10.76 -(*An abstraction of Isabelle types*)
   10.77 -datatype const_typ =  CTVar | CType of string * const_typ list
   10.78 -
   10.79 -(*Is the second type an instance of the first one?*)
   10.80 -fun match_type (CType(con1,args1)) (CType(con2,args2)) = 
   10.81 -      con1=con2 andalso match_types args1 args2
   10.82 -  | match_type CTVar _ = true
   10.83 -  | match_type _ CTVar = false
   10.84 -and match_types [] [] = true
   10.85 -  | match_types (a1::as1) (a2::as2) = match_type a1 a2 andalso match_types as1 as2;
   10.86 -
   10.87 -(*Is there a unifiable constant?*)
   10.88 -fun uni_mem gctab (c,c_typ) =
   10.89 -  case Symtab.lookup gctab c of
   10.90 -      NONE => false
   10.91 -    | SOME ctyps_list => exists (match_types c_typ) ctyps_list;
   10.92 -  
   10.93 -(*Maps a "real" type to a const_typ*)
   10.94 -fun const_typ_of (Type (c,typs)) = CType (c, map const_typ_of typs) 
   10.95 -  | const_typ_of (TFree _) = CTVar
   10.96 -  | const_typ_of (TVar _) = CTVar
   10.97 -
   10.98 -(*Pairs a constant with the list of its type instantiations (using const_typ)*)
   10.99 -fun const_with_typ thy (c,typ) = 
  10.100 -    let val tvars = Sign.const_typargs thy (c,typ)
  10.101 -    in (c, map const_typ_of tvars) end
  10.102 -    handle TYPE _ => (c,[]);   (*Variable (locale constant): monomorphic*)   
  10.103 -
  10.104 -(*Add a const/type pair to the table, but a [] entry means a standard connective,
  10.105 -  which we ignore.*)
  10.106 -fun add_const_typ_table ((c,ctyps), tab) =
  10.107 -  Symtab.map_default (c, [ctyps]) (fn [] => [] | ctyps_list => insert (op =) ctyps ctyps_list) 
  10.108 -    tab;
  10.109 -
  10.110 -(*Free variables are included, as well as constants, to handle locales*)
  10.111 -fun add_term_consts_typs_rm thy (Const(c, typ), tab) =
  10.112 -      add_const_typ_table (const_with_typ thy (c,typ), tab) 
  10.113 -  | add_term_consts_typs_rm thy (Free(c, typ), tab) =
  10.114 -      add_const_typ_table (const_with_typ thy (c,typ), tab) 
  10.115 -  | add_term_consts_typs_rm thy (t $ u, tab) =
  10.116 -      add_term_consts_typs_rm thy (t, add_term_consts_typs_rm thy (u, tab))
  10.117 -  | add_term_consts_typs_rm thy (Abs(_,_,t), tab) = add_term_consts_typs_rm thy (t, tab)
  10.118 -  | add_term_consts_typs_rm _ (_, tab) = tab;
  10.119 -
  10.120 -(*The empty list here indicates that the constant is being ignored*)
  10.121 -fun add_standard_const (s,tab) = Symtab.update (s,[]) tab;
  10.122 -
  10.123 -val null_const_tab : const_typ list list Symtab.table = 
  10.124 -    List.foldl add_standard_const Symtab.empty standard_consts;
  10.125 -
  10.126 -fun get_goal_consts_typs thy = List.foldl (add_term_consts_typs_rm thy) null_const_tab;
  10.127 -
  10.128 -(*Inserts a dummy "constant" referring to the theory name, so that relevance
  10.129 -  takes the given theory into account.*)
  10.130 -fun const_prop_of theory_const th =
  10.131 - if theory_const then
  10.132 -  let val name = Context.theory_name (theory_of_thm th)
  10.133 -      val t = Const (name ^ ". 1", HOLogic.boolT)
  10.134 -  in  t $ prop_of th  end
  10.135 - else prop_of th;
  10.136 -
  10.137 -(**** Constant / Type Frequencies ****)
  10.138 -
  10.139 -(*A two-dimensional symbol table counts frequencies of constants. It's keyed first by
  10.140 -  constant name and second by its list of type instantiations. For the latter, we need
  10.141 -  a linear ordering on type const_typ list.*)
  10.142 -  
  10.143 -local
  10.144 -
  10.145 -fun cons_nr CTVar = 0
  10.146 -  | cons_nr (CType _) = 1;
  10.147 -
  10.148 -in
  10.149 -
  10.150 -fun const_typ_ord TU =
  10.151 -  case TU of
  10.152 -    (CType (a, Ts), CType (b, Us)) =>
  10.153 -      (case fast_string_ord(a,b) of EQUAL => dict_ord const_typ_ord (Ts,Us) | ord => ord)
  10.154 -  | (T, U) => int_ord (cons_nr T, cons_nr U);
  10.155 -
  10.156 -end;
  10.157 -
  10.158 -structure CTtab = Table(type key = const_typ list val ord = dict_ord const_typ_ord);
  10.159 -
  10.160 -fun count_axiom_consts theory_const thy ((thm,_), tab) = 
  10.161 -  let fun count_const (a, T, tab) =
  10.162 -        let val (c, cts) = const_with_typ thy (a,T)
  10.163 -        in  (*Two-dimensional table update. Constant maps to types maps to count.*)
  10.164 -            Symtab.map_default (c, CTtab.empty) 
  10.165 -                               (CTtab.map_default (cts,0) (fn n => n+1)) tab
  10.166 -        end
  10.167 -      fun count_term_consts (Const(a,T), tab) = count_const(a,T,tab)
  10.168 -        | count_term_consts (Free(a,T), tab) = count_const(a,T,tab)
  10.169 -        | count_term_consts (t $ u, tab) =
  10.170 -            count_term_consts (t, count_term_consts (u, tab))
  10.171 -        | count_term_consts (Abs(_,_,t), tab) = count_term_consts (t, tab)
  10.172 -        | count_term_consts (_, tab) = tab
  10.173 -  in  count_term_consts (const_prop_of theory_const thm, tab)  end;
  10.174 -
  10.175 -
  10.176 -(**** Actual Filtering Code ****)
  10.177 -
  10.178 -(*The frequency of a constant is the sum of those of all instances of its type.*)
  10.179 -fun const_frequency ctab (c, cts) =
  10.180 -  let val pairs = CTtab.dest (the (Symtab.lookup ctab c))
  10.181 -      fun add ((cts',m), n) = if match_types cts cts' then m+n else n
  10.182 -  in  List.foldl add 0 pairs  end;
  10.183 -
  10.184 -(*Add in a constant's weight, as determined by its frequency.*)
  10.185 -fun add_ct_weight ctab ((c,T), w) =
  10.186 -  w + weight_fn (real (const_frequency ctab (c,T)));
  10.187 -
  10.188 -(*Relevant constants are weighted according to frequency, 
  10.189 -  but irrelevant constants are simply counted. Otherwise, Skolem functions,
  10.190 -  which are rare, would harm a clause's chances of being picked.*)
  10.191 -fun clause_weight ctab gctyps consts_typs =
  10.192 -    let val rel = filter (uni_mem gctyps) consts_typs
  10.193 -        val rel_weight = List.foldl (add_ct_weight ctab) 0.0 rel
  10.194 -    in
  10.195 -        rel_weight / (rel_weight + real (length consts_typs - length rel))
  10.196 -    end;
  10.197 -    
  10.198 -(*Multiplies out to a list of pairs: 'a * 'b list -> ('a * 'b) list -> ('a * 'b) list*)
  10.199 -fun add_expand_pairs (x,ys) xys = List.foldl (fn (y,acc) => (x,y)::acc) xys ys;
  10.200 -
  10.201 -fun consts_typs_of_term thy t = 
  10.202 -  let val tab = add_term_consts_typs_rm thy (t, null_const_tab)
  10.203 -  in  Symtab.fold add_expand_pairs tab []  end;
  10.204 -
  10.205 -fun pair_consts_typs_axiom theory_const thy (thm,name) =
  10.206 -    ((thm,name), (consts_typs_of_term thy (const_prop_of theory_const thm)));
  10.207 -
  10.208 -exception ConstFree;
  10.209 -fun dest_ConstFree (Const aT) = aT
  10.210 -  | dest_ConstFree (Free aT) = aT
  10.211 -  | dest_ConstFree _ = raise ConstFree;
  10.212 -
  10.213 -(*Look for definitions of the form f ?x1 ... ?xn = t, but not reversed.*)
  10.214 -fun defines thy thm gctypes =
  10.215 -    let val tm = prop_of thm
  10.216 -        fun defs lhs rhs =
  10.217 -            let val (rator,args) = strip_comb lhs
  10.218 -                val ct = const_with_typ thy (dest_ConstFree rator)
  10.219 -            in
  10.220 -              forall is_Var args andalso uni_mem gctypes ct andalso
  10.221 -                subset (op =) (Term.add_vars rhs [], Term.add_vars lhs [])
  10.222 -            end
  10.223 -            handle ConstFree => false
  10.224 -    in    
  10.225 -        case tm of Const ("Trueprop",_) $ (Const("op =",_) $ lhs $ rhs) => 
  10.226 -                   defs lhs rhs 
  10.227 -                 | _ => false
  10.228 -    end;
  10.229 -
  10.230 -type annotd_cls = (thm * (string * int)) * ((string * const_typ list) list);
  10.231 -       
  10.232 -(*For a reverse sort, putting the largest values first.*)
  10.233 -fun compare_pairs ((_,w1),(_,w2)) = Real.compare (w2,w1);
  10.234 -
  10.235 -(*Limit the number of new clauses, to prevent runaway acceptance.*)
  10.236 -fun take_best max_new (newpairs : (annotd_cls*real) list) =
  10.237 -  let val nnew = length newpairs
  10.238 -  in
  10.239 -    if nnew <= max_new then (map #1 newpairs, [])
  10.240 -    else 
  10.241 -      let val cls = sort compare_pairs newpairs
  10.242 -          val accepted = List.take (cls, max_new)
  10.243 -      in
  10.244 -        Res_Axioms.trace_msg (fn () => ("Number of candidates, " ^ Int.toString nnew ^ 
  10.245 -                       ", exceeds the limit of " ^ Int.toString (max_new)));
  10.246 -        Res_Axioms.trace_msg (fn () => ("Effective pass mark: " ^ Real.toString (#2 (List.last accepted))));
  10.247 -        Res_Axioms.trace_msg (fn () => "Actually passed: " ^
  10.248 -          space_implode ", " (map (fn (((_,(name,_)),_),_) => name) accepted));
  10.249 -
  10.250 -        (map #1 accepted, map #1 (List.drop (cls, max_new)))
  10.251 -      end
  10.252 -  end;
  10.253 -
  10.254 -fun relevant_clauses max_new thy ctab p rel_consts =
  10.255 -  let fun relevant ([],_) [] = [] : (thm * (string * int)) list  (*Nothing added this iteration*)
  10.256 -        | relevant (newpairs,rejects) [] =
  10.257 -            let val (newrels,more_rejects) = take_best max_new newpairs
  10.258 -                val new_consts = maps #2 newrels
  10.259 -                val rel_consts' = List.foldl add_const_typ_table rel_consts new_consts
  10.260 -                val newp = p + (1.0-p) / convergence
  10.261 -            in
  10.262 -              Res_Axioms.trace_msg (fn () => "relevant this iteration: " ^ Int.toString (length newrels));
  10.263 -               (map #1 newrels) @ 
  10.264 -               (relevant_clauses max_new thy ctab newp rel_consts' (more_rejects@rejects))
  10.265 -            end
  10.266 -        | relevant (newrels,rejects) ((ax as (clsthm as (_,(name,n)),consts_typs)) :: axs) =
  10.267 -            let val weight = clause_weight ctab rel_consts consts_typs
  10.268 -            in
  10.269 -              if p <= weight orelse (follow_defs andalso defines thy (#1 clsthm) rel_consts)
  10.270 -              then (Res_Axioms.trace_msg (fn () => (name ^ " clause " ^ Int.toString n ^ 
  10.271 -                                            " passes: " ^ Real.toString weight));
  10.272 -                    relevant ((ax,weight)::newrels, rejects) axs)
  10.273 -              else relevant (newrels, ax::rejects) axs
  10.274 -            end
  10.275 -    in  Res_Axioms.trace_msg (fn () => ("relevant_clauses, current pass mark = " ^ Real.toString p));
  10.276 -        relevant ([],[]) 
  10.277 -    end;
  10.278 -        
  10.279 -fun relevance_filter max_new theory_const thy axioms goals = 
  10.280 - if run_relevance_filter andalso pass_mark >= 0.1
  10.281 - then
  10.282 -  let val const_tab = List.foldl (count_axiom_consts theory_const thy) Symtab.empty axioms
  10.283 -      val goal_const_tab = get_goal_consts_typs thy goals
  10.284 -      val _ = Res_Axioms.trace_msg (fn () => ("Initial constants: " ^
  10.285 -                                 space_implode ", " (Symtab.keys goal_const_tab)));
  10.286 -      val rels = relevant_clauses max_new thy const_tab (pass_mark) 
  10.287 -                   goal_const_tab  (map (pair_consts_typs_axiom theory_const thy) axioms)
  10.288 -  in
  10.289 -      Res_Axioms.trace_msg (fn () => ("Total relevant: " ^ Int.toString (length rels)));
  10.290 -      rels
  10.291 -  end
  10.292 - else axioms;
  10.293 -
  10.294 -(***************************************************************)
  10.295 -(* Retrieving and filtering lemmas                             *)
  10.296 -(***************************************************************)
  10.297 -
  10.298 -(*** retrieve lemmas and filter them ***)
  10.299 -
  10.300 -(*Hashing to detect duplicate and variant clauses, e.g. from the [iff] attribute*)
  10.301 -
  10.302 -fun setinsert (x,s) = Symtab.update (x,()) s;
  10.303 -
  10.304 -(*Reject theorems with names like "List.filter.filter_list_def" or
  10.305 -  "Accessible_Part.acc.defs", as these are definitions arising from packages.*)
  10.306 -fun is_package_def a =
  10.307 -  let val names = Long_Name.explode a
  10.308 -  in
  10.309 -     length names > 2 andalso
  10.310 -     not (hd names = "local") andalso
  10.311 -     String.isSuffix "_def" a  orelse  String.isSuffix "_defs" a
  10.312 -  end;
  10.313 -
  10.314 -(** a hash function from Term.term to int, and also a hash table **)
  10.315 -val xor_words = List.foldl Word.xorb 0w0;
  10.316 -
  10.317 -fun hashw_term ((Const(c,_)), w) = Polyhash.hashw_string (c,w)
  10.318 -  | hashw_term ((Free(a,_)), w) = Polyhash.hashw_string (a,w)
  10.319 -  | hashw_term ((Var(_,_)), w) = w
  10.320 -  | hashw_term ((Bound i), w) = Polyhash.hashw_int(i,w)
  10.321 -  | hashw_term ((Abs(_,_,t)), w) = hashw_term (t, w)
  10.322 -  | hashw_term ((P$Q), w) = hashw_term (Q, (hashw_term (P, w)));
  10.323 -
  10.324 -fun hash_literal (Const("Not",_)$P) = Word.notb(hashw_term(P,0w0))
  10.325 -  | hash_literal P = hashw_term(P,0w0);
  10.326 -
  10.327 -fun hash_term t = Word.toIntX (xor_words (map hash_literal (HOLogic.disjuncts (strip_Trueprop t))));
  10.328 -
  10.329 -fun equal_thm (thm1,thm2) = Term.aconv(prop_of thm1, prop_of thm2);
  10.330 -
  10.331 -exception HASH_CLAUSE;
  10.332 -
  10.333 -(*Create a hash table for clauses, of the given size*)
  10.334 -fun mk_clause_table n =
  10.335 -      Polyhash.mkTable (hash_term o prop_of, equal_thm)
  10.336 -                       (n, HASH_CLAUSE);
  10.337 -
  10.338 -(*Use a hash table to eliminate duplicates from xs. Argument is a list of
  10.339 -  (thm * (string * int)) tuples. The theorems are hashed into the table. *)
  10.340 -fun make_unique xs =
  10.341 -  let val ht = mk_clause_table 7000
  10.342 -  in
  10.343 -      Res_Axioms.trace_msg (fn () => ("make_unique gets " ^ Int.toString (length xs) ^ " clauses"));
  10.344 -      app (ignore o Polyhash.peekInsert ht) xs;
  10.345 -      Polyhash.listItems ht
  10.346 -  end;
  10.347 -
  10.348 -(*Remove existing axiom clauses from the conjecture clauses, as this can dramatically
  10.349 -  boost an ATP's performance (for some reason)*)
  10.350 -fun subtract_cls c_clauses ax_clauses =
  10.351 -  let val ht = mk_clause_table 2200
  10.352 -      fun known x = is_some (Polyhash.peek ht x)
  10.353 -  in
  10.354 -      app (ignore o Polyhash.peekInsert ht) ax_clauses;
  10.355 -      filter (not o known) c_clauses
  10.356 -  end;
  10.357 -
  10.358 -fun all_valid_thms ctxt =
  10.359 -  let
  10.360 -    val global_facts = PureThy.facts_of (ProofContext.theory_of ctxt);
  10.361 -    val local_facts = ProofContext.facts_of ctxt;
  10.362 -    val full_space =
  10.363 -      Name_Space.merge (Facts.space_of global_facts, Facts.space_of local_facts);
  10.364 -
  10.365 -    fun valid_facts facts =
  10.366 -      (facts, []) |-> Facts.fold_static (fn (name, ths0) =>
  10.367 -        let
  10.368 -          fun check_thms a =
  10.369 -            (case try (ProofContext.get_thms ctxt) a of
  10.370 -              NONE => false
  10.371 -            | SOME ths1 => Thm.eq_thms (ths0, ths1));
  10.372 -
  10.373 -          val name1 = Facts.extern facts name;
  10.374 -          val name2 = Name_Space.extern full_space name;
  10.375 -          val ths = filter_out Res_Axioms.bad_for_atp ths0;
  10.376 -        in
  10.377 -          if Facts.is_concealed facts name orelse null ths orelse
  10.378 -            run_blacklist_filter andalso is_package_def name then I
  10.379 -          else
  10.380 -            (case find_first check_thms [name1, name2, name] of
  10.381 -              NONE => I
  10.382 -            | SOME a => cons (a, ths))
  10.383 -        end);
  10.384 -  in valid_facts global_facts @ valid_facts local_facts end;
  10.385 -
  10.386 -fun multi_name a th (n, pairs) =
  10.387 -  (n + 1, (a ^ "(" ^ Int.toString n ^ ")", th) :: pairs);
  10.388 -
  10.389 -fun add_single_names (a, []) pairs = pairs
  10.390 -  | add_single_names (a, [th]) pairs = (a, th) :: pairs
  10.391 -  | add_single_names (a, ths) pairs = #2 (fold (multi_name a) ths (1, pairs));
  10.392 -
  10.393 -(*Ignore blacklisted basenames*)
  10.394 -fun add_multi_names (a, ths) pairs =
  10.395 -  if (Long_Name.base_name a) mem_string Res_Axioms.multi_base_blacklist then pairs
  10.396 -  else add_single_names (a, ths) pairs;
  10.397 -
  10.398 -fun is_multi (a, ths) = length ths > 1 orelse String.isSuffix ".axioms" a;
  10.399 -
  10.400 -(*The single theorems go BEFORE the multiple ones. Blacklist is applied to all.*)
  10.401 -fun name_thm_pairs ctxt =
  10.402 -  let
  10.403 -    val (mults, singles) = List.partition is_multi (all_valid_thms ctxt)
  10.404 -    fun blacklisted (_, th) =
  10.405 -      run_blacklist_filter andalso Res_Blacklist.blacklisted ctxt th
  10.406 -  in
  10.407 -    filter_out blacklisted
  10.408 -      (fold add_single_names singles (fold add_multi_names mults []))
  10.409 -  end;
  10.410 -
  10.411 -fun check_named ("", th) =
  10.412 -      (warning ("No name for theorem " ^ Display.string_of_thm_without_context th); false)
  10.413 -  | check_named _ = true;
  10.414 -
  10.415 -fun get_all_lemmas ctxt =
  10.416 -  let val included_thms =
  10.417 -        tap (fn ths => Res_Axioms.trace_msg
  10.418 -                     (fn () => ("Including all " ^ Int.toString (length ths) ^ " theorems")))
  10.419 -            (name_thm_pairs ctxt)
  10.420 -  in
  10.421 -    filter check_named included_thms
  10.422 -  end;
  10.423 -
  10.424 -(***************************************************************)
  10.425 -(* Type Classes Present in the Axiom or Conjecture Clauses     *)
  10.426 -(***************************************************************)
  10.427 -
  10.428 -fun add_classes (sorts, cset) = List.foldl setinsert cset (flat sorts);
  10.429 -
  10.430 -(*Remove this trivial type class*)
  10.431 -fun delete_type cset = Symtab.delete_safe "HOL.type" cset;
  10.432 -
  10.433 -fun tvar_classes_of_terms ts =
  10.434 -  let val sorts_list = map (map #2 o OldTerm.term_tvars) ts
  10.435 -  in  Symtab.keys (delete_type (List.foldl add_classes Symtab.empty sorts_list))  end;
  10.436 -
  10.437 -fun tfree_classes_of_terms ts =
  10.438 -  let val sorts_list = map (map #2 o OldTerm.term_tfrees) ts
  10.439 -  in  Symtab.keys (delete_type (List.foldl add_classes Symtab.empty sorts_list))  end;
  10.440 -
  10.441 -(*fold type constructors*)
  10.442 -fun fold_type_consts f (Type (a, Ts)) x = fold (fold_type_consts f) Ts (f (a,x))
  10.443 -  | fold_type_consts _ _ x = x;
  10.444 -
  10.445 -val add_type_consts_in_type = fold_type_consts setinsert;
  10.446 -
  10.447 -(*Type constructors used to instantiate overloaded constants are the only ones needed.*)
  10.448 -fun add_type_consts_in_term thy =
  10.449 -  let val const_typargs = Sign.const_typargs thy
  10.450 -      fun add_tcs (Const cT) x = fold add_type_consts_in_type (const_typargs cT) x
  10.451 -        | add_tcs (Abs (_, _, u)) x = add_tcs u x
  10.452 -        | add_tcs (t $ u) x = add_tcs t (add_tcs u x)
  10.453 -        | add_tcs _ x = x
  10.454 -  in  add_tcs  end
  10.455 -
  10.456 -fun type_consts_of_terms thy ts =
  10.457 -  Symtab.keys (fold (add_type_consts_in_term thy) ts Symtab.empty);
  10.458 -
  10.459 -
  10.460 -(***************************************************************)
  10.461 -(* ATP invocation methods setup                                *)
  10.462 -(***************************************************************)
  10.463 -
  10.464 -(*Ensures that no higher-order theorems "leak out"*)
  10.465 -fun restrict_to_logic thy true cls = filter (Meson.is_fol_term thy o prop_of o fst) cls
  10.466 -  | restrict_to_logic thy false cls = cls;
  10.467 -
  10.468 -(**** Predicates to detect unwanted clauses (prolific or likely to cause unsoundness) ****)
  10.469 -
  10.470 -(** Too general means, positive equality literal with a variable X as one operand,
  10.471 -  when X does not occur properly in the other operand. This rules out clearly
  10.472 -  inconsistent clauses such as V=a|V=b, though it by no means guarantees soundness. **)
  10.473 -
  10.474 -fun occurs ix =
  10.475 -    let fun occ(Var (jx,_)) = (ix=jx)
  10.476 -          | occ(t1$t2)      = occ t1 orelse occ t2
  10.477 -          | occ(Abs(_,_,t)) = occ t
  10.478 -          | occ _           = false
  10.479 -    in occ end;
  10.480 -
  10.481 -fun is_recordtype T = not (null (Record.dest_recTs T));
  10.482 -
  10.483 -(*Unwanted equalities include
  10.484 -  (1) those between a variable that does not properly occur in the second operand,
  10.485 -  (2) those between a variable and a record, since these seem to be prolific "cases" thms
  10.486 -*)
  10.487 -fun too_general_eqterms (Var (ix,T), t) = not (occurs ix t) orelse is_recordtype T
  10.488 -  | too_general_eqterms _ = false;
  10.489 -
  10.490 -fun too_general_equality (Const ("op =", _) $ x $ y) =
  10.491 -      too_general_eqterms (x,y) orelse too_general_eqterms(y,x)
  10.492 -  | too_general_equality _ = false;
  10.493 -
  10.494 -(* tautologous? *)
  10.495 -fun is_taut (Const ("Trueprop", _) $ Const ("True", _)) = true
  10.496 -  | is_taut _ = false;
  10.497 -
  10.498 -fun has_typed_var tycons = exists_subterm
  10.499 -  (fn Var (_, Type (a, _)) => member (op =) tycons a | _ => false);
  10.500 -
  10.501 -(*Clauses are forbidden to contain variables of these types. The typical reason is that
  10.502 -  they lead to unsoundness. Note that "unit" satisfies numerous equations like ?X=().
  10.503 -  The resulting clause will have no type constraint, yielding false proofs. Even "bool"
  10.504 -  leads to many unsound proofs, though (obviously) only for higher-order problems.*)
  10.505 -val unwanted_types = ["Product_Type.unit","bool"];
  10.506 -
  10.507 -fun unwanted t =
  10.508 -  is_taut t orelse has_typed_var unwanted_types t orelse
  10.509 -  forall too_general_equality (HOLogic.disjuncts (strip_Trueprop t));
  10.510 -
  10.511 -(*Clauses containing variables of type "unit" or "bool" are unlikely to be useful and
  10.512 -  likely to lead to unsound proofs.*)
  10.513 -fun remove_unwanted_clauses cls = filter (not o unwanted o prop_of o fst) cls;
  10.514 -
  10.515 -fun isFO thy goal_cls = case linkup_logic_mode of
  10.516 -      Auto => forall (Meson.is_fol_term thy) (map prop_of goal_cls)
  10.517 -    | Fol => true
  10.518 -    | Hol => false
  10.519 -
  10.520 -fun get_relevant max_new theory_const (ctxt, (chain_ths, th)) goal_cls =
  10.521 -  let
  10.522 -    val thy = ProofContext.theory_of ctxt
  10.523 -    val isFO = isFO thy goal_cls
  10.524 -    val included_cls = get_all_lemmas ctxt
  10.525 -      |> Res_Axioms.cnf_rules_pairs thy |> make_unique
  10.526 -      |> restrict_to_logic thy isFO
  10.527 -      |> remove_unwanted_clauses
  10.528 -  in
  10.529 -    relevance_filter max_new theory_const thy included_cls (map prop_of goal_cls) 
  10.530 -  end;
  10.531 -
  10.532 -(* prepare for passing to writer,
  10.533 -   create additional clauses based on the information from extra_cls *)
  10.534 -fun prepare_clauses dfg goal_cls chain_ths axcls extra_cls thy =
  10.535 -  let
  10.536 -    (* add chain thms *)
  10.537 -    val chain_cls =
  10.538 -      Res_Axioms.cnf_rules_pairs thy (filter check_named (map Res_Axioms.pairname chain_ths))
  10.539 -    val axcls = chain_cls @ axcls
  10.540 -    val extra_cls = chain_cls @ extra_cls
  10.541 -    val isFO = isFO thy goal_cls
  10.542 -    val ccls = subtract_cls goal_cls extra_cls
  10.543 -    val _ = app (fn th => Res_Axioms.trace_msg (fn _ => Display.string_of_thm_global thy th)) ccls
  10.544 -    val ccltms = map prop_of ccls
  10.545 -    and axtms = map (prop_of o #1) extra_cls
  10.546 -    val subs = tfree_classes_of_terms ccltms
  10.547 -    and supers = tvar_classes_of_terms axtms
  10.548 -    and tycons = type_consts_of_terms thy (ccltms@axtms)
  10.549 -    (*TFrees in conjecture clauses; TVars in axiom clauses*)
  10.550 -    val conjectures = Res_HOL_Clause.make_conjecture_clauses dfg thy ccls
  10.551 -    val (_, extra_clauses) = ListPair.unzip (Res_HOL_Clause.make_axiom_clauses dfg thy extra_cls)
  10.552 -    val (clnames,axiom_clauses) = ListPair.unzip (Res_HOL_Clause.make_axiom_clauses dfg thy axcls)
  10.553 -    val helper_clauses = Res_HOL_Clause.get_helper_clauses dfg thy isFO (conjectures, extra_cls, [])
  10.554 -    val (supers',arity_clauses) = Res_Clause.make_arity_clauses_dfg dfg thy tycons supers
  10.555 -    val classrel_clauses = Res_Clause.make_classrel_clauses thy subs supers'
  10.556 -  in
  10.557 -    (Vector.fromList clnames,
  10.558 -      (conjectures, axiom_clauses, extra_clauses, helper_clauses, classrel_clauses, arity_clauses))
  10.559 -  end
  10.560 -
  10.561 -end;
  10.562 -
    11.1 --- a/src/HOL/Tools/res_axioms.ML	Wed Mar 17 17:23:45 2010 +0100
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,545 +0,0 @@
    11.4 -(*  Title:      HOL/Tools/res_axioms.ML
    11.5 -    Author:     Jia Meng, Cambridge University Computer Laboratory
    11.6 -
    11.7 -Transformation of axiom rules (elim/intro/etc) into CNF forms.
    11.8 -*)
    11.9 -
   11.10 -signature RES_AXIOMS =
   11.11 -sig
   11.12 -  val trace: bool Unsynchronized.ref
   11.13 -  val trace_msg: (unit -> string) -> unit
   11.14 -  val cnf_axiom: theory -> thm -> thm list
   11.15 -  val pairname: thm -> string * thm
   11.16 -  val multi_base_blacklist: string list
   11.17 -  val bad_for_atp: thm -> bool
   11.18 -  val type_has_topsort: typ -> bool
   11.19 -  val cnf_rules_pairs: theory -> (string * thm) list -> (thm * (string * int)) list
   11.20 -  val neg_clausify: thm list -> thm list
   11.21 -  val expand_defs_tac: thm -> tactic
   11.22 -  val combinators: thm -> thm
   11.23 -  val neg_conjecture_clauses: Proof.context -> thm -> int -> thm list * (string * typ) list
   11.24 -  val suppress_endtheory: bool Unsynchronized.ref
   11.25 -    (*for emergency use where endtheory causes problems*)
   11.26 -  val setup: theory -> theory
   11.27 -end;
   11.28 -
   11.29 -structure Res_Axioms: RES_AXIOMS =
   11.30 -struct
   11.31 -
   11.32 -val trace = Unsynchronized.ref false;
   11.33 -fun trace_msg msg = if ! trace then tracing (msg ()) else ();
   11.34 -
   11.35 -fun freeze_thm th = #1 (Drule.legacy_freeze_thaw th);
   11.36 -
   11.37 -val type_has_topsort = Term.exists_subtype
   11.38 -  (fn TFree (_, []) => true
   11.39 -    | TVar (_, []) => true
   11.40 -    | _ => false);
   11.41 -
   11.42 -
   11.43 -(**** Transformation of Elimination Rules into First-Order Formulas****)
   11.44 -
   11.45 -val cfalse = cterm_of @{theory HOL} HOLogic.false_const;
   11.46 -val ctp_false = cterm_of @{theory HOL} (HOLogic.mk_Trueprop HOLogic.false_const);
   11.47 -
   11.48 -(*Converts an elim-rule into an equivalent theorem that does not have the
   11.49 -  predicate variable.  Leaves other theorems unchanged.  We simply instantiate the
   11.50 -  conclusion variable to False.*)
   11.51 -fun transform_elim th =
   11.52 -  case concl_of th of    (*conclusion variable*)
   11.53 -       Const("Trueprop",_) $ (v as Var(_,Type("bool",[]))) =>
   11.54 -           Thm.instantiate ([], [(cterm_of @{theory HOL} v, cfalse)]) th
   11.55 -    | v as Var(_, Type("prop",[])) =>
   11.56 -           Thm.instantiate ([], [(cterm_of @{theory HOL} v, ctp_false)]) th
   11.57 -    | _ => th;
   11.58 -
   11.59 -(*To enforce single-threading*)
   11.60 -exception Clausify_failure of theory;
   11.61 -
   11.62 -
   11.63 -(**** SKOLEMIZATION BY INFERENCE (lcp) ****)
   11.64 -
   11.65 -fun rhs_extra_types lhsT rhs =
   11.66 -  let val lhs_vars = Term.add_tfreesT lhsT []
   11.67 -      fun add_new_TFrees (TFree v) =
   11.68 -            if member (op =) lhs_vars v then I else insert (op =) (TFree v)
   11.69 -        | add_new_TFrees _ = I
   11.70 -      val rhs_consts = fold_aterms (fn Const c => insert (op =) c | _ => I) rhs []
   11.71 -  in fold (#2 #> Term.fold_atyps add_new_TFrees) rhs_consts [] end;
   11.72 -
   11.73 -(*Traverse a theorem, declaring Skolem function definitions. String s is the suggested
   11.74 -  prefix for the Skolem constant.*)
   11.75 -fun declare_skofuns s th =
   11.76 -  let
   11.77 -    val nref = Unsynchronized.ref 0    (* FIXME ??? *)
   11.78 -    fun dec_sko (Const ("Ex",_) $ (xtp as Abs (_, T, p))) (axs, thy) =
   11.79 -          (*Existential: declare a Skolem function, then insert into body and continue*)
   11.80 -          let
   11.81 -            val cname = "sko_" ^ s ^ "_" ^ Int.toString (Unsynchronized.inc nref)
   11.82 -            val args0 = OldTerm.term_frees xtp  (*get the formal parameter list*)
   11.83 -            val Ts = map type_of args0
   11.84 -            val extraTs = rhs_extra_types (Ts ---> T) xtp
   11.85 -            val argsx = map (fn T => Free (gensym "vsk", T)) extraTs
   11.86 -            val args = argsx @ args0
   11.87 -            val cT = extraTs ---> Ts ---> T
   11.88 -            val rhs = list_abs_free (map dest_Free args, HOLogic.choice_const T $ xtp)
   11.89 -                    (*Forms a lambda-abstraction over the formal parameters*)
   11.90 -            val (c, thy') =
   11.91 -              Sign.declare_const ((Binding.conceal (Binding.name cname), cT), NoSyn) thy
   11.92 -            val cdef = cname ^ "_def"
   11.93 -            val thy'' =
   11.94 -              Theory.add_defs_i true false [(Binding.name cdef, Logic.mk_equals (c, rhs))] thy'
   11.95 -            val ax = Thm.axiom thy'' (Sign.full_bname thy'' cdef)
   11.96 -          in dec_sko (subst_bound (list_comb (c, args), p)) (ax :: axs, thy'') end
   11.97 -      | dec_sko (Const ("All", _) $ (Abs (a, T, p))) thx =
   11.98 -          (*Universal quant: insert a free variable into body and continue*)
   11.99 -          let val fname = Name.variant (OldTerm.add_term_names (p, [])) a
  11.100 -          in dec_sko (subst_bound (Free (fname, T), p)) thx end
  11.101 -      | dec_sko (Const ("op &", _) $ p $ q) thx = dec_sko q (dec_sko p thx)
  11.102 -      | dec_sko (Const ("op |", _) $ p $ q) thx = dec_sko q (dec_sko p thx)
  11.103 -      | dec_sko (Const ("Trueprop", _) $ p) thx = dec_sko p thx
  11.104 -      | dec_sko t thx = thx (*Do nothing otherwise*)
  11.105 -  in fn thy => dec_sko (Thm.prop_of th) ([], thy) end;
  11.106 -
  11.107 -(*Traverse a theorem, accumulating Skolem function definitions.*)
  11.108 -fun assume_skofuns s th =
  11.109 -  let val sko_count = Unsynchronized.ref 0   (* FIXME ??? *)
  11.110 -      fun dec_sko (Const ("Ex",_) $ (xtp as Abs(_,T,p))) defs =
  11.111 -            (*Existential: declare a Skolem function, then insert into body and continue*)
  11.112 -            let val skos = map (#1 o Logic.dest_equals) defs  (*existing sko fns*)
  11.113 -                val args = subtract (op =) skos (OldTerm.term_frees xtp) (*the formal parameters*)
  11.114 -                val Ts = map type_of args
  11.115 -                val cT = Ts ---> T
  11.116 -                val id = "sko_" ^ s ^ "_" ^ Int.toString (Unsynchronized.inc sko_count)
  11.117 -                val c = Free (id, cT)
  11.118 -                val rhs = list_abs_free (map dest_Free args,
  11.119 -                                         HOLogic.choice_const T $ xtp)
  11.120 -                      (*Forms a lambda-abstraction over the formal parameters*)
  11.121 -                val def = Logic.mk_equals (c, rhs)
  11.122 -            in dec_sko (subst_bound (list_comb(c,args), p))
  11.123 -                       (def :: defs)
  11.124 -            end
  11.125 -        | dec_sko (Const ("All",_) $ Abs (a, T, p)) defs =
  11.126 -            (*Universal quant: insert a free variable into body and continue*)
  11.127 -            let val fname = Name.variant (OldTerm.add_term_names (p,[])) a
  11.128 -            in dec_sko (subst_bound (Free(fname,T), p)) defs end
  11.129 -        | dec_sko (Const ("op &", _) $ p $ q) defs = dec_sko q (dec_sko p defs)
  11.130 -        | dec_sko (Const ("op |", _) $ p $ q) defs = dec_sko q (dec_sko p defs)
  11.131 -        | dec_sko (Const ("Trueprop", _) $ p) defs = dec_sko p defs
  11.132 -        | dec_sko t defs = defs (*Do nothing otherwise*)
  11.133 -  in  dec_sko (prop_of th) []  end;
  11.134 -
  11.135 -
  11.136 -(**** REPLACING ABSTRACTIONS BY COMBINATORS ****)
  11.137 -
  11.138 -(*Returns the vars of a theorem*)
  11.139 -fun vars_of_thm th =
  11.140 -  map (Thm.cterm_of (theory_of_thm th) o Var) (Thm.fold_terms Term.add_vars th []);
  11.141 -
  11.142 -(*Make a version of fun_cong with a given variable name*)
  11.143 -local
  11.144 -    val fun_cong' = fun_cong RS asm_rl; (*renumber f, g to prevent clashes with (a,0)*)
  11.145 -    val cx = hd (vars_of_thm fun_cong');
  11.146 -    val ty = typ_of (ctyp_of_term cx);
  11.147 -    val thy = theory_of_thm fun_cong;
  11.148 -    fun mkvar a = cterm_of thy (Var((a,0),ty));
  11.149 -in
  11.150 -fun xfun_cong x = Thm.instantiate ([], [(cx, mkvar x)]) fun_cong'
  11.151 -end;
  11.152 -
  11.153 -(*Removes the lambdas from an equation of the form t = (%x. u).  A non-negative n,
  11.154 -  serves as an upper bound on how many to remove.*)
  11.155 -fun strip_lambdas 0 th = th
  11.156 -  | strip_lambdas n th =
  11.157 -      case prop_of th of
  11.158 -          _ $ (Const ("op =", _) $ _ $ Abs (x,_,_)) =>
  11.159 -              strip_lambdas (n-1) (freeze_thm (th RS xfun_cong x))
  11.160 -        | _ => th;
  11.161 -
  11.162 -val lambda_free = not o Term.has_abs;
  11.163 -
  11.164 -val [f_B,g_B] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_B}));
  11.165 -val [g_C,f_C] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_C}));
  11.166 -val [f_S,g_S] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_S}));
  11.167 -
  11.168 -(*FIXME: requires more use of cterm constructors*)
  11.169 -fun abstract ct =
  11.170 -  let
  11.171 -      val thy = theory_of_cterm ct
  11.172 -      val Abs(x,_,body) = term_of ct
  11.173 -      val Type("fun",[xT,bodyT]) = typ_of (ctyp_of_term ct)
  11.174 -      val cxT = ctyp_of thy xT and cbodyT = ctyp_of thy bodyT
  11.175 -      fun makeK() = instantiate' [SOME cxT, SOME cbodyT] [SOME (cterm_of thy body)] @{thm abs_K}
  11.176 -  in
  11.177 -      case body of
  11.178 -          Const _ => makeK()
  11.179 -        | Free _ => makeK()
  11.180 -        | Var _ => makeK()  (*though Var isn't expected*)
  11.181 -        | Bound 0 => instantiate' [SOME cxT] [] @{thm abs_I} (*identity: I*)
  11.182 -        | rator$rand =>
  11.183 -            if loose_bvar1 (rator,0) then (*C or S*)
  11.184 -               if loose_bvar1 (rand,0) then (*S*)
  11.185 -                 let val crator = cterm_of thy (Abs(x,xT,rator))
  11.186 -                     val crand = cterm_of thy (Abs(x,xT,rand))
  11.187 -                     val abs_S' = cterm_instantiate [(f_S,crator),(g_S,crand)] @{thm abs_S}
  11.188 -                     val (_,rhs) = Thm.dest_equals (cprop_of abs_S')
  11.189 -                 in
  11.190 -                   Thm.transitive abs_S' (Conv.binop_conv abstract rhs)
  11.191 -                 end
  11.192 -               else (*C*)
  11.193 -                 let val crator = cterm_of thy (Abs(x,xT,rator))
  11.194 -                     val abs_C' = cterm_instantiate [(f_C,crator),(g_C,cterm_of thy rand)] @{thm abs_C}
  11.195 -                     val (_,rhs) = Thm.dest_equals (cprop_of abs_C')
  11.196 -                 in
  11.197 -                   Thm.transitive abs_C' (Conv.fun_conv (Conv.arg_conv abstract) rhs)
  11.198 -                 end
  11.199 -            else if loose_bvar1 (rand,0) then (*B or eta*)
  11.200 -               if rand = Bound 0 then eta_conversion ct
  11.201 -               else (*B*)
  11.202 -                 let val crand = cterm_of thy (Abs(x,xT,rand))
  11.203 -                     val crator = cterm_of thy rator
  11.204 -                     val abs_B' = cterm_instantiate [(f_B,crator),(g_B,crand)] @{thm abs_B}
  11.205 -                     val (_,rhs) = Thm.dest_equals (cprop_of abs_B')
  11.206 -                 in
  11.207 -                   Thm.transitive abs_B' (Conv.arg_conv abstract rhs)
  11.208 -                 end
  11.209 -            else makeK()
  11.210 -        | _ => error "abstract: Bad term"
  11.211 -  end;
  11.212 -
  11.213 -(*Traverse a theorem, declaring abstraction function definitions. String s is the suggested
  11.214 -  prefix for the constants.*)
  11.215 -fun combinators_aux ct =
  11.216 -  if lambda_free (term_of ct) then reflexive ct
  11.217 -  else
  11.218 -  case term_of ct of
  11.219 -      Abs _ =>
  11.220 -        let val (cv, cta) = Thm.dest_abs NONE ct
  11.221 -            val (v, _) = dest_Free (term_of cv)
  11.222 -            val u_th = combinators_aux cta
  11.223 -            val cu = Thm.rhs_of u_th
  11.224 -            val comb_eq = abstract (Thm.cabs cv cu)
  11.225 -        in transitive (abstract_rule v cv u_th) comb_eq end
  11.226 -    | _ $ _ =>
  11.227 -        let val (ct1, ct2) = Thm.dest_comb ct
  11.228 -        in  combination (combinators_aux ct1) (combinators_aux ct2)  end;
  11.229 -
  11.230 -fun combinators th =
  11.231 -  if lambda_free (prop_of th) then th
  11.232 -  else
  11.233 -    let val th = Drule.eta_contraction_rule th
  11.234 -        val eqth = combinators_aux (cprop_of th)
  11.235 -    in  equal_elim eqth th   end
  11.236 -    handle THM (msg,_,_) =>
  11.237 -      (warning (cat_lines
  11.238 -        ["Error in the combinator translation of " ^ Display.string_of_thm_without_context th,
  11.239 -          "  Exception message: " ^ msg]);
  11.240 -       TrueI);  (*A type variable of sort {} will cause make abstraction fail.*)
  11.241 -
  11.242 -(*cterms are used throughout for efficiency*)
  11.243 -val cTrueprop = Thm.cterm_of @{theory HOL} HOLogic.Trueprop;
  11.244 -
  11.245 -(*cterm version of mk_cTrueprop*)
  11.246 -fun c_mkTrueprop A = Thm.capply cTrueprop A;
  11.247 -
  11.248 -(*Given an abstraction over n variables, replace the bound variables by free
  11.249 -  ones. Return the body, along with the list of free variables.*)
  11.250 -fun c_variant_abs_multi (ct0, vars) =
  11.251 -      let val (cv,ct) = Thm.dest_abs NONE ct0
  11.252 -      in  c_variant_abs_multi (ct, cv::vars)  end
  11.253 -      handle CTERM _ => (ct0, rev vars);
  11.254 -
  11.255 -(*Given the definition of a Skolem function, return a theorem to replace
  11.256 -  an existential formula by a use of that function.
  11.257 -   Example: "EX x. x : A & x ~: B ==> sko A B : A & sko A B ~: B"  [.] *)
  11.258 -fun skolem_of_def def =
  11.259 -  let val (c,rhs) = Thm.dest_equals (cprop_of (freeze_thm def))
  11.260 -      val (ch, frees) = c_variant_abs_multi (rhs, [])
  11.261 -      val (chilbert,cabs) = Thm.dest_comb ch
  11.262 -      val thy = Thm.theory_of_cterm chilbert
  11.263 -      val t = Thm.term_of chilbert
  11.264 -      val T = case t of Const ("Hilbert_Choice.Eps", Type("fun",[_,T])) => T
  11.265 -                      | _ => raise THM ("skolem_of_def: expected Eps", 0, [def])
  11.266 -      val cex = Thm.cterm_of thy (HOLogic.exists_const T)
  11.267 -      val ex_tm = c_mkTrueprop (Thm.capply cex cabs)
  11.268 -      and conc =  c_mkTrueprop (Drule.beta_conv cabs (Drule.list_comb(c,frees)));
  11.269 -      fun tacf [prem] = rewrite_goals_tac [def] THEN rtac (prem RS @{thm someI_ex}) 1
  11.270 -  in  Goal.prove_internal [ex_tm] conc tacf
  11.271 -       |> forall_intr_list frees
  11.272 -       |> Thm.forall_elim_vars 0  (*Introduce Vars, but don't discharge defs.*)
  11.273 -       |> Thm.varifyT
  11.274 -  end;
  11.275 -
  11.276 -
  11.277 -(*Converts an Isabelle theorem (intro, elim or simp format, even higher-order) into NNF.*)
  11.278 -fun to_nnf th ctxt0 =
  11.279 -  let val th1 = th |> transform_elim |> zero_var_indexes
  11.280 -      val ((_, [th2]), ctxt) = Variable.import true [th1] ctxt0
  11.281 -      val th3 = th2
  11.282 -        |> Conv.fconv_rule Object_Logic.atomize
  11.283 -        |> Meson.make_nnf ctxt |> strip_lambdas ~1
  11.284 -  in  (th3, ctxt)  end;
  11.285 -
  11.286 -(*Generate Skolem functions for a theorem supplied in nnf*)
  11.287 -fun assume_skolem_of_def s th =
  11.288 -  map (skolem_of_def o assume o (cterm_of (theory_of_thm th))) (assume_skofuns s th);
  11.289 -
  11.290 -
  11.291 -(*** Blacklisting (duplicated in Res_ATP?) ***)
  11.292 -
  11.293 -val max_lambda_nesting = 3;
  11.294 -
  11.295 -fun excessive_lambdas (f$t, k) = excessive_lambdas (f,k) orelse excessive_lambdas (t,k)
  11.296 -  | excessive_lambdas (Abs(_,_,t), k) = k=0 orelse excessive_lambdas (t,k-1)
  11.297 -  | excessive_lambdas _ = false;
  11.298 -
  11.299 -fun is_formula_type T = (T = HOLogic.boolT orelse T = propT);
  11.300 -
  11.301 -(*Don't count nested lambdas at the level of formulas, as they are quantifiers*)
  11.302 -fun excessive_lambdas_fm Ts (Abs(_,T,t)) = excessive_lambdas_fm (T::Ts) t
  11.303 -  | excessive_lambdas_fm Ts t =
  11.304 -      if is_formula_type (fastype_of1 (Ts, t))
  11.305 -      then exists (excessive_lambdas_fm Ts) (#2 (strip_comb t))
  11.306 -      else excessive_lambdas (t, max_lambda_nesting);
  11.307 -
  11.308 -(*The max apply_depth of any metis call in Metis_Examples (on 31-10-2007) was 11.*)
  11.309 -val max_apply_depth = 15;
  11.310 -
  11.311 -fun apply_depth (f$t) = Int.max (apply_depth f, apply_depth t + 1)
  11.312 -  | apply_depth (Abs(_,_,t)) = apply_depth t
  11.313 -  | apply_depth _ = 0;
  11.314 -
  11.315 -fun too_complex t =
  11.316 -  apply_depth t > max_apply_depth orelse
  11.317 -  Meson.too_many_clauses NONE t orelse
  11.318 -  excessive_lambdas_fm [] t;
  11.319 -
  11.320 -fun is_strange_thm th =
  11.321 -  case head_of (concl_of th) of
  11.322 -      Const (a, _) => (a <> "Trueprop" andalso a <> "==")
  11.323 -    | _ => false;
  11.324 -
  11.325 -fun bad_for_atp th =
  11.326 -  too_complex (prop_of th)
  11.327 -  orelse exists_type type_has_topsort (prop_of th)
  11.328 -  orelse is_strange_thm th;
  11.329 -
  11.330 -val multi_base_blacklist =
  11.331 -  ["defs","select_defs","update_defs","induct","inducts","split","splits","split_asm",
  11.332 -   "cases","ext_cases"];  (* FIXME put other record thms here, or declare as "noatp" *)
  11.333 -
  11.334 -(*Keep the full complexity of the original name*)
  11.335 -fun flatten_name s = space_implode "_X" (Long_Name.explode s);
  11.336 -
  11.337 -fun fake_name th =
  11.338 -  if Thm.has_name_hint th then flatten_name (Thm.get_name_hint th)
  11.339 -  else gensym "unknown_thm_";
  11.340 -
  11.341 -(*Skolemize a named theorem, with Skolem functions as additional premises.*)
  11.342 -fun skolem_thm (s, th) =
  11.343 -  if member (op =) multi_base_blacklist (Long_Name.base_name s) orelse bad_for_atp th then []
  11.344 -  else
  11.345 -    let
  11.346 -      val ctxt0 = Variable.thm_context th
  11.347 -      val (nnfth, ctxt1) = to_nnf th ctxt0
  11.348 -      val (cnfs, ctxt2) = Meson.make_cnf (assume_skolem_of_def s nnfth) nnfth ctxt1
  11.349 -    in  cnfs |> map combinators |> Variable.export ctxt2 ctxt0 |> Meson.finish_cnf  end
  11.350 -    handle THM _ => [];
  11.351 -
  11.352 -(*The cache prevents repeated clausification of a theorem, and also repeated declaration of
  11.353 -  Skolem functions.*)
  11.354 -structure ThmCache = Theory_Data
  11.355 -(
  11.356 -  type T = thm list Thmtab.table * unit Symtab.table;
  11.357 -  val empty = (Thmtab.empty, Symtab.empty);
  11.358 -  val extend = I;
  11.359 -  fun merge ((cache1, seen1), (cache2, seen2)) : T =
  11.360 -    (Thmtab.merge (K true) (cache1, cache2), Symtab.merge (K true) (seen1, seen2));
  11.361 -);
  11.362 -
  11.363 -val lookup_cache = Thmtab.lookup o #1 o ThmCache.get;
  11.364 -val already_seen = Symtab.defined o #2 o ThmCache.get;
  11.365 -
  11.366 -val update_cache = ThmCache.map o apfst o Thmtab.update;
  11.367 -fun mark_seen name = ThmCache.map (apsnd (Symtab.update (name, ())));
  11.368 -
  11.369 -(*Exported function to convert Isabelle theorems into axiom clauses*)
  11.370 -fun cnf_axiom thy th0 =
  11.371 -  let val th = Thm.transfer thy th0 in
  11.372 -    case lookup_cache thy th of
  11.373 -      NONE => map Thm.close_derivation (skolem_thm (fake_name th, th))
  11.374 -    | SOME cls => cls
  11.375 -  end;
  11.376 -
  11.377 -
  11.378 -(**** Rules from the context ****)
  11.379 -
  11.380 -fun pairname th = (Thm.get_name_hint th, th);
  11.381 -
  11.382 -
  11.383 -(**** Translate a set of theorems into CNF ****)
  11.384 -
  11.385 -fun pair_name_cls k (n, []) = []
  11.386 -  | pair_name_cls k (n, cls::clss) = (cls, (n,k)) :: pair_name_cls (k+1) (n, clss)
  11.387 -
  11.388 -fun cnf_rules_pairs_aux _ pairs [] = pairs
  11.389 -  | cnf_rules_pairs_aux thy pairs ((name,th)::ths) =
  11.390 -      let val pairs' = (pair_name_cls 0 (name, cnf_axiom thy th)) @ pairs
  11.391 -                       handle THM _ => pairs | Res_Clause.CLAUSE _ => pairs
  11.392 -      in  cnf_rules_pairs_aux thy pairs' ths  end;
  11.393 -
  11.394 -(*The combination of rev and tail recursion preserves the original order*)
  11.395 -fun cnf_rules_pairs thy l = cnf_rules_pairs_aux thy [] (rev l);
  11.396 -
  11.397 -
  11.398 -(**** Convert all facts of the theory into clauses (Res_Clause.clause, or Res_HOL_Clause.clause) ****)
  11.399 -
  11.400 -local
  11.401 -
  11.402 -fun skolem_def (name, th) thy =
  11.403 -  let val ctxt0 = Variable.thm_context th in
  11.404 -    (case try (to_nnf th) ctxt0 of
  11.405 -      NONE => (NONE, thy)
  11.406 -    | SOME (nnfth, ctxt1) =>
  11.407 -        let val (defs, thy') = declare_skofuns (flatten_name name) nnfth thy
  11.408 -        in (SOME (th, ctxt0, ctxt1, nnfth, defs), thy') end)
  11.409 -  end;
  11.410 -
  11.411 -fun skolem_cnfs (th, ctxt0, ctxt1, nnfth, defs) =
  11.412 -  let
  11.413 -    val (cnfs, ctxt2) = Meson.make_cnf (map skolem_of_def defs) nnfth ctxt1;
  11.414 -    val cnfs' = cnfs
  11.415 -      |> map combinators
  11.416 -      |> Variable.export ctxt2 ctxt0
  11.417 -      |> Meson.finish_cnf
  11.418 -      |> map Thm.close_derivation;
  11.419 -    in (th, cnfs') end;
  11.420 -
  11.421 -in
  11.422 -
  11.423 -fun saturate_skolem_cache thy =
  11.424 -  let
  11.425 -    val facts = PureThy.facts_of thy;
  11.426 -    val new_facts = (facts, []) |-> Facts.fold_static (fn (name, ths) =>
  11.427 -      if Facts.is_concealed facts name orelse already_seen thy name then I
  11.428 -      else cons (name, ths));
  11.429 -    val new_thms = (new_facts, []) |-> fold (fn (name, ths) =>
  11.430 -      if member (op =) multi_base_blacklist (Long_Name.base_name name) then I
  11.431 -      else fold_index (fn (i, th) =>
  11.432 -        if bad_for_atp th orelse is_some (lookup_cache thy th) then I
  11.433 -        else cons (name ^ "_" ^ string_of_int (i + 1), Thm.transfer thy th)) ths);
  11.434 -  in
  11.435 -    if null new_facts then NONE
  11.436 -    else
  11.437 -      let
  11.438 -        val (defs, thy') = thy
  11.439 -          |> fold (mark_seen o #1) new_facts
  11.440 -          |> fold_map skolem_def (sort_distinct (Thm.thm_ord o pairself snd) new_thms)
  11.441 -          |>> map_filter I;
  11.442 -        val cache_entries = Par_List.map skolem_cnfs defs;
  11.443 -      in SOME (fold update_cache cache_entries thy') end
  11.444 -  end;
  11.445 -
  11.446 -end;
  11.447 -
  11.448 -val suppress_endtheory = Unsynchronized.ref false;
  11.449 -
  11.450 -fun clause_cache_endtheory thy =
  11.451 -  if ! suppress_endtheory then NONE
  11.452 -  else saturate_skolem_cache thy;
  11.453 -
  11.454 -
  11.455 -(*The cache can be kept smaller by inspecting the prop of each thm. Can ignore all that are
  11.456 -  lambda_free, but then the individual theory caches become much bigger.*)
  11.457 -
  11.458 -
  11.459 -(*** meson proof methods ***)
  11.460 -
  11.461 -(*Expand all new definitions of abstraction or Skolem functions in a proof state.*)
  11.462 -fun is_absko (Const ("==", _) $ Free (a,_) $ u) = String.isPrefix "sko_" a
  11.463 -  | is_absko _ = false;
  11.464 -
  11.465 -fun is_okdef xs (Const ("==", _) $ t $ u) =   (*Definition of Free, not in certain terms*)
  11.466 -      is_Free t andalso not (member (op aconv) xs t)
  11.467 -  | is_okdef _ _ = false
  11.468 -
  11.469 -(*This function tries to cope with open locales, which introduce hypotheses of the form
  11.470 -  Free == t, conjecture clauses, which introduce various hypotheses, and also definitions
  11.471 -  of sko_ functions. *)
  11.472 -fun expand_defs_tac st0 st =
  11.473 -  let val hyps0 = #hyps (rep_thm st0)
  11.474 -      val hyps = #hyps (crep_thm st)
  11.475 -      val newhyps = filter_out (member (op aconv) hyps0 o Thm.term_of) hyps
  11.476 -      val defs = filter (is_absko o Thm.term_of) newhyps
  11.477 -      val remaining_hyps = filter_out (member (op aconv) (map Thm.term_of defs))
  11.478 -                                      (map Thm.term_of hyps)
  11.479 -      val fixed = OldTerm.term_frees (concl_of st) @
  11.480 -                  fold (union (op aconv)) (map OldTerm.term_frees remaining_hyps) []
  11.481 -  in Seq.of_list [Local_Defs.expand (filter (is_okdef fixed o Thm.term_of) defs) st] end;
  11.482 -
  11.483 -
  11.484 -fun meson_general_tac ctxt ths i st0 =
  11.485 -  let
  11.486 -    val thy = ProofContext.theory_of ctxt
  11.487 -    val ctxt0 = Classical.put_claset HOL_cs ctxt
  11.488 -  in (Meson.meson_tac ctxt0 (maps (cnf_axiom thy) ths) i THEN expand_defs_tac st0) st0 end;
  11.489 -
  11.490 -val meson_method_setup =
  11.491 -  Method.setup @{binding meson} (Attrib.thms >> (fn ths => fn ctxt =>
  11.492 -    SIMPLE_METHOD' (CHANGED_PROP o meson_general_tac ctxt ths)))
  11.493 -    "MESON resolution proof procedure";
  11.494 -
  11.495 -
  11.496 -(*** Converting a subgoal into negated conjecture clauses. ***)
  11.497 -
  11.498 -fun neg_skolemize_tac ctxt =
  11.499 -  EVERY' [rtac ccontr, Object_Logic.atomize_prems_tac, Meson.skolemize_tac ctxt];
  11.500 -
  11.501 -val neg_clausify = Meson.make_clauses #> map combinators #> Meson.finish_cnf;
  11.502 -
  11.503 -fun neg_conjecture_clauses ctxt st0 n =
  11.504 -  let
  11.505 -    val st = Seq.hd (neg_skolemize_tac ctxt n st0)
  11.506 -    val ({params, prems, ...}, _) = Subgoal.focus (Variable.set_body false ctxt) n st
  11.507 -  in (neg_clausify prems, map (Term.dest_Free o Thm.term_of o #2) params) end;
  11.508 -
  11.509 -(*Conversion of a subgoal to conjecture clauses. Each clause has
  11.510 -  leading !!-bound universal variables, to express generality. *)
  11.511 -fun neg_clausify_tac ctxt =
  11.512 -  neg_skolemize_tac ctxt THEN'
  11.513 -  SUBGOAL (fn (prop, i) =>
  11.514 -    let val ts = Logic.strip_assums_hyp prop in
  11.515 -      EVERY'
  11.516 -       [Subgoal.FOCUS
  11.517 -         (fn {prems, ...} =>
  11.518 -           (Method.insert_tac
  11.519 -             (map forall_intr_vars (neg_clausify prems)) i)) ctxt,
  11.520 -        REPEAT_DETERM_N (length ts) o etac thin_rl] i
  11.521 -     end);
  11.522 -
  11.523 -val neg_clausify_setup =
  11.524 -  Method.setup @{binding neg_clausify} (Scan.succeed (SIMPLE_METHOD' o neg_clausify_tac))
  11.525 -  "conversion of goal to conjecture clauses";
  11.526 -
  11.527 -
  11.528 -(** Attribute for converting a theorem into clauses **)
  11.529 -
  11.530 -val clausify_setup =
  11.531 -  Attrib.setup @{binding clausify}
  11.532 -    (Scan.lift OuterParse.nat >>
  11.533 -      (fn i => Thm.rule_attribute (fn context => fn th =>
  11.534 -          Meson.make_meta_clause (nth (cnf_axiom (Context.theory_of context) th) i))))
  11.535 -  "conversion of theorem to clauses";
  11.536 -
  11.537 -
  11.538 -
  11.539 -(** setup **)
  11.540 -
  11.541 -val setup =
  11.542 -  meson_method_setup #>
  11.543 -  neg_clausify_setup #>
  11.544 -  clausify_setup #>
  11.545 -  perhaps saturate_skolem_cache #>
  11.546 -  Theory.at_end clause_cache_endtheory;
  11.547 -
  11.548 -end;
    12.1 --- a/src/HOL/Tools/res_clause.ML	Wed Mar 17 17:23:45 2010 +0100
    12.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.3 @@ -1,534 +0,0 @@
    12.4 -(*  Title:      HOL/Tools/res_clause.ML
    12.5 -    Author:     Jia Meng, Cambridge University Computer Laboratory
    12.6 -
    12.7 -Storing/printing FOL clauses and arity clauses.  Typed equality is
    12.8 -treated differently.
    12.9 -
   12.10 -FIXME: combine with res_hol_clause!
   12.11 -*)
   12.12 -
   12.13 -signature RES_CLAUSE =
   12.14 -sig
   12.15 -  val schematic_var_prefix: string
   12.16 -  val fixed_var_prefix: string
   12.17 -  val tvar_prefix: string
   12.18 -  val tfree_prefix: string
   12.19 -  val clause_prefix: string
   12.20 -  val const_prefix: string
   12.21 -  val tconst_prefix: string
   12.22 -  val class_prefix: string
   12.23 -  val union_all: ''a list list -> ''a list
   12.24 -  val const_trans_table: string Symtab.table
   12.25 -  val type_const_trans_table: string Symtab.table
   12.26 -  val ascii_of: string -> string
   12.27 -  val undo_ascii_of: string -> string
   12.28 -  val paren_pack : string list -> string
   12.29 -  val make_schematic_var : string * int -> string
   12.30 -  val make_fixed_var : string -> string
   12.31 -  val make_schematic_type_var : string * int -> string
   12.32 -  val make_fixed_type_var : string -> string
   12.33 -  val make_fixed_const : bool -> string -> string
   12.34 -  val make_fixed_type_const : bool -> string -> string
   12.35 -  val make_type_class : string -> string
   12.36 -  datatype kind = Axiom | Conjecture
   12.37 -  type axiom_name = string
   12.38 -  datatype fol_type =
   12.39 -      AtomV of string
   12.40 -    | AtomF of string
   12.41 -    | Comp of string * fol_type list
   12.42 -  val string_of_fol_type : fol_type -> string
   12.43 -  datatype type_literal = LTVar of string * string | LTFree of string * string
   12.44 -  exception CLAUSE of string * term
   12.45 -  val add_typs : typ list -> type_literal list
   12.46 -  val get_tvar_strs: typ list -> string list
   12.47 -  datatype arLit =
   12.48 -      TConsLit of class * string * string list
   12.49 -    | TVarLit of class * string
   12.50 -  datatype arityClause = ArityClause of
   12.51 -   {axiom_name: axiom_name, conclLit: arLit, premLits: arLit list}
   12.52 -  datatype classrelClause = ClassrelClause of
   12.53 -   {axiom_name: axiom_name, subclass: class, superclass: class}
   12.54 -  val make_classrel_clauses: theory -> class list -> class list -> classrelClause list
   12.55 -  val make_arity_clauses_dfg: bool -> theory -> string list -> class list -> class list * arityClause list
   12.56 -  val make_arity_clauses: theory -> string list -> class list -> class list * arityClause list
   12.57 -  val add_type_sort_preds: typ * int Symtab.table -> int Symtab.table
   12.58 -  val add_classrelClause_preds : classrelClause * int Symtab.table -> int Symtab.table
   12.59 -  val class_of_arityLit: arLit -> class
   12.60 -  val add_arityClause_preds: arityClause * int Symtab.table -> int Symtab.table
   12.61 -  val add_foltype_funcs: fol_type * int Symtab.table -> int Symtab.table
   12.62 -  val add_arityClause_funcs: arityClause * int Symtab.table -> int Symtab.table
   12.63 -  val init_functab: int Symtab.table
   12.64 -  val dfg_sign: bool -> string -> string
   12.65 -  val dfg_of_typeLit: bool -> type_literal -> string
   12.66 -  val gen_dfg_cls: int * string * kind * string list * string list * string list -> string
   12.67 -  val string_of_preds: (string * Int.int) list -> string
   12.68 -  val string_of_funcs: (string * int) list -> string
   12.69 -  val string_of_symbols: string -> string -> string
   12.70 -  val string_of_start: string -> string
   12.71 -  val string_of_descrip : string -> string
   12.72 -  val dfg_tfree_clause : string -> string
   12.73 -  val dfg_classrelClause: classrelClause -> string
   12.74 -  val dfg_arity_clause: arityClause -> string
   12.75 -  val tptp_sign: bool -> string -> string
   12.76 -  val tptp_of_typeLit : bool -> type_literal -> string
   12.77 -  val gen_tptp_cls : int * string * kind * string list * string list -> string
   12.78 -  val tptp_tfree_clause : string -> string
   12.79 -  val tptp_arity_clause : arityClause -> string
   12.80 -  val tptp_classrelClause : classrelClause -> string
   12.81 -end
   12.82 -
   12.83 -structure Res_Clause: RES_CLAUSE =
   12.84 -struct
   12.85 -
   12.86 -val schematic_var_prefix = "V_";
   12.87 -val fixed_var_prefix = "v_";
   12.88 -
   12.89 -val tvar_prefix = "T_";
   12.90 -val tfree_prefix = "t_";
   12.91 -
   12.92 -val clause_prefix = "cls_";
   12.93 -val arclause_prefix = "clsarity_"
   12.94 -val clrelclause_prefix = "clsrel_";
   12.95 -
   12.96 -val const_prefix = "c_";
   12.97 -val tconst_prefix = "tc_";
   12.98 -val class_prefix = "class_";
   12.99 -
  12.100 -fun union_all xss = List.foldl (uncurry (union (op =))) [] xss;
  12.101 -
  12.102 -(*Provide readable names for the more common symbolic functions*)
  12.103 -val const_trans_table =
  12.104 -      Symtab.make [(@{const_name "op ="}, "equal"),
  12.105 -                   (@{const_name Orderings.less_eq}, "lessequals"),
  12.106 -                   (@{const_name "op &"}, "and"),
  12.107 -                   (@{const_name "op |"}, "or"),
  12.108 -                   (@{const_name "op -->"}, "implies"),
  12.109 -                   (@{const_name "op :"}, "in"),
  12.110 -                   ("ATP_Linkup.fequal", "fequal"),
  12.111 -                   ("ATP_Linkup.COMBI", "COMBI"),
  12.112 -                   ("ATP_Linkup.COMBK", "COMBK"),
  12.113 -                   ("ATP_Linkup.COMBB", "COMBB"),
  12.114 -                   ("ATP_Linkup.COMBC", "COMBC"),
  12.115 -                   ("ATP_Linkup.COMBS", "COMBS"),
  12.116 -                   ("ATP_Linkup.COMBB'", "COMBB_e"),
  12.117 -                   ("ATP_Linkup.COMBC'", "COMBC_e"),
  12.118 -                   ("ATP_Linkup.COMBS'", "COMBS_e")];
  12.119 -
  12.120 -val type_const_trans_table =
  12.121 -      Symtab.make [("*", "prod"),
  12.122 -                   ("+", "sum"),
  12.123 -                   ("~=>", "map")];
  12.124 -
  12.125 -(*Escaping of special characters.
  12.126 -  Alphanumeric characters are left unchanged.
  12.127 -  The character _ goes to __
  12.128 -  Characters in the range ASCII space to / go to _A to _P, respectively.
  12.129 -  Other printing characters go to _nnn where nnn is the decimal ASCII code.*)
  12.130 -val A_minus_space = Char.ord #"A" - Char.ord #" ";
  12.131 -
  12.132 -fun stringN_of_int 0 _ = ""
  12.133 -  | stringN_of_int k n = stringN_of_int (k-1) (n div 10) ^ Int.toString (n mod 10);
  12.134 -
  12.135 -fun ascii_of_c c =
  12.136 -  if Char.isAlphaNum c then String.str c
  12.137 -  else if c = #"_" then "__"
  12.138 -  else if #" " <= c andalso c <= #"/"
  12.139 -       then "_" ^ String.str (Char.chr (Char.ord c + A_minus_space))
  12.140 -  else if Char.isPrint c
  12.141 -       then ("_" ^ stringN_of_int 3 (Char.ord c))  (*fixed width, in case more digits follow*)
  12.142 -  else ""
  12.143 -
  12.144 -val ascii_of = String.translate ascii_of_c;
  12.145 -
  12.146 -(** Remove ASCII armouring from names in proof files **)
  12.147 -
  12.148 -(*We don't raise error exceptions because this code can run inside the watcher.
  12.149 -  Also, the errors are "impossible" (hah!)*)
  12.150 -fun undo_ascii_aux rcs [] = String.implode(rev rcs)
  12.151 -  | undo_ascii_aux rcs [#"_"] = undo_ascii_aux (#"_"::rcs) []  (*ERROR*)
  12.152 -      (*Three types of _ escapes: __, _A to _P, _nnn*)
  12.153 -  | undo_ascii_aux rcs (#"_" :: #"_" :: cs) = undo_ascii_aux (#"_"::rcs) cs
  12.154 -  | undo_ascii_aux rcs (#"_" :: c :: cs) =
  12.155 -      if #"A" <= c andalso c<= #"P"  (*translation of #" " to #"/"*)
  12.156 -      then undo_ascii_aux (Char.chr(Char.ord c - A_minus_space) :: rcs) cs
  12.157 -      else
  12.158 -        let val digits = List.take (c::cs, 3) handle Subscript => []
  12.159 -        in
  12.160 -            case Int.fromString (String.implode digits) of
  12.161 -                NONE => undo_ascii_aux (c:: #"_"::rcs) cs  (*ERROR*)
  12.162 -              | SOME n => undo_ascii_aux (Char.chr n :: rcs) (List.drop (cs, 2))
  12.163 -        end
  12.164 -  | undo_ascii_aux rcs (c::cs) = undo_ascii_aux (c::rcs) cs;
  12.165 -
  12.166 -val undo_ascii_of = undo_ascii_aux [] o String.explode;
  12.167 -
  12.168 -(* convert a list of strings into one single string; surrounded by brackets *)
  12.169 -fun paren_pack [] = ""   (*empty argument list*)
  12.170 -  | paren_pack strings = "(" ^ commas strings ^ ")";
  12.171 -
  12.172 -(*TSTP format uses (...) rather than the old [...]*)
  12.173 -fun tptp_pack strings = "(" ^ space_implode " | " strings ^ ")";
  12.174 -
  12.175 -
  12.176 -(*Remove the initial ' character from a type variable, if it is present*)
  12.177 -fun trim_type_var s =
  12.178 -  if s <> "" andalso String.sub(s,0) = #"'" then String.extract(s,1,NONE)
  12.179 -  else error ("trim_type: Malformed type variable encountered: " ^ s);
  12.180 -
  12.181 -fun ascii_of_indexname (v,0) = ascii_of v
  12.182 -  | ascii_of_indexname (v,i) = ascii_of v ^ "_" ^ Int.toString i;
  12.183 -
  12.184 -fun make_schematic_var v = schematic_var_prefix ^ (ascii_of_indexname v);
  12.185 -fun make_fixed_var x = fixed_var_prefix ^ (ascii_of x);
  12.186 -
  12.187 -fun make_schematic_type_var (x,i) =
  12.188 -      tvar_prefix ^ (ascii_of_indexname (trim_type_var x,i));
  12.189 -fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (trim_type_var x));
  12.190 -
  12.191 -(*HACK because SPASS truncates identifiers to 63 characters :-(( *)
  12.192 -(*32-bit hash,so we expect no collisions unless there are around 65536 long identifiers...*)
  12.193 -fun controlled_length dfg_format s =
  12.194 -  if size s > 60 andalso dfg_format
  12.195 -  then Word.toString (Polyhash.hashw_string(s,0w0))
  12.196 -  else s;
  12.197 -
  12.198 -fun lookup_const dfg c =
  12.199 -    case Symtab.lookup const_trans_table c of
  12.200 -        SOME c' => c'
  12.201 -      | NONE => controlled_length dfg (ascii_of c);
  12.202 -
  12.203 -fun lookup_type_const dfg c =
  12.204 -    case Symtab.lookup type_const_trans_table c of
  12.205 -        SOME c' => c'
  12.206 -      | NONE => controlled_length dfg (ascii_of c);
  12.207 -
  12.208 -fun make_fixed_const _ "op =" = "equal"   (*MUST BE "equal" because it's built-in to ATPs*)
  12.209 -  | make_fixed_const dfg c      = const_prefix ^ lookup_const dfg c;
  12.210 -
  12.211 -fun make_fixed_type_const dfg c = tconst_prefix ^ lookup_type_const dfg c;
  12.212 -
  12.213 -fun make_type_class clas = class_prefix ^ ascii_of clas;
  12.214 -
  12.215 -
  12.216 -(***** definitions and functions for FOL clauses, for conversion to TPTP or DFG format. *****)
  12.217 -
  12.218 -datatype kind = Axiom | Conjecture;
  12.219 -
  12.220 -type axiom_name = string;
  12.221 -
  12.222 -(**** Isabelle FOL clauses ****)
  12.223 -
  12.224 -(*FIXME: give the constructors more sensible names*)
  12.225 -datatype fol_type = AtomV of string
  12.226 -                  | AtomF of string
  12.227 -                  | Comp of string * fol_type list;
  12.228 -
  12.229 -fun string_of_fol_type (AtomV x) = x
  12.230 -  | string_of_fol_type (AtomF x) = x
  12.231 -  | string_of_fol_type (Comp(tcon,tps)) =
  12.232 -      tcon ^ (paren_pack (map string_of_fol_type tps));
  12.233 -
  12.234 -(*First string is the type class; the second is a TVar or TFfree*)
  12.235 -datatype type_literal = LTVar of string * string | LTFree of string * string;
  12.236 -
  12.237 -exception CLAUSE of string * term;
  12.238 -
  12.239 -fun atomic_type (TFree (a,_)) = AtomF(make_fixed_type_var a)
  12.240 -  | atomic_type (TVar (v,_))  = AtomV(make_schematic_type_var v);
  12.241 -
  12.242 -(*Flatten a type to a fol_type while accumulating sort constraints on the TFrees and
  12.243 -  TVars it contains.*)
  12.244 -fun type_of dfg (Type (a, Ts)) =
  12.245 -      let val (folTyps, ts) = types_of dfg Ts
  12.246 -          val t = make_fixed_type_const dfg a
  12.247 -      in (Comp(t,folTyps), ts) end
  12.248 -  | type_of dfg T = (atomic_type T, [T])
  12.249 -and types_of dfg Ts =
  12.250 -      let val (folTyps,ts) = ListPair.unzip (map (type_of dfg) Ts)
  12.251 -      in (folTyps, union_all ts) end;
  12.252 -
  12.253 -(*Make literals for sorted type variables*)
  12.254 -fun sorts_on_typs_aux (_, [])   = []
  12.255 -  | sorts_on_typs_aux ((x,i),  s::ss) =
  12.256 -      let val sorts = sorts_on_typs_aux ((x,i), ss)
  12.257 -      in
  12.258 -          if s = "HOL.type" then sorts
  12.259 -          else if i = ~1 then LTFree(make_type_class s, make_fixed_type_var x) :: sorts
  12.260 -          else LTVar(make_type_class s, make_schematic_type_var (x,i)) :: sorts
  12.261 -      end;
  12.262 -
  12.263 -fun sorts_on_typs (TFree (a,s)) = sorts_on_typs_aux ((a,~1),s)
  12.264 -  | sorts_on_typs (TVar (v,s))  = sorts_on_typs_aux (v,s);
  12.265 -
  12.266 -fun pred_of_sort (LTVar (s,ty)) = (s,1)
  12.267 -  | pred_of_sort (LTFree (s,ty)) = (s,1)
  12.268 -
  12.269 -(*Given a list of sorted type variables, return a list of type literals.*)
  12.270 -fun add_typs Ts = List.foldl (uncurry (union (op =))) [] (map sorts_on_typs Ts);
  12.271 -
  12.272 -(*The correct treatment of TFrees like 'a in lemmas (axiom clauses) is not clear.
  12.273 -  * Ignoring them leads to unsound proofs, since we do nothing to ensure that 'a
  12.274 -    in a lemma has the same sort as 'a in the conjecture.
  12.275 -  * Deleting such clauses will lead to problems with locales in other use of local results
  12.276 -    where 'a is fixed. Probably we should delete clauses unless the sorts agree.
  12.277 -  * Currently we include a class constraint in the clause, exactly as with TVars.
  12.278 -*)
  12.279 -
  12.280 -(** make axiom and conjecture clauses. **)
  12.281 -
  12.282 -fun get_tvar_strs [] = []
  12.283 -  | get_tvar_strs ((TVar (indx,s))::Ts) =
  12.284 -      insert (op =) (make_schematic_type_var indx) (get_tvar_strs Ts)
  12.285 -  | get_tvar_strs((TFree _)::Ts) = get_tvar_strs Ts
  12.286 -
  12.287 -
  12.288 -
  12.289 -(**** Isabelle arities ****)
  12.290 -
  12.291 -exception ARCLAUSE of string;
  12.292 -
  12.293 -datatype arLit = TConsLit of class * string * string list
  12.294 -               | TVarLit of class * string;
  12.295 -
  12.296 -datatype arityClause =
  12.297 -         ArityClause of {axiom_name: axiom_name,
  12.298 -                         conclLit: arLit,
  12.299 -                         premLits: arLit list};
  12.300 -
  12.301 -
  12.302 -fun gen_TVars 0 = []
  12.303 -  | gen_TVars n = ("T_" ^ Int.toString n) :: gen_TVars (n-1);
  12.304 -
  12.305 -fun pack_sort(_,[])  = []
  12.306 -  | pack_sort(tvar, "HOL.type"::srt) = pack_sort(tvar, srt)   (*IGNORE sort "type"*)
  12.307 -  | pack_sort(tvar, cls::srt) =  (cls, tvar) :: pack_sort(tvar, srt);
  12.308 -
  12.309 -(*Arity of type constructor tcon :: (arg1,...,argN)res*)
  12.310 -fun make_axiom_arity_clause dfg (tcons, axiom_name, (cls,args)) =
  12.311 -   let val tvars = gen_TVars (length args)
  12.312 -       val tvars_srts = ListPair.zip (tvars,args)
  12.313 -   in
  12.314 -      ArityClause {axiom_name = axiom_name, 
  12.315 -                   conclLit = TConsLit (cls, make_fixed_type_const dfg tcons, tvars),
  12.316 -                   premLits = map TVarLit (union_all(map pack_sort tvars_srts))}
  12.317 -   end;
  12.318 -
  12.319 -
  12.320 -(**** Isabelle class relations ****)
  12.321 -
  12.322 -datatype classrelClause =
  12.323 -         ClassrelClause of {axiom_name: axiom_name,
  12.324 -                            subclass: class,
  12.325 -                            superclass: class};
  12.326 -
  12.327 -(*Generate all pairs (sub,super) such that sub is a proper subclass of super in theory thy.*)
  12.328 -fun class_pairs thy [] supers = []
  12.329 -  | class_pairs thy subs supers =
  12.330 -      let val class_less = Sorts.class_less(Sign.classes_of thy)
  12.331 -          fun add_super sub (super,pairs) =
  12.332 -                if class_less (sub,super) then (sub,super)::pairs else pairs
  12.333 -          fun add_supers (sub,pairs) = List.foldl (add_super sub) pairs supers
  12.334 -      in  List.foldl add_supers [] subs  end;
  12.335 -
  12.336 -fun make_classrelClause (sub,super) =
  12.337 -  ClassrelClause {axiom_name = clrelclause_prefix ^ ascii_of sub ^ "_" ^ ascii_of super,
  12.338 -                  subclass = make_type_class sub,
  12.339 -                  superclass = make_type_class super};
  12.340 -
  12.341 -fun make_classrel_clauses thy subs supers =
  12.342 -  map make_classrelClause (class_pairs thy subs supers);
  12.343 -
  12.344 -
  12.345 -(** Isabelle arities **)
  12.346 -
  12.347 -fun arity_clause dfg _ _ (tcons, []) = []
  12.348 -  | arity_clause dfg seen n (tcons, ("HOL.type",_)::ars) =  (*ignore*)
  12.349 -      arity_clause dfg seen n (tcons,ars)
  12.350 -  | arity_clause dfg seen n (tcons, (ar as (class,_)) :: ars) =
  12.351 -      if class mem_string seen then (*multiple arities for the same tycon, class pair*)
  12.352 -          make_axiom_arity_clause dfg (tcons, lookup_type_const dfg tcons ^ "_" ^ class ^ "_" ^ Int.toString n, ar) ::
  12.353 -          arity_clause dfg seen (n+1) (tcons,ars)
  12.354 -      else
  12.355 -          make_axiom_arity_clause dfg (tcons, lookup_type_const dfg tcons ^ "_" ^ class, ar) ::
  12.356 -          arity_clause dfg (class::seen) n (tcons,ars)
  12.357 -
  12.358 -fun multi_arity_clause dfg [] = []
  12.359 -  | multi_arity_clause dfg ((tcons,ars) :: tc_arlists) =
  12.360 -      arity_clause dfg [] 1 (tcons, ars)  @  multi_arity_clause dfg tc_arlists
  12.361 -
  12.362 -(*Generate all pairs (tycon,class,sorts) such that tycon belongs to class in theory thy
  12.363 -  provided its arguments have the corresponding sorts.*)
  12.364 -fun type_class_pairs thy tycons classes =
  12.365 -  let val alg = Sign.classes_of thy
  12.366 -      fun domain_sorts (tycon,class) = Sorts.mg_domain alg tycon [class]
  12.367 -      fun add_class tycon (class,pairs) =
  12.368 -            (class, domain_sorts(tycon,class))::pairs
  12.369 -            handle Sorts.CLASS_ERROR _ => pairs
  12.370 -      fun try_classes tycon = (tycon, List.foldl (add_class tycon) [] classes)
  12.371 -  in  map try_classes tycons  end;
  12.372 -
  12.373 -(*Proving one (tycon, class) membership may require proving others, so iterate.*)
  12.374 -fun iter_type_class_pairs thy tycons [] = ([], [])
  12.375 -  | iter_type_class_pairs thy tycons classes =
  12.376 -      let val cpairs = type_class_pairs thy tycons classes
  12.377 -          val newclasses = union_all (union_all (union_all (map (map #2 o #2) cpairs)))
  12.378 -            |> subtract (op =) classes |> subtract (op =) HOLogic.typeS
  12.379 -          val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses
  12.380 -      in (union (op =) classes' classes, union (op =) cpairs' cpairs) end;
  12.381 -
  12.382 -fun make_arity_clauses_dfg dfg thy tycons classes =
  12.383 -  let val (classes', cpairs) = iter_type_class_pairs thy tycons classes
  12.384 -  in  (classes', multi_arity_clause dfg cpairs)  end;
  12.385 -val make_arity_clauses = make_arity_clauses_dfg false;
  12.386 -
  12.387 -(**** Find occurrences of predicates in clauses ****)
  12.388 -
  12.389 -(*FIXME: multiple-arity checking doesn't work, as update_new is the wrong
  12.390 -  function (it flags repeated declarations of a function, even with the same arity)*)
  12.391 -
  12.392 -fun update_many (tab, keypairs) = List.foldl (uncurry Symtab.update) tab keypairs;
  12.393 -
  12.394 -fun add_type_sort_preds (T, preds) =
  12.395 -      update_many (preds, map pred_of_sort (sorts_on_typs T));
  12.396 -
  12.397 -fun add_classrelClause_preds (ClassrelClause {subclass,superclass,...}, preds) =
  12.398 -  Symtab.update (subclass,1) (Symtab.update (superclass,1) preds);
  12.399 -
  12.400 -fun class_of_arityLit (TConsLit (tclass, _, _)) = tclass
  12.401 -  | class_of_arityLit (TVarLit (tclass, _)) = tclass;
  12.402 -
  12.403 -fun add_arityClause_preds (ArityClause {conclLit,premLits,...}, preds) =
  12.404 -  let val classes = map (make_type_class o class_of_arityLit) (conclLit::premLits)
  12.405 -      fun upd (class,preds) = Symtab.update (class,1) preds
  12.406 -  in  List.foldl upd preds classes  end;
  12.407 -
  12.408 -(*** Find occurrences of functions in clauses ***)
  12.409 -
  12.410 -fun add_foltype_funcs (AtomV _, funcs) = funcs
  12.411 -  | add_foltype_funcs (AtomF a, funcs) = Symtab.update (a,0) funcs
  12.412 -  | add_foltype_funcs (Comp(a,tys), funcs) =
  12.413 -      List.foldl add_foltype_funcs (Symtab.update (a, length tys) funcs) tys;
  12.414 -
  12.415 -(*TFrees are recorded as constants*)
  12.416 -fun add_type_sort_funcs (TVar _, funcs) = funcs
  12.417 -  | add_type_sort_funcs (TFree (a, _), funcs) =
  12.418 -      Symtab.update (make_fixed_type_var a, 0) funcs
  12.419 -
  12.420 -fun add_arityClause_funcs (ArityClause {conclLit,...}, funcs) =
  12.421 -  let val TConsLit (_, tcons, tvars) = conclLit
  12.422 -  in  Symtab.update (tcons, length tvars) funcs  end;
  12.423 -
  12.424 -(*This type can be overlooked because it is built-in...*)
  12.425 -val init_functab = Symtab.update ("tc_itself", 1) Symtab.empty;
  12.426 -
  12.427 -
  12.428 -(**** String-oriented operations ****)
  12.429 -
  12.430 -fun string_of_clausename (cls_id,ax_name) =
  12.431 -    clause_prefix ^ ascii_of ax_name ^ "_" ^ Int.toString cls_id;
  12.432 -
  12.433 -fun string_of_type_clsname (cls_id,ax_name,idx) =
  12.434 -    string_of_clausename (cls_id,ax_name) ^ "_tcs" ^ (Int.toString idx);
  12.435 -
  12.436 -
  12.437 -(**** Producing DFG files ****)
  12.438 -
  12.439 -(*Attach sign in DFG syntax: false means negate.*)
  12.440 -fun dfg_sign true s = s
  12.441 -  | dfg_sign false s = "not(" ^ s ^ ")"
  12.442 -
  12.443 -fun dfg_of_typeLit pos (LTVar (s,ty))  = dfg_sign pos (s ^ "(" ^ ty ^ ")")
  12.444 -  | dfg_of_typeLit pos (LTFree (s,ty)) = dfg_sign pos (s ^ "(" ^ ty ^ ")");
  12.445 -
  12.446 -(*Enclose the clause body by quantifiers, if necessary*)
  12.447 -fun dfg_forall [] body = body
  12.448 -  | dfg_forall vars body = "forall([" ^ commas vars ^ "],\n" ^ body ^ ")"
  12.449 -
  12.450 -fun gen_dfg_cls (cls_id, ax_name, Axiom, lits, tylits, vars) =
  12.451 -      "clause( %(axiom)\n" ^
  12.452 -      dfg_forall vars ("or(" ^ commas (tylits@lits) ^ ")") ^ ",\n" ^
  12.453 -      string_of_clausename (cls_id,ax_name) ^  ").\n\n"
  12.454 -  | gen_dfg_cls (cls_id, ax_name, Conjecture, lits, _, vars) =
  12.455 -      "clause( %(negated_conjecture)\n" ^
  12.456 -      dfg_forall vars ("or(" ^ commas lits ^ ")") ^ ",\n" ^
  12.457 -      string_of_clausename (cls_id,ax_name) ^  ").\n\n";
  12.458 -
  12.459 -fun string_of_arity (name, num) =  "(" ^ name ^ "," ^ Int.toString num ^ ")"
  12.460 -
  12.461 -fun string_of_preds [] = ""
  12.462 -  | string_of_preds preds = "predicates[" ^ commas(map string_of_arity preds) ^ "].\n";
  12.463 -
  12.464 -fun string_of_funcs [] = ""
  12.465 -  | string_of_funcs funcs = "functions[" ^ commas(map string_of_arity funcs) ^ "].\n" ;
  12.466 -
  12.467 -fun string_of_symbols predstr funcstr =
  12.468 -  "list_of_symbols.\n" ^ predstr  ^ funcstr  ^ "end_of_list.\n\n";
  12.469 -
  12.470 -fun string_of_start name = "begin_problem(" ^ name ^ ").\n\n";
  12.471 -
  12.472 -fun string_of_descrip name =
  12.473 -  "list_of_descriptions.\nname({*" ^ name ^
  12.474 -  "*}).\nauthor({*Isabelle*}).\nstatus(unknown).\ndescription({*auto-generated*}).\nend_of_list.\n\n"
  12.475 -
  12.476 -fun dfg_tfree_clause tfree_lit =
  12.477 -  "clause( %(negated_conjecture)\n" ^ "or( " ^ tfree_lit ^ "),\n" ^ "tfree_tcs" ^ ").\n\n"
  12.478 -
  12.479 -fun dfg_of_arLit (TConsLit (c,t,args)) =
  12.480 -      dfg_sign true (make_type_class c ^ "(" ^ t ^ paren_pack args ^ ")")
  12.481 -  | dfg_of_arLit (TVarLit (c,str)) =
  12.482 -      dfg_sign false (make_type_class c ^ "(" ^ str ^ ")")
  12.483 -
  12.484 -fun dfg_classrelLits sub sup =  "not(" ^ sub ^ "(T)), " ^ sup ^ "(T)";
  12.485 -
  12.486 -fun dfg_classrelClause (ClassrelClause {axiom_name,subclass,superclass,...}) =
  12.487 -  "clause(forall([T],\nor( " ^ dfg_classrelLits subclass superclass ^ ")),\n" ^
  12.488 -  axiom_name ^ ").\n\n";
  12.489 -
  12.490 -fun string_of_ar axiom_name = arclause_prefix ^ ascii_of axiom_name;
  12.491 -
  12.492 -fun dfg_arity_clause (ArityClause{axiom_name,conclLit,premLits,...}) =
  12.493 -  let val TConsLit (_,_,tvars) = conclLit
  12.494 -      val lits = map dfg_of_arLit (conclLit :: premLits)
  12.495 -  in
  12.496 -      "clause( %(axiom)\n" ^
  12.497 -      dfg_forall tvars ("or( " ^ commas lits ^ ")") ^ ",\n" ^
  12.498 -      string_of_ar axiom_name ^ ").\n\n"
  12.499 -  end;
  12.500 -
  12.501 -
  12.502 -(**** Produce TPTP files ****)
  12.503 -
  12.504 -(*Attach sign in TPTP syntax: false means negate.*)
  12.505 -fun tptp_sign true s = s
  12.506 -  | tptp_sign false s = "~ " ^ s
  12.507 -
  12.508 -fun tptp_of_typeLit pos (LTVar (s,ty))  = tptp_sign pos (s ^ "(" ^ ty ^ ")")
  12.509 -  | tptp_of_typeLit pos (LTFree (s,ty)) = tptp_sign pos  (s ^ "(" ^ ty ^ ")");
  12.510 -
  12.511 -fun gen_tptp_cls (cls_id,ax_name,Axiom,lits,tylits) =
  12.512 -      "cnf(" ^ string_of_clausename (cls_id,ax_name) ^ ",axiom," ^ 
  12.513 -               tptp_pack (tylits@lits) ^ ").\n"
  12.514 -  | gen_tptp_cls (cls_id,ax_name,Conjecture,lits,_) =
  12.515 -      "cnf(" ^ string_of_clausename (cls_id,ax_name) ^ ",negated_conjecture," ^ 
  12.516 -               tptp_pack lits ^ ").\n";
  12.517 -
  12.518 -fun tptp_tfree_clause tfree_lit =
  12.519 -    "cnf(" ^ "tfree_tcs," ^ "negated_conjecture" ^ "," ^ tptp_pack[tfree_lit] ^ ").\n";
  12.520 -
  12.521 -fun tptp_of_arLit (TConsLit (c,t,args)) =
  12.522 -      tptp_sign true (make_type_class c ^ "(" ^ t ^ paren_pack args ^ ")")
  12.523 -  | tptp_of_arLit (TVarLit (c,str)) =
  12.524 -      tptp_sign false (make_type_class c ^ "(" ^ str ^ ")")
  12.525 -
  12.526 -fun tptp_arity_clause (ArityClause{axiom_name,conclLit,premLits,...}) =
  12.527 -  "cnf(" ^ string_of_ar axiom_name ^ ",axiom," ^
  12.528 -  tptp_pack (map tptp_of_arLit (conclLit :: premLits)) ^ ").\n";
  12.529 -
  12.530 -fun tptp_classrelLits sub sup =
  12.531 -  let val tvar = "(T)"
  12.532 -  in  tptp_pack [tptp_sign false (sub^tvar), tptp_sign true (sup^tvar)]  end;
  12.533 -
  12.534 -fun tptp_classrelClause (ClassrelClause {axiom_name,subclass,superclass,...}) =
  12.535 -  "cnf(" ^ axiom_name ^ ",axiom," ^ tptp_classrelLits subclass superclass ^ ").\n"
  12.536 -
  12.537 -end;
    13.1 --- a/src/HOL/Tools/res_hol_clause.ML	Wed Mar 17 17:23:45 2010 +0100
    13.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.3 @@ -1,531 +0,0 @@
    13.4 -(*  Title:      HOL/Tools/res_hol_clause.ML
    13.5 -    Author:     Jia Meng, NICTA
    13.6 -
    13.7 -FOL clauses translated from HOL formulae.
    13.8 -*)
    13.9 -
   13.10 -signature RES_HOL_CLAUSE =
   13.11 -sig
   13.12 -  val ext: thm
   13.13 -  val comb_I: thm
   13.14 -  val comb_K: thm
   13.15 -  val comb_B: thm
   13.16 -  val comb_C: thm
   13.17 -  val comb_S: thm
   13.18 -  val minimize_applies: bool
   13.19 -  type axiom_name = string
   13.20 -  type polarity = bool
   13.21 -  type clause_id = int
   13.22 -  datatype combterm =
   13.23 -      CombConst of string * Res_Clause.fol_type * Res_Clause.fol_type list (*Const and Free*)
   13.24 -    | CombVar of string * Res_Clause.fol_type
   13.25 -    | CombApp of combterm * combterm
   13.26 -  datatype literal = Literal of polarity * combterm
   13.27 -  datatype clause = Clause of {clause_id: clause_id, axiom_name: axiom_name, th: thm,
   13.28 -                    kind: Res_Clause.kind,literals: literal list, ctypes_sorts: typ list}
   13.29 -  val type_of_combterm: combterm -> Res_Clause.fol_type
   13.30 -  val strip_comb: combterm -> combterm * combterm list
   13.31 -  val literals_of_term: theory -> term -> literal list * typ list
   13.32 -  exception TOO_TRIVIAL
   13.33 -  val make_conjecture_clauses:  bool -> theory -> thm list -> clause list
   13.34 -  val make_axiom_clauses: bool ->
   13.35 -       theory ->
   13.36 -       (thm * (axiom_name * clause_id)) list -> (axiom_name * clause) list
   13.37 -  val get_helper_clauses: bool ->
   13.38 -       theory ->
   13.39 -       bool ->
   13.40 -       clause list * (thm * (axiom_name * clause_id)) list * string list ->
   13.41 -       clause list
   13.42 -  val tptp_write_file: bool -> Path.T ->
   13.43 -    clause list * clause list * clause list * clause list *
   13.44 -    Res_Clause.classrelClause list * Res_Clause.arityClause list ->
   13.45 -    int * int
   13.46 -  val dfg_write_file: bool -> Path.T ->
   13.47 -    clause list * clause list * clause list * clause list *
   13.48 -    Res_Clause.classrelClause list * Res_Clause.arityClause list ->
   13.49 -    int * int
   13.50 -end
   13.51 -
   13.52 -structure Res_HOL_Clause: RES_HOL_CLAUSE =
   13.53 -struct
   13.54 -
   13.55 -structure RC = Res_Clause;   (* FIXME avoid structure alias *)
   13.56 -
   13.57 -(* theorems for combinators and function extensionality *)
   13.58 -val ext = thm "HOL.ext";
   13.59 -val comb_I = thm "ATP_Linkup.COMBI_def";
   13.60 -val comb_K = thm "ATP_Linkup.COMBK_def";
   13.61 -val comb_B = thm "ATP_Linkup.COMBB_def";
   13.62 -val comb_C = thm "ATP_Linkup.COMBC_def";
   13.63 -val comb_S = thm "ATP_Linkup.COMBS_def";
   13.64 -val fequal_imp_equal = thm "ATP_Linkup.fequal_imp_equal";
   13.65 -val equal_imp_fequal = thm "ATP_Linkup.equal_imp_fequal";
   13.66 -
   13.67 -
   13.68 -(* Parameter t_full below indicates that full type information is to be
   13.69 -exported *)
   13.70 -
   13.71 -(*If true, each function will be directly applied to as many arguments as possible, avoiding
   13.72 -  use of the "apply" operator. Use of hBOOL is also minimized.*)
   13.73 -val minimize_applies = true;
   13.74 -
   13.75 -fun min_arity_of const_min_arity c = the_default 0 (Symtab.lookup const_min_arity c);
   13.76 -
   13.77 -(*True if the constant ever appears outside of the top-level position in literals.
   13.78 -  If false, the constant always receives all of its arguments and is used as a predicate.*)
   13.79 -fun needs_hBOOL const_needs_hBOOL c =
   13.80 -  not minimize_applies orelse
   13.81 -    the_default false (Symtab.lookup const_needs_hBOOL c);
   13.82 -
   13.83 -
   13.84 -(******************************************************)
   13.85 -(* data types for typed combinator expressions        *)
   13.86 -(******************************************************)
   13.87 -
   13.88 -type axiom_name = string;
   13.89 -type polarity = bool;
   13.90 -type clause_id = int;
   13.91 -
   13.92 -datatype combterm = CombConst of string * RC.fol_type * RC.fol_type list (*Const and Free*)
   13.93 -                  | CombVar of string * RC.fol_type
   13.94 -                  | CombApp of combterm * combterm
   13.95 -
   13.96 -datatype literal = Literal of polarity * combterm;
   13.97 -
   13.98 -datatype clause =
   13.99 -         Clause of {clause_id: clause_id,
  13.100 -                    axiom_name: axiom_name,
  13.101 -                    th: thm,
  13.102 -                    kind: RC.kind,
  13.103 -                    literals: literal list,
  13.104 -                    ctypes_sorts: typ list};
  13.105 -
  13.106 -
  13.107 -(*********************************************************************)
  13.108 -(* convert a clause with type Term.term to a clause with type clause *)
  13.109 -(*********************************************************************)
  13.110 -
  13.111 -fun isFalse (Literal(pol, CombConst(c,_,_))) =
  13.112 -      (pol andalso c = "c_False") orelse
  13.113 -      (not pol andalso c = "c_True")
  13.114 -  | isFalse _ = false;
  13.115 -
  13.116 -fun isTrue (Literal (pol, CombConst(c,_,_))) =
  13.117 -      (pol andalso c = "c_True") orelse
  13.118 -      (not pol andalso c = "c_False")
  13.119 -  | isTrue _ = false;
  13.120 -
  13.121 -fun isTaut (Clause {literals,...}) = exists isTrue literals;
  13.122 -
  13.123 -fun type_of dfg (Type (a, Ts)) =
  13.124 -      let val (folTypes,ts) = types_of dfg Ts
  13.125 -      in  (RC.Comp(RC.make_fixed_type_const dfg a, folTypes), ts)  end
  13.126 -  | type_of _ (tp as TFree (a, _)) =
  13.127 -      (RC.AtomF (RC.make_fixed_type_var a), [tp])
  13.128 -  | type_of _ (tp as TVar (v, _)) =
  13.129 -      (RC.AtomV (RC.make_schematic_type_var v), [tp])
  13.130 -and types_of dfg Ts =
  13.131 -      let val (folTyps,ts) = ListPair.unzip (map (type_of dfg) Ts)
  13.132 -      in  (folTyps, RC.union_all ts)  end;
  13.133 -
  13.134 -(* same as above, but no gathering of sort information *)
  13.135 -fun simp_type_of dfg (Type (a, Ts)) =
  13.136 -      RC.Comp(RC.make_fixed_type_const dfg a, map (simp_type_of dfg) Ts)
  13.137 -  | simp_type_of _ (TFree (a, _)) = RC.AtomF(RC.make_fixed_type_var a)
  13.138 -  | simp_type_of _ (TVar (v, _)) = RC.AtomV(RC.make_schematic_type_var v);
  13.139 -
  13.140 -
  13.141 -fun const_type_of dfg thy (c,t) =
  13.142 -      let val (tp,ts) = type_of dfg t
  13.143 -      in  (tp, ts, map (simp_type_of dfg) (Sign.const_typargs thy (c,t))) end;
  13.144 -
  13.145 -(* convert a Term.term (with combinators) into a combterm, also accummulate sort info *)
  13.146 -fun combterm_of dfg thy (Const(c,t)) =
  13.147 -      let val (tp,ts,tvar_list) = const_type_of dfg thy (c,t)
  13.148 -          val c' = CombConst(RC.make_fixed_const dfg c, tp, tvar_list)
  13.149 -      in  (c',ts)  end
  13.150 -  | combterm_of dfg _ (Free(v,t)) =
  13.151 -      let val (tp,ts) = type_of dfg t
  13.152 -          val v' = CombConst(RC.make_fixed_var v, tp, [])
  13.153 -      in  (v',ts)  end
  13.154 -  | combterm_of dfg _ (Var(v,t)) =
  13.155 -      let val (tp,ts) = type_of dfg t
  13.156 -          val v' = CombVar(RC.make_schematic_var v,tp)
  13.157 -      in  (v',ts)  end
  13.158 -  | combterm_of dfg thy (P $ Q) =
  13.159 -      let val (P',tsP) = combterm_of dfg thy P
  13.160 -          val (Q',tsQ) = combterm_of dfg thy Q
  13.161 -      in  (CombApp(P',Q'), union (op =) tsP tsQ)  end
  13.162 -  | combterm_of _ _ (t as Abs _) = raise RC.CLAUSE ("HOL CLAUSE", t);
  13.163 -
  13.164 -fun predicate_of dfg thy ((Const("Not",_) $ P), polarity) = predicate_of dfg thy (P, not polarity)
  13.165 -  | predicate_of dfg thy (t,polarity) = (combterm_of dfg thy (Envir.eta_contract t), polarity);
  13.166 -
  13.167 -fun literals_of_term1 dfg thy args (Const("Trueprop",_) $ P) = literals_of_term1 dfg thy args P
  13.168 -  | literals_of_term1 dfg thy args (Const("op |",_) $ P $ Q) =
  13.169 -      literals_of_term1 dfg thy (literals_of_term1 dfg thy args P) Q
  13.170 -  | literals_of_term1 dfg thy (lits,ts) P =
  13.171 -      let val ((pred,ts'),pol) = predicate_of dfg thy (P,true)
  13.172 -      in
  13.173 -          (Literal(pol,pred)::lits, union (op =) ts ts')
  13.174 -      end;
  13.175 -
  13.176 -fun literals_of_term_dfg dfg thy P = literals_of_term1 dfg thy ([],[]) P;
  13.177 -val literals_of_term = literals_of_term_dfg false;
  13.178 -
  13.179 -(* Problem too trivial for resolution (empty clause) *)
  13.180 -exception TOO_TRIVIAL;
  13.181 -
  13.182 -(* making axiom and conjecture clauses *)
  13.183 -fun make_clause dfg thy (clause_id,axiom_name,kind,th) =
  13.184 -    let val (lits,ctypes_sorts) = literals_of_term_dfg dfg thy (prop_of th)
  13.185 -    in
  13.186 -        if forall isFalse lits
  13.187 -        then raise TOO_TRIVIAL
  13.188 -        else
  13.189 -            Clause {clause_id = clause_id, axiom_name = axiom_name, th = th, kind = kind,
  13.190 -                    literals = lits, ctypes_sorts = ctypes_sorts}
  13.191 -    end;
  13.192 -
  13.193 -
  13.194 -fun add_axiom_clause dfg thy ((th,(name,id)), pairs) =
  13.195 -  let val cls = make_clause dfg thy (id, name, RC.Axiom, th)
  13.196 -  in
  13.197 -      if isTaut cls then pairs else (name,cls)::pairs
  13.198 -  end;
  13.199 -
  13.200 -fun make_axiom_clauses dfg thy = List.foldl (add_axiom_clause dfg thy) [];
  13.201 -
  13.202 -fun make_conjecture_clauses_aux _ _ _ [] = []
  13.203 -  | make_conjecture_clauses_aux dfg thy n (th::ths) =
  13.204 -      make_clause dfg thy (n,"conjecture", RC.Conjecture, th) ::
  13.205 -      make_conjecture_clauses_aux dfg thy (n+1) ths;
  13.206 -
  13.207 -fun make_conjecture_clauses dfg thy = make_conjecture_clauses_aux dfg thy 0;
  13.208 -
  13.209 -
  13.210 -(**********************************************************************)
  13.211 -(* convert clause into ATP specific formats:                          *)
  13.212 -(* TPTP used by Vampire and E                                         *)
  13.213 -(* DFG used by SPASS                                                  *)
  13.214 -(**********************************************************************)
  13.215 -
  13.216 -(*Result of a function type; no need to check that the argument type matches.*)
  13.217 -fun result_type (RC.Comp ("tc_fun", [_, tp2])) = tp2
  13.218 -  | result_type _ = error "result_type"
  13.219 -
  13.220 -fun type_of_combterm (CombConst (_, tp, _)) = tp
  13.221 -  | type_of_combterm (CombVar (_, tp)) = tp
  13.222 -  | type_of_combterm (CombApp (t1, _)) = result_type (type_of_combterm t1);
  13.223 -
  13.224 -(*gets the head of a combinator application, along with the list of arguments*)
  13.225 -fun strip_comb u =
  13.226 -    let fun stripc (CombApp(t,u), ts) = stripc (t, u::ts)
  13.227 -        |   stripc  x =  x
  13.228 -    in  stripc(u,[])  end;
  13.229 -
  13.230 -val type_wrapper = "ti";
  13.231 -
  13.232 -fun head_needs_hBOOL const_needs_hBOOL (CombConst(c,_,_)) = needs_hBOOL const_needs_hBOOL c
  13.233 -  | head_needs_hBOOL _ _ = true;
  13.234 -
  13.235 -fun wrap_type t_full (s, tp) =
  13.236 -  if t_full then
  13.237 -      type_wrapper ^ RC.paren_pack [s, RC.string_of_fol_type tp]
  13.238 -  else s;
  13.239 -
  13.240 -fun apply ss = "hAPP" ^ RC.paren_pack ss;
  13.241 -
  13.242 -fun rev_apply (v, []) = v
  13.243 -  | rev_apply (v, arg::args) = apply [rev_apply (v, args), arg];
  13.244 -
  13.245 -fun string_apply (v, args) = rev_apply (v, rev args);
  13.246 -
  13.247 -(*Apply an operator to the argument strings, using either the "apply" operator or
  13.248 -  direct function application.*)
  13.249 -fun string_of_applic t_full cma (CombConst (c, _, tvars), args) =
  13.250 -      let val c = if c = "equal" then "c_fequal" else c
  13.251 -          val nargs = min_arity_of cma c
  13.252 -          val args1 = List.take(args, nargs)
  13.253 -            handle Subscript => error ("string_of_applic: " ^ c ^ " has arity " ^
  13.254 -                                         Int.toString nargs ^ " but is applied to " ^
  13.255 -                                         space_implode ", " args)
  13.256 -          val args2 = List.drop(args, nargs)
  13.257 -          val targs = if not t_full then map RC.string_of_fol_type tvars
  13.258 -                      else []
  13.259 -      in
  13.260 -          string_apply (c ^ RC.paren_pack (args1@targs), args2)
  13.261 -      end
  13.262 -  | string_of_applic _ _ (CombVar (v, _), args) = string_apply (v, args)
  13.263 -  | string_of_applic _ _ _ = error "string_of_applic";
  13.264 -
  13.265 -fun wrap_type_if t_full cnh (head, s, tp) =
  13.266 -  if head_needs_hBOOL cnh head then wrap_type t_full (s, tp) else s;
  13.267 -
  13.268 -fun string_of_combterm (params as (t_full, cma, cnh)) t =
  13.269 -  let val (head, args) = strip_comb t
  13.270 -  in  wrap_type_if t_full cnh (head,
  13.271 -                    string_of_applic t_full cma (head, map (string_of_combterm (params)) args),
  13.272 -                    type_of_combterm t)
  13.273 -  end;
  13.274 -
  13.275 -(*Boolean-valued terms are here converted to literals.*)
  13.276 -fun boolify params t =
  13.277 -  "hBOOL" ^ RC.paren_pack [string_of_combterm params t];
  13.278 -
  13.279 -fun string_of_predicate (params as (_,_,cnh)) t =
  13.280 -  case t of
  13.281 -      (CombApp(CombApp(CombConst("equal",_,_), t1), t2)) =>
  13.282 -          (*DFG only: new TPTP prefers infix equality*)
  13.283 -          ("equal" ^ RC.paren_pack [string_of_combterm params t1, string_of_combterm params t2])
  13.284 -    | _ =>
  13.285 -          case #1 (strip_comb t) of
  13.286 -              CombConst(c,_,_) => if needs_hBOOL cnh c then boolify params t else string_of_combterm params t
  13.287 -            | _ => boolify params t;
  13.288 -
  13.289 -
  13.290 -(*** tptp format ***)
  13.291 -
  13.292 -fun tptp_of_equality params pol (t1,t2) =
  13.293 -  let val eqop = if pol then " = " else " != "
  13.294 -  in  string_of_combterm params t1 ^ eqop ^ string_of_combterm params t2  end;
  13.295 -
  13.296 -fun tptp_literal params (Literal(pol, CombApp(CombApp(CombConst("equal",_,_), t1), t2))) =
  13.297 -      tptp_of_equality params pol (t1,t2)
  13.298 -  | tptp_literal params (Literal(pol,pred)) =
  13.299 -      RC.tptp_sign pol (string_of_predicate params pred);
  13.300 -
  13.301 -(*Given a clause, returns its literals paired with a list of literals concerning TFrees;
  13.302 -  the latter should only occur in conjecture clauses.*)
  13.303 -fun tptp_type_lits params pos (Clause{literals, ctypes_sorts, ...}) =
  13.304 -      (map (tptp_literal params) literals, 
  13.305 -       map (RC.tptp_of_typeLit pos) (RC.add_typs ctypes_sorts));
  13.306 -
  13.307 -fun clause2tptp params (cls as Clause {axiom_name, clause_id, kind, ...}) =
  13.308 -  let val (lits,tylits) = tptp_type_lits params (kind = RC.Conjecture) cls
  13.309 -  in
  13.310 -      (RC.gen_tptp_cls(clause_id,axiom_name,kind,lits,tylits), tylits)
  13.311 -  end;
  13.312 -
  13.313 -
  13.314 -(*** dfg format ***)
  13.315 -
  13.316 -fun dfg_literal params (Literal(pol,pred)) = RC.dfg_sign pol (string_of_predicate params pred);
  13.317 -
  13.318 -fun dfg_type_lits params pos (Clause{literals, ctypes_sorts, ...}) =
  13.319 -      (map (dfg_literal params) literals, 
  13.320 -       map (RC.dfg_of_typeLit pos) (RC.add_typs ctypes_sorts));
  13.321 -
  13.322 -fun get_uvars (CombConst _) vars = vars
  13.323 -  | get_uvars (CombVar(v,_)) vars = (v::vars)
  13.324 -  | get_uvars (CombApp(P,Q)) vars = get_uvars P (get_uvars Q vars);
  13.325 -
  13.326 -fun get_uvars_l (Literal(_,c)) = get_uvars c [];
  13.327 -
  13.328 -fun dfg_vars (Clause {literals,...}) = RC.union_all (map get_uvars_l literals);
  13.329 -
  13.330 -fun clause2dfg params (cls as Clause{axiom_name,clause_id,kind,ctypes_sorts,...}) =
  13.331 -  let val (lits,tylits) = dfg_type_lits params (kind = RC.Conjecture) cls
  13.332 -      val vars = dfg_vars cls
  13.333 -      val tvars = RC.get_tvar_strs ctypes_sorts
  13.334 -  in
  13.335 -      (RC.gen_dfg_cls(clause_id, axiom_name, kind, lits, tylits, tvars@vars), tylits)
  13.336 -  end;
  13.337 -
  13.338 -
  13.339 -(** For DFG format: accumulate function and predicate declarations **)
  13.340 -
  13.341 -fun addtypes tvars tab = List.foldl RC.add_foltype_funcs tab tvars;
  13.342 -
  13.343 -fun add_decls (t_full, cma, cnh) (CombConst (c, _, tvars), (funcs, preds)) =
  13.344 -      if c = "equal" then (addtypes tvars funcs, preds)
  13.345 -      else
  13.346 -        let val arity = min_arity_of cma c
  13.347 -            val ntys = if not t_full then length tvars else 0
  13.348 -            val addit = Symtab.update(c, arity+ntys)
  13.349 -        in
  13.350 -            if needs_hBOOL cnh c then (addtypes tvars (addit funcs), preds)
  13.351 -            else (addtypes tvars funcs, addit preds)
  13.352 -        end
  13.353 -  | add_decls _ (CombVar(_,ctp), (funcs,preds)) =
  13.354 -      (RC.add_foltype_funcs (ctp,funcs), preds)
  13.355 -  | add_decls params (CombApp(P,Q),decls) = add_decls params (P,add_decls params (Q,decls));
  13.356 -
  13.357 -fun add_literal_decls params (Literal(_,c), decls) = add_decls params (c,decls);
  13.358 -
  13.359 -fun add_clause_decls params (Clause {literals, ...}, decls) =
  13.360 -    List.foldl (add_literal_decls params) decls literals
  13.361 -    handle Symtab.DUP a => error ("function " ^ a ^ " has multiple arities")
  13.362 -
  13.363 -fun decls_of_clauses params clauses arity_clauses =
  13.364 -  let val init_functab = Symtab.update (type_wrapper,2) (Symtab.update ("hAPP",2) RC.init_functab)
  13.365 -      val init_predtab = Symtab.update ("hBOOL",1) Symtab.empty
  13.366 -      val (functab,predtab) = (List.foldl (add_clause_decls params) (init_functab, init_predtab) clauses)
  13.367 -  in
  13.368 -      (Symtab.dest (List.foldl RC.add_arityClause_funcs functab arity_clauses),
  13.369 -       Symtab.dest predtab)
  13.370 -  end;
  13.371 -
  13.372 -fun add_clause_preds (Clause {ctypes_sorts, ...}, preds) =
  13.373 -  List.foldl RC.add_type_sort_preds preds ctypes_sorts
  13.374 -  handle Symtab.DUP a => error ("predicate " ^ a ^ " has multiple arities")
  13.375 -
  13.376 -(*Higher-order clauses have only the predicates hBOOL and type classes.*)
  13.377 -fun preds_of_clauses clauses clsrel_clauses arity_clauses =
  13.378 -    Symtab.dest
  13.379 -        (List.foldl RC.add_classrelClause_preds
  13.380 -               (List.foldl RC.add_arityClause_preds
  13.381 -                      (List.foldl add_clause_preds Symtab.empty clauses)
  13.382 -                      arity_clauses)
  13.383 -               clsrel_clauses)
  13.384 -
  13.385 -
  13.386 -(**********************************************************************)
  13.387 -(* write clauses to files                                             *)
  13.388 -(**********************************************************************)
  13.389 -
  13.390 -val init_counters =
  13.391 -    Symtab.make [("c_COMBI", 0), ("c_COMBK", 0),
  13.392 -                 ("c_COMBB", 0), ("c_COMBC", 0),
  13.393 -                 ("c_COMBS", 0)];
  13.394 -
  13.395 -fun count_combterm (CombConst (c, _, _), ct) =
  13.396 -     (case Symtab.lookup ct c of NONE => ct  (*no counter*)
  13.397 -                               | SOME n => Symtab.update (c,n+1) ct)
  13.398 -  | count_combterm (CombVar _, ct) = ct
  13.399 -  | count_combterm (CombApp(t1,t2), ct) = count_combterm(t1, count_combterm(t2, ct));
  13.400 -
  13.401 -fun count_literal (Literal(_,t), ct) = count_combterm(t,ct);
  13.402 -
  13.403 -fun count_clause (Clause{literals,...}, ct) = List.foldl count_literal ct literals;
  13.404 -
  13.405 -fun count_user_clause user_lemmas (Clause{axiom_name,literals,...}, ct) =
  13.406 -  if axiom_name mem_string user_lemmas then List.foldl count_literal ct literals
  13.407 -  else ct;
  13.408 -
  13.409 -fun cnf_helper_thms thy =
  13.410 -  Res_Axioms.cnf_rules_pairs thy o map Res_Axioms.pairname
  13.411 -
  13.412 -fun get_helper_clauses dfg thy isFO (conjectures, axcls, user_lemmas) =
  13.413 -  if isFO then []  (*first-order*)
  13.414 -  else
  13.415 -    let
  13.416 -        val axclauses = map #2 (make_axiom_clauses dfg thy axcls)
  13.417 -        val ct0 = List.foldl count_clause init_counters conjectures
  13.418 -        val ct = List.foldl (count_user_clause user_lemmas) ct0 axclauses
  13.419 -        fun needed c = the (Symtab.lookup ct c) > 0
  13.420 -        val IK = if needed "c_COMBI" orelse needed "c_COMBK"
  13.421 -                 then cnf_helper_thms thy [comb_I,comb_K]
  13.422 -                 else []
  13.423 -        val BC = if needed "c_COMBB" orelse needed "c_COMBC"
  13.424 -                 then cnf_helper_thms thy [comb_B,comb_C]
  13.425 -                 else []
  13.426 -        val S = if needed "c_COMBS"
  13.427 -                then cnf_helper_thms thy [comb_S]
  13.428 -                else []
  13.429 -        val other = cnf_helper_thms thy [fequal_imp_equal,equal_imp_fequal]
  13.430 -    in
  13.431 -        map #2 (make_axiom_clauses dfg thy (other @ IK @ BC @ S))
  13.432 -    end;
  13.433 -
  13.434 -(*Find the minimal arity of each function mentioned in the term. Also, note which uses
  13.435 -  are not at top level, to see if hBOOL is needed.*)
  13.436 -fun count_constants_term toplev t (const_min_arity, const_needs_hBOOL) =
  13.437 -  let val (head, args) = strip_comb t
  13.438 -      val n = length args
  13.439 -      val (const_min_arity, const_needs_hBOOL) = fold (count_constants_term false) args (const_min_arity, const_needs_hBOOL)
  13.440 -  in
  13.441 -      case head of
  13.442 -          CombConst (a,_,_) => (*predicate or function version of "equal"?*)
  13.443 -            let val a = if a="equal" andalso not toplev then "c_fequal" else a
  13.444 -            val const_min_arity = Symtab.map_default (a, n) (Integer.min n) const_min_arity
  13.445 -            in
  13.446 -              if toplev then (const_min_arity, const_needs_hBOOL)
  13.447 -              else (const_min_arity, Symtab.update (a,true) (const_needs_hBOOL))
  13.448 -            end
  13.449 -        | _ => (const_min_arity, const_needs_hBOOL)
  13.450 -  end;
  13.451 -
  13.452 -(*A literal is a top-level term*)
  13.453 -fun count_constants_lit (Literal (_,t)) (const_min_arity, const_needs_hBOOL) =
  13.454 -  count_constants_term true t (const_min_arity, const_needs_hBOOL);
  13.455 -
  13.456 -fun count_constants_clause (Clause{literals,...}) (const_min_arity, const_needs_hBOOL) =
  13.457 -  fold count_constants_lit literals (const_min_arity, const_needs_hBOOL);
  13.458 -
  13.459 -fun display_arity const_needs_hBOOL (c,n) =
  13.460 -  Res_Axioms.trace_msg (fn () => "Constant: " ^ c ^ " arity:\t" ^ Int.toString n ^
  13.461 -                (if needs_hBOOL const_needs_hBOOL c then " needs hBOOL" else ""));
  13.462 -
  13.463 -fun count_constants (conjectures, _, extra_clauses, helper_clauses, _, _) =
  13.464 -  if minimize_applies then
  13.465 -     let val (const_min_arity, const_needs_hBOOL) =
  13.466 -          fold count_constants_clause conjectures (Symtab.empty, Symtab.empty)
  13.467 -       |> fold count_constants_clause extra_clauses
  13.468 -       |> fold count_constants_clause helper_clauses
  13.469 -     val _ = List.app (display_arity const_needs_hBOOL) (Symtab.dest (const_min_arity))
  13.470 -     in (const_min_arity, const_needs_hBOOL) end
  13.471 -  else (Symtab.empty, Symtab.empty);
  13.472 -
  13.473 -(* tptp format *)
  13.474 -
  13.475 -fun tptp_write_file t_full file clauses =
  13.476 -  let
  13.477 -    val (conjectures, axclauses, _, helper_clauses,
  13.478 -      classrel_clauses, arity_clauses) = clauses
  13.479 -    val (cma, cnh) = count_constants clauses
  13.480 -    val params = (t_full, cma, cnh)
  13.481 -    val (tptp_clss,tfree_litss) = ListPair.unzip (map (clause2tptp params) conjectures)
  13.482 -    val tfree_clss = map RC.tptp_tfree_clause (List.foldl (uncurry (union (op =))) [] tfree_litss)
  13.483 -    val _ =
  13.484 -      File.write_list file (
  13.485 -        map (#1 o (clause2tptp params)) axclauses @
  13.486 -        tfree_clss @
  13.487 -        tptp_clss @
  13.488 -        map RC.tptp_classrelClause classrel_clauses @
  13.489 -        map RC.tptp_arity_clause arity_clauses @
  13.490 -        map (#1 o (clause2tptp params)) helper_clauses)
  13.491 -    in (length axclauses + 1, length tfree_clss + length tptp_clss)
  13.492 -  end;
  13.493 -
  13.494 -
  13.495 -(* dfg format *)
  13.496 -
  13.497 -fun dfg_write_file t_full file clauses =
  13.498 -  let
  13.499 -    val (conjectures, axclauses, _, helper_clauses,
  13.500 -      classrel_clauses, arity_clauses) = clauses
  13.501 -    val (cma, cnh) = count_constants clauses
  13.502 -    val params = (t_full, cma, cnh)
  13.503 -    val (dfg_clss, tfree_litss) = ListPair.unzip (map (clause2dfg params) conjectures)
  13.504 -    and probname = Path.implode (Path.base file)
  13.505 -    val axstrs = map (#1 o (clause2dfg params)) axclauses
  13.506 -    val tfree_clss = map RC.dfg_tfree_clause (RC.union_all tfree_litss)
  13.507 -    val helper_clauses_strs = map (#1 o (clause2dfg params)) helper_clauses
  13.508 -    val (funcs,cl_preds) = decls_of_clauses params (helper_clauses @ conjectures @ axclauses) arity_clauses
  13.509 -    and ty_preds = preds_of_clauses axclauses classrel_clauses arity_clauses
  13.510 -    val _ =
  13.511 -      File.write_list file (
  13.512 -        RC.string_of_start probname ::
  13.513 -        RC.string_of_descrip probname ::
  13.514 -        RC.string_of_symbols (RC.string_of_funcs funcs)
  13.515 -          (RC.string_of_preds (cl_preds @ ty_preds)) ::
  13.516 -        "list_of_clauses(axioms,cnf).\n" ::
  13.517 -        axstrs @
  13.518 -        map RC.dfg_classrelClause classrel_clauses @
  13.519 -        map RC.dfg_arity_clause arity_clauses @
  13.520 -        helper_clauses_strs @
  13.521 -        ["end_of_list.\n\nlist_of_clauses(conjectures,cnf).\n"] @
  13.522 -        tfree_clss @
  13.523 -        dfg_clss @
  13.524 -        ["end_of_list.\n\n",
  13.525 -        (*VarWeight=3 helps the HO problems, probably by counteracting the presence of hAPP*)
  13.526 -         "list_of_settings(SPASS).\n{*\nset_flag(VarWeight,3).\n*}\nend_of_list.\n\n",
  13.527 -         "end_problem.\n"])
  13.528 -
  13.529 -    in (length axclauses + length classrel_clauses + length arity_clauses +
  13.530 -      length helper_clauses + 1, length tfree_clss + length dfg_clss)
  13.531 -  end;
  13.532 -
  13.533 -end;
  13.534 -
    14.1 --- a/src/HOL/Tools/res_reconstruct.ML	Wed Mar 17 17:23:45 2010 +0100
    14.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.3 @@ -1,584 +0,0 @@
    14.4 -(*  Title:      HOL/Tools/res_reconstruct.ML
    14.5 -    Author:     Lawrence C Paulson and Claire Quigley, Cambridge University Computer Laboratory
    14.6 -
    14.7 -Transfer of proofs from external provers.
    14.8 -*)
    14.9 -
   14.10 -signature RES_RECONSTRUCT =
   14.11 -sig
   14.12 -  val chained_hint: string
   14.13 -
   14.14 -  val fix_sorts: sort Vartab.table -> term -> term
   14.15 -  val invert_const: string -> string
   14.16 -  val invert_type_const: string -> string
   14.17 -  val num_typargs: theory -> string -> int
   14.18 -  val make_tvar: string -> typ
   14.19 -  val strip_prefix: string -> string -> string option
   14.20 -  val setup: theory -> theory
   14.21 -  (* extracting lemma list*)
   14.22 -  val find_failure: string -> string option
   14.23 -  val lemma_list: bool -> string ->
   14.24 -    string * string vector * (int * int) * Proof.context * thm * int -> string * string list
   14.25 -  (* structured proofs *)
   14.26 -  val structured_proof: string ->
   14.27 -    string * string vector * (int * int) * Proof.context * thm * int -> string * string list
   14.28 -end;
   14.29 -
   14.30 -structure Res_Reconstruct : RES_RECONSTRUCT =
   14.31 -struct
   14.32 -
   14.33 -val trace_path = Path.basic "atp_trace";
   14.34 -
   14.35 -fun trace s =
   14.36 -  if ! Res_Axioms.trace then File.append (File.tmp_path trace_path) s
   14.37 -  else ();
   14.38 -
   14.39 -fun string_of_thm ctxt = PrintMode.setmp [] (Display.string_of_thm ctxt);
   14.40 -
   14.41 -(*For generating structured proofs: keep every nth proof line*)
   14.42 -val (modulus, modulus_setup) = Attrib.config_int "sledgehammer_modulus" 1;
   14.43 -
   14.44 -(*Indicates whether to include sort information in generated proofs*)
   14.45 -val (recon_sorts, recon_sorts_setup) = Attrib.config_bool "sledgehammer_sorts" true;
   14.46 -
   14.47 -(*Indicated whether to generate full proofs or just lemma lists - now via setup of atps*)
   14.48 -(* val (full_proofs, full_proofs_setup) = Attrib.config_bool "sledgehammer_full" false; *)
   14.49 -
   14.50 -val setup = modulus_setup #> recon_sorts_setup;
   14.51 -
   14.52 -(**** PARSING OF TSTP FORMAT ****)
   14.53 -
   14.54 -(*Syntax trees, either termlist or formulae*)
   14.55 -datatype stree = Int of int | Br of string * stree list;
   14.56 -
   14.57 -fun atom x = Br(x,[]);
   14.58 -
   14.59 -fun scons (x,y) = Br("cons", [x,y]);
   14.60 -val listof = List.foldl scons (atom "nil");
   14.61 -
   14.62 -(*Strings enclosed in single quotes, e.g. filenames*)
   14.63 -val quoted = $$"'" |-- Scan.repeat (~$$"'") --| $$"'" >> implode;
   14.64 -
   14.65 -(*Intended for $true and $false*)
   14.66 -fun tf s = "c_" ^ str (Char.toUpper (String.sub(s,0))) ^ String.extract(s,1,NONE);
   14.67 -val truefalse = $$"$" |-- Symbol.scan_id >> (atom o tf);
   14.68 -
   14.69 -(*Integer constants, typically proof line numbers*)
   14.70 -fun is_digit s = Char.isDigit (String.sub(s,0));
   14.71 -val integer = Scan.many1 is_digit >> (the o Int.fromString o implode);
   14.72 -
   14.73 -(*Generalized FO terms, which include filenames, numbers, etc.*)
   14.74 -fun termlist x = (term ::: Scan.repeat ($$"," |-- term)) x
   14.75 -and term x = (quoted >> atom || integer>>Int || truefalse ||
   14.76 -              Symbol.scan_id -- Scan.optional ($$"(" |-- termlist --| $$")") [] >> Br ||
   14.77 -              $$"(" |-- term --| $$")" ||
   14.78 -              $$"[" |-- Scan.optional termlist [] --| $$"]" >> listof) x;
   14.79 -
   14.80 -fun negate t = Br("c_Not", [t]);
   14.81 -fun equate (t1,t2) = Br("c_equal", [t1,t2]);
   14.82 -
   14.83 -(*Apply equal or not-equal to a term*)
   14.84 -fun syn_equal (t, NONE) = t
   14.85 -  | syn_equal (t1, SOME (NONE, t2)) = equate (t1,t2)
   14.86 -  | syn_equal (t1, SOME (SOME _, t2)) = negate (equate (t1,t2));
   14.87 -
   14.88 -(*Literals can involve negation, = and !=.*)
   14.89 -fun literal x = ($$"~" |-- literal >> negate ||
   14.90 -                 (term -- Scan.option (Scan.option ($$"!") --| $$"=" -- term) >> syn_equal)) x;
   14.91 -
   14.92 -val literals = literal ::: Scan.repeat ($$"|" |-- literal);
   14.93 -
   14.94 -(*Clause: a list of literals separated by the disjunction sign*)
   14.95 -val clause = $$"(" |-- literals --| $$")" || Scan.single literal;
   14.96 -
   14.97 -val annotations = $$"," |-- term -- Scan.option ($$"," |-- termlist);
   14.98 -
   14.99 -(*<cnf_annotated> ::= cnf(<name>,<formula_role>,<cnf_formula><annotations>).
  14.100 -  The <name> could be an identifier, but we assume integers.*)
  14.101 -val tstp_line = (Scan.this_string "cnf" -- $$"(") |--
  14.102 -                integer --| $$"," -- Symbol.scan_id --| $$"," --
  14.103 -                clause -- Scan.option annotations --| $$ ")";
  14.104 -
  14.105 -
  14.106 -(**** INTERPRETATION OF TSTP SYNTAX TREES ****)
  14.107 -
  14.108 -exception STREE of stree;
  14.109 -
  14.110 -(*If string s has the prefix s1, return the result of deleting it.*)
  14.111 -fun strip_prefix s1 s =
  14.112 -  if String.isPrefix s1 s
  14.113 -  then SOME (Res_Clause.undo_ascii_of (String.extract (s, size s1, NONE)))
  14.114 -  else NONE;
  14.115 -
  14.116 -(*Invert the table of translations between Isabelle and ATPs*)
  14.117 -val type_const_trans_table_inv =
  14.118 -      Symtab.make (map swap (Symtab.dest Res_Clause.type_const_trans_table));
  14.119 -
  14.120 -fun invert_type_const c =
  14.121 -    case Symtab.lookup type_const_trans_table_inv c of
  14.122 -        SOME c' => c'
  14.123 -      | NONE => c;
  14.124 -
  14.125 -fun make_tvar b = TVar(("'" ^ b, 0), HOLogic.typeS);
  14.126 -fun make_var (b,T) = Var((b,0),T);
  14.127 -
  14.128 -(*Type variables are given the basic sort, HOL.type. Some will later be constrained
  14.129 -  by information from type literals, or by type inference.*)
  14.130 -fun type_of_stree t =
  14.131 -  case t of
  14.132 -      Int _ => raise STREE t
  14.133 -    | Br (a,ts) =>
  14.134 -        let val Ts = map type_of_stree ts
  14.135 -        in
  14.136 -          case strip_prefix Res_Clause.tconst_prefix a of
  14.137 -              SOME b => Type(invert_type_const b, Ts)
  14.138 -            | NONE =>
  14.139 -                if not (null ts) then raise STREE t  (*only tconsts have type arguments*)
  14.140 -                else
  14.141 -                case strip_prefix Res_Clause.tfree_prefix a of
  14.142 -                    SOME b => TFree("'" ^ b, HOLogic.typeS)
  14.143 -                  | NONE =>
  14.144 -                case strip_prefix Res_Clause.tvar_prefix a of
  14.145 -                    SOME b => make_tvar b
  14.146 -                  | NONE => make_tvar a   (*Variable from the ATP, say X1*)
  14.147 -        end;
  14.148 -
  14.149 -(*Invert the table of translations between Isabelle and ATPs*)
  14.150 -val const_trans_table_inv =
  14.151 -      Symtab.update ("fequal", "op =")
  14.152 -        (Symtab.make (map swap (Symtab.dest Res_Clause.const_trans_table)));
  14.153 -
  14.154 -fun invert_const c =
  14.155 -    case Symtab.lookup const_trans_table_inv c of
  14.156 -        SOME c' => c'
  14.157 -      | NONE => c;
  14.158 -
  14.159 -(*The number of type arguments of a constant, zero if it's monomorphic*)
  14.160 -fun num_typargs thy s = length (Sign.const_typargs thy (s, Sign.the_const_type thy s));
  14.161 -
  14.162 -(*Generates a constant, given its type arguments*)
  14.163 -fun const_of thy (a,Ts) = Const(a, Sign.const_instance thy (a,Ts));
  14.164 -
  14.165 -(*First-order translation. No types are known for variables. HOLogic.typeT should allow
  14.166 -  them to be inferred.*)
  14.167 -fun term_of_stree args thy t =
  14.168 -  case t of
  14.169 -      Int _ => raise STREE t
  14.170 -    | Br ("hBOOL",[t]) => term_of_stree [] thy t  (*ignore hBOOL*)
  14.171 -    | Br ("hAPP",[t,u]) => term_of_stree (u::args) thy t
  14.172 -    | Br (a,ts) =>
  14.173 -        case strip_prefix Res_Clause.const_prefix a of
  14.174 -            SOME "equal" =>
  14.175 -              list_comb(Const ("op =", HOLogic.typeT), List.map (term_of_stree [] thy) ts)
  14.176 -          | SOME b =>
  14.177 -              let val c = invert_const b
  14.178 -                  val nterms = length ts - num_typargs thy c
  14.179 -                  val us = List.map (term_of_stree [] thy) (List.take(ts,nterms) @ args)
  14.180 -                  (*Extra args from hAPP come AFTER any arguments given directly to the
  14.181 -                    constant.*)
  14.182 -                  val Ts = List.map type_of_stree (List.drop(ts,nterms))
  14.183 -              in  list_comb(const_of thy (c, Ts), us)  end
  14.184 -          | NONE => (*a variable, not a constant*)
  14.185 -              let val T = HOLogic.typeT
  14.186 -                  val opr = (*a Free variable is typically a Skolem function*)
  14.187 -                    case strip_prefix Res_Clause.fixed_var_prefix a of
  14.188 -                        SOME b => Free(b,T)
  14.189 -                      | NONE =>
  14.190 -                    case strip_prefix Res_Clause.schematic_var_prefix a of
  14.191 -                        SOME b => make_var (b,T)
  14.192 -                      | NONE => make_var (a,T)    (*Variable from the ATP, say X1*)
  14.193 -              in  list_comb (opr, List.map (term_of_stree [] thy) (ts@args))  end;
  14.194 -
  14.195 -(*Type class literal applied to a type. Returns triple of polarity, class, type.*)
  14.196 -fun constraint_of_stree pol (Br("c_Not",[t])) = constraint_of_stree (not pol) t
  14.197 -  | constraint_of_stree pol t = case t of
  14.198 -        Int _ => raise STREE t
  14.199 -      | Br (a,ts) =>
  14.200 -            (case (strip_prefix Res_Clause.class_prefix a, map type_of_stree ts) of
  14.201 -                 (SOME b, [T]) => (pol, b, T)
  14.202 -               | _ => raise STREE t);
  14.203 -
  14.204 -(** Accumulate type constraints in a clause: negative type literals **)
  14.205 -
  14.206 -fun addix (key,z)  = Vartab.map_default (key,[]) (cons z);
  14.207 -
  14.208 -fun add_constraint ((false, cl, TFree(a,_)), vt) = addix ((a,~1),cl) vt
  14.209 -  | add_constraint ((false, cl, TVar(ix,_)), vt) = addix (ix,cl) vt
  14.210 -  | add_constraint (_, vt) = vt;
  14.211 -
  14.212 -(*False literals (which E includes in its proofs) are deleted*)
  14.213 -val nofalses = filter (not o equal HOLogic.false_const);
  14.214 -
  14.215 -(*Final treatment of the list of "real" literals from a clause.*)
  14.216 -fun finish [] = HOLogic.true_const  (*No "real" literals means only type information*)
  14.217 -  | finish lits =
  14.218 -      case nofalses lits of
  14.219 -          [] => HOLogic.false_const  (*The empty clause, since we started with real literals*)
  14.220 -        | xs => foldr1 HOLogic.mk_disj (rev xs);
  14.221 -
  14.222 -(*Accumulate sort constraints in vt, with "real" literals in lits.*)
  14.223 -fun lits_of_strees _ (vt, lits) [] = (vt, finish lits)
  14.224 -  | lits_of_strees ctxt (vt, lits) (t::ts) =
  14.225 -      lits_of_strees ctxt (add_constraint (constraint_of_stree true t, vt), lits) ts
  14.226 -      handle STREE _ =>
  14.227 -      lits_of_strees ctxt (vt, term_of_stree [] (ProofContext.theory_of ctxt) t :: lits) ts;
  14.228 -
  14.229 -(*Update TVars/TFrees with detected sort constraints.*)
  14.230 -fun fix_sorts vt =
  14.231 -  let fun tysubst (Type (a, Ts)) = Type (a, map tysubst Ts)
  14.232 -        | tysubst (TVar (xi, s)) = TVar (xi, the_default s (Vartab.lookup vt xi))
  14.233 -        | tysubst (TFree (x, s)) = TFree (x, the_default s (Vartab.lookup vt (x, ~1)))
  14.234 -      fun tmsubst (Const (a, T)) = Const (a, tysubst T)
  14.235 -        | tmsubst (Free (a, T)) = Free (a, tysubst T)
  14.236 -        | tmsubst (Var (xi, T)) = Var (xi, tysubst T)
  14.237 -        | tmsubst (t as Bound _) = t
  14.238 -        | tmsubst (Abs (a, T, t)) = Abs (a, tysubst T, tmsubst t)
  14.239 -        | tmsubst (t $ u) = tmsubst t $ tmsubst u;
  14.240 -  in fn t => if Vartab.is_empty vt then t else tmsubst t end;
  14.241 -
  14.242 -(*Interpret a list of syntax trees as a clause, given by "real" literals and sort constraints.
  14.243 -  vt0 holds the initial sort constraints, from the conjecture clauses.*)
  14.244 -fun clause_of_strees ctxt vt0 ts =
  14.245 -  let val (vt, dt) = lits_of_strees ctxt (vt0,[]) ts in
  14.246 -    singleton (Syntax.check_terms ctxt) (TypeInfer.constrain HOLogic.boolT (fix_sorts vt dt))
  14.247 -  end;
  14.248 -
  14.249 -fun gen_all_vars t = fold_rev Logic.all (OldTerm.term_vars t) t;
  14.250 -
  14.251 -fun ints_of_stree_aux (Int n, ns) = n::ns
  14.252 -  | ints_of_stree_aux (Br(_,ts), ns) = List.foldl ints_of_stree_aux ns ts;
  14.253 -
  14.254 -fun ints_of_stree t = ints_of_stree_aux (t, []);
  14.255 -
  14.256 -fun decode_tstp vt0 (name, role, ts, annots) ctxt =
  14.257 -  let val deps = case annots of NONE => [] | SOME (source,_) => ints_of_stree source
  14.258 -      val cl = clause_of_strees ctxt vt0 ts
  14.259 -  in  ((name, role, cl, deps), fold Variable.declare_term (OldTerm.term_frees cl) ctxt)  end;
  14.260 -
  14.261 -fun dest_tstp ((((name, role), ts), annots), chs) =
  14.262 -  case chs of
  14.263 -          "."::_ => (name, role, ts, annots)
  14.264 -        | _ => error ("TSTP line not terminated by \".\": " ^ implode chs);
  14.265 -
  14.266 -
  14.267 -(** Global sort constraints on TFrees (from tfree_tcs) are positive unit clauses. **)
  14.268 -
  14.269 -fun add_tfree_constraint ((true, cl, TFree(a,_)), vt) = addix ((a,~1),cl) vt
  14.270 -  | add_tfree_constraint (_, vt) = vt;
  14.271 -
  14.272 -fun tfree_constraints_of_clauses vt [] = vt
  14.273 -  | tfree_constraints_of_clauses vt ([lit]::tss) =
  14.274 -      (tfree_constraints_of_clauses (add_tfree_constraint (constraint_of_stree true lit, vt)) tss
  14.275 -       handle STREE _ => (*not a positive type constraint: ignore*)
  14.276 -       tfree_constraints_of_clauses vt tss)
  14.277 -  | tfree_constraints_of_clauses vt (_::tss) = tfree_constraints_of_clauses vt tss;
  14.278 -
  14.279 -
  14.280 -(**** Translation of TSTP files to Isar Proofs ****)
  14.281 -
  14.282 -fun decode_tstp_list ctxt tuples =
  14.283 -  let val vt0 = tfree_constraints_of_clauses Vartab.empty (map #3 tuples)
  14.284 -  in  #1 (fold_map (decode_tstp vt0) tuples ctxt) end;
  14.285 -
  14.286 -(** Finding a matching assumption. The literals may be permuted, and variable names
  14.287 -    may disagree. We have to try all combinations of literals (quadratic!) and
  14.288 -    match up the variable names consistently. **)
  14.289 -
  14.290 -fun strip_alls_aux n (Const("all",_)$Abs(a,T,t))  =
  14.291 -      strip_alls_aux (n+1) (subst_bound (Var ((a,n), T), t))
  14.292 -  | strip_alls_aux _ t  =  t;
  14.293 -
  14.294 -val strip_alls = strip_alls_aux 0;
  14.295 -
  14.296 -exception MATCH_LITERAL;
  14.297 -
  14.298 -(*Ignore types: they are not to be trusted...*)
  14.299 -fun match_literal (t1$u1) (t2$u2) env =
  14.300 -      match_literal t1 t2 (match_literal u1 u2 env)
  14.301 -  | match_literal (Abs (_,_,t1)) (Abs (_,_,t2)) env =
  14.302 -      match_literal t1 t2 env
  14.303 -  | match_literal (Bound i1) (Bound i2) env =
  14.304 -      if i1=i2 then env else raise MATCH_LITERAL
  14.305 -  | match_literal (Const(a1,_)) (Const(a2,_)) env =
  14.306 -      if a1=a2 then env else raise MATCH_LITERAL
  14.307 -  | match_literal (Free(a1,_)) (Free(a2,_)) env =
  14.308 -      if a1=a2 then env else raise MATCH_LITERAL
  14.309 -  | match_literal (Var(ix1,_)) (Var(ix2,_)) env = insert (op =) (ix1,ix2) env
  14.310 -  | match_literal _ _ _ = raise MATCH_LITERAL;
  14.311 -
  14.312 -(*Checking that all variable associations are unique. The list env contains no
  14.313 -  repetitions, but does it contain say (x,y) and (y,y)? *)
  14.314 -fun good env =
  14.315 -  let val (xs,ys) = ListPair.unzip env
  14.316 -  in  not (has_duplicates (op=) xs orelse has_duplicates (op=) ys)  end;
  14.317 -
  14.318 -(*Match one list of literals against another, ignoring types and the order of
  14.319 -  literals. Sorting is unreliable because we don't have types or variable names.*)
  14.320 -fun matches_aux _ [] [] = true
  14.321 -  | matches_aux env (lit::lits) ts =
  14.322 -      let fun match1 us [] = false
  14.323 -            | match1 us (t::ts) =
  14.324 -                let val env' = match_literal lit t env
  14.325 -                in  (good env' andalso matches_aux env' lits (us@ts)) orelse
  14.326 -                    match1 (t::us) ts
  14.327 -                end
  14.328 -                handle MATCH_LITERAL => match1 (t::us) ts
  14.329 -      in  match1 [] ts  end;
  14.330 -
  14.331 -(*Is this length test useful?*)
  14.332 -fun matches (lits1,lits2) =
  14.333 -  length lits1 = length lits2  andalso
  14.334 -  matches_aux [] (map Envir.eta_contract lits1) (map Envir.eta_contract lits2);
  14.335 -
  14.336 -fun permuted_clause t =
  14.337 -  let val lits = HOLogic.disjuncts t
  14.338 -      fun perm [] = NONE
  14.339 -        | perm (ctm::ctms) =
  14.340 -            if matches (lits, HOLogic.disjuncts (HOLogic.dest_Trueprop (strip_alls ctm)))
  14.341 -            then SOME ctm else perm ctms
  14.342 -  in perm end;
  14.343 -
  14.344 -fun have_or_show "show " _ = "show \""
  14.345 -  | have_or_show have lname = have ^ lname ^ ": \""
  14.346 -
  14.347 -(*ctms is a list of conjecture clauses as yielded by Isabelle. Those returned by the
  14.348 -  ATP may have their literals reordered.*)
  14.349 -fun isar_lines ctxt ctms =
  14.350 -  let val string_of = PrintMode.setmp [] (fn term => Syntax.string_of_term ctxt term)
  14.351 -      val _ = trace ("\n\nisar_lines: start\n")
  14.352 -      fun doline _ (lname, t, []) =  (*No deps: it's a conjecture clause, with no proof.*)
  14.353 -           (case permuted_clause t ctms of
  14.354 -                SOME u => "assume " ^ lname ^ ": \"" ^ string_of u ^ "\"\n"
  14.355 -              | NONE => "assume? " ^ lname ^ ": \"" ^ string_of t ^ "\"\n")  (*no match!!*)
  14.356 -        | doline have (lname, t, deps) =
  14.357 -            have_or_show have lname ^ string_of (gen_all_vars (HOLogic.mk_Trueprop t)) ^
  14.358 -            "\"\n  by (metis " ^ space_implode " " deps ^ ")\n"
  14.359 -      fun dolines [(lname, t, deps)] = [doline "show " (lname, t, deps)]
  14.360 -        | dolines ((lname, t, deps)::lines) = doline "have " (lname, t, deps) :: dolines lines
  14.361 -  in setmp_CRITICAL show_sorts (Config.get ctxt recon_sorts) dolines end;
  14.362 -
  14.363 -fun notequal t (_,t',_) = not (t aconv t');
  14.364 -
  14.365 -(*No "real" literals means only type information*)
  14.366 -fun eq_types t = t aconv HOLogic.true_const;
  14.367 -
  14.368 -fun replace_dep (old:int, new) dep = if dep=old then new else [dep];
  14.369 -
  14.370 -fun replace_deps (old:int, new) (lno, t, deps) =
  14.371 -      (lno, t, List.foldl (uncurry (union (op =))) [] (map (replace_dep (old, new)) deps));
  14.372 -
  14.373 -(*Discard axioms; consolidate adjacent lines that prove the same clause, since they differ
  14.374 -  only in type information.*)
  14.375 -fun add_prfline ((lno, "axiom", t, []), lines) =  (*axioms are not proof lines*)
  14.376 -      if eq_types t (*must be clsrel/clsarity: type information, so delete refs to it*)
  14.377 -      then map (replace_deps (lno, [])) lines
  14.378 -      else
  14.379 -       (case take_prefix (notequal t) lines of
  14.380 -           (_,[]) => lines                  (*no repetition of proof line*)
  14.381 -         | (pre, (lno', _, _) :: post) =>   (*repetition: replace later line by earlier one*)
  14.382 -             pre @ map (replace_deps (lno', [lno])) post)
  14.383 -  | add_prfline ((lno, _, t, []), lines) =  (*no deps: conjecture clause*)
  14.384 -      (lno, t, []) :: lines
  14.385 -  | add_prfline ((lno, _, t, deps), lines) =
  14.386 -      if eq_types t then (lno, t, deps) :: lines
  14.387 -      (*Type information will be deleted later; skip repetition test.*)
  14.388 -      else (*FIXME: Doesn't this code risk conflating proofs involving different types??*)
  14.389 -      case take_prefix (notequal t) lines of
  14.390 -         (_,[]) => (lno, t, deps) :: lines  (*no repetition of proof line*)
  14.391 -       | (pre, (lno', t', _) :: post) =>
  14.392 -           (lno, t', deps) ::               (*repetition: replace later line by earlier one*)
  14.393 -           (pre @ map (replace_deps (lno', [lno])) post);
  14.394 -
  14.395 -(*Recursively delete empty lines (type information) from the proof.*)
  14.396 -fun add_nonnull_prfline ((lno, t, []), lines) = (*no dependencies, so a conjecture clause*)
  14.397 -     if eq_types t (*must be type information, tfree_tcs, clsrel, clsarity: delete refs to it*)
  14.398 -     then delete_dep lno lines
  14.399 -     else (lno, t, []) :: lines
  14.400 -  | add_nonnull_prfline ((lno, t, deps), lines) = (lno, t, deps) :: lines
  14.401 -and delete_dep lno lines = List.foldr add_nonnull_prfline [] (map (replace_deps (lno, [])) lines);
  14.402 -
  14.403 -fun bad_free (Free (a,_)) = String.isPrefix "sko_" a
  14.404 -  | bad_free _ = false;
  14.405 -
  14.406 -(*TVars are forbidden in goals. Also, we don't want lines with <2 dependencies.
  14.407 -  To further compress proofs, setting modulus:=n deletes every nth line, and nlines
  14.408 -  counts the number of proof lines processed so far.
  14.409 -  Deleted lines are replaced by their own dependencies. Note that the "add_nonnull_prfline"
  14.410 -  phase may delete some dependencies, hence this phase comes later.*)
  14.411 -fun add_wanted_prfline ctxt ((lno, t, []), (nlines, lines)) =
  14.412 -      (nlines, (lno, t, []) :: lines)   (*conjecture clauses must be kept*)
  14.413 -  | add_wanted_prfline ctxt ((lno, t, deps), (nlines, lines)) =
  14.414 -      if eq_types t orelse not (null (Term.add_tvars t [])) orelse
  14.415 -         exists_subterm bad_free t orelse
  14.416 -         (not (null lines) andalso   (*final line can't be deleted for these reasons*)
  14.417 -          (length deps < 2 orelse nlines mod (Config.get ctxt modulus) <> 0))
  14.418 -      then (nlines+1, map (replace_deps (lno, deps)) lines) (*Delete line*)
  14.419 -      else (nlines+1, (lno, t, deps) :: lines);
  14.420 -
  14.421 -(*Replace numeric proof lines by strings, either from thm_names or sequential line numbers*)
  14.422 -fun stringify_deps thm_names deps_map [] = []
  14.423 -  | stringify_deps thm_names deps_map ((lno, t, deps) :: lines) =
  14.424 -      if lno <= Vector.length thm_names  (*axiom*)
  14.425 -      then (Vector.sub(thm_names,lno-1), t, []) :: stringify_deps thm_names deps_map lines
  14.426 -      else let val lname = Int.toString (length deps_map)
  14.427 -               fun fix lno = if lno <= Vector.length thm_names
  14.428 -                             then SOME(Vector.sub(thm_names,lno-1))
  14.429 -                             else AList.lookup op= deps_map lno;
  14.430 -           in  (lname, t, map_filter fix (distinct (op=) deps)) ::
  14.431 -               stringify_deps thm_names ((lno,lname)::deps_map) lines
  14.432 -           end;
  14.433 -
  14.434 -val proofstart = "proof (neg_clausify)\n";
  14.435 -
  14.436 -fun isar_header [] = proofstart
  14.437 -  | isar_header ts = proofstart ^ "fix " ^ space_implode " " ts ^ "\n";
  14.438 -
  14.439 -fun decode_tstp_file cnfs ctxt th sgno thm_names =
  14.440 -  let val _ = trace "\ndecode_tstp_file: start\n"
  14.441 -      val tuples = map (dest_tstp o tstp_line o explode) cnfs
  14.442 -      val _ = trace (Int.toString (length tuples) ^ " tuples extracted\n")
  14.443 -      val ctxt = ProofContext.set_mode ProofContext.mode_schematic ctxt
  14.444 -      val raw_lines = List.foldr add_prfline [] (decode_tstp_list ctxt tuples)
  14.445 -      val _ = trace (Int.toString (length raw_lines) ^ " raw_lines extracted\n")
  14.446 -      val nonnull_lines = List.foldr add_nonnull_prfline [] raw_lines
  14.447 -      val _ = trace (Int.toString (length nonnull_lines) ^ " nonnull_lines extracted\n")
  14.448 -      val (_,lines) = List.foldr (add_wanted_prfline ctxt) (0,[]) nonnull_lines
  14.449 -      val _ = trace (Int.toString (length lines) ^ " lines extracted\n")
  14.450 -      val (ccls,fixes) = Res_Axioms.neg_conjecture_clauses ctxt th sgno
  14.451 -      val _ = trace (Int.toString (length ccls) ^ " conjecture clauses\n")
  14.452 -      val ccls = map forall_intr_vars ccls
  14.453 -      val _ =
  14.454 -        if ! Res_Axioms.trace then app (fn th => trace ("\nccl: " ^ string_of_thm ctxt th)) ccls
  14.455 -        else ()
  14.456 -      val ilines = isar_lines ctxt (map prop_of ccls) (stringify_deps thm_names [] lines)
  14.457 -      val _ = trace "\ndecode_tstp_file: finishing\n"
  14.458 -  in
  14.459 -    isar_header (map #1 fixes) ^ implode ilines ^ "qed\n"
  14.460 -  end handle STREE _ => error "Could not extract proof (ATP output malformed?)";
  14.461 -
  14.462 -
  14.463 -(*=== EXTRACTING PROOF-TEXT === *)
  14.464 -
  14.465 -val begin_proof_strings = ["# SZS output start CNFRefutation.",
  14.466 -  "=========== Refutation ==========",
  14.467 -  "Here is a proof"];
  14.468 -
  14.469 -val end_proof_strings = ["# SZS output end CNFRefutation",
  14.470 -  "======= End of refutation =======",
  14.471 -  "Formulae used in the proof"];
  14.472 -
  14.473 -fun get_proof_extract proof =
  14.474 -  let
  14.475 -    (*splits to_split by the first possible of a list of splitters*)
  14.476 -    val (begin_string, end_string) =
  14.477 -      (find_first (fn s => String.isSubstring s proof) begin_proof_strings,
  14.478 -      find_first (fn s => String.isSubstring s proof) end_proof_strings)
  14.479 -  in
  14.480 -    if is_none begin_string orelse is_none end_string
  14.481 -    then error "Could not extract proof (no substring indicating a proof)"
  14.482 -    else proof |> first_field (the begin_string) |> the |> snd
  14.483 -               |> first_field (the end_string) |> the |> fst
  14.484 -  end;
  14.485 -
  14.486 -(* ==== CHECK IF PROOF OF E OR VAMPIRE WAS SUCCESSFUL === *)
  14.487 -
  14.488 -val failure_strings_E = ["SZS status: Satisfiable","SZS status Satisfiable",
  14.489 -  "SZS status: ResourceOut","SZS status ResourceOut","# Cannot determine problem status"];
  14.490 -val failure_strings_vampire = ["Satisfiability detected", "Refutation not found", "CANNOT PROVE"];
  14.491 -val failure_strings_SPASS = ["SPASS beiseite: Completion found.",
  14.492 -  "SPASS beiseite: Ran out of time.", "SPASS beiseite: Maximal number of loops exceeded."];
  14.493 -val failure_strings_remote = ["Remote-script could not extract proof"];
  14.494 -fun find_failure proof =
  14.495 -  let val failures =
  14.496 -    map_filter (fn s => if String.isSubstring s proof then SOME s else NONE)
  14.497 -      (failure_strings_E @ failure_strings_vampire @ failure_strings_SPASS @ failure_strings_remote)
  14.498 -  val correct = null failures andalso
  14.499 -    exists (fn s => String.isSubstring s proof) begin_proof_strings andalso
  14.500 -    exists (fn s => String.isSubstring s proof) end_proof_strings
  14.501 -  in
  14.502 -    if correct then NONE
  14.503 -    else if null failures then SOME "Output of ATP not in proper format"
  14.504 -    else SOME (hd failures) end;
  14.505 -
  14.506 -(* === EXTRACTING LEMMAS === *)
  14.507 -(* lines have the form "cnf(108, axiom, ...",
  14.508 -the number (108) has to be extracted)*)
  14.509 -fun get_step_nums false proofextract =
  14.510 -  let val toks = String.tokens (not o Char.isAlphaNum)
  14.511 -  fun inputno ("cnf"::ntok::"axiom"::_) = Int.fromString ntok
  14.512 -    | inputno ("cnf"::ntok::"negated"::"conjecture"::_) = Int.fromString ntok
  14.513 -    | inputno _ = NONE
  14.514 -  val lines = split_lines proofextract
  14.515 -  in  map_filter (inputno o toks) lines  end
  14.516 -(*String contains multiple lines. We want those of the form
  14.517 -  "253[0:Inp] et cetera..."
  14.518 -  A list consisting of the first number in each line is returned. *)
  14.519 -|  get_step_nums true proofextract =
  14.520 -  let val toks = String.tokens (not o Char.isAlphaNum)
  14.521 -  fun inputno (ntok::"0"::"Inp"::_) = Int.fromString ntok
  14.522 -    | inputno _ = NONE
  14.523 -  val lines = split_lines proofextract
  14.524 -  in  map_filter (inputno o toks) lines  end
  14.525 -  
  14.526 -(*extracting lemmas from tstp-output between the lines from above*)
  14.527 -fun extract_lemmas get_step_nums (proof, thm_names, conj_count, _, _, _) =
  14.528 -  let
  14.529 -  (* get the names of axioms from their numbers*)
  14.530 -  fun get_axiom_names thm_names step_nums =
  14.531 -    let
  14.532 -    val last_axiom = Vector.length thm_names
  14.533 -    fun is_axiom n = n <= last_axiom
  14.534 -    fun is_conj n = n >= fst conj_count andalso n < fst conj_count + snd conj_count
  14.535 -    fun getname i = Vector.sub(thm_names, i-1)
  14.536 -    in
  14.537 -      (sort_distinct string_ord (filter (fn x => x <> "??.unknown")
  14.538 -        (map getname (filter is_axiom step_nums))),
  14.539 -      exists is_conj step_nums)
  14.540 -    end
  14.541 -  val proofextract = get_proof_extract proof
  14.542 -  in
  14.543 -    get_axiom_names thm_names (get_step_nums proofextract)
  14.544 -  end;
  14.545 -
  14.546 -(*Used to label theorems chained into the sledgehammer call*)
  14.547 -val chained_hint = "CHAINED";
  14.548 -val nochained = filter_out (fn y => y = chained_hint)
  14.549 -  
  14.550 -(* metis-command *)
  14.551 -fun metis_line [] = "apply metis"
  14.552 -  | metis_line xs = "apply (metis " ^ space_implode " " xs ^ ")"
  14.553 -
  14.554 -(* atp_minimize [atp=<prover>] <lemmas> *)
  14.555 -fun minimize_line _ [] = ""
  14.556 -  | minimize_line name lemmas = "For minimizing the number of lemmas try this command:\n" ^
  14.557 -        (Markup.markup Markup.sendback) ("atp_minimize [atp=" ^ name ^ "] " ^
  14.558 -                                         space_implode " " (nochained lemmas))
  14.559 -
  14.560 -fun sendback_metis_nochained lemmas =
  14.561 -  (Markup.markup Markup.sendback o metis_line) (nochained lemmas)
  14.562 -
  14.563 -fun lemma_list dfg name result =
  14.564 -  let val (lemmas, used_conj) = extract_lemmas (get_step_nums dfg) result
  14.565 -  in (sendback_metis_nochained lemmas ^ "\n" ^ minimize_line name lemmas ^
  14.566 -    (if used_conj then ""
  14.567 -     else "\nWarning: Goal is provable because context is inconsistent."),
  14.568 -     nochained lemmas)
  14.569 -  end;
  14.570 -
  14.571 -(* === Extracting structured Isar-proof === *)
  14.572 -fun structured_proof name (result as (proof, thm_names, conj_count, ctxt, goal, subgoalno)) =
  14.573 -  let
  14.574 -  (*Could use split_lines, but it can return blank lines...*)
  14.575 -  val lines = String.tokens (equal #"\n");
  14.576 -  val nospaces = String.translate (fn c => if Char.isSpace c then "" else str c)
  14.577 -  val proofextract = get_proof_extract proof
  14.578 -  val cnfs = filter (String.isPrefix "cnf(") (map nospaces (lines proofextract))
  14.579 -  val (one_line_proof, lemma_names) = lemma_list false name result
  14.580 -  val structured =
  14.581 -    if chained_hint mem_string (String.tokens (fn c => c = #" ") one_line_proof) then ""
  14.582 -    else decode_tstp_file cnfs ctxt goal subgoalno thm_names
  14.583 -  in
  14.584 -  (one_line_proof ^ "\n\n" ^ Markup.markup Markup.sendback structured, lemma_names)
  14.585 -end
  14.586 -
  14.587 -end;