; Copyright (c) 1993-2007 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Hilbert vectors are like vectors that grow as large as they need to.
; That is, they can be indexed by arbitrarily large nonnegative integers.

; The implementation allows for arbitrarily large gaps by arranging
; the entries in a tree.

; So-called because they live in an infinite-dimensional vector
; space...


(define hilbert-log 8)
(define hilbert-node-size (arithmetic-shift 1 hilbert-log))
(define hilbert-mask (- hilbert-node-size 1))
(define minus-hilbert-log (- 0 hilbert-log))

(define-record-type sparse-vector
  (make-hilbert height root default)
  sparse-vector?
  (height hilbert-height set-hilbert-height!)
  (root hilbert-root set-hilbert-root!)
  (default hilbert-default set-hilbert-default!))

(define-record hilbert-def value)

(define-record-printer (sparse-vector x p)
  (fprintf p "#~s" (sparse-vector->list x)) )

(define (make-sparse-vector . rest)
  (let-optionals rest ((default #f))
    (make-hilbert 1 (make-vector hilbert-node-size 
                                 (make-hilbert-def default)) 
		  (make-hilbert-def default))))

(define (sparse-vector-ref1 hilbert index)
  (let recur ((height (hilbert-height hilbert))
	      (index index))
    (if (= height 1)
	(let ((root (hilbert-root hilbert)))
	  (if (< index (vector-length root))
	      (vector-ref root index)
	      (hilbert-default hilbert)))
	(let ((node (recur (- height 1)
			   (arithmetic-shift index minus-hilbert-log))))
	  (if (vector? node)
	      (vector-ref node (bitwise-and index hilbert-mask))
	      (hilbert-default hilbert))))))

(define (sparse-vector-set! hilbert index value)
  (vector-set!
   (let recur ((height (hilbert-height hilbert))
	       (index index))
     (if (= height 1)
	 (make-higher-if-necessary hilbert index)
	 (let ((index (arithmetic-shift index minus-hilbert-log)))
	   (make-node-if-necessary
	    (recur (- height 1) index)
	    (bitwise-and index hilbert-mask)
	    (hilbert-default hilbert)))))
   (bitwise-and index hilbert-mask)
   value))

(define sparse-vector-ref
  (getter-with-setter
   (lambda (hilbert index)
     (let ((val (sparse-vector-ref1 hilbert index)))
       (if (hilbert-def? val)
	   (hilbert-def-value val)
	   val)))
   sparse-vector-set!))
	       
(define (make-higher-if-necessary hilbert index)
  (if (< index hilbert-node-size)
      (hilbert-root hilbert)
      (let ((new-root (make-vector hilbert-node-size (hilbert-default hilbert))))
	(vector-set! new-root 0 (hilbert-root hilbert))
	(set-hilbert-root! hilbert new-root)
	(set-hilbert-height! hilbert (+ (hilbert-height hilbert) 1))
	(let ((index (arithmetic-shift index minus-hilbert-log)))
	  (make-node-if-necessary (make-higher-if-necessary hilbert index)
				  (bitwise-and index hilbert-mask)
				  (hilbert-default hilbert))))))

(define (make-node-if-necessary node index default)
  (let ((v (vector-ref node index)))
    (if (vector? v) v
	(let ((new (make-vector hilbert-node-size default)))
	  (vector-set! node index new)
	  new))))

; For debugging

(define (sparse-vector->list h)
  (let recur ((node (hilbert-root h))
              (height (hilbert-height h))
              (more '()))
    (if (= height 0)
        (if (or (vector? node) (pair? more))
            (cons (if (hilbert-def? node) (hilbert-def-value node) node) more)
            '())
        (do ((i (- hilbert-node-size 1) (- i 1))
             (more more (recur (if (vector? node)
				   (let ((val (vector-ref node i)))
				     (if (hilbert-def? val)
					 (hilbert-def-value val)
					 val))
                                   (hilbert-default h))
                               (- height 1) more)))
            ((< i 0) more)))))