null? copy! map-into! etc.

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

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)

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)
+  (assert (<= 0 start (+ start len) (sequence-length s))
-               (procedure? proc)
-               (<= 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)

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

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))
 

s48/sequences/specseqs.scm

@@ -1,7 +1,7 @@
 ; Copyright (c) 2003 RT Happe <rthappe at web de>
 ; 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)
+; (define (list-fill! xs x)
-  (pair-for-each (lambda (p) (set-car! p x)) xs))
+;   (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)))))))

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)