From 3c234fddc9b591c3d44cc956e8f1dd3183cb645a Mon Sep 17 00:00:00 2001 From: Rolf-Thomas Happe Date: Fri, 14 Feb 2003 00:47:58 +0000 Subject: [PATCH] s48/krims/README --- s48/krims/README | 100 ++++++++++++++++++++++++++++++ s48/krims/interfaces.scm | 36 +++++++++++ s48/krims/packages.scm | 12 ++++ s48/sequences/baseqs.scm | 13 +--- s48/sequences/composeqs.scm | 104 +++++++++++++++++++++++++++----- s48/sequences/genseqs.scm | 114 +++++++++++++++++++++++++++-------- s48/sequences/interfaces.scm | 57 +++++++++++++++--- s48/sequences/packages.scm | 52 ++++++++++++++-- s48/sequences/uniseqs.scm | 21 +++++-- 9 files changed, 440 insertions(+), 69 deletions(-) create mode 100644 s48/krims/README create mode 100644 s48/krims/interfaces.scm diff --git a/s48/krims/README b/s48/krims/README new file mode 100644 index 0000000..d22764a --- /dev/null +++ b/s48/krims/README @@ -0,0 +1,100 @@ +sunterlib/s48/krims -- Odds and Ends + +structure SRFI-1+ -- SRFI-1 + REST + +The structure SRFI-1+ extends the list lib with REST := CDR. [ I dearly +like (FIRST . REST) lists and (CAR . CDR) trees. ] + + * + +structure SRFI-9+ -- SRFI-9 + DEFINE-RECORD-DISCLOSER + +The structure SRFI-9+ extends SRFI-9 by the convenient record disclosing +facility from DEFINE-RECORD-TYPES: + +(define-record-type rt predicate ...) SYNTAX + +just as SRFI-9. + + +(define-record-discloser rt d) --> unspecified PROCEDURE + +just as DEFINE-RECORD-TYPES: Install the procedure D : rt -> list +as discloser for records of type RT where RT has been defined with +DEFINE-RECORD-TYPE (from above) and D maps its input record to a +printable list starting with a symbol. + + * + + +structure KRIMS -- Odds and Ends + +The structure KRIMS gathers miscellaneous tiny utilities mainly for use +of other sunterlib projects. + +(assert [id] exp) SYNTAX + +The usual ASSERT macro with an optional ID tag: Signal an error and +complain if EXP evaluates to false. The error message contains the +value of ID (if supplied) and the expression EXP. [ ASSERT being a +macro, we can change it to the trivial form that doesn't evaluate its +arguments and recompile before selling our stuff ... ] + + * + +(receive/name loop formals exp form0 ...) SYNTAX + +RECEIVE/NAME is a multi-values analogue of named LET (but much less +useful) that helps when chaining n-valued n-ary functions, for instance. + +Synopsis: Bind LOOP to a macro wrapped around the procedure LUP with +parameter list FORMALS and body FORM0 ... so that +* (LOOP multi-valued-expression) calls LUP with the values of + multi-valued-expression , and +* (LOOP exp0 ...) becomes (LUP exp0 ...) + +Syntax: (receive/name ) +with non-terminals from R5RS. + +Semantics: (A special case is good enough.) +Assuming the LOOP tag isn't shadowed in the context `...' + + (receive/name loop (x y) exp0 + ... (loop exp1) ...) +is eqv to + (receive (x y) exp0 + (let lup ((x x) (y y)) + ... (receive (x y) exp1 + (lup x y)) ...)) + +and (receive/name loop (x y) exp0 + ... (loop exp1 exp1) ...) +is eqv to + (receive (x y) exp0 + (let lup ((x x) (y y)) + ... (lup exp1 exp2) ...)) + +Example: + + (define (shove n xs) (values (- n 1) (cons n xs))) + (receive/name loop (n xs) (values 7 '()) + (if (= n 0) + (display xs) + (loop (shove n xs)))) + ==> (1 2 3 4 5 6 7) + * + +(gen-dispatch ((predicate action) ...) e0 e1 ... en) SYNTAX + +Dispatch action on type of first argument E0: feed E0 ... EN to the +first action such that the PREDICATE holds for E0. Signal an error +if nothing goes. + +Example: + (gen-dispatch ((string? string-ref) + (vector? vector-ref) + (list? list-ref)) + '#(a zopp 36) 2) + ==> 36 + + oOo diff --git a/s48/krims/interfaces.scm b/s48/krims/interfaces.scm new file mode 100644 index 0000000..652998c --- /dev/null +++ b/s48/krims/interfaces.scm @@ -0,0 +1,36 @@ +;; since SRFI-1-INTERFACE isn't defined in the usual 0.6.3 image +;; definition hijacked from scsh-0.6.3/scheme/more-interfaces.scm +(define-interface srfi-1-face + (export map for-each member assoc ; redefined from R5RS + xcons make-list list-tabulate cons* list-copy + proper-list? circular-list? dotted-list? not-pair? null-list? list= + circular-list length+ + iota + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr + take drop + take-right drop-right + take! drop-right! + split-at split-at! + last last-pair + zip unzip1 unzip2 unzip3 unzip4 unzip5 + count + append! append-reverse append-reverse! concatenate concatenate! + unfold fold pair-fold reduce + unfold-right fold-right pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove + filter! partition! remove! + find find-tail any every list-index + take-while drop-while take-while! + span break span! break! + delete delete! + alist-cons alist-copy + delete-duplicates delete-duplicates! + alist-delete alist-delete! + reverse! + lset<= lset= lset-adjoin + lset-union lset-intersection lset-difference lset-xor + lset-diff+intersection + lset-union! lset-intersection! lset-difference! lset-xor! + lset-diff+intersection!)) diff --git a/s48/krims/packages.scm b/s48/krims/packages.scm index 15628fe..934ac5e 100644 --- a/s48/krims/packages.scm +++ b/s48/krims/packages.scm @@ -11,7 +11,16 @@ scheme) (files krims)) +;; srfi-1 + REST +(define-structure srfi-1+ + (compound-interface srfi-1-face + (export rest)) + (open srfi-1 scheme) + (begin (define rest cdr))) + ;; srfi-9 + define-record-discloser +;; [ extended version of the srfi-9 structure def +;; from scsh-0.6.3/scheme/more-packages.scm ] (define-structure srfi-9+ (export (define-record-type :syntax) define-record-discloser) @@ -23,3 +32,6 @@ ((define-record-type type-name . stuff) (sys:define-record-type type-name type-name . stuff)))) (define define-record-discloser sys:define-record-discloser))) + + + diff --git a/s48/sequences/baseqs.scm b/s48/sequences/baseqs.scm index 060b4a6..3d4db16 100644 --- a/s48/sequences/baseqs.scm +++ b/s48/sequences/baseqs.scm @@ -50,15 +50,8 @@ ((vector? s) (apply make-vector len maybe-fill)) ((list? s) (apply make-list len maybe-fill)) ((behaved-sequence? s) - (apply make-behaved-sequence + (apply make-behaved-sequence/type (behaved-sequence:type s) len maybe-fill)) - (else (error "make-another : unsupported sequence(?) type" s)))) - - - - - - - - + (else (error "make-another-sequence : first arg not a sequence?" + s)))) diff --git a/s48/sequences/composeqs.scm b/s48/sequences/composeqs.scm index 41c9544..180d4f9 100644 --- a/s48/sequences/composeqs.scm +++ b/s48/sequences/composeqs.scm @@ -3,7 +3,6 @@ ;;; sequence operations definABLE in terms of the elementary operations ;;; with no regard to the concrete sequence type -;;; [ not too much there yet ] (define (ident x) x) @@ -12,45 +11,120 @@ ((string? string->list) (byte-vector? contiguous-sequence->list) (vector? vector->list) - (list? ident) + (pair? ident) (behaved-sequence? contiguous-sequence->list)) s)) (define (sequence-fill! s x) (gen-dispatch - ((string? string-fill!) + ((vector? vector-fill!) + (string? string-fill!) (byte-vector? contiguous-sequence-fill!) - (vector? vector-fill!) - (list? ident) + (pair? ident) (behaved-sequence? contiguous-sequence-fill!)) s x)) (define (subsequence s start end) - (cond ((pair? s) - (sublist s start end)) + (cond ((vector? s) + (subvector s start end)) ((string? s) (substring s start end)) + ((pair? s) + (sublist s start end)) (else (contiguous-subsequence s start end)))) (define (sequence-copy s) (gen-dispatch - ((string? string-copy) + ((vector? vector-copy) + (string? string-copy) (byte-vector? contiguous-sequence-copy) - (vector? contiguous-sequence-copy) - (list? list-copy) + (pair? list-copy) (behaved-sequence? contiguous-sequence-copy)) s)) + +(define (sequence-append seq . seqs) + (cond ((vector? seq) (apply vector-append seq seqs)) + ((string? seq) (apply string-append seq seqs)) + ((pair? seq) (apply append seq seqs)) + (else (apply contiguous-sequence-append seq seqs)))) + + +(define (sequence-map proc s . opts) + (cond ((vector? s) + (apply vector-map proc s opts)) + ((string? s) + (apply string-map proc s opts)) + ((and (pair? s) (null? opts)) + (map proc s)) + (else (apply contiguous-sequence-map proc s opts)))) + + +(define (sequence-for-each proc s . opts) + (cond ((vector? s) + (apply vector-for-each proc s opts)) + ((string? s) + (apply string-for-each proc s opts)) + ((and (pair? s) (null? opts)) + (for-each proc s)) + (else (apply contiguous-sequence-for-each proc s opts)))) + + +(define (sequence-fold kons nil s . opts) + (cond ((vector? s) + (apply vector-fold kons nil s opts)) + ((string? s) + (apply string-fold kons nil s opts)) + ((and (pair? s) (null? opts)) + (fold kons nil s)) + (else (apply contiguous-sequence-fold kons nil s opts)))) + + +(define (sequence-fold-right kons nil s . opts) + (cond ((vector? s) + (apply vector-fold-right kons nil s opts)) + ((string? s) + (apply string-fold-right kons nil s opts)) + ((and (pair? s) (null? opts)) + (fold-right kons nil s)) + (else (apply contiguous-sequence-fold-right kons nil s opts)))) + + +(define (sequence-any pred s . opts) + (cond ((vector? s) + (apply vector-any pred s opts)) + ((string? s) + (apply string-any pred s opts)) + ((and (pair? s) (null? opts)) + (any pred s)) + (else (apply contiguous-sequence-any pred s opts)))) + + +(define (sequence-every pred s . opts) + (cond ((vector? s) + (apply vector-every pred s opts)) + ((string? s) + (apply string-every pred s opts)) + ((and (pair? s) (null? opts)) + (every pred s)) + (else (apply contiguous-sequence-every pred s opts)))) + + ;; The following procedures take or accept >1 sequence argument. ;; Therefore we don't dispatch on the sequence type so that we ;; may support mixed sequences: (sequence-append (vector) "abc" '(anton)) (define sequence-append contiguous-sequence-append) -(define sequence-map contiguous-sequence-map) -(define sequence-for-each contiguous-sequence-for-each) -(define sequence-fold contiguous-sequence-fold) -(define sequence-every contiguous-sequence-every) -(define sequence-every/bounds contiguous-sequence-every/bounds) +(define sequences-map contiguous-sequences-map) +(define sequences-for-each contiguous-sequences-for-each) +(define sequences-fold contiguous-sequences-fold) +(define sequences-fold-right contiguous-sequences-fold-right) +(define sequences-any contiguous-sequences-any) +(define sequences-every contiguous-sequences-every) + + + + diff --git a/s48/sequences/genseqs.scm b/s48/sequences/genseqs.scm index b2eeba1..892980f 100644 --- a/s48/sequences/genseqs.scm +++ b/s48/sequences/genseqs.scm @@ -12,11 +12,12 @@ ;;; subsequence ;;; sequence-copy ;;; sequence-append -;;; sequence-map -;;; sequence-for-each -;;; sequence-fold -;;; sequence-every -;;; sequence-every/bounds +;;; sequence-map sequences-map +;;; sequence-for-each sequences-for-each +;;; sequence-fold sequences-fold +;;; sequence-fold-right sequence-fold-right +;;; sequence-any sequences-any +;;; sequence-every sequences-every (define (sequence->list s) (let loop ((i (sequence-length s)) (xs '())) @@ -34,6 +35,7 @@ (define (subsequence s start end) + (assert (<= start end)) (let* ((len (- end start)) (ss (make-another-sequence s len))) (do ((i 0 (+ i 1))) @@ -45,18 +47,20 @@ (subsequence s 0 (sequence-length s))) -(define (sequence-fold/3 kons nil s) - (let ((end (sequence-length s))) - (let loop ((subtotal nil) (i 0)) +(define (sequence-fold kons nil s . opts) + (let-optionals opts ((start 0) + (end (sequence-length s))) + (assert (<= start end)) + (let loop ((subtotal nil) (i start)) (if (= i end) subtotal (loop (kons (sequence-ref s i) subtotal) (+ i 1)))))) -(define (sequence-fold kons nil seq . seqs) +(define (sequences-fold kons nil seq . seqs) (if (null? seqs) - (sequence-fold/3 kons nil seq) + (sequence-fold kons nil seq) (let* ((ss (cons seq seqs)) - ;; are we morally obliged to use a fold/3 here? + ;; are we morally obliged to use FOLD here? (end (apply min (map sequence-length ss)))) (let loop ((subtotal nil) (i 0)) (if (= i end) subtotal @@ -67,6 +71,30 @@ (+ i 1))))))) +(define (sequence-fold-right kons nil s . opts) + (let-optionals opts ((start 0) + (end (sequence-length s))) + (assert (<= start end)) + (let loop ((subtotal nil) (i end)) + (if (= i start) subtotal + (loop (kons (sequence-ref s (- i 1)) subtotal) (- i 1)))))) + + +(define (sequences-fold-right kons nil seq . seqs) + (if (null? seqs) + (sequence-fold-right kons nil seq) + (let* ((ss (cons seq seqs)) + ;; are we morally obliged to use FOLD here? + (end (apply min (map sequence-length ss)))) + (let loop ((subtotal nil) (i (- end 1))) + (if (= i -1) subtotal + (loop (apply kons (append! (map (lambda (s) + (sequence-ref s i)) + ss) + (list subtotal))) + (- i 1))))))) + + (define (sequence-append . seqs) (if (null? seqs) (vector) (let* ((len (apply + (map sequence-length seqs))) @@ -80,7 +108,15 @@ (sequence-ref s i))))))))) -(define (sequence-for-each proc seq . seqs) +(define (sequence-for-each proc seq . opts) + (let-optionals opts ((start 0) (end (sequence-length seq))) + (assert (<= start end)) + (do ((i start (+ i 1))) + ((= i end) (unspecific)) + (proc (sequence-ref seq i))))) + + +(define (sequences-for-each proc seq . seqs) (let* ((ss (cons seq seqs)) (end (apply min (map sequence-length ss)))) (do ((i 0 (+ i 1))) @@ -88,7 +124,16 @@ (apply proc (map (lambda (s) (sequence-ref s i)) ss))))) -(define (sequence-map proc seq . seqs) +(define (sequence-map proc seq . opts) + (let-optionals opts ((start 0) (end (sequence-length seq))) + (assert (<= start end)) + (let ((res (make-another-sequence seq end))) + (do ((i start (+ i 1))) + ((= i end) res) + (sequence-set! res i (proc (sequence-ref seq i))))))) + + +(define (sequences-map proc seq . seqs) (let* ((ss (cons seq seqs)) (end (apply min (map sequence-length ss))) (res (make-another-sequence seq end))) @@ -97,8 +142,37 @@ (sequence-set! res i (apply proc (map (lambda (s) (sequence-ref s i)) ss)))))) +(define (sequence-any pred seq . opts) + (let-optionals opts ((start 0) (end (sequence-length seq))) + (assert (<= start end)) + (let loop ((i start)) + (cond ((= i end) #f) + ((pred (sequence-ref seq i)) #t) + (else (loop (+ i 1))))))) -(define (sequence-every pred . seqs) + +(define (sequences-any pred . seqs) + (if (null? seqs) #f + (let ((end (apply min (map sequence-length seqs)))) + (let loop ((i 0)) + (cond ((= i end) #f) + ((apply pred (map (lambda (seq) (sequence-ref seq i)) + seqs)) + #t) + (else (loop (+ i 1)))))))) + + +(define (sequence-every pred seq . opts) + (let-optionals opts ((start 0) (end (sequence-length seq))) + (assert (<= start end)) + (let loop ((i start)) + (cond ((= i end) #t) + ((pred (sequence-ref seq i)) + (loop (+ i 1))) + (else #f))))) + + +(define (sequences-every pred . seqs) (if (null? seqs) #t (let ((end (apply min (map sequence-length seqs)))) (let loop ((i 0)) @@ -109,18 +183,6 @@ (else #f)))))) -(define (sequence-every/bounds start end pred . seqs) - (assert (<= 0 start end)) - (if (null? seqs) #t - (let ((eff-end (apply min end (map sequence-length seqs)))) - (let loop ((i start)) - (cond ((= i eff-end) #t) - ((apply pred (map (lambda (seq) (sequence-ref seq i)) - seqs)) - (loop (+ i 1))) - (else #f)))))) - - diff --git a/s48/sequences/interfaces.scm b/s48/sequences/interfaces.scm index 3d832e4..e3ba287 100644 --- a/s48/sequences/interfaces.scm +++ b/s48/sequences/interfaces.scm @@ -16,26 +16,63 @@ subsequence sequence-copy sequence-append - sequence-map - sequence-for-each - sequence-fold - sequence-every - sequence-every/bounds)) + sequence-map sequences-map + sequence-for-each sequences-for-each + sequence-fold sequences-fold + sequence-fold-right sequences-fold-right + sequence-any sequences-any + sequence-every sequences-every)) -;; specialised versions of sequence operations +;; specialised sequence operations (for lists, actually) (define-interface sequence-specifics-face - (export make-list - list-set! + (export list-set! list-fill! - sublist)) + sublist + )) ;; the sequence ADT etc. (define-interface behaved-sequences-face (export make-sequence-type make-behaved-sequence-record behaved-sequence:type - make-behaved-sequence + make-behaved-sequence/type + behaved-sequence/type + list->behaved-sequence/type behaved-sequence? behaved-sequence-ref behaved-sequence-set! behaved-sequence-length)) + +;; the basic + extra sequence procedures +;; [ extends the union of SEQUENCE-BASICS- and -EXTRAS-INTERFACE with +;; `VECTOR' replacing `SEQUENCE' ] +(define-interface vector-lib-face + (export ;; std constructors + vector + make-vector + ;; basics w/o the vanilla constructor + vector? + vector-length + vector-ref + vector-set! + + ;; extras + vector->list + vector-fill! + subvector + vector-copy + vector-append + vector-map + vector-for-each + vector-fold + vector-fold-right + vector-any + vector-every + vectors-map + vectors-for-each + vectors-fold + vectors-fold-right + vectors-any + vectors-every + )) + diff --git a/s48/sequences/packages.scm b/s48/sequences/packages.scm index 2c97b8b..cd51c5f 100644 --- a/s48/sequences/packages.scm +++ b/s48/sequences/packages.scm @@ -9,19 +9,21 @@ scheme) (files uniseqs)) -;; some sequence operations tuned for lists +;; specialists for lists, vectors, strings (define-structure sequence-specifics sequence-specifics-face - (open srfi-1 ; drop first take make-list pair-for-each + (open srfi-1 ; list procs + srfi-13 ; string procs scheme) (files specseqs)) ;; basic sequence accessors etc. (define-structure sequence-basics sequence-basics-face (open krims ; gen-dispatch - let-opt ; :optional + let-opt ; :optional [ from scsh ] sequence-specifics ; list-set! make-list behaved-sequences byte-vectors + srfi-1 ; make-list srfi-23 ; error scheme) (files baseqs)) @@ -33,9 +35,48 @@ util ; unspecific srfi-1 ; append! srfi-23 ; error + let-opt ; let-optionals [ from scsh ] scheme) (files genseqs)) + + +;; sequence procedures specialised to vectors +(define-structure vector-lib vector-lib-face + (open krims ; assert + util ; unspecific + let-opt ; let-optionals [ from scsh ] + srfi-1 ; append! + scheme) + ;; bind the basic operations to vector specialists + (begin + (define sequence? vector?) + (define sequence-length vector-length) + (define sequence-ref vector-ref) + (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 + (begin + (define subvector subsequence) + (define vector-copy sequence-copy) + (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 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) + )) + + ;; elementary and other general sequence operations, typically dispatching ;; early on the sequence type in order to make use of built-ins or special ;; code (notably for lists) @@ -47,7 +88,10 @@ sequence-basics behaved-sequences sequence-specifics - srfi-1 ; list-copy byte-vectors + vector-lib + srfi-1 ; list procs + srfi-13 ; string procs + let-opt ; let-optionals [ from scsh ] scheme) (files composeqs)) diff --git a/s48/sequences/uniseqs.scm b/s48/sequences/uniseqs.scm index 04f7433..2cf1985 100644 --- a/s48/sequences/uniseqs.scm +++ b/s48/sequences/uniseqs.scm @@ -39,8 +39,21 @@ ((sequence-type:meter (behaved-sequence:type s)) (behaved-sequence:instance s))) -;; note the necessary TYPE arg contrasting with MAKE-VECTOR etc. -(define (make-behaved-sequence type k . maybe-fill) - (make-behaved-sequence-record type - (apply (sequence-type:maker type) +(define (make-behaved-sequence/type st k . maybe-fill) + (make-behaved-sequence-record st + (apply (sequence-type:maker st) k maybe-fill))) + +(define (list->behaved-sequence/type st xs) + (let* ((len (length xs)) + (s (make-behaved-sequence/type st len))) + (do ((i 0 (+ i 1)) + (xs xs (cdr xs))) + ((null? xs) s) + (behaved-sequence-set! s i (car xs))))) + +(define (behaved-sequence/type st . args) + (list->behaved-sequence/type st args)) + + +