tabulate; list->vector bug fix

s48/sequences/README

@@ -38,7 +38,9 @@ vectors=              sequences=
 
 * Constructors
 make-vector           make-another-sequence    make-absequence/behavior
-vector                                         absequence/behavior
+vector
+vector-tabulate
+                                               absequence/behavior
                                                make-sequence-behavior
                                                make-absequence-record
 
@@ -57,6 +59,7 @@ subvector             subsequence
 * Modification
 vector-set!           sequence-set!            absequence-set!
 sequence-fill!        vector-fill!             absequence-fill!
+sequence-tabulate!    vector-tabulate!
 
 * Reverse & Append
 vector-append         sequence-append
@@ -218,6 +221,12 @@ 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).
+
+                                  *
+
 (make-sequence-behavior maker predicate getter setter meter) --> sb
 
 Synopsis: Package the concrete sequence behaviour (basic procedures
@@ -231,7 +240,7 @@ in the absequence record ABS.
 
 List & Sequence Conversion
 
-(list->vector xs [sbart end]) --> s
+(list->vector xs [start end]) --> s
 (list->absequence/behavior sb xs [start end]) --> s
 
 Synopsis:  Make a new vector (absequence with sequence-behavior SB) S
@@ -302,6 +311,16 @@ Synopsis:  Set s[i] := x for all i in [start:end) etc.
 
                                 *
 
+(vector-tabulate! s start proc len) --> s
+(sequence-tabulate! s start proc len) --> s
+
+Synopsis:  Set s[start+i] := (proc i) for all i in [0:len), return s.
+[ Destructive-update analogue to STRING-TABULATE, exceptionally with a
+  useful return value. ]
+
+                                *
+
+
 Reverse & Append
 
 (vector-append s0 ...) --> s

s48/sequences/composeqs.scm

@@ -26,6 +26,11 @@
          (apply contiguous-sequence-fill! s x opts))))
 
 
+(define (sequence-tabulate! s start proc len)
+  ((if (vector? s) vector-tabulate! sequence-tabulate!)
+   s start proc len))
+
+
 (define (subsequence s start end)
   (cond ((vector? s)
          (subvector s start end))

s48/sequences/genseqs.scm

@@ -9,6 +9,7 @@
 ;;;
 ;;; sequence->list
 ;;; sequence-fill!
+;;; sequence-tabulate!
 ;;; subsequence
 ;;; sequence-copy
 ;;; sequence-append
@@ -23,7 +24,7 @@
 (define (id x) x)
 
 ;; seqs : nonempty proper list of sequences
-;; compute min sequence-length
+;; compute min sequence-length [ for internal use ]
 (define (sequences-length seqs)
   ;; we got the time, we got the space ...
   (apply min (map sequence-length seqs)))
@@ -47,6 +48,17 @@
             (loop (+ i 1)))))))
 
 
+(define (sequence-tabulate! s start proc len)
+  (assert (and (sequence? s)
+               (procedure? proc)
+               (<= 0 start (+ start len) (sequence-length s)))
+          sequence-tabulate!)
+  (do ((i 0 (+ i 1)))
+      ((= i len) s)
+    (sequence-set! s (+ start i) (proc i))))
+
+
+
 (define (sequence-copy/maker maker s . opts)
   (let-optionals opts ((start 0)
                        (end (sequence-length s)))

s48/sequences/interfaces.scm

@@ -12,6 +12,7 @@
 ;; things definable in terms of the basic protocol
 (define-interface sequence-extras-face
   (export sequence->list
+          sequence-tabulate!
           sequence-fill!
           subsequence
           sequence-copy
@@ -52,9 +53,11 @@
 ;; [ extends the union of SEQUENCE-BASICS- and -EXTRAS-INTERFACE with
 ;;   `VECTOR' replacing `SEQUENCE' ]
 (define-interface vector-lib-face
-  (export ;; std constructors
-          vector
+  (export ;; constructors and the like
           make-vector
+          vector
+          list->vector                  ; with opts
+          vector-tabulate
           ;; basics w/o the vanilla constructor
           vector?
           vector-length
@@ -64,6 +67,7 @@
           ;; extras
           vector->list
           vector-fill!
+          vector-tabulate!
           subvector
           vector-copy
           vector-append

s48/sequences/packages.scm

@@ -48,7 +48,7 @@
   (open krims                           ; assert
         util                            ; unspecific
         let-opt                         ; let-optionals [ from scsh ]
-        srfi-1+                         ; append! first rest
+        srfi-1+                         ; append! drop first rest
         scheme)
   ;; bind the basic operations to vector specialists
   (begin
@@ -58,36 +58,9 @@
     (define sequence-set! vector-set!)
     (define (make-another-sequence v k . maybe-fill)
       (apply make-vector k maybe-fill)))
-  (files genseqs)
-  ;; 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)
-    (define vector-fold sequence-fold)
-    (define vector-fold-right sequence-fold-right)
-    (define vector-any sequence-any)
-    (define vector-every sequence-every)
-    (define vector= sequence=)
-    (define vectors-map sequences-map)
-    (define vectors-for-each sequences-for-each)
-    (define vectors-fold sequences-fold)
-    (define vectors-fold-right sequences-fold-right)
-    (define vectors-any sequences-any)
-    (define vectors-every sequences-every)
-    (define vectors= sequences=)
-    (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))))))
-    ))
+  (files genseqs     ; generic code
+         vecnames)   ; renames stuff, defines constructors
+)
 
 
 ;; elementary and other general sequence operations, typically dispatching

s48/sequences/vecnames.scm

@@ -0,0 +1,39 @@
+; Copyright (c) 2003 RT Happe <rthappe at web de>
+; See the file COPYING distributed with the Scheme Untergrund Library
+
+;;; `vector names' for the sequence procedures specialised to vectors, and
+;;; some constructors or the like:  list->vector  vector-tabulate
+
+(define subvector subsequence)
+(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-for-each sequence-for-each)
+(define vector-fold sequence-fold)
+(define vector-fold-right sequence-fold-right)
+(define vector-any sequence-any)
+(define vector-every sequence-every)
+(define vector= sequence=)
+(define vectors-map sequences-map)
+(define vectors-for-each sequences-for-each)
+(define vectors-fold sequences-fold)
+(define vectors-fold-right sequences-fold-right)
+(define vectors-any sequences-any)
+(define vectors-every sequences-every)
+(define vectors= sequences=)
+
+;; redefine with opts
+(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 (drop xs start) (rest ys)))
+          ((= i end) v)
+        (vector-set! v (- i start) (first ys))))))
+
+
+(define (vector-tabulate proc len)
+  (vector-tabulate! (make-vector len) 0 proc len))