;;;; sparse-vectors-test.scm

(import test)
(import (chicken format) (test-utils gloss))

;;;

(test-begin "Sparse Vectors")

(import sparse-vectors (sparse-vectors hof))
(import (only (sparse-vectors debug) sparse-vector-info))
(import (only (sparse-vectors extras) alist->sparse-vector sparse-vector->alist))
(import (chicken random) (chicken sort) (chicken port) (chicken string))
(import (chicken fixnum))
(import (only (srfi 1) take! reverse! append!))

(define (check-list loc obj) (##sys#check-list obj loc) obj)
(define (check-closure loc obj) (##sys#check-closure obj loc) obj)
(define check-procedure check-closure)

(define (list-unique ls #!optional (eqal? equal?))
  (check-procedure 'list-unique eqal?)
  (let loop ((ils (check-list 'list-unique ls)) (ols '()) (prev list-unique))
    (if (null? ils) (reverse! ols)
        (let ((curr (car ils)) (rst (cdr ils)))
          (if (and (not (eq? list-unique prev)) (eqal? prev curr))
              (loop rst ols prev)
              (loop rst (cons curr ols) curr) ) ) ) ) )

;NOTE most-positive-fixnum > (length longest possible-list)

(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 (list-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 (list-unique (sort! os <) =))
                 (len (length os)) )
            (cond ((fx= len cnt) os)
                  ((fx> len cnt) (take! os cnt))
                  (else (loop os)) ) ) ) ) ) )

(define (list-sample ls . rest)
  (assert (list? ls))
  (let* ((len (length ls))
         (cnt (optional rest (pseudo-random-integer len))) )
    (assert (fixnum? cnt)) (assert (fx<= 0 cnt))
    #; ;assumed
    (assert (fixnum? len))
    (assert (fx<= cnt len))
    ;use of a sorted set of indices allows only forward input list motion
    (let loop ((ls ls) (is (list-randoms cnt len)) (i 0) (os '()))
      (cond ((or (null? is) (null? ls))
              (reverse! os))
            ((= i (car is))
              (loop (cdr ls) (cdr is) (+ i 1) (cons (car ls) os)))
            (else
              (loop (cdr ls) is (+ i 1) os)) ) ) ) )

;;

(define (sparse-vector-reduce sv func seed)
  (sparse-vector-fold sv (lambda (i a v) (func a v)) seed) )

(define (sparse-vector-sum sv) (sparse-vector-reduce sv + 0))

(define (sparse-vector-folded-count sv)
  (sparse-vector-fold sv (lambda (i a v) (add1 a)) 0) )

(define (sparse-vector-unoccupied-count sv)
  (sparse-vector-fold sv (lambda (i a v) (if (not v) (add1 a) a)) 0 #f) )

(define (sparse-vector-efficiency sv)
  (let-values (((nodcnt nodht nodsiz) (sparse-vector-info sv)))
    (exact->inexact (/ (sparse-vector-count sv) (* nodcnt nodsiz))) ) )

;;

;NOTE the "order is descending" is an implementation detail, necessary only
;for testing

;for alist comparison
(define (sval< a b) (< (car a) (car b)))
(define (sval> a b) (> (car a) (car b)))

(define (asc-sv sv) (sort sv sval<))
(define (dsc-sv sv) (sort sv sval>))

;;

;shared, unordered by index, test sparse-vector alist
(define tal '((8 . 9) (7 . 8) (6 . 7) (5 . 6) (4 . 4) (3 . 3)
              (2 . 2) (43 . 43) (1 . 1) (0 . 0) (60 . 60)))

(test-group "Alist"
  (let ((sv (alist->sparse-vector tal)))
    (test-assert (sparse-vector? sv))
    (test (length tal) (sparse-vector-count sv))
    (gloss "sv (ASC) =" (asc-sv (sparse-vector->alist sv)))
    (test (dsc-sv tal) (sparse-vector->alist sv)) )
)

(test-group "Copy"
  (let* ((sv1 (alist->sparse-vector tal))
         (sv (sparse-vector-copy sv1)) )
    (test-assert (sparse-vector? sv))
    (test (sparse-vector-count sv1) (sparse-vector-count sv))
    (gloss "sv (ASC) =" (asc-sv (sparse-vector->alist sv)))
    (test (dsc-sv tal) (sparse-vector->alist sv))
    (test-assert (sparse-vector-equal? sv1 sv eqv?))
    (set! (sparse-vector-ref sv1 43) -1)
    (gloss "sv1 (ASC) =" (asc-sv (sparse-vector->alist sv1)))
    (test-assert (not (sparse-vector-equal? sv1 sv eqv?))) )
)

(test-group "HOF"
  (let ((sv (alist->sparse-vector tal)))
    (test 143 (sparse-vector-sum sv))
    ;these won't be the same since v != i
    (test '(0 1 2 3 4 6 7 8 9 43 60) (sparse-vector-map sv (lambda (i v) v)))
    (test "for-each"
          '(60 43 8 7 6 5 4 3 2 1 0)
          (let ((ids '()))
            (sparse-vector-for-each sv (lambda (i v) (set! ids (cons i ids))))
            ids)) )
)

;;

(define-constant DEFAULT-BITS 8)

(define-constant RANDOM-SETTING-COUNT 10000)

(define (random-set-sv! sv maxi cnt dups)
  (let ((indicies (list-randoms cnt maxi 0 dups)))
    (for-each (lambda (j) (set! (sparse-vector-ref sv j) j)) indicies)
    (values (apply max indicies) indicies) ) )

(define (check-filled-sv sv indices)
  (if #t
      ;no stinking indicies
      (call/cc (lambda (k)
        (sparse-vector-for-each sv
          (lambda (i v)
            (unless (= i v)
              (gloss i "!=" v (if (memv i indices) "INCORRECT" "INVALID"))
              (k i))))
        #f))
      ;stinking indicies
      (let loop ((i indices))
        (and (not (null? i))
             (let ((j (car i)))
               (if (not (= j (sparse-vector-ref sv j))) j
                   (loop (cdr i)) ) ) ) ) ) )

(define (random-filled-sv maxi #!optional def (bits DEFAULT-BITS) (cnt RANDOM-SETTING-COUNT) dups)
  (let ((sv (make-sparse-vector def bits)))
    (gloss "filling ...")
    (let-values (((high indices) (random-set-sv! sv maxi cnt dups)))
      (gloss "checking ( highest =" high ") ...")
      (and-let* ((j (check-filled-sv sv indices)))
        (test (conc "Index " j) j (sparse-vector-ref sv j)) )
      (values sv indices) ) ) )

(define (test-random-filled maxi
                            #!optional
                            def (bits DEFAULT-BITS)
                            (req-cnt RANDOM-SETTING-COUNT)
                            (low RANDOM-SETTING-COUNT) (high RANDOM-SETTING-COUNT)
                            dups)
  (let-values (((sv indices) (random-filled-sv maxi def bits req-cnt dups)))
    (let ((cnt (sparse-vector-count sv)))
      ;(gloss "count =" cnt)
      ;FIXME allows for re-set of elms, cnt will, probably, not = RANDOM-SETTING-COUNT
      (test-assert "within index range" (<= low cnt high))
      (values sv indices) ) ) )

(test-group "Random Filled"

  (test-group "max random filled & emptied: 10 ** 1 w/ 2 ** 8 node-size"
    (let ((sv (test-random-filled 10 (void) 8 1000 10 10 #t)))
      (gloss "info =" (receive (sparse-vector-info sv)))
      (test 10 (sparse-vector-count sv))
      (test-assert "unset!" (begin (sparse-vector-unset! sv 5) #t))
      (test "unset" 9 (sparse-vector-count sv))
      (gloss "rem 6th elm [5]:" (sparse-vector->alist sv)) )
  )

  (test-group "max random filled: 10^4 max: 10 ** 9 w/ 2 ** 8 node-size"
    (let ((sv (test-random-filled (expt 10 9) #f 8 RANDOM-SETTING-COUNT 9999)))
      (gloss "eff =" (sparse-vector-efficiency sv))
      #;(gloss "uno =" (sparse-vector-unoccupied-count sv))
      (test "folded count" RANDOM-SETTING-COUNT (sparse-vector-folded-count sv)) )
  )

  (test-group "max random filled: 10^4 max: 10 ** 21 w/ 2 ** 3 node-size"
    (let ((sv (test-random-filled (expt 10 21) #f 6)))
      (gloss "eff =" (sparse-vector-efficiency sv))
      #;(gloss "uno =" (sparse-vector-unoccupied-count sv))
      (test "stored count" RANDOM-SETTING-COUNT (sparse-vector-count sv))
      (test "folded count" (sparse-vector-count sv) (sparse-vector-folded-count sv)) )
  )

  #; ;UNCOMMENT FOR MORE TESTS
  (test-group "max random filled: 10^4 max: 10 ** 21 w/ 2 ** 4 node-size"
    (let ((sv (test-random-filled (expt 10 21) #f 6)))
      (gloss "eff =" (sparse-vector-efficiency sv))
      #;(gloss "uno =" (sparse-vector-unoccupied-count sv))
      (test "stored count" RANDOM-SETTING-COUNT (sparse-vector-count sv))
      (test "folded count" (sparse-vector-count sv) (sparse-vector-folded-count sv)) )
  )

  #; ;UNCOMMENT FOR MORE TESTS
  (test-group "max random filled: 10^4 max: 10 ** 21 w/ 2 ** 6 node-size"
    (let ((sv (test-random-filled (expt 10 21) #f 6)))
      (gloss "eff =" (sparse-vector-efficiency sv))
      #;(gloss "uno =" (sparse-vector-unoccupied-count sv))
      (test "stored count" RANDOM-SETTING-COUNT (sparse-vector-count sv))
      (test "folded count" (sparse-vector-count sv) (sparse-vector-folded-count sv)) )
  )

  (test-group "max random filled: 10^4 max: 10 ** 21 w/ 2 ** 8 node-size"
    ;NOTE use of defaults
    (let ((sv (test-random-filled (expt 10 21))))
      (gloss "eff =" (sparse-vector-efficiency sv))
      #;(gloss "uno =" (sparse-vector-unoccupied-count sv))
      (test "stored count" RANDOM-SETTING-COUNT (sparse-vector-count sv))
      (test "folded count" (sparse-vector-count sv) (sparse-vector-folded-count sv)) )
  )

  #; ;UNCOMMENT FOR MORE TESTS
  (test-group "max random filled: 10^4 max: 10 ** 21 w/ 2 ** 10 node-size"
    (let ((sv (test-random-filled (expt 10 21) #f 10)))
      (gloss "eff =" (sparse-vector-efficiency sv))
      #;(gloss "uno =" (sparse-vector-unoccupied-count sv))
      (test "stored count" RANDOM-SETTING-COUNT (sparse-vector-count sv))
      (test "folded count" (sparse-vector-count sv) (sparse-vector-folded-count sv)) )
  )

  (test-group "max random filled & emptied: 10 ** 9 w/ 2 ** 6 node-size"
    (let-values (((sv is) (test-random-filled (expt 10 9) #f 6)))
      (let ((old-cnt (sparse-vector-count sv))
            (ris (list-sample is 30)) )
        (for-each (cut sparse-vector-unset! sv <>) ris)
        (test "stored count" old-cnt (+ (sparse-vector-count sv) (length ris)))
        (test "folded count" (sparse-vector-count sv) (sparse-vector-folded-count sv))
        (for-each (lambda (i) (test-assert (not (sparse-vector-ref sv i)))) ris) ) )
  )

)

;;;

(test-end "Sparse Vectors")

(test-exit)