Random combinations in Church (Buckles-Lybanon '77)

gistfile1.scm

(define (pn x) (for-each display (list x "\n")))

(define (! n)
  (let iter ((product 1)
             (counter 1))       
    (if (> counter n)
        product
        (iter (* counter product)
              (+ counter 1)))))

(define (binom n k)
  (/ (! n) (* (! k) (! (- n k)))))

(define (choose lst k)
  (let* ((n (length lst))
         (L (+ 1 (sample-integer (binom n k))))) ;; lexicographic index
    (map (lambda (i) (list-ref lst (- i 1))) (get-combination n k L))))

;; get the p-combination of n items with lexicographic index L
;; Buckles & Lybanon 1977 (http://dl.acm.org/citation.cfm?id=355739)

;; i have basically no idea how this works

(define (get-combination n p L)
  (letrec
      ((get-lower-bound (lambda (i c_i k)
                            (let* ((c_i* (+ c_i 1))
                                   (r (binom (- n c_i*) (- p i)))
                                   (k* (+ k r)))
                              (if (>= k* L)
                                  (list c_i* k) ;; k because it's k + r - r
                                  (get-lower-bound i c_i* k*))))))
    (let loop ((i 1)
               (k 0) ;; lower bound
               (c '()))
      (if (= i p)
          (append c (list (+ (last c) L (- 0 k))))
          (let* ((c_i (if (> i 1) (last c) 0))
                 (result (get-lower-bound i c_i k))
                 (new-element (first result))
                 (new-k (second result)))
            (loop (+ i 1) new-k (append c (list new-element))))))))

(define (x) (choose '(a b c) 2))

(enumeration-query
 (define subset (x))
 subset
 )

the initial gist contained an error. as written, in choose, the lexicographic index L ranges from 0 to binom(n, k) - 1. but it should range from 1 to binom(n, k) - 1. this was fixed in the second version (the third version just cleans up parens highlighting for github gists)