(require (lib "defmacro.ss"))
(require (lib "list.ss"))

(define call/cc call-with-current-continuation)
(define href hash-table-get)
(define hput hash-table-put!)

(define (hinc h x increment)
  (let ((count (href h x (lambda () (hput h x 0) 0))))
    (hput h x (+ count increment))))

(define (h-to-assoc h)
  (hash-table-map h cons))

(define __cont-other '())

(define (__probabilities to-evaluate)
  (let ((results (make-hash-table 'equal)))
    (fluid-let ((__cont-other '()))
      (call/cc
       (lambda (ret) ; catch the continuation of probabilities
         (set! __cont-other `((,(lambda () (ret (h-to-assoc results))) . 1)))
         (hinc results (to-evaluate) (foldl * 1 (map cdr __cont-other)))
         ((caar __cont-other)))))))

(define-macro (probabilities . body)
  `(__probabilities (lambda () . ,body)))

(define (choose choices)
  (let ((rest-choices choices))
    (call/cc (lambda (c) (set! __cont-other `((,c . 1) . ,__cont-other))))
    (if (null? rest-choices)
        (begin
          (set! __cont-other (cdr __cont-other))
          ((caar __cont-other)))
        (let ((next-val (caar rest-choices))
              (next-prob (cdar rest-choices)))
          (set! rest-choices (cdr rest-choices))
          (set-cdr! (car __cont-other) next-prob)
          next-val))))

(define (choose-equal choices)
  (let ((probability (/ 1 (length choices))))
    (choose (map (lambda (x) `(,x . ,probability)) choices))))