sunterlib/s48/sequences/uniseqs.scm

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

(define (make-behaved-sequence/type st k . maybe-fill)
  (make-behaved-sequence-record st
                                (apply (sequence-type:maker st)
                                       k maybe-fill)))

(define (list->behaved-sequence/type st xs . opts)
  (let-optionals opts ((start 0) (end (length xs)))
    (assert (<= 0 start end))
    (let ((s (make-behaved-sequence/type st (- end start))))
      (do ((i 0 (+ i 1))
           (xs xs (cdr xs)))
          ((= i end) s)
        (behaved-sequence-set! s (- i start) (car xs)))))) 

(define (behaved-sequence/type st . args)
  (list->behaved-sequence/type st args))