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

;;Issues
;;

(module (sequences utils)

(;export
  ;
  foldl->alist
  ;
  ->list ->vector ->string
  ;
  merge merge!
  sorted?
  sort sort!
  unique
  ;
  histogram
  ;
  randoms
  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:))

;;;

(include "sequences-utils-types")

(: foldl->alist (seq (* 'a -> 'a) 'a #!optional binary-equality --> (list-of (pair * 'a))))

(: ->list (seq --> list))
(: ->vector (seq --> vector))
(: ->string (seq --> string))

(: merge! (seq seq binary-predicate -> seq))
(: merge (seq seq binary-predicate --> seq))

(: sorted? (seq binary-predicate --> boolean))

(: sort! (seq binary-predicate -> seq))
(: sort (seq binary-predicate --> seq))

(: unique (seq #!optional binary-equality --> seq))

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

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

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

;;

;miscellaneous

(define (foldl->alist seq next seed #!optional (eqal? equal=?))
  (define (kons bins value)
    (let ((cur (alist-ref value bins eqal? seed)))
      (alist-update! value (next value cur) bins eqal?)) )
  (seq:foldl kons '() seq) )

;basic coercions

(define (->list x) (if (list? x) x (seq:coerce '() x)))
(define (->vector x) (if (vector? x) x (seq:coerce #() x)))
(define (->string x) (if (string? x) x (seq:coerce "" x)))

;expose (chicken sort)

(define (merge! a b less?)
  (let ((rs (chicken:merge! (->list a) (->list b) less?)))
    (if (list? a) rs (seq:coerce a rs)) ) )

(define (merge a b less?)
  (let ((rs (chicken:merge (->list a) (->list b) less?)))
    (if (list? a) rs (seq:coerce a rs)) ) )

(define (sorted? seq less?)
  (let ((ss (if (vector? seq) seq (->list seq))))
    (chicken:sorted? ss less?) ) )

(define (sort! seq less?)
  ;FIXME fill-in original from sorted-list
  (let* ((ss (if (vector? seq) seq (->list seq)))
         (rs (chicken:sort! ss less?)) )
    (if (or (list? seq) (vector? seq)) rs (seq:coerce seq rs)) ) )

(define (sort seq less?)
  (define (*->list x) (if (list? x) (list-copy x) (->list x)))
  (seq:coerce seq (chicken:sort! (*->list seq) less?)) )

;FIXME handle linear vs random in unique
(define (unique seq #!optional (eqal? equal?))
  (assert (seq:sequence? seq))
  #; ;assumed, cannot enforce
  (assert (sorted? seq lessp))
  (assert (procedure? eqal?))
  (let loop ((seq seq) (os '()) (prv unique))
    (if (seq:empty? seq)
        ;then finished, anything done?
        (if (eq? unique prv) seq
            (seq:coerce seq (reverse! os)) )
        ;else try current
        (let ((cur (seq:peek seq)) (rst (seq:pop seq)))
          (if (and (not (eq? unique prv)) (eqal? prv cur))
              (loop rst os cur)
              (loop rst (cons cur os) cur) ) ) ) ) )

;really simple stats

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

(define (randoms* 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 (randoms cnt #!optional (end most-positive-fixnum) (low 0) (dups? #f))
  (assert (fixnum? cnt)) (assert (fx<= 0 cnt))
  (assert (integer? end)) (assert (not (negative? end)))
  (assert (integer? low)) (assert (not (negative? low)))
  (assert (< low end))
  (let ((lim (- end low)))
    (if dups? (randoms* cnt lim low)
        (let loop ((os '()))
          (let* ((os (unique (chicken:sort! (append! os (randoms* cnt lim low)) fx<) fx=))
                 (len (length os)) )
            (cond ((fx= len cnt) os)
                  ((fx> len cnt) (take! os cnt))
                  (else (loop os)) ) ) ) ) ) )

(define (sample seq . rest)
  (assert (seq:sequence? seq))
  (let* ((siz (seq:size seq))
         (cnt (optional rest (pseudo-random-integer siz))) )
    (assert (fixnum? cnt)) (assert (fx<= 0 cnt))
    (assert (<= cnt siz))
    ;use of a sorted set of indices allows linear access
    (let ((is (randoms cnt siz)))
      (define (linear-sample)
        (let loop ((seq seq) (is is) (i 0) (os '()))
          (cond ((or (null? is) (seq:empty? seq))
                  os)
                ((= i (car is))
                  (loop (seq:pop seq) (cdr is) (+ i 1) (cons (seq:peek seq) os)))
                (else
                  (loop (seq:pop seq) is (+ i 1) os)) ) ) )
      (define (random-sample)
        (let loop ((iter (seq:iterator seq)) (is is) (os '()))
          (let ((i (seq:index iter)))
            (cond ((or (null? is) (seq:at-end? iter))
                    os)
                  ((= i (car is))
                    (loop (seq:advance! iter) (cdr is) (cons (seq:elt seq i) os)))
                  (else
                    (loop (seq:advance! iter) is os)) ) ) ) )
      (let ((os (if (seq:linear-sequence? seq) (linear-sample) (random-sample))))
        (seq:coerce seq (reverse! os)) ) ) ) )

) ;module (sequences utils)