;;; Representations for propositional logic: normal forms
;;; and abstract syntax operations.
;;; File also contains code relating to variables and binding lists,
;;; which may be useful for propositionalization of first-order expressions.

;;;; Convert Expressions to Normal Form (Conjunctive, Implicative or Horn)

;;; This could be done much more efficiently by using a special
;;; representation for CNF, which eliminates the explicit ANDs
;;; and ORs.  This code is meant to be informative, not efficient.

;;;; Top-Level Functions

(defun prefix->cnf (p &optional vars)
  "Convert a sentence p to conjunctive normal form [p 279-280]."
  ;; That is, return (and (or ...) ...) where 
  ;; each of the conjuncts has all literal disjuncts.
  ;; VARS is a list of universally quantified variables that P is in scope of.
  (setf p (eliminate-implications p))
  (case (op p)
    (NOT (let ((p2 (move-not-inwards (arg1 p))))
	   (if (literal? p2) p2 (prefix->cnf p2 vars))))
    (AND (conjunction (mappend #'(lambda (q) (conjuncts (prefix->cnf q vars)))
				(args p))))
    (OR  (merge-disjuncts (mapcar #'(lambda (q) (prefix->cnf q vars))
				  (args p))))
    (FORALL (let ((new-vars (mapcar #'new-variable  (mklist (arg1 p)))))
	   (prefix->cnf (sublis (mapcar #'cons  (mklist (arg1 p)) new-vars)
			  (arg2 p))
		  (append new-vars vars))))
    (EXISTS (prefix->cnf (skolemize (arg2 p) (arg1 p) vars) vars))
    (t   p) ; p is atomic
    ))

(defun prefix->inf (p)
  "Convert a sentence p to implicative normal form [p 282]."
  (conjunction (mapcar #'cnf1->inf1 (conjuncts (prefix->cnf p)))))

(defun prefix->horn (p)
  "Try to convert sentence to a Horn clause, or a conjunction of Horn clauses.
  Signal an error if this cannot be done."
  (let ((q (prefix->inf p)))
    (when (not (every #'horn-clause? (conjuncts q)))
      (warn "~A, converted to ~A, is not a Horn clause." p q))
    q))

;;;; Auxiliary Functions

(defun cnf1->inf1 (p)
  ;; P is of the form (or (not a) (not b) ... c d ...)
  ;; Convert to: (=> (and a b ...) (or c d ...))
  ;; where a,b,c,d ... are positive atomic clauses
  (let ((lhs (mapcar #'arg1 (remove-if-not #'negated? (disjuncts p))))
	(rhs (remove-if #'negated? (disjuncts p))))
    `(=> ,(conjunction lhs) ,(disjunction rhs))))

(defun eliminate-implications (p)
  (if (literal? p)
      p
    (case (op p)
      (=>  `(or ,(arg2 p) (not ,(arg1 p))))
      (<=> `(and (or ,(arg1 p) (not ,(arg2 p)))
		 (or (not ,(arg1 p)) ,(arg2 p))))
      (t   (cons (op p) (mapcar #'eliminate-implications (args p)))))))

(defun move-not-inwards (p)
  "Given P, return ~P, but with the negation moved as far in as possible."
  (case (op p)
    (TRUE 'false)
    (FALSE 'true)
    (NOT (arg1 p))
    (AND (disjunction (mapcar #'move-not-inwards (args p))))
    (OR  (conjunction (mapcar #'move-not-inwards (args p))))
    (FORALL (make-exp 'EXISTS (arg1 p) (move-not-inwards (arg2 p))))
    (EXISTS (make-exp 'FORALL (arg1 p) (move-not-inwards (arg2 p))))
    (t (make-exp 'not p))))

(defun merge-disjuncts (disjuncts)
  "Return a CNF expression for the disjunction."
  ;; The argument is a list of disjuncts, each in CNF.
  ;; The second argument is a list of conjuncts built so far.
  (case (length disjuncts)
    (0 'false)
    (1 (first disjuncts))
    (t (conjunction
	(let ((result nil))
	  (loop for y in (conjuncts (merge-disjuncts (rest disjuncts))) do
	       (loop for x in (conjuncts (first disjuncts)) do
		    (push (disjunction (append (disjuncts x) (disjuncts y)))
			  result)))
	  (nreverse result))))))

(defun skolemize (p vars outside-vars)
  "Within the proposition P, replace each of VARS with a skolem constant,
  or if OUTSIDE-VARS is non-null, a skolem function of them."
  (sublis (mapcar #'(lambda (var)
		      (cons var (if (null outside-vars)
				    (skolem-constant var)
				  (cons (skolem-constant var) outside-vars))))
		  (mklist vars))
	  p))

(defun skolem-constant (name)
  "Return a unique skolem constant, a symbol starting with '$'."
  (intern (format nil "$~A_~D" name (incf *new-variable-counter*))))

(defun renaming? (p q &optional (bindings +no-bindings+))
  "Are p and q renamings of each other? (That is, expressions that differ
  only in variable names?)"
  (cond ((eq bindings +fail+) +fail+)
	((equal p q) bindings)
	((and (consp p) (consp q))
	 (renaming? (rest p) (rest q)
		    (renaming? (first p) (first q) bindings)))
	((not (and (variable? p) (variable? q)))
	 +fail+)
	;; P and Q are both variables from here on
	((and (not (get-binding p bindings)) (not (get-binding q bindings)))
	 (extend-bindings p q bindings))
	((or (eq (lookup p bindings) q) (eq p (lookup q bindings)))
	 bindings)
	(t +fail+)))

;;;; Operations on variables and binding lists

(defun variable? (x)
  "Is x a variable (a symbol starting with $)?"
  (and (symbolp x) (eql (char (symbol-name x) 0) #\$)))

(defun variables-in (exp)
  "Return a list of all the variables in EXP."
  (unique-find-anywhere-if #'variable? exp))

(defvar *new-variable-counter* 0)

(defun new-variable (var)
  "Create a new variable.  Assumes user never types variables of form $X.9"
  (concat-symbol (if (variable? var) "" "$")
                 var "." (incf *new-variable-counter*)))

(defconstant +fail+ nil "Indicates unification failure")

(defconstant +no-bindings+ '((nil))
  "Indicates unification success, with no variables.")

(defun get-binding (var bindings)
  "Find a (variable . value) pair in a binding list."
  (assoc var bindings))

(defun binding-var (binding)
  "Get the variable part of a single binding."
  (car binding))

(defun binding-val (binding)
  "Get the value part of a single binding."
  (cdr binding))

(defun make-binding (var val) (cons var val))

(defun lookup (var bindings)
  "Get the value part for var from a binding list."
  (binding-val (get-binding var bindings)))

(defun extend-bindings (var val bindings)
  "Add a (var . value) pair to a binding list."
  (cons (make-binding var val)
        ;; Once we add a "real" binding,
        ;; we can get rid of the dummy +no-bindings+
        (if (eq bindings +no-bindings+)
            nil
            bindings)))

(defun subst-bindings (bindings x)
  "Substitute the value of variables in bindings into x,
  taking recursively bound variables into account."
  (cond ((eq bindings +fail+) +fail+)
        ((eq bindings +no-bindings+) x)
        ((and (variable? x) (get-binding x bindings))
         (subst-bindings bindings (lookup x bindings)))
        ((atom x) x)
        (t (reuse-cons (subst-bindings bindings (car x))
                       (subst-bindings bindings (cdr x))
                       x))))

(defun rename-variables (x)
  "Replace all variables in x with new ones."
  (sublis (mapcar #'(lambda (var) (make-binding var (new-variable var)))
                  (variables-in x))
          x))



;;;; Utility Predicates and Accessors

(defconstant +logical-connectives+ '(and or not => <=>))
(defconstant +logical-quantifiers+ '(forall exists))

(defun logical-atom? (sentence)
  "A logical atom has no connectives or quantifiers."
  (not (or (member (op sentence) +logical-connectives+)
	   (member (op sentence) +logical-quantifiers+))))

(defun negated? (sentence)
  "A negated expression has NOT as the operator."
  (eq (op sentence) 'not))

(defun literal? (sentence)
  "A literal is an atomic clause or a negated atomic clause."
  (or (logical-atom? sentence)
      (and (negated? sentence) (logical-atom? (arg1 sentence)))))

(defun negative-literal? (l)
  (and (negated? l) (logical-atom? (arg1 l))))

(defun positive-literal? (l) (logical-atom? l))

(defun literal-atom (literal) (if (logical-atom? literal) literal (arg1 literal)))

(defun horn-clause? (sentence)
  "A Horn clause (in INF) is an implication with atoms on the left and one
  atom on the right."
  (and (eq (op sentence) '=>)
       (every #'logical-atom? (conjuncts (arg1 sentence)))
       (logical-atom? (arg2 sentence))))

(defun conjuncts (sentence)
  "Return a list of the conjuncts in this sentence."
  (cond ((eq (op sentence) 'and) (args sentence))
	((eq sentence 'true) nil)
	(t (list sentence))))

(defun disjuncts (sentence)
  "Return a list of the disjuncts in this sentence."
  (cond ((eq (op sentence) 'or) (args sentence))
	((eq sentence 'false) nil)
	(t (list sentence))))

(defun conjunction (args)
  "Form a conjunction with these args."
  (case (length args)
    (0 'true)
    (1 (first args))
    (t (cons 'and args))))

(defun disjunction (args)
  "Form a disjunction with these args."
  (case (length args)
    (0 'false)
    (1 (first args))
    (t (cons 'or args))))

(defun negation (arg)
  "Form a negation with this arg."
  (list 'not arg))

(defun biconditional (s1 s2)
  `(<=> ,s1 ,s2))


;;; Indexed cnf representation for efficient implementation of propositional algorithms

;;; An icnf instance represents its symbols by the integers 0,1,...,n-1
;;; and numbers its clauses by integers 0,1,...,m-1.
;;; All internal processing uses these integers; the symbol-to-integer mapping
;;; is retained for convenience.
;;; Each clause is represented by separate lists of symbols
;;; that appear positively and negatively; the lists are stored
;;; in arrays (cpos and cneg) indexed by clause number.
;;; The arrays vpos and vneg are indexed by symbol number and
;;; list the clauses in which the symbol appears positviely and negatively.

(defstruct icnf 
  n             ;;; the number of symbols
  m             ;;; the number of clauses
  k             ;;; array, indexed by clause, giving total # of literals
  cpos cneg     ;;; arrays, indexed by clause, giving lists of         
                ;;;    symbols appearing in the clause positively/negatively 
  vpos vneg     ;;; arrays, index by symbol, giving lists of 
                ;;;    clauses the symbol appears in positively/negatively
  mapping       ;;; association list of (symbol . integer) pairs
  )

;;; cnf->icnf converts a cnf expression (conjunction of disjunctions 
;;; of literals) into an indexed-cnf reprersentation.

(defun cnf->icnf (cnf)
  (let* ((symbols (pl-symbols-in cnf))
	 (n (length symbols))
	 (m (length (conjuncts cnf)))
	 (k (make-array (list m) :initial-element nil))
	 (cpos (make-array (list m) :initial-element nil))
	 (cneg (make-array (list m) :initial-element nil))
	 (vpos (make-array (list n) :initial-element nil))
	 (vneg (make-array (list n) :initial-element nil))
	 (mapping (mapcar #'cons symbols (iota n)))
	 (c 0))
    (loop for clause in (conjuncts cnf) do
      (setf (aref k c) (length (disjuncts clause)))
      (loop for literal in (disjuncts clause) do
        (let ((s (cdr (assoc (literal-atom literal) mapping))))
	  (push s (aref (if (atom literal) cpos cneg) c))
	  (push c (aref (if (atom literal) vpos vneg) s))))
      (incf c))
    (make-icnf :n n :m m :k k :cpos cpos :cneg cneg :vpos vpos :vneg vneg :mapping mapping)))


;;; Abstract syntax operations specifically for propositional logic

(defun pl-clause-equal? (c1 c2)
  "Returns t iff clauses c1 and c2 contain the same literals"
  (and (subsetp (conjuncts c1) (conjuncts c2) :test #'equal) 
       (subsetp (conjuncts c2) (conjuncts c1) :test #'equal)))

(defun complementary-literals? (l1 l2)
  "Returns t iff l1 and l2 are complementary, e.g., P and (NOT P)"
  (if (negative-literal? l1)
      (and (positive-literal? l2) (equal l2 (arg1 l1)))
    (and (negative-literal? l2) (equal l1 (arg1 l2)))))

(defun pl-tautological-clause? (clause)
  "Returns t iff clause contains complementary literals"
  (some #'(lambda (literal)
	    (member literal (disjuncts clause) :test #'complementary-literals?))
	(disjuncts clause)))

(defun pl-symbols-in (sentence)
  "Return a list of all the propositional symbols in sentence."
  (cond ((member sentence '(true false)) nil)
	((atom sentence) (list sentence))
	(t (delete-duplicates (mapcan #'pl-symbols-in (args sentence))
			      :from-end t))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Truth table algorithm for checking entailment
;;; KB entails alpha iff alpha is true in all models where KB is true
;;; The algorithm is a simple recursive enumeration of possible models,
;;; which are represented by alists.
;;; [[Could be made more efficient using early detection - revise pl-true?
;;; to allow checks with partial models.]]

(defun tt-entails? (kb alpha)
  "Truth table entailment algorithm: returns t iff kb entails alpha"
  (tt-check-all kb alpha (union (pl-symbols-in kb) (pl-symbols-in alpha)) nil))

(defun tt-check-all (kb alpha symbols model)
  (if (null symbols)
      (if (pl-true? kb model) (pl-true? alpha model) t)
    (let ((var (first symbols)) (restsymbols (rest symbols)))
      (and (tt-check-all kb alpha restsymbols (cons (cons var t) model))
	   (tt-check-all kb alpha restsymbols (cons (cons var nil) model))
	   ))))

;;; Deciding truth of a sentence in a model.
;;; Computed recursively, terminating in symbols whose truth is looked up.
;;; Model is represented by an alist, e.g., ((P . t) (Q . nil)).

(defun pl-true? (sentence model)
  "Returns t iff sentence is true in model.
  It is an error if there are any propositional symbols in the sentence
  that are not given a value in the model."
  (cond ((eq sentence 'true) t)
	((eq sentence 'false) nil)
	((atom sentence) (symbol-true? sentence model t))
	(t (case (op sentence)
	     (or  (some #'(lambda (s) (pl-true? s model)) (args sentence)))
	     (and (every #'(lambda (s) (pl-true? s model)) (args sentence)))
	     (not (not (pl-true? (arg1 sentence) model)))
	     (=>  (or (not (pl-true? (arg1 sentence) model))
		      (pl-true? (arg2 sentence) model)))
	     (<=> (eq (pl-true? (arg1 sentence) model)
		      (pl-true? (arg2 sentence) model)))
	     (otherwise (error "Unknown connective ~A in ~A"
			       (op sentence) sentence))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DPLL (Davis-Putnam-Logemann-Loveland) algorithm for
;;; deciding satisfiability.
;;; This implementation uses the indexed CNF (icnf) representation.
;;; This description from Stephen Cook and David Mitchell,
;;; Finding Hard Instances of the Satisfiability Problem: A Survey. 
;;; DIMACS Series in Discrete Math. and Theoretical Computer Science,35, 1997, pp1-17. 
;;; DPLL(f)
;;; if f is empty return true
;;; else if f contains () then return false
;;; else if some literal u appears with only one sign, fix and recurse
;;; else if there is a unit clause, fix and recurse
;;; else return DPLL(x_i=true) or DPLL(x_i=false)

;;; In order to speed up search, DPLL maintains auxiliary data structures
;;; during the search, stored as an "indexed model" (imod).

(defstruct imod 
  model         ;;; the current model, an array of 1/0 indexed by symbol
  vposcount     ;;; array, indexed by symbol, # of unsatisfied clauses in which appears +ve
  vnegcount     ;;; array, indexed by symbol, # of unsatisfied clauses in which appears -ve
  trues         ;;; array, indexed by clause, # of literals true in current model
  falses        ;;; array, indexed by clause, # of literals false in current model
  csatcount     ;;; count of clauses satisfied by current model
  falsified?    ;;; flag set to t when all of a clauses's literals are false
  )

(defun initial-imod (icnf)
  (make-imod
   :model (make-array (list (icnf-n icnf)) :initial-element nil)
   :vposcount (map 'vector #'length (icnf-vpos icnf))
   :vnegcount (map 'vector #'length (icnf-vneg icnf))
   :trues (make-array (list (icnf-m icnf)) :initial-element 0)
   :falses (make-array (list (icnf-m icnf)) :initial-element 0)
   :csatcount 0
   :falsified? nil))

(defun dpll-entails? (kb sentence)
  "Returns t iff sentence (in propositional logic) is entailed by kb"
  (not (dpll-satisfiable? (conjunction (list kb (negation sentence))))))

(defun dpll-satisfiable? (sentence)
  "Returns t iff sentence (in propositional logic) is satisfiable"
  (let* ((icnf (cnf->icnf (prefix->cnf sentence)))
	 (imod (initial-imod icnf)))
    (dpll icnf imod)))

(defun dpll (icnf imod &optional (symbols (iota (icnf-n icnf))) &aux symbol value result)
  "Returns t iff clauses are satisfied by some extension of model"
  (cond ((icnf-solved? icnf imod) t)
	((icnf-falsified? icnf imod) nil)
        ((or (multiple-value-setq (symbol value) (find-pure-symbol icnf imod))
	     (multiple-value-setq (symbol value) (find-unit-clause icnf imod)))
	 (assign-symbol symbol value icnf imod)
	 (setq result (dpll icnf imod (remove symbol symbols)))
	 (unassign-symbol symbol value icnf imod)
	 result)
	(t (setq symbol (first symbols))
	   (assign-symbol symbol 1 icnf imod)
	   (setq result (dpll icnf imod (rest symbols)))
	   (unassign-symbol symbol 1 icnf imod)
	   (when result (return-from dpll result))
	   (assign-symbol symbol 0 icnf imod)
	   (setq result (dpll icnf imod (rest symbols)))
	   (unassign-symbol symbol 0 icnf imod)
	   result)))


(defun icnf-solved? (icnf imod) (= (imod-csatcount imod) (icnf-m icnf)))

(defun icnf-falsified? (icnf imod) (declare (ignore icnf)) (imod-falsified? imod))

(defun find-pure-symbol (icnf imod &aux symbol (n (icnf-n icnf)) (model (imod-model imod)))
  (cond ((setq symbol (dotimes (s n nil) (when (and (null (aref model s)) (zerop (aref (imod-vposcount imod) s))) (return s)))) (values symbol 0))
	((setq symbol (dotimes (s n nil) (when (and (null (aref model s)) (zerop (aref (imod-vnegcount imod) s))) (return s)))) (values symbol 1))
	(t (values nil nil))))

(defun find-unit-clause (icnf imod &aux clause (m (icnf-m icnf)) (k (icnf-k icnf)))
  (cond ((setq clause (dotimes (c m nil) (when (and (zerop (aref (imod-trues imod) c))
						    (= (aref (imod-falses imod) c) (1- (aref k c))))
					   (return c))))
	 (unit-symbol-value icnf imod clause))
	(t (values nil nil))))

(defun unit-symbol-value (icnf imod clause &aux symbol (model (imod-model imod)))
  (cond ((setq symbol (find-if-not #'(lambda (s) (eql 0 (aref model s))) (aref (icnf-cpos icnf) clause)))
	 (values symbol 1))
	((setq symbol (find-if-not #'(lambda (s) (eql 1 (aref model s))) (aref (icnf-cneg icnf) clause)))
	 (values symbol 0))
	(t (error "Not a correct unit clause: ~A" clause))))
	


(defun assign-symbol (symbol value icnf imod &aux (k (icnf-k icnf)) count)
  (setf (aref (imod-model imod) symbol) value)
  ;;; deal with literals that are set to false
  (loop for c in (if (zerop value) (aref (icnf-vpos icnf) symbol) (aref (icnf-vneg icnf) symbol)) do
    (setq count (incf (aref (imod-falses imod) c)))
    (when (= count (aref k c)) (setf (imod-falsified? imod) c)))
  ;;; deal with literals that are set to true
  (loop for c in (if (zerop value) (aref (icnf-vneg icnf) symbol) (aref (icnf-vpos icnf) symbol)) do
    (setq count (incf (aref (imod-trues imod) c)))
    (when (= count 1) ;;; clause now satisfied
      (incf (imod-csatcount imod))
      (loop for s in (aref (icnf-cpos icnf) c) do (decf (aref (imod-vposcount imod) s)))
      (loop for s in (aref (icnf-cneg icnf) c) do (decf (aref (imod-vnegcount imod) s))))))


(defun unassign-symbol (symbol value icnf imod &aux (k (icnf-k icnf)) count)
  (setf (aref (imod-model imod) symbol) nil)
  ;;; deal with literals that were set to false, now unset
  (loop for c in (if (zerop value) (aref (icnf-vpos icnf) symbol) (aref (icnf-vneg icnf) symbol)) do
    (setq count (decf (aref (imod-falses imod) c)))
    (when (= count (1- (aref k c))) (setf (imod-falsified? imod) nil)))
  ;;; deal with literals that were set to true, now unset
  (loop for c in (if (zerop value) (aref (icnf-vneg icnf) symbol) (aref (icnf-vpos icnf) symbol)) do
    (setq count (decf (aref (imod-trues imod) c)))
    (when (= count 0) ;;; clause now unsatisfied
      (decf (imod-csatcount imod))
      (loop for s in (aref (icnf-cpos icnf) c) do (incf (aref (imod-vposcount imod) s)))
      (loop for s in (aref (icnf-cneg icnf) c) do (incf (aref (imod-vnegcount imod) s))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Greedy local search algorithms for satisfiability: 
;;; The WalkSAT algorithm (Selman, Kautz, and Cohen, 1994) is implemented here
;;; using an augmented data structure for CNF instances called indexed CNF (icnf).
;;; Core of the algorithm is
;;;   pick an unsatisfied clause u.a.r.
;;;      with probability p, choose a symbol u.a.r. in that clause, flip it
;;;      with probability 1-p, flip the symbol (ties broken randomly) that
;;;        gives the largest increase in the number of satisfied clauses

(defun walksat-entails? (kb sentence)
  "Returns t iff sentence (in propositional logic) is entailed by kb
   or the attempt to refute the negated sentence fails."
  (not (walksat-satisfiable? (conjunction (list kb (negation sentence))))))

(defun walksat-satisfiable? (sentence)
  "Returns t if a satisfying assignment is found for sentence,
   nil if unsatisfiable or if algorithm terminates with no satisfying assignment."
  (let* ((icnf (cnf->icnf (prefix->cnf sentence)))
	 (imod (initial-imod icnf)))
    (walksat icnf imod)))

(defun walksat (icnf imod &optional (p 0.5) (max-flips (* 5 (square (icnf-n icnf)))))
  (random-assign icnf imod)
  (dotimes (i max-flips nil)
    (when (icnf-solved? icnf imod) 
      (return-from walksat (imod-model imod)))
    (let* ((clause (random-index-if #'zerop (imod-trues imod)))
	   (symbols (append (aref (icnf-cpos icnf) clause) (aref (icnf-cneg icnf) clause))))
      (flip-symbol (if (< (random 1.0) p) (random-element symbols)
		     (greedy-choose-flip symbols icnf imod))
		   icnf imod))))

;;; flip-symbol flips the assignment of a given symbol.
;;; This could probably be done more efficiently.

(defun flip-symbol (symbol icnf imod &aux (value (aref (imod-model imod) symbol)) (new-value (- 1 value)))
  (unassign-symbol symbol value icnf imod)
  (assign-symbol symbol new-value icnf imod))


;;; greedy-choose-flip selects the symbol whose flip would
;;; give the highest number of satisfied clauses (ties broken randomly).

(defun greedy-choose-flip (symbols icnf imod)
  (the-biggest-random-tie #'(lambda (symbol) (net-improvement symbol icnf imod)) symbols))

(defun net-improvement (symbol icnf imod &aux (value (aref (imod-model imod) symbol)) 
                                              (count 0))
  (cond ((zerop value)
         (loop for c in (aref (icnf-vpos icnf) symbol) do
           (when (= (aref (imod-trues imod) c) 0) (incf count)))
         (loop for c in (aref (icnf-vneg icnf) symbol) do
           (when (= (aref (imod-trues imod) c) 1) (decf count))))
        (t
         (loop for c in (aref (icnf-vpos icnf) symbol) do
           (when (= (aref (imod-trues imod) c) 1) (decf count)))
         (loop for c in (aref (icnf-vneg icnf) symbol) do
           (when (= (aref (imod-trues imod) c) 0) (incf count)))))
  count)

;;; An initial assignment is created by randomly setting each bit.
;;; Returns the modified CNF problem, with clause counts initialized.

(defun random-assign (icnf imod)
  (dotimes (v (icnf-n icnf)) (assign-symbol v (random 2) icnf imod)))



;;; Abstract syntax for evaluating truth in models
;;; [[check which are actually ever used]]

(defun clause-true? (clause model)
  "Returns t iff clause is true in (partial) model."
  (some #'(lambda (l) (literal-true? l model)) clause))

(defun clause-false? (clause model)
  "Returns t iff clause is false in (partial) model"
  (every #'(lambda (l) (literal-false? l model)) clause))

(defun literal-true? (literal model)
  "Returns t iff literal is true in (partial) model"
  (if (atom literal) (symbol-true? literal model)
    (symbol-false? (arg1 literal) model)))

(defun literal-false? (literal model)
  "Returns t iff literal is false in (partial) model"
  (if (atom literal) (symbol-false? literal model)
    (symbol-true? (arg1 literal) model)))

(defun symbol-true? (symbol model &optional (check nil))
  "Returns t iff symbol has value t in (partial) model.
   I.e., returns nil if value is nil OR UNDEFINED.
   If check is t, signals an error if undefined."
  (let ((s.v (assoc symbol model)))
    (if (and check (null s.v)) (error "No truth value for ~A." symbol)
      (cdr s.v))))

(defun symbol-false? (symbol model &optional (check nil))
  "Returns t iff symbol has value nil in (partial) model.
   I.e., returns nil if value is t OR UNDEFINED."
  (let ((s.v (assoc symbol model)))
    (if (and check (null s.v)) (error "No truth value for ~A." symbol)
      (if s.v (not (cdr s.v)) nil))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Utility functions

(defun make-exp (op &rest args) (cons op args))
(defun op (exp) "Operator of an expression" (if (listp exp) (first exp) exp))
(defun args (exp) "Arguments of an expression" (if (listp exp) (rest exp) nil))
(defun arg1 (exp) "First argument" (first (args exp)))
(defun arg2 (exp) "Second argument" (second (args exp)))

(defsetf args (exp) (new-value)
  `(setf (cdr ,exp) ,new-value))

(defun iota (n &optional (start-at 0))
  "Return a list of n consecutive integers, by default starting at 0."
  (if (<= n 0) nil (cons start-at (iota (- n 1) (+ start-at 1)))))

(defun square (x) (* x x))

(defun the-biggest-random-tie (fn l)
  (random-element
   (let ((biggest (list (first l)))
	 (best-val (funcall fn (first l))))
     (dolist (x (rest l))
       (let ((val (funcall fn x)))
	 (cond ((> val best-val)
		(setq best-val val)
		(setq biggest (list x)))
	       ((= val best-val)
		(push x biggest)))))
     biggest)))

(defun random-element (sequence)
  "Return some element of the sequence, chosen at random."
  (elt sequence (random (length sequence))))

(defun random-index-if (pred sequence)
  "Return the index of a randomly chosen element that satisfies pred."
  (let ((n (count-if pred sequence)) (index 0))
    (block it 
     (map nil #'(lambda (x) 
		  (when (funcall pred x) 
		    (when (<= (random 1.0) (/ 1 n)) (return-from it index))
		    (decf n))
		  (incf index))
	  sequence))))

(defun mappend (fn &rest lists)
  "Apply fn to respective elements of list(s), and append results."
  (reduce #'append (apply #'mapcar fn lists) :from-end t))

(defun unique-find-anywhere-if (predicate tree &optional found-so-far)
  "Return a list of leaves of tree satisfying predicate,
  with duplicates removed."
  (if (atom tree)
      (if (funcall predicate tree)
          (pushnew tree found-so-far)
          found-so-far)
      (unique-find-anywhere-if
        predicate
        (first tree)
        (unique-find-anywhere-if predicate (rest tree)
                                 found-so-far))))

(defun reuse-cons (x y x-y)
  "Return (cons x y), or reuse x-y if it is equal to (cons x y)"
  (if (and (eql x (car x-y)) (eql y (cdr x-y)))
      x-y
      (cons x y)))

(defun concat-symbol (&rest args)
  "Concatenate the args into one string, and turn that into a symbol."
  (intern (format nil "~{~a~}" args)))

(defun mklist (x) (if (listp x) x (list x)))