mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
adding (srfi 134)
This commit is contained in:
Alex Shinn
parent
0c27921f51
commit
bd9ea1d3ac
6 changed files with 708 additions and 2 deletions
6
AUTHORS
6
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
|
||||
|
|
|
|||
|
|
@ -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}}
|
||||
|
|
|
|||
457
lib/srfi/134.scm
Normal file
457
lib/srfi/134.scm
Normal file
|
|
@ -0,0 +1,457 @@
|
|||
;;;
|
||||
;;; srfi-134 reference implementation
|
||||
;;;
|
||||
;;; Copyright (c) 2015 Shiro Kawai <shiro@acm.org>
|
||||
;;;
|
||||
;;; 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 <ideque> (%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)))
|
||||
32
lib/srfi/134.sld
Normal file
32
lib/srfi/134.sld
Normal file
|
|
@ -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"))
|
||||
212
lib/srfi/134/test.sld
Normal file
212
lib/srfi/134/test.sld
Normal file
|
|
@ -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))))
|
||||
)
|
||||
|
||||
))))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue