;;;; sequences-utils.sample.scm  -*- Scheme -*-
;;;; Kon Lovett, Oct '22

;;Issues
;;

(module (sequences utils sample)

(;export
  ;
  histogram
  ;
  random-integers random-reals
  ;
  random-sample cyclic-sample)

(import scheme
  (chicken base)
  (chicken type)
  (chicken fixnum)
  (chicken random)
  (only (srfi 1) list-copy reverse! append! take!)
  (prefix (chicken sort) chicken:)
  (prefix sequences seq:)
  (prefix (sequences utils misc) seq:)
  (prefix (sequences utils sort) seq:))

;;;

(include-relative "sequences-utils-types")

(: histogram (seq #!optional binary-equality -> alist))

(: random-integers (seq #!optional fixnum integer integer boolean -> seq))
(: random-reals (seq #!optional fixnum boolean -> seq))

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

;;

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

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

(define (random-reals* cnt)
  (let loop ((cnt cnt) (ls '()))
    (if (fx= 0 cnt) ls
        (loop (fx- cnt 1) (cons (pseudo-random-real) ls)) ) ) )

;;

(define (histogram seq #!optional (eqal? equal=?))
  (seq:foldl->alist seq (lambda (occurs _) (add1 occurs)) 0 eqal?) )

(define (random-integers seq #!optional (cnt 30) (end most-positive-fixnum) (low 0) (dups? #f))
 ;
  (define (randoms)
    (let ((lim (- end low)))
      (if dups? (random-integers* cnt lim low)
          (let loop ((os '()))
            (let* ((rs (random-integers* cnt lim low))
                   (os (append! rs os))
                   (os (seq:unique (seq:sort! os <) =))
                   (len (length os)) )
              (cond ((fx= len cnt) os)
                    ((fx> len cnt) (take! os cnt))
                    (else (loop os)) ) ) ) ) ) )
  ;
  (assert (fixnum? cnt)) (assert (fx<= 0 cnt))
  (assert (integer? end)) (assert (not (negative? end)))
  (assert (integer? low)) (assert (not (negative? low)))
  (assert (< low end))
  (seq:coerce seq (randoms)) )

(define (random-reals seq #!optional (cnt 30) (dups? #f))
  ;
  (define (randoms)
    (if dups? (random-reals* cnt)
        (let loop ((os '()))
          (let* ((rs (random-reals* cnt))
                 (os (append! rs os))
                 (os (seq:unique (seq:sort! os <) =))
                 (len (length os)) )
            (cond ((fx= len cnt) os)
                  ((fx> len cnt) (take! os cnt))
                  (else (loop os)) ) ) ) ) )
  ;
  (assert (fixnum? cnt)) (assert (fx<= 0 cnt))
  (seq:coerce seq (randoms)) )

(define (random-sample seq . rest)
  (assert (seq:sequence? seq))
  (let* ((siz (seq:size seq))
         (cnt (optional rest (pseudo-random-integer siz))) )
    ;
    (define (make-sampler)
      (*make-random-bernoullis (exact->inexact (/ cnt siz)) pseudo-random-real) )
    ;
    (define (random-sample)
      (if (or (fx= 0 siz) (fx= 0 cnt)) '()
          (let ((sample? (make-sampler)))
            (let loop ((iter (seq:iterator seq)) (siz siz) (cnt cnt) (os '()))
              (cond ((or (fx= 0 cnt) (seq:at-end? iter))
                      os)
                    ;issue w/ small input (large sample?)
                    ((fx= siz cnt)
                      (loop '() 0 0 (append! (seq:->list (seq:sub seq (seq:index iter))) os)))
                    ((sample?)
                      ;get elm before advance
                      (let ((cur (seq:elt seq iter)))
                        (loop (seq:advance! iter) (fx- siz 1) (fx- cnt 1) (cons cur os))))
                    (else
                      (loop (seq:advance! iter) (fx- siz 1) cnt os)) ) ) ) ) )
    ;
    ;(assert (fixnum? siz))
    (assert (fixnum? cnt)) (assert (fx<= 0 cnt))
    (assert (<= cnt siz))
    (seq:coerce seq (reverse! (random-sample))) ) )

(define (cyclic-sample seq . rest)
  (assert (seq:sequence? seq))
  (let* ((siz (seq:size seq))
         (cnt (optional rest (pseudo-random-integer siz))) )
    ;
    (define (cyclic-sample)
      (if (or (null? seq) (fx= 0 cnt)) '()
          ;i mod cnt = 0 then sample
          (let loop ((iter (seq:iterator seq)) (icnt 0) (os '()))
            (cond ((seq:at-end? iter)
                    os)
                  ((fx= icnt 0)
                    ;get elm before advance
                    (let ((cur (seq:elt seq iter)))
                      (loop (seq:advance! iter) (fx- cnt 1) (cons cur os))))
                  (else
                    (loop (seq:advance! iter) (fx- icnt 1) os)) ) ) ) )
    ;
    ;(assert (fixnum? siz))
    (assert (fixnum? cnt)) (assert (fx<= 0 cnt))
    (assert (<= cnt siz))
    (seq:coerce seq (reverse! (cyclic-sample))) ) )

) ;module (sequences utils sample)