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

; Modifications Sep 2022 Kon Lovett

;;

(declare
  (bound-to-procedure ##sys#check-exact-uinteger
    ##sys#check-list ##sys#check-pair ##sys#check-closure
    ##sys#check-output-port ##sys#check-structure
    ##sys#check-range))

;;

(define-record-type-variant sparse-vector (unchecked inline unsafe)
  (make-hilbert height root default count capacity bits)
  hilbert?
  (height hilbert-height set-hilbert-height!)
  (root hilbert-root set-hilbert-root!)
  (default hilbert-default)
  (count hilbert-count set-hilbert-count!)
  (capacity hilbert-capacity set-hilbert-capacity!)
  (bits hilbert-bits))

(define-record-type-variant hilbert-def (unchecked inline unsafe)
  (make-hilbert-def value)
  hilbert-def?
  (value hilbert-def-value) )

(define-inline (hilbert-def-value* x)
  (if (not (hilbert-def? x)) x
      (hilbert-def-value x)) )

;;

(define-type hilbert-node vector)

(define-constant DEFAULT-HILBERT-BITS 8)

(define-inline (node-size-expt i bits) (arithmetic-shift i bits))

(define-inline (hilbert-node-size hilbert) (node-size-expt 1 (hilbert-bits hilbert)))
(define-inline (hilbert-mask hilbert) (fx- (hilbert-node-size hilbert) 1))

(define-inline (make-node hilbert)
  (make-vector (hilbert-node-size hilbert) (hilbert-default hilbert)) )

(define-inline (node? x) (vector? x))

(define-inline (node-length vec) (vector-length vec))

(define-inline (node-ref-valid? x idx)
  (and (node? x)
       (fixnum? idx)
       (fx<= 0 idx)
       (fx< idx (node-length x))) )

(define-inline (node-ref vec idx) (vector-ref vec idx))

(define-inline (node-set! vec idx val) (vector-set! vec idx val))

(define-inline (node-unset! vec idx val) (vector-set! vec idx val))

(define-inline (check-exact-uinteger loc obj) (##sys#check-exact-uinteger obj loc) obj)
(define-inline (check-list loc obj) (##sys#check-list obj loc) obj)
(define-inline (check-pair loc obj) (##sys#check-pair obj loc) obj)
(define-inline (check-vector loc obj) (##sys#check-vector obj loc) obj)
(define-inline (check-procedure loc obj) (##sys#check-closure obj loc) obj)
(define-inline (check-output-port loc obj) (##sys#check-output-port obj loc) obj)
(define-inline (check-structure loc obj tag) (##sys#check-structure obj tag loc) obj)
(define-inline (check-fixnum-in-range loc obj from to) (##sys#check-range obj from to loc) obj)

#+compiling
(define-inline (bound-value? obj) (not (##core#inline "C_unboundvaluep" obj)))

(define-inline (error-bound-value loc obj argnam) (##sys#error-hook 4 loc obj argnam))

(define-inline (check-bound-value loc obj argnam)
  (unless (bound-value? obj) (error-bound-value loc obj argnam))
  obj )

(define-inline (error-bounds loc obj idx) (##sys#error-hook 8 loc obj idx))