Commits

Moritz Heidkamp  committed 6e1b734

PV version 1!!

  • Participants
  • Parent commits 8645d2f
  • Branches pv

Comments (0)

Files changed (1)

File clojurian-vector.scm

 (define (vector-copy vec #!optional (count (vector-length vec)) copy)
   (let* ((count (if (positive? count)
                     count
-                    (+ (vector-length vec) count)))
+                    (+ (vector-length vec) count 1)))
          (copy (or copy (make-vector count))))
     (vector-copy! vec copy count)
     copy))
 
 ;; deftype PersistentVector [meta cnt shift root tail ^:mutable __hash]
 (define-record pv
-  cnt shift root tail tail-next)
+  cnt shift root tail)
 
 ;; (defn- pv-fresh-node [edit]
 ;;   (VectorNode. edit (make-array 32)))
   (pv-fresh-node #f))
 
 (define +empty-vector+
-  (make-pv 0 5 +empty-node+ (make-vector 32) 0))
+  (make-pv 0 5 +empty-node+ (vector)))
 
 
 ;; (defn- pv-aget [node idx]
 ;;   (VectorNode. (.-edit node) (aclone (.-arr node))))
 (define (pv-clone-node node)
   (make-pv-node (pv-node-edit node)
-                (vector-copy (pv-node-arr node))))
+                    (vector-copy (pv-node-arr node))))
 
 
 ;; (defn- 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)))
+               (vector-copy (pv-tail pv) -2)))
      (else
       (let* ((new-tail (array-for pv (- cnt 2)))
              (nr (pop-tail pv (pv-shift pv) (pv-root 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)
+        (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)))
 ;;       (-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)
     (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))