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