sequences

s48/sequences/baseqs.scm

@@ -0,0 +1,64 @@
+; Copyright (c) 2003 RT Happe <rthappe at web de>
+; See the file COPYING distributed with the Scheme Untergrund Library
+
+;;; general sequences
+;;; the sequence protocol -- elementary procedures
+;;; sequence predicate, basic accessors, length, and even a constructor
+
+(define (sequence? s)
+  (or (string? s)
+      (byte-vector? s)
+      (vector? s)
+      (list? s)
+      (behaved-sequence? s)))
+
+(define (sequence-length s)
+  (gen-dispatch
+   ((string? string-length)
+    (byte-vector? byte-vector-length)
+    (vector? vector-length)
+    (list? length)
+    (behaved-sequence? behaved-sequence-length))
+   s))
+
+
+(define (sequence-ref s k)
+  (gen-dispatch
+   ((string? string-ref)
+    (byte-vector? byte-vector-ref)
+    (vector? vector-ref)
+    (list? list-ref)
+    (behaved-sequence? behaved-sequence-ref))
+   s k))
+
+
+(define (sequence-set! s k x)
+  (gen-dispatch
+   ((string? string-set!)
+    (byte-vector? byte-vector-set!)
+    (vector? vector-set!)
+    (list? list-set!)
+    (behaved-sequence? behaved-sequence-set!))
+   s k x))
+
+
+(define (make-another-sequence s len . maybe-fill)
+  (cond ((string? s) (apply make-string len maybe-fill))
+        ((byte-vector? s) (make-byte-vector len
+                                            ;; mbv requires 2nd arg
+                                            (:optional maybe-fill 0)))
+        ((vector? s) (apply make-vector len maybe-fill))
+        ((list? s) (apply make-list len maybe-fill))
+        ((behaved-sequence? s)
+         (apply make-behaved-sequence
+                (behaved-sequence:type s) len maybe-fill))
+        (else (error "make-another : unsupported sequence(?) type" s))))  
+
+
+
+
+
+
+
+
+

s48/sequences/composeqs.scm

@@ -0,0 +1,39 @@
+; Copyright (c) 2003 RT Happe <rthappe at web de>
+; See the file COPYING distributed with the Scheme Untergrund Library
+
+;;; sequence operations definABLE in terms of the elementary operations
+;;; [ not much there yet ]
+
+(define (ident x) x)
+
+(define (sequence->list s)
+  (gen-dispatch
+   ((string? string->list)
+    (byte-vector? contiguous-sequence->list)
+    (vector? vector->list)
+    (list? ident)
+    (behaved-sequence? contiguous-sequence->list))
+   s))
+
+
+(define (sequence-fill! s x)
+  (gen-dispatch
+   ((string? string-fill!)
+    (byte-vector? contiguous-sequence-fill!)
+    (vector? vector-fill!)
+    (list? ident)
+    (behaved-sequence? contiguous-sequence-fill!))
+   s x))
+   
+
+(define (subsequence s start end)
+  (cond ((pair? s)
+         (sublist s start end))
+        ((string? s)
+         (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)
+

s48/sequences/genseqs.scm

@@ -0,0 +1,53 @@
+; Copyright (c) 2003 RT Happe <rthappe at web de>
+; See the file COPYING distributed with the Scheme Untergrund Library
+
+;;; generic sequence procedures -- no explicit dispatch on sequence type
+;;; 
+;;; The code should work with the names of the elementary sequence 
+;;; operations bound to the umbrella procedures that dispatch on the
+;;; sequence type, or to the specific procedures of a particular type,
+;;; 
+;;; sequence->list
+;;; sequennce-fill!
+;;; subsequence
+;;; every/bounds
+
+(define (sequence->list s)
+  (let loop ((i (sequence-length s)) (xs '()))
+    (if (= 0 i) xs
+        (loop (- i 1) (cons (sequence-ref s (- i 1)) xs)))))
+
+;; unspecified return value as usual
+(define (sequence-fill! s x)
+  (let ((len (sequence-length s)))
+    (let loop ((i 0))
+      (if (< i len)
+          (begin 
+            (sequence-set! s i x)
+            (loop (+ i 1)))))))
+        
+
+(define (subsequence s start end)
+  (let* ((len (- end start))
+         (ss (make-another-sequence s len)))
+    (do ((i 0 (+ i 1)))
+        ((= i len) ss)
+      (sequence-set! ss i (sequence-ref s (+ start i))))))
+
+(define (every/bounds start end pred . args) 
+  (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)))))
+
+
+
+
+
+
+
+
+

s48/sequences/interfaces.scm

@@ -0,0 +1,35 @@
+; 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
+(define-interface sequence-basics-face
+  (export sequence?
+          sequence-length
+          sequence-ref
+          sequence-set!
+          make-another-sequence))
+
+;; things definable in terms of the basic protocol
+(define-interface sequence-extras-face
+  (export sequence->list
+          sequence-fill!
+          subsequence
+          every/bounds))
+
+;; specialised versions of sequence operations
+(define-interface sequence-specifics-face
+  (export make-list
+          list-set!
+          list-fill!
+          sublist))
+
+;; the sequence ADT etc.
+(define-interface behaved-sequences-face
+  (export make-sequence-type
+          make-behaved-sequence-record
+          behaved-sequence:type
+          make-behaved-sequence
+          behaved-sequence?
+          behaved-sequence-ref
+          behaved-sequence-set!
+          behaved-sequence-length))

s48/sequences/packages.scm

@@ -0,0 +1,49 @@
+; Copyright (c) 2003 RT Happe <rthappe at web de>
+; See the file COPYING distributed with the Scheme Untergrund Library
+
+;;; refers to structure KRIMS from sunterlib/s48/krims
+
+;; sequences as data + behaviour
+(define-structure behaved-sequences behaved-sequences-face
+  (open srfi-9                          ; define-record-type
+        scheme)
+  (files uniseqs))
+
+;; some sequence operations tuned for lists
+(define-structure sequence-specifics sequence-specifics-face
+  (open srfi-1         ; drop first take make-list pair-for-each
+        scheme)
+  (files specseqs))
+        
+;; basic sequence accessors etc.
+(define-structure sequence-basics sequence-basics-face
+  (open krims                           ; gen-dispatch
+        let-opt                         ; :optional
+        sequence-specifics              ; list-set! make-list
+        behaved-sequences
+        byte-vectors
+        srfi-23                         ; error
+        scheme)
+  (files baseqs))
+
+;; sequence operations defined in terms of the basic protocol
+(define-structure sequence-extras sequence-extras-face
+  (open sequence-basics
+        krims                           ; assert
+        scheme)
+  (files genseqs))
+
+;; 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)
+(define-structure sequence-lib (compound-interface sequence-basics-face
+                                                   sequence-extras-face
+                                                   behaved-sequences-face)
+  (open krims                           ; gen-dispatch
+        (with-prefix sequence-extras contiguous-)
+        sequence-basics
+        behaved-sequences
+        sequence-specifics
+        byte-vectors
+        scheme)
+  (files composeqs))

s48/sequences/specseqs.scm

@@ -0,0 +1,16 @@
+; 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)
+;;; list-set!  sublist  list-fill!
+
+;; unspecified return value as usual
+(define (list-set! xs k x)
+  (set-car! (drop xs k) x))
+
+(define (sublist xs start end)
+  (take (drop xs start) (- end start)))
+
+;; unspecified return value 
+(define (list-fill! xs x)
+  (pair-for-each (lambda (p) (set-car! p x)) xs))

s48/sequences/uniseqs.scm

@@ -0,0 +1,46 @@
+; Copyright (c) 2003 RT Happe <rthappe at web de>
+; See the file COPYING distributed with the Scheme Untergrund Library
+
+;;; a uniform framework for sequence as data + behaviour
+;;; in other words: mucho indirection here [ could reduce it ]
+
+;; such records represent behavioural sequence types S
+;; maker : integer [t] -> S                -- like MAKE-VECTOR
+;; predicate : any -> boolean              -- like VECTOR?
+;; getter : S integer --> any              -- like VECTOR-REF
+;; setter : S integer any --> unspecified  -- like VECTOR-SET!
+;; meter : S --> integer                   -- like VECTOR-LENGTH
+(define-record-type :sequence-type
+  (make-sequence-type maker predicate getter setter meter)
+  sequence-type?
+  (maker sequence-type:maker)
+  (predicate sequence-type:predicate)
+  (getter sequence-type:getter)
+  (setter sequence-type:setter)
+  (meter sequence-type:meter))
+
+;; underlying sequence data + behavioural sequence type
+(define-record-type :behaved-sequence
+  ;; avoiding the make-behaved-sequence namning pattern for good reason
+  (make-behaved-sequence-record type instance)
+  behaved-sequence?
+  (type behaved-sequence:type)
+  (instance behaved-sequence:instance))
+
+(define (behaved-sequence-ref s k)
+  ((sequence-type:getter (behaved-sequence:type s))
+   (behaved-sequence:instance s) k))
+
+(define (behaved-sequence-set! s k x)
+  ((sequence-type:setter (behaved-sequence:type s))
+   (behaved-sequence:instance s) k x))
+
+(define (behaved-sequence-length s)
+  ((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)
+                                       k maybe-fill)))