scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

some more start&ends

This commit is contained in:
Rolf-Thomas Happe 2003-02-15 02:48:52 +00:00
parent 12a2b6f06d
commit c294d73444
5 changed files with 58 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
s48/sequences/genseqs.scm
View File

@ -19,23 +19,28 @@
;;; sequence-any sequences-any
;;; sequence-every sequences-every
(define (sequence->list s)
(let loop ((i (sequence-length s)) (xs '()))
(if (= 0 i) xs
(loop (- i 1) (cons (sequence-ref s (- i 1)) xs)))))
(define (id x) x)
(define (sequence->list s . opts)
(let-optionals opts ((start 0) (end (sequence-length s)))
(assert (<= 0 start end))
(let loop ((i end) (xs '()))
(if (= i start) xs
(loop (- i 1) (cons (sequence-ref s (- i 1)) xs))))))
;; unspecified return value as usual
(define (sequence-fill! s x)
(let ((len (sequence-length s)))
(define (sequence-fill! s x . opts)
(let-optionals opts ((start 0) (end (sequence-length s)))
(assert (<= 0 start end))
(let loop ((i 0))
(if (< i len)
(if (< i end)
(begin
(sequence-set! s i x)
(loop (+ i 1)))))))
(define (subsequence s start end)
(assert (<= start end))
(assert (<= 0 start end))
(let* ((len (- end start))
(ss (make-another-sequence s len)))
(do ((i 0 (+ i 1)))
@ -43,14 +48,16 @@
(sequence-set! ss i (sequence-ref s (+ start i))))))
(define (sequence-copy s)
(subsequence s 0 (sequence-length s)))
(define (sequence-copy s . opts)
(let-optionals opts ((start 0) (end (sequence-length s)))
(assert (<= 0 start end))
(subsequence s start end)))
(define (sequence-fold kons nil s . opts)
(let-optionals opts ((start 0)
(end (sequence-length s)))
(assert (<= start end))
(assert (<= 0 start end))
(let loop ((subtotal nil) (i start))
(if (= i end) subtotal
(loop (kons (sequence-ref s i) subtotal) (+ i 1))))))
@ -74,7 +81,7 @@
(define (sequence-fold-right kons nil s . opts)
(let-optionals opts ((start 0)
(end (sequence-length s)))
(assert (<= start end))
(assert (<= 0 start end))
(let loop ((subtotal nil) (i end))
(if (= i start) subtotal
(loop (kons (sequence-ref s (- i 1)) subtotal) (- i 1))))))
@ -110,7 +117,7 @@
(define (sequence-for-each proc seq . opts)
(let-optionals opts ((start 0) (end (sequence-length seq)))
(assert (<= start end))
(assert (<= 0 start end))
(do ((i start (+ i 1)))
((= i end) (unspecific))
(proc (sequence-ref seq i)))))
@ -142,42 +149,42 @@
(sequence-set! res i (apply proc (map (lambda (s) (sequence-ref s i))
ss))))))
(define (sequence-any pred seq . opts)
(define (sequence-any foo? seq . opts)
(let-optionals opts ((start 0) (end (sequence-length seq)))
(assert (<= start end))
(assert (<= 0 start end))
(let loop ((i start))
(cond ((= i end) #f)
((pred (sequence-ref seq i)) #t)
((foo? (sequence-ref seq i)) => id)
(else (loop (+ i 1)))))))
(define (sequences-any pred . seqs)
(define (sequences-any foo? . seqs)
(if (null? seqs) #f
(let ((end (apply min (map sequence-length seqs))))
(let loop ((i 0))
(cond ((= i end) #f)
((apply pred (map (lambda (seq) (sequence-ref seq i))
((apply foo? (map (lambda (seq) (sequence-ref seq i))
seqs))
#t)
=> id)
(else (loop (+ i 1))))))))
(define (sequence-every pred seq . opts)
(define (sequence-every foo? seq . opts)
(let-optionals opts ((start 0) (end (sequence-length seq)))
(assert (<= start end))
(let loop ((i start))
(cond ((= i end) #t)
((pred (sequence-ref seq i))
(loop (+ i 1)))
(assert (<= 0 start end))
(let loop ((i start) (res #t))
(cond ((= i end) res)
((foo? (sequence-ref seq i))
=> (lambda (r) (loop (+ i 1) r)))
(else #f)))))
(define (sequences-every pred . seqs)
(define (sequences-every foo? . seqs)
(if (null? seqs) #t
(let ((end (apply min (map sequence-length seqs))))
(let loop ((i 0))
(cond ((= i end) #t)
((apply pred (map (lambda (seq) (sequence-ref seq i))
((apply foo? (map (lambda (seq) (sequence-ref seq i))
seqs))
(loop (+ i 1)))
(else #f))))))

1
s48/sequences/interfaces.scm
View File

@ -33,6 +33,7 @@
;; the sequence ADT etc.
(define-interface behaved-sequences-face
(export make-sequence-type
sequence-type?
make-behaved-sequence-record
behaved-sequence:type
make-behaved-sequence/type

15
s48/sequences/packages.scm
View File

@ -6,6 +6,8 @@
;; sequences as data + behaviour
(define-structure behaved-sequences behaved-sequences-face
(open srfi-9 ; define-record-type
krims ; assert
let-opt ; let-optionals [ from scsh ]
scheme)
(files uniseqs))
@ -46,7 +48,7 @@
(open krims ; assert
util ; unspecific
let-opt ; let-optionals [ from scsh ]
srfi-1 ; append!
srfi-1+ ; append! first rest
scheme)
;; bind the basic operations to vector specialists
(begin
@ -57,10 +59,11 @@
(define (make-another-sequence v k . maybe-fill)
(apply make-vector k maybe-fill)))
(files genseqs)
;; rename extras not supplied by scheme
;; rename extras not supplied by scheme and def list->vector with opts
(begin
(define subvector subsequence)
(define vector-copy sequence-copy)
(define vector-fill! sequence-fill!) ; with opt. start & end
(define vector-append sequence-append)
(define vector-map sequence-map)
(define vector-for-each sequence-for-each)
@ -74,6 +77,14 @@
(define vectors-fold-right sequences-fold-right)
(define vectors-any sequences-any)
(define vectors-every sequences-every)
(define (list->vector xs . opts)
(let-optionals opts ((start 0) (end (length xs)))
(assert (<= 0 start end))
(let ((v (make-vector (- end start))))
(do ((i start (+ i 1))
(ys xs (rest ys)))
((= i end) v)
(vector-set! v (- i start) (first ys))))))
))

2
s48/sequences/specseqs.scm
View File

@ -14,3 +14,5 @@
;; unspecified return value
(define (list-fill! xs x)
(pair-for-each (lambda (p) (set-car! p x)) xs))

11
s48/sequences/uniseqs.scm
View File

@ -44,13 +44,14 @@
(apply (sequence-type:maker st)
k maybe-fill)))
(define (list->behaved-sequence/type st xs)
(let* ((len (length xs))
(s (make-behaved-sequence/type st len)))
(define (list->behaved-sequence/type st xs . opts)
(let-optionals opts ((start 0) (end (length xs)))
(assert (<= 0 start end))
(let ((s (make-behaved-sequence/type st (- end start))))
(do ((i 0 (+ i 1))
(xs xs (cdr xs)))
((null? xs) s)
(behaved-sequence-set! s i (car xs)))))
((= i end) s)
(behaved-sequence-set! s (- i start) (car xs))))))
(define (behaved-sequence/type st . args)
(list->behaved-sequence/type st args))