25189bfa3dc9 — Linus Bj√∂rnstam 1 year, 7 months ago
First commit!
3 files changed, 708 insertions(+), 0 deletions(-)

A => LICENSE
A => fector.scm
A => readme.md
A => LICENSE +46 -0
@@ 0,0 1,46 @@ 
+# Blue Oak Model License
+Version 1.0.0
+
+## Purpose
+This license gives everyone as much permission to work with
+this software as possible, while protecting contributors
+from liability.
+
+## Acceptance
+In order to receive this license, you must agree to its
+rules.  The rules of this license are both obligations
+under that agreement and conditions to your license.
+You must not do anything with this software that triggers
+a rule that you cannot or will not follow.
+
+## Copyright
+Each contributor licenses you to do everything with this
+software that would otherwise infringe that contributor's
+copyright in it.
+
+## Notices
+You must ensure that everyone who gets a copy of
+any part of this software from you, with or without
+changes, also gets the text of this license or a link to
+<https://blueoakcouncil.org/license/1.0.0>.
+
+## Excuse
+If anyone notifies you in writing that you have not
+complied with Notices, you can keep your
+license by taking all practical steps to comply within 30
+days after the notice.  If you do not do so, your license
+ends immediately.
+
+## Patent
+Each contributor licenses you to do everything with this
+software that would otherwise infringe any patent claims
+they can license or become able to license.
+
+## Reliability
+No contributor can revoke this license.
+
+## No Liability
+***As far as the law allows, this software comes as is,
+without any warranty or condition, and no contributor
+will be liable to anyone for any damages related to this
+software or this license, under any kind of legal claim.***
  No newline at end of file

          
A => fector.scm +635 -0
@@ 0,0 1,635 @@ 
+;; Fectors, functional vectors
+;; Copyright 2019 Andy Wingo
+;; Licensed under the Blue Oak Model license 1.0.0 (see the file LICENSE)
+;;
+;; A functional vector.
+;; It uses 32-way trees to represent the fector, which means that the tree will never
+;; become very deep, making lookups what you call "effectively O(1)". This is like
+;; the persistent vectors of clojure. A fector-set or fector-push operation returns
+;; a new fector, with the paths to whatever value set copied, meaning the original
+;; fector is never edited. For batch operations, it provides transient fectors, that
+;; speed up operations by doing the updates in place.
+
+(define-module (fector)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 match)
+  #:export (fector?
+	          transient-fector?
+	          transient-fector
+	          persistent-fector
+	          empty-fector
+            fector
+	          make-fector
+	          fector-length
+	          fector-ref
+	          fector-set
+	          fector-set!
+	          fector-push
+	          fector-push!
+	          fector-pop
+	          fector-pop!
+	          fector-fold
+	          fector-fold-right
+
+            build-fector
+            fector-map
+            fector-map!
+            fector-filter
+            fector-filter-map
+            fector-append
+
+            fector->list
+            list->fector
+            fector->vector
+            vector->fector
+            ))
+
+(define-syntax-rule (define-inline name val)
+  (define-syntax name (identifier-syntax val)))
+
+;; FIXME: This should make an actual atomic reference.
+(define-inlinable (make-atomic-reference value)
+  (list value))
+(define-inlinable (get-atomic-reference reference)
+  (car reference))
+(define-inlinable (set-atomic-reference! reference value)
+  (set-car! reference value))
+
+(define-inline *branch-bits* 5)
+(define-inline *branch-size* (ash 1 *branch-bits*))
+(define-inline *branch-size-with-edit* (1+ *branch-size*))
+(define-inline *edit-index* *branch-size*)
+(define-inline *branch-mask* (1- *branch-size*))
+
+(define-record-type <fector>
+  (make-fector length shift root tail)
+  fector?
+  (length %fector-length)
+  (shift fector-shift)
+  (root fector-root)
+  (tail fector-tail))
+
+(define-record-type <transient-fector>
+  (make-transient-fector length shift root tail edit)
+  transient-fector?
+  (length transient-fector-length set-transient-fector-length!)
+  (shift transient-fector-shift set-transient-fector-shift!)
+  (root transient-fector-root set-transient-fector-root!)
+  (tail transient-fector-tail set-transient-fector-tail!)
+  (edit transient-fector-edit set-transient-fector-edit!))
+
+;; Returns the number of values stored in @var{fector}. Works for both fectors and transient fectors
+(define (fector-length fector)
+  (match fector
+    (($ <fector> length) length)
+    (($ <transient-fector> length) length)))
+
+(define-inlinable (new-branch edit)
+  (let ((vec (make-vector *branch-size-with-edit* #f)))
+    (when edit (vector-set! vec *edit-index* edit))
+    vec))
+(define (clone-branch-and-set branch i elt)
+  (let ((new (vector-copy branch)))
+    (vector-set! new i elt)
+    new))
+(define-inlinable (assert-readable! root-edit)
+  (unless (eq? (get-atomic-reference root-edit) (current-thread))
+    (error "Transient fector owned by another thread" root-edit)))
+(define-inlinable (writable-branch branch root-edit)
+  (let ((edit (vector-ref branch *edit-index*)))
+    (if (eq? root-edit edit)
+        branch
+        (clone-branch-and-set branch *edit-index* root-edit))))
+
+(define-inlinable (round-down min shift)
+  (logand min (lognot (1- (ash 1 shift)))))
+
+(define-inlinable (compute-tail-offset length)
+  (if (< length *branch-size*)
+      0
+      (logand (1- length) (lognot *branch-mask*))))
+
+(define-inlinable (compute-tail-length length)
+  (- length (compute-tail-offset length)))
+
+(define *empty-branch* (new-branch #f))
+
+;; An empty fector for use when building fectors, for example as the seed variable in fector-fold.
+(define empty-fector (make-fector 0 *branch-bits* *empty-branch* #()))
+
+
+
+;; Returns a transient fector that supports in-place updates.
+;; The default @{source} is empty-fector. If @{source} is not transient
+;; any leaf nodes in the fector will be copied before updated and the source
+;; will be left unedited.
+(define* (transient-fector #:optional (source empty-fector))
+  (match source
+    (($ <transient-fector> length shift root tail edit)
+     (assert-readable! edit)
+     source)
+    (($ <fector> length shift root tail)
+     (let* ((edit (make-atomic-reference (current-thread)))
+	          (tail* (new-branch edit)))
+       (vector-move-left! tail 0 (vector-length tail) tail* 0)
+       (make-transient-fector length shift root tail* edit)))))
+
+
+;; Makes a transient fector persistent again, disallowing any in-place edits.
+;; Calling fector-set! or transient-fector on the fector returned by persistent-fector
+;; will return a new transient fector and will not change anything in the fector.
+(define* (persistent-fector #:optional (source empty-fector))
+  (match source
+    (($ <transient-fector> length shift root tail edit)
+     (assert-readable! edit)
+     ;; Make a fresh reference, causing any further operations on this
+     ;; transient to clone its root afresh.
+     (set-transient-fector-edit! source
+                                 (make-atomic-reference (current-thread)))
+     ;; Clear the reference to the current thread, causing our edited
+     ;; data structures to be persistent again.
+     (set-atomic-reference! edit #f)
+     (let* ((tail-length (compute-tail-length length))
+	    (tail* (make-vector tail-length #f)))
+       (vector-move-left! tail 0 tail-length tail* 0)
+       (make-fector length shift root tail)))
+    (($ <fector>)
+     source)))
+
+
+;; Updates the value at index @var{i} in @{fector} to @var{val}.
+;; If fector is transient, it will do an in-place update, otherwise it will create a new transient fector
+;; and update that in place. Returns the updated transient fector.
+(define (fector-set! fector i val)
+  (define (update-tree! shift root)
+    (let* ((shift (- shift *branch-bits*))
+	         (idx (logand (ash i (- shift)) *branch-mask*)))
+      (if (zero? shift)
+	        (vector-set! root idx val)
+	        (let* ((edit (vector-ref root *edit-index*))
+		             (branch (vector-ref root idx))
+		             (branch* (writable-branch branch edit)))
+	          (unless (eq? branch branch*)
+	            (vector-set! root idx branch*))
+	          (update-tree! shift branch*)))))
+  (match fector
+    (($ <transient-fector> length shift root tail edit)
+     (assert-readable! edit)
+     (unless (and (< 0 i) (< i length))
+       (error "index out of range" i))
+     (let ((tail-offset (compute-tail-offset length)))
+       (cond
+	      ((<= tail-offset i)
+	       (vector-set! tail (- i tail-offset) val))
+	      (else
+	       (let ((root* (writable-branch root edit)))
+	         (unless (eq? root root*)
+	           (set-transient-fector-root! fector root*))
+	         (update-tree! shift root*)))))
+     fector)
+    (($ <fector>)
+     (fector-set! (transient-fector fector) i val))))
+
+;; Returns a new persistent fector with the value of @var{fector} at index @var{i} changed to @{val}.
+(define (fector-set fector i val)
+  (define (update-tree shift root)
+    (let* ((shift (- shift *branch-bits*))
+	   (idx (logand (ash i (- shift)) *branch-mask*))
+	   (node (if (zero? shift)
+		     val
+		     (update-tree shift (vector-ref root idx)))))
+      (clone-branch-and-set root idx node)))
+  (match fector
+    (($ <fector> length shift root tail)
+     (unless (and (< 0 i) (< i length))
+       (error "index out of range" i))
+     (let ((tail-offset (compute-tail-offset length)))
+       (cond
+	((<= tail-offset i)
+	 (let ((new-tail (vector-copy tail)))
+	   (vector-set! new-tail (- i tail-offset) val)
+	   (make-fector length shift root new-tail)))
+	(else
+	 (make-fector length shift (update-tree shift root) tail)))))
+    (($ <transient-fector>)
+     (fector-set (persistent-fector fector) i val))))
+
+;; Pushes @var{val} to the end of @{fector}. If fector is persistent, a new transient fector is created.
+;; Returns a transient fector.
+;; @example
+;; (define f (fector 1 2 3))
+;; (define f2 (fector-push! 4))
+;; (fector-push! f2 5)
+;; f ;; => [1 2 3]
+;; f2 ;; => [1 2 3 4 5]
+;; @end example
+(define (fector-push! fector val)
+  (define (add-tail! i shift root tail)
+    (let* ((shift (- shift *branch-bits*))
+	   (idx (logand (ash i (- shift)) *branch-mask*)))
+      (if (= shift *branch-bits*)
+	  (vector-set! root idx tail)
+	  (let* ((branch (vector-ref root idx))
+		 (edit (vector-ref root *edit-index*))
+		 (branch* (if branch
+			      (writable-branch branch edit)
+			      (new-branch edit))))
+	    (unless (eq? branch branch*)
+	      (vector-set! root idx branch*))
+	    (add-tail! i shift branch* tail)))))
+  (match fector
+    (($ <transient-fector> length shift root tail edit)
+     (assert-readable! edit)
+     (let* ((tail-length (compute-tail-length length)))
+       (cond
+	((< tail-length *branch-size*)
+	 ;; Normal case: just add to the tail.
+	 (vector-set! tail tail-length val))
+	(else
+	 ;; Tail array is full; push into tree.
+	 (cond
+	  ((= length *branch-size*)
+	   ;; The tail becomes the first root.
+	   (set-transient-fector-root! fector tail))
+	  ((= length (+ (ash 1 shift) *branch-size*))
+	   ;; Tree is full; add a level.
+	   (let ((root* (new-branch edit))
+		 (shift* (+ shift *branch-bits*)))
+	     (vector-set! root* 0 root)
+	     (set-transient-fector-root! fector root*)
+	     (set-transient-fector-shift! fector shift*)
+	     (add-tail! (- length *branch-size*) shift* root* tail)))
+	  (else
+	   (let ((root* (writable-branch root edit)))
+	     (unless (eq? root root*)
+	       (set-transient-fector-root! fector root*))
+	     (add-tail! (- length *branch-size*) shift root* tail))))
+	 ;; Make a fresh tail and add the pushed val.
+	 (let ((tail (new-branch edit)))
+	   (set-transient-fector-tail! fector tail)
+	   (vector-set! tail 0 val)))))
+     (set-transient-fector-length! fector (1+ length))
+     fector)
+    (($ <fector>)
+     (fector-push! (transient-fector fector) val))))
+
+;; Returns a new persistent fector with value pushed to the end.
+;; @example
+;; (define f (fector 1)
+;; f ;; => [1]
+;; (fector-push f 2) ;; => [1 2]
+;; f ;; => [1]
+;; @end example
+(define (fector-push fector val)
+  (define (add-tail i shift root tail)
+    (let* ((shift (- shift *branch-bits*))
+	   (idx (logand (ash i (- shift)) *branch-mask*))
+	   (branch (if (= shift *branch-bits*)
+		       tail
+		       (add-tail i shift
+				 (or (vector-ref root idx) (new-branch #f))
+				 tail))))
+      (clone-branch-and-set root idx branch)))
+  (match fector
+    (($ <fector> length shift root tail)
+     (let* ((tail-length (compute-tail-length length)))
+       (cond
+	((< tail-length *branch-size*)
+	 ;; Normal case: just add to the tail.
+	 (let ((new-tail (make-vector (1+ tail-length) #f)))
+	   (vector-move-left! tail 0 tail-length new-tail 0)
+	   (vector-set! new-tail tail-length val)
+	   (make-fector (1+ length) shift root new-tail)))
+	(else
+	 ;; Tail array is full; push into tree.  We have to copy the
+	 ;; tail, though, in order to add the trailing "edit" field.
+	 (let ((tail (let ((tail* (new-branch #f)))
+		       (vector-move-left! tail 0 *branch-size* tail* 0)
+		       tail*))
+	       (new-tail (new-branch #f)))
+	   ;; Go ahead and add the pushed value to the new tail.
+	   (vector-set! new-tail 0 val)
+	   (cond
+	    ((= length *branch-size*)
+	     ;; The tail becomes the first root.
+	     (make-fector (1+ length) shift tail new-tail))
+	    ((= length (+ (ash 1 shift) *branch-size*))
+	     ;; Tree is full; add a level.
+	     (let ((root* (new-branch #f))
+		   (shift* (+ shift *branch-bits*)))
+	       (vector-set! root* 0 root)
+	       (let ((root* (add-tail (ash 1 shift) shift* root* tail)))
+		 (make-fector (1+ length) shift* root* new-tail))))
+	    (else
+	     (let ((root (add-tail (- length *branch-size*) shift root tail)))
+	       (make-fector (1+ length) shift root new-tail)))))))))
+    (($ <transient-fector>)
+     (fector-push (persistent-fector fector) val))))
+
+;; If fector is transient, fector-pop! removes the last element in-place.
+;; otherwise it returns a new transient fector with the last element removed.
+;; Returns a transient fector.
+(define (fector-pop! fector)
+  (define (pop-tail! i shift root)
+    (let* ((shift (- shift *branch-bits*))
+	   (idx (logand (ash i (- shift)) *branch-mask*)))
+      (if (= shift *branch-bits*)
+	  (let ((tail (vector-ref root idx)))
+	    (vector-set! root idx #f)
+	    tail)
+	  (let* ((branch (vector-ref root idx))
+		 (edit (vector-ref root *edit-index*))
+		 (branch* (writable-branch branch edit)))
+	    (unless (eq? branch branch*)
+	      (vector-set! root idx branch*))
+	    (pop-tail! i shift branch*)))))
+  (match fector
+    (($ <transient-fector> length shift root tail edit)
+     (assert-readable! edit)
+     (let* ((tail-length (compute-tail-length length)))
+       (cond
+	((< 1 tail-length)
+	 ;; Normal case: just clear the last entry in the tail.
+	 (when (zero? length)
+	   (error "can't pop from empty fector"))
+	 (vector-set! tail (1- tail-length) #f))
+	(else
+	 ;; Tail array will be empty; pop a tail from the tree.
+	 (cond
+	  ((= length (1+ *branch-size*))
+	   ;; The root becomes the tail.
+	   (set-transient-fector-tail! fector (writable-branch root edit))
+	   (set-transient-fector-root! fector *empty-branch*))
+	  ((= length (+ (ash 1 shift) *branch-size* 1))
+	   ;; Shrink the tree.
+	   (let ((tail (let lp ((branch (vector-ref root 1))
+				(shift (- shift *branch-bits*)))
+			 (if (= shift *branch-bits*)
+			     (writable-branch branch edit)
+			     (lp (vector-ref branch 0)
+				 (- shift *branch-bits*))))))
+	     (set-transient-fector-tail! fector tail)
+	     (set-transient-fector-root! fector (vector-ref root 0))
+	     (set-transient-fector-shift! fector (- shift *branch-bits*))))
+	  (else
+	   (let ((root* (writable-branch root edit)))
+	     (unless (eq? root root*)
+	       (set-transient-fector-root! fector root*))
+	     (let ((tail (pop-tail! (- length 1 *branch-size*) shift root*)))
+	       (set-transient-fector-tail! fector tail))))))))
+     (set-transient-fector-length! fector (1- length))
+     fector)
+    (($ <fector>)
+     (fector-pop! (transient-fector fector)))))
+
+;; Returns a persistent fector with the last element of @var{fector} removed.
+(define (fector-pop fector)
+  (define (pop-tail i shift root)
+    (let* ((shift (- shift *branch-bits*))
+	   (idx (logand (ash i (- shift)) *branch-mask*)))
+      (call-with-values (lambda ()
+			  (if (= shift *branch-bits*)
+			      (values #f (vector-ref root idx))
+			      (pop-tail i shift (vector-ref root idx))))
+	(lambda (branch tail)
+	  (values (clone-branch-and-set root idx branch)
+		  tail)))))
+  (match fector
+    (($ <fector> length shift root tail)
+     (let* ((tail-length (compute-tail-length length)))
+       (cond
+	((< 1 tail-length)
+	 ;; Normal case: just trim the tail.
+	 (when (zero? length)
+	   (error "can't pop from empty fector"))
+	 (let ((new-tail (make-vector (1- tail-length) #f)))
+	   (vector-move-left! tail 0 (1- tail-length) new-tail 0)
+	   (make-fector (1- length) shift root new-tail)))
+	(else
+	 ;; Tail array will be empty; pop a tail from the tree.
+	 (cond
+	  ((= length (1+ *branch-size*))
+	   ;; The root becomes the tail.
+	   (make-fector *branch-size* *branch-bits* *empty-branch* root))
+	  ((= length (+ (ash 1 shift) *branch-size* 1))
+	   ;; Shrink the tree.
+	   (let ((tail (let lp ((branch (vector-ref root 1))
+				(shift (- shift *branch-bits*)))
+			 (if (= shift *branch-bits*)
+			     branch
+			     (lp (vector-ref branch 0)
+				 (- shift *branch-bits*))))))
+	     (make-fector (1- length) (- shift *branch-bits*)
+			  (vector-ref root 0) tail)))
+	  (else
+	   (call-with-values (lambda ()
+			       (pop-tail (- length 1 *branch-size*) shift root))
+	     (lambda (root tail)
+	       (make-fector (1- length) shift root tail)))))))))
+    (($ <transient-fector>)
+     (fector-pop (persistent-fector fector)))))
+
+;; Gets the value @var{fector} at index @var{i}.
+(define (fector-ref fector i)
+  (define (ref length shift root tail)
+    (unless (< i length)
+      (error "index out of range" i))
+    (let ((tail-offset (compute-tail-offset length)))
+      (cond
+       ((<= tail-offset i) (vector-ref tail (- i tail-offset)))
+       (else
+	      (let lp ((shift shift) (root root))
+	        (let* ((shift (- shift *branch-bits*)))
+	          (if (zero? shift)
+		            (vector-ref root (logand i *branch-mask*))
+		            (let ((idx (logand (ash i (- shift)) *branch-mask*)))
+		              (lp shift (vector-ref root idx))))))))))
+  (match fector
+    (($ <fector> length shift root tail)
+     (ref length shift root tail))
+    (($ <transient-fector> length shift root tail edit)
+     (assert-readable! edit)
+     (ref length shift root tail))))
+
+;; Folds over @var{fector} from the left. @var{f} is a procedure that takes three arguments (index, value and result)
+;; and returns a new result that will be passed on as the result to the next invocation of @var{f}. @var{seed} is the
+;; result argument that will be used for the first invocation of @var{f}.
+(define (fector-fold f fector seed)
+  (define (visit-branch branch start end shift seed)
+    (let* ((shift (- shift *branch-bits*))
+	   (end-idx (ash (- end start 1) (- shift)))
+	   (inc (ash 1 shift)))
+      (let lp ((i 0) (start start) (seed seed))
+        (let ((node (vector-ref branch i)))
+          (if (< i end-idx)
+              (lp (1+ i)
+                  (+ start inc)
+                  (if (= shift *branch-bits*)
+                      (visit-leaf node start seed)
+                      (visit-branch node start (+ start inc) shift seed)))
+              (if (= shift *branch-bits*)
+                  (visit-leaf node start seed)
+                  (visit-branch node start end shift seed)))))))
+  (define (visit-leaf leaf start seed)
+    (let lp ((n 0) (seed seed))
+      (if (< n *branch-size*)
+	        (lp (1+ n) (f (+ start n) (vector-ref leaf n) seed))
+	        seed)))
+
+  (match fector
+    (($ <fector> length shift root tail)
+     (let* ((tail-offset  (compute-tail-offset length))
+	          (seed (if (<= length *branch-size*)
+		                  seed
+		                  (if (= shift *branch-bits*)
+			                    (visit-leaf root 0 seed)
+			                    (visit-branch root 0 tail-offset shift seed)))))
+       (let ((tail-length (- length tail-offset)))
+	       (let lp ((n 0) (seed seed))
+	         (let ((idx (+ tail-offset n)))
+	           (if (= idx length)
+		             seed
+		             (lp (1+ n) (f idx (vector-ref tail n) seed))))))))
+    (($ <transient-fector>)
+     (fector-fold f (persistent-fector fector) seed))))
+
+;; Same as fector-fold, but starts from the back of the fector.
+(define (fector-fold-right f fector seed)
+  (define (visit-branch branch start end shift seed)
+    (let* ((shift (- shift *branch-bits*))
+	         (end-idx (ash (- end start 1) (- shift)))
+	         (inc (ash 1 shift)))
+      (let lp ((i end-idx)
+               (end (+ start (* end-idx inc)))
+               (seed (let ((node (vector-ref branch end-idx))
+                           (start (+ start (* end-idx inc))))
+                       (if (= shift *branch-bits*)
+                           (visit-leaf node start seed)
+                           (visit-branch node start end shift seed)))))
+	      (if (zero? i)
+	          seed
+	          (let ((i (1- i)))
+	            (let ((node (vector-ref branch i))
+		                (start (- end inc)))
+		            (lp i
+		                start
+		                (if (= shift *branch-bits*)
+			                  (visit-leaf node start seed)
+			                  (visit-branch node start end shift seed)))))))))
+  (define (visit-leaf leaf start seed)
+    (let lp ((n *branch-size*) (seed seed))
+      (if (zero? n)
+	        seed
+	        (let ((n (1- n)))
+	          (lp n (f (+ start n) (vector-ref leaf n) seed))))))
+  (match fector
+    (($ <fector> length shift root tail)
+     (let* ((tail-offset (compute-tail-offset length)))
+       (let lp ((i (1- length)) (seed seed))
+	       (if (<= tail-offset i)
+	           (lp (1- i) (f i (vector-ref tail (- i tail-offset)) seed))
+	           (if (<= length *branch-size*)
+		             seed
+		             (if (= shift *branch-bits*)
+		                 (visit-leaf root 0 seed)
+		                 (visit-branch root 0 tail-offset shift seed)))))))
+    (($ <transient-fector>)
+     (fector-fold-right f (persistent-fector fector) seed))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; constructors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Returns a persistent fector containing @{elements} in order
+(define (fector . elements)
+  (let loop ((f (transient-fector)) (elements elements))
+    (if (null? elements)
+        (persistent-fector f)
+        (loop (fector-push! f (car elements)) (cdr elements)))))
+
+;; Build a fector of @var{n} elements where the value of each index is (@var{proc} index)
+(define (build-fector n proc)
+  (let loop ((t (transient-fector)) (i 0))
+    (if (= n i)
+        (persistent-fector t)
+        (loop (fector-push t (proc i)) (1+ i)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; mapping and filtering
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; Applies @var{proc} to every value of @var{fector} and returns a new persistent vector.
+(define (fector-map proc fector)
+  (fector-fold (lambda (index value result) (fector-push! result (proc value)))
+               fector
+               (transient-fector)))
+
+;; Applies @var{proc} to every value of @var{fector} updating it in-place where possible.
+;; This can sometimes be faster than fector-map if you have already built a transient vector and want to map over it.
+(define (fector-map! proc fector)
+  (fector-fold (lambda (index value result) (fector-set! result index (proc value)))
+               fector
+               (transient-fector fector)))
+
+;; Returns a new fector with the elements of @var{fector} that satisfies @var{pred}.
+(define (fector-filter pred fector)
+  (define (f index value result)
+    (if (pred value)
+        (fector-push! result value)
+        result))
+  (persistent-fector (fector-fold f fector (transient-fector))))
+
+;; Like fector-map, but only values for which @var{proc} that return truthy are saved.
+(define (fector-filter-map proc fector)
+  (define (f index value result)
+    (let ((temp (proc value)))
+      (if temp
+          (fector-push! result value)
+          result)))
+  (persistent-fector (fector-fold f fector (transient-fector))))
+
+;; Returns a new persistent fector with the values of @var{f2} to @var{f}
+(define (fector-append f f2)
+  (persistent-fector (fector-fold (lambda (index value result) (fector-push! result value)) f2 (transient-fector f))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Conversion
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Returns a list with the same elements as the fector @var{f}
+(define (fector->list f)
+  (fector-fold-right (lambda (key value result) (cons value result)) f '()))
+
+;; Returns a fector with the same elements as @var{l}
+(define (list->fector l)
+  (let loop ((f (transient-fector)) (l l))
+    (if (null? l)
+        (persistent-fector f)
+        (loop (fector-push! f (car l)) (cdr l)))))
+
+;; Returns a vector with the same elements as the fector @var{f}
+(define (fector->vector f)
+  (define vec (make-vector (fector-length f)))
+  (fector-fold (lambda (index value result) (vector-set! vec index value)) f #f)
+  vec)
+
+;; Returns a fector with the same elements as the vector @var{vec}
+(define (vector->fector vec)
+  (let loop ((f (transient-fector)) (i 0))
+    (if (= i (vector-length vec))
+        (persistent-fector f)
+        (loop (fector-push! f (vector-ref vec i))
+              (1+ i)))))
+
+(define (benchmark-persistent-append count)
+  (let lp ((n 0) (fec empty-fector))
+    (if (< n count)
+	(lp (1+ n) (fector-push fec n))
+	fec)))
+
+(define (benchmark-transient-append count)
+  (let lp ((n 0) (fec empty-fector))
+    (if (< n count)
+	(lp (1+ n) (fector-push! fec n))
+	(persistent-fector fec))))

          
A => readme.md +27 -0
@@ 0,0 1,27 @@ 
+# guile-fector - Persistent vectors for guile
+This is a guile implementation of persistent vectors for guile. They are really nifty little data structures that do amortized O(1) pushes, and "effectively o(1)" (as in log32) set and get. To speed things up this little library provides a transient interface which updates the fectors in-place. 
+
+## Credit where it's due
+This was written by [Andy Wingo](http://www.wingolog.org), and I got his permission to work with the codebase. I added some convenience procedures over fector-fold, and found two small bugs. 
+
+## Documentation
+Currently there is no documentation since I can't make guild doc-snarf to extract my documentation comments, but if you look in the file fector.scm you will find that all exported procedures have a small description.
+
+## Example
+Just a short example demonstrating general gist of things:
+
+    (import (fector))
+    (define f (fector 1 2 3 4))
+    (fector-set f 0 5) ;; => [5 2 3 4]
+    f ;; => [1 2 3 4]
+    (define t (transient-fector f))
+    (fector-set! t 0 5)
+    (fector-push! t 5)
+    t ;; => [5 2 3 4 5]
+    
+
+## Speed
+In my unscientific benchmarking fectors are faster than (ice-9 vlist) at everything except random access. Both building and iterating through fectors is about 2x faster, but random access is about 2x slower. This might be a little bit due to the dispatching code of fector-ref, but probably mostly due to that the vlist-ref is simply faster due to the data structure being simpler.
+
+## License
+Andy asked me to use the Blue Oak Model license 1.0, which is a permissive license with a patent grant. The license text is available in the LICENSE file and at this web address: https://blueoakcouncil.org/license/1.0.0