;;;; sparse-vectors.hof.scm

(module (sparse-vectors hof)

(;export
  ;
  sparse-vector-fold sparse-vector-map sparse-vector-for-each
  ;
  sparse-vector-copy
  ;
  sparse-vector-equal?
  ;
  alist->sparse-vector sparse-vector->alist)

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

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

;FIXME cannot state procedure argument as pure w/ `-->'; info lost w/ define-type as well
(: sparse-vector-fold (sparse-vector (integer * * -> *) * #!optional boolean -> *))
(: sparse-vector-map (sparse-vector (integer * -> *) #!optional boolean -> (list-of *)))
(: sparse-vector-for-each (sparse-vector (integer * -> *) #!optional boolean -> void))

(: sparse-vector-copy (sparse-vector --> sparse-vector))

(: sparse-vector-equal? (sparse-vector sparse-vector #!optional (* * -> boolean) --> boolean))

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

;;

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

(define (*sparse-vector-fold hilbert func seed skip?)
  (let ((siz (hilbert-node-size hilbert))
        (def-def (hilbert-def-value (hilbert-default hilbert))) )
    ;for-each node element
    (define (hilbert-node-fold node fun acc idx)
      #;(assert (node? node))
      (let loop ((i 0) (acc acc) (idx idx))
        (if (fx= i siz) (values acc idx)
            (let-values (((acc idx) (fun idx acc (node-ref node i))))
              (loop (fx+ i 1) acc idx) ) ) ) )
    ;depth-first tree walk
    (let recur ((height (hilbert-height hilbert)) (node (hilbert-root hilbert)) (acc seed) (idx 0))
      #;(assert (node? node) '*sparse-vector-fold "internal node issue" height acc idx node)
      (if (fx= 1 height)
          ;walk across
          (hilbert-node-fold
            node
            (lambda (i a v)
              (values
                (cond ((not (hilbert-def? v))
                        (func i a v))
                      (skip?
                        a)
                      (else
                        (func i a def-def)))
                (add1 i)) )
            acc idx)
          ;walk down
          (let* ((height-1 (fx- height 1))
                 (stp (expt siz height-1)) )
            #;(assert (fx< 0 height-1) '*sparse-vector-fold "internal height issue" 0 acc idx node)
            (hilbert-node-fold
              node
              (lambda (i a v)
                (cond ((not (hilbert-def? v))
                        (recur height-1 v a i))
                      (skip?
                        (values a (+ i stp)))
                      (else
                        (let ((lim (+ i stp)))
                          (let loop ((i i) (a a))
                            (if (<= lim i) (values a i)
                                (loop (add1 i) (func i a def-def)) ) ) ) ) ) )
              acc idx) ) ) ) ) )

;;

;NOTE due to the sparse nature of the vector the index is a crucial property
;of an element. Any enumeration of a sparse-vector must include the index.

;NOTE order is not that of a vector, but a hash-table library

(define (sparse-vector-fold hilbert func seed . rest)
  (let-values
    (((acc _) (*sparse-vector-fold (check-sparse-vector 'sparse-vector-fold hilbert)
                                   (check-procedure 'sparse-vector-fold func)
                                   (check-bound-value 'sparse-vector-fold seed 'seed)
                                   (optional rest #t)) ) )
    acc ) )

(define (sparse-vector-map hilbert func . rest)
  (check-procedure 'sparse-vector-map func)
  (let-values
    (((acc _) (*sparse-vector-fold (check-sparse-vector 'sparse-vector-map hilbert)
                                   (lambda (i a v) (cons (func i v) a))
                                   '()
                                   (optional rest #t)) ) )
    ;restore order (left-to-right)
    (reverse! acc) ) )

(define (sparse-vector-for-each hilbert func . rest)
  (check-procedure 'sparse-vector-for-each func)
  ;ignore results
  (*sparse-vector-fold (check-sparse-vector 'sparse-vector-for-each hilbert)
                       (lambda (i a v) (func i v) a)
                       (void)
                       (optional rest #t))
  ;no result
  (void) )

(define (sparse-vector-copy hilbert)
  (check-sparse-vector 'sparse-vector-copy hilbert)
  (let ((hil-new (make-sparse-vector (hilbert-def-value (hilbert-default hilbert))
                                     (hilbert-bits hilbert))) )
    ;FIXME parallel "fold" over hilbert & hil-new
    (*sparse-vector-fold hilbert
                         (lambda (i a v) (*sparse-vector-set! hil-new i v) a)
                         #t
                         #t)
    hil-new ) )

(define (sparse-vector-equal? hil1 hil2 #!optional (eqal? equal?))
  (check-sparse-vector 'sparse-vector-equal? hil1)
  (and (fx= (hilbert-count hil1) (hilbert-count hil2))
       (call/cc
         (lambda (k)
           ;FIXME parallel "fold" over hil1 & hil2
           (*sparse-vector-fold hil1
                                (lambda (i a v)
                                  (unless (eqal? v (*sparse-vector-ref hil2 i)) (k #f))
                                  a)
                                #t
                                #t)
           #t) ) ) )

;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 ) )

) ;module (sparse-vectors hof)