Initial file

srfi/117.sld

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

srfi/list-queues/list-queues-impl.scm

@@ -0,0 +1,214 @@
+;;;; Implementation of list-queue SRFI
+
+;;; R7RS shims.  Comment these out on an R7RS system.
+;;; I stole this code from Chibi Scheme, which is BSD-licensed.
+
+(define (make-list n . o)
+  (let ((default (if (pair? o) (car o))))
+    (let lp ((n n) (res '()))
+      (if (<= n 0) res (lp (- n 1) (cons default res))))))
+
+(define (list-copy ls)
+  (let lp ((ls ls) (res '()))
+    (if (pair? ls)
+        (lp (cdr ls) (cons (car ls) res))
+        (append (reverse res) ls))))
+
+(define (list-set! ls k x)
+  (cond ((null? ls) (error "invalid list index"))
+        ((zero? k) (set-car! ls x))
+        (else (list-set! (cdr ls) (- k 1) x))))
+
+;;; This definition is from Chibi's SRFI-1 implementation.
+
+(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls))))
+
+;;; This definition of map! isn't fully SRFI-1 compliant, as it
+;;; handles only unary functions.  You can use SRFI-1's definition
+;;; if you want.
+
+(define (map! f lis)
+  (let lp ((lis lis))
+    (if (pair? lis)
+      (begin
+        (set-car! lis (f (car lis)))
+        (lp (cdr lis))))))
+
+;;; The list-queue record
+;;; The invariant is that either first is (the first pair of) a list
+;;; and last is the last pair, or both of them are the empty list.
+
+(define-record-type <list-queue> (raw-make-list-queue first last) list-queue?
+  (first get-first set-first!)
+  (last get-last set-last!))
+
+;;; Constructors
+
+(define make-list-queue
+  (case-lambda
+    ((list)
+     (if (null? list)
+       (raw-make-list-queue '() '())
+       (raw-make-list-queue list (last-pair list))))
+    ((list last)
+     (raw-make-list-queue list last))))
+
+(define (list-queue . objs)
+  (make-list-queue objs))
+
+(define (list-queue-copy list-queue)
+  (make-list-queue (list-copy (get-first list-queue))))
+
+;;; Predicates
+
+(define (list-queue-empty? list-queue)
+  (null? (get-first list-queue)))
+
+;;; Accessors
+
+(define (list-queue-front list-queue)
+  (if (list-queue-empty? list-queue)
+    (error "Empty list-queue")
+    (car (get-first list-queue))))
+
+(define (list-queue-back list-queue)
+  (if (list-queue-empty? list-queue)
+    (error "Empty list-queue")
+    (car (get-last list-queue))))
+
+;;; Mutators (which carefully maintain the invariant)
+
+(define (list-queue-add-front! list-queue elem)
+  (let ((new-first (cons elem (get-first list-queue))))
+    (if (list-queue-empty? list-queue)
+      (set-last! list-queue new-first))
+    (set-first! list-queue new-first)))
+
+(define (list-queue-add-back! list-queue elem)
+  (let ((new-last (list elem)))
+    (if (list-queue-empty? list-queue)
+      (set-first! list-queue new-last)
+      (set-cdr! (get-last list-queue) new-last))
+    (set-last! list-queue new-last)))
+
+(define (list-queue-remove-front! list-queue)
+  (if (list-queue-empty? list-queue)
+    (error "Empty list-queue"))
+  (let* ((old-first (get-first list-queue))
+         (elem (car old-first))
+         (new-first (cdr old-first)))
+    (if (null? new-first)
+      (set-last! list-queue '()))
+    (set-first! list-queue new-first)
+    elem))
+
+(define (list-queue-remove-back! list-queue)
+  (if (list-queue-empty? list-queue)
+    (error "Empty list-queue"))
+  (let* ((old-last (get-last list-queue))
+         (elem (car old-last))
+         (new-last (penult-pair (get-first list-queue))))
+    (if (null? new-last)
+      (set-first! list-queue '())
+      (set-cdr! new-last '()))
+    (set-last! list-queue new-last)
+    elem))
+
+(define (list-queue-remove-all! list-queue)
+   (let ((result (get-first list-queue)))
+      (set-first! list-queue '())
+      (set-last! list-queue '())
+      result))
+
+;; Return the next to last pair of lis, or nil if there is none
+
+(define (penult-pair lis)
+  (let lp ((lis lis))
+    (cond
+     ;((null? lis) (error "Empty list-queue"))
+      ((null? (cdr lis)) '())
+      ((null? (cddr lis)) lis)
+      (else (lp (cdr lis))))))
+
+;;; The whole list-queue
+
+
+;; Because append does not copy its back argument, we cannot use it
+(define (list-queue-append . list-queues)
+  (list-queue-concatenate list-queues))
+
+(define (list-queue-concatenate list-queues)
+  (let ((result (list-queue)))
+    (for-each
+      (lambda (list-queue)
+        (for-each (lambda (elem) (list-queue-add-back! result elem)) (get-first list-queue)))
+      list-queues)
+     result))
+
+(define list-queue-append!
+  (case-lambda
+    (() (list-queue))
+    ((queue) queue)
+    (queues
+      (for-each (lambda (queue) (list-queue-join! (car queues) queue))
+                (cdr queues))
+      (car queues))))
+
+; Forcibly join two queues, destroying the second
+(define (list-queue-join! queue1 queue2)
+  (set-cdr! (get-last queue1) (get-first queue2)))
+
+(define (list-queue-map proc list-queue)
+  (make-list-queue (map proc (get-first list-queue))))
+
+(define list-queue-unfold
+  (case-lambda
+    ((stop? mapper successor seed queue)
+     (list-queue-unfold* stop? mapper successor seed queue))
+    ((stop? mapper successor seed)
+     (list-queue-unfold* stop? mapper successor seed (list-queue)))))
+
+(define (list-queue-unfold* stop? mapper successor seed queue)
+  (let loop ((seed seed))
+    (if (not (stop? seed))
+      (list-queue-add-front! (loop (successor seed)) (mapper seed)))
+    queue))
+
+(define list-queue-unfold-right
+  (case-lambda
+    ((stop? mapper successor seed queue)
+     (list-queue-unfold-right* stop? mapper successor seed queue))
+    ((stop? mapper successor seed)
+     (list-queue-unfold-right* stop? mapper successor seed (list-queue)))))
+
+(define (list-queue-unfold-right* stop? mapper successor seed queue)
+  (let loop ((seed seed))
+    (if (not (stop? seed))
+      (list-queue-add-back! (loop (successor seed)) (mapper seed)))
+    queue))
+
+(define (list-queue-map! proc list-queue)
+  (map! proc (get-first list-queue)))
+
+(define (list-queue-for-each proc list-queue)
+  (for-each proc (get-first list-queue)))
+
+;;; Conversion
+
+(define (list-queue-list list-queue)
+  (get-first list-queue))
+
+(define (list-queue-first-last list-queue)
+  (values (get-first list-queue) (get-last list-queue)))
+
+(define list-queue-set-list!
+  (case-lambda
+    ((list-queue first)
+     (set-first! list-queue first)
+     (if (null? first)
+       (set-last! list-queue '())
+       (set-last! list-queue (last-pair first))))
+    ((list-queue first last)
+     (set-first! list-queue first)
+     (set-last! list-queue last))))
+

srfi/list-queues/list-queues-test.scm

@@ -0,0 +1,102 @@
+(cond-expand
+  (chicken (use test srfi-117))
+  (chibi (import (chibi test) (list-queues)))
+)
+
+(test-group "list-queues"
+
+(test-group "list-queues/simple"
+  (test '(1 1 1) (list-queue-list (make-list-queue '(1 1 1))))
+  (define x (list-queue 1 2 3))
+  (test '(1 2 3) (list-queue-list x))
+  (define x1 (list 1 2 3))
+  (define x2 (make-list-queue x1 (cddr x1)))
+  (test 3 (list-queue-back x2))
+  (define y (list-queue 4 5))
+  (test-assert (list-queue? y))
+  (define z (list-queue-append x y))
+  (test '(1 2 3 4 5) (list-queue-list z))
+  (define z2 (list-queue-append! x (list-queue-copy y)))
+  (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))
+) ; end list-queues/simple
+
+(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)))
+  (define c (list-queue-concatenate (list a b)))
+  (test '(1 2 3 0 1 2 3) (list-queue-list c))
+) ; end list-queues/whole
+
+(test-group "list-queues/map"
+  (define r (list-queue 1 2 3))
+  (define s (list-queue-map (lambda (x) (* x 10)) r))
+  (test '(10 20 30) (list-queue-list s))
+  (list-queue-map! (lambda (x) (+ x 1)) r)
+  (test '(2 3 4) (list-queue-list r))
+  (define sum 0)
+  (list-queue-for-each (lambda (x) (set! sum (+ sum x))) s)
+  (test 60 sum)
+) ; end list-queues/map
+
+(test-group "list-queues/conversion"
+  (define n (list-queue 5 6))
+  (list-queue-set-list! n (list 1 2))
+  (test '(1 2) (list-queue-list n))
+  (define d (list 1 2 3))
+  (define e (cddr d))
+  (define f (make-list-queue d e))
+  (define-values (dx ex) (list-queue-first-last f))
+  (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))
+  (define g (make-list-queue d e))
+  (test '(1 2 3 4) (list-queue-list g))
+  (define h (list-queue 5 6))
+  (list-queue-set-list! h d e)
+  (test '(1 2 3 4) (list-queue-list h))
+); end list-queues/conversion
+
+(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))
+  (test '(0 2 4 6) (list-queue-list x))
+  (define y (list-queue-unfold-right done? double add1 0))
+  (test '(6 4 2 0) (list-queue-list y))
+  (define x0 (list-queue 8))
+  (define x1 (list-queue-unfold done? double add1 0 x0))
+  (test '(0 2 4 6 8) (list-queue-list x1))
+  (define y0 (list-queue 8))
+  (define y1 (list-queue-unfold-right done? double add1 0 y0))
+  (test '(8 6 4 2 0) (list-queue-list y1))
+
+) ; end list-queues/unfold
+
+) ; end list-queues
+
+(test-exit)