Commits

Moritz Heidkamp  committed 8645d2f

PV initial commit

  • Participants
  • Parent commits f64e1f2
  • Branches pv

Comments (0)

Files changed (1)

File 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)))
+         (copy (or copy (make-vector count))))
+    (vector-copy! vec copy count)
+    copy))
+
+;; (deftype VectorNode [edit arr])
+
+(define-record pv-node
+  edit arr)
+
+;; deftype PersistentVector [meta cnt shift root tail ^:mutable __hash]
+(define-record pv
+  cnt shift root tail tail-next)
+
+;; (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+ (make-vector 32) 0))
+
+
+;; (defn- pv-aget [node idx]
+;;   (aget (.-arr node) idx))
+
+(define (pv-aget node idx)
+  (vector-ref (pv-node-arr node) idx))
+
+;; (defn- pv-aset [node idx val]
+;;   (aset (.-arr node) idx val))
+
+(define (pv-aset node idx val)
+  (vector-set! (pv-node-arr 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-arr 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 (array-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-arr 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) -1 (make-vector 32))
+               (pv-tail-next pv)))
+     (else
+      (let* ((new-tail (array-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)))
+          (pv-push new-tail 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))
+
+(define pv-ref
+  (case-lambda
+   ((pv n)
+    (vector-ref (array-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))))