; $Header: /usr/local/cvsrep/weitz.de/files/riddle.lisp,v 1.2 2001/12/06 08:53:21 edi Exp $    

(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)
       (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)))))))

(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)))
           ,@(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))
             (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))))))))