From c294d73444ecae60902e69ed5dedbd9eaef99f93 Mon Sep 17 00:00:00 2001 From: Rolf-Thomas Happe Date: Sat, 15 Feb 2003 02:48:52 +0000 Subject: [PATCH] some more start&ends --- s48/sequences/genseqs.scm | 61 ++++++++++++++++++++---------------- s48/sequences/interfaces.scm | 1 + s48/sequences/packages.scm | 15 +++++++-- s48/sequences/specseqs.scm | 2 ++ s48/sequences/uniseqs.scm | 15 ++++----- 5 files changed, 58 insertions(+), 36 deletions(-) diff --git a/s48/sequences/genseqs.scm b/s48/sequences/genseqs.scm index 892980f..dd26b0a 100644 --- a/s48/sequences/genseqs.scm +++ b/s48/sequences/genseqs.scm @@ -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)))))) diff --git a/s48/sequences/interfaces.scm b/s48/sequences/interfaces.scm index e3ba287..d4a7e08 100644 --- a/s48/sequences/interfaces.scm +++ b/s48/sequences/interfaces.scm @@ -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 diff --git a/s48/sequences/packages.scm b/s48/sequences/packages.scm index cd51c5f..5e80198 100644 --- a/s48/sequences/packages.scm +++ b/s48/sequences/packages.scm @@ -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)))))) )) diff --git a/s48/sequences/specseqs.scm b/s48/sequences/specseqs.scm index ca11837..044fe3e 100644 --- a/s48/sequences/specseqs.scm +++ b/s48/sequences/specseqs.scm @@ -14,3 +14,5 @@ ;; unspecified return value (define (list-fill! xs x) (pair-for-each (lambda (p) (set-car! p x)) xs)) + + diff --git a/s48/sequences/uniseqs.scm b/s48/sequences/uniseqs.scm index 2cf1985..766e3c6 100644 --- a/s48/sequences/uniseqs.scm +++ b/s48/sequences/uniseqs.scm @@ -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))) - (do ((i 0 (+ i 1)) - (xs xs (cdr xs))) - ((null? xs) s) - (behaved-sequence-set! s i (car xs))))) +(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))) + ((= i end) s) + (behaved-sequence-set! s (- i start) (car xs)))))) (define (behaved-sequence/type st . args) (list->behaved-sequence/type st args))