; $Header: /usr/local/cvsrep/weitz.de/files/einstein-minimize.lisp,v 1.4 2001/12/08 00:57:06 edi Exp $ (eval-when (:compile-toplevel :execute :load-toplevel) (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0) (compilation-speed 0)))) (eval-when (:compile-toplevel :execute :load-toplevel) (defun min-arg (fn list) (loop with min-key and min = most-positive-fixnum for key in list if (< (funcall fn key) min) do (setq min (funcall fn key) min-key key) finally (return min-key)))) (eval-when (:compile-toplevel :execute :load-toplevel) (defun permute (list) (if (null list) (list nil) (mapcan #'(lambda (first) (mapcar #'(lambda (rest) (cons first rest)) (permute (remove first list :count 1 :test #'eq)))) list)))) (defmacro riddle-condition (name property1 value1 property2 value2 &key negate (distance 0) directed) `(progn (defun ,name (selection) (declare (type simple-vector selection)) (let ((position1 ,(if (eq property1 :position) value1 `(position-if #'(lambda (unit) (eq (,property1 unit) ,value1)) selection))) (position2 ,(if (eq property2 :position) value2 `(position-if #'(lambda (unit) (eq (,property2 unit) ,value2)) selection)))) (if (or (null position1) (null position2)) t ,(let* ((distance-to-check (if directed '(- position2 position1) '(abs (- position2 position1)))) (distance-check `(= ,distance ,distance-to-check))) (if negate `(not ,distance-check) distance-check))))) (eval-when (:compile-toplevel :execute :load-toplevel) (proclaim '(inline ,name))))) (defmacro prepare (unit-name orig-property-descriptor-list orig-condition-list) (labels ((name (property-descriptor) (first property-descriptor)) (args (property-descriptor) (second property-descriptor)) (plural (name choices &key plural-name) (declare (ignore choices)) (if plural-name plural-name (intern (concatenate 'string (symbol-name name) "S")))) (permutation-name (name) (intern (concatenate 'string (symbol-name name) "-PERMUTATIONS"))) (minimize (property-descriptor-list condition-list) (let ((len (length property-descriptor-list))) (labels ((weight (condition properties) (apply #'+ (mapcar #'(lambda (property) (expt len (or (position property properties :key #'first) 0))) (list (second condition) (fourth condition)))))) (let ((new-property-list (min-arg #'(lambda (property-permutation) (apply #'+ (mapcar #'(lambda (condition) (weight condition property-permutation)) condition-list))) (permute property-descriptor-list)))) (values new-property-list (sort condition-list #'< :key #'(lambda (condition) (weight condition new-property-list))))))))) (multiple-value-bind (property-descriptor-list condition-list) (minimize orig-property-descriptor-list orig-condition-list) (let* ((make-unit-name (intern (concatenate 'string "MAKE-" (symbol-name unit-name)))) (problem-size (length property-descriptor-list)) (accessor-list (mapcar #'name property-descriptor-list)) (plural-list (mapcar #'(lambda (property-descriptor) (apply #'plural property-descriptor)) property-descriptor-list)) (permutation-list (mapcar #'(lambda (property-descriptor) (list (permutation-name (name property-descriptor)) `(mapcar #'(lambda (permutation) (make-array ,problem-size :initial-contents permutation)) (permute ,(args property-descriptor))))) property-descriptor-list)) (condition-name-list (mapcar #'car condition-list))) (labels ((build-backtracking (property-descriptor-list &optional (accum-list nil)) (if (null property-descriptor-list) '(pprint result) (let* ((property-descriptor (first property-descriptor-list)) (plural-name (apply #'plural property-descriptor)) (new-accum-list (append accum-list (list plural-name)))) `(dolist (,plural-name ,(permutation-name (name property-descriptor))) (let ((result (possible-p ,@new-accum-list))) (when result ,(build-backtracking (cdr property-descriptor-list) new-accum-list)))))))) `(progn (defparameter *not-yet-defined* (make-array ,problem-size :initial-element nil)) (defstruct (,unit-name (:conc-name nil) (:type vector)) ,@accessor-list) (defparameter *selection* (make-array ,problem-size)) (dotimes (n ,problem-size) (setf (svref *selection* n) (,make-unit-name))) (eval-when (:compile-toplevel :execute :load-toplevel) (proclaim '(inline ,@accessor-list))) ,@(mapcar #'(lambda (condition) `(riddle-condition ,@condition)) condition-list) (defun possible-p (&optional ,@(mapcar #'(lambda (property-descriptor) `(,(apply #'plural property-descriptor) *not-yet-defined*)) property-descriptor-list)) (declare (type simple-vector ,@plural-list)) (dotimes (m ,problem-size) ,@(mapcar #'(lambda (accessor plural-name) `(setf (,accessor (svref *selection* m)) (svref ,plural-name m))) accessor-list plural-list)) (when (and ,@(mapcar #'(lambda (condition) `(,condition *selection*)) condition-name-list)) *selection*)) (defun solve () (let ,permutation-list ,(build-backtracking property-descriptor-list) (values))))))))) (prepare einstein ((nation '(british swedish norwegian german danish)) (house '(red green yellow blue white)) (animal '(dog horse cat bird fish)) (cigarette '(marlboro winfield rothmans pallmall dunhill)) (drink '(tea coffee milk beer water))) ((cond-position-first-norwegian :position 0 nation 'norwegian) (cond-left-green-white house 'green house 'white :distance 1 :directed t) (cond-british-red nation 'british house 'red) (cond-neighbor-norwegian-blue nation 'norwegian house 'blue :distance 1) (cond-swedish-dog nation 'swedish animal 'dog) (cond-german-rothmans nation 'german cigarette 'rothmans) (cond-yellow-dunhill house 'yellow cigarette 'dunhill) (cond-green-coffee house 'green drink 'coffee) (cond-danish-tea nation 'danish drink 'tea) (cond-bird-pallmall animal 'bird cigarette 'pallmall) (cond-neighbor-cat-marlboro animal 'cat cigarette 'marlboro :distance 1) (cond-neighbor-horse-dunhill animal 'horse cigarette 'dunhill :distance 1) (cond-winfield-beer cigarette 'winfield drink 'beer) (cond-neighbor-marlboro-water cigarette 'marlboro drink 'water :distance 1) (cond-position-middle-milk :position 2 drink 'milk)))