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

;;Issues
;;

(module (sequences utils)

(;export
  ;
  reduce
  ;
  foldl->alist
  ;
  ->list ->vector ->string
  ;
  merge merge!
  sorted?
  sort sort!
  unique unique/unsorted
  ;
  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:)
  (srfi 69))

;;;

(include "sequences-utils-types")

(: reduce (('a 'a -> 'a) 'a seq --> 'a))

(: 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))
(: unique/unsorted (seq --> seq))

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

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

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

;;

;srfi-1 reduce

(define (reduce f rid seq)
  (if (seq:empty? seq) rid
      (seq:foldl f (seq:peek seq) (seq:pop 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 cur value) 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?)) )

(define (unique seq #!optional (eqal? equal?))
  (define (ordered-unique)
    (let loop ((iter (seq:iterator seq)) (os '()) (prv unique))
      (if (seq:at-end? iter)
          ;then finished, anything done?
          (if (eq? unique prv) seq os)
          ;else try current
          (let ((cur (seq:elt seq (seq:index iter))))
            (if (and (not (eq? unique prv)) (eqal? prv cur))
                (loop (seq:advance! iter) os cur)
                (loop (seq:advance! iter) (cons cur os) cur)) ) ) ) )
  (assert (seq:sequence? seq))
  #; ;assumed, cannot enforce
  (assert (sorted? seq lessp))
  (assert (procedure? eqal?))
  (let ((os (ordered-unique)))
    (if (eq? os seq) seq
        (seq:coerce seq (reverse! os)) ) ) )

(define (unique/unsorted seq)
  (assert (seq:sequence? seq))
  (let-values (((eqal? hsh) (if (string? seq) (values char=? eqv?-hash)
                                (values equal? hash))))
    (let ((ht (make-hash-table eqal? hsh)))
      (define (sequential-unique)
        (let loop ((iter (seq:iterator seq)) (idx 0))
          (if (seq:at-end? iter)
              ;then finished, anything done?
              (if (= idx (hash-table-size ht)) seq
                  (hash-table-keys ht))
              ;else try current
              (let ((cur (seq:elt seq (seq:index iter))))
                (hash-table-update! ht cur (lambda (v) (add1 v)) (lambda () 0))
                (loop (seq:advance! iter) (add1 idx)) ) ) ) )
      (seq:coerce seq (reverse! (sequential-unique))) ) ) )

;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* ((rs (randoms* cnt lim low))
                 (os (append! rs os))
                 (os (unique (sort! os <) =))
                 (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 (random-sample)
        (let loop ((iter (seq:iterator seq)) (is is) (os '()))
                ;done?
            (if (or (null? is) (seq:at-end? iter)) os
                ;else is this your sample?
                (let ((i (seq:index iter)))
                  (if (= i (car is))
                      ;then sample
                      ;FIXME better check if necessary
                      (let ((cur (seq:elt seq i)))
                        (loop (seq:advance! iter) (cdr is) (cons cur os)))
                      ;else ignore
                      (loop (seq:advance! iter) is os) ) ) ) ) )
      (seq:coerce seq (reverse! (random-sample))) ) ) )

) ;module (sequences utils)