scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

null? copy! map-into! etc.

This commit is contained in:
Rolf-Thomas Happe 2003-03-22 22:22:15 +00:00
parent 066947bdb2
commit 93f8fe8c5c
7 changed files with 178 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
s48/sequences/README
View File

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

32
s48/sequences/composeqs.scm
View File

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

80
s48/sequences/genseqs.scm
View File

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

7
s48/sequences/interfaces.scm
View File

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

4
s48/sequences/packages.scm
View File

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

23
s48/sequences/specseqs.scm
View File

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

4
s48/sequences/vecnames.scm
View File

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