clojurian / clojurian-vector.scm

(use clojurian-syntax)

(define (arithmetic-shift-right/zero-fill n x)
  (arithmetic-shift (bitwise-and n #xFFFFFFFF) (- x)))

(define (vector-copy vec #!optional (count (vector-length vec)) copy)
  (let* ((count (if (positive? count)
                    count
                    (+ (vector-length vec) count 1)))
         (copy (or copy (make-vector count))))
    (vector-copy! vec copy count)
    copy))

;; (deftype VectorNode [edit arr])

(define-record pv-node
  edit vec)

;; deftype PersistentVector [meta cnt shift root tail ^:mutable __hash]
(define-record pv
  cnt shift root tail)

;; (defn- pv-fresh-node [edit]
;;   (VectorNode. edit (make-array 32)))

(define (pv-fresh-node edit)
  (make-pv-node edit (make-vector 32)))

(define +empty-node+
  (pv-fresh-node #f))

(define +empty-vector+
  (make-pv 0 5 +empty-node+ (vector)))


;; (defn- pv-aget [node idx]
;;   (aget (.-arr node) idx))

(define (pv-aget node idx)
  (vector-ref (pv-node-vec node) idx))

;; (defn- pv-aset [node idx val]
;;   (aset (.-arr node) idx val))

(define (pv-aset node idx val)
  (vector-set! (pv-node-vec node) idx val))

;; (defn- pv-clone-node [node]
;;   (VectorNode. (.-edit node) (aclone (.-arr node))))
(define (pv-clone-node node)
  (make-pv-node (pv-node-edit node)
                    (vector-copy (pv-node-vec node))))


;; (defn- tail-off [pv]
;;   (let [cnt (.-cnt pv)]
;;     (if (< cnt 32)
;;       0
;;       (bit-shift-left (bit-shift-right-zero-fill (dec cnt) 5) 5))))

(define (tail-off pv)
  (let ((cnt (pv-cnt pv)))
    (if (< cnt 32)
        0
        (-> (- cnt 1)
            (arithmetic-shift-right/zero-fill 5)
            (arithmetic-shift 5)))))

;; (defn- new-path [edit level node]
;;   (loop [ll level
;;          ret node]
;;     (if (zero? ll)
;;       ret
;;       (let [embed ret
;;             r (pv-fresh-node edit)
;;             _ (pv-aset r 0 embed)]
;;         (recur (- ll 5) r)))))

(define (new-path edit level node)
  (let loop ((ll level)
             (ret node))
    (if (zero? ll)
        ret
        (let* ( ;; (embed ret)
               (r (pv-fresh-node edit)))
          (pv-aset r 0 ret)
          (loop (- ll 5) r)))))

;; (defn- push-tail [pv level parent tailnode]
;;   (let [ret (pv-clone-node parent)
;;         subidx (bit-and (bit-shift-right-zero-fill (dec (.-cnt pv)) level) 0x01f)]
;;     (if (== 5 level)
;;       (do
;;         (pv-aset ret subidx tailnode)
;;         ret)
;;       (let [child (pv-aget parent subidx)]
;;         (if-not (nil? child)
;;           (let [node-to-insert (push-tail pv (- level 5) child tailnode)]
;;             (pv-aset ret subidx node-to-insert)
;;             ret)
;;           (let [node-to-insert (new-path nil (- level 5) tailnode)]
;;             (pv-aset ret subidx node-to-insert)
;;             ret))))))

(define (push-tail pv level parent tailnode)
  (let ((ret (pv-clone-node parent))
        (subidx (-> (- (pv-cnt pv) 1)
                    (arithmetic-shift-right/zero-fill level)
                    (bitwise-and #x01f))))
    (if (= 5 level)
        (begin
          (pv-aset ret subidx tailnode)
          ret)
        (let ((child (pv-aget parent subidx)))
          (if child
              (let ((node-to-insert (push-tail pv (- level 5) child tailnode)))
                (pv-aset ret subidx node-to-insert)
                ret)
              (let ((node-to-insert (new-path #f (- level 5) tailnode)))
                (pv-aset ret subidx node-to-insert)
                ret))))))

;; (defn- array-for [pv i]
;;   (if (and (<= 0 i) (< i (.-cnt pv)))
;;     (if (>= i (tail-off pv))
;;       (.-tail pv)
;;       (loop [node (.-root pv)
;;              level (.-shift pv)]
;;         (if (pos? level)
;;           (recur (pv-aget node (bit-and (bit-shift-right-zero-fill i level) 0x01f))
;;                  (- level 5))
;;           (.-arr node))))
;;     (throw (js/Error. (str "No item " i " in vector of length " (.-cnt pv))))))


(define (vector-for pv i)
  (if (and (<= 0 i) (< i (pv-cnt pv)))
      (if (>= i (tail-off pv))
          (pv-tail pv)
          (let loop ((node (pv-root pv))
                     (level (pv-shift pv)))
            (if (positive? level)
                (loop (pv-aget node (-> (arithmetic-shift-right/zero-fill i level)
                                        (bitwise-and #x01f)))
                      (- level 5))
                (pv-node-vec node))))
      (error "Vector index out of bounds" i (pv-cnt pv))))


;; (defn- do-assoc [pv level node i val]
;;   (let [ret (pv-clone-node node)]
;;     (if (zero? level)
;;       (do
;;         (pv-aset ret (bit-and i 0x01f) val)
;;         ret)
;;       (let [subidx (bit-and (bit-shift-right-zero-fill i level) 0x01f)]
;;         (pv-aset ret subidx (do-assoc pv (- level 5) (pv-aget node subidx) i val))
;;         ret))))


(define (do-assoc pv level node i val)
  (let ((ret (pv-clone-node node)))
    (if (zero? level)
        (begin
          (pv-aset ret (bitwise-and i #x01f) val)
          ret)
        (let ((subidx (-> (arithmetic-shift-right/zero-fill i level)
                          (bitwise-and #x01f))))
          (->> (do-assoc pv (- level 5) (pv-aget node subidx) i val)
               (pv-aset ret subidx))
          ret))))

;; (defn- pop-tail [pv level node]
;;   (let [subidx (bit-and (bit-shift-right-zero-fill (- (.-cnt pv) 2) level) 0x01f)]
;;     (cond
;;      (> level 5) (let [new-child (pop-tail pv (- level 5) (pv-aget node subidx))]
;;                    (if (and (nil? new-child) (zero? subidx))
;;                      nil
;;                      (let [ret (pv-clone-node node)]
;;                        (pv-aset ret subidx new-child)
;;                        ret)))
;;      (zero? subidx) nil
;;      :else (let [ret (pv-clone-node node)]
;;              (pv-aset ret subidx nil)
;;              ret))))



(define (pop-tail pv level node)
  (let ((subidx (-> (- (pv-cnt pv) 2)
                    (arithmetic-shift-right/zero-fill level)
                    (bitwise-and #x01f))))
    (cond
     ((> level 5)
      (let ((new-child (pop-tail pv (- level 5) (pv-aget node subidx))))
        (if (and (not new-child) (zero? subidx))
            #f
            (let ((ret (pv-clone-node node)))
              (pv-aset ret subidx new-child)
              ret))))
     ((zero? subidx) #f)
     (else (let ((ret (pv-clone-node node)))
             (pv-aset ret subidx #f)
             ret)))))

;; (declare tv-editable-root tv-editable-tail TransientVector deref
;;          pr-sequential pr-seq)

;; (declare chunked-seq)

;; (deftype PersistentVector [meta cnt shift root tail ^:mutable __hash]
;;   IStack
;;   (-peek [coll]
;;     (when (> cnt 0)
;;       (-nth coll (dec cnt))))

(define (pv-last pv)
  (let ((cnt (pv-cnt pv)))
    (if (zero? cnt)
        (error "Can't access last element of empty vector")
        (pv-ref pv (- cnt 1)))))

;;   (-pop [coll]
;;     (cond
;;      (zero? cnt) (throw (js/Error. "Can't pop empty vector"))
;;      (== 1 cnt) (-with-meta cljs.core.PersistentVector/EMPTY meta)
;;      (< 1 (- cnt (tail-off coll)))
;;       (PersistentVector. meta (dec cnt) shift root (.slice tail 0 -1) nil)
;;       :else (let [new-tail (array-for coll (- cnt 2))
;;                   nr (pop-tail coll shift root)
;;                   new-root (if (nil? nr) cljs.core.PersistentVector/EMPTY_NODE nr)
;;                   cnt-1 (dec cnt)]
;;               (if (and (< 5 shift) (nil? (pv-aget new-root 1)))
;;                 (PersistentVector. meta cnt-1 (- shift 5) (pv-aget new-root 0) new-tail nil)
;;                 (PersistentVector. meta cnt-1 shift new-root new-tail nil)))))

(define (pv-pop pv)
  (let ((cnt (pv-cnt pv)))
    (cond
     ((zero? cnt)
      (error "Can't pop empty vector"))
     ((= 1 cnt)
      +empty-vector+)
     ((< 1 (- cnt (tail-off pv)))
      (make-pv (- cnt 1)
               (pv-shift pv)
               (pv-root pv)
               (vector-copy (pv-tail pv) -2)))
     (else
      (let* ((new-tail (vector-for pv (- cnt 2)))
             (nr (pop-tail pv (pv-shift pv) (pv-root pv)))
             (new-root (or nr +empty-vector+))
             (cnt-1 (- cnt 1)))
        (if (and (< 5 (pv-shift pv)) (not (pv-aget new-root 1)))
            (make-pv cnt-1 (- (pv-shift pv) 5) (pv-aget new-root 0) new-tail)
            (make-pv cnt-1 (pv-shift pv) new-root new-tail)))))))

;;   ICollection
;;   (-conj [coll o]
;;     (if (< (- cnt (tail-off coll)) 32)
;;       (let [new-tail (aclone tail)]
;;         (.push new-tail o)
;;         (PersistentVector. meta (inc cnt) shift root new-tail nil))
;;       (let [root-overflow? (> (bit-shift-right-zero-fill cnt 5) (bit-shift-left 1 shift))
;;             new-shift (if root-overflow? (+ shift 5) shift)
;;             new-root (if root-overflow?
;;                        (let [n-r (pv-fresh-node nil)]
;;                            (pv-aset n-r 0 root)
;;                            (pv-aset n-r 1 (new-path nil shift (VectorNode. nil tail)))
;;                            n-r)
;;                        (push-tail coll shift root (VectorNode. nil tail)))]
;;         (PersistentVector. meta (inc cnt) new-shift new-root (array o) nil))))

(define (pv-conj pv o)
  (let ((cnt (pv-cnt pv))
        (tail (pv-tail pv))
        (shift (pv-shift pv))
        (root (pv-root pv)))
    (if (< (- cnt (tail-off pv)) 32)
        (let ((new-tail (vector-copy tail -1 (make-vector (+ 1 (vector-length tail))))))
          (vector-set! new-tail (- (vector-length new-tail) 1) o)
          (make-pv (+ cnt 1) shift root new-tail))
        (let* ((root-overflow? (> (arithmetic-shift-right/zero-fill cnt 5)
                                  (arithmetic-shift 1 shift)))
               (new-shift (if root-overflow? (+ shift 5) shift))
               (new-root (if root-overflow?
                             (let ((n-r (pv-fresh-node #f)))
                               (pv-aset n-r 0 root)
                               (pv-aset n-r 1 (new-path #f shift (make-pv-node #f tail)))
                               n-r)
                             (push-tail pv shift root (make-pv-node #f tail)))))
          (make-pv (+ cnt 1) new-shift new-root (vector o))))))

;;   ISeqable
;;   (-seq [coll]
;;     (if (zero? cnt)
;;       nil
;;       (chunked-seq coll 0 0)))

;;   ICounted
;;   (-count [coll] cnt)

(define (pv-length pv)
  (pv-cnt pv))

;;   IIndexed
;;   (-nth [coll n]
;;     (aget (array-for coll n) (bit-and n 0x01f)))
;;   (-nth [coll n not-found]
;;     (if (and (<= 0 n) (< n cnt))
;;       (-nth coll n)
;;       not-found))

;; IAssociative
;; (-assoc [coll k v]
;;     (cond
;;        (and (<= 0 k) (< k cnt))
;;        (if (<= (tail-off coll) k)
;;          (let [new-tail (aclone tail)]
;;            (aset new-tail (bit-and k 0x01f) v)
;;            (PersistentVector. meta cnt shift root new-tail nil))
;;          (PersistentVector. meta cnt shift (do-assoc coll shift root k v) tail nil))
;;        (== k cnt) (-conj coll v)
;;        :else (throw (js/Error. (str "Index " k " out of bounds  [0," cnt "]")))))

(define (pv-assoc pv k v)
  (let ((cnt (pv-cnt pv))
        (shift (pv-shift pv))
        (root (pv-root pv))
        (tail (pv-tail pv)))
    (cond ((and (<= 0 k) (< k cnt))
           (if (<= (tail-off pv) k)
               (let ((new-tail (vector-copy tail)))
                 (vector-set! new-tail (bitwise-and k #x01f) v)
                 (make-pv cnt shift root new-tail))
               (make-pv cnt shift (do-assoc pv shift root k v) tail)))
          ((= k cnt) (pv-conj pv v))
          (else (error "Index out of bounds" k cnt)))))

(define pv-ref
  (case-lambda
   ((pv n)
    (vector-ref (vector-for pv n) (bitwise-and n #x01f)))
   ((pv n not-found)
    (if (and (<= 0 n) (< n (pv-cnt pv)))
        (pv-ref pv n)
        not-found))))

(define (list->pvector lst)
  (let loop ((pv +empty-vector+) (lst lst))
    (if (null? lst)
        pv
        (loop (pv-conj pv (car lst)) (cdr lst)))))

(define (pvector . args)
  (list->pvector args))

(define (pvector->list pv)
  (let ((len (pv-length pv)))
    (let loop ((pv pv) (i 0))
      (if (= i len)
          '()
          (cons (pv-ref pv i) (loop pv (+ i 1)))))))


(define-record-printer (pv pv out)
  (display "#<pvector " out)
  (write (pvector->list pv) out)
  (display ">" out))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.