From 93f8fe8c5c01b0839515bb5b249954c45e690e68 Mon Sep 17 00:00:00 2001 From: Rolf-Thomas Happe Date: Sat, 22 Mar 2003 22:22:15 +0000 Subject: [PATCH] null? copy! map-into! etc. --- s48/sequences/README | 57 +++++++++++++++++++++---- s48/sequences/composeqs.scm | 32 ++++++++++++++- s48/sequences/genseqs.scm | 80 +++++++++++++++++++++++++++++------- s48/sequences/interfaces.scm | 7 ++++ s48/sequences/packages.scm | 4 +- s48/sequences/specseqs.scm | 23 +++++++++-- s48/sequences/vecnames.scm | 4 ++ 7 files changed, 178 insertions(+), 29 deletions(-) diff --git a/s48/sequences/README b/s48/sequences/README index 1846cb0..9bb569d 100644 --- a/s48/sequences/README +++ b/s48/sequences/README @@ -25,15 +25,12 @@ VECTOR-LIB SEQUENCE-LIB ABSEQUENCES, also SL * Predicates or so vector? sequence? absequence? sequence-behavior? -[ versions with 1 sequence and optional start & end parameters ] +vector-null? sequence-null? vector-every sequence-every vector-any sequence-any -[ versions with >1 sequence but no optional start & end parameters ] vectors-every sequences-every vectors-any sequences-any -[ 2 seq. args and opt. start & end parms for both seqs ] vector= sequence= -[ >=0 sequence args, no start & end parameters ] vectors= sequences= * Constructors @@ -54,6 +51,7 @@ vector-ref sequence-ref absequence-ref absequence:behavior vector-copy sequence-copy sequence-copy/maker +vector-copy! sequence-copy! subvector subsequence * Modification @@ -65,15 +63,15 @@ sequence-tabulate! vector-tabulate! vector-append sequence-append * Fold, Unfold & Map -[ versions with 1 sequence and optional start & end parameters ] vector-map sequence-map sequence-map/maker +vector-map-into! sequence-map-into! vector-for-each sequence-for-each vector-fold sequence-fold vector-fold-right sequence-fold-right -[ versions with >1 sequence but no start & end parameters ] vectors-map sequences-map sequences-map/maker +vectors-map-into! sequences-map-into! vectors-for-each sequences-for-each vectors-fold sequences-fold vectors-fold-right sequences-fold-right @@ -140,8 +138,11 @@ library grows, but please report deviations anyway. the respective srfi, the result complies with the srfi spec. E.g. ``sequences-fold = fold'' on lists, ``sequence-fold = string-fold'' on strings. - Exception: SEQUENCE= vs. STRING= -- parameter lists don't match (ELT=) - + Attention: + SEQUENCE= vs. STRING= -- parameter lists don't match (ELT=) + SEQUENCE-TABULATE! (and VECTOR-TABULATE) -- + parameter list is patterned after (STRING-TABULATE proc len), not + after (LIST-TABULATE len proc). * Predicates @@ -155,6 +156,13 @@ inclusions the boolean B0 ==> B1 and B2 ==> B1. * +(vector-null? s) --> b +(sequence-null? s) --> b + +Synopsis: Return B := boolean(s.length = 0). + + * + (vector-every foo? s [start end]) --> x (sequence-every foo? s [start end]) --> x @@ -224,6 +232,7 @@ of minimal length with the elements S[0] = X0, ... (vector-tabulate proc len) --> s Synopsis: Make vector s[0:len) with s[i] := (proc i). +[ after (string-tabulate proc len) rather than (list-tabulate len proc) ] * @@ -286,6 +295,13 @@ S1 = < s0[start+i] : i in [0:end-start) >. * +(vector-copy! s1 start1 s0 [start0 end0]) --> unspec +(sequence-copy! s1 start1 s0 [start0 end0]) --> unspec + +Synopsis: Set s1[start1 + i] := s0[start0 + i] for 0 <= i < end0 - start0. + + * + (subvector s0 start end) --> s1 (subsequence s0 start end) --> s1 @@ -352,6 +368,31 @@ arg. ] * +(vector-map-into! s1 proc s0 [start1 end1 start0]) --> s1 +(sequence-map-into! s1 proc s0 [start1 end1 start0]) --> s1 + +Synopsis: Set s1[start1 + i] := (proc s0[start0 + i]) +for 0 <= i < end1 - start1, return s1. + +Attention: differing from CL's MAP-INTO, these procs expect +end1 - start1 <= s0.length - start0, i.e. the destination S1 drives the +loop, as with MAP! in SRFI-1. Differing from SEQUENCE-COPY!, the optionals +relate 2 to the destination S1 and 1 to the source S0 instead of 1 to the +destination and 2 to the source. (Why? Because of the different loop +termination criteria: dest length vs. src length.) + + * + +(vectors-map-into! s1 proc s00 ...) --> s1 +(sequences-map-into! s1 proc s00 ...) --> s1 + +Synopsis: Set s1[i] := (proc s00[i] ...) for i in [0:s1.length), return s1. + +Attention: differing from CL's MAP-INTO, these procs expect the sequences +S00, ... to be no less long than the destination S1, like MAP! in SRFI-1. + + * + (vector-for-each proc s [start end]) --> unspec (vectors-for-each f s0 s1 ...) --> unspec (sequence-for-each proc s [start end]) --> unspec diff --git a/s48/sequences/composeqs.scm b/s48/sequences/composeqs.scm index a630c4d..ccf6f42 100644 --- a/s48/sequences/composeqs.scm +++ b/s48/sequences/composeqs.scm @@ -2,7 +2,8 @@ ; See the file COPYING distributed with the Scheme Untergrund Library ;;; sequence operations definABLE in terms of the elementary operations -;;; with no regard to the concrete sequence type +;;; The procedures dispatch early on the specific sequence type but +;;; implement the ``generic behaviour.'' (define (sequence->list s . opts) (cond ((vector? s) @@ -20,7 +21,7 @@ (apply vector-fill! s x opts)) ((string? s) (apply string-fill! s x opts)) - ((and (pair? s) (null? opts)) + ((pair? s) (apply list-fill! s x opts)) (else (apply contiguous-sequence-fill! s x opts)))) @@ -55,6 +56,16 @@ (apply contiguous-sequence-copy s opts)))) +(define (sequence-copy! s1 start1 s0 . opts) + (cond + ((and (vector? s1) (vector? s0)) + (apply vector-copy! s1 start1 s0 opts)) + ((and (string? s1) (string? s0)) + (apply string-copy! s1 start1 s0 opts)) + (else + (apply contiguous-sequence-copy! s1 start1 s0 opts)))) + + (define (sequence-append seq . seqs) (cond ((vector? seq) (apply vector-append seq seqs)) @@ -77,6 +88,15 @@ (apply contiguous-sequence-map proc s opts)))) +(define (sequence-map-into! s1 proc s0 . opts) + (cond ((and (vector? s1) (vector? s0)) + (apply vector-map-into! s1 proc s0 opts)) + ((and (pair? s1) (pair? s0) (null? opts)) + (map! (lambda (x y) (proc y)) s1 s0)) + (else + (apply contiguous-sequence-map-into! s1 proc s0 opts)))) + + (define (sequence-for-each proc s . opts) (cond ((vector? s) (apply vector-for-each proc s opts)) @@ -109,6 +129,13 @@ (else (apply contiguous-sequence-fold-right kons nil s opts)))) +(define (sequence-null? s) + (cond ((vector? s) (vector-null? s)) + ((string? s) (string-null? s)) + ((pair? s) (null? s)) + (else (contiguous-sequence-null? s)))) + + (define (sequence-any pred s . opts) (cond ((vector? s) (apply vector-any pred s opts)) @@ -135,6 +162,7 @@ (define sequence-append contiguous-sequence-append) (define sequences-map contiguous-sequences-map) (define sequences-map/maker contiguous-sequences-map/maker) +(define sequences-map-into! contiguous-sequences-map-into!) (define sequences-for-each contiguous-sequences-for-each) (define sequences-fold contiguous-sequences-fold) (define sequences-fold-right contiguous-sequences-fold-right) diff --git a/s48/sequences/genseqs.scm b/s48/sequences/genseqs.scm index f87a3d1..38c2f37 100644 --- a/s48/sequences/genseqs.scm +++ b/s48/sequences/genseqs.scm @@ -12,11 +12,14 @@ ;;; sequence-tabulate! ;;; subsequence ;;; sequence-copy +;;; sequence-copy! ;;; sequence-append ;;; sequence-map sequences-map sequences-map/maker +;;; sequence-map-into! sequences-map-into! ;;; sequence-for-each sequences-for-each ;;; sequence-fold sequences-fold ;;; sequence-fold-right sequence-fold-right +;;; sequence-null? ;;; sequence-any sequences-any ;;; sequence-every sequences-every ;;; sequence= sequences= @@ -32,7 +35,8 @@ (define (sequence->list s . opts) (let-optionals opts ((start 0) (end (sequence-length s))) - (assert (<= 0 start end)) + (assert (<= 0 start end (sequence-length s)) + sequence->list) (let loop ((i end) (xs '())) (if (= i start) xs (loop (- i 1) (cons (sequence-ref s (- i 1)) xs)))))) @@ -40,7 +44,8 @@ ;; unspecified return value as usual (define (sequence-fill! s x . opts) (let-optionals opts ((start 0) (end (sequence-length s))) - (assert (<= 0 start end)) + (assert (<= 0 start end (sequence-length s)) + sequence-fill!) (let loop ((i start)) (if (< i end) (begin @@ -49,9 +54,7 @@ (define (sequence-tabulate! s start proc len) - (assert (and (sequence? s) - (procedure? proc) - (<= 0 start (+ start len) (sequence-length s))) + (assert (<= 0 start (+ start len) (sequence-length s)) sequence-tabulate!) (do ((i 0 (+ i 1))) ((= i len) s) @@ -62,7 +65,8 @@ (define (sequence-copy/maker maker s . opts) (let-optionals opts ((start 0) (end (sequence-length s))) - (assert (<= 0 start end)) + (assert (<= 0 start end (sequence-length s)) + sequence-copy/maker) (let* ((len (- end start)) (ss (maker len))) (do ((i 0 (+ i 1))) @@ -76,6 +80,17 @@ s opts)) +(define (sequence-copy! s1 start1 s0 . opts) + (let-optionals opts ((start0 0) (end0 (sequence-length s0))) + (assert (<= 0 start0 end0 (sequence-length s0)) + sequence-copy!) + (assert (<= 0 start1 (+ start1 (- end0 start0)) (sequence-length s1)) + sequence-copy!) + (do ((i0 start0 (+ i0 1)) + (i1 start1 (+ i1 1))) + ((= i0 end0) (unspecific)) + (sequence-set! s1 i1 (sequence-ref s0 i0))))) + ;; ... (define (subsequence s start end) (sequence-copy s start end)) @@ -84,7 +99,8 @@ (define (sequence-fold kons nil s . opts) (let-optionals opts ((start 0) (end (sequence-length s))) - (assert (<= 0 start end)) + (assert (<= 0 start end (sequence-length s)) + sequence-fold) (let loop ((subtotal nil) (i start)) (if (= i end) subtotal (loop (kons (sequence-ref s i) subtotal) (+ i 1)))))) @@ -108,7 +124,8 @@ (define (sequence-fold-right kons nil s . opts) (let-optionals opts ((start 0) (end (sequence-length s))) - (assert (<= 0 start end)) + (assert (<= 0 start end (sequence-length s)) + sequence-fold-right) (let loop ((subtotal nil) (i end)) (if (= i start) subtotal (loop (kons (sequence-ref s (- i 1)) subtotal) (- i 1)))))) @@ -144,7 +161,8 @@ (define (sequence-for-each proc seq . opts) (let-optionals opts ((start 0) (end (sequence-length seq))) - (assert (<= 0 start end)) + (assert (<= 0 start end (sequence-length seq)) + sequence-for-each) (do ((i start (+ i 1))) ((= i end) (unspecific)) (proc (sequence-ref seq i))))) @@ -161,7 +179,8 @@ (define (sequence-map/maker maker proc seq . opts) (let-optionals opts ((start 0) (end (sequence-length seq))) - (assert (<= 0 start end)) + (assert (<= 0 start end (sequence-length seq)) + sequence-map/maker) (let ((res (maker (- end start)))) (do ((i start (+ i 1))) ((= i end) res) @@ -170,7 +189,7 @@ (define (sequence-map proc seq . opts) - (apply sequences-map/maker + (apply sequence-map/maker (lambda (n) (make-another-sequence seq n)) seq opts)) @@ -190,9 +209,39 @@ proc seq seqs)) +(define (sequence-map-into! s1 proc s0 . opts) + (let-optionals opts ((start1 0) + (end1 (sequence-length s1)) + (start0 0)) + (assert (<= 0 start0 (sequence-length s0)) + sequence-map-into!) + (assert (<= 0 start1 (sequence-length s1)) + sequence-map-into!) + (assert (<= (- end1 start1) (- (sequence-length s0) start0)) + sequence-map-into!) + (do ((i0 start0 (+ i0 1)) + (i1 start1 (+ i1 1))) + ((= i1 end1) s1) + (sequence-set! s1 i1 (proc (sequence-ref s0 i0)))))) + + +(define (sequences-map-into! seq proc . seqs) + (let ((end (sequence-length seq))) + (do ((i 0 (+ i 1))) + ((= i end) seq) + (sequence-set! seq i (apply proc + (map (lambda (s) (sequence-ref s i)) + seqs)))))) + + +(define (sequence-null? s) + (= (sequence-length s) 0)) + + (define (sequence-any foo? seq . opts) (let-optionals opts ((start 0) (end (sequence-length seq))) - (assert (<= 0 start end)) + (assert (<= 0 start end (sequence-length seq)) + sequence-any) (let loop ((i start)) (cond ((= i end) #f) ((foo? (sequence-ref seq i)) => id) @@ -212,7 +261,8 @@ (define (sequence-every foo? seq . opts) (let-optionals opts ((start 0) (end (sequence-length seq))) - (assert (<= 0 start end)) + (assert (<= 0 start end (sequence-length seq)) + sequence-every) (let loop ((i start) (res #t)) (cond ((= i end) res) ((foo? (sequence-ref seq i)) @@ -232,9 +282,10 @@ (define (sequence= elt= s0 s1 . opts) - (assert (procedure? elt=)) (let-optionals opts ((start0 0) (end0 (sequence-length s0)) (start1 0) (end1 (sequence-length s1))) + (assert (<= start0 end0 (sequence-length s0)) sequence=) + (assert (<= start1 end1 (sequence-length s1)) sequence=) (and (= (- end0 start0) (- end1 start1)) (let loop ((i0 start0) (i1 start1)) @@ -246,7 +297,6 @@ (define (sequences= elt= . seqs) - (assert (procedure? elt=)) (if (null? seqs) #t (let loop ((s (first seqs)) (ss (rest seqs))) (cond ((null? ss) #t) diff --git a/s48/sequences/interfaces.scm b/s48/sequences/interfaces.scm index 6772350..a787af1 100644 --- a/s48/sequences/interfaces.scm +++ b/s48/sequences/interfaces.scm @@ -16,13 +16,16 @@ sequence-fill! subsequence sequence-copy + sequence-copy! sequence-copy/maker sequence-append sequence-map sequences-map sequence-map/maker sequences-map/maker + sequence-map-into! sequences-map-into! sequence-for-each sequences-for-each sequence-fold sequences-fold sequence-fold-right sequences-fold-right + sequence-null? sequence-any sequences-any sequence-every sequences-every sequence= sequences= @@ -70,15 +73,19 @@ vector-tabulate! subvector vector-copy + vector-copy! vector-append vector-map ; forget the optional MAKER arg + vector-map-into! vector-for-each vector-fold vector-fold-right + vector-null? vector-any vector-every vector= vectors-map ; but not vectors-map/maker + vectors-map-into! vectors-for-each vectors-fold vectors-fold-right diff --git a/s48/sequences/packages.scm b/s48/sequences/packages.scm index 4dc8bcd..09b3ab0 100644 --- a/s48/sequences/packages.scm +++ b/s48/sequences/packages.scm @@ -13,8 +13,10 @@ ;; specialists for lists, vectors, strings (define-structure sequence-specifics sequence-specifics-face - (open srfi-1 ; list procs + (open krims ; assert + srfi-1+ ; list procs srfi-13 ; string procs + let-opt ; let-optionals [ from scsh ] scheme) (files specseqs)) diff --git a/s48/sequences/specseqs.scm b/s48/sequences/specseqs.scm index 1bdb4dd..ca39a4f 100644 --- a/s48/sequences/specseqs.scm +++ b/s48/sequences/specseqs.scm @@ -1,7 +1,7 @@ ; Copyright (c) 2003 RT Happe ; See the file COPYING distributed with the Scheme Untergrund Library -;;; sequence procedures for specific types (for lists, actually) +;;; some sequence procedures for specific types (for lists, actually) ;;; list-set! sublist list-fill! ;; unspecified return value as usual @@ -12,5 +12,22 @@ (take (drop xs start) (- end start))) ;; unspecified return value -- no [start end] for now -(define (list-fill! xs x) - (pair-for-each (lambda (p) (set-car! p x)) xs)) +; (define (list-fill! xs x) +; (pair-for-each (lambda (p) (set-car! p x)) xs)) + +;; unspecified return value +(define (list-fill! xs x . opts) + (let-optionals* opts ((start 0 (<= 0 start)) + ;; the default value is only used to make the + ;; check work. Don't want to compute xs' length. + (end start (<= start end) end-supplied?)) + (let loop ((xs xs) (i 0)) + (cond ((null? xs) + (assert (or (not end-supplied?) + (= i end)) + list-fill!)) + ((< i start) + (loop (rest xs) (+ i 1))) + ((if end-supplied? (< i end) #t) + (set-car! xs x) + (loop (rest xs) (+ i 1))))))) diff --git a/s48/sequences/vecnames.scm b/s48/sequences/vecnames.scm index e258382..50d3a86 100644 --- a/s48/sequences/vecnames.scm +++ b/s48/sequences/vecnames.scm @@ -6,17 +6,21 @@ (define subvector subsequence) (define vector-copy sequence-copy) +(define vector-copy! sequence-copy!) (define vector-fill! sequence-fill!) ; with opt. start & end (define vector-tabulate! sequence-tabulate!) (define vector-append sequence-append) (define vector-map sequence-map) +(define vector-map-into! sequence-map-into!) (define vector-for-each sequence-for-each) (define vector-fold sequence-fold) (define vector-fold-right sequence-fold-right) +(define vector-null? sequence-null?) (define vector-any sequence-any) (define vector-every sequence-every) (define vector= sequence=) (define vectors-map sequences-map) +(define vectors-map-into! sequences-map-into!) (define vectors-for-each sequences-for-each) (define vectors-fold sequences-fold) (define vectors-fold-right sequences-fold-right)