From 7cfd2e6c72d73b5812883bff07bc0fceacc2a1c1 Mon Sep 17 00:00:00 2001 From: Rolf-Thomas Happe Date: Wed, 12 Feb 2003 00:23:30 +0000 Subject: [PATCH] sequences --- s48/sequences/baseqs.scm | 64 ++++++++++++++++++++++++++++++++++++ s48/sequences/composeqs.scm | 39 ++++++++++++++++++++++ s48/sequences/genseqs.scm | 53 +++++++++++++++++++++++++++++ s48/sequences/interfaces.scm | 35 ++++++++++++++++++++ s48/sequences/packages.scm | 49 +++++++++++++++++++++++++++ s48/sequences/specseqs.scm | 16 +++++++++ s48/sequences/uniseqs.scm | 46 ++++++++++++++++++++++++++ 7 files changed, 302 insertions(+) create mode 100644 s48/sequences/baseqs.scm create mode 100644 s48/sequences/composeqs.scm create mode 100644 s48/sequences/genseqs.scm create mode 100644 s48/sequences/interfaces.scm create mode 100644 s48/sequences/packages.scm create mode 100644 s48/sequences/specseqs.scm create mode 100644 s48/sequences/uniseqs.scm diff --git a/s48/sequences/baseqs.scm b/s48/sequences/baseqs.scm new file mode 100644 index 0000000..060b4a6 --- /dev/null +++ b/s48/sequences/baseqs.scm @@ -0,0 +1,64 @@ +; Copyright (c) 2003 RT Happe +; 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)))) + + + + + + + + + diff --git a/s48/sequences/composeqs.scm b/s48/sequences/composeqs.scm new file mode 100644 index 0000000..6ffda9e --- /dev/null +++ b/s48/sequences/composeqs.scm @@ -0,0 +1,39 @@ +; Copyright (c) 2003 RT Happe +; 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) + diff --git a/s48/sequences/genseqs.scm b/s48/sequences/genseqs.scm new file mode 100644 index 0000000..f68ccde --- /dev/null +++ b/s48/sequences/genseqs.scm @@ -0,0 +1,53 @@ +; Copyright (c) 2003 RT Happe +; 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))))) + + + + + + + + + diff --git a/s48/sequences/interfaces.scm b/s48/sequences/interfaces.scm new file mode 100644 index 0000000..ab63225 --- /dev/null +++ b/s48/sequences/interfaces.scm @@ -0,0 +1,35 @@ +; Copyright (c) 2003 RT Happe +; 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)) diff --git a/s48/sequences/packages.scm b/s48/sequences/packages.scm new file mode 100644 index 0000000..728903e --- /dev/null +++ b/s48/sequences/packages.scm @@ -0,0 +1,49 @@ +; Copyright (c) 2003 RT Happe +; 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)) diff --git a/s48/sequences/specseqs.scm b/s48/sequences/specseqs.scm new file mode 100644 index 0000000..ca11837 --- /dev/null +++ b/s48/sequences/specseqs.scm @@ -0,0 +1,16 @@ +; Copyright (c) 2003 RT Happe +; 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)) diff --git a/s48/sequences/uniseqs.scm b/s48/sequences/uniseqs.scm new file mode 100644 index 0000000..04f7433 --- /dev/null +++ b/s48/sequences/uniseqs.scm @@ -0,0 +1,46 @@ +; Copyright (c) 2003 RT Happe +; 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)))