src/HOL/Tools/res_hol_clause.ML
author wenzelm
Sat Jan 20 14:09:14 2007 +0100 (2007-01-20)
changeset 22130 0906fd95e0b5
parent 22078 5084f53cef39
child 22825 bd774e01d6d5
permissions -rw-r--r--
Output.debug: non-strict;
renamed Output.show_debug_msgs to Output.debugging (coincides with Toplevel.debug);
     1 (* ID: $Id$ 
     2    Author: Jia Meng, NICTA
     3 
     4 FOL clauses translated from HOL formulae.  Combinators are used to represent lambda terms.
     5 *)
     6 
     7 structure ResHolClause =
     8 
     9 struct
    10 
    11 structure RC = ResClause;
    12 
    13 (* theorems for combinators and function extensionality *)
    14 val ext = thm "HOL.ext";
    15 val comb_I = thm "ATP_Linkup.COMBI_def";
    16 val comb_K = thm "ATP_Linkup.COMBK_def";
    17 val comb_B = thm "ATP_Linkup.COMBB_def";
    18 val comb_C = thm "ATP_Linkup.COMBC_def";
    19 val comb_S = thm "ATP_Linkup.COMBS_def";
    20 val comb_B' = thm "ATP_Linkup.COMBB'_def";
    21 val comb_C' = thm "ATP_Linkup.COMBC'_def";
    22 val comb_S' = thm "ATP_Linkup.COMBS'_def";
    23 val fequal_imp_equal = thm "ATP_Linkup.fequal_imp_equal";
    24 val equal_imp_fequal = thm "ATP_Linkup.equal_imp_fequal";
    25 
    26 (*A flag to set if we use the Turner optimizations. Currently FALSE, as the 5 standard
    27   combinators appear to work best.*)
    28 val use_Turner = ref false;
    29 
    30 (*If true, each function will be directly applied to as many arguments as possible, avoiding
    31   use of the "apply" operator. Use of hBOOL is also minimized.*)
    32 val minimize_applies = ref true;
    33 
    34 val const_typargs = ref (Library.K [] : (string*typ -> typ list));
    35 
    36 val const_min_arity = ref (Symtab.empty : int Symtab.table);
    37 
    38 val const_needs_hBOOL = ref (Symtab.empty : bool Symtab.table);
    39 
    40 fun min_arity_of c = getOpt (Symtab.lookup(!const_min_arity) c, 0);
    41 
    42 fun needs_hBOOL c = not (!minimize_applies) orelse 
    43                     getOpt (Symtab.lookup(!const_needs_hBOOL) c, false);
    44 
    45 fun init thy = 
    46   (const_typargs := Sign.const_typargs thy; 
    47    const_min_arity := Symtab.empty; 
    48    const_needs_hBOOL := Symtab.empty);
    49 
    50 (**********************************************************************)
    51 (* convert a Term.term with lambdas into a Term.term with combinators *) 
    52 (**********************************************************************)
    53 
    54 fun is_free (Bound(a)) n = (a = n)
    55   | is_free (Abs(x,_,b)) n = (is_free b (n+1))
    56   | is_free (P $ Q) n = ((is_free P n) orelse (is_free Q n))
    57   | is_free _ _ = false;
    58 
    59 fun mk_compact_comb (tm as (Const("ATP_Linkup.COMBB",_)$p) $ (Const("ATP_Linkup.COMBB",_)$q$r)) bnds =
    60       let val tp_p = Term.type_of1(bnds,p)
    61 	  val tp_q = Term.type_of1(bnds,q)
    62 	  val tp_r = Term.type_of1(bnds,r)
    63 	  val typ_B' = [tp_p,tp_q,tp_r] ---> Term.type_of1(bnds,tm)
    64       in
    65 	  Const("ATP_Linkup.COMBB'",typ_B') $ p $ q $ r
    66       end
    67   | mk_compact_comb (tm as (Const("ATP_Linkup.COMBC",_) $ (Const("ATP_Linkup.COMBB",_)$p$q) $ r)) bnds =
    68       let val tp_p = Term.type_of1(bnds,p)
    69 	  val tp_q = Term.type_of1(bnds,q)
    70 	  val tp_r = Term.type_of1(bnds,r)
    71 	  val typ_C' = [tp_p,tp_q,tp_r] ---> Term.type_of1(bnds,tm)
    72       in
    73 	  Const("ATP_Linkup.COMBC'",typ_C') $ p $ q $ r
    74       end
    75   | mk_compact_comb (tm as (Const("ATP_Linkup.COMBS",_) $ (Const("ATP_Linkup.COMBB",_)$p$q) $ r)) bnds =
    76       let val tp_p = Term.type_of1(bnds,p)
    77 	  val tp_q = Term.type_of1(bnds,q)
    78 	  val tp_r = Term.type_of1(bnds,r)
    79 	  val typ_S' = [tp_p,tp_q,tp_r] ---> Term.type_of1(bnds,tm)
    80       in
    81 	  Const("ATP_Linkup.COMBS'",typ_S') $ p $ q $ r
    82       end
    83   | mk_compact_comb tm _ = tm;
    84 
    85 fun compact_comb t bnds = 
    86   if !use_Turner then mk_compact_comb t bnds else t;
    87 
    88 fun lam2comb (Abs(x,tp,Bound 0)) _ = Const("ATP_Linkup.COMBI",tp-->tp) 
    89   | lam2comb (Abs(x,tp,Bound n)) bnds = 
    90       let val tb = List.nth(bnds,n-1)
    91       in  Const("ATP_Linkup.COMBK", [tb,tp] ---> tb) $ Bound (n-1)  end
    92   | lam2comb (Abs(x,t1,Const(c,t2))) _ = Const("ATP_Linkup.COMBK",[t2,t1] ---> t2) $ Const(c,t2) 
    93   | lam2comb (Abs(x,t1,Free(v,t2))) _ = Const("ATP_Linkup.COMBK",[t2,t1] ---> t2) $ Free(v,t2)
    94   | lam2comb (Abs(x,t1,Var(ind,t2))) _ = Const("ATP_Linkup.COMBK", [t2,t1] ---> t2) $ Var(ind,t2)
    95   | lam2comb (t as (Abs(x,t1,P$(Bound 0)))) bnds =
    96       if is_free P 0 then 
    97 	  let val tI = [t1] ---> t1
    98 	      val P' = lam2comb (Abs(x,t1,P)) bnds
    99 	      val tp' = Term.type_of1(bnds,P')
   100 	      val tS = [tp',tI] ---> Term.type_of1(t1::bnds,P)
   101 	  in
   102 	      compact_comb (Const("ATP_Linkup.COMBS",tS) $ P' $ 
   103 	                     Const("ATP_Linkup.COMBI",tI)) bnds
   104 	  end
   105       else incr_boundvars ~1 P
   106   | lam2comb (t as (Abs(x,t1,P$Q))) bnds =
   107       let val nfreeP = not(is_free P 0)
   108 	  and nfreeQ = not(is_free Q 0)
   109 	  val tpq = Term.type_of1(t1::bnds, P$Q) 
   110       in
   111 	  if nfreeP andalso nfreeQ 
   112 	  then 
   113 	    let val tK = [tpq,t1] ---> tpq
   114 	    in  Const("ATP_Linkup.COMBK",tK) $ incr_boundvars ~1 (P $ Q)  end
   115 	  else if nfreeP then 
   116 	    let val Q' = lam2comb (Abs(x,t1,Q)) bnds
   117 		val P' = incr_boundvars ~1 P
   118 		val tp = Term.type_of1(bnds,P')
   119 		val tq' = Term.type_of1(bnds, Q')
   120 		val tB = [tp,tq',t1] ---> tpq
   121 	    in  compact_comb (Const("ATP_Linkup.COMBB",tB) $ P' $ Q') bnds  end
   122 	  else if nfreeQ then 
   123 	    let val P' = lam2comb (Abs(x,t1,P)) bnds
   124 		val Q' = incr_boundvars ~1 Q
   125 		val tq = Term.type_of1(bnds,Q')
   126 		val tp' = Term.type_of1(bnds, P')
   127 		val tC = [tp',tq,t1] ---> tpq
   128 	    in  compact_comb (Const("ATP_Linkup.COMBC",tC) $ P' $ Q') bnds  end
   129           else
   130 	    let val P' = lam2comb (Abs(x,t1,P)) bnds
   131 		val Q' = lam2comb (Abs(x,t1,Q)) bnds 
   132 		val tp' = Term.type_of1(bnds,P')
   133 		val tq' = Term.type_of1(bnds,Q')
   134 		val tS = [tp',tq',t1] ---> tpq
   135 	    in  compact_comb (Const("ATP_Linkup.COMBS",tS) $ P' $ Q') bnds  end
   136       end
   137   | lam2comb (t as (Abs(x,t1,_))) _ = raise RC.CLAUSE("HOL CLAUSE",t);
   138 
   139 fun to_comb (Abs(x,tp,b)) bnds = lam2comb (Abs(x, tp, to_comb b (tp::bnds))) bnds 
   140   | to_comb (P $ Q) bnds = (to_comb P bnds) $ (to_comb Q bnds)
   141   | to_comb t _ = t;
   142 
   143 
   144 (******************************************************)
   145 (* data types for typed combinator expressions        *)
   146 (******************************************************)
   147 
   148 datatype type_level = T_FULL | T_PARTIAL | T_CONST | T_NONE;
   149 
   150 val typ_level = ref T_CONST;
   151 
   152 fun full_types () = (typ_level:=T_FULL);
   153 fun partial_types () = (typ_level:=T_PARTIAL);
   154 fun const_types_only () = (typ_level:=T_CONST);
   155 fun no_types () = (typ_level:=T_NONE);
   156 
   157 fun find_typ_level () = !typ_level;
   158 
   159 type axiom_name = string;
   160 type polarity = bool;
   161 type clause_id = int;
   162 
   163 datatype combterm = CombConst of string * RC.fol_type * RC.fol_type list
   164 		  | CombFree of string * RC.fol_type
   165 		  | CombVar of string * RC.fol_type
   166 		  | CombApp of combterm * combterm
   167 		  
   168 datatype literal = Literal of polarity * combterm;
   169 
   170 datatype clause = 
   171 	 Clause of {clause_id: clause_id,
   172 		    axiom_name: axiom_name,
   173 		    th: thm,
   174 		    kind: RC.kind,
   175 		    literals: literal list,
   176 		    ctypes_sorts: (RC.typ_var * Term.sort) list, 
   177                     ctvar_type_literals: RC.type_literal list, 
   178                     ctfree_type_literals: RC.type_literal list};
   179 
   180 
   181 (*********************************************************************)
   182 (* convert a clause with type Term.term to a clause with type clause *)
   183 (*********************************************************************)
   184 
   185 fun isFalse (Literal(pol, CombConst(c,_,_))) =
   186       (pol andalso c = "c_False") orelse
   187       (not pol andalso c = "c_True")
   188   | isFalse _ = false;
   189 
   190 fun isTrue (Literal (pol, CombConst(c,_,_))) =
   191       (pol andalso c = "c_True") orelse
   192       (not pol andalso c = "c_False")
   193   | isTrue _ = false;
   194   
   195 fun isTaut (Clause {literals,...}) = exists isTrue literals;  
   196 
   197 fun type_of (Type (a, Ts)) =
   198       let val (folTypes,ts) = types_of Ts
   199       in  (RC.Comp(RC.make_fixed_type_const a, folTypes), ts)  end
   200   | type_of (tp as (TFree(a,s))) =
   201       (RC.AtomF (RC.make_fixed_type_var a), [RC.mk_typ_var_sort tp])
   202   | type_of (tp as (TVar(v,s))) =
   203       (RC.AtomV (RC.make_schematic_type_var v), [RC.mk_typ_var_sort tp])
   204 and types_of Ts =
   205       let val (folTyps,ts) = ListPair.unzip (map type_of Ts)
   206       in  (folTyps, RC.union_all ts)  end;
   207 
   208 (* same as above, but no gathering of sort information *)
   209 fun simp_type_of (Type (a, Ts)) = 
   210       RC.Comp(RC.make_fixed_type_const a, map simp_type_of Ts)
   211   | simp_type_of (TFree (a,s)) = RC.AtomF(RC.make_fixed_type_var a)
   212   | simp_type_of (TVar (v,s)) = RC.AtomV(RC.make_schematic_type_var v);
   213 
   214 
   215 fun const_type_of (c,t) =
   216       let val (tp,ts) = type_of t
   217       in  (tp, ts, map simp_type_of (!const_typargs(c,t))) end;
   218 
   219 (* convert a Term.term (with combinators) into a combterm, also accummulate sort info *)
   220 fun combterm_of (Const(c,t)) =
   221       let val (tp,ts,tvar_list) = const_type_of (c,t)
   222 	  val c' = CombConst(RC.make_fixed_const c, tp, tvar_list)
   223       in  (c',ts)  end
   224   | combterm_of (Free(v,t)) =
   225       let val (tp,ts) = type_of t
   226 	  val v' = if RC.isMeta v then CombVar(RC.make_schematic_var(v,0),tp)
   227 		   else CombFree(RC.make_fixed_var v,tp)
   228       in  (v',ts)  end
   229   | combterm_of (Var(v,t)) =
   230       let val (tp,ts) = type_of t
   231 	  val v' = CombVar(RC.make_schematic_var v,tp)
   232       in  (v',ts)  end
   233   | combterm_of (t as (P $ Q)) =
   234       let val (P',tsP) = combterm_of P
   235 	  val (Q',tsQ) = combterm_of Q
   236       in  (CombApp(P',Q'), tsP union tsQ)  end;
   237 
   238 fun predicate_of ((Const("Not",_) $ P), polarity) = predicate_of (P, not polarity)
   239   | predicate_of (t,polarity) = (combterm_of t, polarity);
   240 
   241 fun literals_of_term1 args (Const("Trueprop",_) $ P) = literals_of_term1 args P
   242   | literals_of_term1 args (Const("op |",_) $ P $ Q) = 
   243       literals_of_term1 (literals_of_term1 args P) Q
   244   | literals_of_term1 (lits,ts) P =
   245       let val ((pred,ts'),pol) = predicate_of (P,true)
   246       in
   247 	  (Literal(pol,pred)::lits, ts union ts')
   248       end;
   249 
   250 fun literals_of_term P = literals_of_term1 ([],[]) P;
   251 
   252 (* making axiom and conjecture clauses *)
   253 fun make_clause(clause_id,axiom_name,kind,th) =
   254     let val (lits,ctypes_sorts) = literals_of_term (to_comb (prop_of th) [])
   255 	val (ctvar_lits,ctfree_lits) = RC.add_typs_aux ctypes_sorts
   256     in
   257 	if forall isFalse lits
   258 	then error "Problem too trivial for resolution (empty clause)"
   259 	else
   260 	    Clause {clause_id = clause_id, axiom_name = axiom_name, th = th, kind = kind,
   261 		    literals = lits, ctypes_sorts = ctypes_sorts, 
   262 		    ctvar_type_literals = ctvar_lits,
   263 		    ctfree_type_literals = ctfree_lits}
   264     end;
   265 
   266 
   267 fun add_axiom_clause ((th,(name,id)), pairs) =
   268   let val cls = make_clause(id, name, RC.Axiom, th)
   269   in
   270       if isTaut cls then pairs else (name,cls)::pairs
   271   end;
   272 
   273 val make_axiom_clauses = foldl add_axiom_clause [];
   274 
   275 fun make_conjecture_clauses_aux _ [] = []
   276   | make_conjecture_clauses_aux n (th::ths) =
   277       make_clause(n,"conjecture", RC.Conjecture, th) ::
   278       make_conjecture_clauses_aux (n+1) ths;
   279 
   280 val make_conjecture_clauses = make_conjecture_clauses_aux 0;
   281 
   282 
   283 (**********************************************************************)
   284 (* convert clause into ATP specific formats:                          *)
   285 (* TPTP used by Vampire and E                                         *)
   286 (* DFG used by SPASS                                                  *)
   287 (**********************************************************************)
   288 
   289 val type_wrapper = "typeinfo";
   290 
   291 fun wrap_type (c,tp) = case !typ_level of
   292 	T_FULL => type_wrapper ^ RC.paren_pack [c, RC.string_of_fol_type tp]
   293       | _ => c;
   294     
   295 
   296 val bool_tp = RC.make_fixed_type_const "bool";
   297 
   298 val app_str = "hAPP";
   299 
   300 (*Result of a function type; no need to check that the argument type matches.*)
   301 fun result_type (RC.Comp ("tc_fun", [_, tp2])) = tp2
   302   | result_type _ = raise ERROR "result_type"
   303 
   304 fun type_of_combterm (CombConst(c,tp,_)) = tp
   305   | type_of_combterm (CombFree(v,tp)) = tp
   306   | type_of_combterm (CombVar(v,tp)) = tp
   307   | type_of_combterm (CombApp(t1,t2)) = result_type (type_of_combterm t1);
   308 
   309 (*gets the head of a combinator application, along with the list of arguments*)
   310 fun strip_comb u =
   311     let fun stripc (CombApp(t,u), ts) = stripc (t, u::ts)
   312         |   stripc  x =  x
   313     in  stripc(u,[])  end;
   314 
   315 fun string_of_combterm1 (CombConst(c,tp,_)) = 
   316       let val c' = if c = "equal" then "c_fequal" else c
   317       in  wrap_type (c',tp)  end
   318   | string_of_combterm1 (CombFree(v,tp)) = wrap_type (v,tp)
   319   | string_of_combterm1 (CombVar(v,tp)) = wrap_type (v,tp)
   320   | string_of_combterm1 (CombApp(t1,t2)) =
   321       let val s1 = string_of_combterm1 t1
   322 	  and s2 = string_of_combterm1 t2
   323       in
   324 	  case !typ_level of
   325 	      T_FULL => type_wrapper ^ 
   326 	                RC.paren_pack 
   327 	                  [app_str ^ RC.paren_pack [s1,s2], 
   328 	                   RC.string_of_fol_type (result_type (type_of_combterm t1))]
   329 	    | T_PARTIAL => app_str ^ RC.paren_pack 
   330 	                     [s1,s2, RC.string_of_fol_type (type_of_combterm t1)]
   331 	    | T_NONE => app_str ^ RC.paren_pack [s1,s2]
   332 	    | T_CONST => raise ERROR "string_of_combterm1"
   333       end;
   334 
   335 fun rev_apply (v, []) = v
   336   | rev_apply (v, arg::args) = app_str ^ RC.paren_pack [rev_apply (v, args), arg];
   337 
   338 fun string_apply (v, args) = rev_apply (v, rev args);
   339 
   340 (*Apply an operator to the argument strings, using either the "apply" operator or
   341   direct function application.*)
   342 fun string_of_applic (CombConst(c,_,tvars), args) =
   343       let val c = if c = "equal" then "c_fequal" else c
   344           val nargs = min_arity_of c
   345           val args1 = List.take(args, nargs) @ (map RC.string_of_fol_type tvars)
   346             handle Subscript => raise ERROR ("string_of_applic: " ^ c ^ " has arity " ^
   347 					     Int.toString nargs ^ " but is applied to " ^ 
   348 					     space_implode ", " args) 
   349           val args2 = List.drop(args, nargs)
   350       in
   351 	  string_apply (c ^ RC.paren_pack args1, args2)
   352       end
   353   | string_of_applic (CombFree(v,_), args) = string_apply (v, args)
   354   | string_of_applic (CombVar(v,_), args) = string_apply (v, args)  
   355   | string_of_applic _ = raise ERROR "string_of_applic";
   356 
   357 fun string_of_combterm2 t = 
   358   let val (head, args) = strip_comb t
   359   in  string_of_applic (head, map string_of_combterm2 args)  end;
   360 
   361 fun string_of_combterm t = 
   362     case !typ_level of T_CONST => string_of_combterm2 t
   363 		           | _ => string_of_combterm1 t;
   364 
   365 (*Boolean-valued terms are here converted to literals.*)
   366 fun boolify t = "hBOOL" ^ RC.paren_pack [string_of_combterm t];
   367 
   368 fun string_of_predicate t = 
   369   case t of
   370       (CombApp(CombApp(CombConst("equal",_,_), t1), t2)) =>
   371 	  (*DFG only: new TPTP prefers infix equality*)
   372 	  ("equal" ^ RC.paren_pack [string_of_combterm t1, string_of_combterm t2])
   373     | _ => 
   374           case #1 (strip_comb t) of
   375               CombConst(c,_,_) => if needs_hBOOL c then boolify t else string_of_combterm t
   376             | _ => boolify t;
   377 
   378 fun string_of_clausename (cls_id,ax_name) = 
   379     RC.clause_prefix ^ RC.ascii_of ax_name ^ "_" ^ Int.toString cls_id;
   380 
   381 fun string_of_type_clsname (cls_id,ax_name,idx) = 
   382     string_of_clausename (cls_id,ax_name) ^ "_tcs" ^ (Int.toString idx);
   383 
   384 
   385 (*** tptp format ***)
   386 
   387 fun tptp_of_equality pol (t1,t2) =
   388   let val eqop = if pol then " = " else " != "
   389   in  string_of_combterm t1 ^ eqop ^ string_of_combterm t2  end;
   390 
   391 fun tptp_literal (Literal(pol, CombApp(CombApp(CombConst("equal",_,_), t1), t2))) = 
   392       tptp_of_equality pol (t1,t2)
   393   | tptp_literal (Literal(pol,pred)) = 
   394       RC.tptp_sign pol (string_of_predicate pred);
   395  
   396 (*Given a clause, returns its literals paired with a list of literals concerning TFrees;
   397   the latter should only occur in conjecture clauses.*)
   398 fun tptp_type_lits (Clause cls) = 
   399     let val lits = map tptp_literal (#literals cls)
   400 	val ctvar_lits_strs =
   401 	    case !typ_level of T_NONE => []
   402 	      | _ => map RC.tptp_of_typeLit (#ctvar_type_literals cls)
   403 	val ctfree_lits = 
   404 	    case !typ_level of T_NONE => []
   405 	      | _ => map RC.tptp_of_typeLit (#ctfree_type_literals cls)
   406     in
   407 	(ctvar_lits_strs @ lits, ctfree_lits)
   408     end; 
   409     
   410 fun clause2tptp (cls as Clause{axiom_name,clause_id,kind,ctypes_sorts,...}) =
   411     let val (lits,ctfree_lits) = tptp_type_lits cls
   412 	val cls_str = RC.gen_tptp_cls(clause_id,axiom_name,kind,lits)
   413     in
   414 	(cls_str,ctfree_lits)
   415     end;
   416 
   417 
   418 (*** dfg format ***)
   419 
   420 fun dfg_literal (Literal(pol,pred)) = RC.dfg_sign pol (string_of_predicate pred);
   421 
   422 fun dfg_clause_aux (Clause{literals, ctypes_sorts, ...}) = 
   423   let val lits = map dfg_literal literals
   424       val (tvar_lits,tfree_lits) = RC.add_typs_aux ctypes_sorts
   425       val tvar_lits_strs = 
   426 	  case !typ_level of T_NONE => [] 
   427 	      | _ => map RC.dfg_of_typeLit tvar_lits
   428       val tfree_lits =
   429           case !typ_level of T_NONE => []
   430 	      | _ => map RC.dfg_of_typeLit tfree_lits 
   431   in
   432       (tvar_lits_strs @ lits, tfree_lits)
   433   end; 
   434 
   435 fun get_uvars (CombConst _) vars = vars
   436   | get_uvars (CombFree _) vars = vars
   437   | get_uvars (CombVar(v,_)) vars = (v::vars)
   438   | get_uvars (CombApp(P,Q)) vars = get_uvars P (get_uvars Q vars);
   439 
   440 fun get_uvars_l (Literal(_,c)) = get_uvars c [];
   441 
   442 fun dfg_vars (Clause {literals,...}) = RC.union_all (map get_uvars_l literals);
   443  
   444 fun clause2dfg (cls as Clause{axiom_name,clause_id,kind,ctypes_sorts,...}) =
   445     let val (lits,tfree_lits) = dfg_clause_aux cls 
   446         val vars = dfg_vars cls
   447         val tvars = RC.get_tvar_strs ctypes_sorts
   448 	val knd = RC.name_of_kind kind
   449 	val lits_str = commas lits
   450 	val cls_str = RC.gen_dfg_cls(clause_id, axiom_name, knd, lits_str, tvars@vars) 
   451     in (cls_str, tfree_lits) end;
   452 
   453 (** For DFG format: accumulate function and predicate declarations **)
   454 
   455 fun addtypes tvars tab = foldl RC.add_foltype_funcs tab tvars;
   456 
   457 fun add_decls (CombConst(c,_,tvars), (funcs,preds)) =
   458       if c = "equal" then (addtypes tvars funcs, preds)
   459       else
   460 	(case !typ_level of
   461 	     T_CONST => 
   462                let val arity = min_arity_of c + length tvars
   463                    val addit = Symtab.update(c,arity) 
   464                in
   465                    if needs_hBOOL c then (addtypes tvars (addit funcs), preds)
   466                    else (addtypes tvars funcs, addit preds)
   467                end
   468            | _ => (addtypes tvars (Symtab.update(c,0) funcs), preds))
   469   | add_decls (CombFree(v,ctp), (funcs,preds)) = 
   470       (RC.add_foltype_funcs (ctp,Symtab.update (v,0) funcs), preds)
   471   | add_decls (CombVar(_,ctp), (funcs,preds)) = 
   472       (RC.add_foltype_funcs (ctp,funcs), preds)
   473   | add_decls (CombApp(P,Q),decls) = add_decls(P,add_decls (Q,decls));
   474 
   475 fun add_literal_decls (Literal(_,c), decls) = add_decls (c,decls);
   476 
   477 fun add_clause_decls (Clause {literals, ...}, decls) =
   478     foldl add_literal_decls decls literals
   479     handle Symtab.DUP a => raise ERROR ("function " ^ a ^ " has multiple arities")
   480 
   481 fun decls_of_clauses clauses arity_clauses =
   482   let val happ_ar = case !typ_level of T_PARTIAL => 3 | _ => 2
   483       val init_functab = Symtab.update ("typeinfo",2) (Symtab.update ("hAPP",happ_ar) Symtab.empty)
   484       val init_predtab = Symtab.update ("hBOOL",1) Symtab.empty
   485       val (functab,predtab) = (foldl add_clause_decls (init_functab, init_predtab) clauses)
   486   in
   487       (Symtab.dest (foldl RC.add_arityClause_funcs functab arity_clauses), 
   488        Symtab.dest predtab)
   489   end;
   490 
   491 fun add_clause_preds (Clause {ctypes_sorts, ...}, preds) =
   492   foldl RC.add_type_sort_preds preds ctypes_sorts
   493   handle Symtab.DUP a => raise ERROR ("predicate " ^ a ^ " has multiple arities")
   494 
   495 (*Higher-order clauses have only the predicates hBOOL and type classes.*)
   496 fun preds_of_clauses clauses clsrel_clauses arity_clauses = 
   497     Symtab.dest
   498 	(foldl RC.add_classrelClause_preds 
   499 	       (foldl RC.add_arityClause_preds
   500 		      (foldl add_clause_preds Symtab.empty clauses) 
   501 		      arity_clauses)
   502 	       clsrel_clauses)
   503 
   504 
   505 
   506 (**********************************************************************)
   507 (* write clauses to files                                             *)
   508 (**********************************************************************)
   509 
   510 
   511 val init_counters =
   512     Symtab.make [("c_COMBI", 0), ("c_COMBK", 0),
   513 		 ("c_COMBB", 0), ("c_COMBC", 0),
   514 		 ("c_COMBS", 0), ("c_COMBB_e", 0),
   515 		 ("c_COMBC_e", 0), ("c_COMBS_e", 0)];
   516                 
   517 fun count_combterm (CombConst(c,tp,_), ct) = 
   518      (case Symtab.lookup ct c of NONE => ct  (*no counter*)
   519                                | SOME n => Symtab.update (c,n+1) ct)
   520   | count_combterm (CombFree(v,tp), ct) = ct
   521   | count_combterm (CombVar(v,tp), ct) = ct
   522   | count_combterm (CombApp(t1,t2), ct) = count_combterm(t1, count_combterm(t2, ct));
   523 
   524 fun count_literal (Literal(_,t), ct) = count_combterm(t,ct);
   525 
   526 fun count_clause (Clause{literals,...}, ct) = foldl count_literal ct literals;
   527 
   528 fun count_user_clause user_lemmas (Clause{axiom_name,literals,...}, ct) = 
   529   if axiom_name mem_string user_lemmas then foldl count_literal ct literals
   530   else ct;
   531 
   532 val cnf_helper_thms = ResAxioms.cnf_rules_pairs o (map ResAxioms.pairname)
   533 
   534 fun get_helper_clauses (conjectures, axclauses, user_lemmas) =
   535     let val ct0 = foldl count_clause init_counters conjectures
   536         val ct = foldl (count_user_clause user_lemmas) ct0 axclauses
   537         fun needed c = valOf (Symtab.lookup ct c) > 0
   538         val IK = if needed "c_COMBI" orelse needed "c_COMBK" 
   539                  then (Output.debug (fn () => "Include combinator I K"); cnf_helper_thms [comb_I,comb_K]) 
   540                  else []
   541 	val BC = if needed "c_COMBB" orelse needed "c_COMBC" 
   542 	         then (Output.debug (fn () => "Include combinator B C"); cnf_helper_thms [comb_B,comb_C]) 
   543 	         else []
   544 	val S = if needed "c_COMBS" 
   545 	        then (Output.debug (fn () => "Include combinator S"); cnf_helper_thms [comb_S]) 
   546 	        else []
   547 	val B'C' = if needed "c_COMBB_e" orelse needed "c_COMBC_e" 
   548 	           then (Output.debug (fn () => "Include combinator B' C'"); cnf_helper_thms [comb_B', comb_C']) 
   549 	           else []
   550 	val S' = if needed "c_COMBS_e" 
   551 	         then (Output.debug (fn () => "Include combinator S'"); cnf_helper_thms [comb_S']) 
   552 	         else []
   553 	val other = cnf_helper_thms [ext,fequal_imp_equal,equal_imp_fequal]
   554     in
   555 	map #2 (make_axiom_clauses (other @ IK @ BC @ S @ B'C' @ S'))
   556     end
   557 
   558 (*Find the minimal arity of each function mentioned in the term. Also, note which uses
   559   are not at top level, to see if hBOOL is needed.*)
   560 fun count_constants_term toplev t =
   561   let val (head, args) = strip_comb t
   562       val n = length args
   563       val _ = List.app (count_constants_term false) args
   564   in
   565       case head of
   566 	  CombConst (a,_,_) => (*predicate or function version of "equal"?*)
   567 	    let val a = if a="equal" andalso not toplev then "c_fequal" else a
   568 	    in  
   569 	      const_min_arity := Symtab.map_default (a,n) (curry Int.min n) (!const_min_arity);
   570 	      if toplev then ()
   571 	      else const_needs_hBOOL := Symtab.update (a,true) (!const_needs_hBOOL)
   572 	    end
   573 	| ts => ()
   574   end;
   575 
   576 (*A literal is a top-level term*)
   577 fun count_constants_lit (Literal (_,t)) = count_constants_term true t;
   578 
   579 fun count_constants_clause (Clause{literals,...}) = List.app count_constants_lit literals;
   580 
   581 fun display_arity (c,n) =
   582   Output.debug (fn () => "Constant: " ^ c ^ " arity:\t" ^ Int.toString n ^ 
   583                 (if needs_hBOOL c then " needs hBOOL" else ""));
   584 
   585 fun count_constants (conjectures, axclauses, helper_clauses) = 
   586   if !minimize_applies then
   587     (List.app count_constants_clause conjectures;
   588      List.app count_constants_clause axclauses;
   589      List.app count_constants_clause helper_clauses;
   590      List.app display_arity (Symtab.dest (!const_min_arity)))
   591   else ();
   592 
   593 (* tptp format *)
   594 						  
   595 (* write TPTP format to a single file *)
   596 fun tptp_write_file thms filename (ax_tuples,classrel_clauses,arity_clauses) user_lemmas =
   597     let val conjectures = make_conjecture_clauses thms
   598         val (clnames,axclauses) = ListPair.unzip (make_axiom_clauses ax_tuples)
   599 	val helper_clauses = get_helper_clauses (conjectures, axclauses, user_lemmas)
   600 	val _ = count_constants (conjectures, axclauses, helper_clauses);
   601 	val (tptp_clss,tfree_litss) = ListPair.unzip (map clause2tptp conjectures)
   602 	val tfree_clss = map RC.tptp_tfree_clause (foldl (op union_string) [] tfree_litss)
   603         val out = TextIO.openOut filename
   604     in
   605 	List.app (curry TextIO.output out o #1 o clause2tptp) axclauses;
   606 	RC.writeln_strs out tfree_clss;
   607 	RC.writeln_strs out tptp_clss;
   608 	List.app (curry TextIO.output out o RC.tptp_classrelClause) classrel_clauses;
   609 	List.app (curry TextIO.output out o RC.tptp_arity_clause) arity_clauses;
   610 	List.app (curry TextIO.output out o #1 o clause2tptp) helper_clauses;
   611 	TextIO.closeOut out;
   612 	clnames
   613     end;
   614 
   615 
   616 
   617 (* dfg format *)
   618 
   619 fun dfg_write_file  thms filename (ax_tuples,classrel_clauses,arity_clauses) user_lemmas =
   620     let val conjectures = make_conjecture_clauses thms
   621         val (clnames,axclauses) = ListPair.unzip (make_axiom_clauses ax_tuples)
   622 	val helper_clauses = get_helper_clauses (conjectures, axclauses, user_lemmas)
   623 	val _ = count_constants (conjectures, axclauses, helper_clauses);
   624 	val (dfg_clss,tfree_litss) = ListPair.unzip (map clause2dfg conjectures)
   625 	and probname = Path.implode (Path.base (Path.explode filename))
   626 	val axstrs = map (#1 o clause2dfg) axclauses
   627 	val tfree_clss = map RC.dfg_tfree_clause (RC.union_all tfree_litss)
   628 	val out = TextIO.openOut filename
   629 	val helper_clauses_strs = map (#1 o clause2dfg) helper_clauses
   630 	val (funcs,cl_preds) = decls_of_clauses (helper_clauses @ conjectures @ axclauses) arity_clauses
   631 	and ty_preds = preds_of_clauses axclauses classrel_clauses arity_clauses
   632     in
   633 	TextIO.output (out, RC.string_of_start probname); 
   634 	TextIO.output (out, RC.string_of_descrip probname); 
   635 	TextIO.output (out, RC.string_of_symbols 
   636 	                      (RC.string_of_funcs funcs) 
   637 	                      (RC.string_of_preds (cl_preds @ ty_preds))); 
   638 	TextIO.output (out, "list_of_clauses(axioms,cnf).\n");
   639 	RC.writeln_strs out axstrs;
   640 	List.app (curry TextIO.output out o RC.dfg_classrelClause) classrel_clauses;
   641 	List.app (curry TextIO.output out o RC.dfg_arity_clause) arity_clauses;
   642 	RC.writeln_strs out helper_clauses_strs;
   643 	TextIO.output (out, "end_of_list.\n\nlist_of_clauses(conjectures,cnf).\n");
   644 	RC.writeln_strs out tfree_clss;
   645 	RC.writeln_strs out dfg_clss;
   646 	TextIO.output (out, "end_of_list.\n\n");
   647 	(*VarWeight=3 helps the HO problems, probably by counteracting the presence of hAPP*)
   648 	TextIO.output (out, "list_of_settings(SPASS).\n{*\nset_flag(VarWeight,3).\n*}\nend_of_list.\n\n");
   649 	TextIO.output (out, "end_problem.\n");
   650 	TextIO.closeOut out;
   651 	clnames
   652     end;
   653 
   654 end