;;;; sparse-vectors.extras.scm

(module (sparse-vectors extras)

(;export
  ;
  fill-sparse-vector! *fill-sparse-vector!
  ;
  alist->sparse-vector sparse-vector->alist
  list->sparse-vector sparse-vector->list
  sparse-vector->vector vector->sparse-vector
  ;
  sparse-vector-reserve!)

(import
  scheme
  (chicken base)
  (chicken type)
  (chicken bitwise)
  (chicken fixnum)
  (only (srfi 1) reverse!)
  record-variants
  sparse-vectors (sparse-vectors hof))

(include-relative "sparse-vectors.types")

(: alist->sparse-vector (sparse-alist #!optional * -> sparse-vector))
(: sparse-vector->alist (sparse-vector -> sparse-alist))

(: sparse-vector->list (sparse-vector -> list))
(: list->sparse-vector (list #!optional integer * fixnum -> sparse-vector))

(: *fill-sparse-vector! (sparse-vector (or list vector) integer -> sparse-vector))
(: fill-sparse-vector! (sparse-vector (or list vector) #!optional integer -> void))

(: sparse-vector->vector (sparse-vector #!optional integer integer -> vector))
(: vector->sparse-vector (vector #!optional integer * fixnum -> sparse-vector))

(: sparse-vector-reserve! (sparse-vector integer #!optional integer -> void))

;;

(define (vector-foldl f s v)
  (let ((len (vector-length v)))
    (let loop ((i 0) (a s))
      (if (fx= i len) a
          (loop (fx+ i 1) (f a i (vector-ref v i))) ) ) ) )

;;

(include-relative "sparse-vectors-inlines")

(define-inline (sparse-vector-reserve-elm! hilbert index value)
  (*sparse-vector-set! hilbert index value) )

(define (check-index loc obj)
  (assert (not (negative? (check-exact-uinteger loc obj)))
          loc "index cannot be negative" obj)
  obj )

(define (*sparse-vector->list loc hilbert start end)
  (check-index loc start)
  (when end
    (assert (< start (check-index loc end))
            loc "start must be less than end" start end) )
  (let-values (
      ((ls _)
        (*sparse-vector-fold (check-sparse-vector loc hilbert)
                             (lambda (i a v)
                               (cond ((< i start) a)
                                     ((or (not end) (< i end)) (cons v a))
                                     (else a)) )
                             '()
                             #f)) )
    (reverse! ls) ) )

(define (*sparse-vector-update! hilbert idx val def)
      ;the default value?
  (if (eq? def val)
      ;then unset - whether set or not
      (*sparse-vector-unset! hilbert idx #t)
      ;else set - whether set or not
      (*sparse-vector-set! hilbert idx val) ) )

;;

;@start : sparse-vector start
;vector range [0 end]
(define (*fill-sparse-vector! hilbert vec-or-lis start)
  (let ((def (hilbert-def-value (hilbert-default hilbert))))
    (define (updt! v i) (*sparse-vector-update! hilbert (+ start i) v def))
    (if (list? vec-or-lis)
        (foldl (lambda (i v) (updt! v i) (fx+ i 1)) 0 vec-or-lis)
        (vector-foldl (lambda (a i v) (updt! v i) a) #t vec-or-lis) )
    hilbert ) )

;@start : sparse-vector start
;vector range [0 end]
(define (fill-sparse-vector! hilbert vec-or-lis . rest)
  (let-optionals rest ((start 0))
    (*fill-sparse-vector! (check-sparse-vector 'fill-sparse-vector! hilbert)
                          (if (list? vec-or-lis) vec-or-lis
                              (check-vector 'fill-sparse-vector! vec-or-lis))
                          (check-index 'fill-sparse-vector! start))
    (void) ) )

(define (list->sparse-vector lis . rest)
  (let-optionals rest ((start 0))
    (*fill-sparse-vector! (apply make-sparse-vector rest)
                          (check-list 'vector->sparse-vector lis)
                          (check-index 'fill-sparse-vector! start)) ) )

;@start, @end : sparse-vector range
;vector range [0 end]
(define (sparse-vector->list hilbert . rest)
  (let-optionals rest ((start 0) (end #f))
    (*sparse-vector->list 'sparse-vector->list hilbert start end) ) )

;@start, @end : sparse-vector range
;vector range [0 end]
(define (sparse-vector->vector hilbert . rest)
  (let-optionals rest ((start 0) (end #f))
    (list->vector
     (*sparse-vector->list 'sparse-vector->vector hilbert start end)) ) )

;@start : sparse-vector start
;vector range [0 end]
(define (vector->sparse-vector vec . rest)
  (let-optionals rest ((start 0))
    (*fill-sparse-vector! (apply make-sparse-vector rest)
                          (check-vector 'vector->sparse-vector vec)
                          (check-index 'vector->sparse-vector start))) )

;FIXME arg check overhead, how often called?
(define (alist->sparse-vector al . rest)
  (let-optionals rest ((default #f) (bits DEFAULT-HILBERT-BITS))
    (let ((hilbert (make-sparse-vector default bits)))
      (define (set-sv/cell! cell)
        (check-pair 'alist->sparse-vector cell)
        (*sparse-vector-set! hilbert
                             (check-exact-uinteger 'alist->sparse-vector (car cell))
                             (cdr cell)) )
      (for-each set-sv/cell! (check-list 'alist->sparse-vector al))
      hilbert ) ) )

(define (sparse-vector->alist hilbert)
  (let-values (
    ((acc idx)
      (*sparse-vector-fold (check-sparse-vector 'sparse-vector->alist hilbert)
                           (lambda (i a v) `((,i . ,v) . ,a))
                           '()
                           #t)) )
    acc ) )

;;

;@end last index, @low first index where @low <= @end!
(define (sparse-vector-reserve! hilbert end . rest)
  ;hacky but it works
  (check-sparse-vector 'sparse-vector-reserve hilbert)
  (let ((low (optional rest 0))
        (siz (hilbert-node-size hilbert))
        (def (hilbert-default hilbert)) )
    (unless (<= (check-index 'sparse-vector-reserve! low)
                (check-index 'sparse-vector-reserve! end))
      (error 'sparse-vector-reserve! "low must be less than end" low end))
    ;FIXME used may not be in range
    (unless (fx= 0 (sparse-vector-count hilbert))
      (error 'sparse-vector-reserve! "non-empty sparse-vector" hilbert end low))
    (do ((index (* (quotient low siz) siz) (+ index siz)))
        ((>= index end) (set-hilbert-count! hilbert 0))
      (sparse-vector-reserve-elm! hilbert index def)) ) )

) ;module (sparse-vectors extras)