[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Collection iterators for Scheme
The RNRS-Author comittee which reviewed Dylan made a recommendation.
> Scheme might benefit from adopting a subset of the collection and
> sequence operations from Dylan. In particular, the ability to
> iterate over diverse sequences would be a valuable addition to
> Scheme, and compatible with similar generic operations on numbers
> already provided in the language.
I thought I might sketch something out.
Enjoy,
-Ken
;;========================================================================
; FILE "collect.oo"
; IMPLEMENTS Sample collection operations
; AUTHOR Ken Dickey
; DATE 1992 September 1
; LAST UPDATED 1992 September 2
; NOTES Expository (optimizations & checks elided).
; Requires YASOS (Yet Another Scheme Object System).
;;(require 'yasos)
;; COLLECTION INTERFACE
;; (collection? obj) -- predicate
;;
;; (do-elts proc coll+) -- apply proc element-wise to collections
;; (do-keys proc coll+) -- .. return value is unspecified
;;
;; (map-elts proc coll+) -- as with do-*, but returns collection
;; (map-keys proc coll+) -- e.g. (map-keys + (list 1 2 3) (vector 1 2 3))
;; -> #( 2 4 6 )
;;
;; (for-each-key coll proc) -- for single collection (more efficient)
;; (for-each-elt coll proc)
;;
;; (reduce proc seed coll+) -- e.g. (reduce + 0 (vector 1 2 3))
;; (any? predicate coll+) -- e.g. (any? odd? (list 2 3 4 5))
;; (every? predicate coll+) -- e.g. (every? collection collections)
;;
;; (empty? collection) -- I bet you can guess what these do as well...
;; (size collection)
;;
;;==============================
;; Collections must implement:
;; collection?
;; gen-elts
;; gen-keys
;; size
;; print
;;
;; Collections should implement {typically faster}:
;; for-each-key
;; for-each-elt
;;==============================
(define-operation (COLLECTION? obj)
;; default
(cond
((or (list? obj) (vector? obj) (string obj)) #t)
(else #f)
) )
(define (EMPTY? collection) (zero? (size collection)))
(define-operation (GEN-ELTS <collection>) ;; return element generator
;; default behavior
(cond ;; see utilities, below, for generators
((vector? <collection>) (vector-gen-elts <collection>))
((list? <collection>) (list-gen-elts <collection>))
((string? <collection>) (string-gen-elts <collection>))
(else
(error "Operation not supported: gen-elts " (print obj #f)))
) )
(define-operation (GEN-KEYS collection)
(if (or (vector? collection) (list? collection) (string? collection))
(let ( (max+1 (size collection)) (index 0) )
(lambda ()
(cond
((< index max+1)
(set! index (add1 index))
(sub1 index))
(else (error "no more keys in generator"))
) ) )
(error "Operation not handled: GEN-KEYS " collection)
) )
(define (DO-ELTS <proc> . <collections>)
(let ( (max+1 (size (car <collections>)))
(generators (map gen-elts <collections>))
)
(let loop ( (counter 0) )
(cond
((< counter max+1)
(apply <proc> (map (lambda (g) (g)) generators))
(loop (add1 counter))
)
(else 'unspecific) ; done
) )
) )
(define (DO-KEYS <proc> . <collections>)
(let ( (max+1 (size (car <collections>)))
(generators (map gen-keys <collections>))
)
(let loop ( (counter 0) )
(cond
((< counter max+1)
(apply <proc> (map (lambda (g) (g)) generators))
(loop (add1 counter))
)
(else 'unspecific) ; done
) )
) )
(define (MAP-ELTS <proc> . <collections>)
(let ( (max+1 (size (car <collections>)))
(generators (map gen-elts <collections>))
(vec (make-vector (size (car <collections>))))
)
(let loop ( (index 0) )
(cond
((< index max+1)
(vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
(loop (add1 index))
)
(else vec) ; done
) )
) )
(define (MAP-KEYS <proc> . <collections>)
(let ( (max+1 (size (car <collections>)))
(generators (map gen-keys <collections>))
(vec (make-vector (size (car <collections>))))
)
(let loop ( (index 0) )
(cond
((< index max+1)
(vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
(loop (add1 index))
)
(else vec) ; done
) )
) )
(define-operation (FOR-EACH-KEY <collection> <proc>)
;; default
(do-keys <proc> <collection>) ;; talk about lazy!
)
(define-operation (FOR-EACH-ELT <collection> <proc>)
(do-elts <proc> <collection>)
)
(define (REDUCE <proc> <seed> . <collections>)
(let ( (max+1 (size (car <collections>)))
(generators (map gen-elts <collections>))
)
(let loop ( (count 0) )
(cond
((< count max+1)
(set! <seed>
(apply <proc> <seed> (map (lambda (g) (g)) generators)))
(loop (add1 count))
)
(else <seed>)
) )
) )
;; pred true for every elt?
(define (EVERY? <pred?> . <collections>)
(let ( (max+1 (size (car <collections>)))
(generators (map gen-elts <collections>))
)
(let loop ( (count 0) )
(cond
((< count max+1)
(if (apply <pred?> (map (lambda (g) (g)) generators))
(loop (add1 count))
#f)
)
(else #t)
) )
) )
;; pred true for any elt?
(define (ANY? <pred?> . <collections>)
(let ( (max+1 (size (car <collections>)))
(generators (map gen-elts <collections>))
)
(let loop ( (count 0) )
(cond
((< count max+1)
(if (apply <pred?> (map (lambda (g) (g)) generators))
#t
(loop (add1 count))
))
(else #f)
) )
) )
;; SAMPLE COLLECTION -- simple-table .. also a TABLE
(define-predicate TABLE?)
(define-operation (LOOKUP table key failure-object))
(define-operation (ASSOCIATE! table key value)) ;; returns key
(define-operation (REMOVE! table key)) ;; returns value
(define (MAKE-SIMPLE-TABLE)
(let ( (table (list)) )
(object
;; table behaviors
((TABLE? self) #t)
((SIZE self) (size table))
((PRINT self port) (format port "#<SIMPLE-TABLE>"))
((LOOKUP self key failure-object)
(cond
((assq key table) => cdr)
(else failure-object)
))
((ASSOCIATE! self key value)
(cond
((assq key table) => (lambda (bucket) (set-cdr! bucket value) key))
(else
(set! table (cons (cons key value) table))
key)
))
((REMOVE! self key) ;; returns old value
(cond
((null? table) (error "TABLE:REMOVE! Key not found: " key))
((eq? key (caar table))
(let ( (value (cdar table)) )
(set! table (cdr table))
value)
)
(else
(let loop ( (last table) (this (cdr table)) )
(cond
((null? this) (error "TABLE:REMOVE! Key not found: " key))
((eq? key (caar this))
(let ( (value (cdar this)) )
(set-cdr! last (cdr this))
value)
)
(else
(loop (cdr last) (cdr this)))
) ) )
))
;; collection behaviors
((COLLECTION? self) #t)
((GEN-KEYS self) (list-gen-elts (map car table)))
((GEN-ELTS self) (list-gen-elts (map cdr table)))
((FOR-EACH-KEY self proc)
(for-each (lambda (bucket) (proc (car bucket))) table)
)
((FOR-EACH-ELT self proc)
(for-each (lambda (bucket) (proc (cdr bucket))) table)
)
) ) )
;; MISC UTILITIES
(define (ZERO? obj) (= obj 0))
(define (ADD1 obj) (+ obj 1))
(define (SUB1 obj) (- obj 1))
;; Let lists be regular
(define (LIST-REF <list> <index>)
(if (zero? <index>)
(car <list>)
(list-ref (cdr <list>) (sub1 <index>))
) )
;; Nota Bene: list-set! is bogus for element 0
(define (LIST-SET! <list> <index> <value>)
(define (set-loop last this idx)
(cond
((zero? idx)
(set-cdr! last (cons <value> (cdr this)))
<list>
)
(else (set-loop (cdr last) (cdr this) (sub1 idx)))
) )
;; main
(if (zero? <index>)
(cons <value> (cdr <list>)) ;; return value
(set-loop <list> (cdr <list>) (sub1 <index>)))
)
(ADD-SETTER list-ref list-set!) ; for (setter list-ref)
;; generator for list elements
(define (LIST-GEN-ELTS <list>)
(lambda ()
(if (null? <list>)
(error "No more list elements in generator")
(let ( (elt (car <list>)) )
(set! <list> (cdr <list>))
elt))
) )
(define (MAKE-VEC-GEN-ELTS <accessor>)
(lambda (vec)
(let ( (max+1 (size vec))
(index 0)
)
(lambda ()
(cond ((< index max+1)
(set! index (add1 index))
(<accessor> vec (sub1 index))
)
(else #f)
) )
) )
)
(define VECTOR-GEN-ELTS (make-vec-gen-elts vector-ref))
(define STRING-GEN-ELTS (make-vec-gen-elts string-ref))
;; --- E O F "collect.oo" --- ;;
;;========================================================================
;; FILE "YASOS.scm"
;; IMPLEMENTS YASOS: Yet Another Scheme Object System
;; AUTHOR Kenneth Dickey
;; DATE 1992 March 1
;; LAST UPDATED 1992 September 1 -- misc optimizations
;; 1992 May 22 -- added SET and SETTER
;; REQUIRES R^4RS Syntax System
;; NOTES: A simple object system for Scheme based on the paper by
;; Norman Adams and Jonathan Rees: "Object Oriented Programming in
;; Scheme", Proceedings of the 1988 ACM Conference on LISP and Functional
;; Programming, July 1988 [ACM #552880].
;
;; Setters use space for speed {extra conses for O(1) lookup}.
;;
;; INTERFACE:
;;
;; (DEFINE-OPERATION (opname self arg ...) default-body)
;;
;; (DEFINE-PREDICATE opname)
;;
;; (OBJECT ((name self arg ...) body) ... )
;;
;; (OBJECT-WITH-ANCESTORS ( (ancestor1 init1) ...) operation ...)
;;
;; in an operation {a.k.a. send-to-super}
;; (OPERATE-AS component operation self arg ...)
;;
;; (SET var new-vale) or (SET (access-proc index ...) new-value)
;;
;; (SETTER access-proc) -> setter-proc
;; (DEFINE-ACCESS-OPERATION getter-name) -> operation
;; (ADD-SETTER getter setter) ;; setter is a Scheme proc
;; (REMOVE-SETTER-FOR getter)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;; IMPLEMENTATION ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INSTANCES
; (define-predicate instance?)
; (define (make-instance dispatcher)
; (object
; ((instance? self) #t)
; ((instance-dispatcher self) dispatcher)
; ) )
(define make-instance 'bogus) ;; defined below
(define instance? 'bogus)
(define-syntax INSTANCE-DISPATCHER ;; alias so compiler can inline for speed
(syntax-rules () ((instance-dispatcher inst) (cdr inst)))
)
(let ( (instance-tag "instance") ) ;; Make a unique tag within a local scope.
;; No other data object is EQ? to this tag.
(set! MAKE-INSTANCE
(lambda (dispatcher) (cons instance-tag dispatcher)))
(set! INSTANCE?
(lambda (obj) (and (pair? obj) (eq? (car obj) instance-tag))))
)
;; DEFINE-OPERATION
(define-syntax DEFINE-OPERATION
(syntax-rules ()
((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...)
;;=>
(define <name>
(letrec ( (former-inst #f) ;; simple caching -- for loops
(former-method #f)
(self
(lambda (<inst> <arg> ...)
(cond
((eq? <inst> former-inst) ; check cache
(former-method <inst> <arg> ...)
)
((and (instance? <inst>)
((instance-dispatcher <inst>) self))
=> (lambda (method)
(set! former-inst <inst>)
(set! former-method method)
(method <inst> <arg> ...))
)
(else <exp1> <exp2> ...)
) ) ) )
self)
))
((define-operation (<name> <inst> <arg> ...) ) ;; no body
;;=>
(define-operation (<name> <inst> <arg> ...)
(error "Operation not handled"
'<name>
(format #f (if (instance? <inst>) "#<INSTANCE>" "~s") <inst>)))
))
)
;; DEFINE-PREDICATE
(define-syntax DEFINE-PREDICATE
(syntax-rules ()
((define-predicate <name>)
;;=>
(define-operation (<name> obj) #f)
)
) )
;; OBJECT
(define-syntax OBJECT
(syntax-rules ()
((object ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
;;=>
(let ( (table
(list (cons <name>
(lambda (<self> <arg> ...) <exp1> <exp2> ...))
...
) )
)
(make-instance
(lambda (op)
(cond
((assq op table) => cdr)
(else #f)
) ) )))) )
;; OBJECT with MULTIPLE INHERITANCE {First Found Rule}
(define-syntax OBJECT-WITH-ANCESTORS
(syntax-rules ()
((object-with-ancestors ( (<ancestor1> <init1>) ... ) <operation> ...)
;;=>
(let ( (<ancestor1> <init1>) ... )
(let ( (child (object <operation> ...)) )
(make-instance
(lambda (op)
(or ((instance-dispatcher child) op)
((instance-dispatcher <ancestor1>) op) ...
) ) )
)))
) )
;; OPERATE-AS {a.k.a. send-to-super}
; used in operations/methods
(define-syntax OPERATE-AS
(syntax-rules ()
((operate-as <component> <op> <composit> <arg> ...)
;;=>
(((instance-dispatcher <component>) <op>) <composit> <arg> ...)
))
)
;; SET & SETTER
(define-syntax SET
(syntax-rules ()
((set (<access> <index> ...) <newval>)
((setter <access>) <index> ... <newval>)
)
((set <var> <newval>)
(set! <var> <newval>)
)
) )
(define add-setter 'bogus)
(define remove-setter-for 'bogus)
(define SETTER
(let ( (known-setters (list (cons car set-car!)
(cons cdr set-cdr!)
(cons vector-ref vector-set!)
(cons string-ref string-set!))
)
(added-setters '())
)
(set! ADD-SETTER
(lambda (getter setter)
(set! added-setters (cons (cons getter setter) added-setters)))
)
(set! REMOVE-SETTER-FOR
(lambda (getter)
(cond
((null? added-setters)
(error "REMOVE-SETTER: Unknown getter" getter)
)
((eq? getter (caar added-setters))
(set! added-setters (cdr added-setters))
)
(else
(let loop ((x added-setters) (y (cdr added-setters)))
(cond
((null? y) (error "REMOVE-SETTER: Unknown getter" getter))
((eq? getter (caar y)) (set-cdr! x (cdr y)))
(else (loop (cdr x) (cdr y)))
) ) )
) ) )
(letrec ( (self
(lambda (proc-or-operation)
(cond ((assq proc-or-operation known-setters) => cdr)
((assq proc-or-operation added-setters) => cdr)
(else (proc-or-operation self))) )
) )
self)
) )
(define (%%MAKE-ACCESS-OPERATION <name>)
(letrec ( (setter-dispatch
(lambda (inst . args)
(cond
((and (instance? inst)
((instance-dispatcher inst) setter-dispatch))
=> (lambda (method) (apply method inst args))
)
(else #f)))
)
(self
(lambda (inst . args)
(cond
((eq? inst setter) setter-dispatch) ; for (setter self)
((and (instance? inst)
((instance-dispatcher inst) self))
=> (lambda (method) (apply method inst args))
)
(else (error "Operation not handled" <name> inst))
) )
)
)
self
) )
(define-syntax DEFINE-ACCESS-OPERATION
(syntax-rules ()
((define-access-operation <name>)
;=>
(define <name> (%%make-access-operation '<name>))
) ) )
;;---------------------
;; general operations
;;---------------------
(define-operation (PRINT obj port)
(format port
;; if an instance does not have a PRINT operation..
(if (instance? obj) "#<INSTANCE>" "~s")
obj
) )
(define-operation (SIZE obj)
;; default behavior
(cond
((vector? obj) (vector-length obj))
((list? obj) (length obj))
((pair? obj) 2)
((string? obj) (string-length obj))
((char? obj) 1)
(else
(error "Operation not supported: size" obj))
) )
;; --- E O F "yasos.scm" --- ;;