some more start&ends

s48/sequences/genseqs.scm

@@ -19,23 +19,28 @@
 ;;; sequence-any sequences-any
 ;;; sequence-every sequences-every
 
-(define (sequence->list s)
+(define (id x) x)
-  (let loop ((i (sequence-length s)) (xs '()))
+
-    (if (= 0 i) xs
+(define (sequence->list s . opts)
-        (loop (- i 1) (cons (sequence-ref s (- i 1)) xs)))))
+  (let-optionals opts ((start 0) (end (sequence-length s)))
+    (assert (<= 0 start end))
+    (let loop ((i end) (xs '()))
+      (if (= i start) xs
+          (loop (- i 1) (cons (sequence-ref s (- i 1)) xs))))))
 
 ;; unspecified return value as usual
-(define (sequence-fill! s x)
+(define (sequence-fill! s x . opts)
-  (let ((len (sequence-length s)))
+  (let-optionals opts ((start 0) (end (sequence-length s)))
+    (assert (<= 0 start end))
     (let loop ((i 0))
-      (if (< i len)
+      (if (< i end)
           (begin 
             (sequence-set! s i x)
             (loop (+ i 1)))))))
         
 
 (define (subsequence s start end)
-  (assert (<= start end))
+  (assert (<= 0 start end))
   (let* ((len (- end start))
          (ss (make-another-sequence s len)))
     (do ((i 0 (+ i 1)))
@@ -43,14 +48,16 @@
       (sequence-set! ss i (sequence-ref s (+ start i))))))
 
 
-(define (sequence-copy s)
+(define (sequence-copy s . opts)
-  (subsequence s 0 (sequence-length s)))
+  (let-optionals opts ((start 0) (end (sequence-length s)))
+    (assert (<= 0 start end))
+    (subsequence s start end)))
 
 
 (define (sequence-fold kons nil s . opts)
   (let-optionals opts ((start 0)
                        (end (sequence-length s)))
-    (assert (<= start end))
+    (assert (<= 0 start end))
     (let loop ((subtotal nil) (i start))
       (if (= i end) subtotal
           (loop (kons (sequence-ref s i) subtotal) (+ i 1))))))
@@ -74,7 +81,7 @@
 (define (sequence-fold-right kons nil s . opts)
   (let-optionals opts ((start 0)
                  (end (sequence-length s)))
-    (assert (<= start end))
+    (assert (<= 0 start end))
     (let loop ((subtotal nil) (i end))
       (if (= i start) subtotal
           (loop (kons (sequence-ref s (- i 1)) subtotal) (- i 1))))))
@@ -110,7 +117,7 @@
 
 (define (sequence-for-each proc seq . opts)
   (let-optionals opts ((start 0) (end (sequence-length seq)))
-    (assert (<= start end))
+    (assert (<= 0 start end))
     (do ((i start (+ i 1)))
         ((= i end) (unspecific))
       (proc (sequence-ref seq i)))))
@@ -142,42 +149,42 @@
       (sequence-set! res i (apply proc (map (lambda (s) (sequence-ref s i))
                                             ss))))))
 
-(define (sequence-any pred seq . opts)
+(define (sequence-any foo? seq . opts)
   (let-optionals opts ((start 0) (end (sequence-length seq)))
-    (assert (<= start end))
+    (assert (<= 0 start end))
     (let loop ((i start))
       (cond ((= i end) #f)
-            ((pred (sequence-ref seq i)) #t)
+            ((foo? (sequence-ref seq i)) => id)
             (else (loop (+ i 1)))))))
 
 
-(define (sequences-any pred . seqs) 
+(define (sequences-any foo? . 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))
+                ((apply foo? (map (lambda (seq) (sequence-ref seq i))
                                   seqs))
-                 #t)
+                 => id)
                 (else (loop (+ i 1))))))))
 
 
-(define (sequence-every pred seq . opts)
+(define (sequence-every foo? seq . opts)
   (let-optionals opts ((start 0) (end (sequence-length seq)))
-    (assert (<= start end))
+    (assert (<= 0 start end))
-    (let loop ((i start))
+    (let loop ((i start) (res #t))
-      (cond ((= i end) #t)
+      (cond ((= i end) res)
-            ((pred (sequence-ref seq i))
+            ((foo? (sequence-ref seq i))
-             (loop (+ i 1)))
+             => (lambda (r) (loop (+ i 1) r)))
             (else #f)))))
 
 
-(define (sequences-every pred . seqs) 
+(define (sequences-every foo? . 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))
+                ((apply foo? (map (lambda (seq) (sequence-ref seq i))
                                   seqs))
                  (loop (+ i 1)))
                 (else #f))))))

s48/sequences/interfaces.scm

@@ -33,6 +33,7 @@
 ;; the sequence ADT etc.
 (define-interface behaved-sequences-face
   (export make-sequence-type
+          sequence-type?
           make-behaved-sequence-record
           behaved-sequence:type
           make-behaved-sequence/type

s48/sequences/packages.scm

@@ -6,6 +6,8 @@
 ;; sequences as data + behaviour
 (define-structure behaved-sequences behaved-sequences-face
   (open srfi-9                          ; define-record-type
+        krims                           ; assert
+        let-opt                         ; let-optionals [ from scsh ]
         scheme)
   (files uniseqs))
 
@@ -46,7 +48,7 @@
   (open krims                           ; assert
         util                            ; unspecific
         let-opt                         ; let-optionals [ from scsh ]
-        srfi-1                          ; append!
+        srfi-1+                         ; append! first rest
         scheme)
   ;; bind the basic operations to vector specialists
   (begin
@@ -57,10 +59,11 @@
     (define (make-another-sequence v k . maybe-fill)
       (apply make-vector k maybe-fill)))
   (files genseqs)
-  ;; rename extras not supplied by scheme
+  ;; 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)
@@ -74,6 +77,14 @@
     (define vectors-fold-right sequences-fold-right)
     (define vectors-any sequences-any) 
     (define vectors-every sequences-every) 
+    (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))))))             
     ))
 
 

s48/sequences/specseqs.scm

@@ -14,3 +14,5 @@
 ;; unspecified return value 
 (define (list-fill! xs x)
   (pair-for-each (lambda (p) (set-car! p x)) xs))
+
+

s48/sequences/uniseqs.scm

@@ -44,13 +44,14 @@
                                 (apply (sequence-type:maker st)
                                        k maybe-fill)))
 
-(define (list->behaved-sequence/type st xs)
+(define (list->behaved-sequence/type st xs . opts)
-  (let* ((len (length xs))
+  (let-optionals opts ((start 0) (end (length xs)))
-         (s (make-behaved-sequence/type st len)))
+    (assert (<= 0 start end))
-    (do ((i 0 (+ i 1))
+    (let ((s (make-behaved-sequence/type st (- end start))))
-         (xs xs (cdr xs)))
+      (do ((i 0 (+ i 1))
-        ((null? xs) s)
+           (xs xs (cdr xs)))
-      (behaved-sequence-set! s i (car xs))))) 
+          ((= i end) s)
+        (behaved-sequence-set! s (- i start) (car xs)))))) 
 
 (define (behaved-sequence/type st . args)
   (list->behaved-sequence/type st args))