summaryrefslogtreecommitdiffstats
path: root/collectx.scm
diff options
context:
space:
mode:
authorSteve Langasek <vorlon@debian.org>2005-01-10 08:53:33 +0000
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:30 -0800
commite33f9eb9cf5cc29c36ce2aa7e10cd0f37ae0cc8e (patch)
treeabbf06041619e445f9d0b772b0d58132009d8234 /collectx.scm
parentf559c149c83da84d0b1c285f0298c84aec564af9 (diff)
parent8466d8cfa486fb30d1755c4261b781135083787b (diff)
downloadslib-e33f9eb9cf5cc29c36ce2aa7e10cd0f37ae0cc8e.tar.gz
slib-e33f9eb9cf5cc29c36ce2aa7e10cd0f37ae0cc8e.zip
Import Debian changes 3a1-4.2debian/3a1-4.2
slib (3a1-4.2) unstable; urgency=low * Non-maintainer upload. * Add guile.init.local for use within the build dir, since otherwise we have an (earlier unnoticed) circular build-dep due to a difference between scm and guile. slib (3a1-4.1) unstable; urgency=low * Non-maintainer upload. * Build-depend on guile-1.6 instead of scm, since the new version of scm is wedged in unstable (closes: #281809). slib (3a1-4) unstable; urgency=low * Also check for expected creation on slibcat. (Closes: #240096) slib (3a1-3) unstable; urgency=low * Also check for /usr/share/guile/1.6/slib before installing for guile 1.6. (Closes: #239267) slib (3a1-2) unstable; urgency=low * Add format.scm back into slib until gnucash stops using it. * Call guile-1.6 new-catalog (Closes: #238231) slib (3a1-1) unstable; urgency=low * New upstream release * Remove Info section from doc-base file (Closes: #186950) * Remove period from end of description (linda, lintian) * html gen fixed upstream (Closes: #111778) slib (2d4-2) unstable; urgency=low * Fix url for upstream source (Closes: #144981) * Fix typo in slib.texi (enquque->enqueue) (Closes: #147475) * Add build depends. slib (2d4-1) unstable; urgency=low * New upstream. slib (2d3-1) unstable; urgency=low * New upstream. * Remove texi2html call in debian/rules. Now done upstream. Add make html instead. * Changes to rules and doc-base to conform to upstream html gen * Clean up upstream makefile to make sure it cleans up after itself.
Diffstat (limited to 'collectx.scm')
-rw-r--r--collectx.scm247
1 files changed, 247 insertions, 0 deletions
diff --git a/collectx.scm b/collectx.scm
new file mode 100644
index 0000000..7ba46b9
--- /dev/null
+++ b/collectx.scm
@@ -0,0 +1,247 @@
+;"collect.scm" Sample collection operations
+; COPYRIGHT (c) Kenneth Dickey 1992
+;
+; This software may be used for any purpose whatever
+; without warranty 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 'object)
+(require 'yasos)
+
+(define collect:size size)
+(define collect:print print)
+
+;@
+(define collection?
+ (make-generic-method
+ (lambda (obj!2)
+ (cond ((or (list? obj!2)
+ (vector? obj!2)
+ (string? obj!2))
+ #t)
+ (else #f)))))
+;@
+(define empty?
+ (lambda (collection!1)
+ (zero? (collect:size collection!1))))
+;@
+(define gen-elts
+ (make-generic-method
+ (lambda (<collection>!2)
+ (cond ((vector? <collection>!2)
+ (collect:vector-gen-elts <collection>!2))
+ ((list? <collection>!2)
+ (collect:list-gen-elts <collection>!2))
+ ((string? <collection>!2)
+ (collect:string-gen-elts <collection>!2))
+ (else
+ (slib:error
+ 'gen-elts
+ 'operation-not-supported
+ (collect:print <collection>!2 #f)))))))
+;@
+(define gen-keys
+ (make-generic-method
+ (lambda (collection!2)
+ (if (or (vector? collection!2)
+ (list? collection!2)
+ (string? collection!2))
+ (let ((max+1!3 (collect:size collection!2))
+ (index!3 0))
+ (lambda ()
+ (cond ((< index!3 max+1!3)
+ (set! index!3 (collect:add1 index!3))
+ (collect:sub1 index!3))
+ (else (slib:error 'no-more 'keys 'in 'generator)))))
+ (slib:error
+ 'gen-keys
+ 'operation-not-handled
+ collection!2)))))
+;@
+(define do-elts
+ (lambda (<proc>!1 . <collections>!1)
+ (let ((max+1!2 (collect:size (car <collections>!1)))
+ (generators!2
+ (map collect:gen-elts <collections>!1)))
+ (let loop!4 ((counter!3 0))
+ (cond ((< counter!3 max+1!2)
+ (apply <proc>!1
+ (map (lambda (g!5) (g!5)) generators!2))
+ (loop!4 (collect:add1 counter!3)))
+ (else 'unspecific))))))
+;@
+(define do-keys
+ (lambda (<proc>!1 . <collections>!1)
+ (let ((max+1!2 (collect:size (car <collections>!1)))
+ (generators!2
+ (map collect:gen-keys <collections>!1)))
+ (let loop!4 ((counter!3 0))
+ (cond ((< counter!3 max+1!2)
+ (apply <proc>!1
+ (map (lambda (g!5) (g!5)) generators!2))
+ (loop!4 (collect:add1 counter!3)))
+ (else 'unspecific))))))
+;@
+(define map-elts
+ (lambda (<proc>!1 . <collections>!1)
+ (let ((max+1!2 (collect:size (car <collections>!1)))
+ (generators!2
+ (map collect:gen-elts <collections>!1))
+ (vec!2 (make-vector
+ (collect:size (car <collections>!1)))))
+ (let loop!4 ((index!3 0))
+ (cond ((< index!3 max+1!2)
+ (vector-set!
+ vec!2
+ index!3
+ (apply <proc>!1
+ (map (lambda (g!5) (g!5)) generators!2)))
+ (loop!4 (collect:add1 index!3)))
+ (else vec!2))))))
+;@
+(define map-keys
+ (lambda (<proc>!1 . <collections>!1)
+ (let ((max+1!2 (collect:size (car <collections>!1)))
+ (generators!2
+ (map collect:gen-keys <collections>!1))
+ (vec!2 (make-vector
+ (collect:size (car <collections>!1)))))
+ (let loop!4 ((index!3 0))
+ (cond ((< index!3 max+1!2)
+ (vector-set!
+ vec!2
+ index!3
+ (apply <proc>!1
+ (map (lambda (g!5) (g!5)) generators!2)))
+ (loop!4 (collect:add1 index!3)))
+ (else vec!2))))))
+;@
+(define for-each-key
+ (make-generic-method
+ (lambda (<collection>!2 <proc>!2)
+ (collect:do-keys <proc>!2 <collection>!2))))
+;@
+(define for-each-elt
+ (make-generic-method
+ (lambda (<collection>!2 <proc>!2)
+ (collect:do-elts <proc>!2 <collection>!2))))
+;@
+(define reduce
+ (lambda (<proc>!1 <seed>!1 . <collections>!1)
+ (let ((max+1!2 (collect:size (car <collections>!1)))
+ (generators!2
+ (map collect:gen-elts <collections>!1)))
+ (let loop!4 ((count!3 0))
+ (cond ((< count!3 max+1!2)
+ (set! <seed>!1
+ (apply <proc>!1
+ <seed>!1
+ (map (lambda (g!5) (g!5)) generators!2)))
+ (loop!4 (collect:add1 count!3)))
+ (else <seed>!1))))))
+
+
+
+;;@ pred true for every elt?
+(define every?
+ (lambda (<pred?>!1 . <collections>!1)
+ (let ((max+1!2 (collect:size (car <collections>!1)))
+ (generators!2
+ (map collect:gen-elts <collections>!1)))
+ (let loop!4 ((count!3 0))
+ (cond ((< count!3 max+1!2)
+ (if (apply <pred?>!1
+ (map (lambda (g!5) (g!5)) generators!2))
+ (loop!4 (collect:add1 count!3))
+ #f))
+ (else #t))))))
+
+;;@ pred true for any elt?
+(define any?
+ (lambda (<pred?>!1 . <collections>!1)
+ (let ((max+1!2 (collect:size (car <collections>!1)))
+ (generators!2
+ (map collect:gen-elts <collections>!1)))
+ (let loop!4 ((count!3 0))
+ (cond ((< count!3 max+1!2)
+ (if (apply <pred?>!1
+ (map (lambda (g!5) (g!5)) generators!2))
+ #t
+ (loop!4 (collect:add1 count!3))))
+ (else #f))))))
+
+
+;; MISC UTILITIES
+
+(define collect:add1
+ (lambda (obj!1) (+ obj!1 1)))
+(define collect:sub1
+ (lambda (obj!1) (- obj!1 1)))
+
+;; Nota Bene: list-set! is bogus for element 0
+
+(define collect:list-set!
+ (lambda (<list>!1 <index>!1 <value>!1)
+ (letrec ((set-loop!3
+ (lambda (last!4 this!4 idx!4)
+ (cond ((zero? idx!4)
+ (set-cdr! last!4 (cons <value>!1 (cdr this!4)))
+ <list>!1)
+ (else
+ (set-loop!3
+ (cdr last!4)
+ (cdr this!4)
+ (collect:sub1 idx!4)))))))
+ (if (zero? <index>!1)
+ (cons <value>!1 (cdr <list>!1))
+ (set-loop!3
+ <list>!1
+ (cdr <list>!1)
+ (collect:sub1 <index>!1))))))
+
+(add-setter list-ref collect:list-set!)
+ ; for (setter list-ref)
+
+
+;; generator for list elements
+(define collect:list-gen-elts
+ (lambda (<list>!1)
+ (lambda ()
+ (if (null? <list>!1)
+ (slib:error
+ 'no-more
+ 'list-elements
+ 'in
+ 'generator)
+ (let ((elt!3 (car <list>!1)))
+ (begin (set! <list>!1 (cdr <list>!1)) elt!3))))))
+
+;; generator for vector elements
+(define collect:make-vec-gen-elts
+ (lambda (<accessor>!1)
+ (lambda (vec!2)
+ (let ((max+1!3 (collect:size vec!2)) (index!3 0))
+ (lambda ()
+ (cond ((< index!3 max+1!3)
+ (set! index!3 (collect:add1 index!3))
+ (<accessor>!1 vec!2 (collect:sub1 index!3)))
+ (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 collect:gen-keys gen-keys)
+(define collect:gen-elts gen-elts)
+(define collect:do-elts do-elts)
+(define collect:do-keys do-keys)
+
+;; --- E O F "collect.oo" --- ;;