Cartesian Products of Sets pasted by DeeEff on Tue Mar 14 22:19:47 2017

(use srfi-113 srfi-128)

(define (set-union-map proc lst)
  (apply set-union (set->list (set-map (make-eq-comparator) proc lst))))

(define (set-product comparator z xs)
  (set-map comparator
           (lambda (x)
             (if (pair? x)
               (cons z x)
               (list z x)))
           xs))

(define (set-cart-2 comparator set1 set2)
  (let ((list-comparator
         (make-list-comparator comparator list? null? car cdr)))
   (set-union-map (cute set-product list-comparator <> set2) set1)))

(define (set-cartesian-product comparator #!rest sets)
  (let ((sets (reverse sets)))
    (fold (cute set-cart-2 comparator <> <>)
          (car sets)
          (cdr sets))))

(define (set-cartesian-power set n)
  (apply set-cartesian-product
         (set-element-comparator set)
         (repeat set n)))

Fix set-union-map for perf added by DeeEff on Tue Mar 14 22:32:31 2017

;; Set Cartesian Product
(use srfi-113 srfi-128)

(define (set-union-map comparator proc lst)
  (set-fold set-union
            (set comparator)
            (set-map (make-eq-comparator) proc lst)))

(define (set-product comparator z xs)
  (set-map comparator
           (lambda (x)
             (if (pair? x)
               (cons z x)
               (list z x)))
           xs))

(define (set-cart-2 comparator set1 set2)
  (let ((list-comparator
         (make-list-comparator comparator list? null? car cdr)))
   (set-union-map list-comparator (cute set-product list-comparator <> set2) set1)))

(define (set-cartesian-product comparator #!rest sets)
  (let ((sets (reverse sets)))
    (fold (cute set-cart-2 comparator <> <>)
          (car sets)
          (cdr sets))))

(define (set-cartesian-power set n)
  (apply set-cartesian-product
         (set-element-comparator set)
         (repeat set n)))