Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv8605/utils-kt
Modified Files: debug.lisp detritus.lisp flow-control.lisp quad.lisp utils-kt.lpr Log Message: Mostly differentiating new *depender* from CAR of *call-stack* so we can clear former to get without-c-dependency behavior without clearing *call-stack*, in turn to detect cyclic calculation even if doing a without-c-dependency.
--- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/02/16 09:34:29 1.18 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/03/15 15:18:34 1.19 @@ -56,7 +56,7 @@ (defmacro count-it (&rest keys) (declare (ignorable keys)) #+(or) `(progn) - `(when *counting* + `(when (car *counting*) (call-count-it ,@keys)))
(defun call-count-it (&rest keys) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/02/16 05:04:56 1.19 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/03/15 15:18:34 1.20 @@ -188,21 +188,11 @@ (char= #; (schar trim 0))))) count 1)))
-#+save -(defun source-line-count (path) - (with-open-file (s path) - (loop with lines = 0 - for c = (read-char s nil nil) - while c - when (find c '(#\newline #\return)) - do (incf lines) - finally (return lines)))) - #+(or) (line-count (make-pathname :device "c" - :directory `(:absolute "0Algebra" "Cells")) - nil 1 t) + :directory `(:absolute "ALGCOUNT" )) + nil 5 t)
#+(or) (loop for d1 in '("cl-s3" "kpax" "puri-1.5.1" "s-base64" "s-http-client" "s-http-server" "s-sysdeps" "s-utils" "s-xml") --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/01/29 04:29:55 1.12 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/03/15 15:18:34 1.13 @@ -113,6 +113,11 @@ `(let ((,bindvar ,boundform)) (when ,bindvar ,@body))) + +(defmacro b-when (bindvar boundform &body body) + `(let ((,bindvar ,boundform)) + (when ,bindvar + ,@body)))
(defmacro bif ((bindvar boundform) yup &optional nope) `(let ((,bindvar ,boundform)) @@ -120,11 +125,17 @@ ,yup ,nope)))
+(defmacro b-if (bindvar boundform yup &optional nope) + `(let ((,bindvar ,boundform)) + (if ,bindvar + ,yup + ,nope))) + (defmacro maptimes ((nvar count) &body body) `(loop for ,nvar below ,count collecting (progn ,@body)))
-(export! maphash* hashtable-assoc -1?1 -1?1 prime?) +(export! maphash* hashtable-assoc -1?1 -1?1 prime? b-if b-when)
(defun maphash* (f h) (loop for k being the hash-keys of h @@ -195,7 +206,7 @@
(defun without-repeating-generator (decent-interval all) (let ((len (length all)) - (head (let ((v (copy-list all))) + (head (let ((v (shuffle all))) (nconc v v)))) (lambda () (if (< len 2) @@ -207,7 +218,16 @@ (car head) (setf head (cdr head)))))))
-(export! without-repeating) +(defun shuffle (list &key (test 'identity)) + (if (cdr list) + (loop thereis + (funcall test + (mapcar 'cdr + (sort (loop for e in list collecting (cons (random most-positive-fixnum) e)) + '< :key 'car)))) + (copy-list list))) + +(export! without-repeating shuffle)
(let ((generators (make-hash-table :test 'equalp))) (defun reset-without-repeating () --- /project/cells/cvsroot/cells/utils-kt/quad.lisp 2007/12/03 20:11:12 1.3 +++ /project/cells/cvsroot/cells/utils-kt/quad.lisp 2008/03/15 15:18:34 1.4 @@ -86,41 +86,114 @@
|#
-(in-package :cells) +(in-package :ukt)
;;;(defstruct (juad jar jbr jcr jdr)
(defun qar (q) (car q)) +(defun (setf qar) (v q) (setf (car q) v)) + (defun qbr (q) (cadr q)) +(defun (setf qbr) (v q) (setf (cadr q) v)) + (defun qcr (q) (caddr q)) +(defun (setf qcr) (v q) (setf (caddr q) v)) + (defun qdr (q) (cdddr q)) +(defun (setf qdr) (v q) (setf (cdddr q) v)) + +(defun sub-quads (q) + (loop for childq on (qcr q) by #'qdr + collecting childq)) + +(defun sub-quads-do (q fn) + (loop for childq on (qcr q) by #'qdr + do (funcall fn childq)))
(defun quad-traverse (q fn &optional (depth 0)) (funcall fn q depth) - (loop for childq on (qcr q) by #'qdr - do (quad-traverse childq fn (1+ depth)))) + (sub-quads-do q + (lambda (subq) + (quad-traverse subq fn (1+ depth)))))
(defun quad (operator parent contents next) (list operator parent contents next))
+(defun quad* (operator parent contents next) + (list operator parent contents next)) + (defun qups (q) (loop for up = (qbr q) then (qbr up) unless up do (loop-finish) collecting up))
+(defun quad-tree (q) + (list* (qar q) + (loop for childq on (qcr q) by #'qdr + while childq + collecting (quad-tree childq)))) + +(defun tree-quad (tree &optional parent) + (let* ((q (quad (car tree) parent nil nil)) + (kids (loop for k in (cdr tree) + collecting (tree-quad k q)))) + (loop for (k n) on kids + do (setf (qdr k) n)) + (setf (qcr q) (car kids)) + q)) + +#+test +(test-qt) + +(defun test-qt () + (print (quad-tree #1='(zot nil (foo #1# ("123" "abc") + . #2=(bar #1# (ding #2# "456" + dong #2# "789"))))))) + +(print #1='(zot nil (foo #1# ("123" "abc") + . #2=(bar #1# (ding #2# "456" + dong #2# "789"))))) +#+xxxx +(test-tq) + +(defun test-tq () + (let ((*print-circle* t) + (tree '(zot (foo ("123")) (bar (ding) (dong))))) + (assert (equal tree (quad-tree (tree-quad tree)))))) + (defun testq () (let ((*print-circle* t)) - (let ((q #1='(zot nil (foo #1# "123" + (let ((q #1='(zot nil (foo #1# ("123" "abc") . #2=(bar #1# (ding #2# "456" dong #2# "789")))))) + (print '(traverse showing each type and data preceded by its depth)) + (quad-traverse q (lambda (q depth) - (print (list depth (qar q)))))) + (print (list depth (qar q)(qcr q))))) + (print `(listify same ,(quad-tree q)))) (let ((q #2='(zot nil (ding #2# "456" dong #2# "789")))) + (print '(traverse showing each "car" and itd parentage preceded by its depth)) + (print '(of data (zot (ding (dong))))) (quad-traverse q (lambda (q depth) (print (list depth (qar q) (mapcar 'qar (qups q))))))))) + +;;;(defun tree-quad (tree) + + +(defun testq2 () + (let ((*print-circle* t)) + (let ((q #2='(zot nil (ding #2# "456" + dong #2# "789")))) + (print '(traverse showing each "car" and itd parentage preceded by its depth)) + (print '(of data (zot (ding (dong))))) + (quad-traverse q (lambda (q depth) + (print (list depth (qar q) + (mapcar 'qar (qups q))))))))) + +
\ No newline at end of file --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2007/11/30 16:51:20 1.23 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2008/03/15 15:18:34 1.24 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)