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

s48/krims/README

This commit is contained in:
Rolf-Thomas Happe 2003-02-14 00:47:58 +00:00
parent 60069b30d4
commit 3c234fddc9
9 changed files with 440 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
s48/krims/README Normal file
View File

@ -0,0 +1,100 @@
sunterlib/s48/krims -- Odds and Ends
structure SRFI-1+ -- SRFI-1 + REST
The structure SRFI-1+ extends the list lib with REST := CDR. [ I dearly
like (FIRST . REST) lists and (CAR . CDR) trees. ]
*
structure SRFI-9+ -- SRFI-9 + DEFINE-RECORD-DISCLOSER
The structure SRFI-9+ extends SRFI-9 by the convenient record disclosing
facility from DEFINE-RECORD-TYPES:
(define-record-type rt <make> predicate <field spec> ...) SYNTAX
just as SRFI-9.
(define-record-discloser rt d) --> unspecified PROCEDURE
just as DEFINE-RECORD-TYPES: Install the procedure D : rt -> list
as discloser for records of type RT where RT has been defined with
DEFINE-RECORD-TYPE (from above) and D maps its input record to a
printable list starting with a symbol.
*
structure KRIMS -- Odds and Ends
The structure KRIMS gathers miscellaneous tiny utilities mainly for use
of other sunterlib projects.
(assert [id] exp) SYNTAX
The usual ASSERT macro with an optional ID tag: Signal an error and
complain if EXP evaluates to false. The error message contains the
value of ID (if supplied) and the expression EXP. [ ASSERT being a
macro, we can change it to the trivial form that doesn't evaluate its
arguments and recompile before selling our stuff ... ]
*
(receive/name loop formals exp form0 ...) SYNTAX
RECEIVE/NAME is a multi-values analogue of named LET (but much less
useful) that helps when chaining n-valued n-ary functions, for instance.
Synopsis: Bind LOOP to a macro wrapped around the procedure LUP with
parameter list FORMALS and body FORM0 ... so that
* (LOOP multi-valued-expression) calls LUP with the values of
multi-valued-expression , and
* (LOOP exp0 ...) becomes (LUP exp0 ...)
Syntax: (receive/name <identifier> <formals> <expression> <body>)
with non-terminals from R5RS.
Semantics: (A special case is good enough.)
Assuming the LOOP tag isn't shadowed in the context `...'
(receive/name loop (x y) exp0
... (loop exp1) ...)
is eqv to
(receive (x y) exp0
(let lup ((x x) (y y))
... (receive (x y) exp1
(lup x y)) ...))
and (receive/name loop (x y) exp0
... (loop exp1 exp1) ...)
is eqv to
(receive (x y) exp0
(let lup ((x x) (y y))
... (lup exp1 exp2) ...))
Example:
(define (shove n xs) (values (- n 1) (cons n xs)))
(receive/name loop (n xs) (values 7 '())
(if (= n 0)
(display xs)
(loop (shove n xs))))
==> (1 2 3 4 5 6 7)
*
(gen-dispatch ((predicate action) ...) e0 e1 ... en) SYNTAX
Dispatch action on type of first argument E0: feed E0 ... EN to the
first action such that the PREDICATE holds for E0. Signal an error
if nothing goes.
Example:
(gen-dispatch ((string? string-ref)
(vector? vector-ref)
(list? list-ref))
'#(a zopp 36) 2)
==> 36
oOo

36
s48/krims/interfaces.scm Normal file
View File

@ -0,0 +1,36 @@
;; since SRFI-1-INTERFACE isn't defined in the usual 0.6.3 image
;; definition hijacked from scsh-0.6.3/scheme/more-interfaces.scm
(define-interface srfi-1-face
(export map for-each member assoc ; redefined from R5RS
xcons make-list list-tabulate cons* list-copy
proper-list? circular-list? dotted-list? not-pair? null-list? list=
circular-list length+
iota
first second third fourth fifth sixth seventh eighth ninth tenth
car+cdr
take drop
take-right drop-right
take! drop-right!
split-at split-at!
last last-pair
zip unzip1 unzip2 unzip3 unzip4 unzip5
count
append! append-reverse append-reverse! concatenate concatenate!
unfold fold pair-fold reduce
unfold-right fold-right pair-fold-right reduce-right
append-map append-map! map! pair-for-each filter-map map-in-order
filter partition remove
filter! partition! remove!
find find-tail any every list-index
take-while drop-while take-while!
span break span! break!
delete delete!
alist-cons alist-copy
delete-duplicates delete-duplicates!
alist-delete alist-delete!
reverse!
lset<= lset= lset-adjoin
lset-union lset-intersection lset-difference lset-xor
lset-diff+intersection
lset-union! lset-intersection! lset-difference! lset-xor!
lset-diff+intersection!))

12
s48/krims/packages.scm
View File

@ -11,7 +11,16 @@
scheme) scheme)
(files krims)) (files krims))
;; srfi-1 + REST
(define-structure srfi-1+
(compound-interface srfi-1-face
(export rest))
(open srfi-1 scheme)
(begin (define rest cdr)))
;; srfi-9 + define-record-discloser ;; srfi-9 + define-record-discloser
;; [ extended version of the srfi-9 structure def
;; from scsh-0.6.3/scheme/more-packages.scm ]
(define-structure srfi-9+ (define-structure srfi-9+
(export (define-record-type :syntax) (export (define-record-type :syntax)
define-record-discloser) define-record-discloser)
@ -23,3 +32,6 @@
((define-record-type type-name . stuff) ((define-record-type type-name . stuff)
(sys:define-record-type type-name type-name . stuff)))) (sys:define-record-type type-name type-name . stuff))))
(define define-record-discloser sys:define-record-discloser))) (define define-record-discloser sys:define-record-discloser)))

13
s48/sequences/baseqs.scm
View File

@ -50,15 +50,8 @@
((vector? s) (apply make-vector len maybe-fill)) ((vector? s) (apply make-vector len maybe-fill))
((list? s) (apply make-list len maybe-fill)) ((list? s) (apply make-list len maybe-fill))
((behaved-sequence? s) ((behaved-sequence? s)
(apply make-behaved-sequence (apply make-behaved-sequence/type
(behaved-sequence:type s) len maybe-fill)) (behaved-sequence:type s) len maybe-fill))
(else (error "make-another : unsupported sequence(?) type" s)))) (else (error "make-another-sequence : first arg not a sequence?"
s))))

104
s48/sequences/composeqs.scm
View File

@ -3,7 +3,6 @@
;;; sequence operations definABLE in terms of the elementary operations ;;; sequence operations definABLE in terms of the elementary operations
;;; with no regard to the concrete sequence type ;;; with no regard to the concrete sequence type
;;; [ not too much there yet ]
(define (ident x) x) (define (ident x) x)
@ -12,45 +11,120 @@
((string? string->list) ((string? string->list)
(byte-vector? contiguous-sequence->list) (byte-vector? contiguous-sequence->list)
(vector? vector->list) (vector? vector->list)
(list? ident) (pair? ident)
(behaved-sequence? contiguous-sequence->list)) (behaved-sequence? contiguous-sequence->list))
s)) s))
(define (sequence-fill! s x) (define (sequence-fill! s x)
(gen-dispatch (gen-dispatch
((string? string-fill!) ((vector? vector-fill!)
(string? string-fill!)
(byte-vector? contiguous-sequence-fill!) (byte-vector? contiguous-sequence-fill!)
(vector? vector-fill!) (pair? ident)
(list? ident)
(behaved-sequence? contiguous-sequence-fill!)) (behaved-sequence? contiguous-sequence-fill!))
s x)) s x))
(define (subsequence s start end) (define (subsequence s start end)
(cond ((pair? s) (cond ((vector? s)
(sublist s start end)) (subvector s start end))
((string? s) ((string? s)
(substring s start end)) (substring s start end))
((pair? s)
(sublist s start end))
(else (contiguous-subsequence s start end)))) (else (contiguous-subsequence s start end))))
(define (sequence-copy s) (define (sequence-copy s)
(gen-dispatch (gen-dispatch
((string? string-copy) ((vector? vector-copy)
(string? string-copy)
(byte-vector? contiguous-sequence-copy) (byte-vector? contiguous-sequence-copy)
(vector? contiguous-sequence-copy) (pair? list-copy)
(list? list-copy)
(behaved-sequence? contiguous-sequence-copy)) (behaved-sequence? contiguous-sequence-copy))
s)) s))
(define (sequence-append seq . seqs)
(cond ((vector? seq) (apply vector-append seq seqs))
((string? seq) (apply string-append seq seqs))
((pair? seq) (apply append seq seqs))
(else (apply contiguous-sequence-append seq seqs))))
(define (sequence-map proc s . opts)
(cond ((vector? s)
(apply vector-map proc s opts))
((string? s)
(apply string-map proc s opts))
((and (pair? s) (null? opts))
(map proc s))
(else (apply contiguous-sequence-map proc s opts))))
(define (sequence-for-each proc s . opts)
(cond ((vector? s)
(apply vector-for-each proc s opts))
((string? s)
(apply string-for-each proc s opts))
((and (pair? s) (null? opts))
(for-each proc s))
(else (apply contiguous-sequence-for-each proc s opts))))
(define (sequence-fold kons nil s . opts)
(cond ((vector? s)
(apply vector-fold kons nil s opts))
((string? s)
(apply string-fold kons nil s opts))
((and (pair? s) (null? opts))
(fold kons nil s))
(else (apply contiguous-sequence-fold kons nil s opts))))
(define (sequence-fold-right kons nil s . opts)
(cond ((vector? s)
(apply vector-fold-right kons nil s opts))
((string? s)
(apply string-fold-right kons nil s opts))
((and (pair? s) (null? opts))
(fold-right kons nil s))
(else (apply contiguous-sequence-fold-right kons nil s opts))))
(define (sequence-any pred s . opts)
(cond ((vector? s)
(apply vector-any pred s opts))
((string? s)
(apply string-any pred s opts))
((and (pair? s) (null? opts))
(any pred s))
(else (apply contiguous-sequence-any pred s opts))))
(define (sequence-every pred s . opts)
(cond ((vector? s)
(apply vector-every pred s opts))
((string? s)
(apply string-every pred s opts))
((and (pair? s) (null? opts))
(every pred s))
(else (apply contiguous-sequence-every pred s opts))))
;; The following procedures take or accept >1 sequence argument. ;; The following procedures take or accept >1 sequence argument.
;; Therefore we don't dispatch on the sequence type so that we ;; Therefore we don't dispatch on the sequence type so that we
;; may support mixed sequences: (sequence-append (vector) "abc" '(anton)) ;; may support mixed sequences: (sequence-append (vector) "abc" '(anton))
(define sequence-append contiguous-sequence-append) (define sequence-append contiguous-sequence-append)
(define sequence-map contiguous-sequence-map) (define sequences-map contiguous-sequences-map)
(define sequence-for-each contiguous-sequence-for-each) (define sequences-for-each contiguous-sequences-for-each)
(define sequence-fold contiguous-sequence-fold) (define sequences-fold contiguous-sequences-fold)
(define sequence-every contiguous-sequence-every) (define sequences-fold-right contiguous-sequences-fold-right)
(define sequence-every/bounds contiguous-sequence-every/bounds) (define sequences-any contiguous-sequences-any)
(define sequences-every contiguous-sequences-every)

114
s48/sequences/genseqs.scm
View File

@ -12,11 +12,12 @@
;;; subsequence ;;; subsequence
;;; sequence-copy ;;; sequence-copy
;;; sequence-append ;;; sequence-append
;;; sequence-map ;;; sequence-map sequences-map
;;; sequence-for-each ;;; sequence-for-each sequences-for-each
;;; sequence-fold ;;; sequence-fold sequences-fold
;;; sequence-every ;;; sequence-fold-right sequence-fold-right
;;; sequence-every/bounds ;;; sequence-any sequences-any
;;; sequence-every sequences-every
(define (sequence->list s) (define (sequence->list s)
(let loop ((i (sequence-length s)) (xs '())) (let loop ((i (sequence-length s)) (xs '()))
@ -34,6 +35,7 @@
(define (subsequence s start end) (define (subsequence s start end)
(assert (<= start end))
(let* ((len (- end start)) (let* ((len (- end start))
(ss (make-another-sequence s len))) (ss (make-another-sequence s len)))
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
@ -45,18 +47,20 @@
(subsequence s 0 (sequence-length s))) (subsequence s 0 (sequence-length s)))
(define (sequence-fold/3 kons nil s) (define (sequence-fold kons nil s . opts)
(let ((end (sequence-length s))) (let-optionals opts ((start 0)
(let loop ((subtotal nil) (i 0)) (end (sequence-length s)))
(assert (<= start end))
(let loop ((subtotal nil) (i start))
(if (= i end) subtotal (if (= i end) subtotal
(loop (kons (sequence-ref s i) subtotal) (+ i 1)))))) (loop (kons (sequence-ref s i) subtotal) (+ i 1))))))
(define (sequence-fold kons nil seq . seqs) (define (sequences-fold kons nil seq . seqs)
(if (null? seqs) (if (null? seqs)
(sequence-fold/3 kons nil seq) (sequence-fold kons nil seq)
(let* ((ss (cons seq seqs)) (let* ((ss (cons seq seqs))
;; are we morally obliged to use a fold/3 here? ;; are we morally obliged to use FOLD here?
(end (apply min (map sequence-length ss)))) (end (apply min (map sequence-length ss))))
(let loop ((subtotal nil) (i 0)) (let loop ((subtotal nil) (i 0))
(if (= i end) subtotal (if (= i end) subtotal
@ -67,6 +71,30 @@
(+ i 1))))))) (+ i 1)))))))
(define (sequence-fold-right kons nil s . opts)
(let-optionals opts ((start 0)
(end (sequence-length s)))
(assert (<= start end))
(let loop ((subtotal nil) (i end))
(if (= i start) subtotal
(loop (kons (sequence-ref s (- i 1)) subtotal) (- i 1))))))
(define (sequences-fold-right kons nil seq . seqs)
(if (null? seqs)
(sequence-fold-right kons nil seq)
(let* ((ss (cons seq seqs))
;; are we morally obliged to use FOLD here?
(end (apply min (map sequence-length ss))))
(let loop ((subtotal nil) (i (- end 1)))
(if (= i -1) subtotal
(loop (apply kons (append! (map (lambda (s)
(sequence-ref s i))
ss)
(list subtotal)))
(- i 1)))))))
(define (sequence-append . seqs) (define (sequence-append . seqs)
(if (null? seqs) (vector) (if (null? seqs) (vector)
(let* ((len (apply + (map sequence-length seqs))) (let* ((len (apply + (map sequence-length seqs)))
@ -80,7 +108,15 @@
(sequence-ref s i))))))))) (sequence-ref s i)))))))))
(define (sequence-for-each proc seq . seqs) (define (sequence-for-each proc seq . opts)
(let-optionals opts ((start 0) (end (sequence-length seq)))
(assert (<= start end))
(do ((i start (+ i 1)))
((= i end) (unspecific))
(proc (sequence-ref seq i)))))
(define (sequences-for-each proc seq . seqs)
(let* ((ss (cons seq seqs)) (let* ((ss (cons seq seqs))
(end (apply min (map sequence-length ss)))) (end (apply min (map sequence-length ss))))
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
@ -88,7 +124,16 @@
(apply proc (map (lambda (s) (sequence-ref s i)) ss))))) (apply proc (map (lambda (s) (sequence-ref s i)) ss)))))
(define (sequence-map proc seq . seqs) (define (sequence-map proc seq . opts)
(let-optionals opts ((start 0) (end (sequence-length seq)))
(assert (<= start end))
(let ((res (make-another-sequence seq end)))
(do ((i start (+ i 1)))
((= i end) res)
(sequence-set! res i (proc (sequence-ref seq i)))))))
(define (sequences-map proc seq . seqs)
(let* ((ss (cons seq seqs)) (let* ((ss (cons seq seqs))
(end (apply min (map sequence-length ss))) (end (apply min (map sequence-length ss)))
(res (make-another-sequence seq end))) (res (make-another-sequence seq end)))
@ -97,8 +142,37 @@
(sequence-set! res i (apply proc (map (lambda (s) (sequence-ref s i)) (sequence-set! res i (apply proc (map (lambda (s) (sequence-ref s i))
ss)))))) ss))))))
(define (sequence-any pred seq . opts)
(let-optionals opts ((start 0) (end (sequence-length seq)))
(assert (<= start end))
(let loop ((i start))
(cond ((= i end) #f)
((pred (sequence-ref seq i)) #t)
(else (loop (+ i 1)))))))
(define (sequence-every pred . seqs)
(define (sequences-any pred . 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))
seqs))
#t)
(else (loop (+ i 1))))))))
(define (sequence-every pred seq . opts)
(let-optionals opts ((start 0) (end (sequence-length seq)))
(assert (<= start end))
(let loop ((i start))
(cond ((= i end) #t)
((pred (sequence-ref seq i))
(loop (+ i 1)))
(else #f)))))
(define (sequences-every pred . seqs)
(if (null? seqs) #t (if (null? seqs) #t
(let ((end (apply min (map sequence-length seqs)))) (let ((end (apply min (map sequence-length seqs))))
(let loop ((i 0)) (let loop ((i 0))
@ -109,18 +183,6 @@
(else #f)))))) (else #f))))))
(define (sequence-every/bounds start end pred . seqs)
(assert (<= 0 start end))
(if (null? seqs) #t
(let ((eff-end (apply min end (map sequence-length seqs))))
(let loop ((i start))
(cond ((= i eff-end) #t)
((apply pred (map (lambda (seq) (sequence-ref seq i))
seqs))
(loop (+ i 1)))
(else #f))))))

57
s48/sequences/interfaces.scm
View File

@ -16,26 +16,63 @@
subsequence subsequence
sequence-copy sequence-copy
sequence-append sequence-append
sequence-map sequence-map sequences-map
sequence-for-each sequence-for-each sequences-for-each
sequence-fold sequence-fold sequences-fold
sequence-every sequence-fold-right sequences-fold-right
sequence-every/bounds)) sequence-any sequences-any
sequence-every sequences-every))
;; specialised versions of sequence operations ;; specialised sequence operations (for lists, actually)
(define-interface sequence-specifics-face (define-interface sequence-specifics-face
(export make-list (export list-set!
list-set!
list-fill! list-fill!
sublist)) sublist
))
;; the sequence ADT etc. ;; the sequence ADT etc.
(define-interface behaved-sequences-face (define-interface behaved-sequences-face
(export make-sequence-type (export make-sequence-type
make-behaved-sequence-record make-behaved-sequence-record
behaved-sequence:type behaved-sequence:type
make-behaved-sequence make-behaved-sequence/type
behaved-sequence/type
list->behaved-sequence/type
behaved-sequence? behaved-sequence?
behaved-sequence-ref behaved-sequence-ref
behaved-sequence-set! behaved-sequence-set!
behaved-sequence-length)) behaved-sequence-length))
;; the basic + extra sequence procedures
;; [ extends the union of SEQUENCE-BASICS- and -EXTRAS-INTERFACE with
;; `VECTOR' replacing `SEQUENCE' ]
(define-interface vector-lib-face
(export ;; std constructors
vector
make-vector
;; basics w/o the vanilla constructor
vector?
vector-length
vector-ref
vector-set!
;; extras
vector->list
vector-fill!
subvector
vector-copy
vector-append
vector-map
vector-for-each
vector-fold
vector-fold-right
vector-any
vector-every
vectors-map
vectors-for-each
vectors-fold
vectors-fold-right
vectors-any
vectors-every
))

52
s48/sequences/packages.scm
View File

@ -9,19 +9,21 @@
scheme) scheme)
(files uniseqs)) (files uniseqs))
;; some sequence operations tuned for lists ;; specialists for lists, vectors, strings
(define-structure sequence-specifics sequence-specifics-face (define-structure sequence-specifics sequence-specifics-face
(open srfi-1 ; drop first take make-list pair-for-each (open srfi-1 ; list procs
srfi-13 ; string procs
scheme) scheme)
(files specseqs)) (files specseqs))
;; basic sequence accessors etc. ;; basic sequence accessors etc.
(define-structure sequence-basics sequence-basics-face (define-structure sequence-basics sequence-basics-face
(open krims ; gen-dispatch (open krims ; gen-dispatch
let-opt ; :optional let-opt ; :optional [ from scsh ]
sequence-specifics ; list-set! make-list sequence-specifics ; list-set! make-list
behaved-sequences behaved-sequences
byte-vectors byte-vectors
srfi-1 ; make-list
srfi-23 ; error srfi-23 ; error
scheme) scheme)
(files baseqs)) (files baseqs))
@ -33,9 +35,48 @@
util ; unspecific util ; unspecific
srfi-1 ; append! srfi-1 ; append!
srfi-23 ; error srfi-23 ; error
let-opt ; let-optionals [ from scsh ]
scheme) scheme)
(files genseqs)) (files genseqs))
;; sequence procedures specialised to vectors
(define-structure vector-lib vector-lib-face
(open krims ; assert
util ; unspecific
let-opt ; let-optionals [ from scsh ]
srfi-1 ; append!
scheme)
;; bind the basic operations to vector specialists
(begin
(define sequence? vector?)
(define sequence-length vector-length)
(define sequence-ref vector-ref)
(define sequence-set! vector-set!)
(define (make-another-sequence v k . maybe-fill)
(apply make-vector k maybe-fill)))
(files genseqs)
;; rename extras not supplied by scheme
(begin
(define subvector subsequence)
(define vector-copy sequence-copy)
(define vector-append sequence-append)
(define vector-map sequence-map)
(define vector-for-each sequence-for-each)
(define vector-fold sequence-fold)
(define vector-fold-right sequence-fold-right)
(define vector-any sequence-any)
(define vector-every sequence-every)
(define vectors-map sequences-map)
(define vectors-for-each sequences-for-each)
(define vectors-fold sequences-fold)
(define vectors-fold-right sequences-fold-right)
(define vectors-any sequences-any)
(define vectors-every sequences-every)
))
;; elementary and other general sequence operations, typically dispatching ;; elementary and other general sequence operations, typically dispatching
;; early on the sequence type in order to make use of built-ins or special ;; early on the sequence type in order to make use of built-ins or special
;; code (notably for lists) ;; code (notably for lists)
@ -47,7 +88,10 @@
sequence-basics sequence-basics
behaved-sequences behaved-sequences
sequence-specifics sequence-specifics
srfi-1 ; list-copy
byte-vectors byte-vectors
vector-lib
srfi-1 ; list procs
srfi-13 ; string procs
let-opt ; let-optionals [ from scsh ]
scheme) scheme)
(files composeqs)) (files composeqs))

21
s48/sequences/uniseqs.scm
View File

@ -39,8 +39,21 @@
((sequence-type:meter (behaved-sequence:type s)) ((sequence-type:meter (behaved-sequence:type s))
(behaved-sequence:instance s))) (behaved-sequence:instance s)))
;; note the necessary TYPE arg contrasting with MAKE-VECTOR etc. (define (make-behaved-sequence/type st k . maybe-fill)
(define (make-behaved-sequence type k . maybe-fill) (make-behaved-sequence-record st
(make-behaved-sequence-record type (apply (sequence-type:maker st)
(apply (sequence-type:maker type)
k maybe-fill))) k maybe-fill)))
(define (list->behaved-sequence/type st xs)
(let* ((len (length xs))
(s (make-behaved-sequence/type st len)))
(do ((i 0 (+ i 1))
(xs xs (cdr xs)))
((null? xs) s)
(behaved-sequence-set! s i (car xs)))))
(define (behaved-sequence/type st . args)
(list->behaved-sequence/type st args))