src/HOL/Tools/prop_logic.ML
author wenzelm
Thu Aug 03 17:30:36 2006 +0200 (2006-08-03)
changeset 20328 5b240a4216b0
parent 17809 195045659c06
child 20442 04621ea9440e
permissions -rw-r--r--
RuleInsts.bires_inst_tac;
webertj@14452
     1
(*  Title:      HOL/Tools/prop_logic.ML
webertj@14452
     2
    ID:         $Id$
webertj@14452
     3
    Author:     Tjark Weber
webertj@16907
     4
    Copyright   2004-2005
webertj@14452
     5
webertj@14452
     6
Formulas of propositional logic.
webertj@14452
     7
*)
webertj@14452
     8
webertj@14452
     9
signature PROP_LOGIC =
webertj@14452
    10
sig
webertj@14452
    11
	datatype prop_formula =
webertj@14452
    12
		  True
webertj@14452
    13
		| False
webertj@14452
    14
		| BoolVar of int  (* NOTE: only use indices >= 1 *)
webertj@14452
    15
		| Not of prop_formula
webertj@14452
    16
		| Or of prop_formula * prop_formula
webertj@14452
    17
		| And of prop_formula * prop_formula
webertj@14452
    18
webertj@16909
    19
	val SNot     : prop_formula -> prop_formula
webertj@16909
    20
	val SOr      : prop_formula * prop_formula -> prop_formula
webertj@16909
    21
	val SAnd     : prop_formula * prop_formula -> prop_formula
webertj@16909
    22
	val simplify : prop_formula -> prop_formula  (* eliminates True/False and double-negation *)
webertj@14452
    23
webertj@14681
    24
	val indices : prop_formula -> int list  (* set of all variable indices *)
webertj@15301
    25
	val maxidx  : prop_formula -> int       (* maximal variable index *)
webertj@14452
    26
webertj@14452
    27
	val exists      : prop_formula list -> prop_formula  (* finite disjunction *)
webertj@14452
    28
	val all         : prop_formula list -> prop_formula  (* finite conjunction *)
webertj@14452
    29
	val dot_product : prop_formula list * prop_formula list -> prop_formula
webertj@14452
    30
webertj@16909
    31
	val nnf    : prop_formula -> prop_formula  (* negation normal form *)
webertj@16909
    32
	val cnf    : prop_formula -> prop_formula  (* conjunctive normal form *)
webertj@16909
    33
	val auxcnf : prop_formula -> prop_formula  (* cnf with auxiliary variables *)
webertj@16909
    34
	val defcnf : prop_formula -> prop_formula  (* definitional cnf *)
webertj@16909
    35
webertj@14452
    36
	val eval : (int -> bool) -> prop_formula -> bool  (* semantics *)
webertj@17809
    37
webertj@17809
    38
	val prop_formula_of_term : Term.term -> int Termtab.table -> prop_formula * int Termtab.table
webertj@17809
    39
		(* propositional representation of HOL terms *)
webertj@14452
    40
end;
webertj@14452
    41
webertj@14452
    42
structure PropLogic : PROP_LOGIC =
webertj@14452
    43
struct
webertj@14452
    44
webertj@14452
    45
(* ------------------------------------------------------------------------- *)
webertj@14753
    46
(* prop_formula: formulas of propositional logic, built from Boolean         *)
webertj@14452
    47
(*               variables (referred to by index) and True/False using       *)
webertj@14452
    48
(*               not/or/and                                                  *)
webertj@14452
    49
(* ------------------------------------------------------------------------- *)
webertj@14452
    50
webertj@14452
    51
	datatype prop_formula =
webertj@14452
    52
		  True
webertj@14452
    53
		| False
webertj@14452
    54
		| BoolVar of int  (* NOTE: only use indices >= 1 *)
webertj@14452
    55
		| Not of prop_formula
webertj@14452
    56
		| Or of prop_formula * prop_formula
webertj@14452
    57
		| And of prop_formula * prop_formula;
webertj@14452
    58
webertj@14452
    59
(* ------------------------------------------------------------------------- *)
webertj@14452
    60
(* The following constructor functions make sure that True and False do not  *)
webertj@14452
    61
(* occur within any of the other connectives (i.e. Not, Or, And), and        *)
webertj@14452
    62
(* perform double-negation elimination.                                      *)
webertj@14452
    63
(* ------------------------------------------------------------------------- *)
webertj@14452
    64
webertj@14452
    65
	(* prop_formula -> prop_formula *)
webertj@14452
    66
webertj@14452
    67
	fun SNot True     = False
webertj@14452
    68
	  | SNot False    = True
webertj@14452
    69
	  | SNot (Not fm) = fm
webertj@14452
    70
	  | SNot fm       = Not fm;
webertj@14452
    71
webertj@14452
    72
	(* prop_formula * prop_formula -> prop_formula *)
webertj@14452
    73
webertj@14452
    74
	fun SOr (True, _)   = True
webertj@14452
    75
	  | SOr (_, True)   = True
webertj@14452
    76
	  | SOr (False, fm) = fm
webertj@14452
    77
	  | SOr (fm, False) = fm
webertj@14452
    78
	  | SOr (fm1, fm2)  = Or (fm1, fm2);
webertj@14452
    79
webertj@14452
    80
	(* prop_formula * prop_formula -> prop_formula *)
webertj@14452
    81
webertj@14452
    82
	fun SAnd (True, fm) = fm
webertj@14452
    83
	  | SAnd (fm, True) = fm
webertj@14452
    84
	  | SAnd (False, _) = False
webertj@14452
    85
	  | SAnd (_, False) = False
webertj@14452
    86
	  | SAnd (fm1, fm2) = And (fm1, fm2);
webertj@14452
    87
webertj@14452
    88
(* ------------------------------------------------------------------------- *)
webertj@16909
    89
(* simplify: eliminates True/False below other connectives, and double-      *)
webertj@16909
    90
(*      negation                                                             *)
webertj@16909
    91
(* ------------------------------------------------------------------------- *)
webertj@16909
    92
webertj@16909
    93
	(* prop_formula -> prop_formula *)
webertj@16909
    94
webertj@16909
    95
	fun simplify (Not fm)         = SNot (simplify fm)
webertj@16909
    96
	  | simplify (Or (fm1, fm2))  = SOr (simplify fm1, simplify fm2)
webertj@16909
    97
	  | simplify (And (fm1, fm2)) = SAnd (simplify fm1, simplify fm2)
webertj@16909
    98
	  | simplify fm               = fm;
webertj@16909
    99
webertj@16909
   100
(* ------------------------------------------------------------------------- *)
webertj@14753
   101
(* indices: collects all indices of Boolean variables that occur in a        *)
webertj@14452
   102
(*      propositional formula 'fm'; no duplicates                            *)
webertj@14452
   103
(* ------------------------------------------------------------------------- *)
webertj@14452
   104
webertj@14452
   105
	(* prop_formula -> int list *)
webertj@14452
   106
webertj@16909
   107
	fun indices True             = []
webertj@16909
   108
	  | indices False            = []
webertj@16909
   109
	  | indices (BoolVar i)      = [i]
webertj@16909
   110
	  | indices (Not fm)         = indices fm
webertj@16909
   111
	  | indices (Or (fm1, fm2))  = (indices fm1) union_int (indices fm2)
webertj@16909
   112
	  | indices (And (fm1, fm2)) = (indices fm1) union_int (indices fm2);
webertj@14452
   113
webertj@14452
   114
(* ------------------------------------------------------------------------- *)
webertj@14452
   115
(* maxidx: computes the maximal variable index occuring in a formula of      *)
webertj@14452
   116
(*      propositional logic 'fm'; 0 if 'fm' contains no variable             *)
webertj@14452
   117
(* ------------------------------------------------------------------------- *)
webertj@14452
   118
webertj@14452
   119
	(* prop_formula -> int *)
webertj@14452
   120
webertj@16909
   121
	fun maxidx True             = 0
webertj@16909
   122
	  | maxidx False            = 0
webertj@16909
   123
	  | maxidx (BoolVar i)      = i
webertj@16909
   124
	  | maxidx (Not fm)         = maxidx fm
webertj@16909
   125
	  | maxidx (Or (fm1, fm2))  = Int.max (maxidx fm1, maxidx fm2)
webertj@16909
   126
	  | maxidx (And (fm1, fm2)) = Int.max (maxidx fm1, maxidx fm2);
webertj@16909
   127
webertj@16909
   128
(* ------------------------------------------------------------------------- *)
webertj@16909
   129
(* exists: computes the disjunction over a list 'xs' of propositional        *)
webertj@16909
   130
(*      formulas                                                             *)
webertj@16909
   131
(* ------------------------------------------------------------------------- *)
webertj@16909
   132
webertj@16909
   133
	(* prop_formula list -> prop_formula *)
webertj@16909
   134
webertj@16909
   135
	fun exists xs = Library.foldl SOr (False, xs);
webertj@16909
   136
webertj@16909
   137
(* ------------------------------------------------------------------------- *)
webertj@16909
   138
(* all: computes the conjunction over a list 'xs' of propositional formulas  *)
webertj@16909
   139
(* ------------------------------------------------------------------------- *)
webertj@16909
   140
webertj@16909
   141
	(* prop_formula list -> prop_formula *)
webertj@16909
   142
webertj@16909
   143
	fun all xs = Library.foldl SAnd (True, xs);
webertj@16909
   144
webertj@16909
   145
(* ------------------------------------------------------------------------- *)
webertj@16909
   146
(* dot_product: ([x1,...,xn], [y1,...,yn]) -> x1*y1+...+xn*yn                *)
webertj@16909
   147
(* ------------------------------------------------------------------------- *)
webertj@16909
   148
webertj@16909
   149
	(* prop_formula list * prop_formula list -> prop_formula *)
webertj@16909
   150
webertj@16909
   151
	fun dot_product (xs,ys) = exists (map SAnd (xs~~ys));
webertj@14452
   152
webertj@14452
   153
(* ------------------------------------------------------------------------- *)
webertj@14452
   154
(* nnf: computes the negation normal form of a formula 'fm' of propositional *)
webertj@16909
   155
(*      logic (i.e. only variables may be negated, but not subformulas).     *)
webertj@16909
   156
(*      Simplification (c.f. 'simplify') is performed as well.               *)
webertj@14452
   157
(* ------------------------------------------------------------------------- *)
webertj@14452
   158
webertj@14452
   159
	(* prop_formula -> prop_formula *)
webertj@14452
   160
webertj@14452
   161
	fun
webertj@14452
   162
	(* constants *)
webertj@16909
   163
	    nnf True                   = True
webertj@16909
   164
	  | nnf False                  = False
webertj@14452
   165
	(* variables *)
webertj@16909
   166
	  | nnf (BoolVar i)            = (BoolVar i)
webertj@14452
   167
	(* 'or' and 'and' as outermost connectives are left untouched *)
webertj@16909
   168
	  | nnf (Or  (fm1, fm2))       = SOr  (nnf fm1, nnf fm2)
webertj@16909
   169
	  | nnf (And (fm1, fm2))       = SAnd (nnf fm1, nnf fm2)
webertj@14452
   170
	(* 'not' + constant *)
webertj@16909
   171
	  | nnf (Not True)             = False
webertj@16909
   172
	  | nnf (Not False)            = True
webertj@14452
   173
	(* 'not' + variable *)
webertj@16909
   174
	  | nnf (Not (BoolVar i))      = Not (BoolVar i)
webertj@14452
   175
	(* pushing 'not' inside of 'or'/'and' using de Morgan's laws *)
webertj@16909
   176
	  | nnf (Not (Or  (fm1, fm2))) = SAnd (nnf (SNot fm1), nnf (SNot fm2))
webertj@16909
   177
	  | nnf (Not (And (fm1, fm2))) = SOr  (nnf (SNot fm1), nnf (SNot fm2))
webertj@14452
   178
	(* double-negation elimination *)
webertj@16909
   179
	  | nnf (Not (Not fm))         = nnf fm;
webertj@14452
   180
webertj@14452
   181
(* ------------------------------------------------------------------------- *)
webertj@14681
   182
(* cnf: computes the conjunctive normal form (i.e. a conjunction of          *)
webertj@14681
   183
(*      disjunctions) of a formula 'fm' of propositional logic.  The result  *)
webertj@14681
   184
(*      formula may be exponentially longer than 'fm'.                       *)
webertj@14452
   185
(* ------------------------------------------------------------------------- *)
webertj@14452
   186
webertj@14452
   187
	(* prop_formula -> prop_formula *)
webertj@14452
   188
webertj@14452
   189
	fun cnf fm =
webertj@14452
   190
	let
webertj@14452
   191
		fun
webertj@14452
   192
		(* constants *)
webertj@14939
   193
		    cnf_from_nnf True             = True
webertj@14939
   194
		  | cnf_from_nnf False            = False
webertj@14452
   195
		(* literals *)
webertj@14939
   196
		  | cnf_from_nnf (BoolVar i)      = BoolVar i
webertj@14939
   197
		  | cnf_from_nnf (Not fm1)        = Not fm1  (* 'fm1' must be a variable since the formula is in NNF *)
webertj@14452
   198
		(* pushing 'or' inside of 'and' using distributive laws *)
webertj@14939
   199
		  | cnf_from_nnf (Or (fm1, fm2))  =
webertj@14452
   200
			let
webertj@14939
   201
				fun cnf_or (And (fm11, fm12), fm2) =
webertj@14939
   202
					And (cnf_or (fm11, fm2), cnf_or (fm12, fm2))
webertj@14939
   203
				  | cnf_or (fm1, And (fm21, fm22)) =
webertj@14939
   204
					And (cnf_or (fm1, fm21), cnf_or (fm1, fm22))
webertj@14939
   205
				(* neither subformula contains 'and' *)
webertj@14939
   206
				  | cnf_or (fm1, fm2) =
webertj@14939
   207
					Or (fm1, fm2)
webertj@14452
   208
			in
webertj@14939
   209
				cnf_or (cnf_from_nnf fm1, cnf_from_nnf fm2)
webertj@14452
   210
			end
webertj@14452
   211
		(* 'and' as outermost connective is left untouched *)
webertj@14939
   212
		  | cnf_from_nnf (And (fm1, fm2)) = And (cnf_from_nnf fm1, cnf_from_nnf fm2)
webertj@14452
   213
	in
webertj@14452
   214
		(cnf_from_nnf o nnf) fm
webertj@14452
   215
	end;
webertj@14452
   216
webertj@14452
   217
(* ------------------------------------------------------------------------- *)
webertj@16909
   218
(* auxcnf: computes the definitional conjunctive normal form of a formula    *)
webertj@14681
   219
(*      'fm' of propositional logic, introducing auxiliary variables if      *)
webertj@14681
   220
(*      necessary to avoid an exponential blowup of the formula.  The result *)
webertj@14681
   221
(*      formula is satisfiable if and only if 'fm' is satisfiable.           *)
webertj@16907
   222
(*      Auxiliary variables are introduced as switches for OR-nodes, based   *)
webertj@16909
   223
(*      on the observation that e.g. "fm1 OR (fm21 AND fm22)" is             *)
webertj@16909
   224
(*      equisatisfiable with "(fm1 OR ~aux) AND (fm21 OR aux) AND (fm22 OR   *)
webertj@16909
   225
(*      aux)".                                                               *)
webertj@16909
   226
(* ------------------------------------------------------------------------- *)
webertj@16909
   227
webertj@16909
   228
(* ------------------------------------------------------------------------- *)
webertj@16909
   229
(* Note: 'auxcnf' tends to use fewer variables and fewer clauses than        *)
webertj@16913
   230
(*      'defcnf' below, but sometimes generates much larger SAT problems     *)
webertj@16909
   231
(*      overall (hence it must sometimes generate longer clauses than        *)
webertj@16909
   232
(*      'defcnf' does).  It is currently not quite clear to me if one of the *)
webertj@16913
   233
(*      algorithms is clearly superior to the other, but I suggest using     *)
webertj@16913
   234
(*      'defcnf' instead.                                                    *)
webertj@14452
   235
(* ------------------------------------------------------------------------- *)
webertj@14452
   236
webertj@14452
   237
	(* prop_formula -> prop_formula *)
webertj@14452
   238
webertj@16909
   239
	fun auxcnf fm =
webertj@14452
   240
	let
webertj@16907
   241
		(* convert formula to NNF first *)
webertj@16907
   242
		val fm' = nnf fm
webertj@14452
   243
		(* 'new' specifies the next index that is available to introduce an auxiliary variable *)
webertj@16907
   244
		(* int ref *)
webertj@16907
   245
		val new = ref (maxidx fm' + 1)
webertj@16907
   246
		(* unit -> int *)
webertj@16907
   247
		fun new_idx () = let val idx = !new in new := idx+1; idx end
webertj@16907
   248
		(* prop_formula -> prop_formula *)
webertj@14452
   249
		fun
webertj@14452
   250
		(* constants *)
webertj@16909
   251
		    auxcnf_from_nnf True  = True
webertj@16909
   252
		  | auxcnf_from_nnf False = False
webertj@14452
   253
		(* literals *)
webertj@16909
   254
		  | auxcnf_from_nnf (BoolVar i) = BoolVar i
webertj@16909
   255
		  | auxcnf_from_nnf (Not fm1)   = Not fm1  (* 'fm1' must be a variable since the formula is in NNF *)
webertj@14939
   256
		(* pushing 'or' inside of 'and' using auxiliary variables *)
webertj@16909
   257
		  | auxcnf_from_nnf (Or (fm1, fm2)) =
webertj@14452
   258
			let
webertj@16909
   259
				val fm1' = auxcnf_from_nnf fm1
webertj@16909
   260
				val fm2' = auxcnf_from_nnf fm2
webertj@16907
   261
				(* prop_formula * prop_formula -> prop_formula *)
webertj@16909
   262
				fun auxcnf_or (And (fm11, fm12), fm2) =
webertj@14964
   263
					(case fm2 of
webertj@14964
   264
					(* do not introduce an auxiliary variable for literals *)
webertj@14964
   265
					  BoolVar _ =>
webertj@16909
   266
							And (auxcnf_or (fm11, fm2), auxcnf_or (fm12, fm2))
webertj@14964
   267
					| Not _ =>
webertj@16909
   268
							And (auxcnf_or (fm11, fm2), auxcnf_or (fm12, fm2))
webertj@14964
   269
					| _ =>
webertj@14964
   270
						let
webertj@16907
   271
							val aux = BoolVar (new_idx ())
webertj@14964
   272
						in
webertj@16909
   273
							And (And (auxcnf_or (fm11, aux), auxcnf_or (fm12, aux)), auxcnf_or (fm2, Not aux))
webertj@14964
   274
						end)
webertj@16909
   275
				  | auxcnf_or (fm1, And (fm21, fm22)) =
webertj@14964
   276
					(case fm1 of
webertj@14964
   277
					(* do not introduce an auxiliary variable for literals *)
webertj@14964
   278
					  BoolVar _ =>
webertj@16909
   279
							And (auxcnf_or (fm1, fm21), auxcnf_or (fm1, fm22))
webertj@14964
   280
					| Not _ =>
webertj@16909
   281
							And (auxcnf_or (fm1, fm21), auxcnf_or (fm1, fm22))
webertj@14964
   282
					| _ =>
webertj@14964
   283
						let
webertj@16907
   284
							val aux = BoolVar (new_idx ())
webertj@14964
   285
						in
webertj@16909
   286
							And (auxcnf_or (fm1, Not aux), And (auxcnf_or (fm21, aux), auxcnf_or (fm22, aux)))
webertj@14964
   287
						end)
webertj@14939
   288
				(* neither subformula contains 'and' *)
webertj@16909
   289
				  | auxcnf_or (fm1, fm2) =
webertj@16907
   290
					Or (fm1, fm2)
webertj@14939
   291
			in
webertj@16909
   292
				auxcnf_or (fm1', fm2')
webertj@14452
   293
			end
webertj@14452
   294
		(* 'and' as outermost connective is left untouched *)
webertj@16909
   295
		  | auxcnf_from_nnf (And (fm1, fm2)) =
webertj@16909
   296
				And (auxcnf_from_nnf fm1, auxcnf_from_nnf fm2)
webertj@14452
   297
	in
webertj@16909
   298
		auxcnf_from_nnf fm'
webertj@14452
   299
	end;
webertj@14452
   300
webertj@14452
   301
(* ------------------------------------------------------------------------- *)
webertj@16909
   302
(* defcnf: computes the definitional conjunctive normal form of a formula    *)
webertj@16909
   303
(*      'fm' of propositional logic, introducing auxiliary variables to      *)
webertj@16909
   304
(*      avoid an exponential blowup of the formula.  The result formula is   *)
webertj@16909
   305
(*      satisfiable if and only if 'fm' is satisfiable.  Auxiliary variables *)
webertj@16909
   306
(*      are introduced as abbreviations for AND-, OR-, and NOT-nodes, based  *)
webertj@16909
   307
(*      on the following equisatisfiabilities (+/- indicates polarity):      *)
webertj@16909
   308
(*      LITERAL+       == LITERAL                                            *)
webertj@16909
   309
(*      LITERAL-       == NOT LITERAL                                        *)
webertj@16909
   310
(*      (NOT fm1)+     == aux AND (NOT aux OR fm1-)                          *)
webertj@16909
   311
(*      (fm1 OR fm2)+  == aux AND (NOT aux OR fm1+ OR fm2+)                  *)
webertj@16909
   312
(*      (fm1 AND fm2)+ == aux AND (NOT aux OR fm1+) AND (NOT aux OR fm2+)    *)
webertj@16909
   313
(*      (NOT fm1)-     == aux AND (NOT aux OR fm1+)                          *)
webertj@16909
   314
(*      (fm1 OR fm2)-  == aux AND (NOT aux OR fm1-) AND (NOT aux OR fm2-)    *)
webertj@16909
   315
(*      (fm1 AND fm2)- == aux AND (NOT aux OR fm1- OR fm2-)                  *)
webertj@16909
   316
(*      Example:                                                             *)
webertj@16909
   317
(*      NOT (a AND b) == aux1 AND (NOT aux1 OR aux2)                         *)
webertj@16909
   318
(*                            AND (NOT aux2 OR NOT a OR NOT b)               *)
webertj@14452
   319
(* ------------------------------------------------------------------------- *)
webertj@14452
   320
webertj@16909
   321
	(* prop_formula -> prop_formula *)
webertj@14452
   322
webertj@16909
   323
	fun defcnf fm =
webertj@16909
   324
	let
webertj@16909
   325
		(* simplify formula first *)
webertj@16909
   326
		val fm' = simplify fm
webertj@16909
   327
		(* 'new' specifies the next index that is available to introduce an auxiliary variable *)
webertj@16909
   328
		(* int ref *)
webertj@16909
   329
		val new = ref (maxidx fm' + 1)
webertj@16909
   330
		(* unit -> int *)
webertj@16909
   331
		fun new_idx () = let val idx = !new in new := idx+1; idx end
webertj@16909
   332
		(* optimization for n-ary disjunction/conjunction *)
webertj@16909
   333
		(* prop_formula -> prop_formula list *)
webertj@16909
   334
		fun disjuncts (Or (fm1, fm2)) = (disjuncts fm1) @ (disjuncts fm2)
webertj@16909
   335
		  | disjuncts fm1             = [fm1]
webertj@16909
   336
		(* prop_formula -> prop_formula list *)
webertj@16909
   337
		fun conjuncts (And (fm1, fm2)) = (conjuncts fm1) @ (conjuncts fm2)
webertj@16909
   338
		  | conjuncts fm1              = [fm1]
webertj@16909
   339
		(* polarity -> formula -> (defining clauses, literal) *)
webertj@16909
   340
		(* bool -> prop_formula -> prop_formula * prop_formula *)
webertj@16909
   341
		fun
webertj@16909
   342
		(* constants *)
webertj@16909
   343
		    defcnf' true  True  = (True, True)
webertj@16909
   344
		  | defcnf' false True  = (*(True, False)*) error "formula is not simplified, True occurs with negative polarity"
webertj@16909
   345
		  | defcnf' true  False = (True, False)
webertj@16909
   346
		  | defcnf' false False = (*(True, True)*) error "formula is not simplified, False occurs with negative polarity"
webertj@16909
   347
		(* literals *)
webertj@16909
   348
		  | defcnf' true  (BoolVar i)       = (True, BoolVar i)
webertj@16909
   349
		  | defcnf' false (BoolVar i)       = (True, Not (BoolVar i))
webertj@16909
   350
		  | defcnf' true  (Not (BoolVar i)) = (True, Not (BoolVar i))
webertj@16909
   351
		  | defcnf' false (Not (BoolVar i)) = (True, BoolVar i)
webertj@16909
   352
		(* 'not' *)
webertj@16909
   353
		  | defcnf' polarity (Not fm1) =
webertj@16909
   354
			let
webertj@16909
   355
				val (def1, aux1) = defcnf' (not polarity) fm1
webertj@16909
   356
				val aux          = BoolVar (new_idx ())
webertj@16909
   357
				val def          = Or (Not aux, aux1)
webertj@16909
   358
			in
webertj@16909
   359
				(SAnd (def1, def), aux)
webertj@16909
   360
			end
webertj@16909
   361
		(* 'or' *)
webertj@16909
   362
		  | defcnf' polarity (Or (fm1, fm2)) =
webertj@16909
   363
			let
webertj@16909
   364
				val fms          = disjuncts (Or (fm1, fm2))
webertj@16909
   365
				val (defs, auxs) = split_list (map (defcnf' polarity) fms)
webertj@16909
   366
				val aux          = BoolVar (new_idx ())
webertj@16909
   367
				val def          = if polarity then Or (Not aux, exists auxs) else all (map (fn a => Or (Not aux, a)) auxs)
webertj@16909
   368
			in
webertj@16909
   369
				(SAnd (all defs, def), aux)
webertj@16909
   370
			end
webertj@16909
   371
		(* 'and' *)
webertj@16909
   372
		  | defcnf' polarity (And (fm1, fm2)) =
webertj@16909
   373
			let
webertj@16909
   374
				val fms          = conjuncts (And (fm1, fm2))
webertj@16909
   375
				val (defs, auxs) = split_list (map (defcnf' polarity) fms)
webertj@16909
   376
				val aux          = BoolVar (new_idx ())
webertj@16909
   377
				val def          = if not polarity then Or (Not aux, exists auxs) else all (map (fn a => Or (Not aux, a)) auxs)
webertj@16909
   378
			in
webertj@16909
   379
				(SAnd (all defs, def), aux)
webertj@16909
   380
			end
webertj@16909
   381
		(* optimization: do not introduce auxiliary variables for parts of the formula that are in CNF already *)
webertj@16909
   382
		(* prop_formula -> prop_formula * prop_formula *)
webertj@16909
   383
		fun defcnf_or (Or (fm1, fm2)) =
webertj@16909
   384
			let
webertj@16909
   385
				val (def1, aux1) = defcnf_or fm1
webertj@16909
   386
				val (def2, aux2) = defcnf_or fm2
webertj@16909
   387
			in
webertj@16909
   388
				(SAnd (def1, def2), Or (aux1, aux2))
webertj@16909
   389
			end
webertj@16909
   390
		  | defcnf_or fm =
webertj@16909
   391
			defcnf' true fm
webertj@16909
   392
		(* prop_formula -> prop_formula * prop_formula *)
webertj@16909
   393
		fun defcnf_and (And (fm1, fm2)) =
webertj@16909
   394
			let
webertj@16909
   395
				val (def1, aux1) = defcnf_and fm1
webertj@16909
   396
				val (def2, aux2) = defcnf_and fm2
webertj@16909
   397
			in
webertj@16909
   398
				(SAnd (def1, def2), And (aux1, aux2))
webertj@16909
   399
			end
webertj@16909
   400
		  | defcnf_and (Or (fm1, fm2)) =
webertj@16909
   401
			let
webertj@16909
   402
				val (def1, aux1) = defcnf_or fm1
webertj@16909
   403
				val (def2, aux2) = defcnf_or fm2
webertj@16909
   404
			in
webertj@16909
   405
				(SAnd (def1, def2), Or (aux1, aux2))
webertj@16909
   406
			end
webertj@16909
   407
		  | defcnf_and fm =
webertj@16909
   408
			defcnf' true fm
webertj@16909
   409
	in
webertj@16909
   410
		SAnd (defcnf_and fm')
webertj@16909
   411
	end;
webertj@14452
   412
webertj@14452
   413
(* ------------------------------------------------------------------------- *)
webertj@14753
   414
(* eval: given an assignment 'a' of Boolean values to variable indices, the  *)
webertj@14452
   415
(*      truth value of a propositional formula 'fm' is computed              *)
webertj@14452
   416
(* ------------------------------------------------------------------------- *)
webertj@14452
   417
webertj@14452
   418
	(* (int -> bool) -> prop_formula -> bool *)
webertj@14452
   419
webertj@14452
   420
	fun eval a True            = true
webertj@14452
   421
	  | eval a False           = false
webertj@14452
   422
	  | eval a (BoolVar i)     = (a i)
webertj@14452
   423
	  | eval a (Not fm)        = not (eval a fm)
webertj@14452
   424
	  | eval a (Or (fm1,fm2))  = (eval a fm1) orelse (eval a fm2)
webertj@14452
   425
	  | eval a (And (fm1,fm2)) = (eval a fm1) andalso (eval a fm2);
webertj@14452
   426
webertj@17809
   427
(* ------------------------------------------------------------------------- *)
webertj@17809
   428
(* prop_formula_of_term: returns the propositional structure of a HOL term,  *)
webertj@17809
   429
(*      with subterms replaced by Boolean variables.  Also returns a table   *)
webertj@17809
   430
(*      of terms and corresponding variables that extends the table that was *)
webertj@17809
   431
(*      given as an argument.  Usually, you'll just want to use              *)
webertj@17809
   432
(*      'Termtab.empty' as value for 'table'.                                *)
webertj@17809
   433
(* ------------------------------------------------------------------------- *)
webertj@17809
   434
webertj@17809
   435
(* Note: The implementation is somewhat optimized; the next index to be used *)
webertj@17809
   436
(*       is computed only when it is actually needed.  However, when         *)
webertj@17809
   437
(*       'prop_formula_of_term' is invoked many times, it might be more      *)
webertj@17809
   438
(*       efficient to pass and return this value as an additional parameter, *)
webertj@17809
   439
(*       so that it does not have to be recomputed (by folding over the      *)
webertj@17809
   440
(*       table) for each invocation.                                         *)
webertj@17809
   441
webertj@17809
   442
	(* Term.term -> int Termtab.table -> prop_formula * int Termtab.table *)
webertj@17809
   443
	fun prop_formula_of_term t table =
webertj@17809
   444
	let
webertj@17809
   445
		val next_idx_is_valid = ref false
webertj@17809
   446
		val next_idx          = ref 0
webertj@17809
   447
		fun get_next_idx () =
webertj@17809
   448
			if !next_idx_is_valid then
webertj@17809
   449
				inc next_idx
webertj@17809
   450
			else (
webertj@17809
   451
				next_idx          := Termtab.fold (curry Int.max o snd) table 0;
webertj@17809
   452
				next_idx_is_valid := true;
webertj@17809
   453
				inc next_idx
webertj@17809
   454
			)
webertj@17809
   455
		fun aux (Const ("True", _))         table =
webertj@17809
   456
			(True, table)
webertj@17809
   457
		  | aux (Const ("False", _))        table =
webertj@17809
   458
			(False, table)
webertj@17809
   459
		  | aux (Const ("Not", _) $ x)      table =
webertj@17809
   460
			apfst Not (aux x table)
webertj@17809
   461
		  | aux (Const ("op |", _) $ x $ y) table =
webertj@17809
   462
			let
webertj@17809
   463
				val (fm1, table1) = aux x table
webertj@17809
   464
				val (fm2, table2) = aux y table1
webertj@17809
   465
			in
webertj@17809
   466
				(Or (fm1, fm2), table2)
webertj@17809
   467
			end
webertj@17809
   468
		  | aux (Const ("op &", _) $ x $ y) table =
webertj@17809
   469
			let
webertj@17809
   470
				val (fm1, table1) = aux x table
webertj@17809
   471
				val (fm2, table2) = aux y table1
webertj@17809
   472
			in
webertj@17809
   473
				(And (fm1, fm2), table2)
webertj@17809
   474
			end
webertj@17809
   475
		  | aux x                           table =
webertj@17809
   476
			(case Termtab.lookup table x of
webertj@17809
   477
			  SOME i =>
webertj@17809
   478
				(BoolVar i, table)
webertj@17809
   479
			| NONE   =>
webertj@17809
   480
				let
webertj@17809
   481
					val i = get_next_idx ()
webertj@17809
   482
				in
webertj@17809
   483
					(BoolVar i, Termtab.update (x, i) table)
webertj@17809
   484
				end)
webertj@17809
   485
	in
webertj@17809
   486
		aux t table
webertj@17809
   487
	end;
webertj@17809
   488
webertj@14452
   489
end;