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