;;;; combinations.scm -- combination library ;;; Created: <2003-01-15 12:06:11 foof> ;;; Time-stamp: <2003-01-20 00:43:20 foof> ;;; Author: Alex Shinn (define-module util.combinations (use srfi-1) (export-all) ) (select-module util.combinations) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; permuations and combinations (define (permutations set) (if (null? set) (list '()) (append-map (lambda (x) (map (cut cons x <>) (permutations (delete x set)))) set))) (define (permutations-for-each proc set) (if (null? set) (proc '()) (for-each (lambda (x) (permutations-for-each (lambda (sub-perm) (proc (cons x sub-perm))) (delete x set))) set))) (define (combinations set n) (if (zero? n) (list '()) (let ((n2 (- n 1))) (pair-fold-right (lambda (pr acc) (let ((first (car pr))) (append (map (cut cons first <>) (combinations (cdr pr) n2)) acc))) '() set)))) (define (combinations-for-each proc set n) (if (zero? n) (proc '()) (let ((n2 (- n 1))) (pair-for-each (lambda (pr) (let ((first (car pr))) (combinations-for-each (lambda (sub-comb) (proc (cons first sub-comb))) (cdr pr) n2))) set)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; power sets (all subsets of any size of a given set) ;; the easy binary way (define (power-set-binary set) (if (null? set) (list '()) (let ((x (car set)) (rest (power-set (cdr set)))) (append rest (map (cut cons x <>) rest))))) ;; use combinations for nice ordering (define (power-set set) (let ((size (length set))) (let loop ((i 0)) (if (> i size) '() (append (combinations set i) (loop (+ i 1))))))) ;; also ordered (define (power-set-for-each proc set) (let ((size (length set))) (let loop ((i 0)) (if (> i size) '() (begin (combinations-for-each proc set i) (loop (+ i 1))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; cartesian product (all combinations of one element from each set) (define (cartesian-product lol) (if (null? lol) (list '()) (let ((l (car lol)) (rest (cartesian-product (cdr lol)))) (append-map (lambda (x) (map (lambda (sub-prod) (cons x sub-prod)) rest)) l)))) (define (cartesian-product-for-each proc lol) (if (null? lol) (proc '()) (for-each (lambda (x) (cartesian-product-for-each (lambda (sub-prod) (proc (cons x sub-prod))) (cdr lol))) (car lol)))) ;; The above is left fixed (it varies elements to the right first). ;; Below is a right fixed product which could be defined with two ;; reverses but is short enough to warrant the performance gain of a ;; separate procedure. ;;(define (cartesian-product-right lol) ;; (map reverse (cartesian-product (reverse lol)))) (define (cartesian-product-right lol) (if (null? lol) (list '()) (let ((l (car lol)) (rest (cartesian-product (cdr lol)))) (append-map (lambda (sub-prod) (map (lambda (x) (cons x sub-prod)) l)) rest)))) (define (cartesian-product-right-for-each proc lol) (if (null? lol) (proc '()) (cartesian-product-right-for-each (lambda (sub-prod) (for-each (lambda (x) (proc (cons x sub-prod))) (car lol))) (cdr lol)))) (provide "util/combinations")