copy fold append map for-each every

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 (sequence-copy s)
-(define every/bounds contiguous-every/bounds)
+  (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)
 

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))))
+  (if (null? seqs) #t
-    (let loop ((i start))
+      (let ((eff-end (apply min end (map sequence-length seqs))))
-      (cond ((= i eff-end) #t)
+        (let loop ((i start))
-            ((apply pred (map (lambda (s) (sequence-ref s i)) args))
+          (cond ((= i eff-end) #t)
-             (loop (+ i 1)))
+                ((apply pred (map (lambda (seq) (sequence-ref seq i))
-            (else #f)))))
+                                  seqs))
+                 (loop (+ i 1)))
+                (else #f))))))
 
 
 

s48/sequences/interfaces.scm

@@ -1,7 +1,7 @@
 ; Copyright (c) 2003 RT Happe <rthappe at web de>
 ; 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

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