Programming challenge: wildcard exclusion in cartesian products

[funkyj]

here is my version of the same.

REPL output:

CL-USER> (tests)


set      = (1 2)
n        = 3
patterns = ((1 ANY 2))
-----------------------
(1 1 1)
(1 2 1)
(2 1 1)
(2 1 2)
(2 2 1)
(2 2 2)


set      = (A B)
n        = 3
patterns = ((A ANY B) (B ANY A))
-----------------------
(A A A)
(A B A)
(B A B)
(B B B)


set      = (1 2)
n        = 3
patterns = ((1 ANY 2) (2 ANY 1))
-----------------------
(1 1 1)
(1 2 1)
(2 1 2)
(2 2 2)
NIL
CL-USER>

source:

;;;; cartesian products minus wildcard patterns per:
;;;;
;;;; >Newsgroups: comp.lang.lisp, etc...
;;;; >Subject: Programming challenge: wildcard exclusion in cartesian
products
;;;; >Date: 16 Mar 2006 03:14:23 -0800
;;;;
;;;;

(defun show-me (x) (format t "~A~%" x))

(defun set^n (fn set n &optional acc)
  "call `fn' on each permutation of `set' raised to the `n' power"
  (if (<= n 0)
      (funcall fn (reverse acc))
      (dolist (e set)
        (set^n fn set (- n 1) (cons e acc)))))

;; test set^n by printing and visually inspecting the result
(defun pr-set^n (set n)   (set^n #'show-me set n))

;; curry `set^n' so that `fn' is the only parameter
(defun set^n-gen (set n)
  (lambda (fn) (set^n fn set n)))

(defun mk-matchl-p (pat-list)
  "return a function that tests a value against the patterns in
`pat-list'"
  (labels ((matchp (pat val)
             (cond ((null pat) t)
                   ((or (eq (car pat) (car val))
                        (eq (car pat) :any))
                    (matchp (cdr pat) (cdr val))))))
    (lambda (val)
      "predicate: return true if val matches any pattern in `pat-list'"
      (dolist (p pat-list)
        (if (matchp p val)
            (return t))))))

(defun not-fp (f-pred)
  "return the complement of predicate `f-pred'"
  (lambda (x) (not (funcall f-pred x))))

;; f-gen is a generator of the form returned by set^n-gen
(defun accumulate-if (f-gen f-pred)
  "accumulate values generated by f-gen that satisfy f-pred"
  (let (acc)
    (funcall f-gen (lambda (x) (if (funcall f-pred x) (push x acc))))
    (nreverse acc)))

;; `pr-set^n-withoutWC' is the lisp equivalent (more or less) of
;; python code:
;;   >>> for i in cp.CPWithoutWC(x,y,z): print i
(defun pr-set^n-withoutWC (set n pat-list)
  (format t "~%~%set      = ~A~%n        = ~A~%patterns = ~A~%~A~%"
          set n pat-list "-----------------------")
  (dolist (e (accumulate-if (set^n-gen set n)
                            (not-fp (mk-matchl-p pat-list))))
    (format t "~A~%" e)))

(defun tests ()
  "generate test output per the original problem examples"
  (pr-set^n-withoutWC '(1 2) 3 '((1 :any 2)))
  (pr-set^n-withoutWC '(a b) 3 '((a :any b) (b :any a)))
  (pr-set^n-withoutWC '(1 2) 3 '((1 :any 2) (2 :any 1))))