From bd9ea1d3acd629944d3ab4581ee18918a75c6891 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 16 Jan 2018 00:00:48 +0900 Subject: [PATCH] adding (srfi 134) --- AUTHORS | 6 +- doc/chibi.scrbl | 1 + lib/srfi/134.scm | 457 ++++++++++++++++++++++++++++++++++++++++++ lib/srfi/134.sld | 32 +++ lib/srfi/134/test.sld | 212 ++++++++++++++++++++ tests/lib-tests.scm | 2 + 6 files changed, 708 insertions(+), 2 deletions(-) create mode 100644 lib/srfi/134.scm create mode 100644 lib/srfi/134.sld create mode 100644 lib/srfi/134/test.sld diff --git a/AUTHORS b/AUTHORS index 3daaec91..8f85548a 100644 --- a/AUTHORS +++ b/AUTHORS @@ -14,8 +14,10 @@ The (scheme time) module includes code for handling leap seconds from Alan Watson's Scheme clock library at http://code.google.com/p/scheme-clock/ under the same license. -The (srfi 101) library is adapted from the reference implementation -by David van Horn. +The following distributed SRFIs use the reference implementations: + + (srfi 101) is adapted from David van Horn's implementation + (srfi 134) is Shiro Kawai's implementation The benchmarks are based on the Racket versions of the classic Gabriel benchmarks from diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl index 688ec807..ea0b877d 100755 --- a/doc/chibi.scrbl +++ b/doc/chibi.scrbl @@ -1210,6 +1210,7 @@ snow-fort): \item{\hyperlink["http://srfi.schemers.org/srfi-130/srfi-130.html"]{(srfi 130) - cursor-based string library}} \item{\hyperlink["http://srfi.schemers.org/srfi-132/srfi-132.html"]{(srfi 132) - sort libraries}} \item{\hyperlink["http://srfi.schemers.org/srfi-133/srfi-133.html"]{(srfi 133) - vector library}} +\item{\hyperlink["http://srfi.schemers.org/srfi-134/srfi-134.html"]{(srfi 134) - immutable deques}} \item{\hyperlink["http://srfi.schemers.org/srfi-139/srfi-139.html"]{(srfi 139) - syntax parameters}} \item{\hyperlink["http://srfi.schemers.org/srfi-141/srfi-141.html"]{(srfi 141) - integer division}} \item{\hyperlink["http://srfi.schemers.org/srfi-143/srfi-143.html"]{(srfi 143) - fixnums}} diff --git a/lib/srfi/134.scm b/lib/srfi/134.scm new file mode 100644 index 00000000..2bd47f10 --- /dev/null +++ b/lib/srfi/134.scm @@ -0,0 +1,457 @@ +;;; +;;; srfi-134 reference implementation +;;; +;;; Copyright (c) 2015 Shiro Kawai +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; +;;; 3. Neither the name of the authors nor the names of its contributors +;;; may be used to endorse or promote products derived from this +;;; software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;; + +;; This implements banker's deque as described in +;; Chris Okasaki's Purely Functional Data Structures. +;; It provides amortized O(1) basic operations. +;; Originally written for Gauche, and ported to R7RS. + +;; Requires srfi-1, srfi-9, srfi-121. + +;; some compatibility stuff +(define-syntax receive + (syntax-rules () + ((_ binds mv-expr body ...) + (let-values ((binds mv-expr)) body ...)))) + +;;; +;;; Record +;;; + +(define-record-type (%make-dq lenf f lenr r) ideque? + (lenf dq-lenf) ; length of front chain + (f dq-f) ; front chain + (lenr dq-lenr) ; length of rear chain + (r dq-r)) ; rear chain + +;; We use a singleton for empty deque +(define *empty* (%make-dq 0 '() 0 '())) + +;; Common type checker +(define (%check-ideque x) + (unless (ideque? x) + (error "ideque expected, but got:" x))) + +;;; +;;; Constructors +;;; + +;; API +(define (ideque . args) (list->ideque args)) + +;; API +(define (ideque-tabulate size init) + (let ((lenf (quotient size 2)) + (lenr (quotient (+ size 1) 2))) + (%make-dq lenf (list-tabulate lenf init) + lenr (unfold (lambda (n) (= n lenr)) + (lambda (n) (init (- size n 1))) + (lambda (n) (+ n 1)) + 0)))) + +;; API +(define (ideque-unfold p f g seed) + (list->ideque (unfold p f g seed))) + +;; API +(define (ideque-unfold-right p f g seed) + (list->ideque (unfold-right p f g seed))) +;; alternatively: +;; (ideque-reverse (list->ideque (unfold p f g seed))) + +;; Internal constructor. Returns a new ideque, with balancing 'front' and +;; 'rear' chains. (The name 'check' comes from Okasaki's book.) + +(define C 3) + +(define (check lenf f lenr r) + (cond ((> lenf (+ (* lenr C) 1)) + (let* ((i (quotient (+ lenf lenr) 2)) + (j (- (+ lenf lenr) i)) + (f. (take f i)) + (r. (append r (reverse (drop f i))))) + (%make-dq i f. j r.))) + ((> lenr (+ (* lenf C) 1)) + (let* ((j (quotient (+ lenf lenr) 2)) + (i (- (+ lenf lenr) j)) + (r. (take r j)) + (f. (append f (reverse (drop r j))))) + (%make-dq i f. j r.))) + (else (%make-dq lenf f lenr r)))) + +;;; +;;; Basic operations +;;; + +;; API +(define (ideque-empty? dq) + (%check-ideque dq) + (and (zero? (dq-lenf dq)) + (zero? (dq-lenr dq)))) + +;; API +(define (ideque-add-front dq x) + (%check-ideque dq) + (check (+ (dq-lenf dq) 1) (cons x (dq-f dq)) (dq-lenr dq) (dq-r dq))) + +;; API +(define (ideque-front dq) + (%check-ideque dq) + (if (zero? (dq-lenf dq)) + (if (zero? (dq-lenr dq)) + (error "Empty deque:" dq) + (car (dq-r dq))) + (car (dq-f dq)))) + +;; API +(define (ideque-remove-front dq) + (%check-ideque dq) + (if (zero? (dq-lenf dq)) + (if (zero? (dq-lenr dq)) + (error "Empty deque:" dq) + *empty*) + (check (- (dq-lenf dq) 1) (cdr (dq-f dq)) (dq-lenr dq) (dq-r dq)))) + +;; API +(define (ideque-add-back dq x) + (%check-ideque dq) + (check (dq-lenf dq) (dq-f dq) (+ (dq-lenr dq) 1) (cons x (dq-r dq)))) + +;; API +(define (ideque-back dq) + (%check-ideque dq) + (if (zero? (dq-lenr dq)) + (if (zero? (dq-lenf dq)) + (error "Empty deque:" dq) + (car (dq-f dq))) + (car (dq-r dq)))) + +;; API +(define (ideque-remove-back dq) + (%check-ideque dq) + (if (zero? (dq-lenr dq)) + (if (zero? (dq-lenf dq)) + (error "Empty deque:" dq) + *empty*) + (check (dq-lenf dq) (dq-f dq) (- (dq-lenr dq) 1) (cdr (dq-r dq))))) + +;; API +(define (ideque-reverse dq) + (%check-ideque dq) + (if (ideque-empty? dq) + *empty* + (%make-dq (dq-lenr dq) (dq-r dq) (dq-lenf dq) (dq-f dq)))) + +;; +;; Other operations +;; + +;; API +(define ideque= + (case-lambda + ((elt=) #t) + ((elt= ideque) (%check-ideque ideque) #t) + ((elt= dq1 dq2) + ;; we optimize two-arg case + (%check-ideque dq1) + (%check-ideque dq2) + (or (eq? dq1 dq2) + (let ((len1 (+ (dq-lenf dq1) (dq-lenr dq1))) + (len2 (+ (dq-lenf dq2) (dq-lenr dq2)))) + (and (= len1 len2) + (receive (x t1 t2) (list-prefix= elt= (dq-f dq1) (dq-f dq2)) + (and x + (receive (y r1 r2) (list-prefix= elt= (dq-r dq1) (dq-r dq2)) + (and y + (if (null? t1) + (list= elt= t2 (reverse r1)) + (list= elt= t1 (reverse r2))))))))))) + ((elt= . dqs) + ;; The comparison scheme is the same as srfi-1's list=. + (apply list= elt= (map ideque->list dqs))))) + +;; Compare two lists up to whichever shorter one. +;; Returns the compare result and the tails of uncompared lists. +(define (list-prefix= elt= a b) + (let loop ((a a) (b b)) + (cond ((or (null? a) (null? b)) (values #t a b)) + ((elt= (car a) (car b)) (loop (cdr a) (cdr b))) + (else (values #f a b))))) + +;; API +(define (ideque-ref dq n) + (%check-ideque dq) + (let ((len (+ (dq-lenf dq) (dq-lenr dq)))) + (cond ((or (< n 0) (>= n len)) (error "Index out of range:" n)) + ((< n (dq-lenf dq)) (list-ref (dq-f dq) n)) + (else (list-ref (dq-r dq) (- len n 1)))))) + +(define (%ideque-take dq n) ; n is within the range + (let ((lenf (dq-lenf dq)) + (f (dq-f dq))) + (if (<= n lenf) + (check n (take f n) 0 '()) + (let ((lenr. (- n lenf))) + (check lenf f lenr. (take-right (dq-r dq) lenr.)))))) + +(define (%ideque-drop dq n) ; n is within the range + (let ((lenf (dq-lenf dq)) + (f (dq-f dq)) + (lenr (dq-lenr dq)) + (r (dq-r dq))) + (if (<= n lenf) + (check n (drop f n) lenr r) + (let ((lenr. (- lenr (- n lenf)))) + (check 0 '() lenr. (take r lenr.)))))) + +(define (%check-length dq n) + (unless (<= 0 n (- (ideque-length dq) 1)) + (error "argument is out of range:" n))) + +;; API +(define (ideque-take dq n) + (%check-ideque dq) + (%check-length dq n) + (%ideque-take dq n)) + +;; API +(define (ideque-take-right dq n) + (%check-ideque dq) + (%check-length dq n) + (%ideque-drop dq (- (ideque-length dq) n))) + +;; API +(define (ideque-drop dq n) + (%check-ideque dq) + (%check-length dq n) + (%ideque-drop dq n)) + +;; API +(define (ideque-drop-right dq n) + (%check-ideque dq) + (%check-length dq n) + (%ideque-take dq (- (ideque-length dq) n))) + +;; API +(define (ideque-split-at dq n) + (%check-ideque dq) + (%check-length dq n) + (values (%ideque-take dq n) + (%ideque-drop dq n))) + +;; API +(define (ideque-length dq) + (%check-ideque dq) + (+ (dq-lenf dq) (dq-lenr dq))) + +;; API +(define (ideque-append . dqs) + ;; We could save some list copying by carefully split dqs into front and + ;; rear groups and append separately, but for now we don't bother... + (list->ideque (concatenate (map ideque->list dqs)))) + +;; API +(define (ideque-count pred dq) + (%check-ideque dq) + (+ (count pred (dq-f dq)) (count pred (dq-r dq)))) + +;; API +(define (ideque-zip dq . dqs) + ;; An easy way. + (let ((elts (apply zip (ideque->list dq) (map ideque->list dqs)))) + (check (length elts) elts 0 '()))) + +;; API +(define (ideque-map proc dq) + (%check-ideque dq) + (%make-dq (dq-lenf dq) (map proc (dq-f dq)) + (dq-lenr dq) (map proc (dq-r dq)))) + +;; API +(define (ideque-filter-map proc dq) + (%check-ideque dq) + (let ((f (filter-map proc (dq-f dq))) + (r (filter-map proc (dq-r dq)))) + (check (length f) f (length r) r))) + +;; API +(define (ideque-for-each proc dq) + (%check-ideque dq) + (for-each proc (dq-f dq)) + (for-each proc (reverse (dq-r dq)))) + +;; API +(define (ideque-for-each-right proc dq) + (%check-ideque dq) + (for-each proc (dq-r dq)) + (for-each proc (reverse (dq-f dq)))) + +;; API +(define (ideque-fold proc knil dq) + (%check-ideque dq) + (fold proc (fold proc knil (dq-f dq)) (reverse (dq-r dq)))) + +;; API +(define (ideque-fold-right proc knil dq) + (%check-ideque dq) + (fold-right proc (fold-right proc knil (reverse (dq-r dq))) (dq-f dq))) + +;; API +(define (ideque-append-map proc dq) + ;; can be cleverer, but for now... + (list->ideque (append-map proc (ideque->list dq)))) + +(define (%ideque-filter-remove op pred dq) + (%check-ideque dq) + (let ((f (op pred (dq-f dq))) + (r (op pred (dq-r dq)))) + (check (length f) f (length r) r))) + +;; API +(define (ideque-filter pred dq) (%ideque-filter-remove filter pred dq)) +(define (ideque-remove pred dq) (%ideque-filter-remove remove pred dq)) + +;; API +(define (ideque-partition pred dq) + (%check-ideque dq) + (receive (f1 f2) (partition pred (dq-f dq)) + (receive (r1 r2) (partition pred (dq-r dq)) + (values (check (length f1) f1 (length r1) r1) + (check (length f2) f2 (length r2) r2))))) + +(define *not-found* (cons #f #f)) ; unique value + +(define (%search pred seq1 seq2 failure) + ;; We could write seek as CPS, but we employ *not-found* instead to avoid + ;; closure allocation. + (define (seek pred s) + (cond ((null? s) *not-found*) + ((pred (car s)) (car s)) + (else (seek pred (cdr s))))) + (let ((r (seek pred seq1))) + (if (not (eq? r *not-found*)) + r + (let ((r (seek pred (reverse seq2)))) + (if (not (eq? r *not-found*)) + r + (failure)))))) + +;; API +(define (ideque-find pred dq . opts) + (%check-ideque dq) + (let ((failure (if (pair? opts) (car opts) (lambda () #f)))) + (%search pred (dq-f dq) (dq-r dq) failure))) + +;; API +(define (ideque-find-right pred dq . opts) + (%check-ideque dq) + (let ((failure (if (pair? opts) (car opts) (lambda () #f)))) + (%search pred (dq-r dq) (dq-f dq) failure))) + +;; API +(define (ideque-take-while pred dq) + (%check-ideque dq) + (receive (hd tl) (span pred (dq-f dq)) + (if (null? tl) + (receive (hd. tl.) (span pred (reverse (dq-r dq))) + (check (dq-lenf dq) (dq-f dq) (length hd.) (reverse hd.))) + (check (length hd) hd 0 '())))) + +;; API +(define (ideque-take-while-right pred dq) + (%check-ideque dq) + (ideque-reverse (ideque-take-while pred (ideque-reverse dq)))) + +;; API +(define (ideque-drop-while pred dq) + (%check-ideque dq) + (receive (hd tl) (span pred (dq-f dq)) + (if (null? tl) + (receive (hd. tl.) (span pred (reverse (dq-r dq))) + (check (length tl.) tl. 0 '())) + (check (length tl) tl (dq-lenr dq) (dq-r dq))))) + +;; API +(define (ideque-drop-while-right pred dq) + (%check-ideque dq) + (ideque-reverse (ideque-drop-while pred (ideque-reverse dq)))) + +(define (%idq-span-break op pred dq) + (%check-ideque dq) + (receive (head tail) (op pred (dq-f dq)) + (if (null? tail) + (receive (head. tail.) (op pred (reverse (dq-r dq))) + (values (check (length head) head (length head.) (reverse head.)) + (check (length tail.) tail. 0 '()))) + (values (check (length head) head 0 '()) + (check (length tail) tail (dq-lenr dq) (dq-r dq)))))) + +;; API +(define (ideque-span pred dq) (%idq-span-break span pred dq)) +(define (ideque-break pred dq) (%idq-span-break break pred dq)) + +;; API +(define (ideque-any pred dq) + (%check-ideque dq) + (if (null? (dq-r dq)) + (any pred (dq-f dq)) + (or (any pred (dq-f dq)) (any pred (reverse (dq-r dq)))))) + +;; API +(define (ideque-every pred dq) + (%check-ideque dq) + (if (null? (dq-r dq)) + (every pred (dq-f dq)) + (and (every pred (dq-f dq)) (every pred (reverse (dq-r dq)))))) + +;; API +(define (ideque->list dq) + (%check-ideque dq) + (append (dq-f dq) (reverse (dq-r dq)))) + +;; API +(define (list->ideque lis) (check (length lis) lis 0 '())) + +;; API +(define (ideque->generator dq) + (%check-ideque dq) + (lambda () + (if (ideque-empty? dq) + (eof-object) + (let ((v (ideque-front dq))) + (set! dq (ideque-remove-front dq)) + v)))) + +;; API +(define (generator->ideque gen) + (list->ideque (generator->list gen))) diff --git a/lib/srfi/134.sld b/lib/srfi/134.sld new file mode 100644 index 00000000..c1485646 --- /dev/null +++ b/lib/srfi/134.sld @@ -0,0 +1,32 @@ +(define-library (srfi 134) + (import (scheme base) (scheme case-lambda) + (srfi 1) (srfi 9) (srfi 121)) + (export ideque ideque-tabulate ideque-unfold ideque-unfold-right + ideque? ideque-empty? ideque= ideque-any ideque-every + + ideque-front ideque-add-front ideque-remove-front + ideque-back ideque-add-back ideque-remove-back + + ideque-ref + ideque-take ideque-take-right ideque-drop ideque-drop-right + ideque-split-at + + ideque-length ideque-append ideque-reverse + ideque-count ideque-zip + + ideque-map ideque-filter-map + ideque-for-each ideque-for-each-right + ideque-fold ideque-fold-right + ideque-append-map + + ideque-filter ideque-remove ideque-partition + + ideque-find ideque-find-right + ideque-take-while ideque-take-while-right + ideque-drop-while ideque-drop-while-right + ideque-span ideque-break + + list->ideque ideque->list + generator->ideque ideque->generator + ) + (include "134.scm")) diff --git a/lib/srfi/134/test.sld b/lib/srfi/134/test.sld new file mode 100644 index 00000000..230a9284 --- /dev/null +++ b/lib/srfi/134/test.sld @@ -0,0 +1,212 @@ + +(define-library (srfi 134 test) + (import (scheme base) (scheme char) + (srfi 1) (srfi 121) (srfi 134) + (chibi test)) + (export run-tests) + (begin + (define-syntax receive + (syntax-rules () + ((_ binds mv-expr body ...) + (let-values ((binds mv-expr)) body ...)))) + (define (run-tests) + (test-group "ideque" + + (test-group "ideque/constructors" + (test '() (ideque->list (ideque))) + (test '() (ideque->list (list->ideque '()))) + (test '(1 2 3) (ideque->list (ideque 1 2 3))) + (test '(4 5 6 7) (ideque->list (list->ideque '(4 5 6 7)))) + (test '(10 9 8 7 6 5 4 3 2 1) + (ideque->list (ideque-unfold zero? values (lambda (n) (- n 1)) 10))) + (test '(1 2 3 4 5 6 7 8 9 10) + (ideque->list (ideque-unfold-right zero? values (lambda (n) (- n 1)) 10))) + (test '(0 2 4 6 8 10) + (ideque->list (ideque-tabulate 6 (lambda (n) (* n 2))))) + + ;; corner cases + (test '() (ideque->list + (ideque-unfold (lambda (n) #t) values (lambda (n) (+ n 1)) 0))) + (test '() (ideque->list + (ideque-unfold-right (lambda (n) #t) values (lambda (n) (+ n 1)) 0))) + (test '() (ideque->list (ideque-tabulate 0 values))) + ) + + (test-group "ideque/predicates" + (test-assert (ideque? (ideque))) + (test-assert (not (ideque? 1))) + (test-assert (ideque-empty? (ideque))) + (test-assert (not (ideque-empty? (ideque 1)))) + (test-assert (ideque= eq?)) + (test-assert (ideque= eq? (ideque 1))) + (test-assert (ideque= char-ci=? (ideque #\a #\b) (ideque #\A #\B))) + (test-assert (ideque= char-ci=? (ideque) (ideque))) + (test-assert (not (ideque= char-ci=? (ideque #\a #\b) (ideque #\A #\B #\c)))) + (test-assert (not (ideque= char-ci=? (ideque #\a #\b) (ideque #\A)))) + (test-assert (ideque= char-ci=? (ideque) (ideque) (ideque))) + (test-assert (ideque= char-ci=? (ideque #\a #\b) (ideque #\A #\B) (ideque #\a #\B))) + (test-assert (not (ideque= char-ci=? (ideque #\a #\b) (ideque #\A) (ideque #\a #\B)))) + (test-assert (not (ideque= char-ci=? (ideque #\a #\b) (ideque #\A #\B) (ideque #\A #\B #\c)))) + ) + + (test-group "ideque/queue-operations" + (test-error (ideque-front (ideque))) + (test-error (ideque-back (ideque))) + (test 1 (ideque-front (ideque 1 2 3))) + (test 3 (ideque-back (ideque 1 2 3))) + (test 2 (ideque-front (ideque-remove-front (ideque 1 2 3)))) + (test 2 (ideque-back (ideque-remove-back (ideque 1 2 3)))) + (test 1 (ideque-front (ideque-remove-back (ideque 1 2 3)))) + (test 3 (ideque-back (ideque-remove-front (ideque 1 2 3)))) + (test-assert (ideque-empty? (ideque-remove-front (ideque 1)))) + (test-assert (ideque-empty? (ideque-remove-back (ideque 1)))) + (test 0 (ideque-front (ideque-add-front (ideque 1 2 3) 0))) + (test 0 (ideque-back (ideque-add-back (ideque 1 2 3) 0))) + ) + + (test-group "ideque/other-accessors" + (define (check name ideque-op list-op n) + (let* ((lis (iota n)) + (dq (list->ideque lis))) + (for-each (lambda (i) + (test (cons name i) + (receive xs (list-op lis i) xs) + (receive xs (ideque-op dq i) + (map ideque->list xs)))) + lis))) + (check 'ideque-take ideque-take take 7) + (check 'ideque-drop ideque-drop drop 6) + (check 'ideque-split-at ideque-split-at split-at 8) + ;; out-of-range conditions + (test-error (ideque->list (ideque-take (ideque 1 2 3 4 5 6 7) 10))) + (test-error (ideque->list (ideque-take-right (ideque 1 2 3 4 5 6 7) 10))) + (test-error (ideque-split-at (ideque 1 2 3 4 5 6 7) 10)) + + (test '(3 2 1) (map (lambda (n) (ideque-ref (ideque 3 2 1) n)) '(0 1 2))) + (test-error (ideque-ref (ideque 3 2 1) -1)) + (test-error (ideque-ref (ideque 3 2 1) 3)) + ) + + (test-group "ideque/whole-ideque" + (test 7 (ideque-length (ideque 1 2 3 4 5 6 7))) + (test 0 (ideque-length (ideque))) + (test '() (ideque->list (ideque-append))) + (test '() (ideque->list (ideque-append (ideque) (ideque)))) + (test '(1 2 3 a b c d 5 6 7 8 9) + (ideque->list (ideque-append (ideque 1 2 3) + (ideque 'a 'b 'c 'd) + (ideque) + (ideque 5 6 7 8 9)))) + (test '() (ideque->list (ideque-reverse (ideque)))) + (test '(5 4 3 2 1) (ideque->list (ideque-reverse (ideque 1 2 3 4 5)))) + (test 0 (ideque-count odd? (ideque))) + (test 3 (ideque-count odd? (ideque 1 2 3 4 5))) + (test '((1 a) (2 b) (3 c)) + (ideque->list (ideque-zip (ideque 1 2 3) (ideque 'a 'b 'c 'd 'e)))) + (test '((1 a x) (2 b y) (3 c z)) + (ideque->list (ideque-zip (ideque 1 2 3 4 5) + (ideque 'a 'b 'c 'd 'e) + (ideque 'x 'y 'z)))) + (test '((1) (2) (3)) + (ideque->list (ideque-zip (ideque 1 2 3)))) + (test '() + (ideque->list (ideque-zip (ideque 1 2 3) (ideque)))) + ) + + (test-group "ideque/mapping" + (test-assert (ideque-empty? (ideque-map list (ideque)))) + (test '(-1 -2 -3 -4 -5) (ideque->list (ideque-map - (ideque 1 2 3 4 5)))) + (test '(-1 -3 5 -8) + (ideque->list (ideque-filter-map (lambda (x) (and (number? x) (- x))) + (ideque 1 3 'a -5 8)))) + (test '(5 4 3 2 1) + (let ((r '())) + (ideque-for-each (lambda (n) (set! r (cons n r))) + (ideque 1 2 3 4 5)) + r)) + (test '(1 2 3 4 5) + (let ((r '())) + (ideque-for-each-right (lambda (n) (set! r (cons n r))) + (ideque 1 2 3 4 5)) + r)) + (test '(5 4 3 2 1 . z) + (ideque-fold cons 'z (ideque 1 2 3 4 5))) + (test '(1 2 3 4 5 . z) + (ideque-fold-right cons 'z (ideque 1 2 3 4 5))) + (test '(a a b b c c) + (ideque->list (ideque-append-map (lambda (x) (list x x)) + (ideque 'a 'b 'c)))) + ) + + (test-group "ideque/filtering" + (test '(1 3 5) + (ideque->list (ideque-filter odd? (ideque 1 2 3 4 5)))) + (test '(2 4) + (ideque->list (ideque-remove odd? (ideque 1 2 3 4 5)))) + (test '((1 3 5) (2 4)) + (receive xs (ideque-partition odd? (ideque 1 2 3 4 5)) + (map ideque->list xs))) + ) + + (test-group "ideque/searching" + (test 3 (ideque-find number? (ideque 'a 3 'b 'c 4 'd) (lambda () 'boo))) + (test 'boo (ideque-find number? (ideque 'a 'b 'c 'd) (lambda () 'boo))) + (test #f (ideque-find number? (ideque 'a 'b 'c 'd))) + (test 4 (ideque-find-right number? (ideque 'a 3 'b 'c 4 'd) (lambda () 'boo))) + (test 'boo (ideque-find-right number? (ideque 'a 'b 'c 'd) (lambda () 'boo))) + (test #f (ideque-find-right number? (ideque 'a 'b 'c 'd))) + (test '(1 3 2) + (ideque->list (ideque-take-while (lambda (n) (< n 5)) + (ideque 1 3 2 5 8 4 6 3 4 2)))) + (test '(5 8 4 6 3 4 2) + (ideque->list (ideque-drop-while (lambda (n) (< n 5)) + (ideque 1 3 2 5 8 4 6 3 4 2)))) + (test '(3 4 2) + (ideque->list (ideque-take-while-right (lambda (n) (< n 5)) + (ideque 1 3 2 5 8 4 6 3 4 2)))) + (test '(1 3 2 5 8 4 6) + (ideque->list (ideque-drop-while-right (lambda (n) (< n 5)) + (ideque 1 3 2 5 8 4 6 3 4 2)))) + (test '() + (ideque->list (ideque-take-while (lambda (n) (< n 5)) + (ideque 5 8 4 6 3 4 2 9)))) + (test '() + (ideque->list (ideque-drop-while (lambda (n) (< n 5)) + (ideque 1 4 3 2 3 4 2 1)))) + (test '() + (ideque->list (ideque-take-while-right (lambda (n) (< n 5)) + (ideque 5 8 4 6 3 4 2 9)))) + (test '() + (ideque->list (ideque-drop-while-right (lambda (n) (< n 5)) + (ideque 1 3 2 4 3 2 3 2)))) + (test '((1 3 2) (5 8 4 6 3 4 2)) + (receive xs (ideque-span (lambda (n) (< n 5)) + (ideque 1 3 2 5 8 4 6 3 4 2)) + (map ideque->list xs))) + (test '((5 8) (4 6 3 4 2 9)) + (receive xs (ideque-break (lambda (n) (< n 5)) + (ideque 5 8 4 6 3 4 2 9)) + (map ideque->list xs))) + (test 3 (ideque-any (lambda (x) (and (number? x) x)) + (ideque 'a 3 'b 'c 4 'd 'e))) + (test 5 (ideque-any (lambda (x) (and (number? x) x)) + (ideque 'a 'b 'c 'd 'e 5))) + (test #f (ideque-any (lambda (x) (and (number? x) x)) + (ideque 'a 'b 'c 'd 'e))) + (test 9 (ideque-every (lambda (x) (and (number? x) x)) + (ideque 1 5 3 2 9))) + (test #f (ideque-every (lambda (x) (and (number? x) x)) + (ideque 1 5 'a 2 9))) + ;; check if we won't see further once we found the result + (test 1 (ideque-any (lambda (x) (and (odd? x) x)) + (ideque 2 1 'a 'b 'c 'd))) + (test #f (ideque-every (lambda (x) (and (odd? x) x)) + (ideque 1 2 'a 'b 'c 'd))) + + (test '(1 2 3) (generator->list (ideque->generator (ideque 1 2 3)))) + (test '() (generator->list (ideque->generator (ideque)))) + (test '(1 2 3) (ideque->list (generator->ideque (generator 1 2 3)))) + (test '() (ideque->list (generator->ideque (generator)))) + ) + + )))) diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm index 206d3294..e05fa4b4 100644 --- a/tests/lib-tests.scm +++ b/tests/lib-tests.scm @@ -24,6 +24,7 @@ (rename (srfi 130 test) (run-tests run-srfi-130-tests)) (rename (srfi 132 test) (run-tests run-srfi-132-tests)) (rename (srfi 133 test) (run-tests run-srfi-133-tests)) + (rename (srfi 134 test) (run-tests run-srfi-134-tests)) (rename (srfi 139 test) (run-tests run-srfi-139-tests)) (rename (srfi 151 test) (run-tests run-srfi-151-tests)) (rename (chibi base64-test) (run-tests run-base64-tests)) @@ -81,6 +82,7 @@ (run-srfi-130-tests) (run-srfi-132-tests) (run-srfi-133-tests) +(run-srfi-134-tests) (run-srfi-139-tests) (run-srfi-151-tests) (run-base64-tests)