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 ,@trcargs)) (time (progn ,@body)) - (format t "timing was of ~{ ~a~}" ,@trcargs)) + (format t "~&Above timing was of ~{ ~a~}" (list ,@trcargs))) (progn ,@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)