[cells-cvs] CVS cells/utils-kt

[ktilton]

Update of /project/cells/cvsroot/cells/utils-kt
In directory clnet:/tmp/cvs-serv9859/utils-kt

Modified Files:
	detritus.lisp flow-control.lisp utils-kt.lpr 
Log Message:


--- /project/cells/cvsroot/cells/utils-kt/detritus.lisp	2006/10/11 22:16:22	1.11
+++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp	2006/12/12 15:58:43	1.12
@@ -20,12 +20,15 @@
 (in-package :utils-kt)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(eval-now! export!)))
+  (export '(eval-now! export! assocd rassoca)))
 
 (defmacro wdbg (&body body)
   `(let ((*dbg* t))
      , at body))
 
+(defun assocd (x y) (cdr (assoc x y)))
+(defun rassoca (x y) (car (assoc x y)))
+
 ;;;(defmethod class-slot-named ((classname symbol) slotname)
 ;;;  (class-slot-named (find-class classname) slotname))
 ;;;
--- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp	2006/11/04 20:52:02	1.8
+++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp	2006/12/12 15:58:43	1.9
@@ -149,3 +149,33 @@
 (defmethod instance-slots (self)
   (class-slots (class-of self))) ;; acl has this for structs
 
+;;; ---- without-repeating ----------------------------------------------
+
+;; Returns a function that generates an elements from ALL each time it
+;; is called. When a certain element is generated it will take at
+;; least DECENT-INTERVAL calls before it is generated again.  
+;;
+;; note: order of ALL is important for first few calls, could be fixed
+
+(defun without-repeating-generator (decent-interval all)
+  (let ((len (length all))
+        (head (let ((v (copy-list all)))
+                (nconc v v))))
+    (lambda ()
+      (if (< len 2)
+          (car all)
+        (prog2
+          (rotatef (car head)
+            (car (nthcdr (random (- len decent-interval))
+                   head)))
+            (car head)
+          (setf head (cdr head)))))))
+
+(export! without-repeating)
+
+(let ((generators (make-hash-table :test 'equalp)))
+  (defun without-repeating (key all &optional (decent-interval (floor (length all) 2)))
+    (funcall (or (gethash key generators)
+               (setf (gethash key generators)
+                 (without-repeating-generator decent-interval all))))))
+
--- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/11/13 05:28:09	1.20
+++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/12/12 15:58:43	1.21
@@ -15,7 +15,8 @@
                  (make-instance 'module :name "flow-control.lisp")
                  (make-instance 'module :name "detritus.lisp")
                  (make-instance 'module :name "strings.lisp")
-                 (make-instance 'module :name "datetime.lisp"))
+                 (make-instance 'module :name "datetime.lisp")
+                 (make-instance 'module :name "split-sequence.lisp"))
   :projects nil
   :libraries nil
   :distributed-files nil