From f21e9e0e4448591524cf767144fcbfc59c0d6dc0 Mon Sep 17 00:00:00 2001 From: Rolf-Thomas Happe Date: Wed, 12 Feb 2003 21:48:40 +0000 Subject: [PATCH] copy fold append map for-each every --- s48/sequences/composeqs.scm | 25 ++++++++-- s48/sequences/genseqs.scm | 95 ++++++++++++++++++++++++++++++++---- s48/sequences/interfaces.scm | 10 +++- s48/sequences/packages.scm | 4 ++ 4 files changed, 119 insertions(+), 15 deletions(-) diff --git a/s48/sequences/composeqs.scm b/s48/sequences/composeqs.scm index 6ffda9e..41c9544 100644 --- a/s48/sequences/composeqs.scm +++ b/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 -;;; [ not much there yet ] +;;; with no regard to the concrete sequence type +;;; [ not too much there yet ] (define (ident x) x) @@ -33,7 +34,23 @@ (substring s start end)) (else (contiguous-subsequence s start end)))) -;; this is rather inefficient for lists-only uses, but supports mixed -;; sequences (comparing lists against vectors, for instance) -(define every/bounds contiguous-every/bounds) + +(define (sequence-copy s) + (gen-dispatch + ((string? string-copy) + (byte-vector? contiguous-sequence-copy) + (vector? contiguous-sequence-copy) + (list? list-copy) + (behaved-sequence? contiguous-sequence-copy)) + s)) + +;; 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) diff --git a/s48/sequences/genseqs.scm b/s48/sequences/genseqs.scm index f68ccde..b2eeba1 100644 --- a/s48/sequences/genseqs.scm +++ b/s48/sequences/genseqs.scm @@ -8,9 +8,15 @@ ;;; sequence type, or to the specific procedures of a particular type, ;;; ;;; sequence->list -;;; sequennce-fill! +;;; sequence-fill! ;;; subsequence -;;; every/bounds +;;; sequence-copy +;;; sequence-append +;;; sequence-map +;;; sequence-for-each +;;; sequence-fold +;;; sequence-every +;;; sequence-every/bounds (define (sequence->list s) (let loop ((i (sequence-length s)) (xs '())) @@ -34,14 +40,85 @@ ((= i len) ss) (sequence-set! ss i (sequence-ref s (+ start i)))))) -(define (every/bounds start end pred . args) + +(define (sequence-copy s) + (subsequence s 0 (sequence-length s))) + + +(define (sequence-fold/3 kons nil s) + (let ((end (sequence-length s))) + (let loop ((subtotal nil) (i 0)) + (if (= i end) subtotal + (loop (kons (sequence-ref s i) subtotal) (+ i 1)))))) + + +(define (sequence-fold kons nil seq . seqs) + (if (null? seqs) + (sequence-fold/3 kons nil seq) + (let* ((ss (cons seq seqs)) + ;; are we morally obliged to use a fold/3 here? + (end (apply min (map sequence-length ss)))) + (let loop ((subtotal nil) (i 0)) + (if (= i end) 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))) + (res (make-another-sequence (car seqs) len))) + (let loop ((ss seqs) (start 0)) + (if (null? ss) res + (let* ((s (car ss)) (end (sequence-length s))) + (do ((i 0 (+ i 1))) + ((= i end) (loop (cdr ss) (+ start end))) + (sequence-set! res (+ start i) + (sequence-ref s i))))))))) + + +(define (sequence-for-each proc seq . seqs) + (let* ((ss (cons seq seqs)) + (end (apply min (map sequence-length ss)))) + (do ((i 0 (+ i 1))) + ((= i end) (unspecific)) + (apply proc (map (lambda (s) (sequence-ref s i)) ss))))) + + +(define (sequence-map proc seq . seqs) + (let* ((ss (cons seq seqs)) + (end (apply min (map sequence-length ss))) + (res (make-another-sequence seq end))) + (do ((i 0 (+ i 1))) + ((= i end) res) + (sequence-set! res i (apply proc (map (lambda (s) (sequence-ref s i)) + ss)))))) + + +(define (sequence-every pred . seqs) + (if (null? seqs) #t + (let ((end (apply min (map sequence-length seqs)))) + (let loop ((i 0)) + (cond ((= i end) #t) + ((apply pred (map (lambda (seq) (sequence-ref seq i)) + seqs)) + (loop (+ i 1))) + (else #f)))))) + + +(define (sequence-every/bounds start end pred . seqs) (assert (<= 0 start end)) - (let ((eff-end (apply min end (map sequence-length args)))) - (let loop ((i start)) - (cond ((= i eff-end) #t) - ((apply pred (map (lambda (s) (sequence-ref s i)) args)) - (loop (+ i 1))) - (else #f))))) + (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 ab63225..3d832e4 100644 --- a/s48/sequences/interfaces.scm +++ b/s48/sequences/interfaces.scm @@ -1,7 +1,7 @@ ; Copyright (c) 2003 RT Happe ; See the file COPYING distributed with the Scheme Untergrund Library -;; the basic protocol + a vanilla constructor +;; the basic protocol including a vanilla constructor (define-interface sequence-basics-face (export sequence? sequence-length @@ -14,7 +14,13 @@ (export sequence->list sequence-fill! subsequence - every/bounds)) + sequence-copy + sequence-append + sequence-map + sequence-for-each + sequence-fold + sequence-every + sequence-every/bounds)) ;; specialised versions of sequence operations (define-interface sequence-specifics-face diff --git a/s48/sequences/packages.scm b/s48/sequences/packages.scm index 728903e..2c97b8b 100644 --- a/s48/sequences/packages.scm +++ b/s48/sequences/packages.scm @@ -30,6 +30,9 @@ (define-structure sequence-extras sequence-extras-face (open sequence-basics krims ; assert + util ; unspecific + srfi-1 ; append! + srfi-23 ; error scheme) (files genseqs)) @@ -44,6 +47,7 @@ sequence-basics behaved-sequences sequence-specifics + srfi-1 ; list-copy byte-vectors scheme) (files composeqs))