;;;; sparse-vectors.hof.scm

;; Issues
;;
;; - should have `sparse-vector-unfold' ?

(module (sparse-vectors hof)

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

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

(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 * * -> *) * boolean -> * integer))

(: 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? (* * #!optional (* * -> boolean) -> boolean))

;miscmacros

(define-syntax let/cc
  (syntax-rules ()
    ((let/cc ?k ?body ...)
      (call/cc (lambda (?k) ?body ...)) ) ) )

;;

(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)
  (let-values (
    ((_ _)
      (*sparse-vector-fold (check-sparse-vector 'sparse-vector-for-each hilbert)
                           (lambda (i a v) (func i v) a)
                           (void)
                           (optional rest #t))) )
    (void) ) )

;FIXME parallel "fold" over hilbert & hil-new

(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))) )
    (let-values (
      ((_ _)
        (*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?))
  (and (sparse-vector? hil1) (sparse-vector? hil2)
       (fx= (hilbert-count hil1) (hilbert-count hil2))
       (let/cc return
         (define (eqal-elm-chkr i _ v)
           (or (eqal? v (*sparse-vector-ref hil2 i))
               ;early exit @ 1st <>
               ;FIXME multi-valued continuation?
               (return #f)) )
         (let-values (
           ((succ? _) (*sparse-vector-fold hil1 eqal-elm-chkr #t #t)) )
           succ? ) ) ) )

) ;module (sparse-vectors hof)