From 066947bdb2881f4aa0a8fa79f035fbfc4323de38 Mon Sep 17 00:00:00 2001 From: Rolf-Thomas Happe Date: Thu, 20 Mar 2003 19:09:05 +0000 Subject: [PATCH] tabulate; list->vector bug fix --- s48/sequences/README | 23 +++++++++++++++++++-- s48/sequences/composeqs.scm | 5 +++++ s48/sequences/genseqs.scm | 14 ++++++++++++- s48/sequences/interfaces.scm | 8 ++++++-- s48/sequences/packages.scm | 35 ++++---------------------------- s48/sequences/vecnames.scm | 39 ++++++++++++++++++++++++++++++++++++ 6 files changed, 88 insertions(+), 36 deletions(-) create mode 100644 s48/sequences/vecnames.scm diff --git a/s48/sequences/README b/s48/sequences/README index 7e7aa75..1846cb0 100644 --- a/s48/sequences/README +++ b/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 diff --git a/s48/sequences/composeqs.scm b/s48/sequences/composeqs.scm index 2a788e2..a630c4d 100644 --- a/s48/sequences/composeqs.scm +++ b/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)) diff --git a/s48/sequences/genseqs.scm b/s48/sequences/genseqs.scm index 56535a3..f87a3d1 100644 --- a/s48/sequences/genseqs.scm +++ b/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))) diff --git a/s48/sequences/interfaces.scm b/s48/sequences/interfaces.scm index f9c5ed7..6772350 100644 --- a/s48/sequences/interfaces.scm +++ b/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 diff --git a/s48/sequences/packages.scm b/s48/sequences/packages.scm index 435b11b..4dc8bcd 100644 --- a/s48/sequences/packages.scm +++ b/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 diff --git a/s48/sequences/vecnames.scm b/s48/sequences/vecnames.scm new file mode 100644 index 0000000..e258382 --- /dev/null +++ b/s48/sequences/vecnames.scm @@ -0,0 +1,39 @@ +; Copyright (c) 2003 RT Happe +; 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))