home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / collect.scm < prev    next >
Encoding:
Text File  |  1994-12-07  |  6.7 KB  |  237 lines
  1. ;"collect.scm" Sample collection operations
  2. ; COPYRIGHT (c) Kenneth Dickey 1992
  3. ;
  4. ;               This software may be used for any purpose whatever
  5. ;               without warrantee of any kind.
  6. ; AUTHOR        Ken Dickey
  7. ; DATE          1992 September 1
  8. ; LAST UPDATED  1992 September 2
  9. ; NOTES         Expository (optimizations & checks elided).
  10. ;               Requires YASOS (Yet Another Scheme Object System).
  11.  
  12. (require 'yasos)
  13.  
  14. (define-operation (COLLECT:COLLECTION? obj)
  15.  ;; default
  16.   (cond
  17.     ((or (list? obj) (vector? obj) (string? obj)) #t)
  18.     (else #f)
  19. ) )
  20.  
  21. (define (COLLECT:EMPTY? collection) (zero? (yasos:size collection)))
  22.  
  23. (define-operation (COLLECT:GEN-ELTS <collection>) ;; return element generator
  24.   ;; default behavior
  25.   (cond                      ;; see utilities, below, for generators
  26.     ((vector? <collection>) (collect:vector-gen-elts <collection>)) 
  27.     ((list?   <collection>) (collect:list-gen-elts   <collection>))
  28.     ((string? <collection>) (collect:string-gen-elts <collection>))
  29.     (else 
  30.      (slib:error "Operation not supported: GEN-ELTS " (yasos:print obj #f)))
  31. ) )
  32.  
  33. (define-operation (COLLECT:GEN-KEYS collection)
  34.   (if (or (vector? collection) (list? collection) (string? collection))
  35.       (let ( (max+1 (yasos:size collection)) (index 0) )
  36.      (lambda ()
  37.             (cond
  38.           ((< index max+1)
  39.            (set! index (collect:add1 index))
  40.            (collect:sub1 index))
  41.           (else (slib:error "no more keys in generator"))
  42.       ) ) )
  43.       (slib:error "Operation not handled: GEN-KEYS " collection)
  44. ) )
  45.  
  46. (define (COLLECT:DO-ELTS <proc> . <collections>)
  47.   (let ( (max+1 (yasos:size (car <collections>)))
  48.          (generators (map collect:gen-elts <collections>))
  49.        )
  50.     (let loop ( (counter 0) )
  51.        (cond
  52.           ((< counter max+1)
  53.            (apply <proc> (map (lambda (g) (g)) generators))
  54.            (loop (collect:add1 counter))
  55.           )
  56.           (else 'unspecific)  ; done
  57.     )  )
  58. ) )
  59.  
  60. (define (COLLECT:DO-KEYS <proc> . <collections>)
  61.   (let ( (max+1 (yasos:size (car <collections>)))
  62.          (generators (map collect:gen-keys <collections>))
  63.        )
  64.     (let loop ( (counter 0) )
  65.        (cond
  66.           ((< counter max+1)
  67.            (apply <proc> (map (lambda (g) (g)) generators))
  68.            (loop (collect:add1 counter))
  69.           )
  70.           (else 'unspecific)  ; done
  71.     )  )
  72. ) )
  73.  
  74. (define (collect:MAP-ELTS <proc> . <collections>)
  75.   (let ( (max+1 (yasos:size (car <collections>)))
  76.          (generators (map collect:gen-elts <collections>))
  77.          (vec (make-vector (yasos:size (car <collections>))))
  78.        )
  79.     (let loop ( (index 0) )
  80.        (cond
  81.           ((< index max+1)
  82.            (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
  83.            (loop (collect:add1 index))
  84.           )
  85.           (else vec)  ; done
  86.     )  )
  87. ) )
  88.  
  89. (define (COLLECT:MAP-KEYS <proc> . <collections>)
  90.   (let ( (max+1 (yasos:size (car <collections>)))
  91.          (generators (map collect:gen-keys <collections>))
  92.      (vec (make-vector (yasos:size (car <collections>))))
  93.        )
  94.     (let loop ( (index 0) )
  95.        (cond
  96.           ((< index max+1)
  97.            (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
  98.            (loop (collect:add1 index))
  99.           )
  100.           (else vec)  ; done
  101.     )  )
  102. ) )
  103.  
  104. (define-operation (COLLECT:FOR-EACH-KEY <collection> <proc>)
  105.    ;; default
  106.    (collect:do-keys <proc> <collection>)  ;; talk about lazy!
  107. )
  108.  
  109. (define-operation (COLLECT:FOR-EACH-ELT <collection> <proc>)
  110.    (collect:do-elts <proc> <collection>)
  111. )
  112.  
  113. (define (COLLECT:REDUCE <proc> <seed> . <collections>)
  114.    (let ( (max+1 (yasos:size (car <collections>)))
  115.           (generators (map collect:gen-elts <collections>))
  116.         )
  117.      (let loop ( (count 0) )
  118.        (cond
  119.           ((< count max+1)
  120.            (set! <seed> 
  121.                  (apply <proc> <seed> (map (lambda (g) (g)) generators)))
  122.            (loop (collect:add1 count))
  123.           )
  124.           (else <seed>)
  125.      ) )
  126. )  )
  127.  
  128.  
  129.  
  130. ;; pred true for every elt?
  131. (define (COLLECT:EVERY? <pred?> . <collections>)
  132.    (let ( (max+1 (yasos:size (car <collections>)))
  133.           (generators (map collect:gen-elts <collections>))
  134.         )
  135.      (let loop ( (count 0) )
  136.        (cond
  137.           ((< count max+1)
  138.            (if (apply <pred?> (map (lambda (g) (g)) generators))
  139.                (loop (collect:add1 count))
  140.                #f)
  141.           )
  142.           (else #t)
  143.      ) )
  144. )  )
  145.  
  146. ;; pred true for any elt?
  147. (define (COLLECT:ANY? <pred?> . <collections>)
  148.    (let ( (max+1 (yasos:size (car <collections>)))
  149.           (generators (map collect:gen-elts <collections>))
  150.         )
  151.      (let loop ( (count 0) )
  152.        (cond
  153.           ((< count max+1)
  154.            (if (apply <pred?> (map (lambda (g) (g)) generators))
  155.                #t
  156.                (loop (collect:add1 count))
  157.           ))
  158.           (else #f)
  159.      ) )
  160. )  )
  161.  
  162.  
  163. ;; MISC UTILITIES
  164.  
  165. (define (COLLECT:ADD1 obj)  (+ obj 1))
  166. (define (COLLECT:SUB1 obj)  (- obj 1))
  167.  
  168. ;; Nota Bene:  list-set! is bogus for element 0
  169.  
  170. (define (COLLECT:LIST-SET! <list> <index> <value>)
  171.  
  172.   (define (set-loop last this idx)
  173.      (cond
  174.         ((zero? idx) 
  175.          (set-cdr! last (cons <value> (cdr this)))
  176.          <list>
  177.         )
  178.         (else (set-loop (cdr last) (cdr this) (collect:sub1 idx)))
  179.   )  )
  180.  
  181.   ;; main
  182.   (if (zero? <index>)
  183.       (cons <value> (cdr <list>))  ;; return value
  184.       (set-loop <list> (cdr <list>) (collect:sub1 <index>)))
  185. )
  186.  
  187. (ADD-SETTER list-ref collect:list-set!)  ; for (setter list-ref)
  188.  
  189.  
  190. ;; generator for list elements
  191. (define (COLLECT:LIST-GEN-ELTS <list>)
  192.   (lambda ()
  193.      (if (null? <list>)
  194.          (slib:error "No more list elements in generator")
  195.          (let ( (elt (car <list>)) )
  196.            (set! <list> (cdr <list>))
  197.            elt))
  198. ) )
  199.  
  200. ;; generator for vector elements
  201. (define (COLLECT:MAKE-VEC-GEN-ELTS <accessor>)
  202.   (lambda (vec)
  203.     (let ( (max+1 (yasos:size vec))
  204.            (index 0)
  205.          )
  206.       (lambda () 
  207.          (cond ((< index max+1)
  208.                 (set! index (collect:add1 index))
  209.                 (<accessor> vec (collect:sub1 index))
  210.                )
  211.                (else #f)
  212.       )  )
  213.   ) )
  214. )
  215.  
  216. (define COLLECT:VECTOR-GEN-ELTS (collect:make-vec-gen-elts vector-ref))
  217.  
  218. (define COLLECT:STRING-GEN-ELTS (collect:make-vec-gen-elts string-ref))
  219.  
  220. ;;; exports:
  221.  
  222. (define COLLECTION? collect:collection?)
  223. (define EMPTY? collect:empty?)
  224. (define gen-keys collect:gen-keys)
  225. (define gen-elts collect:gen-elts)
  226. (define do-elts collect:do-elts)
  227. (define do-keys collect:do-keys)
  228. (define map-elts collect:map-elts)
  229. (define map-keys collect:map-keys)
  230. (define for-each-key collect:for-each-key)
  231. (define for-each-elt collect:for-each-elt)
  232. (define reduce collect:reduce)        ; reduce is also in comlist.scm
  233. (define every? collect:every?)
  234. (define any? collect:any?)
  235.  
  236. ;;                        --- E O F "collect.oo" ---                    ;;
  237.