[cells-cvs] CVS cells/utils-kt
ktilton
ktilton at common-lisp.net
Sat Mar 15 15:18:34 UTC 2008
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 , at 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
, at body)))
+
+(defmacro b-when (bindvar boundform &body body)
+ `(let ((,bindvar ,boundform))
+ (when ,bindvar
+ , at 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 , at 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)
More information about the Cells-cvs
mailing list