@@ -13,8 +13,8 @@ For example, in a text editor application we might have (condensed): (make-instance 'menu-item :label "Cut" :enabled (c? (bwhen (f (focus *window*)) - (and (typep focus 'text-widget) - (selection-range focus))))) + (and (typep f 'text-widget) + (selection-range f))))) Translated, the enabled state of the Cut menu item follows whether or not the user is focused on a text-edit widget and @@ -102,7 +102,9 @@ way around it, and thus his prediction that a software silver bullet was in principle impossible. Which brings us to Cells. See also [axiom] Phillip Eby's developing axiomatic -definition he is developing in support of Ryan Forseth's SoC project. +definition he is developing in support of Ryan Forseth's SoC project. Mr. Eby was +inspired by his involvement to develop Trellis, his own Cells work-alike library +for Python. DEFMODEL and Slot types ----------------------- @@ -351,6 +353,9 @@ PhD Thesis in which he develops a constraint programming language or two: http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM http://www.cs.utk.edu/~bvz/quickplan.html +Flow-based programming, developed by J. Paul Morrison at IBM, 1971. + http://en.wikipedia.org/wiki/Flow-based_programming + Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963. Steele himself cites Sketchpad as inexplicably unappreciated prior art to his Constraints system: cells-manifesto.txt @@ -150,30 +150,31 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be. (break "~&i say, unhandled <c-enabling>: ~s" condition)))) (define-condition c-fatal (xcell) - ((name :initarg :name :reader name) - (model :initarg :model :reader model) - (cell :initarg :cell :reader cell)) + ((name :initform :anon :initarg :name :reader name) + (model :initform nil :initarg :model :reader model) + (cell :initform nil :initarg :cell :reader cell)) (:report (lambda (condition stream) (format stream "~&fatal cell programming error: ~s" condition) (format stream "~& : ~s" (name condition)) (format stream "~& : ~s" (model condition)) (format stream "~& : ~s" (cell condition))))) -(define-condition c-unadopted (c-fatal) - () + +(define-condition asker-midst-askers (c-fatal) + ()) +;; "see listener for cell rule cycle diagnotics" + +(define-condition c-unadopted (c-fatal) () (:report (lambda (condition stream) (format stream "~&unadopted cell >: ~s" (cell condition)) (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error")))) - (defun c-break (&rest args) (unless *stop* (let ((*print-level* 5) (*print-circle* t) (args2 (mapcar 'princ-to-string args))) - (c-stop args) - - (format t "~&c-break > stopping > ~{~a ~}" args2) - (print `(c-break-args ,@args2)) + (c-stop :c-break) + ;(format t "~&c-break > stopping > ~{~a ~}" args2) (apply 'error args2)))) \ No newline at end of file cells.lisp @@ -185,6 +185,8 @@ the defmodel form for ~a" ',class ',class)))) (list* `(:default-initargs ,@definitargs) (nreverse class-options))))))))) + + #+test (progn (defclass md-test-super ()()) defmodel.lisp @@ -26,9 +26,13 @@ See the Lisp Lesser GNU Public License for more details. ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name) (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent) (.value :initform nil :accessor value :initarg :value) + (register? :cell nil :initform nil :initarg :register? :reader register?) (zdbg :initform nil :accessor dbg :initarg :dbg)) ) +(defmethod initialize-instance :after ((self model) &key) + (when (register? self) + (fm-register self))) (defmethod print-cell-object ((md model)) (or (md-name md) :md?)) @@ -92,7 +96,14 @@ See the Lisp Lesser GNU Public License for more details. (.kids :initform (c-in nil) ;; most useful :owning t :accessor kids - :initarg :kids))) + :initarg :kids) + (registry? :cell nil + :initform nil + :initarg :registry? + :accessor registry?) + (registry :cell nil + :initform nil + :accessor registry))) #+test (let ((c (find-class 'family))) @@ -143,14 +154,11 @@ See the Lisp Lesser GNU Public License for more details. `(let ((,kid ,self)) (find-prior ,kid (kids (fm-parent ,kid)))))) - -(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self))) - +(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self))) (c-assert self) (c-assert fm-parent) (c-assert (typep fm-parent 'family)) - (trc nil "md be adopted >" :kid self (adopt-ct self) :by fm-parent) (when (plusp (adopt-ct self)) @@ -209,5 +217,45 @@ See the Lisp Lesser GNU Public License for more details. (declare (ignorable self)) (list ,@slot-defs))) +; --- registry "namespacing" --- + +(defmethod registry? (other) (declare (ignore other)) nil) + +(defmethod initialize-instance :after ((self family) &key) + (when (registry? self) + (setf (registry self) (make-hash-table :test 'eq)))) + +(defmethod fm-register (self &optional (guest self)) + (assert self) + (if (registry? self) + (progn + (trc "fm-registering" (md-name guest) :with self) + (setf (gethash (md-name guest) (registry self)) guest)) + (fm-register (fm-parent self) guest))) + +(defmethod fm-check-out (self &optional (guest self)) + (assert self () "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent)) + (if (registry? self) + (remhash (md-name guest) (registry self)) + (bif (p (fm-parent self)) + (fm-check-out p guest) + (break "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent))))) + +(defmethod fm-find-registered (id self &optional (must-find? self must-find?-supplied?)) + (or (if (registry? self) + (gethash id (registry self)) + (bwhen (p (fm-parent self)) + (fm-find-registered id p must-find?))) + (when (and must-find? (not must-find?-supplied?)) + (break "fm-find-registered failed seeking ~a starting search at node ~a" id self)))) + +(export! rg? rg!) + +(defmacro rg? (id) + `(fm-find-registered ,id self nil)) + +(defmacro rg! (id) + `(fm-find-registered ,id self)) + \ No newline at end of file family.lisp @@ -14,7 +14,7 @@ the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. -$Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1.20 2008/05/24 19:24:05 fgoenninger Exp $ +$Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1.21 2008/06/16 12:38:04 ktilton Exp $ |# (in-package :cells) @@ -702,7 +702,6 @@ $Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1. :global-search global-search)))) (when (and must-find (null match)) (trc "fm-find-one > erroring fm-not-found, in family: " family :seeking md-name :global? global-search) - ;;(inspect family) (setq diag t must-find nil) (fm-traverse family #'matcher :skip-tree skip-tree fm-utilities.lisp @@ -102,6 +102,7 @@ See the Lisp Lesser GNU Public License for more details. (^prior-sib-pr self (spacing .parent))))))))))) + (defun ^prior-sib-pb (self &optional (spacing 0)) ;; just keeping with -pt variant till both converted to defun (bif (psib (find-prior self (kids .parent) :test (lambda (sib) @@ -118,23 +119,35 @@ See the Lisp Lesser GNU Public License for more details. (c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) -2)))) ;--------------- geo.row.flow ---------------------------- -(export! geo-row-flow) +(export! geo-row-flow fixed-col-width ^fixed-col-width ^spacing-hz spacing-hz + max-per-row ^max-per-row) (defmd geo-row-flow (geo-inline) (spacing-hz 0) (spacing-vt 0) (aligned :cell nil) + fixed-col-width + max-per-row (row-flow-layout (c? (loop with max-pb = 0 and pl = 0 and pt = 0 for k in (^kids) - for kpr = (+ pl (l-width k)) + for kn upfrom 0 + for kw = (or (^fixed-col-width) (l-width k)) + for kpr = (+ pl kw) when (unless (= pl 0) - (> kpr (- (l-width self) (outset self)))) do + (if (^max-per-row) + (zerop (mod kn (^max-per-row))) + (> kpr (- (l-width self) (outset self))))) + do + (when (> kpr (- (l-width self) (outset self))) + (trc nil "LR overflow break" kpr :gt (- (l-width self) (outset self)))) + (when (zerop (mod kn (^max-per-row))) + (trc nil "max/row break" kn (^max-per-row) (mod kn (^max-per-row)))) (setf pl 0 pt (+ max-pb (downs (^spacing-vt)))) - + collect (cons pl pt) into pxys - do (incf pl (+ (l-width k)(^spacing-hz))) + do (incf pl (+ kw (^spacing-hz))) (setf max-pb (min max-pb (+ pt (downs (l-height k))))) finally (return (cons max-pb pxys))))) :lb (c? (+ (bif (xys (^row-flow-layout)) gui-geometry/geo-family.lisp @@ -66,6 +66,7 @@ See the Lisp Lesser GNU Public License for more details. *unfinished-business* *defer-changes*) (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info) + (when *c-debug* (assert (boundp '*istack*))) (when (or (zerop *data-pulse-id*) (eq opcode :change)) (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) @@ -77,15 +78,17 @@ See the Lisp Lesser GNU Public License for more details. (let ((*istack* (list (list opcode defer-info) (list :trigger code) (list :start-dp *data-pulse-id*)))) + (trc "*istack* bound") (handler-case (go-go) - (t (c) + (xcell (c) (if (functionp *c-debug*) (funcall *c-debug* c (nreverse *istack*)) (loop for f in (nreverse *istack*) do (format t "~&istk> ~(~a~) " f) finally (describe c) - (break "integ backtrace: see listener for deets")))))) + (break "integ backtrace: see listener for deets"))))) + (trc "*istack* unbinding")) (go-go))))) (defun ufb-queue (opcode) @@ -163,7 +166,7 @@ See the Lisp Lesser GNU Public License for more details. ; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem. (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents))) - #+x42 (trc "retelling dependenst, one new one being" uqp) + #+xxx (trc "retelling dependenst, one new one being" uqp) (go tell-dependents)) ;--- process client queue ------------------------------ integrity.lisp @@ -58,8 +58,7 @@ See the Lisp Lesser GNU Public License for more details. (defun c-unlink-unused (c &aux (usage (cd-usage c)) (usage-size (array-dimension (cd-usage c) 0)) - (dbg nil)) ;; #+not (and (typep (c-model c) 'mathx::mx-solver-stack) - ;;(eq (c-slot-name c) '.kids)))) + (dbg nil)) (declare (ignorable dbg usage-size)) (when (cd-useds c) (let (rev-pos) link.lisp @@ -23,9 +23,11 @@ See the Lisp Lesser GNU Public License for more details. (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name))) (when (and (not *not-to-be*) (mdead self)) - (trc "md-slot-value passed dead self, returning NIL" self slot-name c) - #-sbcl (inspect self) - (break "see inspector for dead ~a" self) + (unless *stop* + (setf *stop* t) + (trc "md-slot-value passed dead self, returning NIL" self slot-name c) + #-sbcl (inspect self) + (break "see inspector for dead ~a" self)) (return-from md-slot-value nil)) (tagbody retry @@ -47,7 +49,7 @@ See the Lisp Lesser GNU Public License for more details. ;; (count-it :md-slot-value slot-name) (if c (cell-read c) - (values (bd-slot-value self slot-name) nil))) + (values (slot-value self slot-name) nil))) (defun cell-read (c) (assert (typep c 'cell)) @@ -61,12 +63,6 @@ See the Lisp Lesser GNU Public License for more details. (when (mdead s) (break "model ~a is dead at ~a" s key))) -;;;(defmethod trcp ((c cell)) -;;; (and *dbg* -;;; (case (c-slot-name c) -;;; (mathx::show-time t) -;;; (ctk::app-time t)))) - (defvar *trc-ensure* nil) (defmethod ensure-value-is-current (c debug-id ensurer) @@ -145,6 +141,7 @@ See the Lisp Lesser GNU Public License for more details. nil) v))) + (defun calculate-and-set (c) (flet ((body () (when (c-stopped) @@ -154,19 +151,18 @@ See the Lisp Lesser GNU Public License for more details. #-its-alive! (bwhen (x (find c *call-stack*)) ;; circularity (unless nil ;; *stop* - (let ((stack (copy-list *call-stack*))) - (trc "calculating cell ~a appears in call stack: ~a" c x stack ))) - (setf *stop* t) - (c-break "yep" c) - (loop with caller-reiterated - for caller in *call-stack* - until caller-reiterated - do (trc "caller:" caller) - ;; not necessary (pprint (cr-code c)) - (setf caller-reiterated (eq caller c))) + (let () + (inspect c) + (trc "calculating cell:" c (cr-code c)) + (trc "appears-in-call-stack (newest first): " (length *call-stack*)) + (loop for caller in (copy-list *call-stack*) + for n below (length *call-stack*) + do (trc "caller> " caller #+shhh (cr-code caller)) + when (eq caller c) do (loop-finish)))) + (setf *stop* t) (c-break ;; break is problem when testing cells on some CLs "cell ~a midst askers (see above)" c) - (error "see listener for cell rule cycle diagnotics")) + (error 'asker-midst-askers :cell c)) (multiple-value-bind (raw-value propagation-code) (calculate-and-link c) @@ -197,6 +193,20 @@ See the Lisp Lesser GNU Public License for more details. (funcall (cr-rule c) c) (c-unlink-unused c)))) +#+theabove! +(defun calculate-and-set (c) + (multiple-value-bind (raw-value propagation-code) + (let ((*call-stack* (cons c *call-stack*)) + (*depender* c) + (*defer-changes* t)) + (cd-usage-clear-all c) + (multiple-value-prog1 + (funcall (cr-rule c) c) + (c-unlink-unused c))) + (unless (c-optimized-away-p c) + (md-slot-value-assume c raw-value propagation-code)))) + + ;------------------------------------------------------------- (defun md-slot-makunbound (self slot-name md-slot-value.lisp @@ -54,7 +54,7 @@ See the Lisp Lesser GNU Public License for more details. (:method ((self model-object)) (md-quiesce self)) - + (:method :before ((self model-object)) (loop for slot-name in (md-owning-slots self) do (not-to-be (slot-value self slot-name)))) @@ -62,8 +62,7 @@ See the Lisp Lesser GNU Public License for more details. (:method :around ((self model-object)) (declare (ignorable self)) (let ((*not-to-be* t) - (dbg nil #+not (or (eq (md-name self) :eclm-owner) - (typep self '(or mathx::eclm-2008 clo:ix-form mathx::a1-panel mathx::edit-caret ctk:window))))) + (dbg nil)) (flet ((gok () (unless (eq (md-state self) :eternal-rest) @@ -85,13 +84,15 @@ See the Lisp Lesser GNU Public License for more details. (mapcar 'type-of (slot-value self '.kids)))) (gok) (when dbg (trc "finished nailing" self)))))))) - + (defun md-quiesce (self) (trc nil "md-quiesce nailing cells" self (type-of self)) (md-map-cells self nil (lambda (c) (trc nil "quiescing" c) (c-assert (not (find c *call-stack*))) - (c-quiesce c)))) + (c-quiesce c))) + (when (register? self) + (fm-check-out self))) (defun c-quiesce (c) (typecase c @@ -112,3 +113,78 @@ See the Lisp Lesser GNU Public License for more details. ,@initargs :fm-parent (progn (assert self) self))) +(export! self-owned self-owned?) + +(defun (setf self-owned) (new-value self thing) + (if (consp thing) + (loop for e in thing do + (setf (self-owned self e) new-value)) + (if new-value + (progn + (assert (not (find thing (z-owned self)))) + (push thing (z-owned self))) + (progn + (assert (find thing (z-owned self))) + (setf (z-owned self)(delete thing (z-owned self))))))) + +(defun self-owned? (self thing) + (find thing (z-owned self))) + +(defvar *c-d-d*) +(defvar *max-d-d*) + + +(defun count-model (self) + (setf *c-d-d* (make-hash-table :test 'eq) *max-d-d* 0) + (with-metrics (t nil "cells statistics for" self) + (labels ((cc (self) + (count-it :thing) + (count-it :thing (type-of self)) + ;(count-it :thing-type (type-of self)) + (loop for (id . c) in (cells self) + do (count-it :live-cell) + ;(count-it :live-cell id) + + (typecase c + (c-dependent + (count-it :dependent-cell) + (loop repeat (length (c-useds c)) + do (count-it :cell-useds) + (count-it :dep-depth (c-depend-depth c)))) + (otherwise (if (c-inputp c) + (count-it :c-input id) + (count-it :c-unknow)))) + + (loop repeat (length (c-callers c)) + do (count-it :cell-callers))) + + (loop repeat (length (cells-flushed self)) + do (count-it :flushed-cell #+toomuchinfo id)) + + (loop for slot in (md-owning-slots self) do + (loop for k in (let ((sv (SLOT-VALUE self slot))) + (if (listp sv) sv (list sv))) + do (cc k))))) + (cc self)))) + +(defun c-depend-depth (ctop) + (if (null (c-useds ctop)) + 0 + (or (gethash ctop *c-d-d*) + (labels ((cdd (c &optional (depth 1) chain) + (when (and (not (c-useds c)) + (> depth *max-d-d*)) + (setf *max-d-d* depth) + (trc "new dd champ from user" depth :down-to c) + (when (= depth 41) + (trc "end at" (c-slot-name c) :of (type-of (c-model c))) + (loop for c in chain do + (trc "called by" (c-slot-name c) :of (type-of (c-model c)))))) + (setf (gethash c *c-d-d*) + ;(break "c-depend-depth ~a" c) + (progn + ;(trc "dd" c) + (1+ (loop for u in (c-useds c) + maximizing (cdd u (1+ depth) (cons c chain)))))))) + (cdd ctop))))) + \ No newline at end of file md-utilities.lisp @@ -21,15 +21,17 @@ See the Lisp Lesser GNU Public License for more details. ;;; --- model-object ---------------------- (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(md-name fm-parent .parent))) + (export '(md-name fm-parent .parent z-owned))) (defclass model-object () ((.md-state :initform :nascent :accessor md-state) ; [nil | :nascent | :alive | :doomed] - (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p) ; [nil | :nascent | :alive | :doomed] + (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p) (.cells :initform nil :accessor cells) (.cells-flushed :initform nil :accessor cells-flushed :documentation "cells supplied but un-whenned or optimized-away") - (adopt-ct :initform 0 :accessor adopt-ct))) + (adopt-ct :initform 0 :accessor adopt-ct) + (z-owned :initform nil :accessor z-owned ;; experimental, not yet operative + :documentation "Things such as kids to be taken down when self is taken down"))) (defmethod md-state ((self symbol)) :alive) @@ -202,7 +204,8 @@ See the Lisp Lesser GNU Public License for more details. (dolist (super (class-precedence-list (find-class class-name)) (setf (md-slot-cell-type class-name slot-name) nil)) (bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types))) - (return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry)))))))) + (return-from md-slot-cell-type + (setf (md-slot-cell-type class-name slot-name) (cdr entry)))))))) (defun (setf md-slot-cell-type) (new-type class-name slot-name) (assert class-name) @@ -216,12 +219,6 @@ See the Lisp Lesser GNU Public License for more details. do (setf (md-slot-cell-type (class-name c) slot-name) new-type))) (cdar (push (cons slot-name new-type) (get class-name :cell-types))))))) -#+hunh -(md-slot-owning? 'mathx::prb-solver '.kids) - -#+hunh -(cdr (assoc '.value (get 'm-index :indirect-ownings))) - #+test (md-slot-owning? 'm-index '.value) @@ -289,6 +286,10 @@ See the Lisp Lesser GNU Public License for more details. (defun (setf md-slot-cell) (new-cell self slot-name) (if self ;; not on def-c-variables (bif (entry (assoc slot-name (cells self))) + ; this next branch guessed it would only occur during kid-slotting, + ; before any dependency-ing could have happened, but a math-editor + ; is silently switching between implied-multiplication and mixed numbers + ; while they type and it (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter (declare (ignorable old)) (c-assert (null (c-callers old))) model-object.lisp @@ -58,12 +58,8 @@ See the Lisp Lesser GNU Public License for more details. (setf (c-pulse c) *data-pulse-id*)) ;--------------- propagate ---------------------------- - - ; n.b. the cell argument may have been optimized away, ; though it is still receiving final processing here. -; - (defparameter *per-cell-handler* nil) propagate.lisp @@ -22,7 +22,7 @@ (defun tcprop () (untrace) - (test-prep) + (ukt:test-prep) (LET ((box (make-instance 'tcp))) (trc "changing top to 10" *data-pulse-id*) (setf (top box) 10) test-propagation.lisp @@ -19,13 +19,12 @@ See the Lisp Lesser GNU Public License for more details. (in-package :cells) ;----------- trc ------------------------------------------- - +(defparameter *last-trc* (get-internal-real-time)) (defparameter *trcdepth* 0) (defun trcdepth-reset () (setf *trcdepth* 0)) - (defmacro trc (tgt-form &rest os) (if (eql tgt-form 'nil) '(progn) @@ -45,8 +44,23 @@ See the Lisp Lesser GNU Public License for more details. (count-it :trcfailed))) (count-it :tgtnileval))))))) -(export! brk brkx .bgo) +(defun call-trc (stream s &rest os) + ;(break) + (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) + *trcdepth*) + (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) + (format stream "~&")) + ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) + (setf *last-trc* (get-internal-real-time)) + (format stream "~a" s) + (let (pkwp) + (dolist (o os) + (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like + (setf pkwp (keywordp o)))) + (force-output stream) + (values)) +(export! brk brkx .bgo) (define-symbol-macro .bgo (break "go")) @@ -68,23 +82,8 @@ See the Lisp Lesser GNU Public License for more details. nconcing (list (intern (format nil "~a" obj) :keyword) obj)))))) -(defparameter *last-trc* (get-internal-real-time)) -(defun call-trc (stream s &rest os) - ;(break) - (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) - *trcdepth*) - (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) - (format stream "~&")) - ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) - (setf *last-trc* (get-internal-real-time)) - (format stream "~a" s) - (let (pkwp) - (dolist (o os) - (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like - (setf pkwp (keywordp o)))) - (force-output stream) - (values)) + (defun call-trc-to-string (fmt$ &rest fmt-args) (let ((o$ (make-array '(0) :element-type 'base-char trc-eko.lisp @@ -46,41 +46,26 @@ resulting in implementation-specific behavior." value))) ,@(when docstring (list docstring))))) - -(export! exe-path exe-dll font-path) - -#-iamnotkenny -(defun exe-path () - #+its-alive! - (excl:current-directory) - #-its-alive! +(defun test-setup (&optional drib) + #+(and allegro ide) + (ide.base::find-new-prompt-command + (cg.base::find-window :listener-frame)) + (when drib + (dribble (merge-pathnames + (make-pathname :name drib :type "TXT") + (project-path))))) + +(export! test-setup test-prep test-init) +(export! project-path) +(defun project-path () + #+(and allegro ide) (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) -#-iamnotkenny -(defun font-path () - (merge-pathnames - (make-pathname - :directory #+its-alive! (list :relative "font") - #-its-alive! (append (butlast (pathname-directory - (exe-path) - )) - (list "TY Extender" "font"))) - (exe-path))) - #+test -(list (exe-path)(font-path)) +(test-setup) -(defmacro exe-dll (&optional filename) - (assert filename) - (concatenate 'string filename ".dll")) +(defun test-prep (&optional drib) + (test-setup drib)) -#+chya -(defun exe-dll (&optional filename) - (merge-pathnames - (make-pathname :name filename :type "DLL" - :directory (append (butlast (pathname-directory (exe-path))) - (list "dll"))) - (exe-path))) - -#+test -(probe-file (exe-dll "openal32")) +(defun test-init (&optional drib) + (test-setup drib)) \ No newline at end of file utils-kt/core.lisp @@ -55,13 +55,13 @@ See the Lisp Lesser GNU Public License for more details. (defmacro count-it (&rest keys) (declare (ignorable keys)) - #+(or) `(progn) - `(when (car *counting*) + `(progn) + #+(or) `(when (car *counting*) (call-count-it ,@keys))) (defun call-count-it (&rest keys) (declare (ignorable keys)) - (when (find (car keys) '(:trcfailed :TGTNILEVAL)) + #+nahh (when (find (car keys) '(:trcfailed :TGTNILEVAL)) (break "clean up time ~a" keys)) (let ((entry (assoc keys *count* :test #'equal))) (if entry @@ -85,6 +85,7 @@ See the Lisp Lesser GNU Public License for more details. (when clearp (count-clear "show-count"))) + ;-------------------- timex --------------------------------- (export! timex) utils-kt/debug.lisp @@ -59,30 +59,6 @@ See the Lisp Lesser GNU Public License for more details. (defun collect-if (test list) (remove-if-not test list)) -(defun test-setup (&optional drib) - #-(or iamnotkenny its-alive!) - (ide.base::find-new-prompt-command - (cg.base::find-window :listener-frame)) - (when drib - (dribble (merge-pathnames - (make-pathname :name drib :type "TXT") - (project-path))))) - -(export! project-path) -(defun project-path () - #+allegro (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) - -#+test -(test-setup) - -(defun test-prep (&optional drib) - (test-setup drib)) - -(defun test-init (&optional drib) - (test-setup drib)) - -(export! test-setup test-prep test-init) - ;;; --- FIFO Queue ----------------------------- (defun make-fifo-queue (&rest init-data) utils-kt/detritus.lisp @@ -150,11 +150,15 @@ See the Lisp Lesser GNU Public License for more details. (defun -1?1 (x) (* -1?1 x)) (defun prime? (n) - (and (> n 1) - (or (= 2 n)(oddp n)) - (loop for d upfrom 3 by 2 to (sqrt n) - when (zerop (mod n d)) return nil - finally (return t)))) + (when (> n 1) + (cond + ((= 2 n) t) + ((evenp n) (values nil 2)) + (t (loop for d upfrom 3 by 2 to (sqrt n) + when (zerop (mod n d)) do (return-from prime? (values nil d)) + finally (return t)))))) + + ; --- cloucell support for struct access of slots ------------------------ utils-kt/flow-control.lisp 0d3538c153e7b287a70250ad92e14c05c2c8e9fe ktilton ktilton http://github.com/Ramarren/cells/commit/d565d1228fa96c6392f74d0be0264ab07c71a5fe d565d1228fa96c6392f74d0be0264ab07c71a5fe 2008-06-16T05:38:03-07:00 2008-06-16T05:38:03-07:00 nothing special 37fdfe4f58b913d22162237672f449dd217ac761 ktilton ktilton