Adding more sequence operators
This commit is contained in:
Jay McCarthy
parent
3fe91f0fdd
commit
2751ace762
|
|
@ -1,5 +1,5 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (only-in "private/list.rkt" split-at))
|
||||
(provide first second third fourth fifth sixth seventh eighth ninth tenth
|
||||
|
||||
last-pair last rest
|
||||
|
|
@ -113,14 +113,6 @@
|
|||
(raise-type-error 'drop "non-negative exact integer" n))
|
||||
(or (drop* list n) (too-large 'drop list n)))
|
||||
|
||||
(define (split-at list0 n0)
|
||||
(unless (exact-nonnegative-integer? n0)
|
||||
(raise-type-error 'split-at "non-negative exact integer" n0))
|
||||
(let loop ([list list0] [n n0] [pfx '()])
|
||||
(cond [(zero? n) (values (reverse pfx) list)]
|
||||
[(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))]
|
||||
[else (too-large 'take list0 n0)])))
|
||||
|
||||
;; take/drop-right are originally from srfi-1, uses the same lead-pointer trick
|
||||
|
||||
(define (take-right list n)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
(module base "pre-base.rkt"
|
||||
|
||||
(#%require "hash.rkt"
|
||||
(#%require "sequence.rkt"
|
||||
"hash.rkt"
|
||||
"list.rkt"
|
||||
"string.rkt"
|
||||
"stxcase-scheme.rkt"
|
||||
|
|
@ -22,6 +23,7 @@
|
|||
regexp-replace*
|
||||
new-apply-proc)
|
||||
struct
|
||||
(all-from "sequence.rkt")
|
||||
(all-from "hash.rkt")
|
||||
(all-from "list.rkt")
|
||||
(all-from-except "string.rkt"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
|
||||
(module list "pre-base.rkt"
|
||||
|
||||
(provide foldl
|
||||
(provide split-at
|
||||
|
||||
foldl
|
||||
foldr
|
||||
|
||||
remv
|
||||
|
|
@ -24,6 +26,19 @@
|
|||
build-list
|
||||
|
||||
compose)
|
||||
|
||||
(define (split-at list0 n0)
|
||||
(unless (exact-nonnegative-integer? n0)
|
||||
(raise-type-error 'split-at "non-negative exact integer" n0))
|
||||
(let loop ([list list0] [n n0] [pfx '()])
|
||||
(cond [(zero? n) (values (reverse pfx) list)]
|
||||
[(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))]
|
||||
[else
|
||||
(raise-mismatch-error
|
||||
'split-at
|
||||
(format "index ~e too large for list~a: "
|
||||
n0 (if (list? list0) "" " (not a proper list)"))
|
||||
list0)])))
|
||||
|
||||
(#%require (rename "sort.rkt" raw-sort sort)
|
||||
(for-syntax "stxcase-scheme.rkt"))
|
||||
|
|
|
|||
247
collects/racket/private/sequence.rkt
Normal file
247
collects/racket/private/sequence.rkt
Normal file
|
|
@ -0,0 +1,247 @@
|
|||
(module sequence "pre-base.rkt"
|
||||
(require "list.rkt")
|
||||
|
||||
(define empty-seqn
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(values
|
||||
void
|
||||
void
|
||||
void
|
||||
(λ (pos) #f)
|
||||
(λ (val) #t)
|
||||
(λ (pos val) #t)))))
|
||||
|
||||
(define (seqn->list s)
|
||||
(for/list ([v s]) v))
|
||||
|
||||
(define-syntax-rule (-seqn-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 seqn-cons
|
||||
(case-lambda
|
||||
[()
|
||||
(error 'seqn-cons "expects a sequence to extend, but received no arguments")]
|
||||
[(s)
|
||||
(-seqn-cons (values) s)]
|
||||
[(v s)
|
||||
(-seqn-cons (values v) s)]
|
||||
[vs*s
|
||||
(define-values (vs sl) (split-at vs*s (sub1 (length vs*s))))
|
||||
(-seqn-cons (apply values vs) (car sl))]))
|
||||
|
||||
(define (seqn-first s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(unless (more?)
|
||||
(error 'seqn-first "expects a sequence with at least one element"))
|
||||
(next))
|
||||
|
||||
(define (seqn-rest s)
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(unless (more?)
|
||||
(error 'seqn-rest "expects a sequence with at least one element"))
|
||||
(next)
|
||||
(values
|
||||
(λ (pos) (next))
|
||||
(λ (x) x)
|
||||
0
|
||||
(λ (pos) (more?))
|
||||
(λ _ #t)
|
||||
(λ _ #t)))))
|
||||
|
||||
(define (seqn-length s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ([i 0])
|
||||
(if (more?)
|
||||
(begin (next) (loop (add1 i)))
|
||||
i)))
|
||||
|
||||
(define (seqn-ref s i)
|
||||
(unless (and (exact-integer? i) (i . >= . 0))
|
||||
(error 'seqn-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 'seqn-ref "expects a sequence with at least ~e element(s)" i)])))
|
||||
|
||||
(define (seqn-tail s i)
|
||||
(unless (and (exact-integer? i) (i . >= . 0))
|
||||
(error 'seqn-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 'seqn-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 (-seqn-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 (seqn-append . l)
|
||||
(unless (andmap sequence? l)
|
||||
(error 'seqn-append "expects only sequence arguments, given ~e" l))
|
||||
(-seqn-append empty-seqn l))
|
||||
|
||||
(define (seqn-map f s)
|
||||
(unless (procedure? f)
|
||||
(error 'seqn-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 (seqn-andmap f s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ()
|
||||
(if (more?)
|
||||
(and (call-with-values next f) (loop))
|
||||
#t)))
|
||||
|
||||
(define (seqn-ormap f s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ()
|
||||
(if (more?)
|
||||
(or (call-with-values next f) (loop))
|
||||
#f)))
|
||||
|
||||
(define (seqn-for-each f s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ()
|
||||
(when (more?)
|
||||
(call-with-values next f)
|
||||
(loop))))
|
||||
|
||||
(define (seqn-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 (seqn-filter f s)
|
||||
(unless (procedure? f)
|
||||
(error 'seqn-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 (seqn-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 (seqn-count s)
|
||||
(define-values (more? next) (sequence-generate s))
|
||||
(let loop ([n 0])
|
||||
(if (more?)
|
||||
(begin (next) (loop (add1 n)))
|
||||
n)))
|
||||
|
||||
(provide empty-seqn
|
||||
seqn->list
|
||||
seqn-cons
|
||||
seqn-first
|
||||
seqn-rest
|
||||
seqn-length
|
||||
seqn-ref
|
||||
seqn-tail
|
||||
seqn-append
|
||||
seqn-map
|
||||
seqn-andmap
|
||||
seqn-ormap
|
||||
seqn-for-each
|
||||
seqn-fold
|
||||
seqn-filter
|
||||
seqn-add-between
|
||||
seqn-count))
|
||||
|
|
@ -63,6 +63,89 @@ each element in the sequence.
|
|||
@defproc[(sequence? [v any/c]) boolean?]{ Return @scheme[#t] if
|
||||
@scheme[v] can be used as a sequence, @scheme[#f] otherwise.}
|
||||
|
||||
@defthing[empty-seqn sequence?]{ A sequence with no elements. }
|
||||
|
||||
@defthing[(seqn->list [s (sequence/c any/c)]) list?]{ Returns a list whose
|
||||
elements are the elements of the @scheme[s]. If @scheme[s] is infinite, this
|
||||
function does not terminate. }
|
||||
|
||||
@defproc[(seqn-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[(seqn-first [s sequence?])
|
||||
(values any/c ...)]{
|
||||
Returns the first element of @scheme[s].}
|
||||
|
||||
@defproc[(seqn-rest [s sequence?])
|
||||
sequence?]{
|
||||
Returns a sequence equivalent to @scheme[s], except the first element is omitted.}
|
||||
|
||||
@defproc[(seqn-length [s sequence?])
|
||||
exact-nonnegative-integer?]{
|
||||
Returns the number of elements of @scheme[s]. If @scheme[s] is infinite, this
|
||||
function does not terminate. }
|
||||
|
||||
@defproc[(seqn-ref [s sequence?] [i exact-nonnegative-integer?])
|
||||
(values any/c ...)]{
|
||||
Returns the @scheme[i]th element of @scheme[s].}
|
||||
|
||||
@defproc[(seqn-tail [s sequence?] [i exact-nonnegative-integer?])
|
||||
sequence?]{
|
||||
Returns a sequence equivalent to @scheme[s], except the first @scheme[i] elements are omitted.}
|
||||
|
||||
@defproc[(seqn-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. }
|
||||
|
||||
@defproc[(seqn-map [f (-> any/c ..._0 (values any/c ..._1))]
|
||||
[s (sequence/c any/c ..._0)])
|
||||
(sequence/c any/c ..._1)]{
|
||||
Returns a sequence that contains @scheme[f] applied to each element of @scheme[s]. The new sequence is constructed lazily. }
|
||||
|
||||
@defproc[(seqn-andmap [f (-> any/c ..._0 boolean?)]
|
||||
[s (sequence/c any/c ..._0)])
|
||||
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[(seqn-ormap [f (-> any/c ..._0 boolean?)]
|
||||
[s (sequence/c any/c ..._0)])
|
||||
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[(seqn-for-each [f (-> any/c ..._0 any)]
|
||||
[s (sequence/c any/c ..._0)])
|
||||
(void)]{
|
||||
Applies @scheme[f] to each element of @scheme[s]. If @scheme[s] is infinite, this function does not terminate. }
|
||||
|
||||
@defproc[(seqn-fold [f (-> any/c any/c ..._0 any/c)]
|
||||
[i any/c]
|
||||
[s (sequence/c any/c ..._0)])
|
||||
(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[(seqn-filter [f (-> any/c ..._0 boolean?)]
|
||||
[s (sequence/c any/c ..._0)])
|
||||
(sequence/c any/c ..._0)]{
|
||||
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[(seqn-add-between [s sequence?] [e any/c])
|
||||
sequence?]{
|
||||
Returns a sequence whose elements are the elements of @scheme[s] except in between each is @scheme[e]. The new sequence is constructed lazily. }
|
||||
|
||||
@defproc[(seqn-count [s sequence?])
|
||||
exact-nonnegative-integer?]{
|
||||
Returns the number of elements in @scheme[s]. If @scheme[s] is infinite, this function does not terminate. }
|
||||
|
||||
@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
|
||||
|
|
|
|||
|
|
@ -288,4 +288,105 @@
|
|||
(list (maker) (maker) (maker)
|
||||
(maker) (maker) (maker))))
|
||||
|
||||
;; New operators
|
||||
(require racket/private/sequence)
|
||||
|
||||
(test '(0 1 2) 'seqn->list (seqn->list (in-range 3)))
|
||||
(arity-test seqn->list 1 1)
|
||||
(err/rt-test (seqn->list 1))
|
||||
|
||||
(test '() 'empty-seqn (seqn->list empty-seqn))
|
||||
|
||||
; XXX How do I check rest arity?
|
||||
(test '(0 1 2) 'seqn-cons (seqn->list (seqn-cons 0 (in-range 1 3))))
|
||||
(test '((0 1)) 'seqn-cons
|
||||
(for/list ([(a b) (seqn-cons 0 1 empty-seqn)])
|
||||
(list a b)))
|
||||
|
||||
(arity-test seqn-first 1 1)
|
||||
(err/rt-test (seqn-first 1))
|
||||
(test 0 'seqn-first (seqn-first (in-naturals)))
|
||||
(test #t
|
||||
'seqn-first
|
||||
(equal? (list 0 1)
|
||||
(call-with-values
|
||||
(λ ()
|
||||
(seqn-first (seqn-cons 0 1 empty-seqn)))
|
||||
(λ args args))))
|
||||
|
||||
(arity-test seqn-rest 1 1)
|
||||
(test '(1 2) 'seqn-rest (seqn->list (seqn-rest (in-range 3))))
|
||||
|
||||
(arity-test seqn-length 1 1)
|
||||
(err/rt-test (seqn-length 1))
|
||||
(test 3 'seqn-length (seqn-length (in-range 3)))
|
||||
(test 3 'seqn-length (seqn-length #hasheq((1 . 'a) (2 . 'b) (3 . 'c))))
|
||||
|
||||
(arity-test seqn-ref 2 2)
|
||||
(err/rt-test (seqn-ref 2 0))
|
||||
(err/rt-test (seqn-ref (in-naturals) -1) exn:fail?)
|
||||
(err/rt-test (seqn-ref (in-naturals) 1.0) exn:fail?)
|
||||
(test 0 'seqn-ref (seqn-ref (in-naturals) 0))
|
||||
(test 1 'seqn-ref (seqn-ref (in-naturals) 1))
|
||||
(test 25 'seqn-ref (seqn-ref (in-naturals) 25))
|
||||
|
||||
(arity-test seqn-tail 2 2)
|
||||
(err/rt-test (seqn-tail (in-naturals) -1) exn:fail?)
|
||||
(err/rt-test (seqn-tail (in-naturals) 1.0) exn:fail?)
|
||||
(test 4 'seqn-ref (seqn-ref (seqn-tail (in-naturals) 4) 0))
|
||||
(test 5 'seqn-ref (seqn-ref (seqn-tail (in-naturals) 4) 1))
|
||||
(test 29 'seqn-ref (seqn-ref (seqn-tail (in-naturals) 4) 25))
|
||||
|
||||
; XXX Check for rest
|
||||
(err/rt-test (seqn-append 1) exn:fail?)
|
||||
(err/rt-test (seqn-append (in-naturals) 1) exn:fail?)
|
||||
(test '() 'seqn-append (seqn->list (seqn-append)))
|
||||
(test 5 'seqn-append (seqn-ref (seqn-append (in-naturals)) 5))
|
||||
(test 5 'seqn-append (seqn-ref (seqn-append (in-range 3) (in-range 3 10)) 5))
|
||||
|
||||
(arity-test seqn-map 2 2)
|
||||
(err/rt-test (seqn-map 2 (in-naturals)) exn:fail?)
|
||||
(test '(1 2 3) 'seqn-map (seqn->list (seqn-map add1 (in-range 3))))
|
||||
(test 3 'seqn-map (seqn-ref (seqn-map add1 (in-naturals)) 2))
|
||||
|
||||
(arity-test seqn-andmap 2 2)
|
||||
(err/rt-test (seqn-andmap 2 (in-naturals)))
|
||||
(test #t 'seqn-andmap (seqn-andmap even? (seqn-cons 2 empty-seqn)))
|
||||
(test #f 'seqn-andmap (seqn-andmap even? (in-naturals)))
|
||||
|
||||
(arity-test seqn-ormap 2 2)
|
||||
(err/rt-test (seqn-ormap 2 (in-naturals)))
|
||||
(test #t 'seqn-ormap (seqn-ormap even? (seqn-cons 2 empty-seqn)))
|
||||
(test #f 'seqn-ormap (seqn-ormap even? (seqn-cons 1 empty-seqn)))
|
||||
(test #t 'seqn-ormap (seqn-ormap even? (in-naturals)))
|
||||
|
||||
(arity-test seqn-for-each 2 2)
|
||||
(err/rt-test (seqn-for-each 2 (in-naturals)))
|
||||
(test (vector 0 1 2)
|
||||
'seqn-for-each
|
||||
(let ([v (vector #f #f #f)])
|
||||
(seqn-for-each (λ (i) (vector-set! v i i)) (in-range 3))
|
||||
v))
|
||||
|
||||
(arity-test seqn-fold 3 3)
|
||||
(err/rt-test (seqn-fold 2 (in-naturals) 0))
|
||||
(test 6 'seqn-fold (seqn-fold + 0 (in-range 4)))
|
||||
|
||||
(arity-test seqn-filter 2 2)
|
||||
(err/rt-test (seqn-filter 2 (in-naturals)) exn:fail?)
|
||||
(test 4 'seqn-filter (seqn-ref (seqn-filter even? (in-naturals)) 2))
|
||||
|
||||
(arity-test seqn-add-between 2 2)
|
||||
(test 0 'seqn-add-between (seqn-ref (seqn-add-between (in-naturals) #t) 0))
|
||||
(test #t 'seqn-add-between (seqn-ref (seqn-add-between (in-naturals) #t) 1))
|
||||
(test 1 'seqn-add-between (seqn-ref (seqn-add-between (in-naturals) #t) 2))
|
||||
(test #t 'seqn-add-between (seqn-ref (seqn-add-between (in-naturals) #t) 3))
|
||||
|
||||
(arity-test seqn-count 1 1)
|
||||
(test 0 'seqn-count (seqn-count empty-seqn))
|
||||
(test 1 'seqn-count (seqn-count (in-range 1)))
|
||||
(test 10 'seqn-count (seqn-count (in-range 10)))
|
||||
(let ([r (random 100)])
|
||||
(test r 'seqn-count (seqn-count (in-range r))))
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user