summaryrefslogtreecommitdiffstats
path: root/collect.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963 /collect.scm
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'collect.scm')
-rw-r--r--collect.scm236
1 files changed, 236 insertions, 0 deletions
diff --git a/collect.scm b/collect.scm
new file mode 100644
index 0000000..abdf209
--- /dev/null
+++ b/collect.scm
@@ -0,0 +1,236 @@
+;"collect.scm" Sample collection operations
+; COPYRIGHT (c) Kenneth Dickey 1992
+;
+; This software may be used for any purpose whatever
+; without warrantee of any kind.
+; 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)
+
+(define-operation (collect:collection? obj)
+ ;; default
+ (cond
+ ((or (list? obj) (vector? obj) (string? obj)) #t)
+ (else #f)
+) )
+
+(define (collect:empty? collection) (zero? (yasos:size collection)))
+
+(define-operation (collect:gen-elts <collection>) ;; return element generator
+ ;; default behavior
+ (cond ;; see utilities, below, for generators
+ ((vector? <collection>) (collect:vector-gen-elts <collection>))
+ ((list? <collection>) (collect:list-gen-elts <collection>))
+ ((string? <collection>) (collect:string-gen-elts <collection>))
+ (else
+ (slib:error "Operation not supported: GEN-ELTS " (yasos:print obj #f)))
+) )
+
+(define-operation (collect:gen-keys collection)
+ (if (or (vector? collection) (list? collection) (string? collection))
+ (let ( (max+1 (yasos:size collection)) (index 0) )
+ (lambda ()
+ (cond
+ ((< index max+1)
+ (set! index (collect:add1 index))
+ (collect:sub1 index))
+ (else (slib:error "no more keys in generator"))
+ ) ) )
+ (slib:error "Operation not handled: GEN-KEYS " collection)
+) )
+
+(define (collect:do-elts <proc> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-elts <collections>))
+ )
+ (let loop ( (counter 0) )
+ (cond
+ ((< counter max+1)
+ (apply <proc> (map (lambda (g) (g)) generators))
+ (loop (collect:add1 counter))
+ )
+ (else 'unspecific) ; done
+ ) )
+) )
+
+(define (collect:do-keys <proc> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-keys <collections>))
+ )
+ (let loop ( (counter 0) )
+ (cond
+ ((< counter max+1)
+ (apply <proc> (map (lambda (g) (g)) generators))
+ (loop (collect:add1 counter))
+ )
+ (else 'unspecific) ; done
+ ) )
+) )
+
+(define (collect:map-elts <proc> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-elts <collections>))
+ (vec (make-vector (yasos:size (car <collections>))))
+ )
+ (let loop ( (index 0) )
+ (cond
+ ((< index max+1)
+ (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
+ (loop (collect:add1 index))
+ )
+ (else vec) ; done
+ ) )
+) )
+
+(define (collect:map-keys <proc> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-keys <collections>))
+ (vec (make-vector (yasos:size (car <collections>))))
+ )
+ (let loop ( (index 0) )
+ (cond
+ ((< index max+1)
+ (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
+ (loop (collect:add1 index))
+ )
+ (else vec) ; done
+ ) )
+) )
+
+(define-operation (collect:for-each-key <collection> <proc>)
+ ;; default
+ (collect:do-keys <proc> <collection>) ;; talk about lazy!
+)
+
+(define-operation (collect:for-each-elt <collection> <proc>)
+ (collect:do-elts <proc> <collection>)
+)
+
+(define (collect:reduce <proc> <seed> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-elts <collections>))
+ )
+ (let loop ( (count 0) )
+ (cond
+ ((< count max+1)
+ (set! <seed>
+ (apply <proc> <seed> (map (lambda (g) (g)) generators)))
+ (loop (collect:add1 count))
+ )
+ (else <seed>)
+ ) )
+) )
+
+
+
+;; pred true for every elt?
+(define (collect:every? <pred?> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-elts <collections>))
+ )
+ (let loop ( (count 0) )
+ (cond
+ ((< count max+1)
+ (if (apply <pred?> (map (lambda (g) (g)) generators))
+ (loop (collect:add1 count))
+ #f)
+ )
+ (else #t)
+ ) )
+) )
+
+;; pred true for any elt?
+(define (collect:any? <pred?> . <collections>)
+ (let ( (max+1 (yasos:size (car <collections>)))
+ (generators (map collect:gen-elts <collections>))
+ )
+ (let loop ( (count 0) )
+ (cond
+ ((< count max+1)
+ (if (apply <pred?> (map (lambda (g) (g)) generators))
+ #t
+ (loop (collect:add1 count))
+ ))
+ (else #f)
+ ) )
+) )
+
+
+;; MISC UTILITIES
+
+(define (collect:add1 obj) (+ obj 1))
+(define (collect:sub1 obj) (- obj 1))
+
+;; Nota Bene: list-set! is bogus for element 0
+
+(define (collect: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) (collect:sub1 idx)))
+ ) )
+
+ ;; main
+ (if (zero? <index>)
+ (cons <value> (cdr <list>)) ;; return value
+ (set-loop <list> (cdr <list>) (collect:sub1 <index>)))
+)
+
+(add-setter list-ref collect:list-set!) ; for (setter list-ref)
+
+
+;; generator for list elements
+(define (collect:list-gen-elts <list>)
+ (lambda ()
+ (if (null? <list>)
+ (slib:error "No more list elements in generator")
+ (let ( (elt (car <list>)) )
+ (set! <list> (cdr <list>))
+ elt))
+) )
+
+;; generator for vector elements
+(define (collect:make-vec-gen-elts <accessor>)
+ (lambda (vec)
+ (let ( (max+1 (yasos:size vec))
+ (index 0)
+ )
+ (lambda ()
+ (cond ((< index max+1)
+ (set! index (collect:add1 index))
+ (<accessor> vec (collect:sub1 index))
+ )
+ (else #f)
+ ) )
+ ) )
+)
+
+(define collect:vector-gen-elts (collect:make-vec-gen-elts vector-ref))
+
+(define collect:string-gen-elts (collect:make-vec-gen-elts string-ref))
+
+;;; exports:
+
+(define collection? collect:collection?)
+(define empty? collect:empty?)
+(define gen-keys collect:gen-keys)
+(define gen-elts collect:gen-elts)
+(define do-elts collect:do-elts)
+(define do-keys collect:do-keys)
+(define map-elts collect:map-elts)
+(define map-keys collect:map-keys)
+(define for-each-key collect:for-each-key)
+(define for-each-elt collect:for-each-elt)
+(define reduce collect:reduce) ; reduce is also in comlist.scm
+(define every? collect:every?)
+(define any? collect:any?)
+
+;; --- E O F "collect.oo" --- ;;