; $Header: /usr/local/cvsrep/weitz.de/files/einstein.lisp,v 1.2 2001/12/06 08:54:32 edi Exp $    

(eval-when (:compile-toplevel :execute :load-toplevel)
  (proclaim '(optimize (speed 3)
                       (safety 0)
                       (space 0)
                       (debug 0)
                       (compilation-speed 0))))

(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 property-descriptor-list 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"))))
    (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)))