adding (srfi 117)

lib/srfi/117.sld

@@ -0,0 +1,11 @@
+(define-library (srfi 117)
+  (import (scheme base) (srfi 1))
+  (export
+   make-list-queue list-queue list-queue-copy list-queue-unfold
+   list-queue-unfold-right list-queue? list-queue-empty?
+   list-queue-front list-queue-back list-queue-list list-queue-first-last
+   list-queue-add-front! list-queue-add-back! list-queue-remove-front!
+   list-queue-remove-back! list-queue-remove-all! list-queue-set-list!
+   list-queue-append list-queue-append! list-queue-concatenate
+   list-queue-map list-queue-map! list-queue-for-each)
+  (include "117/queue.scm"))

lib/srfi/117/queue.scm

@@ -0,0 +1,106 @@
+
+(define-record-type List-Queue
+  (make-queue list last)
+  list-queue?
+  (list list-queue-list list-queue-list-set!)
+  (last list-queue-last list-queue-last-set!))
+
+(define (make-list-queue ls . o)
+  (make-queue ls (if (pair? o) (car o) (if (pair? ls) (last-pair ls) '()))))
+
+(define (list-queue . ls)
+  (make-list-queue ls))
+
+(define (list-queue-copy list-queue)
+  (make-list-queue (list-copy (list-queue-list list-queue))))
+
+(define (list-queue-unfold stop? mapper successor seed . o)
+  (let ((ls (unfold stop? mapper successor seed)))
+    (if (pair? o)
+        (let ((queue (car o)))
+          (list-queue-set-list! queue (append ls (list-queue-list queue)))
+          queue)
+        (make-list-queue ls))))
+
+(define (list-queue-unfold-right stop? mapper successor seed . o)
+  (let ((ls (unfold-right stop? mapper successor seed)))
+    (if (pair? o)
+        (let ((queue (car o)))
+          (list-queue-set-list! queue (append (list-queue-list queue) ls))
+          queue)
+        (make-list-queue ls))))
+
+(define (list-queue-empty? list-queue)
+  (null? (list-queue-list list-queue)))
+
+(define (list-queue-front list-queue)
+  (car (list-queue-list list-queue)))
+
+(define (list-queue-back list-queue)
+  (car (list-queue-last list-queue)))
+
+(define (list-queue-first-last list-queue)
+  (values (list-queue-list list-queue) (list-queue-last list-queue)))
+
+(define (list-queue-add-front! list-queue element)
+  (list-queue-list-set! list-queue (cons element (list-queue-list list-queue)))
+  (if (null? (list-queue-last list-queue))
+      (list-queue-last-set! list-queue (list-queue-list list-queue))))
+
+(define (list-queue-add-back! list-queue element)
+  (let ((last (list-queue-last list-queue)))
+    (cond
+     ((pair? last)
+      (set-cdr! last (list element))
+      (list-queue-last-set! list-queue (cdr last)))
+     (else
+      (list-queue-list-set! list-queue (list element))
+      (list-queue-last-set! list-queue (list-queue-list list-queue))))))
+
+(define (list-queue-remove-front! list-queue)
+  (let ((ls (list-queue-list list-queue)))
+    (list-queue-list-set! list-queue (cdr ls))
+    (if (null? (cdr ls))
+        (list-queue-last-set! list-queue '()))
+    (car ls)))
+
+(define (list-queue-remove-back! list-queue)
+  (let ((ls (list-queue-list list-queue)))
+    (if (null? (cdr ls))
+        (car (list-queue-remove-all! list-queue))
+        (let lp ((head ls) (tail (cdr ls)))
+          (cond
+           ((null? (cdr tail))
+            (set-cdr! head '())
+            (car tail))
+           (else
+            (lp tail (cdr tail))))))))
+
+(define (list-queue-remove-all! list-queue)
+  (let ((res (list-queue-list list-queue)))
+    (list-queue-list-set! list-queue '())
+    (list-queue-last-set! list-queue '())
+    res))
+
+(define (list-queue-set-list! list-queue list . o)
+  (list-queue-list-set! list-queue list)
+  (list-queue-last-set! list-queue (if (pair? o) (car o) (last-pair list))))
+
+(define (list-queue-concatenate list-of-queues)
+  (make-list-queue (list-copy (append-map list-queue-list list-of-queues))))
+
+(define (list-queue-append . list-of-queues)
+  (list-queue-concatenate list-of-queues))
+
+(define (list-queue-append! . list-of-queues)
+  (make-list-queue (append-map list-queue-list list-of-queues)))
+
+(define (list-queue-map proc list-queue)
+  (make-list-queue (map proc (list-queue-list list-queue))))
+
+(define (list-queue-map! proc list-queue)
+  (list-queue-set-list! list-queue (map! proc (list-queue-list list-queue)))
+  list-queue)
+
+(define (list-queue-for-each proc list-queue)
+  (for-each proc (list-queue-list list-queue)))

lib/srfi/117/test.sld

@@ -0,0 +1,94 @@
+(define-library (srfi 117 test)
+  (import (scheme base) (srfi 117) (chibi test))
+  (export run-tests)
+  (begin
+    (define (run-tests)
+      (test-begin "list-queues")
+
+      (test-group "list-queues/simple"
+        (define x (list-queue 1 2 3))
+        (define x1 (list 1 2 3))
+        (define x2 (make-list-queue x1 (cddr x1)))
+        (define y (list-queue 4 5))
+        (define z (list-queue-append x y))
+        (define z2 (list-queue-append! x (list-queue-copy y)))
+        (test '(1 1 1) (list-queue-list (make-list-queue '(1 1 1))))
+        (test '(1 2 3) (list-queue-list x))
+        (test 3 (list-queue-back x2))
+        (test-assert (list-queue? y))
+        (test '(1 2 3 4 5) (list-queue-list z))
+        (test '(1 2 3 4 5) (list-queue-list z2))
+        (test 1 (list-queue-front z))
+        (test 5 (list-queue-back z))
+        (list-queue-remove-front! y)
+        (test '(5) (list-queue-list y))
+        (list-queue-remove-back! y)
+        (test-assert (list-queue-empty? y))
+        (test-error (list-queue-remove-front! y))
+        (test-error (list-queue-remove-back! y))
+        (test '(1 2 3 4 5) (list-queue-list z))
+        (test '(1 2 3 4 5) (list-queue-remove-all! z2))
+        (test-assert (list-queue-empty? z2))
+        (list-queue-remove-all! z)
+        (list-queue-add-front! z 1)
+        (list-queue-add-front! z 0)
+        (list-queue-add-back! z 2)
+        (list-queue-add-back! z 3)
+        (test '(0 1 2 3) (list-queue-list z)))
+
+      (test-group "list-queues/whole"
+        (define a (list-queue 1 2 3))
+        (define b (list-queue-copy a))
+        (test '(1 2 3) (list-queue-list b))
+        (list-queue-add-front! b 0)
+        (test '(1 2 3) (list-queue-list a))
+        (test 4 (length (list-queue-list b)))
+        (test '(1 2 3 0 1 2 3)
+            (list-queue-list (list-queue-concatenate (list a b)))))
+
+      (test-group "list-queues/map"
+        (define r (list-queue 1 2 3))
+        (define s (list-queue-map (lambda (x) (* x 10)) r))
+        (define sum 0)
+        (test '(10 20 30) (list-queue-list s))
+        (list-queue-map! (lambda (x) (+ x 1)) r)
+        (test '(2 3 4) (list-queue-list r))
+        (list-queue-for-each (lambda (x) (set! sum (+ sum x))) s)
+        (test 60 sum))
+
+      (test-group "list-queues/conversion"
+        (define n (list-queue 5 6))
+        (define d (list 1 2 3))
+        (define e (cddr d))
+        (define f (make-list-queue d e))
+        (define g (make-list-queue d e))
+        (define h (list-queue 5 6))
+        (define-values (dx ex) (list-queue-first-last f))
+        (list-queue-set-list! n (list 1 2))
+        (test '(1 2) (list-queue-list n))
+        (test-assert (eq? d dx))
+        (test-assert (eq? e ex))
+        (test '(1 2 3) (list-queue-list f))
+        (list-queue-add-front! f 0)
+        (list-queue-add-back! f 4)
+        (test '(0 1 2 3 4) (list-queue-list f))
+        (test '(1 2 3 4) (list-queue-list g))
+        (list-queue-set-list! h d e)
+        (test '(1 2 3 4) (list-queue-list h)))
+
+      (test-group "list-queues/unfold"
+        (define (double x) (* x 2))
+        (define (done? x) (> x 3))
+        (define (add1 x) (+ x 1))
+        (define x (list-queue-unfold done? double add1 0))
+        (define y (list-queue-unfold-right done? double add1 0))
+        (define x0 (list-queue 8))
+        (define x1 (list-queue-unfold done? double add1 0 x0))
+        (define y0 (list-queue 8))
+        (define y1 (list-queue-unfold-right done? double add1 0 y0))
+        (test '(0 2 4 6) (list-queue-list x))
+        (test '(6 4 2 0) (list-queue-list y))
+        (test '(0 2 4 6 8) (list-queue-list x1))
+        (test '(8 6 4 2 0) (list-queue-list y1)))
+
+      (test-end))))