scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

sequences

This commit is contained in:
Rolf-Thomas Happe 2003-02-12 00:23:30 +00:00
parent d6ac20424e
commit 7cfd2e6c72
7 changed files with 302 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
s48/sequences/baseqs.scm Normal file
View File

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

39
s48/sequences/composeqs.scm Normal file
View File

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

53
s48/sequences/genseqs.scm Normal file
View File

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

35
s48/sequences/interfaces.scm Normal file
View File

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

49
s48/sequences/packages.scm Normal file
View File

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

16
s48/sequences/specseqs.scm Normal file
View File

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

46
s48/sequences/uniseqs.scm Normal file
View File

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