NetNews Usenet Archive 1992 #20/NN_1992_20.iso/spool/comp/lang/scheme/2172

Internet Message Format | 1992-09-09 | 17.1 KB

Path: sparky!uunet!haven.umd.edu!darwin.sura.net!sgiblab!cs.uoregon.edu!ogicse!psgrain!percy!data!kend
From: [e-mail] (Ken Dickey)
Newsgroups: comp.lang.scheme
Subject: Collection iterators for Scheme
Message-ID: <[e-mail]>
Date: 8 Sep 92 17:23:54 GMT
Article-I.D.: data.710
Organization: Microtek DSD, Hillsboro, OR
Lines: 621

[Appologies if you see this twice--mailer problems -Ken]


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? > (vector 1 2 3 4) (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" ---                       ;;