[ create a new paste ] login | about

Link: http://codepad.org/WanFTb6R    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Sep 5:
; cartesian product

(define-syntax fold-of
  (syntax-rules (range in is)
    ((_ "z" f b e) (set! b (f b e)))
    ((_ "z" f b e (v range fst pst stp) c ...)
      (let* ((x fst) (p pst) (s stp)
             (le? (if (positive? s) <= >=)))
        (do ((v x (+ v s))) ((le? p v) b)
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (v range fst pst) c ...)
      (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
        (fold-of "z" f b e (v range x p s) c ...)))
    ((_ "z" f b e (v range pst) c ...)
      (fold-of "z" f b e (v range 0 pst) c ...))
    ((_ "z" f b e (x in xs) c ...)
      (do ((t xs (cdr t))) ((null? t) b)
        (let ((x (car t)))
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (x is y) c ...)
      (let ((x y)) (fold-of "z" f b e c ...)))
    ((_ "z" f b e p? c ...)
      (if p? (fold-of "z" f b e c ...)))
    ((_ f i e c ...)
      (let ((b i)) (fold-of "z" f b e c ...)))))

(define-syntax list-of (syntax-rules ()
  ((_ arg ...) (reverse (fold-of
    (lambda (d a) (cons a d)) '() arg ...)))))

(define (fold-right op base xs)
  (if (null? xs)
      base
      (op (car xs) (fold-right op base (cdr xs)))))

(define (cprod . xss)
  (if (null? xss) (list (list))
    (list-of (cons x ys)
      (x in (car xss))
      (ys in (apply cprod (cdr xss))))))

(display (cprod '(1 2 3) '(4) '(5 6))) (newline)

(define (cprod . xss)
  (if (null? xss) (list (list))
    (let loop1 ((xs (car xss)) (zs (list)))
      (if (null? xs) (reverse zs)
        (let loop2 ((yss (apply cprod (cdr xss))) (zs zs))
          (if (null? yss) (loop1 (cdr xs) zs)
            (loop2 (cdr yss) (cons (cons (car xs) (car yss)) zs))))))))

(display (cprod '(1 2 3) '(4) '(5 6))) (newline)

(define (mixed-radix n bases)
  (let loop ((n n) (bases bases) (xs (list)))
    (cond ((zero? n)
            (let loop ((k (length bases)) (xs xs))
              (if (zero? k) xs (loop (- k 1) (cons 0 xs)))))
          ((null? bases) (list))
            (else (loop (quotient n (car bases)) (cdr bases)
                        (cons (remainder n (car bases)) xs))))))

(define (cprod . xss)
  (let ((bases (reverse (map length xss))))
    (let loop ((n 0) (zss (list)))
      (let ((odometer (mixed-radix n bases)))
        (if (null? odometer) (reverse zss)
          (let ((zs (map list-ref xss odometer)))
            (loop (+ n 1) (cons zs zss))))))))

(display (cprod '(1 2 3) '(4) '(5 6))) (newline)

(define (cross . xss)
  (define (f xs yss)
    (define (g x zss)
      (define (h ys uss)
        (cons (cons x ys) uss))
      (fold-right h zss yss))
    (fold-right g '() xs))
  (fold-right f (list '()) xss))

(display (cross '(1 2 3) '(4) '(5 6))) (newline)


Output:
1
2
3
4
((1 4 5) (1 4 6) (2 4 5) (2 4 6) (3 4 5) (3 4 6))
((1 4 5) (1 4 6) (2 4 5) (2 4 6) (3 4 5) (3 4 6))
((1 4 5) (1 4 6) (2 4 5) (2 4 6) (3 4 5) (3 4 6))
((1 4 5) (1 4 6) (2 4 5) (2 4 6) (3 4 5) (3 4 6))


Create a new paste based on this one


Comments: