From ae1704883c580de4e65862e2a25e5922625bcf94 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 1 Apr 2017 22:15:08 +0900 Subject: [PATCH] adding (srfi 117) --- lib/srfi/117.sld | 11 +++++ lib/srfi/117/queue.scm | 106 +++++++++++++++++++++++++++++++++++++++++ lib/srfi/117/test.sld | 94 ++++++++++++++++++++++++++++++++++++ 3 files changed, 211 insertions(+) create mode 100644 lib/srfi/117.sld create mode 100644 lib/srfi/117/queue.scm create mode 100644 lib/srfi/117/test.sld diff --git a/lib/srfi/117.sld b/lib/srfi/117.sld new file mode 100644 index 00000000..3e7098ae --- /dev/null +++ b/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")) diff --git a/lib/srfi/117/queue.scm b/lib/srfi/117/queue.scm new file mode 100644 index 00000000..0e6f8472 --- /dev/null +++ b/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))) diff --git a/lib/srfi/117/test.sld b/lib/srfi/117/test.sld new file mode 100644 index 00000000..f3f2ef1c --- /dev/null +++ b/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))))