Programming challenge: wildcard exclusion in cartesian products

[Wade Humeniuk]

Oops, problems cutting an pasting, should be,

;; Wade Humeniuk

(defclass odometer ()
   ((base :initform 0 :accessor base)
    (meter :initform nil :accessor meter)
    (n-digits :initarg :n-digits :accessor n-digits)
    (digit-set :initarg :digit-set :accessor digit-set)))

(defmethod initialize-instance :after ((obj odometer) &rest initargs)
   (setf (base obj) (length (digit-set obj))
         (meter obj) (make-array (n-digits obj) :initial-element 0)
         (digit-set obj) (coerce (digit-set obj) 'vector)))

(defun inc-odometer (odometer)
   (loop with carry = 1
         for i from (1- (n-digits odometer)) downto 0
         for digit = (incf (aref (meter odometer) i) carry)
         if (= digit (base odometer)) do
           (setf (aref (meter odometer) i) 0)
           (setf carry 1)
         else do
           (setf carry 0)
         while (not (zerop carry))))

(defun zero-meter-p (odometer)
   (every #'zerop (meter odometer)))

(defmethod next-set ((obj odometer))
   (prog1 (map 'list (lambda (digit)
                       (aref (digit-set obj) digit))
               (meter obj))
     (inc-odometer obj)))

(defclass cs-with-wc (odometer)
   ((exclusion :initarg :exclusion :accessor exclusion)
    (at-end :initform nil :accessor at-end)))

(defmethod next-set ((obj cs-with-wc))
   (tagbody
    :next
    (unless (at-end obj)
      (let ((set (call-next-method)))
        (when (zero-meter-p obj) (setf (at-end obj) t))
        (if (not (funcall (exclusion obj) set))
            (return-from next-set set)
          (go :next))))))

(defun print-all-cs (set length exclusion)
   (let ((cs-with-wc (make-instance 'cs-with-wc :n-digits length :digit-set set
                                    :exclusion exclusion)))
     (loop for set = (next-set cs-with-wc)
           while set do (print set))))

CL-USER 7 > (print-all-cs '(a b) 3 (lambda (set)
                                      (destructuring-bind (x y z)
                                          set
                                        (or (and (eql x 'a) (eql z 'b))
                                            (and (eql x 'b) (eql z 'a))))))

(A A A)
(A B A)
(B A B)
(B B B)
NIL

CL-USER 8 > (print-all-cs '(abc xyz) 3 (lambda (set)
                                          (and (eql (first set) 'abc)
                                               (eql (third set) 'xyz))))

(ABC ABC ABC)
(ABC XYZ ABC)
(XYZ ABC ABC)
(XYZ ABC XYZ)
(XYZ XYZ ABC)
(XYZ XYZ XYZ)
NIL

CL-USER 9 >