[cells-cvs] CVS cells/utils-kt

[ktilton]

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

Modified Files:
	debug.lisp detritus.lisp flow-control.lisp utils-kt.lpr 
Log Message:
Some interesting changes

--- /project/cells/cvsroot/cells/utils-kt/debug.lisp	2006/10/02 02:38:32	1.13
+++ /project/cells/cvsroot/cells/utils-kt/debug.lisp	2007/01/29 06:44:04	1.14
@@ -30,6 +30,7 @@
   (setf *count* nil
     *stop* nil
     *dbg* nil)
+  
  (print "----------UTILSRESET----------------------------------"))
 
 
@@ -93,9 +94,10 @@
 
 (defmacro timex ((onp &rest trcargs) &body body)
   `(if ,onp
-       (prog1
+       (prog2
+           (format t "~&Starting timing run of ~{ ~a~}" (list , at trcargs))
            (time (progn , at body))
-         (format t "timing was of ~{ ~a~}" , at trcargs))
+         (format t "~&Above timing was of ~{ ~a~}" (list , at trcargs)))
      (progn , at body)))
 
 #+save
--- /project/cells/cvsroot/cells/utils-kt/detritus.lisp	2006/12/12 15:58:43	1.12
+++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp	2007/01/29 06:44:04	1.13
@@ -170,16 +170,15 @@
   (typecase tree
     (null)
     (atom (funcall test sought tree))
-    (cons (loop for subtree in tree
-                when (tree-includes sought subtree :test test)
-                do (return-from tree-includes t)))))
+    (cons (or (tree-includes sought (car tree) :test test)
+            (tree-includes sought (cdr tree) :test test)))))
 
 (defun tree-traverse (tree fn)
   (typecase tree
     (null)
     (atom (funcall fn tree))
-    (cons (loop for subtree in tree
-                do (tree-traverse subtree fn))))
+    (cons (tree-traverse (car tree) fn)
+      (tree-traverse (cdr tree) fn)))
   (values))
 
 (defun tree-intersect (t1 t2 &key (test 'eql))
--- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp	2006/12/12 15:58:43	1.9
+++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp	2007/01/29 06:44:04	1.10
@@ -31,7 +31,7 @@
 (defun min-if (v1 v2)
      (if v1 (if v2 (min v1 v2) v1) v2))
 
-(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p)
+(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p pair-off)
 
 (defun list-flatten! (&rest list)
   (if (consp list)
@@ -59,6 +59,17 @@
 (defun tree-flatten (tree)
   (list-flatten! (copy-tree tree)))
 
+(defun pair-off (list &optional (test 'eql))
+  (loop with pairs and copy = (copy-list list)
+      while (cdr copy)
+      do (let ((pair (find (car copy) (cdr copy) :test test)))
+           (if pair
+               (progn
+                 (push-end (cons (car copy) pair) pairs)
+                 (setf copy (delete pair (cdr copy) :count 1)))
+             (setf copy (cdr copy))))
+      finally (return pairs)))
+
 (defun packed-flat! (&rest u-nameit)
   (delete nil (list-flatten! u-nameit)))
 
@@ -173,6 +184,7 @@
 
 (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)
--- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/12/12 15:58:43	1.21
+++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2007/01/29 06:44:04	1.22
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
 
 (in-package :cg-user)