summaryrefslogtreecommitdiff
path: root/starling/ring-buffer.scm
diff options
context:
space:
mode:
Diffstat (limited to 'starling/ring-buffer.scm')
-rw-r--r--starling/ring-buffer.scm81
1 files changed, 81 insertions, 0 deletions
diff --git a/starling/ring-buffer.scm b/starling/ring-buffer.scm
new file mode 100644
index 0000000..2b67f78
--- /dev/null
+++ b/starling/ring-buffer.scm
@@ -0,0 +1,81 @@
+(define-module (starling ring-buffer)
+ #:use-module (srfi srfi-9)
+ #:export (make-ring-buffer
+ ring-buffer
+ ring-buffer-length
+ ring-buffer-put!
+ ring-buffer-get!
+ ring-buffer-ref))
+
+(define-record-type <ring-buffer>
+ (%make-ring-buffer vector length head tail)
+ ring-buffer?
+ (vector ring-buffer-vector)
+ (length ring-buffer-length set-ring-buffer-length!)
+ (head ring-buffer-head set-ring-buffer-head!)
+ (tail ring-buffer-tail set-ring-buffer-tail!))
+
+(define (make-ring-buffer size)
+ (%make-ring-buffer (make-vector size #f) 0 0 0))
+
+(define (ring-buffer-empty? ring)
+ (zero? (ring-buffer-length ring)))
+
+(define (ring-buffer-put! ring x)
+ (let* ((head (ring-buffer-head ring))
+ (tail (ring-buffer-tail ring))
+ (l (ring-buffer-length ring))
+ (v (ring-buffer-vector ring))
+ (vl (vector-length v)))
+ (vector-set! v tail x)
+ (set-ring-buffer-length! ring (min (+ l 1) vl))
+ (when (and (> l 0) (= head tail))
+ (set-ring-buffer-head! ring (modulo (+ head 1) vl)))
+ (set-ring-buffer-tail! ring (modulo (+ tail 1) vl))))
+
+(define (ring-buffer-get! ring)
+ (if (ring-buffer-empty? ring)
+ (error "ring buffer empty" ring)
+ (let* ((head (ring-buffer-head ring))
+ (v (ring-buffer-vector ring))
+ (result (vector-ref v head)))
+ (vector-set! v head #f)
+ (set-ring-buffer-head! ring (modulo (+ head 1) (vector-length v)))
+ (set-ring-buffer-length! ring (- (ring-buffer-length ring) 1))
+ result)))
+
+(define (ring-buffer-ref ring i)
+ (let ((l (ring-buffer-length ring))
+ (v (ring-buffer-vector ring)))
+ (if (>= i l)
+ (error "ring buffer index out of bounds" i)
+ (vector-ref v (modulo (+ (ring-buffer-head ring) i)
+ (vector-length v))))))
+
+;; (define (test)
+;; (define (do-test ring)
+;; (ring-buffer-put! ring 'h)
+;; (pk ring)
+;; (ring-buffer-put! ring 'e)
+;; (pk ring)
+;; (ring-buffer-put! ring 'l)
+;; (pk ring)
+;; (ring-buffer-put! ring 'l)
+;; (pk ring)
+;; (ring-buffer-put! ring 'o)
+;; (pk ring)
+;; (ring-buffer-put! ring 'w)
+;; (pk ring)
+;; (ring-buffer-put! ring 'o)
+;; (pk ring)
+;; (ring-buffer-put! ring 'r)
+;; (pk ring)
+;; (ring-buffer-put! ring 'l)
+;; (pk ring)
+;; (ring-buffer-put! ring 'd)
+;; (pk ring)
+;; (pk (ring-buffer-get! ring) (ring-buffer-get! ring) (ring-buffer-get! ring) (ring-buffer-get! ring))
+;; (pk ring))
+;; (let ((ring (make-ring-buffer 4)))
+;; (do-test ring)
+;; (do-test ring)))