add streams to `racket'
- rename old `racket/stream' to `racket/sequence', and adjust to avoid stateful iterations - add a new `racket/stream' library with a `strean-cons' that is based on SRFI 41 - adjust `for' and some sequence constructors like `in-range' to work more directly with streams
This commit is contained in:
parent
ae8b326522
commit
e652546bf5
|
@ -26,6 +26,7 @@
|
|||
racket/promise
|
||||
racket/bool
|
||||
racket/stream
|
||||
racket/sequence
|
||||
racket/local
|
||||
racket/system
|
||||
(for-syntax racket/base))
|
||||
|
@ -56,6 +57,7 @@
|
|||
racket/promise
|
||||
racket/bool
|
||||
racket/stream
|
||||
racket/sequence
|
||||
racket/local
|
||||
racket/system)
|
||||
(for-syntax (all-from-out racket/base)))
|
||||
|
|
|
@ -34,6 +34,7 @@
|
|||
(rename *in-vector in-vector)
|
||||
(rename *in-string in-string)
|
||||
(rename *in-bytes in-bytes)
|
||||
(rename *in-stream in-stream)
|
||||
(rename *in-input-port-bytes in-input-port-bytes)
|
||||
(rename *in-input-port-chars in-input-port-chars)
|
||||
(rename *in-port in-port)
|
||||
|
@ -48,12 +49,22 @@
|
|||
in-sequences
|
||||
in-cycle
|
||||
in-parallel
|
||||
in-values-sequence
|
||||
in-values*-sequence
|
||||
stop-before
|
||||
stop-after
|
||||
(rename *in-producer in-producer)
|
||||
(rename *in-indexed in-indexed)
|
||||
(rename *in-value in-value)
|
||||
|
||||
stream?
|
||||
stream-empty?
|
||||
stream-first
|
||||
stream-rest
|
||||
prop:stream
|
||||
sequence->stream
|
||||
empty-stream make-do-stream
|
||||
|
||||
sequence?
|
||||
sequence-generate
|
||||
prop:sequence
|
||||
|
@ -293,8 +304,9 @@
|
|||
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; sequences
|
||||
;; streams & sequences
|
||||
|
||||
;; structure type for generic sequences:
|
||||
(define-values (struct:do-sequence
|
||||
make-do-sequence
|
||||
do-sequence?
|
||||
|
@ -302,6 +314,40 @@
|
|||
do-sequence-set!)
|
||||
(make-struct-type 'sequence #f 1 0 #f))
|
||||
|
||||
;; property for generic streams
|
||||
(define-values (prop:stream stream-via-prop? stream-ref)
|
||||
(make-struct-type-property
|
||||
'stream
|
||||
(lambda (v si)
|
||||
(unless (and (vector? v)
|
||||
(= 3 (vector-length v))
|
||||
(procedure? (vector-ref v 0))
|
||||
(procedure-arity-includes? (vector-ref v 0) 1)
|
||||
(procedure? (vector-ref v 1))
|
||||
(procedure-arity-includes? (vector-ref v 1) 1)
|
||||
(procedure? (vector-ref v 2))
|
||||
(procedure-arity-includes? (vector-ref v 2) 1))
|
||||
(raise-type-error 'guard-for-prop:stream
|
||||
"vector of three procedures (arity 1)"
|
||||
v))
|
||||
(vector->immutable-vector v))))
|
||||
|
||||
;; new-style sequence property, where the property value is a procedure
|
||||
;; to get the sequence-driving value and procedures;
|
||||
;; this property is not currently exported
|
||||
(define-values (prop:gen-sequence sequence-via-prop? sequence-ref)
|
||||
(make-struct-type-property
|
||||
'sequence
|
||||
(lambda (v si)
|
||||
(unless (and (procedure? v)
|
||||
(procedure-arity-includes? v 1))
|
||||
(raise-type-error 'guard-for-prop:sequence
|
||||
"procedure (arity 1)"
|
||||
v))
|
||||
v)))
|
||||
|
||||
;; exported sequence property, where the property value
|
||||
;; is a procedure to get a sequence
|
||||
(define-values (prop:sequence :sequence? :sequence-ref)
|
||||
(make-struct-type-property
|
||||
'sequence
|
||||
|
@ -325,9 +371,61 @@
|
|||
clause-transformer-expr
|
||||
(syntax-local-certifier #f)))]))
|
||||
|
||||
(define (stream? v)
|
||||
(or (list? v)
|
||||
(stream-via-prop? v)))
|
||||
|
||||
(define (unsafe-stream-not-empty? v)
|
||||
(if (null? v)
|
||||
#f
|
||||
(or (pair? v)
|
||||
(not ((unsafe-vector-ref (stream-ref v) 0) v)))))
|
||||
|
||||
(define (stream-empty? v)
|
||||
(or (null? v)
|
||||
(if (stream? v)
|
||||
(if (pair? v)
|
||||
#f
|
||||
((unsafe-vector-ref (stream-ref v) 0) v))
|
||||
(raise-type-error 'stream-empty?
|
||||
"stream"
|
||||
v))))
|
||||
|
||||
(define (unsafe-stream-first v)
|
||||
(cond
|
||||
[(pair? v) (car v)]
|
||||
[else ((unsafe-vector-ref (stream-ref v) 1) v)]))
|
||||
|
||||
(define (stream-first v)
|
||||
(if (and (stream? v)
|
||||
(not (stream-empty? v)))
|
||||
(unsafe-stream-first v)
|
||||
(raise-type-error 'stream-first
|
||||
"non-empty stream"
|
||||
v)))
|
||||
|
||||
(define (unsafe-stream-rest v)
|
||||
(cond
|
||||
[(pair? v) (cdr v)]
|
||||
[else (let ([r ((unsafe-vector-ref (stream-ref v) 2) v)])
|
||||
(unless (stream? r)
|
||||
(raise-mismatch-error 'stream-rest-guard
|
||||
"result is not a stream: "
|
||||
r))
|
||||
r)]))
|
||||
|
||||
(define (stream-rest v)
|
||||
(if (and (stream? v)
|
||||
(not (stream-empty? v)))
|
||||
(unsafe-stream-rest v)
|
||||
(raise-type-error 'stream-rest
|
||||
"non-empty stream"
|
||||
v)))
|
||||
|
||||
(define (sequence? v)
|
||||
(or (do-sequence? v)
|
||||
(list? v)
|
||||
(sequence-via-prop? v)
|
||||
(stream? v)
|
||||
(mpair? v)
|
||||
(vector? v)
|
||||
(string? v)
|
||||
|
@ -339,14 +437,16 @@
|
|||
(define (make-sequence who v)
|
||||
(cond
|
||||
[(do-sequence? v) ((do-sequence-ref v 0))]
|
||||
[(list? v) (:list-gen v)]
|
||||
[(mpair? v) (:mlist-gen v)]
|
||||
[(list? v) (:list-gen v)]
|
||||
[(vector? v) (:vector-gen v 0 (vector-length v) 1)]
|
||||
[(string? v) (:string-gen v 0 (string-length v) 1)]
|
||||
[(bytes? v) (:bytes-gen v 0 (bytes-length v) 1)]
|
||||
[(input-port? v) (:input-port-gen v)]
|
||||
[(hash? v) (:hash-key+val-gen v)]
|
||||
[(sequence-via-prop? v) ((sequence-ref v) v)]
|
||||
[(:sequence? v) (make-sequence who ((:sequence-ref v) v))]
|
||||
[(stream? v) (:stream-gen v)]
|
||||
[else (raise
|
||||
(exn:fail:contract
|
||||
(format "for: expected a sequence for ~a, got something else: ~v"
|
||||
|
@ -355,7 +455,34 @@
|
|||
who)
|
||||
v)
|
||||
(current-continuation-marks)))]))
|
||||
|
||||
|
||||
(define-values (struct:range
|
||||
make-range
|
||||
range?
|
||||
range-ref
|
||||
range-set!)
|
||||
(make-struct-type 'stream #f 3 0 #f
|
||||
(list (cons prop:stream
|
||||
(vector
|
||||
(lambda (v)
|
||||
(let ([cont? (range-ref v 2)])
|
||||
(and cont?
|
||||
(not (cont? (range-ref v 0))))))
|
||||
(lambda (v) (range-ref v 0))
|
||||
(lambda (v) (make-range
|
||||
((range-ref v 1) (range-ref v 0))
|
||||
(range-ref v 1)
|
||||
(range-ref v 2)))))
|
||||
(cons prop:gen-sequence
|
||||
(lambda (v)
|
||||
(values
|
||||
values
|
||||
(range-ref v 1)
|
||||
(range-ref v 0)
|
||||
(range-ref v 2)
|
||||
#f
|
||||
#f))))))
|
||||
|
||||
(define in-range
|
||||
(case-lambda
|
||||
[(b) (in-range 0 b 1)]
|
||||
|
@ -364,16 +491,11 @@
|
|||
(unless (real? a) (raise-type-error 'in-range "real-number" a))
|
||||
(unless (real? b) (raise-type-error 'in-range "real-number" b))
|
||||
(unless (real? step) (raise-type-error 'in-range "real-number" step))
|
||||
(make-do-sequence (lambda ()
|
||||
(values
|
||||
(lambda (x) x)
|
||||
(lambda (x) (+ x step))
|
||||
a
|
||||
(if (step . >= . 0)
|
||||
(lambda (x) (< x b))
|
||||
(lambda (x) (> x b)))
|
||||
void
|
||||
void)))]))
|
||||
(let* ([cont? (if (step . >= . 0)
|
||||
(lambda (x) (< x b))
|
||||
(lambda (x) (> x b)))]
|
||||
[inc (lambda (x) (+ x step))])
|
||||
(make-range a inc cont?))]))
|
||||
|
||||
(define in-naturals
|
||||
(case-lambda
|
||||
|
@ -385,11 +507,32 @@
|
|||
(raise-type-error 'in-naturals
|
||||
"exact non-negative integer"
|
||||
n))
|
||||
(make-do-sequence (lambda () (values values add1 n void void void)))]))
|
||||
(make-range n add1 #f)]))
|
||||
|
||||
(define-values (struct:list-stream
|
||||
make-list-stream
|
||||
list-stream?
|
||||
list-stream-ref
|
||||
list-stream-set!)
|
||||
(make-struct-type 'stream #f 1 0 #f
|
||||
(list (cons prop:stream
|
||||
(vector
|
||||
(lambda (v) (not (pair? (list-stream-ref v 0))))
|
||||
(lambda (v) (car (list-stream-ref v 0)))
|
||||
(lambda (v) (make-list-stream (cdr (list-stream-ref v 0))))))
|
||||
(cons prop:gen-sequence
|
||||
(lambda (v)
|
||||
(values
|
||||
car
|
||||
cdr
|
||||
(list-stream-ref v 0)
|
||||
pair?
|
||||
#f
|
||||
#f))))))
|
||||
|
||||
(define (in-list l)
|
||||
;; (unless (list? l) (raise-type-error 'in-list "list" l))
|
||||
(make-do-sequence (lambda () (:list-gen l))))
|
||||
(make-list-stream l))
|
||||
|
||||
(define (:list-gen l)
|
||||
(values car cdr l pair? #f #f))
|
||||
|
@ -481,6 +624,13 @@
|
|||
#f
|
||||
#f))
|
||||
|
||||
(define (in-stream l)
|
||||
(unless (stream? l) (raise-type-error 'in-stream "stream" l))
|
||||
(make-do-sequence (lambda () (:stream-gen l))))
|
||||
|
||||
(define (:stream-gen l)
|
||||
(values unsafe-stream-first unsafe-stream-rest l unsafe-stream-not-empty? #f #f))
|
||||
|
||||
;; Vector-like sequences --------------------------------------------------
|
||||
|
||||
;; (: check-ranges (Symbol Natural Integer Integer Natural -> Void))
|
||||
|
@ -741,6 +891,44 @@
|
|||
void
|
||||
void))))
|
||||
|
||||
(define (in-values-sequence g)
|
||||
(unless (sequence? g) (raise-type-error 'in-values-sequence "sequence" g))
|
||||
(make-do-sequence (lambda ()
|
||||
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
|
||||
(make-sequence #f g)])
|
||||
(values (lambda (pos) (call-with-values (lambda () (pos->val pos))
|
||||
list))
|
||||
pos-next
|
||||
init
|
||||
pos-cont?
|
||||
(and pre-cont?
|
||||
(lambda (vals) (apply pre-cont? vals)))
|
||||
(and post-cont?
|
||||
(lambda (pos vals) (apply post-cont? pos vals))))))))
|
||||
|
||||
(define (in-values*-sequence g)
|
||||
(unless (sequence? g) (raise-type-error 'in-values-sequence "sequence" g))
|
||||
(make-do-sequence (lambda ()
|
||||
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
|
||||
(make-sequence #f g)])
|
||||
(values (lambda (pos) (call-with-values (lambda () (pos->val pos))
|
||||
(case-lambda
|
||||
[(v) (if (list? v) (list v) v)]
|
||||
[vs vs])))
|
||||
pos-next
|
||||
init
|
||||
pos-cont?
|
||||
(and pre-cont?
|
||||
(lambda (vals)
|
||||
(if (list? vals)
|
||||
(apply pre-cont? vals)
|
||||
(pre-cont? vals))))
|
||||
(and post-cont?
|
||||
(lambda (pos vals)
|
||||
(if (list? vals)
|
||||
(apply post-cont? pos vals)
|
||||
(post-cont? pos vals)))))))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (append-sequences sequences cyclic?)
|
||||
|
@ -830,6 +1018,56 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; running sequences outside of a loop:
|
||||
|
||||
(define-values (struct:do-stream
|
||||
make-do-stream
|
||||
do-stream?
|
||||
do-stream-ref
|
||||
do-stream-set!)
|
||||
(make-struct-type 'stream #f 3 0 #f
|
||||
(list (cons prop:stream
|
||||
(vector
|
||||
(lambda (v) ((do-stream-ref v 0)))
|
||||
(lambda (v) ((do-stream-ref v 1)))
|
||||
(lambda (v) ((do-stream-ref v 2))))))))
|
||||
|
||||
(define empty-stream (make-do-stream (lambda () #t) void void))
|
||||
|
||||
(define (sequence->stream s)
|
||||
(unless (sequence? s)
|
||||
(raise-type-error 'sequence-generate "sequence" s))
|
||||
(cond
|
||||
[(stream? s) s]
|
||||
[else
|
||||
(let-values ([(pos->val pos-next init pos-cont? pre-cont? post-cont?)
|
||||
(make-sequence #f s)])
|
||||
(define (gen-stream pos)
|
||||
(let ([done? #f]
|
||||
[vals #f]
|
||||
[empty? #f]
|
||||
[next #f])
|
||||
(define (force!)
|
||||
(unless done?
|
||||
(if (if pos-cont? (pos-cont? pos) #t)
|
||||
(begin
|
||||
(set! vals (call-with-values (lambda () (pos->val pos)) list))
|
||||
(unless (if pre-cont? (apply pre-cont? vals) #t)
|
||||
(set! vals #f)
|
||||
(set! empty? #f)))
|
||||
(set! empty? #t))
|
||||
(set! done? #t)))
|
||||
(make-do-stream (lambda () (force!) empty?)
|
||||
(lambda () (force!) (apply values vals))
|
||||
(lambda ()
|
||||
(force!)
|
||||
(if next
|
||||
next
|
||||
(begin
|
||||
(if (if post-cont? (apply post-cont? pos vals) #t)
|
||||
(set! next (gen-stream (pos-next pos)))
|
||||
(set! next empty-stream))
|
||||
next))))))
|
||||
(gen-stream init))]))
|
||||
|
||||
(define (sequence-generate g)
|
||||
(unless (sequence? g)
|
||||
(raise-type-error 'sequence-generate "sequence" g))
|
||||
|
@ -1249,14 +1487,14 @@
|
|||
;; loop bindings
|
||||
([lst lst])
|
||||
;; pos check
|
||||
(not (null? lst))
|
||||
(pair? lst)
|
||||
;; inner bindings
|
||||
([(id) (car lst)])
|
||||
([(id) (unsafe-car lst)])
|
||||
;; pre guard
|
||||
#t
|
||||
;; post guard
|
||||
#t
|
||||
;; loop args -- ok to use unsafe-cdr, since car passed
|
||||
;; loop args
|
||||
((unsafe-cdr lst)))]]
|
||||
[_ #f])))
|
||||
|
||||
|
@ -1285,6 +1523,31 @@
|
|||
((mcdr lst)))]]
|
||||
[_ #f])))
|
||||
|
||||
(define-sequence-syntax *in-stream
|
||||
(lambda () #'in-stream)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[[(id) (_ lst-expr)]
|
||||
#'[(id)
|
||||
(:do-in
|
||||
;;outer bindings
|
||||
([(lst) lst-expr])
|
||||
;; outer check
|
||||
(unless (stream? lst) (in-stream lst))
|
||||
;; loop bindings
|
||||
([lst lst])
|
||||
;; pos check
|
||||
(unsafe-stream-not-empty? lst)
|
||||
;; inner bindings
|
||||
([(id) (unsafe-stream-first lst)])
|
||||
;; pre guard
|
||||
#t
|
||||
;; post guard
|
||||
#t
|
||||
;; loop args
|
||||
((unsafe-stream-rest lst)))]]
|
||||
[_ #f])))
|
||||
|
||||
(define-sequence-syntax *in-indexed
|
||||
(lambda () #'in-indexed)
|
||||
(lambda (stx)
|
||||
|
|
|
@ -139,7 +139,9 @@
|
|||
define-in-vector-like
|
||||
define-:vector-like-gen
|
||||
make-in-vector-like
|
||||
normalise-inputs)
|
||||
normalise-inputs
|
||||
stream? stream-empty? stream-first stream-rest
|
||||
prop:stream in-stream empty-stream make-do-stream)
|
||||
(all-from "kernstruct.rkt")
|
||||
#%top-interaction
|
||||
|
||||
|
|
54
collects/racket/private/sequence.rkt
Normal file
54
collects/racket/private/sequence.rkt
Normal file
|
@ -0,0 +1,54 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Simple sequence functions that are also good enough
|
||||
;; for streams
|
||||
|
||||
(require "for.rkt")
|
||||
|
||||
(provide sequence-andmap
|
||||
sequence-ormap
|
||||
sequence-for-each
|
||||
sequence-fold
|
||||
sequence-count)
|
||||
|
||||
(define (sequence-andmap f s)
|
||||
(unless (procedure? f) (raise-type-error 'sequence-andmap "procedure" f))
|
||||
(unless (sequence? s) (raise-type-error 'sequence-andmap "sequence" s))
|
||||
(for/and ([vs (in-values*-sequence s)])
|
||||
(if (list? vs)
|
||||
(apply f vs)
|
||||
(f vs))))
|
||||
|
||||
(define (sequence-ormap f s)
|
||||
(unless (procedure? f) (raise-type-error 'sequence-ormap "procedure" f))
|
||||
(unless (sequence? s) (raise-type-error 'sequence-ormap "sequence" s))
|
||||
(for/or ([vs (in-values*-sequence s)])
|
||||
(if (list? vs)
|
||||
(apply f vs)
|
||||
(f vs))))
|
||||
|
||||
(define (sequence-for-each f s)
|
||||
(unless (procedure? f) (raise-type-error 'sequence-for-each "procedure" f))
|
||||
(unless (sequence? s) (raise-type-error 'sequence-for-each "sequence" s))
|
||||
(for ([vs (in-values*-sequence s)])
|
||||
(if (list? vs)
|
||||
(apply f vs)
|
||||
(f vs))))
|
||||
|
||||
(define (sequence-fold f i s)
|
||||
(unless (procedure? f) (raise-type-error 'sequence-fold "procedure" f))
|
||||
(unless (sequence? s) (raise-type-error 'sequence-fold "sequence" s))
|
||||
(for/fold ([i i]) ([vs (in-values*-sequence s)])
|
||||
(if (list? vs)
|
||||
(apply f i vs)
|
||||
(f i vs))))
|
||||
|
||||
(define (sequence-count f s)
|
||||
(unless (procedure? f) (raise-type-error 'sequence-count "procedure" f))
|
||||
(unless (sequence? s) (raise-type-error 'sequence-count "sequence" s))
|
||||
(for/fold ([i 0]) ([vs (in-values*-sequence s)])
|
||||
(if (if (list? vs)
|
||||
(apply f vs)
|
||||
(f vs))
|
||||
(add1 i)
|
||||
i)))
|
113
collects/racket/private/stream-cons.rkt
Normal file
113
collects/racket/private/stream-cons.rkt
Normal file
|
@ -0,0 +1,113 @@
|
|||
; Library streams/primitive
|
||||
; Adapted for PLT Scheme by Jacob J. A. Koot
|
||||
; from original version of Philip L. Bewig.
|
||||
; Further adapted by Matthew to allow any kind
|
||||
; of Racket stream as the rest of a lazy stream.
|
||||
|
||||
; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA. All rights
|
||||
; reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of
|
||||
; this software and associated documentation files (the "Software"), to deal in the Software
|
||||
; without restriction, including without limitation the rights to use, copy, modify, merge,
|
||||
; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
|
||||
; whom the Software is furnished to do so, subject to the following conditions: The above
|
||||
; copyright notice and this permission notice shall be included in all copies or substantial
|
||||
; portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
|
||||
; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
|
||||
; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
|
||||
; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
|
||||
; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
||||
#lang racket/base
|
||||
(require (prefix-in for: racket/private/for))
|
||||
|
||||
(provide stream-null stream-cons stream? stream-null? stream-pair?
|
||||
stream-car stream-cdr stream-lambda)
|
||||
|
||||
(define-syntax stream-lazy
|
||||
(syntax-rules ()
|
||||
((stream-lazy expr)
|
||||
(make-stream
|
||||
(mcons 'lazy (lambda () expr))))))
|
||||
|
||||
(define (stream-eager expr)
|
||||
(make-stream
|
||||
(mcons 'eager expr)))
|
||||
|
||||
(define-syntax stream-delay
|
||||
(syntax-rules ()
|
||||
((stream-delay expr)
|
||||
(stream-lazy (stream-eager expr)))))
|
||||
|
||||
(define (stream-force promise)
|
||||
(let ((content (stream-promise promise)))
|
||||
(case (mcar content)
|
||||
((eager) (mcdr content))
|
||||
((lazy) (let* ((promise* ((mcdr content))))
|
||||
;; check mcar again, it can it was set in the
|
||||
;; process of evaluating `(mcdr content)':
|
||||
(if (eq? (mcar content) 'eager)
|
||||
;; yes, it was set
|
||||
(mcdr content)
|
||||
;; normal case: no, it wasn't set:
|
||||
(if (stream? promise*)
|
||||
;; Flatten the result lazy stream and try again:
|
||||
(let ([new-content (stream-promise promise*)])
|
||||
(set-mcar! content (mcar new-content))
|
||||
(set-mcdr! content (mcdr new-content))
|
||||
(set-stream-promise! promise* content)
|
||||
(stream-force promise))
|
||||
;; Forced result is not a lazy stream:
|
||||
(begin
|
||||
(unless (for:stream? promise*)
|
||||
(raise-mismatch-error
|
||||
'stream-cons
|
||||
"rest expression produced a non-stream: "
|
||||
promise*))
|
||||
(set-mcdr! content promise*)
|
||||
(set-mcar! content 'eager)
|
||||
promise*))))))))
|
||||
|
||||
|
||||
(define-syntax stream-lambda
|
||||
(syntax-rules ()
|
||||
((stream-lambda formals body0 body1 ...)
|
||||
(lambda formals (stream-lazy (let () body0 body1 ...))))))
|
||||
|
||||
(define-struct stream-pare (kar kdr))
|
||||
|
||||
(define (stream-null? obj)
|
||||
(let ([v (stream-force obj)])
|
||||
(if (stream-pare? v)
|
||||
#f
|
||||
(or (eqv? v (stream-force stream-null))
|
||||
(for:stream-empty? v)))))
|
||||
|
||||
(define (stream-pair? obj)
|
||||
(and (stream? obj) (stream-pare? (stream-force obj))))
|
||||
|
||||
(define-syntax stream-cons
|
||||
(syntax-rules ()
|
||||
((stream-cons obj strm)
|
||||
(stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))))
|
||||
|
||||
(define (stream-car strm)
|
||||
(let ([v (stream-force strm)])
|
||||
(if (stream-pare? v)
|
||||
(stream-force (stream-pare-kar v))
|
||||
(for:stream-first v))))
|
||||
|
||||
(define (stream-cdr strm)
|
||||
(let ([v (stream-force strm)])
|
||||
(if (stream-pare? v)
|
||||
(stream-pare-kdr v)
|
||||
(for:stream-rest v))))
|
||||
|
||||
(define-struct stream (promise)
|
||||
#:mutable
|
||||
#:property for:prop:stream (vector
|
||||
stream-null?
|
||||
stream-car
|
||||
stream-cdr))
|
||||
|
||||
(define stream-null (stream-delay (cons 'stream 'null)))
|
99
collects/racket/sequence.rkt
Normal file
99
collects/racket/sequence.rkt
Normal file
|
@ -0,0 +1,99 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "stream.rkt"
|
||||
"private/sequence.rkt")
|
||||
|
||||
(provide empty-sequence
|
||||
sequence->list
|
||||
sequence-length
|
||||
sequence-ref
|
||||
sequence-tail
|
||||
sequence-append
|
||||
sequence-map
|
||||
sequence-andmap
|
||||
sequence-ormap
|
||||
sequence-for-each
|
||||
sequence-fold
|
||||
sequence-filter
|
||||
sequence-add-between
|
||||
sequence-count)
|
||||
|
||||
(define empty-sequence
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(values
|
||||
void
|
||||
void
|
||||
#f
|
||||
(λ (pos) #f)
|
||||
#f
|
||||
#f))))
|
||||
|
||||
(define (sequence->list s)
|
||||
(for/list ([v s]) v))
|
||||
|
||||
(define (sequence-length s)
|
||||
(unless (sequence? s) (raise-type-error 'sequence-length "sequence" s))
|
||||
(for/fold ([c 0]) ([i (in-values*-sequence s)])
|
||||
(add1 c)))
|
||||
|
||||
(define (sequence-ref s i)
|
||||
(unless (sequence? s) (raise-type-error 'sequence-ref "sequence" s))
|
||||
(unless (exact-nonnegative-integer? i)
|
||||
(raise-type-error 'sequence-ref "nonnegative exact integer" i))
|
||||
(let ([v (for/fold ([c #f]) ([v (in-values-sequence s)]
|
||||
[i (in-range (add1 i))])
|
||||
v)])
|
||||
(if (list? v)
|
||||
(apply values v)
|
||||
(raise-mismatch-error
|
||||
'sequence-ref
|
||||
(format "sequence ended before element ~e: "
|
||||
(add1 i))
|
||||
s))))
|
||||
|
||||
(define (sequence-tail seq i)
|
||||
(unless (sequence? seq) (raise-type-error 'sequence-tail "sequence" seq))
|
||||
(unless (exact-nonnegative-integer? i)
|
||||
(raise-type-error 'sequence-tail "nonnegative exact integer" i))
|
||||
(cond
|
||||
[(zero? i) seq]
|
||||
[else (let loop ([s (sequence->stream seq)] [n i])
|
||||
(cond
|
||||
[(zero? n) (in-stream s)]
|
||||
[(stream-empty? s)
|
||||
(raise-mismatch-error
|
||||
'sequence-ref
|
||||
(format "sequence ended before ~e element~a: "
|
||||
i
|
||||
(if (= i 1) "" "s"))
|
||||
seq)]
|
||||
[else (loop (stream-rest s)
|
||||
(sub1 n))]))]))
|
||||
|
||||
(define (sequence-append . l)
|
||||
(if (null? l)
|
||||
empty-stream
|
||||
(if (andmap stream? l)
|
||||
(apply stream-append l)
|
||||
(apply in-sequences l))))
|
||||
|
||||
(define (sequence-map f s)
|
||||
(unless (procedure? f)
|
||||
(raise-type-error 'sequence-map "expects a procedure as the first argument, given ~e" f))
|
||||
(if (stream? s)
|
||||
(stream-map f s)
|
||||
(in-stream (stream-map f (sequence->stream s)))))
|
||||
|
||||
(define (sequence-filter f s)
|
||||
(unless (procedure? f) (raise-type-error 'sequence-filter "procedure" f))
|
||||
(unless (sequence? s) (raise-type-error 'sequence-filter "sequence" s))
|
||||
(if (stream? s)
|
||||
(stream-filter f s)
|
||||
(in-stream (stream-filter f (sequence->stream s)))))
|
||||
|
||||
(define (sequence-add-between s e)
|
||||
(unless (sequence? s) (raise-type-error 'sequence-ad-between "sequence" s))
|
||||
(if (stream? s)
|
||||
(stream-add-between s e)
|
||||
(in-stream (stream-add-between (sequence->stream s) e))))
|
|
@ -1,252 +1,155 @@
|
|||
(module stream "private/pre-base.rkt"
|
||||
(require "private/list.rkt")
|
||||
#lang racket/base
|
||||
|
||||
(require "private/for.rkt"
|
||||
"private/sequence.rkt"
|
||||
(only-in "private/stream-cons.rkt"
|
||||
stream-cons))
|
||||
|
||||
(provide empty-stream
|
||||
stream-cons
|
||||
stream?
|
||||
stream-empty?
|
||||
stream-first
|
||||
stream-rest
|
||||
prop:stream
|
||||
in-stream
|
||||
|
||||
stream->list
|
||||
stream-length
|
||||
stream-ref
|
||||
stream-tail
|
||||
stream-append
|
||||
stream-map
|
||||
stream-andmap
|
||||
stream-ormap
|
||||
stream-for-each
|
||||
stream-fold
|
||||
stream-filter
|
||||
stream-add-between
|
||||
stream-count)
|
||||
|
||||
(define empty-stream
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(values
|
||||
void
|
||||
void
|
||||
void
|
||||
(λ (pos) #f)
|
||||
(λ (val) #t)
|
||||
(λ (pos val) #t)))))
|
||||
(define (stream->list s)
|
||||
(for/list ([v (in-stream s)]) v))
|
||||
|
||||
(define (stream->list s)
|
||||
(for/list ([v s]) v))
|
||||
(define (stream-length s)
|
||||
(unless (stream? s) (raise-type-error 'stream-length "stream" s))
|
||||
(let loop ([s s] [len 0])
|
||||
(if (stream-empty? s)
|
||||
len
|
||||
(loop (stream-rest s) (add1 len)))))
|
||||
|
||||
(define (stream-ref st i)
|
||||
(unless (stream? st) (raise-type-error 'stream-ref "stream" st))
|
||||
(unless (exact-nonnegative-integer? i)
|
||||
(raise-type-error 'stream-ref "nonnegative exact integer" i))
|
||||
(let loop ([n i] [s st])
|
||||
(cond
|
||||
[(stream-empty? s)
|
||||
(raise-mismatch-error 'stream-ref
|
||||
(format "sequence ended before element ~e: "
|
||||
(add1 i))
|
||||
st)]
|
||||
[(zero? n)
|
||||
(stream-first s)]
|
||||
[else
|
||||
(loop (sub1 n) (stream-rest s))])))
|
||||
|
||||
(define-syntax-rule (-stream-cons vs s)
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(values
|
||||
(λ (pos)
|
||||
(if (zero? pos)
|
||||
vs
|
||||
(next)))
|
||||
(λ (pos) (if (zero? pos) 1 pos))
|
||||
0
|
||||
(λ (pos)
|
||||
(or (zero? pos) (more?)))
|
||||
(λ _ #t)
|
||||
(λ _ #t)))))
|
||||
(define stream-cons
|
||||
(case-lambda
|
||||
[()
|
||||
(error 'stream-cons "expects a sequence to extend, but received no arguments")]
|
||||
[(s)
|
||||
(-stream-cons (values) s)]
|
||||
[(v s)
|
||||
(-stream-cons (values v) s)]
|
||||
[vs*s
|
||||
; XXX double reverse is bad but moving split-at causes a problem I can't figure
|
||||
(define s*vs (reverse vs*s))
|
||||
(-stream-cons (apply values (reverse (cdr s*vs))) (car s*vs))]))
|
||||
(define (stream-tail st i)
|
||||
(unless (stream? st) (raise-type-error 'stream-tail "stream" st))
|
||||
(unless (exact-nonnegative-integer? i)
|
||||
(raise-type-error 'stream-tail "nonnegative exact integer" i))
|
||||
(let loop ([n i] [s st])
|
||||
(cond
|
||||
[(zero? n) s]
|
||||
[(stream-empty? s)
|
||||
(raise-mismatch-error
|
||||
'stream-tail
|
||||
(format "sequence ended before ~e element~a: "
|
||||
i
|
||||
(if (= i 1) "" "s"))
|
||||
st)]
|
||||
[else
|
||||
(loop (sub1 n) (stream-rest s))])))
|
||||
|
||||
(define (stream-append . l)
|
||||
(for ([s (in-list l)])
|
||||
(unless (stream? s) (raise-type-error 'stream-append "stream" s)))
|
||||
(streams-append l))
|
||||
|
||||
(define (streams-append l)
|
||||
(cond
|
||||
[(null? l) empty-stream]
|
||||
[(stream-empty? (car l)) (streams-append (cdr l))]
|
||||
[else
|
||||
(make-do-stream (lambda () #f)
|
||||
(lambda () (stream-first (car l)))
|
||||
(lambda () (streams-append (cons (stream-rest (car l)) (cdr l)))))]))
|
||||
|
||||
(define (stream-first s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(unless (more?)
|
||||
(error 'stream-first "expects a sequence with at least one element"))
|
||||
(next))
|
||||
(define (stream-map f s)
|
||||
(unless (procedure? f) (raise-type-error 'stream-map "procedure" f))
|
||||
(unless (stream? s) (raise-type-error 'stream-map "stream" s))
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(stream-empty? s) empty-stream]
|
||||
[else (stream-cons (call-with-values (lambda () (stream-first s)) f)
|
||||
(loop (stream-rest s)))])))
|
||||
|
||||
(define (stream-rest s)
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(unless (more?)
|
||||
(error 'stream-rest "expects a sequence with at least one element"))
|
||||
(next)
|
||||
(values
|
||||
(λ (pos) (next))
|
||||
(λ (x) x)
|
||||
0
|
||||
(λ (pos) (more?))
|
||||
(λ _ #t)
|
||||
(λ _ #t)))))
|
||||
(define (stream-andmap f s)
|
||||
(unless (procedure? f) (raise-type-error 'stream-andmap "procedure" f))
|
||||
(unless (stream? s) (raise-type-error 'stream-andmap "stream" s))
|
||||
(sequence-andmap f s))
|
||||
|
||||
(define (stream-length s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ([i 0])
|
||||
(if (more?)
|
||||
(begin (next) (loop (add1 i)))
|
||||
i)))
|
||||
(define (stream-ormap f s)
|
||||
(unless (procedure? f) (raise-type-error 'stream-ormap "procedure" f))
|
||||
(unless (stream? s) (raise-type-error 'stream-ormap "stream" s))
|
||||
(sequence-ormap f s))
|
||||
|
||||
(define (stream-ref s i)
|
||||
(unless (and (exact-integer? i) (i . >= . 0))
|
||||
(error 'stream-ref "expects an exact non-negative index, but got ~e" i))
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ([n i])
|
||||
(cond
|
||||
[(zero? n)
|
||||
(next)]
|
||||
[(more?)
|
||||
(next)
|
||||
(loop (sub1 n))]
|
||||
[else
|
||||
(error 'stream-ref "expects a sequence with at least ~e element(s)" i)])))
|
||||
(define (stream-for-each f s)
|
||||
(unless (procedure? f) (raise-type-error 'stream-for-each "procedure" f))
|
||||
(unless (stream? s) (raise-type-error 'stream-for-each "stream" s))
|
||||
(sequence-for-each f s))
|
||||
|
||||
(define (stream-tail s i)
|
||||
(unless (and (exact-integer? i) (i . >= . 0))
|
||||
(error 'stream-tail "expects an exact non-negative index, but got ~e" i))
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ([n i])
|
||||
(unless (zero? n)
|
||||
(unless (more?)
|
||||
(error 'stream-tail "expects a sequence with at least ~e element(s)" i))
|
||||
(next)
|
||||
(loop (sub1 n))))
|
||||
(values
|
||||
(λ (pos) (next))
|
||||
(λ (x) x)
|
||||
0
|
||||
(λ (pos) (more?))
|
||||
(λ _ #t)
|
||||
(λ _ #t)))))
|
||||
(define (stream-fold f i s)
|
||||
(unless (procedure? f) (raise-type-error 'stream-fold "procedure" f))
|
||||
(unless (stream? s) (raise-type-error 'stream-fold "stream" s))
|
||||
(sequence-fold f i s))
|
||||
|
||||
(define (stream-count f s)
|
||||
(unless (procedure? f) (raise-type-error 'stream-count "procedure" f))
|
||||
(unless (stream? s) (raise-type-error 'stream-count "stream" s))
|
||||
(sequence-count f s))
|
||||
|
||||
(define (-stream-append s0 l)
|
||||
(if (null? l)
|
||||
s0
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(define remaining l)
|
||||
(define (next-pos pos)
|
||||
(cond
|
||||
[(more?)
|
||||
#t]
|
||||
[(null? remaining)
|
||||
#f]
|
||||
[else
|
||||
(let*-values ([(s1) (car remaining)]
|
||||
[(next-more? next-next) (sequence-generate s1)])
|
||||
(set! more? next-more?)
|
||||
(set! next next-next)
|
||||
(set! remaining (cdr remaining))
|
||||
(next-pos pos))]))
|
||||
(define-values (more? next) (sequence-generate s0))
|
||||
(values
|
||||
(λ (pos) (next))
|
||||
(λ (x) x)
|
||||
0
|
||||
next-pos
|
||||
(λ _ #t)
|
||||
(λ _ #t))))))
|
||||
(define (stream-filter f s)
|
||||
(unless (procedure? f) (raise-type-error 'stream-filter "procedure" f))
|
||||
(unless (stream? s) (raise-type-error 'stream-filter "stream" s))
|
||||
(cond
|
||||
[(stream-empty? s) empty-stream]
|
||||
[else
|
||||
(let ([done? #f]
|
||||
[empty? #f]
|
||||
[fst #f]
|
||||
[rst #f])
|
||||
(define (force!)
|
||||
(unless done?
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(stream-empty? s)
|
||||
(set! done? #t)
|
||||
(set! empty? #t)]
|
||||
[(f (stream-first s))
|
||||
(set! fst (stream-first s))
|
||||
(set! rst (stream-filter f (stream-rest s)))]
|
||||
[else (loop (stream-rest s))]))
|
||||
(set! done? #t)))
|
||||
(make-do-stream (lambda () (force!) empty?)
|
||||
(lambda () (force!) fst)
|
||||
(lambda () (force!) rst)))]))
|
||||
|
||||
(define (stream-append . l)
|
||||
(unless (andmap sequence? l)
|
||||
(error 'stream-append "expects only sequence arguments, given ~e" l))
|
||||
(-stream-append empty-stream l))
|
||||
|
||||
(define (stream-map f s)
|
||||
(unless (procedure? f)
|
||||
(error 'stream-map "expects a procedure as the first argument, given ~e" f))
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(values
|
||||
(λ (pos) (call-with-values next f))
|
||||
(λ (x) x)
|
||||
0
|
||||
(λ (pos) (more?))
|
||||
(λ _ #t)
|
||||
(λ _ #t)))))
|
||||
|
||||
(define (stream-andmap f s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ()
|
||||
(if (more?)
|
||||
(and (call-with-values next f) (loop))
|
||||
#t)))
|
||||
|
||||
(define (stream-ormap f s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ()
|
||||
(if (more?)
|
||||
(or (call-with-values next f) (loop))
|
||||
#f)))
|
||||
|
||||
(define (stream-for-each f s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ()
|
||||
(when (more?)
|
||||
(call-with-values next f)
|
||||
(loop))))
|
||||
|
||||
(define (stream-fold f i s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ([i i])
|
||||
(if (more?)
|
||||
(loop (call-with-values next (λ e (apply f i e))))
|
||||
i)))
|
||||
|
||||
(define (stream-filter f s)
|
||||
(unless (procedure? f)
|
||||
(error 'stream-filter "expects a procedure as the first argument, given ~e" f))
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(define next-vs #f)
|
||||
(define (next-pos pos)
|
||||
(if (more?)
|
||||
(call-with-values next
|
||||
(λ vs
|
||||
(if (apply f vs)
|
||||
(begin (set! next-vs vs)
|
||||
#t)
|
||||
(next-pos pos))))
|
||||
#f))
|
||||
(values
|
||||
(λ (pos) (apply values next-vs))
|
||||
(λ (x) x)
|
||||
0
|
||||
next-pos
|
||||
(λ _ #t)
|
||||
(λ _ #t)))))
|
||||
|
||||
(define (stream-add-between s e)
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(values
|
||||
(λ (pos)
|
||||
(if pos
|
||||
(next)
|
||||
e))
|
||||
not
|
||||
#t
|
||||
(λ (pos)
|
||||
(if pos
|
||||
(more?)
|
||||
#t))
|
||||
(λ _ #t)
|
||||
(λ _ #t)))))
|
||||
|
||||
(define (stream-count f s)
|
||||
(unless (procedure? f)
|
||||
(error 'stream-count "expects a procedure as the first argument, given ~e" f))
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ([n 0])
|
||||
(if (more?)
|
||||
(if (call-with-values next f)
|
||||
(loop (add1 n))
|
||||
(loop n))
|
||||
n)))
|
||||
|
||||
(provide empty-stream
|
||||
stream->list
|
||||
stream-cons
|
||||
stream-first
|
||||
stream-rest
|
||||
stream-length
|
||||
stream-ref
|
||||
stream-tail
|
||||
stream-append
|
||||
stream-map
|
||||
stream-andmap
|
||||
stream-ormap
|
||||
stream-for-each
|
||||
stream-fold
|
||||
stream-filter
|
||||
stream-add-between
|
||||
stream-count))
|
||||
(define (stream-add-between s e)
|
||||
(unless (stream? s)
|
||||
(raise-type-error 'stream-add-between "stream" s))
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(stream-empty? s) empty-stream]
|
||||
[else (stream-cons (stream-first s)
|
||||
(stream-cons e (loop (stream-rest s))))])))
|
||||
|
|
|
@ -9,14 +9,26 @@
|
|||
@margin-note{See @secref[where] for information on using @|what| as
|
||||
sequences.})
|
||||
|
||||
@title[#:tag "sequences"]{Sequences}
|
||||
@title[#:style 'toc #:tag "sequences+streams"]{Sequences and Streams}
|
||||
|
||||
@tech{Sequences} and @tech{streams} abstract over iteration of
|
||||
elements in a collection. Streams are functional sequences that can be
|
||||
used either in a generic way or a stream-specific
|
||||
way. @tech{Generators} are closely related stateful objects that can
|
||||
be converted to a sequence and vice-versa.
|
||||
|
||||
@local-table-of-contents[]
|
||||
|
||||
@; ======================================================================
|
||||
@section[#:tag "sequences"]{Sequences}
|
||||
|
||||
@guideintro["sequences"]{sequences}
|
||||
|
||||
A @deftech{sequence} encapsulates an ordered stream of values. The
|
||||
elements of a sequence can be extracted with one of the @scheme[for]
|
||||
syntactic forms or with the procedures returned by
|
||||
@scheme[sequence-generate].
|
||||
A @deftech{sequence} encapsulates an ordered collection of values.
|
||||
The elements of a sequence can be extracted with one of the
|
||||
@scheme[for] syntactic forms, with the procedures returned by
|
||||
@scheme[sequence-generate], or by converting the sequence into a
|
||||
@tech{stream}.
|
||||
|
||||
The sequence datatype overlaps with many other datatypes. Among
|
||||
built-in datatypes, the sequence datatype includes the following:
|
||||
|
@ -45,9 +57,10 @@ built-in datatypes, the sequence datatype includes the following:
|
|||
|
||||
]
|
||||
|
||||
In addition, @scheme[make-do-sequence] creates a sequence given a thunk
|
||||
that returns procedures to implement a sequence, and the
|
||||
@scheme[prop:sequence] property can be associated with a structure type.
|
||||
The @scheme[make-do-sequence] function creates a sequence given a
|
||||
thunk that returns procedures to implement a sequence, and the
|
||||
@scheme[prop:sequence] property can be associated with a structure
|
||||
type to implement its implicit conversion to a sequence.
|
||||
|
||||
For most sequence types, extracting elements from a sequence has no
|
||||
side-effect on the original sequence value; for example, extracting the
|
||||
|
@ -62,15 +75,15 @@ hash table generates two values---a key and its value---for each element
|
|||
in the sequence.
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
@section{Sequence Predicate and Constructors}
|
||||
@subsection{Sequence Predicate and Constructors}
|
||||
|
||||
@defproc[(sequence? [v any/c]) boolean?]{
|
||||
Return @scheme[#t] if @scheme[v] can be used as a sequence,
|
||||
Returns @scheme[#t] if @scheme[v] can be used as a @tech{sequence},
|
||||
@scheme[#f] otherwise.}
|
||||
|
||||
@defproc*[([(in-range [end number?]) sequence?]
|
||||
[(in-range [start number?] [end number?] [step number? 1]) sequence?])]{
|
||||
Returns a sequence whose elements are numbers. The single-argument
|
||||
@defproc*[([(in-range [end number?]) stream?]
|
||||
[(in-range [start number?] [end number?] [step number? 1]) stream?])]{
|
||||
Returns a sequence (that is also a @tech{stream}) whose elements are numbers. The single-argument
|
||||
case @scheme[(in-range end)] is equivalent to @scheme[(in-range 0 end
|
||||
1)]. The first number in the sequence is @scheme[start], and each
|
||||
successive element is generated by adding @scheme[step] to the
|
||||
|
@ -79,13 +92,14 @@ in the sequence.
|
|||
less or equal to @scheme[end] if @scheme[step] is negative.
|
||||
@speed[in-range "number"]}
|
||||
|
||||
@defproc[(in-naturals [start exact-nonnegative-integer? 0]) sequence?]{
|
||||
Returns an infinite sequence of exact integers starting with
|
||||
@defproc[(in-naturals [start exact-nonnegative-integer? 0]) stream?]{
|
||||
Returns an infinite sequence (that is also a @tech{stream}) of exact integers starting with
|
||||
@scheme[start], where each element is one more than the preceding
|
||||
element. @speed[in-naturals "integer"]}
|
||||
|
||||
@defproc[(in-list [lst list?]) sequence?]{
|
||||
Returns a sequence equivalent to @scheme[lst].
|
||||
@defproc[(in-list [lst list?]) stream?]{
|
||||
Returns a sequence (that is also a @tech{stream}) that is equivalent
|
||||
to using @scheme[lst] directly as a sequence.
|
||||
@info-on-seq["pairs" "lists"]
|
||||
@speed[in-list "list"]}
|
||||
|
||||
|
@ -273,6 +287,19 @@ in the sequence.
|
|||
each @scheme[seq]. The elements of each @scheme[seq] must be
|
||||
single-valued.}
|
||||
|
||||
@defproc[(in-values-sequence [seq sequence?]) sequence?]{
|
||||
Returns a sequence that is like @racket[seq], but it combines
|
||||
multiple values for each element from @racket[seq] as a list of
|
||||
elements.}
|
||||
|
||||
@defproc[(in-values*-sequence [seq sequence?]) sequence?]{
|
||||
Returns a sequence that is like @racket[seq], but when an element of
|
||||
@racket[seq] has multiple values or a single list value, then the
|
||||
values are combined in a list. In other words,
|
||||
@racket[in-values*-sequence] is like @racket[in-values-sequence],
|
||||
except that non-list, single-valued elements are not wrapped in a
|
||||
list.}
|
||||
|
||||
@defproc[(stop-before [seq sequence?] [pred (any/c . -> . any)])
|
||||
sequence?]{
|
||||
Returns a sequence that contains the elements of @scheme[seq] (which
|
||||
|
@ -363,7 +390,19 @@ in the sequence.
|
|||
c)]]}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
@section{Sequence Generators}
|
||||
@subsection{Sequence Conversion}
|
||||
|
||||
@defproc[(sequence->stream [seq sequence?]) stream?]{
|
||||
Coverts a sequence to a @tech{stream}, which supports the
|
||||
@racket[stream-first] and @racket[stream-rest] operations. The
|
||||
stream lazily draws elements from the sequence, caching each element
|
||||
so that @racket[stream-first] produces the same result each time
|
||||
is applied to a stream.
|
||||
|
||||
In extracting an element from @racket[seq] involves a side-effect,
|
||||
then the effect is performed each time that either
|
||||
@racket[stream-first] or @racket[stream-rest] is first used to
|
||||
access or skip an element.}
|
||||
|
||||
@defproc[(sequence-generate [seq sequence?])
|
||||
(values (-> boolean?) (-> any))]{
|
||||
|
@ -374,121 +413,262 @@ in the sequence.
|
|||
@exnraise[exn:fail:contract].}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
@section[#:tag "streams"]{Streams}
|
||||
@subsection[#:tag "more-sequences"]{Sequence Combinations}
|
||||
|
||||
@note-lib[racket/stream]
|
||||
@note-lib[racket/sequence]
|
||||
|
||||
Warning: the interface that this library implements is dealing with
|
||||
sequences, not with lazy lists. (In the future, lazy lists will become
|
||||
a valid kind of sequence, hence the naming of these functions.) Note
|
||||
also that some of these operations can result in serious efficiency
|
||||
penalties, for example, each use of @racket[stream-rest] adds a constant
|
||||
overhead for accessing the resulting sequence.
|
||||
|
||||
@defthing[empty-stream sequence?]{
|
||||
@defthing[empty-sequence sequence?]{
|
||||
A sequence with no elements.}
|
||||
|
||||
@defproc[(stream->list [s sequence?]) list?]{
|
||||
Returns a list whose elements are the elements of the @scheme[s],
|
||||
which must be a one-valued sequence. If @scheme[s] is infinite, this
|
||||
@defproc[(sequence->list [s sequence?]) list?]{
|
||||
Returns a list whose elements are the elements of @scheme[s],
|
||||
each of which must be a single value. If @scheme[s] is infinite, this
|
||||
function does not terminate.}
|
||||
|
||||
@defproc[(stream-cons [v any/c]
|
||||
...
|
||||
[s sequence?])
|
||||
sequence?]{
|
||||
Returns a sequence whose first element is @scheme[(values v ...)] and whose
|
||||
remaining elements are the same as @scheme[s].}
|
||||
|
||||
@defproc[(stream-first [s sequence?])
|
||||
(values any/c ...)]{
|
||||
Returns the first element of @scheme[s].}
|
||||
|
||||
@defproc[(stream-rest [s sequence?])
|
||||
sequence?]{
|
||||
Returns a sequence equivalent to @scheme[s], except the first element
|
||||
is omitted.}
|
||||
|
||||
@defproc[(stream-length [s sequence?])
|
||||
@defproc[(sequence-length [s sequence?])
|
||||
exact-nonnegative-integer?]{
|
||||
Returns the number of elements of @scheme[s]. If @scheme[s] is
|
||||
infinite, this function does not terminate.}
|
||||
Returns the number of elements of @scheme[s] by extracting and
|
||||
discarding all of them. If @scheme[s] is infinite, this function
|
||||
does not terminate.}
|
||||
|
||||
@defproc[(stream-ref [s sequence?] [i exact-nonnegative-integer?])
|
||||
(values any/c ...)]{
|
||||
Returns the @scheme[i]th element of @scheme[s].}
|
||||
@defproc[(sequence-ref [s sequence?] [i exact-nonnegative-integer?])
|
||||
any]{
|
||||
Returns the @scheme[i]th element of @scheme[s] (which may be
|
||||
multiple values).}
|
||||
|
||||
@defproc[(stream-tail [s sequence?] [i exact-nonnegative-integer?])
|
||||
@defproc[(sequence-tail [s sequence?] [i exact-nonnegative-integer?])
|
||||
sequence?]{
|
||||
Returns a sequence equivalent to @scheme[s], except the first
|
||||
@scheme[i] elements are omitted.}
|
||||
Returns a sequence equivalent to @scheme[s], except that the first
|
||||
@scheme[i] elements are omitted.
|
||||
|
||||
@defproc[(stream-append [s sequence?] ...)
|
||||
In case extracting elements from @racket[s] involves a side effect,
|
||||
they will not be extracted until the first element is extracted from
|
||||
the resulting sequence.}
|
||||
|
||||
@defproc[(sequence-append [s sequence?] ...)
|
||||
sequence?]{
|
||||
Returns a sequence that contains all elements of each sequence in the
|
||||
order they appear in the original sequences. The new sequence is
|
||||
constructed lazily.
|
||||
|
||||
If all given @racket[s]s are @tech{streams}, the result is also a
|
||||
@tech{stream}.}
|
||||
|
||||
@defproc[(sequence-map [f procedure?]
|
||||
[s sequence?])
|
||||
sequence?]{
|
||||
Returns a sequence that contains @scheme[f] applied to each element of
|
||||
@scheme[s]. The new sequence is constructed lazily.
|
||||
|
||||
If @racket[s] is a @tech{stream}, then the result is also a
|
||||
@tech{stream}.}
|
||||
|
||||
@defproc[(sequence-andmap [f (-> any/c ... boolean?)]
|
||||
[s sequence?])
|
||||
boolean?]{
|
||||
Returns @scheme[#t] if @scheme[f] returns a true result on every
|
||||
element of @scheme[s]. If @scheme[s] is infinite and @scheme[f] never
|
||||
returns a false result, this function does not terminate.}
|
||||
|
||||
@defproc[(sequence-ormap [f (-> any/c ... boolean?)]
|
||||
[s sequence?])
|
||||
boolean?]{
|
||||
Returns @scheme[#t] if @scheme[f] returns a true result on some
|
||||
element of @scheme[s]. If @scheme[s] is infinite and @scheme[f] never
|
||||
returns a true result, this function does not terminate.}
|
||||
|
||||
@defproc[(sequence-for-each [f (-> any/c ... any)]
|
||||
[s sequence?])
|
||||
(void)]{
|
||||
Applies @scheme[f] to each element of @scheme[s]. If @scheme[s] is
|
||||
infinite, this function does not terminate.}
|
||||
|
||||
@defproc[(sequence-fold [f (-> any/c any/c ... any/c)]
|
||||
[i any/c]
|
||||
[s sequence?])
|
||||
(void)]{
|
||||
Folds @scheme[f] over each element of @scheme[s] with @scheme[i] as
|
||||
the initial accumulator. If @scheme[s] is infinite, this function
|
||||
does not terminate.}
|
||||
|
||||
@defproc[(sequence-count [f procedure?] [s sequence?])
|
||||
exact-nonnegative-integer?]{
|
||||
Returns the number of elements in @scheme[s] for which @scheme[f]
|
||||
returns a true result. If @scheme[s] is infinite, this function does
|
||||
not terminate.}
|
||||
|
||||
@defproc[(sequence-filter [f (-> any/c ... boolean?)]
|
||||
[s sequence?])
|
||||
sequence?]{
|
||||
Returns a sequence whose elements are the elements of @scheme[s] for
|
||||
which @scheme[f] returns a true result. Although the new sequence is
|
||||
constructed lazily, if @scheme[s] has an infinite number of elements
|
||||
where @scheme[f] returns a false result in between two elements where
|
||||
@scheme[f] returns a true result, then operations on this sequence will
|
||||
not terminate during the infinite sub-sequence.
|
||||
|
||||
If @racket[s] is a @tech{stream}, then the result is also a
|
||||
@tech{stream}.}
|
||||
|
||||
@defproc[(sequence-add-between [s sequence?] [e any/c])
|
||||
sequence?]{
|
||||
Returns a sequence whose elements are the elements of @scheme[s],
|
||||
but with @scheme[e] between each pair of elements in @racket[s].
|
||||
The new sequence is constructed lazily.
|
||||
|
||||
If @racket[s] is a @tech{stream}, then the result is also a
|
||||
@tech{stream}.}
|
||||
|
||||
@; ======================================================================
|
||||
@section[#:tag "streams"]{Streams}
|
||||
|
||||
A @deftech{stream} is a kind of sequence that supports functional
|
||||
iteration via @racket[stream-first] and @racket[stream-rest]. The
|
||||
@racket[stream-cons] form constructs a lazy stream, but plain lists
|
||||
can be used as stream, and functions such as @racket[in-range] and
|
||||
@racket[in-naturals] also create streams.
|
||||
|
||||
@note-lib[racket/stream]
|
||||
|
||||
@defproc[(stream? [v any/c]) boolean?]{
|
||||
Returns @scheme[#t] if @scheme[v] can be used as a @tech{stream},
|
||||
@scheme[#f] otherwise.}
|
||||
|
||||
@defproc[(stream-empty? [s stream?]) boolean?]{
|
||||
Returns @racket[#f] if @racket[s] has no elements, @racket[#f]
|
||||
otherwise.
|
||||
}
|
||||
|
||||
@defproc[(stream-first [s (and/c stream? (not/c stream-empty?))]) any]{
|
||||
Returns the value(s) of the first element in @racket[s].
|
||||
}
|
||||
|
||||
@defproc[(stream-rest [s (and/c stream? (not/c stream-empty?))]) stream?]{
|
||||
Returns a stream that is equivalent to @racket[s] without its
|
||||
first element.
|
||||
}
|
||||
|
||||
@defform[(stream-cons first-expr rest-expr)]{
|
||||
|
||||
Produces a lazy stream for which @racket[stream-first] forces the
|
||||
evaluation of @racket[first-expr] to produce the first element of the
|
||||
stream, and @racket[stream-rest] forces the evaluation of
|
||||
@racket[rest-expr] to produce a stream for the rest of the returned
|
||||
stream.
|
||||
|
||||
The first element of the stream as produced by @racket[first-expr]
|
||||
must be a single value. The @racket[rest-expr] must produce a stream
|
||||
when it is evaluated, otherwise the @exnraise[exn:fail:contract?].}
|
||||
|
||||
@defproc[(in-stream [s stream?]) sequence?]{
|
||||
Returns a sequence that is equivalent to @racket[s].
|
||||
@speed[in-stream "streams"]}
|
||||
|
||||
@defthing[empty-stream stream?]{
|
||||
A stream with no elements.}
|
||||
|
||||
@defproc[(stream->list [s stream?]) list?]{
|
||||
Returns a list whose elements are the elements of @scheme[s],
|
||||
each of which must be a single value. If @scheme[s] is infinite, this
|
||||
function does not terminate.}
|
||||
|
||||
@defproc[(stream-length [s stream?])
|
||||
exact-nonnegative-integer?]{
|
||||
Returns the number of elements of @scheme[s]. If @scheme[s] is
|
||||
infinite, this function does not terminate.
|
||||
|
||||
In the case of lazy streams, this function forces evaluation only of
|
||||
the sub-streams, and not the stream's elements.}
|
||||
|
||||
@defproc[(stream-ref [s stream?] [i exact-nonnegative-integer?])
|
||||
any]{
|
||||
Returns the @scheme[i]th element of @scheme[s] (which may be
|
||||
multiple values).}
|
||||
|
||||
@defproc[(stream-tail [s stream?] [i exact-nonnegative-integer?])
|
||||
stream?]{
|
||||
Returns a stream equivalent to @scheme[s], except that the first
|
||||
@scheme[i] elements are omitted.
|
||||
|
||||
In case extracting elements from @racket[s] involves a side effect,
|
||||
they will not be extracted until the first element is extracted from
|
||||
the resulting stream.}
|
||||
|
||||
@defproc[(stream-append [s stream?] ...)
|
||||
stream?]{
|
||||
Returns a stream that contains all elements of each stream in the
|
||||
order they appear in the original streams. The new stream is
|
||||
constructed lazily.}
|
||||
|
||||
@defproc[(stream-map [f procedure?]
|
||||
[s sequence?])
|
||||
sequence?]{
|
||||
Returns a sequence that contains @scheme[f] applied to each element of
|
||||
@scheme[s]. The new sequence is constructed lazily.}
|
||||
[s stream?])
|
||||
stream?]{
|
||||
Returns a stream that contains @scheme[f] applied to each element of
|
||||
@scheme[s]. The new stream is constructed lazily.}
|
||||
|
||||
@defproc[(stream-andmap [f (-> any/c ... boolean?)]
|
||||
[s sequence?])
|
||||
[s stream?])
|
||||
boolean?]{
|
||||
Returns @scheme[#t] if @scheme[f] returns a true result on every
|
||||
element of @scheme[s]. If @scheme[s] is infinite and @scheme[f] never
|
||||
returns a false result, this function does not terminate.}
|
||||
|
||||
@defproc[(stream-ormap [f (-> any/c ... boolean?)]
|
||||
[s sequence?])
|
||||
[s stream?])
|
||||
boolean?]{
|
||||
Returns @scheme[#t] if @scheme[f] returns a true result on some
|
||||
element of @scheme[s]. If @scheme[s] is infinite and @scheme[f] never
|
||||
returns a true result, this function does not terminate.}
|
||||
|
||||
@defproc[(stream-for-each [f (-> any/c ... any)]
|
||||
[s sequence?])
|
||||
[s stream?])
|
||||
(void)]{
|
||||
Applies @scheme[f] to each element of @scheme[s]. If @scheme[s] is
|
||||
infinite, this function does not terminate.}
|
||||
|
||||
@defproc[(stream-fold [f (-> any/c any/c ... any/c)]
|
||||
[i any/c]
|
||||
[s sequence?])
|
||||
[s stream?])
|
||||
(void)]{
|
||||
Folds @scheme[f] over each element of @scheme[s] with @scheme[i] as
|
||||
the initial accumulator. If @scheme[s] is infinite, this function
|
||||
does not terminate.}
|
||||
|
||||
@defproc[(stream-filter [f (-> any/c ... boolean?)]
|
||||
[s sequence?])
|
||||
sequence?]{
|
||||
Returns a sequence whose elements are the elements of @scheme[s] for
|
||||
which @scheme[f] returns a true result. Although the new sequence is
|
||||
constructed lazily, if @scheme[s] has an infinite number of elements
|
||||
where @scheme[f] returns a false result in between two elements where
|
||||
@scheme[f] returns a true result then operations on this sequence will
|
||||
not terminate during that infinite sub-sequence.}
|
||||
|
||||
@defproc[(stream-add-between [s sequence?] [e any/c])
|
||||
sequence?]{
|
||||
Returns a sequence whose elements are the elements of @scheme[s],
|
||||
but with @scheme[e] between each pair of elements in @racket[s].
|
||||
The new sequence is constructed lazily.}
|
||||
|
||||
@defproc[(stream-count [f procedure?] [s sequence?])
|
||||
@defproc[(stream-count [f procedure?] [s stream?])
|
||||
exact-nonnegative-integer?]{
|
||||
Returns the number of elements in @scheme[s] for which @scheme[f]
|
||||
returns a true result. If @scheme[s] is infinite, this function does
|
||||
not terminate.}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
@section{Iterator Generators}
|
||||
@defproc[(stream-filter [f (-> any/c ... boolean?)]
|
||||
[s stream?])
|
||||
stream?]{
|
||||
Returns a stream whose elements are the elements of @scheme[s] for
|
||||
which @scheme[f] returns a true result. Although the new stream is
|
||||
constructed lazily, if @scheme[s] has an infinite number of elements
|
||||
where @scheme[f] returns a false result in between two elements where
|
||||
@scheme[f] returns a true result, then operations on this stream will
|
||||
not terminate during the infinite sub-stream.}
|
||||
|
||||
@defmodule[racket/generator]
|
||||
@defproc[(stream-add-between [s stream?] [e any/c])
|
||||
stream?]{
|
||||
Returns a stream whose elements are the elements of @scheme[s],
|
||||
but with @scheme[e] between each pair of elements in @racket[s].
|
||||
The new stream is constructed lazily.}
|
||||
|
||||
@defthing[prop:stream struct-type-property?]{
|
||||
|
||||
Associates three procedures to a structure type to implement stream
|
||||
operations for instances of the structure type.
|
||||
|
||||
The property value must be a vector of three procedures: a
|
||||
@racket[stream-empty?] implementation, a @racket[stream-first]
|
||||
implementation, and a @racket[stream-rest] implementation. The
|
||||
procedures are applied only to instances of the structure type that
|
||||
has the property value.}
|
||||
|
||||
@; ======================================================================
|
||||
@section{Generators}
|
||||
|
||||
A @deftech{generator} is a procedure that returns a sequence of
|
||||
values, incrementing the sequence each time that the generator is
|
||||
|
@ -496,6 +676,8 @@ called. In particular, the @racket[generator] form implements a
|
|||
generator by evaluating a body that calls @racket[yield] to return
|
||||
values from the generator.
|
||||
|
||||
@defmodule[racket/generator]
|
||||
|
||||
@(define generator-eval
|
||||
(let ([the-eval (make-base-eval)])
|
||||
(the-eval '(require racket/generator))
|
||||
|
|
|
@ -1,83 +1,4 @@
|
|||
; Library streams/primitive
|
||||
; Adapted for PLT Scheme by Jacob J. A. Koot
|
||||
; from original version of Philip L. Bewig.
|
||||
#lang racket/base
|
||||
|
||||
; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA. All rights
|
||||
; reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of
|
||||
; this software and associated documentation files (the "Software"), to deal in the Software
|
||||
; without restriction, including without limitation the rights to use, copy, modify, merge,
|
||||
; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
|
||||
; whom the Software is furnished to do so, subject to the following conditions: The above
|
||||
; copyright notice and this permission notice shall be included in all copies or substantial
|
||||
; portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
|
||||
; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
|
||||
; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
|
||||
; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
|
||||
; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
||||
#lang scheme
|
||||
|
||||
(provide stream-null stream-cons stream? stream-null? stream-pair?
|
||||
stream-car stream-cdr stream-lambda)
|
||||
|
||||
(define-struct stream (promise) #:mutable)
|
||||
|
||||
(define-syntax stream-lazy
|
||||
(syntax-rules ()
|
||||
((stream-lazy expr)
|
||||
(make-stream
|
||||
(mcons 'lazy (lambda () expr))))))
|
||||
|
||||
(define (stream-eager expr)
|
||||
(make-stream
|
||||
(mcons 'eager expr)))
|
||||
|
||||
(define-syntax stream-delay
|
||||
(syntax-rules ()
|
||||
((stream-delay expr)
|
||||
(stream-lazy (stream-eager expr)))))
|
||||
|
||||
(define (stream-force promise)
|
||||
(let ((content (stream-promise promise)))
|
||||
(case (mcar content)
|
||||
((eager) (mcdr content))
|
||||
((lazy) (let* ((promise* ((mcdr content)))
|
||||
(content (stream-promise promise)))
|
||||
(when (not (eqv? (mcar content) 'eager))
|
||||
(begin (set-mcar! content (mcar (stream-promise promise*)))
|
||||
(set-mcdr! content (mcdr (stream-promise promise*)))
|
||||
(set-stream-promise! promise* content)))
|
||||
(stream-force promise))))))
|
||||
|
||||
(define stream-null (stream-delay (cons 'stream 'null)))
|
||||
|
||||
(define-struct stream-pare (kar kdr))
|
||||
|
||||
(define (stream-pair? obj)
|
||||
(and (stream? obj) (stream-pare? (stream-force obj))))
|
||||
|
||||
(define (stream-null? obj)
|
||||
(and (stream? obj)
|
||||
(eqv? (stream-force obj)
|
||||
(stream-force stream-null))))
|
||||
|
||||
(define-syntax stream-cons
|
||||
(syntax-rules ()
|
||||
((stream-cons obj strm)
|
||||
(stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))))
|
||||
|
||||
(define (stream-car strm)
|
||||
(cond ((not (stream? strm)) (error 'stream-car "non-stream"))
|
||||
((stream-null? strm) (error 'stream-car "null stream"))
|
||||
(else (stream-force (stream-pare-kar (stream-force strm))))))
|
||||
|
||||
(define (stream-cdr strm)
|
||||
(cond ((not (stream? strm)) (error 'stream-cdr "non-stream"))
|
||||
((stream-null? strm) (error 'stream-cdr "null stream"))
|
||||
(else (stream-pare-kdr (stream-force strm)))))
|
||||
|
||||
(define-syntax stream-lambda
|
||||
(syntax-rules ()
|
||||
((stream-lambda formals body0 body1 ...)
|
||||
(lambda formals (stream-lazy (let () body0 body1 ...))))))
|
||||
(require racket/private/stream-cons)
|
||||
(provide (all-from-out racket/private/stream-cons))
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
(for-syntax scheme/base)
|
||||
(for-label scheme/base))
|
||||
(for-label scheme/base
|
||||
racket/stream))
|
||||
|
||||
@(define-syntax (srfi stx)
|
||||
(syntax-case stx ()
|
||||
|
@ -722,6 +723,9 @@ Superceded by @schememodname[srfi/41].
|
|||
|
||||
@srfi[41 #:subdir #t]{Streams}
|
||||
|
||||
The @racket[stream-cons] operation from @racketmodname[srfi/41] is the
|
||||
same as from @racketmodname[racket/stream].
|
||||
|
||||
@redirect[41 #:subdir #t '(
|
||||
(stream-null #f "stream-null")
|
||||
(stream-cons #t "stream-cons")
|
||||
|
|
|
@ -228,114 +228,4 @@
|
|||
(test 13 next)
|
||||
(test #f more?))
|
||||
|
||||
|
||||
;; New operators
|
||||
(require racket/stream)
|
||||
|
||||
(test '(0 1 2) 'stream->list (stream->list (in-range 3)))
|
||||
(arity-test stream->list 1 1)
|
||||
(err/rt-test (stream->list 1))
|
||||
|
||||
(test '() 'empty-stream (stream->list empty-stream))
|
||||
|
||||
; XXX How do I check rest arity?
|
||||
(test '(0 1 2) 'stream-cons (stream->list (stream-cons 0 (in-range 1 3))))
|
||||
(test '((0 1)) 'stream-cons
|
||||
(for/list ([(a b) (stream-cons 0 1 empty-stream)])
|
||||
(list a b)))
|
||||
|
||||
(arity-test stream-first 1 1)
|
||||
(err/rt-test (stream-first 1))
|
||||
(test 0 'stream-first (stream-first (in-naturals)))
|
||||
(test #t
|
||||
'stream-first
|
||||
(equal? (list 0 1)
|
||||
(call-with-values
|
||||
(λ ()
|
||||
(stream-first (stream-cons 0 1 empty-stream)))
|
||||
(λ args args))))
|
||||
|
||||
(arity-test stream-rest 1 1)
|
||||
(test '(1 2) 'stream-rest (stream->list (stream-rest (in-range 3))))
|
||||
|
||||
(arity-test stream-length 1 1)
|
||||
(err/rt-test (stream-length 1))
|
||||
(test 3 'stream-length (stream-length (in-range 3)))
|
||||
(test 3 'stream-length (stream-length #hasheq((1 . 'a) (2 . 'b) (3 . 'c))))
|
||||
|
||||
(arity-test stream-ref 2 2)
|
||||
(err/rt-test (stream-ref 2 0))
|
||||
(err/rt-test (stream-ref (in-naturals) -1) exn:fail?)
|
||||
(err/rt-test (stream-ref (in-naturals) 1.0) exn:fail?)
|
||||
(test 0 'stream-ref (stream-ref (in-naturals) 0))
|
||||
(test 1 'stream-ref (stream-ref (in-naturals) 1))
|
||||
(test 25 'stream-ref (stream-ref (in-naturals) 25))
|
||||
|
||||
(arity-test stream-tail 2 2)
|
||||
(err/rt-test (stream-tail (in-naturals) -1) exn:fail?)
|
||||
(err/rt-test (stream-tail (in-naturals) 1.0) exn:fail?)
|
||||
(test 4 'stream-ref (stream-ref (stream-tail (in-naturals) 4) 0))
|
||||
(test 5 'stream-ref (stream-ref (stream-tail (in-naturals) 4) 1))
|
||||
(test 29 'stream-ref (stream-ref (stream-tail (in-naturals) 4) 25))
|
||||
|
||||
; XXX Check for rest
|
||||
(err/rt-test (stream-append 1) exn:fail?)
|
||||
(err/rt-test (stream-append (in-naturals) 1) exn:fail?)
|
||||
(test '() 'stream-append (stream->list (stream-append)))
|
||||
(test 5 'stream-append (stream-ref (stream-append (in-naturals)) 5))
|
||||
(test 5 'stream-append
|
||||
(stream-ref (stream-append (in-range 3) (in-range 3 10)) 5))
|
||||
|
||||
(arity-test stream-map 2 2)
|
||||
(err/rt-test (stream-map 2 (in-naturals)) exn:fail?)
|
||||
(test '(1 2 3) 'stream-map (stream->list (stream-map add1 (in-range 3))))
|
||||
(test 3 'stream-map (stream-ref (stream-map add1 (in-naturals)) 2))
|
||||
|
||||
(arity-test stream-andmap 2 2)
|
||||
(err/rt-test (stream-andmap 2 (in-naturals)))
|
||||
(test #t 'stream-andmap (stream-andmap even? (stream-cons 2 empty-stream)))
|
||||
(test #f 'stream-andmap (stream-andmap even? (in-naturals)))
|
||||
|
||||
(arity-test stream-ormap 2 2)
|
||||
(err/rt-test (stream-ormap 2 (in-naturals)))
|
||||
(test #t 'stream-ormap (stream-ormap even? (stream-cons 2 empty-stream)))
|
||||
(test #f 'stream-ormap (stream-ormap even? (stream-cons 1 empty-stream)))
|
||||
(test #t 'stream-ormap (stream-ormap even? (in-naturals)))
|
||||
|
||||
(arity-test stream-for-each 2 2)
|
||||
(err/rt-test (stream-for-each 2 (in-naturals)))
|
||||
(test (vector 0 1 2)
|
||||
'stream-for-each
|
||||
(let ([v (vector #f #f #f)])
|
||||
(stream-for-each (λ (i) (vector-set! v i i)) (in-range 3))
|
||||
v))
|
||||
|
||||
(arity-test stream-fold 3 3)
|
||||
(err/rt-test (stream-fold 2 (in-naturals) 0))
|
||||
(test 6 'stream-fold (stream-fold + 0 (in-range 4)))
|
||||
|
||||
(arity-test stream-filter 2 2)
|
||||
(err/rt-test (stream-filter 2 (in-naturals)) exn:fail?)
|
||||
(test 4 'stream-filter (stream-ref (stream-filter even? (in-naturals)) 2))
|
||||
|
||||
(arity-test stream-add-between 2 2)
|
||||
(test 0 'stream-add-between
|
||||
(stream-ref (stream-add-between (in-naturals) #t) 0))
|
||||
(test #t 'stream-add-between
|
||||
(stream-ref (stream-add-between (in-naturals) #t) 1))
|
||||
(test 1 'stream-add-between
|
||||
(stream-ref (stream-add-between (in-naturals) #t) 2))
|
||||
(test #t 'stream-add-between
|
||||
(stream-ref (stream-add-between (in-naturals) #t) 3))
|
||||
|
||||
(arity-test stream-count 2 2)
|
||||
(test 0 'stream-count (stream-count even? empty-stream))
|
||||
(test 1 'stream-count (stream-count even? (in-range 1)))
|
||||
(test 5 'stream-count (stream-count even? (in-range 10)))
|
||||
(let* ([r (random 100)]
|
||||
[a (if (even? r)
|
||||
(/ r 2)
|
||||
(ceiling (/ r 2)))])
|
||||
(test a 'stream-count (stream-count even? (in-range r))))
|
||||
|
||||
(report-errs)
|
||||
|
|
337
collects/tests/racket/iostream.rktl
Normal file
337
collects/tests/racket/iostream.rktl
Normal file
|
@ -0,0 +1,337 @@
|
|||
|
||||
(printf "Stream Tests (current dir must be startup dir)\n")
|
||||
|
||||
(require scheme/system)
|
||||
|
||||
(define (log . args)
|
||||
'(begin
|
||||
(apply printf args)
|
||||
(newline)))
|
||||
|
||||
(define cs-prog
|
||||
'(define (copy-stream in out)
|
||||
(lambda ()
|
||||
(let ([s (make-bytes 4096)])
|
||||
(let loop ()
|
||||
(let ([l (read-bytes-avail! s in)])
|
||||
(log "in: ~a" l)
|
||||
(unless (eof-object? l)
|
||||
(let loop ([p 0][l l])
|
||||
(let ([r (write-bytes-avail s out p (+ p l))])
|
||||
(log "out: ~a" r)
|
||||
(when (< r l)
|
||||
(loop (+ p r) (- l r)))))
|
||||
(loop))))))))
|
||||
|
||||
(eval cs-prog)
|
||||
|
||||
(define test-file (find-executable-path (find-system-path 'exec-file) #f))
|
||||
(define tmp-file (build-path (find-system-path 'temp-dir) "ZstreamZ"))
|
||||
|
||||
(define (feed-file out)
|
||||
(let ([p (open-input-file test-file)])
|
||||
(let loop ()
|
||||
(let ([c (read-byte p)])
|
||||
(unless (eof-object? c)
|
||||
(write-byte c out)
|
||||
(loop))))))
|
||||
|
||||
(define (feed-file/fast out)
|
||||
(let ([p (open-input-file test-file)])
|
||||
((copy-stream p out))
|
||||
(close-input-port p)))
|
||||
|
||||
(define (check-file in)
|
||||
(let ([p (open-input-file test-file)])
|
||||
(let loop ([badc 0])
|
||||
(let ([c (read-byte p)]
|
||||
[c2 (read-byte in)])
|
||||
(unless (eq? c c2)
|
||||
(if (= badc 30)
|
||||
(error "check-failed" (file-position p) c c2)
|
||||
(begin
|
||||
(fprintf (current-error-port)
|
||||
"fail: ~a ~s=~s ~s=~s\n"
|
||||
(file-position p) c (integer->char c) c2 (integer->char c2))
|
||||
(loop (add1 badc)))))
|
||||
(unless (eof-object? c)
|
||||
(loop badc))))
|
||||
(close-input-port p)))
|
||||
|
||||
(define (check-file/fast in)
|
||||
(let ([p (open-input-file test-file)])
|
||||
(let loop ()
|
||||
(let* ([s (read-bytes 5000 p)]
|
||||
[s2 (read-bytes (if (bytes? s) (bytes-length s) 100) in)])
|
||||
(unless (equal? s s2)
|
||||
(error "fast check failed"))
|
||||
(unless (eof-object? s)
|
||||
(loop))))
|
||||
(close-input-port p)))
|
||||
|
||||
(define (check-file/fastest in)
|
||||
(let ([p (open-input-file test-file)]
|
||||
[s1 (make-bytes 5000)]
|
||||
[s2 (make-bytes 5000)])
|
||||
(let loop ([leftover 0][startpos 0][pos 0])
|
||||
(let* ([n1 (if (zero? leftover)
|
||||
(read-bytes-avail! s1 p)
|
||||
leftover)]
|
||||
[n2 (read-bytes-avail! s2 in 0 (if (eof-object? n1)
|
||||
1
|
||||
n1))])
|
||||
(unless (if (or (eof-object? n1)
|
||||
(eof-object? n2))
|
||||
(and (eof-object? n1)
|
||||
(eof-object? n2))
|
||||
(if (= n2 n1 5000)
|
||||
(bytes=? s1 s2)
|
||||
(bytes=? (subbytes s1 startpos (+ startpos n2))
|
||||
(subbytes s2 0 n2))))
|
||||
(error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2))
|
||||
(unless (eof-object? n1)
|
||||
(loop (- n1 n2)
|
||||
(if (= n1 n2)
|
||||
0
|
||||
(+ startpos n2))
|
||||
(+ pos n2)))))
|
||||
(close-input-port p)))
|
||||
|
||||
(define portno 40010)
|
||||
|
||||
(define (setup-mzscheme-echo tcp?)
|
||||
(define p (process* test-file "-q" "-b"))
|
||||
(define s (make-bytes 256))
|
||||
(define r #f)
|
||||
(define w #f)
|
||||
(define r2 #f)
|
||||
(define w2 #f)
|
||||
(thread (copy-stream (cadddr p) (current-error-port)))
|
||||
(fprintf (cadr p) "(define log void)\n")
|
||||
(fprintf (cadr p) "~s\n" cs-prog)
|
||||
(if tcp?
|
||||
(let ([t
|
||||
(thread (lambda ()
|
||||
(define-values (rr ww) (tcp-accept l1))
|
||||
(define-values (rr2 ww2) (tcp-accept l2))
|
||||
(set! r rr)
|
||||
(set! w ww)
|
||||
(set! r2 rr2)
|
||||
(set! w2 ww2)))])
|
||||
(fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))\n" portno)
|
||||
(fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))\n" (add1 portno))
|
||||
(flush-output (cadr p))
|
||||
(thread-wait t)
|
||||
(fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))\n"))
|
||||
(fprintf (cadr p) "(begin (flush-output) ((copy-stream (current-input-port) (current-output-port))) (exit))\n"))
|
||||
(flush-output (cadr p))
|
||||
|
||||
(unless tcp?
|
||||
;; Flush initial output from other process:
|
||||
(let loop ()
|
||||
(sleep 0.3)
|
||||
(unless (zero? (read-bytes-avail!* s (car p)))
|
||||
(loop))))
|
||||
|
||||
(if tcp?
|
||||
(values r w r2 w2)
|
||||
p))
|
||||
|
||||
(define start-ms 0)
|
||||
(define start-ps-ms 0)
|
||||
(define start-gc-ms 0)
|
||||
(define (start s)
|
||||
(printf s)
|
||||
(set! start-ms (current-milliseconds))
|
||||
(set! start-gc-ms (current-gc-milliseconds))
|
||||
(set! start-ps-ms (current-process-milliseconds)))
|
||||
(define (end)
|
||||
(let ([ps-ms (current-process-milliseconds)]
|
||||
[gc-ms (current-gc-milliseconds)]
|
||||
[ms (current-milliseconds)])
|
||||
(printf "cpu: ~a real: ~a gc ~a\n"
|
||||
(- ps-ms start-ps-ms)
|
||||
(- ms start-ms)
|
||||
(- gc-ms start-gc-ms))))
|
||||
|
||||
'(thread (lambda ()
|
||||
(let loop ()
|
||||
(printf "alive\n")
|
||||
(sleep 1)
|
||||
(loop))))
|
||||
|
||||
(start "Quick check:\n")
|
||||
(define p (open-input-file test-file))
|
||||
(check-file/fast p)
|
||||
(close-input-port p)
|
||||
(end)
|
||||
|
||||
(start "Quicker check:\n")
|
||||
(define p (open-input-file test-file))
|
||||
(check-file/fastest p)
|
||||
(close-input-port p)
|
||||
(end)
|
||||
|
||||
(start "Plain pipe...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(feed-file w)
|
||||
(close-output-port w)
|
||||
(check-file r)
|
||||
(end)
|
||||
|
||||
(start "Plain pipe, faster...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)
|
||||
(check-file/fast r)
|
||||
(end)
|
||||
|
||||
(start "Plain pipe, fastest...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)
|
||||
(check-file/fastest r)
|
||||
(end)
|
||||
|
||||
(start "Limited pipe...\n")
|
||||
(define-values (r w) (make-pipe 253))
|
||||
(thread (lambda ()
|
||||
(feed-file w)
|
||||
(close-output-port w)))
|
||||
(check-file r)
|
||||
(end)
|
||||
|
||||
(start "Limited pipe, faster...\n")
|
||||
(define-values (r w) (make-pipe 253))
|
||||
(thread (lambda ()
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)))
|
||||
(check-file/fast r)
|
||||
(end)
|
||||
|
||||
(start "Limited pipe, fastest...\n")
|
||||
(define-values (r w) (make-pipe 253))
|
||||
(thread (lambda ()
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)))
|
||||
(check-file/fastest r)
|
||||
(end)
|
||||
|
||||
(start "To file and back:\n")
|
||||
(start " to...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(define p (open-output-file tmp-file #:exists 'truncate))
|
||||
(define t (thread (copy-stream r p)))
|
||||
(feed-file w)
|
||||
(close-output-port w)
|
||||
(thread-wait t)
|
||||
(close-output-port p)
|
||||
(end)
|
||||
|
||||
(start " back...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(define p (open-input-file tmp-file))
|
||||
(define t (thread (copy-stream p w)))
|
||||
(thread-wait t)
|
||||
(close-output-port w)
|
||||
(close-input-port p)
|
||||
(check-file r)
|
||||
(end)
|
||||
|
||||
(start "To file and back, faster:\n")
|
||||
(start " to...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(define p (open-output-file tmp-file #:exists 'truncate))
|
||||
(define t (thread (copy-stream r p)))
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)
|
||||
(thread-wait t)
|
||||
(close-output-port p)
|
||||
(end)
|
||||
|
||||
(start " back...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(define p (open-input-file tmp-file))
|
||||
(define t (thread (copy-stream p w)))
|
||||
(thread-wait t)
|
||||
(close-output-port w)
|
||||
(close-input-port p)
|
||||
(check-file/fast r)
|
||||
(end)
|
||||
|
||||
(start "File back, fastest:\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(define p (open-input-file tmp-file))
|
||||
(define t (thread (copy-stream p w)))
|
||||
(thread-wait t)
|
||||
(close-output-port w)
|
||||
(close-input-port p)
|
||||
(check-file/fastest r)
|
||||
(end)
|
||||
|
||||
(start "Echo...\n")
|
||||
(define p (setup-mzscheme-echo #f))
|
||||
(thread (lambda ()
|
||||
(feed-file (cadr p))
|
||||
(close-output-port (cadr p))))
|
||||
(check-file (car p))
|
||||
(end)
|
||||
|
||||
(start "Echo, faster...\n")
|
||||
(define p (setup-mzscheme-echo #f))
|
||||
(thread (lambda ()
|
||||
(feed-file/fast (cadr p))
|
||||
(close-output-port (cadr p))))
|
||||
(check-file/fast (car p))
|
||||
(end)
|
||||
|
||||
(start "Echo, indirect...\n")
|
||||
(define p (setup-mzscheme-echo #f))
|
||||
(define-values (rp1 wp1) (make-pipe))
|
||||
(define-values (rp2 wp2) (make-pipe))
|
||||
(thread (lambda () ((copy-stream rp1 (cadr p))) (close-output-port (cadr p))))
|
||||
(thread (lambda () ((copy-stream (car p) wp2)) (close-output-port wp2)))
|
||||
(thread (lambda ()
|
||||
(feed-file/fast wp1)
|
||||
(close-output-port wp1)))
|
||||
(check-file/fast rp2)
|
||||
(end)
|
||||
|
||||
(define l1 (tcp-listen portno 5 #t))
|
||||
(define l2 (tcp-listen (add1 portno) 5 #t))
|
||||
|
||||
(start "TCP Echo...\n")
|
||||
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
|
||||
(close-input-port r)
|
||||
(thread (lambda ()
|
||||
(feed-file w)
|
||||
(close-output-port w)))
|
||||
(check-file r2)
|
||||
(close-input-port r2)
|
||||
(end)
|
||||
|
||||
(start "TCP Echo, faster...\n")
|
||||
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
|
||||
(close-input-port r)
|
||||
(thread (lambda ()
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)))
|
||||
(check-file/fast r2)
|
||||
(close-input-port r2)
|
||||
(end)
|
||||
|
||||
(start "TCP Echo, indirect...\n")
|
||||
(define-values (rp1 wp1) (make-pipe))
|
||||
(define-values (rp2 wp2) (make-pipe))
|
||||
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
|
||||
(close-input-port r)
|
||||
(thread (lambda () ((copy-stream rp1 w)) (close-output-port w)))
|
||||
(thread (lambda () ((copy-stream r2 wp2)) (close-output-port wp2)))
|
||||
(thread (lambda ()
|
||||
(feed-file/fast wp1)
|
||||
(close-output-port wp1)))
|
||||
(check-file/fast rp2)
|
||||
(end)
|
||||
|
||||
(tcp-close l1)
|
||||
(tcp-close l2)
|
|
@ -17,6 +17,8 @@
|
|||
(load-in-sandbox "date.rktl")
|
||||
(load-in-sandbox "compat.rktl")
|
||||
(load-in-sandbox "cmdline.rktl")
|
||||
(load-in-sandbox "stream.rktl")
|
||||
(load-in-sandbox "sequence.rktl")
|
||||
(load-in-sandbox "generator.rktl")
|
||||
(load-in-sandbox "pconvert.rktl")
|
||||
(load-in-sandbox "pretty.rktl")
|
||||
|
|
175
collects/tests/racket/sequence.rktl
Normal file
175
collects/tests/racket/sequence.rktl
Normal file
|
@ -0,0 +1,175 @@
|
|||
|
||||
(load-relative "loadtest.rktl")
|
||||
|
||||
(Section 'sequence)
|
||||
|
||||
(require racket/sequence
|
||||
racket/stream)
|
||||
|
||||
(define (try-basic-sequence-ops sequence?
|
||||
empty-sequence
|
||||
sequence->list
|
||||
sequence-length
|
||||
sequence-ref
|
||||
sequence-tail
|
||||
sequence-append
|
||||
sequence-map
|
||||
sequence-andmap
|
||||
sequence-ormap
|
||||
sequence-for-each
|
||||
sequence-fold
|
||||
sequence-filter
|
||||
sequence-add-between
|
||||
sequence-count)
|
||||
|
||||
(test #t sequence? empty-sequence)
|
||||
(test #t sequence? (in-range 10))
|
||||
(test #t sequence? '(1 2 3))
|
||||
(test #f sequence? 'symbol)
|
||||
|
||||
(test '(0 1 2) 'sequence->list (sequence->list (in-range 3)))
|
||||
(arity-test sequence->list 1 1)
|
||||
(err/rt-test (sequence->list 1))
|
||||
|
||||
(test '() 'empty-sequence (sequence->list empty-sequence))
|
||||
|
||||
(arity-test sequence-length 1 1)
|
||||
(err/rt-test (sequence-length 1))
|
||||
(test 3 'sequence-length (sequence-length (in-range 3)))
|
||||
|
||||
(arity-test sequence-ref 2 2)
|
||||
(err/rt-test (sequence-ref 2 0))
|
||||
(err/rt-test (sequence-ref (in-naturals) -1) exn:fail?)
|
||||
(err/rt-test (sequence-ref (in-naturals) 1.0) exn:fail?)
|
||||
(test 0 'sequence-ref (sequence-ref (in-naturals) 0))
|
||||
(test 1 'sequence-ref (sequence-ref (in-naturals) 1))
|
||||
(test 25 'sequence-ref (sequence-ref (in-naturals) 25))
|
||||
|
||||
(arity-test sequence-tail 2 2)
|
||||
(err/rt-test (sequence-tail (in-naturals) -1) exn:fail?)
|
||||
(err/rt-test (sequence-tail (in-naturals) 1.0) exn:fail?)
|
||||
(test 4 'sequence-ref (sequence-ref (sequence-tail (in-naturals) 4) 0))
|
||||
(test 5 'sequence-ref (sequence-ref (sequence-tail (in-naturals) 4) 1))
|
||||
(test 29 'sequence-ref (sequence-ref (sequence-tail (in-naturals) 4) 25))
|
||||
|
||||
;; XXX Check for rest
|
||||
(err/rt-test (sequence-append 1) exn:fail?)
|
||||
(err/rt-test (sequence-append (in-naturals) 1) exn:fail?)
|
||||
(test '() 'sequence-append (sequence->list (sequence-append)))
|
||||
(test 5 'sequence-append (sequence-ref (sequence-append (in-naturals)) 5))
|
||||
(test 5 'sequence-append
|
||||
(sequence-ref (sequence-append (in-range 3) (in-range 3 10)) 5))
|
||||
|
||||
(arity-test sequence-map 2 2)
|
||||
(err/rt-test (sequence-map 2 (in-naturals)) exn:fail?)
|
||||
(test '(1 2 3) 'sequence-map (sequence->list (sequence-map add1 (in-range 3))))
|
||||
(test 3 'sequence-map (sequence-ref (sequence-map add1 (in-naturals)) 2))
|
||||
|
||||
(arity-test sequence-andmap 2 2)
|
||||
(err/rt-test (sequence-andmap 2 (in-naturals)))
|
||||
(test #t 'sequence-andmap (sequence-andmap even? '(2)))
|
||||
(test #f 'sequence-andmap (sequence-andmap even? (in-naturals)))
|
||||
|
||||
(arity-test sequence-ormap 2 2)
|
||||
(err/rt-test (sequence-ormap 2 (in-naturals)))
|
||||
(test #t 'sequence-ormap (sequence-ormap even? '(2)))
|
||||
(test #f 'sequence-ormap (sequence-ormap even? '(1)))
|
||||
(test #t 'sequence-ormap (sequence-ormap even? (in-naturals)))
|
||||
|
||||
(arity-test sequence-for-each 2 2)
|
||||
(err/rt-test (sequence-for-each 2 (in-naturals)))
|
||||
(test (vector 0 1 2)
|
||||
'sequence-for-each
|
||||
(let ([v (vector #f #f #f)])
|
||||
(sequence-for-each (λ (i) (vector-set! v i i)) (in-range 3))
|
||||
v))
|
||||
|
||||
(arity-test sequence-fold 3 3)
|
||||
(err/rt-test (sequence-fold 2 (in-naturals) 0))
|
||||
(test 6 'sequence-fold (sequence-fold + 0 (in-range 4)))
|
||||
|
||||
(arity-test sequence-filter 2 2)
|
||||
(err/rt-test (sequence-filter 2 (in-naturals)) exn:fail?)
|
||||
(test 4 'sequence-filter (sequence-ref (sequence-filter even? (in-naturals)) 2))
|
||||
|
||||
(arity-test sequence-add-between 2 2)
|
||||
(test 0 'sequence-add-between
|
||||
(sequence-ref (sequence-add-between (in-naturals) #t) 0))
|
||||
(test #t 'sequence-add-between
|
||||
(sequence-ref (sequence-add-between (in-naturals) #t) 1))
|
||||
(test 1 'sequence-add-between
|
||||
(sequence-ref (sequence-add-between (in-naturals) #t) 2))
|
||||
(test #t 'sequence-add-between
|
||||
(sequence-ref (sequence-add-between (in-naturals) #t) 3))
|
||||
|
||||
(arity-test sequence-count 2 2)
|
||||
(test 0 'sequence-count (sequence-count even? empty-sequence))
|
||||
(test 1 'sequence-count (sequence-count even? (in-range 1)))
|
||||
(test 5 'sequence-count (sequence-count even? (in-range 10)))
|
||||
(let* ([r (random 100)]
|
||||
[a (if (even? r)
|
||||
(/ r 2)
|
||||
(ceiling (/ r 2)))])
|
||||
(test a 'sequence-count (sequence-count even? (in-range r))))
|
||||
|
||||
(test '(0 1 2 5 6 5 6)
|
||||
'no-state-in-iter-over-append
|
||||
(let ([k #f]
|
||||
[l null])
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(for ([i (stream-append (in-range 3) (in-range 5 7))])
|
||||
(set! l (cons i l))
|
||||
(when (= i 2) (let/cc _k (set! k _k))))))
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(k #f)))
|
||||
(reverse l))))
|
||||
|
||||
(try-basic-sequence-ops sequence?
|
||||
empty-sequence
|
||||
sequence->list
|
||||
sequence-length
|
||||
sequence-ref
|
||||
sequence-tail
|
||||
sequence-append
|
||||
sequence-map
|
||||
sequence-andmap
|
||||
sequence-ormap
|
||||
sequence-for-each
|
||||
sequence-fold
|
||||
sequence-filter
|
||||
sequence-add-between
|
||||
sequence-count)
|
||||
(try-basic-sequence-ops stream?
|
||||
empty-stream
|
||||
stream->list
|
||||
stream-length
|
||||
stream-ref
|
||||
stream-tail
|
||||
stream-append
|
||||
stream-map
|
||||
stream-andmap
|
||||
stream-ormap
|
||||
stream-for-each
|
||||
stream-fold
|
||||
stream-filter
|
||||
stream-add-between
|
||||
stream-count)
|
||||
|
||||
(test 3 'sequence-length (sequence-length #hasheq((1 . 'a) (2 . 'b) (3 . 'c))))
|
||||
|
||||
(test-values '(2 3) (lambda () (sequence-ref (in-parallel '(2) '(3)) 0)))
|
||||
(test-values '(8 12) (lambda () (sequence-ref (in-parallel '(2 5 8 -1) '(3 9 12 0)) 2)))
|
||||
|
||||
(test #t stream? (sequence-append))
|
||||
(test #t stream? (sequence-append (in-range 10) '(1 2 3)))
|
||||
(test #f stream? (sequence-append (in-range 10) (vector 1 2 3) '(1 2 3)))
|
||||
|
||||
(test #t stream? (sequence-map add1 (in-range 3)))
|
||||
(test #f stream? (sequence-map add1 (vector 1 2 3)))
|
||||
|
||||
(test #t stream? (sequence-filter odd? (in-range 3)))
|
||||
(test #f stream? (sequence-filter odd? (vector 1 2 3)))
|
||||
|
||||
(report-errs)
|
|
@ -1,337 +1,24 @@
|
|||
|
||||
(printf "Stream Tests (current dir must be startup dir)\n")
|
||||
(load-relative "loadtest.rktl")
|
||||
|
||||
(require scheme/system)
|
||||
(Section 'stream)
|
||||
|
||||
(define (log . args)
|
||||
'(begin
|
||||
(apply printf args)
|
||||
(newline)))
|
||||
(require racket/stream)
|
||||
|
||||
(define cs-prog
|
||||
'(define (copy-stream in out)
|
||||
(lambda ()
|
||||
(let ([s (make-bytes 4096)])
|
||||
(let loop ()
|
||||
(let ([l (read-bytes-avail! s in)])
|
||||
(log "in: ~a" l)
|
||||
(unless (eof-object? l)
|
||||
(let loop ([p 0][l l])
|
||||
(let ([r (write-bytes-avail s out p (+ p l))])
|
||||
(log "out: ~a" r)
|
||||
(when (< r l)
|
||||
(loop (+ p r) (- l r)))))
|
||||
(loop))))))))
|
||||
;; >>> Many basic stream tests are in "sequence.rktl" <<<
|
||||
|
||||
(eval cs-prog)
|
||||
(test #f stream? '#(1 2))
|
||||
|
||||
(define test-file (find-executable-path (find-system-path 'exec-file) #f))
|
||||
(define tmp-file (build-path (find-system-path 'temp-dir) "ZstreamZ"))
|
||||
(test 1 'stream-length (stream-length (stream-cons 1 empty-stream)))
|
||||
|
||||
(define (feed-file out)
|
||||
(let ([p (open-input-file test-file)])
|
||||
(let loop ()
|
||||
(let ([c (read-byte p)])
|
||||
(unless (eof-object? c)
|
||||
(write-byte c out)
|
||||
(loop))))))
|
||||
|
||||
(define (feed-file/fast out)
|
||||
(let ([p (open-input-file test-file)])
|
||||
((copy-stream p out))
|
||||
(close-input-port p)))
|
||||
|
||||
(define (check-file in)
|
||||
(let ([p (open-input-file test-file)])
|
||||
(let loop ([badc 0])
|
||||
(let ([c (read-byte p)]
|
||||
[c2 (read-byte in)])
|
||||
(unless (eq? c c2)
|
||||
(if (= badc 30)
|
||||
(error "check-failed" (file-position p) c c2)
|
||||
(begin
|
||||
(fprintf (current-error-port)
|
||||
"fail: ~a ~s=~s ~s=~s\n"
|
||||
(file-position p) c (integer->char c) c2 (integer->char c2))
|
||||
(loop (add1 badc)))))
|
||||
(unless (eof-object? c)
|
||||
(loop badc))))
|
||||
(close-input-port p)))
|
||||
(define infinite-ones (stream-cons 1 infinite-ones))
|
||||
|
||||
(define (check-file/fast in)
|
||||
(let ([p (open-input-file test-file)])
|
||||
(let loop ()
|
||||
(let* ([s (read-bytes 5000 p)]
|
||||
[s2 (read-bytes (if (bytes? s) (bytes-length s) 100) in)])
|
||||
(unless (equal? s s2)
|
||||
(error "fast check failed"))
|
||||
(unless (eof-object? s)
|
||||
(loop))))
|
||||
(close-input-port p)))
|
||||
(test 1 stream-first infinite-ones)
|
||||
(test 1 stream-ref infinite-ones 100)
|
||||
|
||||
(define (check-file/fastest in)
|
||||
(let ([p (open-input-file test-file)]
|
||||
[s1 (make-bytes 5000)]
|
||||
[s2 (make-bytes 5000)])
|
||||
(let loop ([leftover 0][startpos 0][pos 0])
|
||||
(let* ([n1 (if (zero? leftover)
|
||||
(read-bytes-avail! s1 p)
|
||||
leftover)]
|
||||
[n2 (read-bytes-avail! s2 in 0 (if (eof-object? n1)
|
||||
1
|
||||
n1))])
|
||||
(unless (if (or (eof-object? n1)
|
||||
(eof-object? n2))
|
||||
(and (eof-object? n1)
|
||||
(eof-object? n2))
|
||||
(if (= n2 n1 5000)
|
||||
(bytes=? s1 s2)
|
||||
(bytes=? (subbytes s1 startpos (+ startpos n2))
|
||||
(subbytes s2 0 n2))))
|
||||
(error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2))
|
||||
(unless (eof-object? n1)
|
||||
(loop (- n1 n2)
|
||||
(if (= n1 n2)
|
||||
0
|
||||
(+ startpos n2))
|
||||
(+ pos n2)))))
|
||||
(close-input-port p)))
|
||||
(test 1 stream-first (stream-cons 1 (let loop () (loop))))
|
||||
(test 2 stream-length (stream-cons (let loop () (loop))
|
||||
(stream-cons (let loop () (loop))
|
||||
empty)))
|
||||
|
||||
(define portno 40010)
|
||||
|
||||
(define (setup-mzscheme-echo tcp?)
|
||||
(define p (process* test-file "-q" "-b"))
|
||||
(define s (make-bytes 256))
|
||||
(define r #f)
|
||||
(define w #f)
|
||||
(define r2 #f)
|
||||
(define w2 #f)
|
||||
(thread (copy-stream (cadddr p) (current-error-port)))
|
||||
(fprintf (cadr p) "(define log void)\n")
|
||||
(fprintf (cadr p) "~s\n" cs-prog)
|
||||
(if tcp?
|
||||
(let ([t
|
||||
(thread (lambda ()
|
||||
(define-values (rr ww) (tcp-accept l1))
|
||||
(define-values (rr2 ww2) (tcp-accept l2))
|
||||
(set! r rr)
|
||||
(set! w ww)
|
||||
(set! r2 rr2)
|
||||
(set! w2 ww2)))])
|
||||
(fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))\n" portno)
|
||||
(fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))\n" (add1 portno))
|
||||
(flush-output (cadr p))
|
||||
(thread-wait t)
|
||||
(fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))\n"))
|
||||
(fprintf (cadr p) "(begin (flush-output) ((copy-stream (current-input-port) (current-output-port))) (exit))\n"))
|
||||
(flush-output (cadr p))
|
||||
|
||||
(unless tcp?
|
||||
;; Flush initial output from other process:
|
||||
(let loop ()
|
||||
(sleep 0.3)
|
||||
(unless (zero? (read-bytes-avail!* s (car p)))
|
||||
(loop))))
|
||||
|
||||
(if tcp?
|
||||
(values r w r2 w2)
|
||||
p))
|
||||
|
||||
(define start-ms 0)
|
||||
(define start-ps-ms 0)
|
||||
(define start-gc-ms 0)
|
||||
(define (start s)
|
||||
(printf s)
|
||||
(set! start-ms (current-milliseconds))
|
||||
(set! start-gc-ms (current-gc-milliseconds))
|
||||
(set! start-ps-ms (current-process-milliseconds)))
|
||||
(define (end)
|
||||
(let ([ps-ms (current-process-milliseconds)]
|
||||
[gc-ms (current-gc-milliseconds)]
|
||||
[ms (current-milliseconds)])
|
||||
(printf "cpu: ~a real: ~a gc ~a\n"
|
||||
(- ps-ms start-ps-ms)
|
||||
(- ms start-ms)
|
||||
(- gc-ms start-gc-ms))))
|
||||
|
||||
'(thread (lambda ()
|
||||
(let loop ()
|
||||
(printf "alive\n")
|
||||
(sleep 1)
|
||||
(loop))))
|
||||
|
||||
(start "Quick check:\n")
|
||||
(define p (open-input-file test-file))
|
||||
(check-file/fast p)
|
||||
(close-input-port p)
|
||||
(end)
|
||||
|
||||
(start "Quicker check:\n")
|
||||
(define p (open-input-file test-file))
|
||||
(check-file/fastest p)
|
||||
(close-input-port p)
|
||||
(end)
|
||||
|
||||
(start "Plain pipe...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(feed-file w)
|
||||
(close-output-port w)
|
||||
(check-file r)
|
||||
(end)
|
||||
|
||||
(start "Plain pipe, faster...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)
|
||||
(check-file/fast r)
|
||||
(end)
|
||||
|
||||
(start "Plain pipe, fastest...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)
|
||||
(check-file/fastest r)
|
||||
(end)
|
||||
|
||||
(start "Limited pipe...\n")
|
||||
(define-values (r w) (make-pipe 253))
|
||||
(thread (lambda ()
|
||||
(feed-file w)
|
||||
(close-output-port w)))
|
||||
(check-file r)
|
||||
(end)
|
||||
|
||||
(start "Limited pipe, faster...\n")
|
||||
(define-values (r w) (make-pipe 253))
|
||||
(thread (lambda ()
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)))
|
||||
(check-file/fast r)
|
||||
(end)
|
||||
|
||||
(start "Limited pipe, fastest...\n")
|
||||
(define-values (r w) (make-pipe 253))
|
||||
(thread (lambda ()
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)))
|
||||
(check-file/fastest r)
|
||||
(end)
|
||||
|
||||
(start "To file and back:\n")
|
||||
(start " to...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(define p (open-output-file tmp-file #:exists 'truncate))
|
||||
(define t (thread (copy-stream r p)))
|
||||
(feed-file w)
|
||||
(close-output-port w)
|
||||
(thread-wait t)
|
||||
(close-output-port p)
|
||||
(end)
|
||||
|
||||
(start " back...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(define p (open-input-file tmp-file))
|
||||
(define t (thread (copy-stream p w)))
|
||||
(thread-wait t)
|
||||
(close-output-port w)
|
||||
(close-input-port p)
|
||||
(check-file r)
|
||||
(end)
|
||||
|
||||
(start "To file and back, faster:\n")
|
||||
(start " to...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(define p (open-output-file tmp-file #:exists 'truncate))
|
||||
(define t (thread (copy-stream r p)))
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)
|
||||
(thread-wait t)
|
||||
(close-output-port p)
|
||||
(end)
|
||||
|
||||
(start " back...\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(define p (open-input-file tmp-file))
|
||||
(define t (thread (copy-stream p w)))
|
||||
(thread-wait t)
|
||||
(close-output-port w)
|
||||
(close-input-port p)
|
||||
(check-file/fast r)
|
||||
(end)
|
||||
|
||||
(start "File back, fastest:\n")
|
||||
(define-values (r w) (make-pipe))
|
||||
(define p (open-input-file tmp-file))
|
||||
(define t (thread (copy-stream p w)))
|
||||
(thread-wait t)
|
||||
(close-output-port w)
|
||||
(close-input-port p)
|
||||
(check-file/fastest r)
|
||||
(end)
|
||||
|
||||
(start "Echo...\n")
|
||||
(define p (setup-mzscheme-echo #f))
|
||||
(thread (lambda ()
|
||||
(feed-file (cadr p))
|
||||
(close-output-port (cadr p))))
|
||||
(check-file (car p))
|
||||
(end)
|
||||
|
||||
(start "Echo, faster...\n")
|
||||
(define p (setup-mzscheme-echo #f))
|
||||
(thread (lambda ()
|
||||
(feed-file/fast (cadr p))
|
||||
(close-output-port (cadr p))))
|
||||
(check-file/fast (car p))
|
||||
(end)
|
||||
|
||||
(start "Echo, indirect...\n")
|
||||
(define p (setup-mzscheme-echo #f))
|
||||
(define-values (rp1 wp1) (make-pipe))
|
||||
(define-values (rp2 wp2) (make-pipe))
|
||||
(thread (lambda () ((copy-stream rp1 (cadr p))) (close-output-port (cadr p))))
|
||||
(thread (lambda () ((copy-stream (car p) wp2)) (close-output-port wp2)))
|
||||
(thread (lambda ()
|
||||
(feed-file/fast wp1)
|
||||
(close-output-port wp1)))
|
||||
(check-file/fast rp2)
|
||||
(end)
|
||||
|
||||
(define l1 (tcp-listen portno 5 #t))
|
||||
(define l2 (tcp-listen (add1 portno) 5 #t))
|
||||
|
||||
(start "TCP Echo...\n")
|
||||
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
|
||||
(close-input-port r)
|
||||
(thread (lambda ()
|
||||
(feed-file w)
|
||||
(close-output-port w)))
|
||||
(check-file r2)
|
||||
(close-input-port r2)
|
||||
(end)
|
||||
|
||||
(start "TCP Echo, faster...\n")
|
||||
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
|
||||
(close-input-port r)
|
||||
(thread (lambda ()
|
||||
(feed-file/fast w)
|
||||
(close-output-port w)))
|
||||
(check-file/fast r2)
|
||||
(close-input-port r2)
|
||||
(end)
|
||||
|
||||
(start "TCP Echo, indirect...\n")
|
||||
(define-values (rp1 wp1) (make-pipe))
|
||||
(define-values (rp2 wp2) (make-pipe))
|
||||
(define-values (r w r2 w2) (setup-mzscheme-echo #t))
|
||||
(close-input-port r)
|
||||
(thread (lambda () ((copy-stream rp1 w)) (close-output-port w)))
|
||||
(thread (lambda () ((copy-stream r2 wp2)) (close-output-port wp2)))
|
||||
(thread (lambda ()
|
||||
(feed-file/fast wp1)
|
||||
(close-output-port wp1)))
|
||||
(check-file/fast rp2)
|
||||
(end)
|
||||
|
||||
(tcp-close l1)
|
||||
(tcp-close l2)
|
||||
(report-errs)
|
||||
|
|
Loading…
Reference in New Issue
Block a user