;;;; list-utils.sample.scm  -*- scheme -*-
;;;; Kon Lovett, Jul '07

(module (list-utils sample)

(;export
  list-randoms
  list-random-sample
  list-cyclic-sample)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (chicken fixnum))
(import (only (chicken sort) sort!))
(import (only (chicken random) pseudo-random-integer pseudo-random-real))
(import (only (srfi 1) reverse! append! take! list-copy))
(import (only type-checks-basic define-check+error-type))
(import (check-errors sys))
(import (only (list-utils operations) list-unique))

(: list-randoms (fixnum #!optional integer integer boolean --> (list-of integer)))

(: list-random-sample (list #!optional fixnum --> list))
(: list-cyclic-sample (list #!optional fixnum --> list))

(: *list-randoms/duplicates (fixnum fixnum fixnum --> (list-of integer)))
(: *list-randoms (fixnum fixnum fixnum boolean --> (list-of integer)))

;;

;srfi-27
(define (*make-random-bernoullis p randoms)
  (cond ((= 0 p) (lambda () #f))
        ((= 1 p) (lambda () #t))
        (else (lambda () (<= (randoms) p)))) )

;;

(define (not-negative? obj) (not (negative? obj)))

(define-check+error-type not-negative)

(define-inline (check-bounds loc a b)
  (unless (< a b) (error loc "bounds swapped" a b))
  a )

(define-inline (check-non-negative-fixnum loc obj)
  (check-fixnum-in-range loc (check-fixnum loc obj) 0 most-positive-fixnum) )

;;

(define-constant DEFAULT-CYCLE-SIZE 7)

(define (*list-randoms/duplicates cnt lim low)
  (let loop ((cnt cnt) (ls '()))
    (if (fx= 0 cnt) ls
        (loop (fx- cnt 1) (cons (+ (pseudo-random-integer lim) low) ls)) ) ) )

;nondeterministic convergence
(define (*list-randoms cnt end low dups?)
  (let ((lim (- end low)))
    (if dups? (*list-randoms/duplicates cnt lim low)
        (let loop ((os '()))
          (let* ((rs (*list-randoms/duplicates cnt lim low))
                 (os (append! rs os))
                 (os (list-unique (sort! os <) =))
                 (len (length os)) )
            (cond ((fx= len cnt) os)
                  ((fx> len cnt) (take! os cnt))
                  (else (loop os)) ) ) ) ) ) )

;;

(define (list-randoms cnt #!optional (end most-positive-fixnum) (low 0) (dups? #f))
  (check-non-negative-fixnum 'list-randoms cnt)
  (check-bounds 'list-randoms (check-not-negative 'list-randoms (check-exact-integer 'list-randoms low))
                              (check-not-negative 'list-randoms (check-exact-integer 'list-randoms end)))
  (*list-randoms cnt end low dups?) )

(define (list-random-sample ls . rest)
  (let* ((len (length (check-list 'list-sample ls)))
         (cnt (optional rest (pseudo-random-integer len))) )
    (define (make-sampler)
      (*make-random-bernoullis (exact->inexact (/ cnt len)) pseudo-random-real) )
    ;(assert (fixnum? len))
    (check-fixnum-in-range 'list-sample (check-fixnum 'list-sample cnt) 0 len)
    (if (or (null? ls) (fx= 0 cnt)) '()
        (let ((sample? (make-sampler)))
          (let loop ((ls ls) (len len) (cnt cnt) (os '()))
            (cond ((or (fx= 0 cnt) (null? ls))
                    (reverse! os))
                  ;issue w/ small input (large sample?)
                  ((fx= len cnt)
                    (append (reverse! os) (list-copy ls)))
                  ((sample?)
                    (loop (cdr ls) (fx- len 1) (fx- cnt 1) (cons (car ls) os)))
                  (else
                    (loop (cdr ls) (fx- len 1) cnt os)) ) ) ) ) ) )

(define (list-cyclic-sample ls . rest)
  (let ((len (length (check-list 'list-cyclic-sample ls)))
        (cnt (optional rest DEFAULT-CYCLE-SIZE)) )
    ;(assert (fixnum? len))
    (check-fixnum-in-range 'list-cyclic-sample (check-fixnum 'list-cyclic-sample cnt) 0 len)
    (if (or (null? ls) (fx= 0 cnt)) '()
        ;i mod cnt = 0 then sample
        (let loop ((ls ls) (icnt 0) (os '()))
          (cond ((null? ls)
                  (reverse! os))
                ((fx= icnt 0)
                  (loop (cdr ls) (fx- cnt 1) (cons (car ls) os)))
                (else
                  (loop (cdr ls) (fx- icnt 1) os)) ) ) ) ) )

) ;module (list-utils sample)