From ktilton at common-lisp.net Fri Feb 1 03:18:36 2008 From: ktilton at common-lisp.net (ktilton) Date: Thu, 31 Jan 2008 22:18:36 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080201031836.6915612070@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv4024 Modified Files: cells.lpr integrity.lisp md-slot-value.lisp propagate.lisp Log Message: version 1.0 of multiple updates in one datapulse --- /project/cells/cvsroot/cells/cells.lpr 2007/11/30 16:51:18 1.28 +++ /project/cells/cvsroot/cells/cells.lpr 2008/02/01 03:18:35 1.29 @@ -1,8 +1,8 @@ -;; -*- lisp-version: "8.0 [Windows] (Sep 14, 2007 21:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*- (in-package :cg-user) -(defpackage :cells) +(defpackage :CELLS) (define-project :name :cells :modules (list (make-instance 'module :name "defpackage.lisp") @@ -36,16 +36,17 @@ :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:local-name-info) - :build-flags '(:allow-debug :purify) + :include-flags (list :local-name-info) + :build-flags (list :allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil + :include-manifest-file-for-visual-styles t :default-command-line-arguments "+cx +t \"Initializing\"" - :additional-build-lisp-image-arguments '(:read-init-files nil) + :additional-build-lisp-image-arguments (list :read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'cells::test + :on-initialization 'cells::tcprop :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/cells/integrity.lisp 2007/11/30 22:29:06 1.19 +++ /project/cells/cvsroot/cells/integrity.lisp 2008/02/01 03:18:36 1.20 @@ -27,7 +27,7 @@ (defmacro with-integrity ((&optional opcode defer-info debug) &rest body) (when opcode (assert (find opcode *ufb-opcodes*) () - "Invalid second value to with-integrity: ~a" opcode)) + "Invalid opcode for with-integrity: ~a. Allowed values: ~a" opcode *ufb-opcodes*)) `(call-with-integrity ,opcode ,defer-info (lambda (opcode defer-info) (declare (ignorable opcode defer-info)) ,(when debug @@ -55,8 +55,7 @@ *defer-changes*) (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info) (when (or (zerop *data-pulse-id*) - (eq opcode :change) - ) + (eq opcode :change)) (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) (data-pulse-next (cons opcode defer-info)))) (prog1 --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/01/31 03:30:17 1.38 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/02/01 03:18:36 1.39 @@ -218,8 +218,6 @@ ; ; --- data flow propagation ----------- ; - - (setf (c-pulse-last-changed c) *data-pulse-id*) (without-c-dependency (c-propagate c prior-value t))))))) @@ -245,7 +243,6 @@ (md-slot-value-assume c new-value nil)) (*defer-changes* - (print `(cweird ,c ,(type-of c))) (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c)) (t @@ -277,12 +274,10 @@ (return-from md-slot-value-assume absorbed-value)) ; --- slot maintenance --- - (when (eq (c-state c) :optimized-away) - (break "bongo one ~a flush ~a" c (flushed? c))) + (unless (c-synaptic c) (md-slot-value-store (c-model c) (c-slot-name c) absorbed-value)) - (when (eq (c-state c) :optimized-away) - (break "bongo two ~a flush ~a" c (flushed? c))) + ; --- cell maintenance --- (setf (c-value c) absorbed-value @@ -298,7 +293,6 @@ ; --- data flow propagation ----------- (unless (eq propagation-code :no-propagate) (trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value ) - (setf (c-pulse-last-changed c) *data-pulse-id*) (c-propagate c prior-value (cache-state-bound-p prior-state))) ;; until 06-02-13 was (not (eq prior-state :unbound)) absorbed-value))) --- /project/cells/cvsroot/cells/propagate.lisp 2008/01/31 03:30:17 1.29 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 03:18:36 1.30 @@ -36,10 +36,13 @@ ; --- data pulse (change ID) management ------------------------------------- +(defparameter *client-is-propagating* nil) + (defun data-pulse-next (pulse-info) (declare (ignorable pulse-info)) - (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) - (incf *data-pulse-id*)) + (unless *client-is-propagating* + (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) + (incf *data-pulse-id*))) (defun c-currentp (c) (eql (c-pulse c) *data-pulse-id*)) @@ -59,28 +62,37 @@ ; though it is still receiving final processing here. ; + +(defparameter *per-cell-handler* nil) + (defun c-propagate (c prior-value prior-value-supplied) - - (count-it :c-propagate) + (when *client-is-propagating* + (when *per-cell-handler* + (funcall *per-cell-handler* c prior-value prior-value-supplied) + (return-from c-propagate))) + + (count-it :cpropagate) + (setf (c-pulse-last-changed c) *data-pulse-id*) + (when prior-value (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c)) (let (*call-stack* (*c-prop-depth* (1+ *c-prop-depth*)) (*defer-changes* t)) - (trc nil "c-propagate clearing *call-stack*" c) + (trc nil "c.propagate clearing *call-stack*" c) ;------ debug stuff --------- ; (when *stop* (princ #\.)(princ #\!) (return-from c-propagate)) - (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c))) - #+slow (trc c "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) + (trc nil "c.propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c))) + #+slow (trc c "c.propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) (when *c-debug* (when (> *c-prop-depth* 250) - (trc nil "c-propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c)) + (trc nil "c.propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c)) (when (> *c-prop-depth* 300) - (c-break "c-propagate looping ~c" c))) + (c-break "c.propagate looping ~c" c))) ; --- manifest new value as needed --- ; @@ -94,7 +106,7 @@ (when (and prior-value-supplied prior-value (md-slot-owning (type-of (c-model c)) (c-slot-name c))) - (trc nil "c-propagate> contemplating lost") + (trc nil "c.propagate> contemplating lost") (flet ((listify (x) (if (listp x) x (list x)))) (bif (lost (set-difference (listify prior-value) (listify (c-value c)))) (progn @@ -113,7 +125,7 @@ (unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this (c-propagate-to-callers c)) - (trc nil "c-propagate observing" c) + (trc nil "c.propagate observing" c) ; this next assertion is just to see if we can ever come this way twice. If so, just ; make it a condition on whether to observe @@ -177,6 +189,14 @@ ; --- recalculate dependents ---------------------------------------------------- +(defmacro cll-outer (val &body body) + `(let ((outer-val ,val)) + , at body)) + +(defmacro cll-inner (expr) + `(,expr outer-val)) + +(export! cll-outer cll-inner) (defun c-propagate-to-callers (c) ; @@ -195,11 +215,11 @@ (member (c-lazy caller) '(t :always :once-asked)))) (c-callers c)) (let ((causation (cons c *causation*))) ;; in case deferred - #+slow (TRC c "c-propagate-to-callers > queueing notifying callers" (c-callers c)) + #+slow (TRC c "c.propagate-to-callers > queueing notifying callers" (c-callers c)) (with-integrity (:tell-dependents c) (assert (null *call-stack*)) (let ((*causation* causation)) - (trc nil "c-propagate-to-callers > actually notifying callers of" c (c-callers c)) + (trc nil "c.propagate-to-callers > actually notifying callers of" c (c-callers c)) #+c-debug (dolist (caller (c-callers c)) (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller)) #+c-debug (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list... @@ -217,6 +237,66 @@ (let ((*trc-ensure* (trcp c))) (ensure-value-is-current caller :prop-from c))))))))) +(defparameter *the-unpropagated* nil) + +(defmacro with-client-propagation ((&key (per-cell nil per-cell?) (finally nil finally?)) &body body) + `(call-with-client-propagation (lambda () , at body) + ,@(when per-cell? `(:per-cell (lambda (c) (declare (ignorable c)) ,per-cell))) + ,@(when finally? `(:finally (lambda (cs) (declare (ignorable cs)) ,finally))))) + +(defun call-with-client-propagation + (f &key + (per-cell (lambda (c prior-value prior-value?) + (unless (find c *the-unpropagated* :key 'car) + (pushnew (list c prior-value prior-value?) *the-unpropagated*)))) + (finally (lambda (cs) + (print `(finally sees ,*data-pulse-id* ,cs)) + ;(trace c-propagate ensure-value-is-current) + (loop for (c prior-value prior-value?) in (nreverse cs) do + (c-propagate c prior-value prior-value?))))) + (assert (not *client-is-propagating*)) + (data-pulse-next :client-prop) + (trc "call-with-client-propagation bumps pulse" *data-pulse-id*) + (funcall finally + (let ((*client-is-propagating* t) + (*per-cell-handler* per-cell) + (*the-unpropagated* nil)) + (funcall f) + *the-unpropagated*))) + + +(defmd tcp () + (left (c-in 0)) + (top (c-in 0)) + (right (c-in 0)) + (bottom (c-in 0)) + (area (c? (trc "area running") + (* (- (^right)(^left)) + (- (^top)(^bottom)))))) + +(defobserver area () + (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) + +(defun tcprop () + (untrace) + (test-prep) + (LET ((box (make-instance 'tcp))) + (trc "changing top to 10" *data-pulse-id*) + (setf (top box) 10) + (trc "not changing top" *data-pulse-id*) + (setf (top box) 10) + (trc "changing right to 10" *data-pulse-id*) + (setf (right box) 10) + (trc "not changing right" *data-pulse-id*) + (setf (right box) 10) + (trc "changing bottom to -1" *data-pulse-id*) + (decf (bottom box)) + (with-client-propagation () + (loop repeat 20 do + (trc "changing bottom by -1" *data-pulse-id*) + (decf (bottom box)) + (decf (left box)))))) + From phildebrandt at common-lisp.net Fri Feb 1 15:52:49 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Fri, 1 Feb 2008 10:52:49 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080201155249.A0C1E48227@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv1246 Modified Files: cells.asd defmodel.lisp propagate.lisp Added Files: test-propagation.lisp Log Message: moved propagation test to test-propagation.lisp --- /project/cells/cvsroot/cells/cells.asd 2007/12/02 18:44:18 1.8 +++ /project/cells/cvsroot/cells/cells.asd 2008/02/01 15:52:49 1.9 @@ -39,7 +39,8 @@ (:file "md-utilities") (:file "family") (:file "fm-utilities") - (:file "family-values"))) + (:file "family-values") + (:file "test-propagation"))) (defmethod perform ((o load-op) (c (eql (find-system :cells)))) (pushnew :cells *features*)) --- /project/cells/cvsroot/cells/defmodel.lisp 2007/11/30 16:51:18 1.13 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/02/01 15:52:49 1.14 @@ -25,72 +25,72 @@ (setf (get ',class :cell-types) nil) (setf (get ',class 'slots-excluded-from-persistence) ',(loop for slotspec in slotspecs - unless (and (getf (cdr slotspec) :ps t) - (getf (cdr slotspec) :persistable t)) - collect (car slotspec)))) + unless (and (getf (cdr slotspec) :ps t) + (getf (cdr slotspec) :persistable t)) + collect (car slotspec)))) ;; define slot macros before class so they can appear in ;; initforms and default-initargs ,@(delete nil - (loop for slotspec in slotspecs - nconcing (destructuring-bind - (slotname &rest slotargs - &key (cell t) owning (accessor slotname) reader - &allow-other-keys) - slotspec + (loop for slotspec in slotspecs + nconcing (destructuring-bind + (slotname &rest slotargs + &key (cell t) owning (accessor slotname) reader + &allow-other-keys) + slotspec - (declare (ignorable slotargs owning)) - (list - (when cell - (let* ((reader-fn (or reader accessor)) - (deriver-fn (intern$ "^" (symbol-name reader-fn)))) - `(eval-when (:compile-toplevel :execute :load-toplevel) - (unless (macro-function ',deriver-fn) - (defmacro ,deriver-fn () - `(,',reader-fn self)))))))))) + (declare (ignorable slotargs owning)) + (list + (when cell + (let* ((reader-fn (or reader accessor)) + (deriver-fn (intern$ "^" (symbol-name reader-fn)))) + `(eval-when (:compile-toplevel :execute :load-toplevel) + (unless (macro-function ',deriver-fn) + (defmacro ,deriver-fn () + `(,',reader-fn self)))))))))) - ; - ; ------- defclass --------------- (^slot-value ,model ',',slotname) - ; + ; + ; ------- defclass --------------- (^slot-value ,model ',',slotname) + ; (progn - (defclass ,class ,(or directsupers '(model-object));; now we can def the class - ,(mapcar (lambda (s) - (list* (car s) - (let ((ias (cdr s))) - (remf ias :persistable) - (remf ias :ps) - ;; We handle accessor below - (when (getf ias :cell t) - (remf ias :reader) - (remf ias :writer) - (remf ias :accessor)) - (remf ias :cell) - (remf ias :owning) - (remf ias :unchanged-if) - ias))) (mapcar #'copy-list slotspecs)) - (:documentation - ,@(or (cdr (find :documentation options :key #'car)) - '("chya"))) - (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this - ,@(cdr (find :default-initargs options :key #'car))) - (:metaclass ,(or (cadr (find :metaclass options :key #'car)) - 'standard-class))) + (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class + ,(mapcar (lambda (s) + (list* (car s) + (let ((ias (cdr s))) + (remf ias :persistable) + (remf ias :ps) + ;; We handle accessor below + (when (getf ias :cell t) + (remf ias :reader) + (remf ias :writer) + (remf ias :accessor)) + (remf ias :cell) + (remf ias :owning) + (remf ias :unchanged-if) + ias))) (mapcar #'copy-list slotspecs)) + (:documentation + ,@(or (cdr (find :documentation options :key #'car)) + '("chya"))) + (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this + ,@(cdr (find :default-initargs options :key #'car))) + (:metaclass ,(or (cadr (find :metaclass options :key #'car)) + 'standard-class))) (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) (declare (ignore slot-names iargs)) ,(when (and directsupers (not (member 'model-object directsupers))) - `(unless (typep self 'model-object) - (error "If no superclass of ~a inherits directly + `(unless (typep self 'model-object) + (error "If no superclass of ~a inherits directly or indirectly from model-object, model-object must be included as a direct super-class in the defmodel form for ~a" ',class ',class)))) - ; - ; slot accessors once class is defined... - ; + ; + ; slot accessors once class is defined... + ; ,@(mapcar (lambda (slotspec) (destructuring-bind - (slotname &rest slotargs - &key (cell t) owning unchanged-if (accessor slotname) reader writer type - &allow-other-keys) + (slotname &rest slotargs + &key (cell t) owning unchanged-if (accessor slotname) reader writer type + &allow-other-keys) slotspec (declare (ignorable slotargs)) @@ -102,24 +102,24 @@ (setf (md-slot-cell-type ',class ',slotname) ,cell) ,(when owning - `(setf (md-slot-owning ',class ',slotname) ,owning)) + `(setf (md-slot-owning ',class ',slotname) ,owning)) ,(when reader-fn - `(defmethod ,reader-fn ((self ,class)) - (md-slot-value self ',slotname))) + `(defmethod ,reader-fn ((self ,class)) + (md-slot-value self ',slotname))) ,(when writer-fn - `(defmethod (setf ,writer-fn) (new-value (self ,class)) - (setf (md-slot-value self ',slotname) - ,(if type - `(coerce new-value ',type) - 'new-value)))) + `(defmethod (setf ,writer-fn) (new-value (self ,class)) + (setf (md-slot-value self ',slotname) + ,(if type + `(coerce new-value ',type) + 'new-value)))) ,(when unchanged-if - `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) + `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) ) )) )) - slotspecs) + slotspecs) (find-class ',class)))) (defun defmd-canonicalize-slot (slotname --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 03:18:36 1.30 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 15:52:49 1.31 @@ -264,39 +264,7 @@ (funcall f) *the-unpropagated*))) - -(defmd tcp () - (left (c-in 0)) - (top (c-in 0)) - (right (c-in 0)) - (bottom (c-in 0)) - (area (c? (trc "area running") - (* (- (^right)(^left)) - (- (^top)(^bottom)))))) - -(defobserver area () - (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) - -(defun tcprop () - (untrace) - (test-prep) - (LET ((box (make-instance 'tcp))) - (trc "changing top to 10" *data-pulse-id*) - (setf (top box) 10) - (trc "not changing top" *data-pulse-id*) - (setf (top box) 10) - (trc "changing right to 10" *data-pulse-id*) - (setf (right box) 10) - (trc "not changing right" *data-pulse-id*) - (setf (right box) 10) - (trc "changing bottom to -1" *data-pulse-id*) - (decf (bottom box)) - (with-client-propagation () - (loop repeat 20 do - (trc "changing bottom by -1" *data-pulse-id*) - (decf (bottom box)) - (decf (left box)))))) - + --- /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/01 15:52:49 NONE +++ /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/01 15:52:49 1.1 (in-package :cells) (defmd tcp () (left (c-in 0)) (top (c-in 0)) (right (c-in 0)) (bottom (c-in 0)) (area (c? (trc "area running") (* (- (^right)(^left)) (- (^top)(^bottom)))))) (defobserver area () (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) (defun tcprop () (untrace) (test-prep) (LET ((box (make-instance 'tcp))) (trc "changing top to 10" *data-pulse-id*) (setf (top box) 10) (trc "not changing top" *data-pulse-id*) (setf (top box) 10) (trc "changing right to 10" *data-pulse-id*) (setf (right box) 10) (trc "not changing right" *data-pulse-id*) (setf (right box) 10) (trc "changing bottom to -1" *data-pulse-id*) (decf (bottom box)) (with-client-propagation () (loop repeat 20 do (trc "changing bottom by -1" *data-pulse-id*) (decf (bottom box)) (decf (left box)))))) From phildebrandt at common-lisp.net Fri Feb 1 15:52:49 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Fri, 1 Feb 2008 10:52:49 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080201155249.EA1B055356@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv1246/utils-kt Modified Files: core.lisp Log Message: moved propagation test to test-propagation.lisp --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/01/30 14:33:49 1.5 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/02/01 15:52:49 1.6 @@ -23,23 +23,23 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro export! (&rest symbols) - `(eval-when ( :compile-toplevel :load-toplevel :execute) - #+sbssscl (export (list ,@(mapcar #'(lambda (x) (list 'quote x)) symbols))) - #-sbclss (export ',symbols)))) + `(eval-when ( :compile-toplevel :load-toplevel :execute) + (export ',symbols)))) -(defmacro define-constant (name value &optional docstring) - "Define a constant properly. If NAME is unbound, DEFCONSTANT +(eval-now! + (defmacro define-constant (name value &optional docstring) + "Define a constant properly. If NAME is unbound, DEFCONSTANT it to VALUE. If it is already bound, and it is EQUAL to VALUE, reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again, resulting in implementation-specific behavior." - `(defconstant ,name - (if (not (boundp ',name)) - ,value - (let ((value ,value)) - (if (equal value (symbol-value ',name)) - (symbol-value ',name) - value))) - ,@(when docstring (list docstring)))) + `(defconstant ,name + (if (not (boundp ',name)) + ,value + (let ((value ,value)) + (if (equal value (symbol-value ',name)) + (symbol-value ',name) + value))) + ,@(when docstring (list docstring))))) (export! exe-path exe-dll font-path) From ktilton at common-lisp.net Fri Feb 1 20:41:55 2008 From: ktilton at common-lisp.net (ktilton) Date: Fri, 1 Feb 2008 15:41:55 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080201204155.6E8C15556D@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv25649 Modified Files: propagate.lisp Log Message: tougher test for with-one-datapulse (the new name) --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 15:52:49 1.31 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 20:41:54 1.32 @@ -239,12 +239,14 @@ (defparameter *the-unpropagated* nil) -(defmacro with-client-propagation ((&key (per-cell nil per-cell?) (finally nil finally?)) &body body) - `(call-with-client-propagation (lambda () , at body) - ,@(when per-cell? `(:per-cell (lambda (c) (declare (ignorable c)) ,per-cell))) +(defmacro with-one-datapulse ((&key (per-cell nil per-cell?) (finally nil finally?)) &body body) + `(call-with-one-datapulse (lambda () , at body) + ,@(when per-cell? `(:per-cell (lambda (c prior-value prior-value-boundp) + (declare (ignorable c prior-value prior-value-boundp)) + ,per-cell))) ,@(when finally? `(:finally (lambda (cs) (declare (ignorable cs)) ,finally))))) -(defun call-with-client-propagation +(defun call-with-one-datapulse (f &key (per-cell (lambda (c prior-value prior-value?) (unless (find c *the-unpropagated* :key 'car) @@ -256,15 +258,54 @@ (c-propagate c prior-value prior-value?))))) (assert (not *client-is-propagating*)) (data-pulse-next :client-prop) - (trc "call-with-client-propagation bumps pulse" *data-pulse-id*) + (trc "call-with-one-datapulse bumps pulse" *data-pulse-id*) (funcall finally (let ((*client-is-propagating* t) (*per-cell-handler* per-cell) (*the-unpropagated* nil)) (funcall f) *the-unpropagated*))) - - + +(defmd tcp () + (left (c-in 0)) + (top (c-in 0)) + (right (c-in 0)) + (bottom (c-in 0)) + (area (c? (trc "area running") + (* (- (^right)(^left)) + (- (^top)(^bottom)))))) + +(defobserver area () + (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) + +(defobserver bottom () + (TRC "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*) + (with-integrity (:change 'bottom-tells-left) + (setf (^left) new-value))) + +(defobserver left () + (TRC "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*)) + +(defun tcprop () + (untrace) + (test-prep) + (LET ((box (make-instance 'tcp))) + (trc "changing top to 10" *data-pulse-id*) + (setf (top box) 10) + (trc "not changing top" *data-pulse-id*) + (setf (top box) 10) + (trc "changing right to 10" *data-pulse-id*) + (setf (right box) 10) + (trc "not changing right" *data-pulse-id*) + (setf (right box) 10) + (trc "changing bottom to -1" *data-pulse-id*) + (decf (bottom box)) + (with-one-datapulse () + (loop repeat 20 do + (trc "changing bottom by -1" *data-pulse-id*) + (decf (bottom box)))))) + + From ktilton at common-lisp.net Sat Feb 2 00:09:28 2008 From: ktilton at common-lisp.net (ktilton) Date: Fri, 1 Feb 2008 19:09:28 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080202000928.D683846199@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv19896 Modified Files: cells.lisp cells.lpr initialize.lisp model-object.lisp propagate.lisp test-propagation.lisp Log Message: make cell (if any) sixth param to slot-value-observe --- /project/cells/cvsroot/cells/cells.lisp 2008/01/29 04:29:52 1.23 +++ /project/cells/cvsroot/cells/cells.lisp 2008/02/02 00:09:28 1.24 @@ -103,14 +103,14 @@ (define-condition unbound-cell (unbound-slot) ((cell :initarg :cell :reader cell :initform nil))) -(defgeneric slot-value-observe (slotname self new old old-boundp) +(defgeneric slot-value-observe (slotname self new old old-boundp cell) #-(or cormanlisp) (:method-combination progn)) #-cells-testing (defmethod slot-value-observe #-(or cormanlisp) progn - (slot-name self new old old-boundp) - (declare (ignorable slot-name self new old old-boundp))) + (slot-name self new old old-boundp cell) + (declare (ignorable slot-name self new old old-boundp cell))) ; -------- cell conditions (not much used) --------------------------------------------- --- /project/cells/cvsroot/cells/cells.lpr 2008/02/01 03:18:35 1.29 +++ /project/cells/cvsroot/cells/cells.lpr 2008/02/02 00:09:28 1.30 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -23,7 +23,8 @@ (make-instance 'module :name "md-utilities.lisp") (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") - (make-instance 'module :name "family-values.lisp")) + (make-instance 'module :name "family-values.lisp") + (make-instance 'module :name "test-propagation.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/initialize.lisp 2008/01/31 03:30:17 1.9 +++ /project/cells/cvsroot/cells/initialize.lisp 2008/02/02 00:09:28 1.10 @@ -35,7 +35,7 @@ (trc nil "awaken cell observing" c) (when (> *data-pulse-id* (c-pulse-observed c)) (setf (c-pulse-observed c) *data-pulse-id*) - (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil) + (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil c) (ephemeral-reset c))) (defmethod awaken-cell ((c c-ruled)) --- /project/cells/cvsroot/cells/model-object.lisp 2008/01/31 03:30:17 1.18 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/02/02 00:09:28 1.19 @@ -156,7 +156,7 @@ (> *data-pulse-id* (c-pulse-observed flushed))) ;; unfrickinlikely (when flushed (setf (c-pulse-observed flushed) *data-pulse-id*)) ;; probably unnecessary - (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)))) + (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil flushed)))) ((find (c-lazy c) '(:until-asked :always t)) --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 20:41:54 1.32 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/02 00:09:28 1.33 @@ -36,11 +36,11 @@ ; --- data pulse (change ID) management ------------------------------------- -(defparameter *client-is-propagating* nil) +(defparameter *one-pulse?* nil) (defun data-pulse-next (pulse-info) (declare (ignorable pulse-info)) - (unless *client-is-propagating* + (unless *one-pulse?* (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) (incf *data-pulse-id*))) @@ -66,7 +66,7 @@ (defparameter *per-cell-handler* nil) (defun c-propagate (c prior-value prior-value-supplied) - (when *client-is-propagating* + (when *one-pulse?* (when *per-cell-handler* (funcall *per-cell-handler* c prior-value prior-value-supplied) (return-from c-propagate))) @@ -132,7 +132,7 @@ (when t ; breaks algebra (> *data-pulse-id* (c-pulse-observed c)) (setf (c-pulse-observed c) *data-pulse-id*) (slot-value-observe (c-slot-name c) (c-model c) - (c-value c) prior-value prior-value-supplied)) + (c-value c) prior-value prior-value-supplied c)) ; @@ -152,7 +152,7 @@ (defmacro defobserver (slotname &rest args &aux (aroundp (eq :around (first args)))) (when aroundp (setf args (cdr args))) (destructuring-bind ((&optional (self-arg 'self) (new-varg 'new-value) - (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) + (oldvarg 'old-value) (oldvargboundp 'old-value-boundp) (cell-arg 'c)) &body output-body) args `(progn (eval-when (:compile-toplevel :load-toplevel :execute) @@ -161,24 +161,24 @@ (let ((temp1 (gensym)) (loc-self (gensym))) `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn) - ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) + ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg) (let ((,temp1 (bump-output-count ,slotname)) (,loc-self ,(if (listp self-arg) (car self-arg) self-arg))) (when (and ,oldvargboundp ,oldvarg) - (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg)) - (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg)))) + (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg ,cell-arg)) + (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg ,cell-arg)))) `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn) - ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) + ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg) (declare (ignorable ,@(flet ((arg-name (arg-spec) (etypecase arg-spec (list (car arg-spec)) (atom arg-spec)))) (list (arg-name self-arg)(arg-name new-varg) - (arg-name oldvarg)(arg-name oldvargboundp))))) + (arg-name oldvarg)(arg-name oldvargboundp) (arg-name cell-arg))))) , at output-body))))) (defmacro bump-output-count (slotname) ;; pure test func @@ -256,56 +256,13 @@ ;(trace c-propagate ensure-value-is-current) (loop for (c prior-value prior-value?) in (nreverse cs) do (c-propagate c prior-value prior-value?))))) - (assert (not *client-is-propagating*)) + (assert (not *one-pulse?*)) (data-pulse-next :client-prop) (trc "call-with-one-datapulse bumps pulse" *data-pulse-id*) (funcall finally - (let ((*client-is-propagating* t) + (let ((*one-pulse?* t) (*per-cell-handler* per-cell) (*the-unpropagated* nil)) (funcall f) *the-unpropagated*))) -(defmd tcp () - (left (c-in 0)) - (top (c-in 0)) - (right (c-in 0)) - (bottom (c-in 0)) - (area (c? (trc "area running") - (* (- (^right)(^left)) - (- (^top)(^bottom)))))) - -(defobserver area () - (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) - -(defobserver bottom () - (TRC "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*) - (with-integrity (:change 'bottom-tells-left) - (setf (^left) new-value))) - -(defobserver left () - (TRC "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*)) - -(defun tcprop () - (untrace) - (test-prep) - (LET ((box (make-instance 'tcp))) - (trc "changing top to 10" *data-pulse-id*) - (setf (top box) 10) - (trc "not changing top" *data-pulse-id*) - (setf (top box) 10) - (trc "changing right to 10" *data-pulse-id*) - (setf (right box) 10) - (trc "not changing right" *data-pulse-id*) - (setf (right box) 10) - (trc "changing bottom to -1" *data-pulse-id*) - (decf (bottom box)) - (with-one-datapulse () - (loop repeat 20 do - (trc "changing bottom by -1" *data-pulse-id*) - (decf (bottom box)))))) - - - - - --- /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/01 15:52:49 1.1 +++ /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/02 00:09:28 1.2 @@ -1,4 +1,3 @@ - (in-package :cells) (defmd tcp () @@ -13,6 +12,14 @@ (defobserver area () (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) +(defobserver bottom () + (TRC "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*) + (with-integrity (:change 'bottom-tells-left) + (setf (^left) new-value))) + +(defobserver left () + (TRC "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*)) + (defun tcprop () (untrace) (test-prep) @@ -27,8 +34,12 @@ (setf (right box) 10) (trc "changing bottom to -1" *data-pulse-id*) (decf (bottom box)) - (with-client-propagation () - (loop repeat 20 do + (with-one-datapulse () + (loop repeat 5 do (trc "changing bottom by -1" *data-pulse-id*) - (decf (bottom box)) - (decf (left box)))))) + (decf (bottom box)))))) + + + + + From ktilton at common-lisp.net Sat Feb 2 22:16:44 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 2 Feb 2008 17:16:44 -0500 (EST) Subject: [cells-cvs] CVS kennysarc Message-ID: <20080202221644.5B7B7461D4@common-lisp.net> Update of /project/cells/cvsroot/kennysarc In directory clnet:/tmp/cvs-serv12526 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import From ktilton at common-lisp.net Sat Feb 2 22:19:28 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 2 Feb 2008 17:19:28 -0500 (EST) Subject: [cells-cvs] CVS kennysarc Message-ID: <20080202221928.7E735461DF@common-lisp.net> Update of /project/cells/cvsroot/kennysarc In directory clnet:/tmp/cvs-serv12716 Added Files: struct.arc Log Message: defstruct lite in Arc --- /project/cells/cvsroot/kennysarc/struct.arc 2008/02/02 22:19:28 NONE +++ /project/cells/cvsroot/kennysarc/struct.arc 2008/02/02 22:19:28 1.1 ;; Same license as Arc (mac struct ((name (o pfx (string name "-"))) . slot-defs) (with (maker (coerce (+ "mk-" (string name)) 'sym) defmaker (coerce (+ "mk-def-" (string name)) 'sym) fsd (map [if (acons _) _ (list _ nil)] slot-defs)) `(do (def ,defmaker () (listtab ',fsd)) (def ,maker initargs (aif (keep [~find _ ',(map carif slot-defs)] (map car (pair initargs))) (do (ero "Invalid initargs to " ',maker " supplied: " it ". Allowed are " ',slot-defs) nil) (let self (,defmaker) (map [= (self (car _)) (cadr _)] (pair initargs)) self))) ,@(map (fn (sd) `(def ,(coerce (+ (string pfx) (string sd)) 'sym) (self) (self ',sd))) (map carif slot-defs))))) (prn (macex '(struct (cell c-) awake rule (pulse 0)))) (struct (cell c-) awake rule (pulse 0)) (prn (map [_ (mk-cell 'awake 1 'rule 2 'pulse 3)] (list c-awake c-rule c-pulse))) From ktilton at common-lisp.net Sat Feb 2 23:30:56 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 2 Feb 2008 18:30:56 -0500 (EST) Subject: [cells-cvs] CVS kennysarc Message-ID: <20080202233056.797D6691C5@common-lisp.net> Update of /project/cells/cvsroot/kennysarc In directory clnet:/tmp/cvs-serv27932 Modified Files: struct.arc Log Message: better --- /project/cells/cvsroot/kennysarc/struct.arc 2008/02/02 22:19:28 1.1 +++ /project/cells/cvsroot/kennysarc/struct.arc 2008/02/02 23:30:56 1.2 @@ -3,10 +3,12 @@ (mac struct ((name (o pfx (string name "-"))) . slot-defs) (with (maker (coerce (+ "mk-" (string name)) 'sym) defmaker (coerce (+ "mk-def-" (string name)) 'sym) - fsd (map [if (acons _) _ (list _ nil)] slot-defs)) + ;typdef (cons 'typ name) + ) `(do (def ,defmaker () - (listtab ',fsd)) + ;(prn 'defmakersees ',(keep acons slot-defs)) + (listtab ',(cons (list 'typ name) (keep acons slot-defs)))) (def ,maker initargs (aif (keep [~find _ ',(map carif slot-defs)] (map car (pair initargs))) @@ -17,17 +19,41 @@ ,@(map (fn (sd) `(def ,(coerce (+ (string pfx) (string sd)) 'sym) (self) + (unless (is (self 'typ) ',name) + (prn "This " self " is not a " ',name) + (ero "Wrong struct for accessor")) ;; this was a wild guess and acts weird (self ',sd))) (map carif slot-defs))))) -(prn (macex '(struct (cell c-) awake rule (pulse 0)))) +;;; debug by viewing the macro-expansion... -(struct (cell c-) +;;; (prn (macex '(struct (cell c-) awake rule (pulse 0)))) + +;;; now actually try it.. + +(struct (cell c-) ;; the c- gets prefixed to all accessor names awake rule - (pulse 0)) + (pulse 0)) ;; that zero is a default value + +;;;(prn (mk-def-cell)) + +(= c123 (mk-cell 'awake 1 'rule 2 'pulse 3)) -(prn (map [_ (mk-cell 'awake 1 'rule 2 'pulse 3)] (list c-awake c-rule c-pulse))) +(prn "(1 2 3)? " (map [_ c123] (list c-awake c-rule c-pulse))) + +(prn "(1 2 0)? " (map [_ (mk-cell 'awake 1 'rule 2)] (list c-awake c-rule c-pulse))) + +(struct (cell2) ;; no prefix supplied means you auto-get cell2- + (pulse 0) + awake + rule + ) +(= c2 (mk-cell2 'awake 3 'rule 4)) +(prn "(3 4 0)? " (map [_ c2] (list cell2-awake cell2-rule cell2-pulse))) - \ No newline at end of file +(prn "please fail on wrong type...") + +(prn (c-pulse c2)) + From ktilton at common-lisp.net Sun Feb 3 05:13:37 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 3 Feb 2008 00:13:37 -0500 (EST) Subject: [cells-cvs] CVS kennysarc Message-ID: <20080203051337.BD4C56F23D@common-lisp.net> Update of /project/cells/cvsroot/kennysarc In directory clnet:/tmp/cvs-serv13806 Removed Files: struct.arc Log Message: From ktilton at common-lisp.net Sun Feb 3 05:15:00 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 3 Feb 2008 00:15:00 -0500 (EST) Subject: [cells-cvs] CVS kennysarc2 Message-ID: <20080203051500.2572C6F23F@common-lisp.net> Update of /project/cells/cvsroot/kennysarc2 In directory clnet:/tmp/cvs-serv14068 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import From ktilton at common-lisp.net Sun Feb 3 22:09:14 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 3 Feb 2008 17:09:14 -0500 (EST) Subject: [cells-cvs] CVS kennysarc2 Message-ID: <20080203220914.D796B24004@common-lisp.net> Update of /project/cells/cvsroot/kennysarc2 In directory clnet:/tmp/cvs-serv13489 Added Files: defun.lisp extensions.lisp struct.lisp Log Message: implemented keyword params for defun --- /project/cells/cvsroot/kennysarc2/defun.lisp 2008/02/03 22:09:14 NONE +++ /project/cells/cvsroot/kennysarc2/defun.lisp 2008/02/03 22:09:14 1.1 ;; ;; copyright 2008 by Kenny Tilton ;; ;; Same license as Arc ;; ;; ;; The following is Arc, or is meant to be. ;; The Lisp file extension is for my IDE. ;; n.b. Requires extensions.lisp (mac defun (name params . body) (w/uniq (rtargs) `(def ,name ,rtargs (withs ,(with (reqs nil key? nil opt? nil keys nil opts nil without) (each p params (if (is p '&o) (do (assert (no opt?) "Duplicate &o:" ',params) (assert (no key?) "&k cannot precede &o:" ',params) (= opt? t)) (is p '&k) (do (assert (no key?) "Duplicate &k:" ',params) (= key? t)) key? (push-end p keys) opt? (push-end p opts) (do (assert (~acons p) "Reqd parameters need not be defaulted:" p) (push-end p reqs)))) (with (n -1 kvs (uniq)) (+ (mappend [list _ `(nth ,(++ n) ,rtargs)] reqs) (mappend [list (carif _) `(or (nth ,(++ n) ,rtargs) ,(cadrif _))] opts) (list kvs `(pair (nthcdr ,(++ n) ,rtargs))) (mappend [list (carif _) `(or (alref ,kvs ',(carif _)) ,(cadrif _))] keys) ))) , at body)))) (defun tabc (a b c) ; &opt o1 &key o2) (list a b c)) (prs "test" (tabc 'dog 'cat 3))(prn) (defun tabc-od (a b c &o (d 42)) (list a b c d)) (prs "dog cat 3 nil" (tabc-od 'dog 'cat 3 nil))(prn) (prs "dog cat 3 4" (tabc-od 'dog 'cat 3 4))(prn) (prs "dog cat 3 42" (tabc-od 'dog 'cat 3))(prn) ;;; --- &k feature not yet implemented ------------ (prn (macex '(defun tabc-od-kef (a b c &o (d 42) &k e (f 'go-giants)) (list a b c d e f)))) (defun tabc-od-kef (a b c &o (d 'def-d) &k e (f 'go-giants)) (list a b c d e f)) (prs "dog cat 3 dee nil go-giants" (tabc-od-kef 'dog 'cat 3 'dee))(prn) (prs "dog cat 3 dee rt-eee go-giants" (tabc-od-kef 'dog 'cat 3 'dee 'e 'rt-eee))(prn) (prs "dog cat 3 dee nil ft-ffff" (tabc-od-kef 'dog 'cat 3 'dee 'f 'rt-fff))(prn) ;;;(prn) ;;;(prs "dog cat 3 dee 42" ;;; (tabc-od-ke 'dog 'cat 3 'dee 'e 42)) ;;;(prn) ;;;(prs "dog cat 3 dee go-giants" ;;; (tabc-od-ke 'dog 'cat 3 'dee)) ;;;(prn) ;;;(prs "dog cat 3 def-d go-giants" ;;; (tabc-od-ke 'dog 'cat 3)) ;;;(prn) --- /project/cells/cvsroot/kennysarc2/extensions.lisp 2008/02/03 22:09:14 NONE +++ /project/cells/cvsroot/kennysarc2/extensions.lisp 2008/02/03 22:09:14 1.1 ;; ;; copyright 2008 by Kenny Tilton ;; ;; Same license as Arc ;; ;; ;; The following is Arc, or is meant to be. ;; The Lisp file extension is for my IDE. (def lastcons (seq) (when (acons seq) (if (no (cdr seq)) seq (lastcons (cdr seq))))) (mac push-end (x place) `(if (no ,place) (= ,place (list ,x)) (aif (lastcons ,place) (do (= (cdr it) (cons ,x nil)) ,place)))) (mac assert (c . msg) `(unless ,c (prs "Assert NG:" ',c 'deets: , at msg) (ero "See console for assert failure deets"))) (def cdrif (x) (when (acons x) (cdr x))) (def cadrif (x) (when (acons x) (cadr x))) (def nth (i lst) "Indexed list access but returns NIL if index out of bounds" (let x -1 (some [when (is (++ x) i) _] lst)))--- /project/cells/cvsroot/kennysarc2/struct.lisp 2008/02/03 22:09:14 NONE +++ /project/cells/cvsroot/kennysarc2/struct.lisp 2008/02/03 22:09:14 1.1 ;; ;; copyright 2008 by Kenny Tilton ;; ;; Same license as Arc ;; ;; ;; The following is Arc, or is meant to be. ;; The Lisp file extension is for my IDE. (mac struct ((name (o pfx (string name "-"))) . slot-defs) (with (maker (coerce (+ "mk-" (string name)) 'sym) defmaker (coerce (+ "mk-def-" (string name)) 'sym) ;typdef (cons 'typ name) ) `(do (def ,defmaker () ;(prn 'defmakersees ',(keep acons slot-defs)) (listtab ',(cons (list 'typ name) (keep acons slot-defs)))) (def ,maker initargs (aif (keep [~find _ ',(map carif slot-defs)] (map car (pair initargs))) (do (ero "Invalid initargs to " ',maker " supplied: " it ". Allowed are " ',slot-defs) nil) (let self (,defmaker) (map [= (self (car _)) (cadr _)] (pair initargs)) self))) ,@(map (fn (sd) `(def ,(coerce (+ (string pfx) (string sd)) 'sym) (self) (unless (is (self 'typ) ',name) (prn "This " self " is not a " ',name) (ero "Wrong struct for accessor")) ;; this was a wild guess and acts weird (self ',sd))) (map carif slot-defs))))) ;;; debug by viewing the macro-expansion... ;;; (prn (macex '(struct (cell c-) awake rule (pulse 0)))) ;;; now actually try it.. (struct (cell c-) ;; the c- gets prefixed to all accessor names awake rule (pulse 0)) ;; that zero is a default value ;;;(prn (mk-def-cell)) (= c123 (mk-cell 'awake 1 'rule 2 'pulse 3)) ;; keywords are not prefixed (prn "(1 2 3)? " (map [_ c123] (list c-awake c-rule c-pulse))) (prn "(1 2 0)? " (map [_ (mk-cell 'awake 1 'rule 2)] (list c-awake c-rule c-pulse))) ;;;(struct (cell2) ;; no prefix supplied means you auto-get cell2- ;;; (pulse 0) ;;; awake ;;; rule ;;; ) ;;; ;;;(= c2 (mk-cell2 'awake 3 'rule 4)) ;;; ;;;(prn "(3 4 0)? " (map [_ c2] (list cell2-awake cell2-rule cell2-pulse))) ;;; ;;;(prn "please fail on wrong type...") ;;; ;;;(prn (c-pulse c2)) From phildebrandt at common-lisp.net Fri Feb 8 18:09:31 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Fri, 8 Feb 2008 13:09:31 -0500 (EST) Subject: [cells-cvs] CVS cells-ode Message-ID: <20080208180931.ECB222F10A@common-lisp.net> Update of /project/cells/cvsroot/cells-ode In directory clnet:/tmp/cvs-serv32070 Added Files: bodies.lisp cells-ode.asd collision.lisp core.lisp geoms.lisp joints.lisp mass.lisp objects.lisp ode-compat.lisp package.lisp primitives.lisp simulate.lisp test-c-ode.lisp types.lisp utility.lisp world.lisp Log Message: initial ci --- /project/cells/cvsroot/cells-ode/bodies.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/bodies.lisp 2008/02/08 18:09:31 1.1 (in-package :c-ode) ;;; ;;; body ;;; (def-ode-model body () ((position :type vector) (linear-vel :type vector) (angular-vel :type vector) (quaternion :type quaternion) (force :type vector) (torque :type vector) (mass :type mass :result-arg t) (auto-disable-flag :type bool) (auto-disable-linear-threshold) (auto-disable-angular-threshold) (auto-disable-steps :type int) (auto-disable-time) (finite-rotation-mode :type bool) ; 0 = infinitesimal, 1 = finite (finite-rotation-axis :type vector :result-arg t) (gravity-mode :type bool :initform (c-in t))) (:default-initargs :ode-id (call-ode body-create ((*world* object))))) (defmethod initialize-instance :after ((self body) &rest initargs)) (defmethod ode-destroy ((self body)) (call-ode body-destroy ((self object))) (call-next-method)) (defmethod echo-slots append ((self body)) '(position linear-vel angular-vel quaternion)) ;;; ;;; Forces ;;; ;;; add force or torque (def-ode-method add-force ((self body) (force vector))) (def-ode-method add-torque ((self body) (force vector))) (def-ode-method add-rel-force ((self body) (force vector))) (def-ode-method add-rel-torque ((self body) (force vector))) ;;; add force at a point (def-ode-method add-force-at-pos ((self body) (force vector) (pos vector))) (def-ode-method add-force-at-rel-pos ((self body) (force vector) (pos vector))) (def-ode-method add-rel-force-at-pos ((self body) (force vector) (pos vector))) (def-ode-method add-rel-force-at-rel-pos ((self body) (force vector) (pos vector))) ;;; ;;; coordinate transforms ;;; ;;; get absolute velocity or position for a point (def-ode-method get-rel-point-pos ((self body) (point vector) (result vector))) (def-ode-method get-rel-point-vel ((self body) (point vector) (result vector))) (def-ode-method get-point-vel ((self body) (point vector) (result vector))) ;;; get relative position for a point (def-ode-method get-pos-rel-point ((self body) (point vector) (result vector))) ;;; rotate a vector to/from relative coordinates (def-ode-method vector-to-world ((self body) (point vector) (result vector))) (def-ode-method vector-from-world ((self body) (point vector) (result vector))) ;;; ;;; auto disabling ;;; (def-ode-method enable ((self body))) (def-ode-method disable ((self body))) (def-ode-method is-enabled ((self body)) bool) (def-ode-method set-auto-disable-defaults ((self body))) ;;; ;;; Joint handling ;;; (def-ode-method get-num-joints ((self body)) number) (def-ode-method get-joint ((self body) (index int)) object) --- /project/cells/cvsroot/cells-ode/cells-ode.asd 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/cells-ode.asd 2008/02/08 18:09:31 1.1 (asdf:defsystem :cells-ode :name "cells-ode" :depends-on (:cells :cl-ode :utils-kt :cffi) :serial t :components ((:file "package") (:file "ode-compat") (:file "types" :depends-on ("package")) (:file "core" :depends-on ("types" "ode-compat")) (:file "objects" :depends-on ("core")) (:file "mass" :depends-on ("core")) (:file "world" :depends-on ("objects")) (:file "bodies" :depends-on ("objects")) (:file "geoms" :depends-on ("objects")) (:file "joints" :depends-on ("objects")) (:file "utility" :depends-on ("objects")) (:file "primitives" :depends-on ("geoms" "bodies" "mass")) (:file "collision" :depends-on ("objects")) (:file "simulate" :depends-on ("collision" "objects" "world")) (:file "test-c-ode" :depends-on ("simulate")) ))--- /project/cells/cvsroot/cells-ode/collision.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/collision.lisp 2008/02/08 18:09:31 1.1 ;;; ----------------------------------------------------------------------------------------------- ;;; collision detection ;;; ----------------------------------------------------------------------------------------------- (in-package :c-ode) ;;; ;;; Spaces ;;; (def-ode-model space () ((cleanup :type bool :initform (c-in t)) ; automatic cleanup (num-geoms :type int :read-only t)) ) (defmethod ode-destroy ((self space)) (call-ode space-destroy ((self object))) (call-next-method)) (defmethod echo-slots append ((self space)) '(num-geoms)) ;;; simple space (def-ode-model simple-space (space) () (:default-initargs :ode-id (call-ode simple-space-create (((null-pointer)))))) ;;; hash space (def-ode-model hash-space (space) () (:default-initargs :ode-id (call-ode hash-space-create (((null-pointer)))))) (def-ode-method set-levels ((self hash-space) (minlevel int) (maxlevel int))) ;;; TODO (def-ode-method get-levels) ;; needs multiple return values ;;; quad tree space (def-ode-model quad-tree-space (space) () (:default-initargs :ode-id (error "Use mk-quad-tree-space to create a quad-tree-space"))) (defun mk-quad-tree-space (center extents depth) (make-instance 'quad-tree-space :ode-id (call-ode quad-tree-space-create (((null-pointer)) (center vector) (extents vector) (depth int))))) ;;; ;;; geom/space bookkeeping ;;; (def-ode-method (add-geom :ode-name add) ((self space) (geom object))) (def-ode-method (remove-geom :ode-name remove) ((self space) (geom object))) (def-ode-method (query-geom :ode-name query) ((self space) (geom object)) bool) (def-ode-method get-geom ((self space) (num int)) object) (defmethod geoms ((self space)) (bwhen (num (num-geoms self)) (loop for i from 0 below num collecting (get-geom self i)))) ;;; ;;; collision detection ;;; (defconstant +max-collision-contacts+ 256) (defvar *collision-joint-group* nil "ODE joint group") (def-ode-method (space-collide :ode-name collide) ((self space) data near-collision-callback)) (def-ode-fun space-collide2 ((geom-1 object) (geom-2 object) data near-collision-callback)) (def-ode-fun collide ((geom-1 object) (geom-2 object) (max-contacts int) contact (skip int)) int (format t "~&in collide~%") (let ((res (call-ode-fun))) (format t "~&called collide -- result ~a~%" res) res)) #+nil (collide (,geom-1 ,geom-2 ,max-contacts (foreign-slot-value (mem-aref ,contacts 'ode:contact 0) 'ode:contact 'ode:geom) (foreign-type-size 'ode:contact))) (defmacro do-contacts ((contact geom-1 geom-2 &key (max-contacts +max-collision-contacts+)) &body body) (with-uniqs (contacts num-contacts) `(with-foreign-object (,contacts 'ode:contact ,max-contacts) (let ((,num-contacts (call-ode collide ((,geom-1 object) (,geom-2 object) (,max-contacts int) ((foreign-slot-value (mem-aref ,contacts 'ode:contact 0) 'ode:contact 'ode:geom)) ((foreign-type-size 'ode:contact))) int) )) (dotimes (i ,num-contacts) (let ((,contact (mem-aref ,contacts 'ode:contact i))) (flet ((mk-collision () (attach (mk-contact-joint *collision-joint-group* ,contact) (body ,geom-1) (body ,geom-2)))) , at body))))))) (eval-now! (defun ode-sym (sym) (intern (string sym) :ode)) (defun make-with (type slots-and-types) (multiple-value-bind (slots types) (parse-typed-args slots-and-types) `(defmacro ,(intern-string 'with type) (,type (&optional ,@(mapcar #'(lambda (slot) `(,slot ',(gensym (string slot)))) slots)) &body body) (list 'with-foreign-slots (list ',(mapcar #'ode-sym slots) ,type ',(ode-sym type)) (append (list 'let (list ,@(mapcar #'(lambda (slot type) `(list ,slot ',(make-from-ode type nil (list (ode-sym slot))))) slots types))) body)))))) (defmacro def-with-ode (type (&rest slots-and-types)) (make-with type slots-and-types)) (def-with-ode contact (surface geom (f-dir-1 vector))) (def-with-ode contact-geom ((pos vector) (normal vector) (g-1 object) (g-2 object) (depth number) (side-1 int) (side-2 int))) (defmacro with-surface-parameters ((ode-surface geom-1 geom-2) select &body body) (let ((params '(mu slip-1 slip-2 soft-erp bounce bounce-vel soft-cfm))) (let ((ode-params (mapcar #'(lambda (sym) (intern (string sym) :ode)) params))) (with-uniqs mode `(with-foreign-slots (,(append ode-params '(ode:mode)) ,ode-surface ode:surface-parameters) (let ,(append (list (list mode 0)) params) (macrolet ((select-max (&rest params) `(progn ,@(mapcar #'(lambda (param) `(setf ,param (max (,param ,',geom-1) (,param ,',geom-2)))) ',params)))) ,select) ,@(loop for sym in params for ode-sym in ode-params collecting `(when ,sym (setf ,ode-sym ,@(make-convert sym 'number)) (setf ,mode (logior ,mode ,(intern (format nil "+CONTACT-~a+" (case sym (bounce-vel 'bounce) (mu 'approx-1) (t sym))) :ode))))) (setf ,(intern "MODE" :ode) ,mode) , at body)))))) ;;; ;;; collision detection callback ;;; (defcallback near-collision-callback :void ((data :pointer) (geom-id-1 ode:geom-id) (geom-id-2 ode:geom-id)) (let ((geom-1 (lookup geom-id-1)) (geom-2 (lookup geom-id-2))) (if (or (is-space geom-1) (is-space geom-2)) (space-collide geom-1 geom-2 data (callback near-collision-callback)) (progn (format t "~&Colliding geoms ~a <--> ~a~%" (md-name geom-1) (md-name geom-2)) (do-contacts (contact geom-1 geom-2) (with-contact contact (surface contact-geom friction-dir-1) (with-contact-geom contact-geom (pos normal) (with-surface-parameters (surface geom-1 geom-2) (progn (select-max mu bounce bounce-vel)) (mk-collision))))))))) ;;; ;;; high level collision detection routine (defmacro with-collision ((space) &body body) `(let ((*collision-joint-group* (mk-joint-group (* +max-collision-contacts+ 1000)))) (space-collide ,space (null-pointer) (callback near-collision-callback)) , at body (ode-destroy *collision-joint-group*))) --- /project/cells/cvsroot/cells-ode/core.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/core.lisp 2008/02/08 18:09:31 1.1 (in-package :cells-ode) ;;; ;;; General purpose utilities ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro eval-now! (&body body) `(eval-when (:compile-toplevel :load-toplevel :execute) , at body))) (eval-now! (defun mk-list (var) (if (listp var) var (list var))) (defmacro nconcf (place add) `(setf ,place (nconc (mk-list ,place) (mk-list ,add)))) (defmacro with-uniqs (syms &body body) `(let ,(mapcar #'(lambda (sym) `(,sym (gensym ,(concatenate 'string (string sym) "-")))) (mk-list syms)) , at body)) (defmacro csetf (place value) (with-uniqs newval `(let ((,newval ,value)) (unless (eql ,newval ,place) (setf ,place ,newval))))) (defmacro dohash ((obj hash-table) &body body) `(loop for ,obj being the hash-values of ,hash-table do , at body)) (defun denil (lst) (loop for x in lst if x collect x)) (defun concat (&rest parts) (format nil "~:@(~{~@[~a~#[~:;-~]~]~}~)" (denil parts))) (defun intern-string (&rest strings) (intern (apply #'concat strings)))) ;;; ODE function names (eval-now! (defun setter (name slot) (intern-string name 'set slot)) (defun getter (name slot) (intern-string name 'get slot))) ;;; deactivating an observer ;; later ;;; ;;; ODE model, method, function, call ;;; (defvar *dbg* nil) (defmacro with-dbg (&body body) `(let ((*dbg* t)) , at body)) (eval-now! (defun make-call (fn ret-type args-and-types &optional (self 'self)) (multiple-value-bind (args types) (parse-typed-args args-and-types) (let (par-list result-arg-type) (labels ((call-with (args types) (let ((arg (car args)) (type (car types))) (cond ((not args) (let ((fn-call `(,(intern (string fn) :ode) , at par-list))) (if result-arg-type `(progn ,fn-call result) fn-call))) ((eq arg 'result) (setf result-arg-type type) (nconcf par-list arg) (call-with (rest args) (rest types))) (t (nconcf par-list (make-convert arg type)) (make-with-ode arg type (list (call-with (rest args) (rest types))) self)))))) (let ((fn-call (call-with args types))) (let ((fn-call-ret (bif (return-type (or ret-type result-arg-type)) (make-from-ode return-type (when result-arg-type 'result) (list fn-call)) fn-call))) (with-uniqs result `(if *dbg* (progn (format t ,(format nil "~&~%Calling ~a (~~@{~~a~~#[~~:; ~~]~~}) ... " fn) ,@(remove 'result args)) (let ((,result ,fn-call-ret)) (format t "==> ~a~%" ,result) ,result)) ,fn-call-ret)))))))) (defun canonic-args-list (args-and-types) (mapcar #'mk-list args-and-types)) (defun parse-typed-args (args-and-types) (loop for (arg type) in (canonic-args-list args-and-types) collect arg into args collect type into types finally (return (values args types)))) [110 lines skipped] --- /project/cells/cvsroot/cells-ode/geoms.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/geoms.lisp 2008/02/08 18:09:31 1.1 [275 lines skipped] --- /project/cells/cvsroot/cells-ode/joints.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/joints.lisp 2008/02/08 18:09:31 1.1 [472 lines skipped] --- /project/cells/cvsroot/cells-ode/mass.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/mass.lisp 2008/02/08 18:09:31 1.1 [612 lines skipped] --- /project/cells/cvsroot/cells-ode/objects.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/objects.lisp 2008/02/08 18:09:31 1.1 [732 lines skipped] --- /project/cells/cvsroot/cells-ode/ode-compat.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/ode-compat.lisp 2008/02/08 18:09:31 1.1 [777 lines skipped] --- /project/cells/cvsroot/cells-ode/package.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/package.lisp 2008/02/08 18:09:31 1.1 [787 lines skipped] --- /project/cells/cvsroot/cells-ode/primitives.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/primitives.lisp 2008/02/08 18:09:31 1.1 [810 lines skipped] --- /project/cells/cvsroot/cells-ode/simulate.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/simulate.lisp 2008/02/08 18:09:31 1.1 [862 lines skipped] --- /project/cells/cvsroot/cells-ode/test-c-ode.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/test-c-ode.lisp 2008/02/08 18:09:31 1.1 [928 lines skipped] --- /project/cells/cvsroot/cells-ode/types.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/types.lisp 2008/02/08 18:09:31 1.1 [1092 lines skipped] --- /project/cells/cvsroot/cells-ode/utility.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/utility.lisp 2008/02/08 18:09:31 1.1 [1109 lines skipped] --- /project/cells/cvsroot/cells-ode/world.lisp 2008/02/08 18:09:31 NONE +++ /project/cells/cvsroot/cells-ode/world.lisp 2008/02/08 18:09:31 1.1 [1169 lines skipped] From phildebrandt at common-lisp.net Fri Feb 8 18:19:45 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Fri, 8 Feb 2008 13:19:45 -0500 (EST) Subject: [cells-cvs] CVS cells-ode Message-ID: <20080208181945.BAE2D2F04A@common-lisp.net> Update of /project/cells/cvsroot/cells-ode In directory clnet:/tmp/cvs-serv1675 Modified Files: joints.lisp Log Message: fixed joints --- /project/cells/cvsroot/cells-ode/joints.lisp 2008/02/08 18:09:31 1.1 +++ /project/cells/cvsroot/cells-ode/joints.lisp 2008/02/08 18:19:45 1.2 @@ -49,7 +49,7 @@ (angle-rate :type number :read-only t)) (:default-initargs :ode-id (call-ode joint-create-hinge ((*world* object) ((null-pointer)))))) -#+broken +#+slider-fixed (def-ode-model (slider-joint :ode-class joint :ode-joint slider :joint-axes 2) (joint) ((axis :type vector :result-arg t :auto-update nil) (position :type number :read-only t) @@ -78,26 +78,27 @@ (anglerate2 :type number :read-only t)) (:default-initargs :ode-id (call-ode joint-create-hinge2 ((*world* object) ((null-pointer)))))) -#+broken -(defmodel a-motor-axis () - ((axis :initarg :axis :accessor axis :initform (c-in #(1 0 0))) - (angle :initarg :angle :accessor angle :initform (c-in 0)) - (relative-to :initarg :relative-to :accessor relative-to :initform (c-in :body1)) - #+future-ode (rate :initarg :rate :accessor :rate :initform (c-in 0)) - (num :initarg :num :reader num) - (owner :initarg :owner :initform (error "need to supply :owner for a-motor-axis") :reader owner))) - -(def-ode-model (a-motor-joint :ode-class joint :ode-joint a-motor :joint-axes 2) (joint) - ((mode :type int :auto-update nil :initform (c-in ode:+a-motor-user+)) ; ode:+a-motor-user+ or ode:+a-motor-euler+ - (num-axes :type int :auto-update nil :initform (c-in 0)) - (axes :ode nil :initform (c? (coerce - (let (res) - (dotimes (i (^num-axes) res) - (push (make-instance 'a-motor-axis - :owner self - :num i) res)) - (nreverse res)) 'vector)))) ; a vector of num-axes a-motor-axis models - (:default-initargs :ode-id (call-ode joint-create-a-motor ((*world* object) ((null-pointer)))))) +#+a-motor-fixed +(progn + (defmodel a-motor-axis () + ((axis :initarg :axis :accessor axis :initform (c-in #(1 0 0))) + (angle :initarg :angle :accessor angle :initform (c-in 0)) + (relative-to :initarg :relative-to :accessor relative-to :initform (c-in :body1)) + #+future-ode (rate :initarg :rate :accessor :rate :initform (c-in 0)) + (num :initarg :num :reader num) + (owner :initarg :owner :initform (error "need to supply :owner for a-motor-axis") :reader owner))) + + (def-ode-model (a-motor-joint :ode-class joint :ode-joint a-motor :joint-axes 2) (joint) + ((mode :type int :auto-update nil :initform (c-in ode:+a-motor-user+)) ; ode:+a-motor-user+ or ode:+a-motor-euler+ + (num-axes :type int :auto-update nil :initform (c-in 0)) + (axes :ode nil :initform (c? (coerce + (let (res) + (dotimes (i (^num-axes) res) + (push (make-instance 'a-motor-axis + :owner self + :num i) res)) + (nreverse res)) 'vector)))) ; a vector of num-axes a-motor-axis models + (:default-initargs :ode-id (call-ode joint-create-a-motor ((*world* object) ((null-pointer))))))) ;;; ;;; contact joint @@ -122,55 +123,54 @@ (defmethod bodies ((self joint)) (list (get-body self 0) (get-body self 1))) -;;; -;;; TODO set/get feedback -;;; (def-ode-fun are-connected ((body1 object) (body2 object)) bool) (def-ode-fun are-connected-excluding ((body1 object) (body2 object) (joint-type int)) bool) ;;; AMotor stuff -(define-constant +a-motor-axis-rel+ '(:global :body1 :body2)) - -(def-ode-method set-a-motor-axis ((self a-motor-joint joint) (axis-num int) (relative-to int) (axis vector)) - nil - (let ((relative-to (or (cl:position relative-to +a-motor-axis-rel+) - (error "axis-X-rel has to be one of :global, :body1, :body2 (and not ~a)" relative-to)))) - (call-ode-method))) - -(def-ode-method get-a-motor-axis ((self a-motor-joint joint) (axis-num int) (result vector))) -(def-ode-method get-a-motor-axis-rel ((self a-motor-joint joint) (axis-num int)) - int - (nth (call-ode-method) +a-motor-axis-rel+)) +#+a-motor-fixed +(progn + (define-constant +a-motor-axis-rel+ '(:global :body1 :body2)) + + (def-ode-method set-a-motor-axis ((self a-motor-joint joint) (axis-num int) (relative-to int) (axis vector)) + nil + (let ((relative-to (or (cl:position relative-to +a-motor-axis-rel+) + (error "axis-X-rel has to be one of :global, :body1, :body2 (and not ~a)" relative-to)))) + (call-ode-method))) + + (def-ode-method get-a-motor-axis ((self a-motor-joint joint) (axis-num int) (result vector))) + (def-ode-method get-a-motor-axis-rel ((self a-motor-joint joint) (axis-num int)) + int + (nth (call-ode-method) +a-motor-axis-rel+)) -(def-ode-method set-a-motor-angle ((self a-motor-joint joint) (axis-num int) (angle number))) -(def-ode-method get-a-motor-angle ((self a-motor-joint joint) (axis-num int)) number) + (def-ode-method set-a-motor-angle ((self a-motor-joint joint) (axis-num int) (angle number))) + (def-ode-method get-a-motor-angle ((self a-motor-joint joint) (axis-num int)) number) -#+future-ode (def-ode-method get-a-motor-angle-rate ((self a-motor-joint joint) (axis-num int)) number) + #+future-ode (def-ode-method get-a-motor-angle-rate ((self a-motor-joint joint) (axis-num int)) number) ;;; PH 02.2008 -- this is not supported in ODE 0.8 ;;; AMotor cellified -(defobserver axis ((self a-motor-axis) newval) - (when newval - (set-a-motor-axis (owner self) (num self) (relative-to self) newval))) - -(defobserver relative-to ((self a-motor-axis) newval) - (when newval - (set-a-motor-axis (owner self) (num self) newval (axis self)))) - -(defobserver angle ((self a-motor-axis) newval) - (when newval - (set-a-motor-angle (owner self) (num self) newval))) - -(defmethod update :after ((self a-motor-joint)) - (loop for num from 0 below (num-axes self) - do (with-accessors ((axis axis) (angle angle) #+future-ode (rate rate)) - (aref (axes self) num) - (setf axis (get-a-motor-axis self num) - angle (get-a-motor-angle self num)) - #+future-ode (setf rate (get-a-motor-angle-rate self num))))) + (defobserver axis ((self a-motor-axis) newval) + (when newval + (set-a-motor-axis (owner self) (num self) (relative-to self) newval))) + + (defobserver relative-to ((self a-motor-axis) newval) + (when newval + (set-a-motor-axis (owner self) (num self) newval (axis self)))) + + (defobserver angle ((self a-motor-axis) newval) + (when newval + (set-a-motor-angle (owner self) (num self) newval))) + + (defmethod update :after ((self a-motor-joint)) + (loop for num from 0 below (num-axes self) + do (with-accessors ((axis axis) (angle angle) #+future-ode (rate rate)) + (aref (axes self) num) + (setf axis (get-a-motor-axis self num) + angle (get-a-motor-angle self num)) + #+future-ode (setf rate (get-a-motor-angle-rate self num)))))) ;;; TODO: Add Torque directly From phildebrandt at common-lisp.net Fri Feb 8 18:25:59 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Fri, 8 Feb 2008 13:25:59 -0500 (EST) Subject: [cells-cvs] CVS cells-ode Message-ID: <20080208182559.3C7E3610BC@common-lisp.net> Update of /project/cells/cvsroot/cells-ode In directory clnet:/tmp/cvs-serv4493 Modified Files: test-c-ode.lisp world.lisp Log Message: fixed joint demo and gave environment a name --- /project/cells/cvsroot/cells-ode/test-c-ode.lisp 2008/02/08 18:09:31 1.1 +++ /project/cells/cvsroot/cells-ode/test-c-ode.lisp 2008/02/08 18:25:59 1.2 @@ -42,8 +42,6 @@ (make-instance 'geom-box :md-name :geom2 :size #(.1 .1 .1) :body (obj :body2)) (make-instance 'hinge-joint :md-name :joint :axis #(0 1 0) :anchor #(10 1.2 .5)) - (make-instance 'a-motor-joint :md-name :motor :num-axes 1) - (Attach (obj :motor) (obj :body1) (obj :body2)) (attach (obj :joint) (obj :body1) (obj :body2))) --- /project/cells/cvsroot/cells-ode/world.lisp 2008/02/08 18:09:31 1.1 +++ /project/cells/cvsroot/cells-ode/world.lisp 2008/02/08 18:25:59 1.2 @@ -12,7 +12,7 @@ (:default-initargs :ode-id (null-pointer))) -(defparameter *environment* (make-instance 'environment) "static environment") +(defparameter *environment* (make-instance 'environment :md-name :environment) "static environment") ;;; ;;; world From phildebrandt at common-lisp.net Sat Feb 9 14:02:17 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sat, 9 Feb 2008 09:02:17 -0500 (EST) Subject: [cells-cvs] CVS cells-ode Message-ID: <20080209140217.BE56570215@common-lisp.net> Update of /project/cells/cvsroot/cells-ode In directory clnet:/tmp/cvs-serv23636 Modified Files: collision.lisp mass.lisp objects.lisp simulate.lisp types.lisp world.lisp Log Message: some more fixes --- /project/cells/cvsroot/cells-ode/collision.lisp 2008/02/09 11:18:12 1.2 +++ /project/cells/cvsroot/cells-ode/collision.lisp 2008/02/09 14:02:16 1.3 @@ -47,9 +47,11 @@ (:default-initargs :ode-id (error "Use mk-quad-tree-space to create a quad-tree-space"))) -(defun mk-quad-tree-space (center extents depth) - (make-instance 'quad-tree-space - :ode-id (call-ode quad-tree-space-create (((null-pointer)) (center vector) (extents vector) (depth int))))) +(defun mk-quad-tree-space (center extents depth &rest initargs) + (apply #'make-instance + 'quad-tree-space + :ode-id (call-ode quad-tree-space-create (((null-pointer)) (center vector-3-ptr) (extents vector-3-ptr) (depth int))) + initargs)) ;;; @@ -85,14 +87,6 @@ (format t "~&called collide -- result ~a~%" res) res)) -;;; kt> ACL still complains about the comma even tho this is featured out!!! -;;; -;;;#+bbzzt (collide (,geom-1 -;;; ,geom-2 -;;; ,max-contacts -;;; (foreign-slot-value (mem-aref ,contacts 'ode:contact 0) 'ode:contact 'ode:geom) -;;; (foreign-type-size 'ode:contact))) - (defmacro do-contacts ((contact geom-1 geom-2 &key (max-contacts +max-collision-contacts+)) &body body) (with-uniqs (contacts num-contacts) `(with-foreign-object (,contacts 'ode:contact ,max-contacts) @@ -115,8 +109,10 @@ (defun make-with (type slots-and-types) (multiple-value-bind (slots types) (parse-typed-args slots-and-types) `(defmacro ,(intern-string 'with type) (,type (&optional ,@(mapcar #'(lambda (slot) `(,slot ',(gensym (string slot)))) slots)) &body body) + (declare (ignorable , at slots)) (list 'with-foreign-slots (list ',(mapcar #'ode-sym slots) ,type ',(ode-sym type)) (append (list 'let (list ,@(mapcar #'(lambda (slot type) `(list ,slot ',(make-from-ode type nil (list (ode-sym slot))))) slots types))) + (list (list 'declare (append '(ignorable) ,(append '(list) slots)))) body)))))) (defmacro def-with-ode (type (&rest slots-and-types)) @@ -133,7 +129,10 @@ (with-uniqs mode `(with-foreign-slots (,(append ode-params '(ode:mode)) ,ode-surface ode:surface-parameters) (let ,(append (list (list mode 0)) params) - (macrolet ((select-max (&rest params) `(progn ,@(mapcar #'(lambda (param) `(setf ,param (max (,param ,',geom-1) (,param ,',geom-2)))) ',params)))) + (macrolet ((select-max (&rest params) `(progn ,@(mapcar #'(lambda (param) `(setf ,param (max (,param ,',geom-1) (,param ,',geom-2)))) params))) + (select-avg (&rest params) `(progn ,@(mapcar #'(lambda (param) `(setf ,param (/ (+ (,param ,',geom-1) (,param ,',geom-2)) 2))) params))) + (select-min (&rest params) `(progn ,@(mapcar #'(lambda (param) `(setf ,param (min (,param ,',geom-1) (,param ,',geom-2)))) params))) +) ,select) ,@(loop for sym in params for ode-sym in ode-params collecting `(when ,sym @@ -162,7 +161,9 @@ (with-contact contact (surface contact-geom friction-dir-1) (with-contact-geom contact-geom (pos normal) (with-surface-parameters (surface geom-1 geom-2) - (progn (select-max mu bounce bounce-vel)) + (progn (select-min mu) + (select-avg bounce-vel) + (select-max bounce)) (mk-collision))))))))) ;;; --- /project/cells/cvsroot/cells-ode/mass.lisp 2008/02/09 11:18:12 1.2 +++ /project/cells/cvsroot/cells-ode/mass.lisp 2008/02/09 14:02:17 1.3 @@ -122,8 +122,8 @@ (defobserver length ((self cylinder-mass) newval) (set-cylinder-total self (mass self) (mass-dir (orientation self)) (radius self) newval)) -;;;(defmethod echo-slots append ((self capsule-mass)) kt> duplicates same above -;;; '(radius orientation length)) +(defmethod echo-slots append ((self cylinder-mass)) + '(radius orientation length)) ;;; box mass --- /project/cells/cvsroot/cells-ode/objects.lisp 2008/02/09 11:18:12 1.2 +++ /project/cells/cvsroot/cells-ode/objects.lisp 2008/02/09 14:02:17 1.3 @@ -65,7 +65,6 @@ (defmethod update ((self ode-object)) "called to update cells model after step" - (declare (ignorable self)) ;; kt> ACL does not consider this ignored since the method param was specialized self) (defmethod ode-destroy ((self ode-object)) --- /project/cells/cvsroot/cells-ode/simulate.lisp 2008/02/09 11:18:12 1.2 +++ /project/cells/cvsroot/cells-ode/simulate.lisp 2008/02/09 14:02:17 1.3 @@ -30,8 +30,6 @@ ;;; stepping ;;; -(def-ode-method step-fast1 ((self world) (step-size number) (max-iterations int))) -;;;(def-ode-method step ((self world) (step-size number))) kt> same in world.lisp (defun ode-step (&key (step-size 0.01) (diag t) (fast-step nil) (max-iterations 20)) "steps the world by step-size seconds" --- /project/cells/cvsroot/cells-ode/types.lisp 2008/02/09 11:18:12 1.2 +++ /project/cells/cvsroot/cells-ode/types.lisp 2008/02/09 14:02:17 1.3 @@ -8,7 +8,7 @@ (defconstant +precision+ 'single-float) (define-constant +infinity+ 1.0e8 "prevent overflows") -(ukt:eval-now! +(eval-now! ;;; unknown type (defmethod make-with-ode (name type body &optional (self 'self)) (declare (ignorable self name)) @@ -124,6 +124,19 @@ `(let ((ptr (progn , at body))) ,rest)))) + ;;; vector-3-ptr + + (defmethod make-with-ode (name (type (eql 'vector-3-ptr)) body &optional (self 'self)) + (declare (ignorable self name)) + (let ((vec (intern-string name type))) + `(with-foreign-object (,vec 'ode:real 3) + ,@(loop for i from 0 below 3 + collect `(setf (mem-aref ,vec 'ode:real ,i) (coerce (aref ,name ,i) +precision+))) + , at body))) + + (defmethod make-convert (name (type (eql 'vector-3-ptr))) + `(,(intern-string name type))) + ;;; quaternion --- /project/cells/cvsroot/cells-ode/world.lisp 2008/02/09 11:18:12 1.3 +++ /project/cells/cvsroot/cells-ode/world.lisp 2008/02/09 14:02:17 1.4 @@ -10,9 +10,10 @@ (def-ode-model environment (collideable-object) () (:default-initargs - :ode-id (null-pointer))) + :ode-id (null-pointer) + :md-name :environment)) -(defparameter *environment* (make-instance 'environment :md-name :environment) "static environment") +(defparameter *environment* (make-instance 'environment) "static environment") ;;; ;;; world @@ -37,7 +38,8 @@ (contact-max-correcting-vel :auto-update nil) (contact-surface-layer :auto-update nil)) (:default-initargs - :ode-id (call-ode world-create ()))) + :ode-id (call-ode world-create ()) + :md-name :world)) (defmethod initialize-instance :after ((self world) &rest initargs) (declare (ignore initargs)) @@ -51,9 +53,7 @@ (def-ode-method impulse-to-force ((self world) (step-size number) (impulse vector) (result vector))) (def-ode-method step ((self world) (step-size number))) - -(def-ode-method quick-step ((self world) (step-size number))) - +(def-ode-method step-fast1 ((self world) (step-size number) (max-iterations int))) From phildebrandt at common-lisp.net Mon Feb 11 14:47:31 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Mon, 11 Feb 2008 09:47:31 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080211144731.1714449087@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv25158 Modified Files: defmodel.lisp Log Message: sbcl fixes (forward declaration of reader methods, eval-when) --- /project/cells/cvsroot/cells/defmodel.lisp 2008/02/01 15:52:49 1.14 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/02/11 14:47:30 1.15 @@ -46,7 +46,9 @@ `(eval-when (:compile-toplevel :execute :load-toplevel) (unless (macro-function ',deriver-fn) (defmacro ,deriver-fn () - `(,',reader-fn self)))))))))) + `(,',reader-fn self))) + #+sbcl (unless (fboundp ',reader-fn) + (defgeneric ,reader-fn (slot)))))))))) ; ; ------- defclass --------------- (^slot-value ,model ',',slotname) @@ -98,9 +100,8 @@ (let* ((reader-fn (or reader accessor)) (writer-fn (or writer accessor)) ) - `(progn + `(eval-when (#+sbcl :load-toplevel :execute) ; ph -- prevent sbcl warning (setf (md-slot-cell-type ',class ',slotname) ,cell) - ,(when owning `(setf (md-slot-owning ',class ',slotname) ,owning)) ,(when reader-fn From phildebrandt at common-lisp.net Mon Feb 11 14:47:31 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Mon, 11 Feb 2008 09:47:31 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080211144731.488EE4F01A@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv25158/utils-kt Modified Files: core.lisp Log Message: sbcl fixes (forward declaration of reader methods, eval-when) --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/02/01 15:52:49 1.6 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/02/11 14:47:31 1.7 @@ -23,7 +23,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro export! (&rest symbols) - `(eval-when ( :compile-toplevel :load-toplevel :execute) + `(eval-when (:compile-toplevel :load-toplevel :execute) (export ',symbols)))) (eval-now! From phildebrandt at common-lisp.net Mon Feb 11 14:48:09 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Mon, 11 Feb 2008 09:48:09 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080211144809.DC3024F10D@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv25270 Added Files: .cvsignore Log Message: added a cvsignore --- /project/cells/cvsroot/cells/.cvsignore 2008/02/11 14:48:09 NONE +++ /project/cells/cvsroot/cells/.cvsignore 2008/02/11 14:48:09 1.1 cells.fasl cell-types.fasl constructors.fasl defmodel.fasl defpackage.fasl family.fasl family-values.fasl fm-utilities.fasl initialize.fasl integrity.fasl link.fasl md-slot-value.fasl md-utilities.fasl model-object.fasl propagate.fasl slot-utilities.fasl synapse.fasl synapse-types.fasl test-propagation.fasl trc-eko.fasl From ktilton at common-lisp.net Thu Feb 14 12:30:22 2008 From: ktilton at common-lisp.net (ktilton) Date: Thu, 14 Feb 2008 07:30:22 -0500 (EST) Subject: [cells-cvs] CVS kennysarc2 Message-ID: <20080214123022.EDC905C181@common-lisp.net> Update of /project/cells/cvsroot/kennysarc2 In directory clnet:/tmp/cvs-serv15889 Added Files: cells-1.arc Log Message: Trying to get warning-free build --- /project/cells/cvsroot/kennysarc2/cells-1.arc 2008/02/14 12:30:22 NONE +++ /project/cells/cvsroot/kennysarc2/cells-1.arc 2008/02/14 12:30:22 1.1 ;;; Utilities ;;; --------- (def prt args (apply prs args) (prn)) (mac prun (banner . forms) `(do (prn ,banner) (prn '(do , at forms)) (prn) , at forms)) (prun " Cells ----- Let's start with the moral equivalent of a C++ member function, or at least I think that's what they call it. I mean what looks like a stored data member or slot of an attribute of an object that is in fact implemented as a function of that object. An example would be having a rectangle object with data members where one could store length and width and then have an area attribute implemented (in C++) as: area = this.length * this.width; Aside from saving a little memory, one gets a guarantee that the area will always be consistent with the length and width, which is not the case if one is writing code that says oh gosh I just changed the length I better go change the area. As our 'application pushing down on the core' we'll use my favorite, a boiler. " (= b* (obj outside-temp 72 on? [< _!outside-temp 50]))) (prun " No, the outside temp is not an attribute of a boiler, we're just keeping things in one table as a convenience until we get the ball rolling, later on we'll deal with multiple objects. That anonymous function above boils down to: If the outside temp is less than 50, then turn on the boiler, otherwise turn it off. First, let's see if the rule works (not a big accomplishment) " (prt 'boiler b*!outside-temp (if (b*!on? b*) 'on 'off))) (prun " Good, now change temp to 32 and see if the boiler comes on: " (= b*!outside-temp 32) (prt 'boiler b*!outside-temp (if (b*!on? b*) 'on 'off))) (prun " -> boiler 32 on Super. Now let's hide the fact that on? is a function behind a reader function: " (def on? (i) (i!on? i))) ;;; and ease inspection: (def pr-boiler (b) (prt 'boiler 'temp b*!outside-temp (if (on? b) 'on 'off))) (prun " Test new slot reader, setting temp high enough this time so that the boiler should go off: " (= b*!outside-temp 80) (pr-boiler b*)) (prn " Super. But we want more flexibility than having an attribute always defined by a function. Maybe we just want to store nil or t in on? and maintain it as usual, via assignment. Now on? can no longer be assumed to be a function. Fortunately we already have it behind a reader in our burgeoning little OO system, so we just need to enhance that (and get a redefinition warning): ") (def on? (i) (awhen i!on? (if (isa it 'fn) (it i) it))) (prun " Can a slot of a different boiler be maintained by other code? Start with a hard-coded NIL for on?... " (= b* (obj outside-temp -10 on? nil)) (pr-boiler b*)) (prun " Now assign t to on? " (= b*!on? t) ; We'll hide the assignment implementation later. (pr-boiler b*)) (prun " Super. We will want all our attributes to work this way, so we may as well generalize the on? behavior now: " (def slot-value (i slot-name) ;; i is like self ala Smalltalk (awhen i.slot-name (if (isa it 'fn) (it i) it)))) (mac defslot (name) `(def ,name (i) (slot-value i ',name))) (defslot outside-temp) (defslot on?) (defslot inside-temp) ;; Let's start elaborating the model (def pr-boiler (i) (prt 'boiler 'outside-temp (outside-temp i) (if (on? i) 'on 'off) 'inside-temp (inside-temp i))) (prun " And test: " (= b* (obj outside-temp 20 on? nil inside-temp [if (on? _) 72 _!outside-temp])) (pr-boiler b*)) (prun " Super. Now let's bring back the automatic boiler: " (= b*!on? [< _!outside-temp 50])) (prun " Step temperature up from freezing to torrid. " (loop (= b*!outside-temp 30) (< b*!outside-temp 100) (= b*!outside-temp (+ b*!outside-temp 10)) (pr-boiler b*))) ;;; Super. But we need an air conditioner. And let's get more realistic about the model (= outside* (obj temp 20)) (defslot temp) (= furnace* (obj on? [< (temp outside*) 50])) (= ac* (obj on? [> (temp outside*) 75])) ;; air conditioner (= inside* [if (on? furnace*) 72 (on? ac*) 68 (temp outside*)]) (def dumpworld () (prt "outside" (temp outside*)) (prt "furnace" (if (on? furnace*) 'on 'off)) (prt "a/c" (if (on? ac*) 'on 'off)) (prt "inside" (temp inside*))) ;;;(prun " ;;;Step temperature up from freezing to torrid, but with an air-conditioner ;;;" ;;; (loop (= outside*!temp 30) (< outside*!temp 100) (= outside*!temp (+ outside*!temp 10)) ;;; (prn) ;;; (dumpworld))) ;;; Nice. We have built a working model that runs by itself given simple declarative ;;; rules, meaning we state the rules and an engine sees to it that the model ;;; runs. But we have a problem. Let's add a debug option to our slots: (def slot-value (i slot-name (o debug)) ;; i is like self ala Smalltalk (awhen i.slot-name (if (isa it 'fn) (do (when debug (prt "Running the rule for slot" slot-name)) (let result (it i) (when debug (prt "...slot" slot-name "is" result)) result)) it))) (mac defslot (name (o debug)) `(def ,name (i) (slot-value i ',name ,debug))) (defslot on? t) ;;;(prun " ;;;Same test tracing the on? slots ;;;" ;;; (loop (= outside*!temp 30) (< outside*!temp 100) (= outside*!temp (+ outside*!temp 10)) ;;; (prn) ;;; (dumpworld))) (prun " Looks OK, but watch what happens even if nothing is going on: " (dumpworld)) ;;; Ah, the downside of the functional paradigm: the code runs and runs. ;;; For simple functions that is no problem, but if we build ;;; an entire application this way things bog down (we learned the usual way). ;;; ;;; What we need to do is cache a calculation and then return the cached ;;; result when queried a second time. But then when do we refresh the ;;; cache? Answer: when we have to to stay current with the changing ;;; world arounds us, more prosaically when one of the values used to ;;; calculate the current cache value has changed. ;;; ;;; So we need to keep track of who uses whom in their calculations, ;;; and when one value changes notify its users that they need to ;;; recalculate. ;;; ;;; Next time. From ktilton at common-lisp.net Thu Feb 14 19:51:07 2008 From: ktilton at common-lisp.net (ktilton) Date: Thu, 14 Feb 2008 14:51:07 -0500 (EST) Subject: [cells-cvs] CVS kennysarc2 Message-ID: <20080214195107.C98405F07B@common-lisp.net> Update of /project/cells/cvsroot/kennysarc2 In directory clnet:/tmp/cvs-serv27115 Modified Files: extensions.lisp Log Message: --- /project/cells/cvsroot/kennysarc2/extensions.lisp 2008/02/03 22:09:14 1.1 +++ /project/cells/cvsroot/kennysarc2/extensions.lisp 2008/02/14 19:51:04 1.2 @@ -32,4 +32,5 @@ (def nth (i lst) "Indexed list access but returns NIL if index out of bounds" (let x -1 - (some [when (is (++ x) i) _] lst))) \ No newline at end of file + (some [when (is (++ x) i) _] lst))) + From ktilton at common-lisp.net Sat Feb 16 05:04:56 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 16 Feb 2008 00:04:56 -0500 (EST) Subject: [cells-cvs] CVS cells/cells-test Message-ID: <20080216050456.4C1314D043@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv7833/cells-test Modified Files: test.lisp Log Message: --- /project/cells/cvsroot/cells/cells-test/test.lisp 2007/11/30 22:29:06 1.11 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2008/02/16 05:04:55 1.12 @@ -51,7 +51,6 @@ #| do list --- can we lose the special handling of the .kids slot? -- test drifters (and can they be handled without creating a special subclass for them?) From ktilton at common-lisp.net Sat Feb 16 05:04:56 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 16 Feb 2008 00:04:56 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080216050456.A50CD4D054@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv7833 Modified Files: defmodel.lisp Log Message: --- /project/cells/cvsroot/cells/defmodel.lisp 2008/02/11 14:47:30 1.15 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/02/16 05:04:56 1.16 @@ -24,75 +24,75 @@ (eval-when (:compile-toplevel :execute :load-toplevel) (setf (get ',class :cell-types) nil) (setf (get ',class 'slots-excluded-from-persistence) - ',(loop for slotspec in slotspecs - unless (and (getf (cdr slotspec) :ps t) - (getf (cdr slotspec) :persistable t)) - collect (car slotspec)))) + ',(loop for slotspec in slotspecs + unless (and (getf (cdr slotspec) :ps t) + (getf (cdr slotspec) :persistable t)) + collect (car slotspec)))) ;; define slot macros before class so they can appear in ;; initforms and default-initargs ,@(delete nil - (loop for slotspec in slotspecs - nconcing (destructuring-bind - (slotname &rest slotargs - &key (cell t) owning (accessor slotname) reader - &allow-other-keys) - slotspec + (loop for slotspec in slotspecs + nconcing (destructuring-bind + (slotname &rest slotargs + &key (cell t) owning (accessor slotname) reader + &allow-other-keys) + slotspec - (declare (ignorable slotargs owning)) - (list - (when cell - (let* ((reader-fn (or reader accessor)) - (deriver-fn (intern$ "^" (symbol-name reader-fn)))) - `(eval-when (:compile-toplevel :execute :load-toplevel) - (unless (macro-function ',deriver-fn) - (defmacro ,deriver-fn () - `(,',reader-fn self))) - #+sbcl (unless (fboundp ',reader-fn) - (defgeneric ,reader-fn (slot)))))))))) + (declare (ignorable slotargs owning)) + (list + (when cell + (let* ((reader-fn (or reader accessor)) + (deriver-fn (intern$ "^" (symbol-name reader-fn)))) + `(eval-when (:compile-toplevel :execute :load-toplevel) + (unless (macro-function ',deriver-fn) + (defmacro ,deriver-fn () + `(,',reader-fn self))) + #+sbcl (unless (fboundp ',reader-fn) + (defgeneric ,reader-fn (slot)))))))))) - ; - ; ------- defclass --------------- (^slot-value ,model ',',slotname) - ; + ; + ; ------- defclass --------------- (^slot-value ,model ',',slotname) + ; (progn (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class - ,(mapcar (lambda (s) - (list* (car s) - (let ((ias (cdr s))) - (remf ias :persistable) - (remf ias :ps) - ;; We handle accessor below - (when (getf ias :cell t) - (remf ias :reader) - (remf ias :writer) - (remf ias :accessor)) - (remf ias :cell) - (remf ias :owning) - (remf ias :unchanged-if) - ias))) (mapcar #'copy-list slotspecs)) - (:documentation - ,@(or (cdr (find :documentation options :key #'car)) - '("chya"))) - (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this - ,@(cdr (find :default-initargs options :key #'car))) - (:metaclass ,(or (cadr (find :metaclass options :key #'car)) - 'standard-class))) + ,(mapcar (lambda (s) + (list* (car s) + (let ((ias (cdr s))) + (remf ias :persistable) + (remf ias :ps) + ;; We handle accessor below + (when (getf ias :cell t) + (remf ias :reader) + (remf ias :writer) + (remf ias :accessor)) + (remf ias :cell) + (remf ias :owning) + (remf ias :unchanged-if) + ias))) (mapcar #'copy-list slotspecs)) + (:documentation + ,@(or (cdr (find :documentation options :key #'car)) + '("chya"))) + (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this + ,@(cdr (find :default-initargs options :key #'car))) + (:metaclass ,(or (cadr (find :metaclass options :key #'car)) + 'standard-class))) (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) (declare (ignore slot-names iargs)) ,(when (and directsupers (not (member 'model-object directsupers))) - `(unless (typep self 'model-object) - (error "If no superclass of ~a inherits directly + `(unless (typep self 'model-object) + (error "If no superclass of ~a inherits directly or indirectly from model-object, model-object must be included as a direct super-class in the defmodel form for ~a" ',class ',class)))) - ; - ; slot accessors once class is defined... - ; + ; + ; slot accessors once class is defined... + ; ,@(mapcar (lambda (slotspec) (destructuring-bind - (slotname &rest slotargs - &key (cell t) owning unchanged-if (accessor slotname) reader writer type - &allow-other-keys) + (slotname &rest slotargs + &key (cell t) owning unchanged-if (accessor slotname) reader writer type + &allow-other-keys) slotspec (declare (ignorable slotargs)) @@ -100,27 +100,27 @@ (let* ((reader-fn (or reader accessor)) (writer-fn (or writer accessor)) ) - `(eval-when (#+sbcl :load-toplevel :execute) ; ph -- prevent sbcl warning + `(progn ;; eval-when (#+sbcl :load-toplevel :execute) ; ph -- prevent sbcl warning (setf (md-slot-cell-type ',class ',slotname) ,cell) ,(when owning - `(setf (md-slot-owning ',class ',slotname) ,owning)) + `(setf (md-slot-owning ',class ',slotname) ,owning)) ,(when reader-fn - `(defmethod ,reader-fn ((self ,class)) - (md-slot-value self ',slotname))) + `(defmethod ,reader-fn ((self ,class)) + (md-slot-value self ',slotname))) ,(when writer-fn - `(defmethod (setf ,writer-fn) (new-value (self ,class)) - (setf (md-slot-value self ',slotname) - ,(if type - `(coerce new-value ',type) - 'new-value)))) + `(defmethod (setf ,writer-fn) (new-value (self ,class)) + (setf (md-slot-value self ',slotname) + ,(if type + `(coerce new-value ',type) + 'new-value)))) ,(when unchanged-if - `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) + `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) ) )) )) - slotspecs) + slotspecs) (find-class ',class)))) (defun defmd-canonicalize-slot (slotname From ktilton at common-lisp.net Sat Feb 16 05:04:57 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 16 Feb 2008 00:04:57 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080216050457.1B2E74D054@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv7833/utils-kt Modified Files: detritus.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/01/29 23:30:06 1.18 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/02/16 05:04:56 1.19 @@ -147,27 +147,48 @@ #+allegro -(defun line-count (path &optional show-files (depth 0)) +(defun line-count (path &optional show-files (max-depth most-positive-fixnum) no-semis (depth 0)) (cond ((excl:file-directory-p path) - (when show-files - (format t "~&~v,8t~a counts:" depth (pathname-directory path))) - (let ((directory-lines - (loop for file in (directory path :directories-are-files nil) - for lines = (line-count file show-files (1+ depth)) - when (and show-files (plusp lines)) - do (bwhen (fname (pathname-name file)) - (format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines)) - summing lines))) - (unless (zerop directory-lines) - (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines)) - directory-lines)) + (if (>= depth max-depth) + (progn + (format t "~&~v,8t~a dir too deep:" depth (pathname-directory path)) + 0) + (progn + (when show-files + (format t "~&~v,8t~a counts:" depth (pathname-directory path))) + (let ((directory-lines + (loop for file in (directory path :directories-are-files nil) + for lines = (line-count file show-files max-depth no-semis (1+ depth)) + when (and show-files (plusp lines)) + do (bwhen (fname (pathname-name file)) + (format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines)) + summing lines))) + (unless (zerop directory-lines) + (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines)) + directory-lines)))) ((find (pathname-type path) '("cl" "lisp" "c" "h" "java") :test 'string-equal) - (source-line-count path)) + (source-line-count path no-semis)) (t 0))) +(defun source-line-count (path no-semis) + (with-open-file (s path) + (loop with block-rem = 0 + for line = (read-line s nil nil) + for trim = (when line (string-trim '(#\space #\tab) line)) + while line + when (> (length trim) 1) + do (cond + ((string= "#|" (subseq trim 0 2))(incf block-rem)) + ((string= "|#" (subseq trim 0 2))(decf block-rem))) + unless (or (string= trim "") + (and no-semis (or (plusp block-rem) + (char= #\; (schar trim 0))))) + count 1))) + +#+save (defun source-line-count (path) (with-open-file (s path) (loop with lines = 0 @@ -180,7 +201,8 @@ #+(or) (line-count (make-pathname :device "c" - :directory `(:absolute "0dev"))) + :directory `(:absolute "0Algebra" "Cells")) + nil 1 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") From ktilton at common-lisp.net Sat Feb 16 08:00:59 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 16 Feb 2008 03:00:59 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080216080059.E0A001F0FF@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv10699 Modified Files: cells-manifesto.txt Log Message: --- /project/cells/cvsroot/cells/cells-manifesto.txt 2007/11/30 16:51:18 1.11 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2008/02/16 08:00:59 1.12 @@ -6,6 +6,46 @@ Cells is a mature, stable extension to CLOS[impl] allowing one to create classes whose instances can have slot values determined by instance-specific formulas. +Example +------- +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))))) + +Translated, the enabled state of the Cut menu item follows +whether or not the user is focused on a text-edit widget and +whether they have in fact selected a range of text. + +Meanwhile, the selection-range rule might be: + +(let (start) + (c? (if (mouse-down? .w.) + (bwhen (c (mouse-pos-to-char self (mouse-pos .w.))) + (if start + (list start c) + (setf start c))) + (setf start nil)))) + +Now the only imperative code needed is some glue reading the OS event loop +converting raw mouse down and mouse move events into window (the .w. symbol-macro) +attributes such as mouse-down? and mouse-pos. The desired functionality is achieved +by declarative rules which (like selection-range above) are entirely responsible for +deciding the selection range. + +A final trick comes from slot observers. Suppose we are thinly wrapping a C GUI and need to +do something in the C library to actually make menu items available or not. +It might look something like this: + + (defobserver enabled ((self menu-item) new-value old-value old-value-bound?) + (menu-item-set (c-ptr self) (if new-value 1 0))) + +ie, Somr model attributes must be propagated outside the model as they change, and observers +are callbacks we can provide to handle change. + Motivation ---------- As a child I watched my father toil at home for hours over paper From phildebrandt at common-lisp.net Sat Feb 16 09:34:29 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sat, 16 Feb 2008 04:34:29 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080216093429.7036A5F05E@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv31515 Modified Files: cells.asd family.lisp Log Message: Fixed loading in cells.asd --- /project/cells/cvsroot/cells/cells.asd 2008/02/01 15:52:49 1.9 +++ /project/cells/cvsroot/cells/cells.asd 2008/02/16 09:34:28 1.10 @@ -13,15 +13,8 @@ :long-description "Cells: a dataflow extension to CLOS." :version "3.0" :serial t - :components ((:module "utils-kt" - :serial t - :components ((:file "defpackage") - (:file "debug") - (:file "flow-control") - (:file "detritus") - (:file "strings") - (:file "datetime"))) - (:file "defpackage") + :depends-on (:utils-kt) + :components ((:file "defpackage") (:file "trc-eko") (:file "cells") (:file "integrity") --- /project/cells/cvsroot/cells/family.lisp 2007/12/03 20:11:11 1.22 +++ /project/cells/cvsroot/cells/family.lisp 2008/02/16 09:34:29 1.23 @@ -80,6 +80,9 @@ (when new-value (not-to-be self))) + +(defvar *parent* nil) + (defmodel family (model) ((.kid-slots :cell nil :initform nil @@ -89,9 +92,8 @@ :owning t :accessor kids :initarg :kids) - )) - -(defvar *parent*) + ) + (:default-initargs :fm-parent (when (boundp '*parent*) *parent*))) (defmacro the-kids (&rest kids) `(let ((*parent* self)) From phildebrandt at common-lisp.net Sat Feb 16 09:34:29 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sat, 16 Feb 2008 04:34:29 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080216093429.AB7D77B022@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv31515/utils-kt Modified Files: debug.lisp Log Message: Fixed loading in cells.asd --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/01/29 04:29:55 1.17 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/02/16 09:34:29 1.18 @@ -87,8 +87,7 @@ ;-------------------- timex --------------------------------- -(eval-when (compile eval load) - (export '(timex))) +(export! timex) (defmacro timex ((onp &rest trcargs) &body body) `(if ,onp @@ -119,10 +118,10 @@ ,form-measured) , at postlude)) -(export! clock clock-0 clock-off) - (defvar *clock*) +(export! clock clock-0 clock-off) + (defun clock-off (key) (when (boundp '*clock*) (print (list :clock-off key)) From phildebrandt at common-lisp.net Sat Feb 16 09:40:51 2008 From: phildebrandt at common-lisp.net (phildebrandt) Date: Sat, 16 Feb 2008 04:40:51 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080216094051.106011F0FA@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv713 Modified Files: defmodel.lisp Log Message: ken's defmodel fix --- /project/cells/cvsroot/cells/defmodel.lisp 2008/02/16 05:04:56 1.16 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/02/16 09:40:51 1.17 @@ -100,7 +100,7 @@ (let* ((reader-fn (or reader accessor)) (writer-fn (or writer accessor)) ) - `(progn ;; eval-when (#+sbcl :load-toplevel :execute) ; ph -- prevent sbcl warning + `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) ; ph -- prevent sbcl warning (setf (md-slot-cell-type ',class ',slotname) ,cell) ,(when owning `(setf (md-slot-owning ',class ',slotname) ,owning)) From ktilton at common-lisp.net Sat Feb 16 20:55:45 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 16 Feb 2008 15:55:45 -0500 (EST) Subject: [cells-cvs] CVS kennysarc2 Message-ID: <20080216205545.A968F16043@common-lisp.net> Update of /project/cells/cvsroot/kennysarc2 In directory clnet:/tmp/cvs-serv30841 Removed Files: cells-1.arc defun.lisp extensions.lisp struct.lisp Log Message: moving to new CVS module From ktilton at common-lisp.net Tue Feb 19 02:36:55 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 18 Feb 2008 21:36:55 -0500 (EST) Subject: [cells-cvs] CVS arccells Message-ID: <20080219023655.9DC614D054@common-lisp.net> Update of /project/cells/cvsroot/arccells In directory clnet:/tmp/cvs-serv11144 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import From ktilton at common-lisp.net Tue Feb 19 02:38:06 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 18 Feb 2008 21:38:06 -0500 (EST) Subject: [cells-cvs] CVS arccells Message-ID: <20080219023806.C87D14D056@common-lisp.net> Update of /project/cells/cvsroot/arccells In directory clnet:/tmp/cvs-serv11249 Added Files: arccells-its-alive.arc Log Message: --- /project/cells/cvsroot/arccells/arccells-its-alive.arc 2008/02/19 02:38:06 NONE +++ /project/cells/cvsroot/arccells/arccells-its-alive.arc 2008/02/19 02:38:06 1.1 ;; ;; copyright 2008 by Kenny Tilton ;; ;; License: MIT Open Source ;; ;; ;;; --- detritus ------------ ;;; (def prt args ; why on earth does prn run the output together? (apply prs args) (prn)) (def tablemap (table fn) ; fns are always huge and then a tiny little table ref just hangs off the end (maptable fn table) table) (def cadrif (x) (when (acons x) (cadr x))) (mac withs* (parms . body) ; faux dynamic binding (let uparms (map1 [cons (uniq) _] (pair parms)) `(do ,@(map1 (fn ((save curr val)) `(= ,save ,curr ,curr ,val)) uparms) (do1 (do , at body) ,@(map1 (fn ((save curr val)) `(= ,curr ,save)) uparms))))) ;;; -------------------- Cells ---------------------- ;;; ;;; A partial implementation of the Cells Manifesto: ;;; http://smuglispweeny.blogspot.com/2008/02/cells-manifesto.html ;;; ;;; --- globals -------------------- (= datapulse* 0) ;; "clock" used to ensure synchronization/data integrity (= caller* nil) ;; cell whose rule is currently running, if any (= mds* (table)) ;; model dictionary (= obs* (table)) ;; global "observer" dictionary ;;; --- md -> modelling ---------------------------------------- (mac defmd ((type-name (o includes) (o pfx (string type-name "-"))) . slot-defs) `(do (deftem (,type-name , at includes) ctype ',type-name cells nil ,@(mappend (fn (sd) (list (carif sd)(cadrif sd))) slot-defs)) ; define readers ,@(map (fn (sd) `(def ,(coerce (+ (string pfx) (string sd)) 'sym) (i) (slot-value i ',sd))) (map carif slot-defs)) ; define writers ,@(map (fn (sd) `(def ,(coerce (+ "set-" (string pfx) (string sd)) 'sym) (i v) (set-slot-value i ',sd v))) (map carif slot-defs)))) ;;; --- model initialization (def to-be (i) (do1 i (md-finalize i) (md-awaken i))) (def md-finalize (i) (do1 i (if (acons i) (map md-finalize i) (do ; register instance in a namespace for inter-i dependency (= (mds* (md-name i)) i) ; move cells out of mediated slots into 'cells slot (tablemap i (fn (k v) (when (c-isa v 'cell) (= v!model i v!slot k) (push (list k v) i!cells) (= (i k) 'unbound)))))))) (def md-awaken (i) (do1 i (if (acons i) (map md-awaken i) (do ; bring each slot "to life" (tablemap i (fn (k v) (aif (md-slot-cell i k) (slot-ensure-current it) (slot-value-observe i k v 'unbound)))))))) (def md? (name) mds*.name) ;; --- start of cells stuff ------------------ (def cells-reset () (= datapulse* 1) ; not sure why can't start at zero (= caller* nil) (= mds* (table))) (def ctype-of (x) (when (isa x 'table) x!ctype)) (def c-isa (s type) (is ctype-of.s type)) (defmd (cell nil c-) ;; the c- gets prefixed to all accessor names awake (pulse 0) (pulse-last-changed 0) (cache 'unbound) model slot rule users useds observers) (defmd (model nil md-) ; any template to be mediated by cells must include model name ; used so one instance can find another by name cells observers) (def md-slot-cell (i s) (alref i!cells s)) ;;; --- reading a slot ------------------------- (def slot-value (i s) (aif (md-slot-cell i s) (do (when caller* (pushnew caller* it!users) (pushnew it caller*!useds)) (slot-ensure-current it)) (i s))) (def calculate-and-set (c) ; clear dependencies so we get a fresh set after each rule run (each used c!useds (= used!users (rem c used!users))) (= c!useds nil) ; run the rule (let nv (withs* (caller* c) (c!rule c!model)) (unless c!useds ; losing rules with no dependencies ; is a big performance win (optimize-away c)) (slot-value-assume c nv))) (def optimize-away (c) (pull (assoc c!slot ((c-model c) 'cells)) ((c-model c) 'cells)) (each user c!users (pull c user!useds) (unless user!useds ; rarely happens (optimize-away user)))) (def slot-ensure-current (c) ; It would be fun to figure out a more readable ; version of the next consition. I tried, can't. (when (and c!rule (or (is 0 c!pulse-last-changed) (no (or (is c!pulse datapulse*) (no (any-used-changed c c!useds)))))) (calculate-and-set c)) (= c!pulse datapulse*) (when (is 0 c!pulse-last-changed) ;; proxy for nascent state (= c!pulse-last-changed datapulse*) (slot-value-observe c!model c!slot c!cache 'unbound)) c!cache) (def any-used-changed (c useds) (when useds ; So happens that FIFO is better order for this (or (any-used-changed c (cdr useds)) (let used (car useds) (slot-ensure-current used) (> used!pulse-last-changed c!pulse))))) ;;; --- writing to a slot ----------------------- (def set-slot-value (i s v) (aif (md-slot-cell i s) (do (++ datapulse*) (slot-value-assume it v)) (prt "you cannot assign to a slot without a cell" i s))) (def slot-value-assume (c v) (= c!pulse datapulse*) (with (i c!model ov c!cache) (unless (is v ov) (= c!cache v) (= (i c!slot) v) (= c!pulse-last-changed datapulse*) (slot-propagate c ov))) v) ;;; --- dataflow -------------------------------- ;;; Propagate state change from cell to cell and ;;; as needed from Cell to outside world ;;; (def slot-propagate (c ov) (let caller* nil (each user c!users (slot-ensure-current user)) (slot-value-observe c!model c!slot c!cache ov))) (def slot-value-observe (i s v ov) (awhen (md-slot-cell i s) (observe it!observers i s v ov)) (observe (alref i!observers s) i s v ov) (observe obs*.s i s v ov)) (def observe (o i s v ov) (if (acons o) (map (fn (o2) (o2 i s v ov)) o) o (o i s v ov))) ;;; --- constructor sugar -------------------- (mac imd (name (type) . inits) `(inst ',type 'name ',name ,@(mappend (fn ((s v)) `(',s ,v)) (pair inits)))) (def c-in (v) (inst 'cell 'cache v)) (mac c? (rule . observers) `(inst 'cell 'rule ,rule 'observers (list , at observers))) ;;; --- example -------------------------------- (defmd (furnace (model) fur-) on temp (fuel 0) ;;; another way to do observers, at the class level ;;; observers `((fuel ,(fn (i s v ov) ;;; (prt 'md-defined-observer-sees i!name s v ov)))) ) (defmd (thermostat (model) thermo-) preferred actual) (def test-furnace () (do (cells-reset) (prt '----------start-------------------) (let (th f) (to-be (list (imd th42 (thermostat) preferred (c-in 70) actual 70) (imd f-1 (furnace) fuel 10 on (c? [let th (md? 'th42) (< (thermo-actual th)(thermo-preferred th))] ; an instance-level observer (fn (i s v ov) (prt "Sending"(if v 'on 'off) "control sequence to furnace f-1")))))) ;;; A global observer of any slot called "on" ;;; (push (fn (i s v ov) ;;; (prt 'on-global-obs-1 i!name s v ov)) ;;; obs*!on) (prt "After awakening the model the furnace is" (if (fur-on f) 'on 'off)) (set-thermo-preferred th 72) ;; the furnace comes on cuz we want it warmer ))) (test-furnace) ;;; Output: ; ----------start------------------- ; Sending off control sequence to furnace f-1 ; After awakening the model the furnace is off ; Sending on control sequence to furnace f-1 From ktilton at common-lisp.net Tue Feb 19 17:08:42 2008 From: ktilton at common-lisp.net (ktilton) Date: Tue, 19 Feb 2008 12:08:42 -0500 (EST) Subject: [cells-cvs] CVS arccells Message-ID: <20080219170842.D756439161@common-lisp.net> Update of /project/cells/cvsroot/arccells In directory clnet:/tmp/cvs-serv5046 Modified Files: arccells-its-alive.arc Log Message: Use defset on slot writers to support (= (myslt x) 42) --- /project/cells/cvsroot/arccells/arccells-its-alive.arc 2008/02/19 02:38:06 1.1 +++ /project/cells/cvsroot/arccells/arccells-its-alive.arc 2008/02/19 17:08:42 1.2 @@ -53,15 +53,20 @@ cells nil ,@(mappend (fn (sd) (list (carif sd)(cadrif sd))) slot-defs)) ; define readers - ,@(map (fn (sd) - `(def ,(coerce (+ (string pfx) (string sd)) 'sym) (i) - (slot-value i ',sd))) - (map carif slot-defs)) - ; define writers - ,@(map (fn (sd) - `(def ,(coerce (+ "set-" (string pfx) (string sd)) 'sym) (i v) - (set-slot-value i ',sd v))) - (map carif slot-defs)))) + ,@(mappend (fn (sd) + (withs (rdr$ (+ (string pfx) (string sd)) + rdr (coerce rdr$ 'sym) + wrtr (coerce (+ "set-" rdr$) 'sym)) + `((def ,rdr (i) + (slot-value i ',sd)) + (def ,wrtr (i v) + (set-slot-value i ',sd v)) + (defset ,rdr (x) + (w/uniq g + (list (list g x) + `(,',rdr ,g) + `(fn (val) (,',wrtr ,g val)))))))) + (map carif slot-defs)))) ;;; --- model initialization @@ -97,8 +102,8 @@ (slot-ensure-current it) (slot-value-observe i k v 'unbound)))))))) -(def md? (name) - mds*.name) +(mac md? (name) + `(mds* ',name)) ;; --- start of cells stuff ------------------ @@ -142,7 +147,7 @@ (do (when caller* (pushnew caller* it!users) (pushnew it caller*!useds)) - (slot-ensure-current it)) + slot-ensure-current.it) (i s))) (def calculate-and-set (c) @@ -157,7 +162,7 @@ (unless c!useds ; losing rules with no dependencies ; is a big performance win - (optimize-away c)) + optimize-away.c) (slot-value-assume c nv))) (def optimize-away (c) @@ -165,16 +170,16 @@ (each user c!users (pull c user!useds) (unless user!useds ; rarely happens - (optimize-away user)))) + optimize-away.user))) (def slot-ensure-current (c) ; It would be fun to figure out a more readable ; version of the next consition. I tried, can't. (when (and c!rule (or (is 0 c!pulse-last-changed) - (no (or (is c!pulse datapulse*) - (no (any-used-changed c c!useds)))))) - (calculate-and-set c)) + ~(or (is c!pulse datapulse*) + (~any-used-changed c c!useds)))) + calculate-and-set.c) (= c!pulse datapulse*) @@ -187,8 +192,8 @@ (when useds ; So happens that FIFO is better order for this (or (any-used-changed c (cdr useds)) - (let used (car useds) - (slot-ensure-current used) + (let used car.useds + slot-ensure-current.used (> used!pulse-last-changed c!pulse))))) ;;; --- writing to a slot ----------------------- @@ -216,7 +221,7 @@ (def slot-propagate (c ov) (let caller* nil (each user c!users - (slot-ensure-current user)) + slot-ensure-current.user) (slot-value-observe c!model c!slot c!cache ov))) (def slot-value-observe (i s v ov) @@ -226,8 +231,8 @@ (observe obs*.s i s v ov)) (def observe (o i s v ov) - (if (acons o) - (map (fn (o2) (o2 i s v ov)) o) + (if acons.o + (map [_ i s v ov] o) o (o i s v ov))) ;;; --- constructor sugar -------------------- @@ -263,8 +268,8 @@ (list (imd th42 (thermostat) preferred (c-in 70) actual 70) (imd f-1 (furnace) - fuel 10 - on (c? [let th (md? 'th42) + fuel 10 ;; unused for now + on (c? [let th (md? th42) (< (thermo-actual th)(thermo-preferred th))] ; an instance-level observer (fn (i s v ov) @@ -275,7 +280,7 @@ ;;; obs*!on) (prt "After awakening the model the furnace is" (if (fur-on f) 'on 'off)) - (set-thermo-preferred th 72) ;; the furnace comes on cuz we want it warmer + (= (thermo-preferred th) 72) ;; the furnace comes on cuz we want it warmer ))) (test-furnace) From ktilton at common-lisp.net Sat Feb 23 01:22:11 2008 From: ktilton at common-lisp.net (ktilton) Date: Fri, 22 Feb 2008 20:22:11 -0500 (EST) Subject: [cells-cvs] CVS triple-cells Message-ID: <20080223012211.802332F051@common-lisp.net> Update of /project/cells/cvsroot/triple-cells In directory clnet:/tmp/cvs-serv15290 Modified Files: api.lisp core.lisp dataflow.lisp defpackage.lisp hello-world.lisp observer.lisp triple-cells.lpr Log Message: Version 2, with integrity --- /project/cells/cvsroot/triple-cells/api.lisp 2007/12/23 10:04:56 1.1 +++ /project/cells/cvsroot/triple-cells/api.lisp 2008/02/23 01:22:11 1.2 @@ -1,25 +1,8 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*- ;;; ;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 2008 by Kenneth William Tilton. ;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. (in-package :3c) @@ -27,10 +10,9 @@ ;;; --- API --------------------------------------- (defun 3c-init () - (setf *3c-pulse* 0) (setf *calc-nodes* nil) (setf *3c?* (make-hash-table :test 'equal)) - (setf *3c-observers* (make-hash-table :test 'equal))) + (setf *3c-observers* (make-hash-table :test 'equalp))) ;;; --- API constructors ------------------------------- @@ -59,6 +41,7 @@ (add-triple c !ccc:type !ccc:ruled) (add-triple c !ccc:rule (mk-upi (prin1-to-string rule))) (when ephemeral + ;(trc "bingo ephemeral" rule) (add-triple c !ccc:ephemeral !ccc:t)) (when test (add-triple c !ccc:test (mk-upi test))) @@ -71,13 +54,8 @@ ;(trc "c? value tr" tr-cv) c))) - - ;;; --- API accessors -(defun clear-usage (cell) - (delete-triples :s cell :p !ccc:uses)) - (defun 3c (s p) (assert (and s p)) (bif (cell (stmt-cell s p)) @@ -102,21 +80,18 @@ ;(trc "tr-value" (triple-id tr-value)) (unless (equal new-value prior-value) - (3c-pulse-advance :setf-3c) - (when tr-value - (delete-triple (triple-id tr-value))) - - (let* ((new-value-upi (mk-upi new-value)) - (tr-value-new (add-triple s p new-value-upi))) - - (delete-triples :s cell :p !ccc:value) - - (let ((tr-cell-value-new (add-triple cell !ccc:value new-value-upi))) + (with-3c-integrity (:change cell) + (when tr-value + (delete-triple (triple-id tr-value))) + + (let ((new-value-upi (mk-upi new-value))) + (add-triple s p new-value-upi) + ; cell maintenance, including its own copy of value + (delete-triples :s cell :p !ccc:value) + (add-triple cell !ccc:value new-value-upi) (3c-propagate cell) (cell-observe-change cell s p new-value prior-value t) (when (3c-ephemeral? cell) - ; fix up cell... - (delete-triple tr-cell-value-new) - ; reset value itself to nil - (delete-triple tr-value-new))))))) + (add-triple !ccc:ufb-reset-ephemerals (mk-upi 42) cell))))))) + --- /project/cells/cvsroot/triple-cells/core.lisp 2007/12/23 10:04:53 1.3 +++ /project/cells/cvsroot/triple-cells/core.lisp 2008/02/23 01:22:11 1.4 @@ -1,38 +1,23 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*- ;;; +;;; Copyright (c) 2008 by Kenneth William Tilton. ;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - (in-package :3c) ;; --- triple-cells --- -(defvar *3c-pulse*) (defvar *calc-nodes*) -(defun 3c-pulse-advance (dbg) +(defun 3c-pulse-advance (&optional (dbg :anon-advance)) (declare (ignorable dbg)) - (trc "PULSE> ------------------" (1+ *3c-pulse*) dbg) - (incf *3c-pulse*)) + (trc "PULSE> ---- advancing:" dbg) + (delete-triples :s !ccc:integrity :p !ccc:pulse) + (add-triple !ccc:integrity !ccc:pulse (new-blank-node))) + +(defun 3c-pulse () + (bwhen (tr (get-triple :s !ccc:integrity :p !ccc:pulse)) + (object tr))) ;;; --- low-level 3cell accessors @@ -41,12 +26,18 @@ (part-value (object tr)))) (defun (setf 3c-cell-value) (new-value c) + (3c-cell-make-current c) + (delete-triples :s c :p !ccc:value) (when new-value (add-triple c !ccc:value (mk-upi new-value)))) -(defun 3c-pulse (c) - (get-sp-value c !ccc:pulse)) +(defun 3c-cell-make-current (c) + (delete-triples :s c :p !ccc:pulse) + (add-triple c !ccc:pulse (3c-pulse))) + +(defun 3c-cell-pulse (c) + (object (get-sp c !ccc:pulse))) ;;; --- rule storage ------------------------------- @@ -55,7 +46,7 @@ #+dump (maphash (lambda (k v) (trc "kk" k v)) *3c?*) -(defun (setf 3c?-rule) ( rule c-node) +(defun (setf 3c?-rule) (rule c-node) (assert (functionp rule) () "3c?-rule setf not rule: ~a ~a" (type-of rule) rule) ;;(trc "storing rule!!!! for" c-node rule) (setf (gethash c-node *3c?*) rule)) @@ -102,8 +93,6 @@ (intern (nsubstitute #\- #\# (up$ (string-trim "<>" s))))) - - ;;; --- access ------------------------------------------ (defun subject-cells-node (s) @@ -121,42 +110,65 @@ (object tr))) (defun cell-predicate (c) - (predicate (car (get-triples-list :o c)))) + (object (get-sp c !ccc:is-cell-of-predicate))) -(defun cell-subject (c) - (subject (car (get-triples-list - :p !ccc:cells - :o (subject (car (get-triples-list :o c))))))) +(defun cell-model (c) + (object (get-sp c !ccc:is-cell-of-model))) + +(defun 3c-install-cell (s p o) + (add-triple (subject-cells-node s) p o) + (add-triple o !ccc:is-cell-of-model s) + (add-triple o !ccc:is-cell-of-predicate p)) (defun stmt-new (s p o &aux (tv o)) - (when (3c-cell? o) - (add-triple (subject-cells-node s) p o) - + (cond + ((3c-cell? o) + (3c-install-cell s p o) (cond ((3c-input? o) - (3c-pulse-advance :new-input) ;; why does creating data advance pulse? - (setf tv (3c-cell-value o))) - - ((3c-ruled? o) - (setf tv (funcall (3c?-rule o) o nil nil)) - (setf (3c-cell-value o) tv)) - - (t (break "unknown cell" o))) - - (add-triple o !ccc:pulse (mk-upi *3c-pulse*)) - (setf tv (3c-cell-value o))) - - (when tv - (add-triple s p (mk-upi tv))) - - (cell-observe-change o s p tv nil nil)) + (bwhen (tv (3c-cell-value o)) + (add-triple s p (mk-upi tv))) + (with-3c-integrity (!ccc:observe o) + (cell-observe-change o s p tv nil nil))) + ((3c-ruled? o) + (with-3c-integrity (!ccc:awaken-ruled-cell o) + (3c-awaken-ruled-cell o))) + (t (break "unknown cell" o)))) + + (t (when tv + (let ((tr (add-triple s p (mk-upi tv)))) + (trc "recording k under" p :id tr tv) + (with-3c-integrity (!ccc:observe (mk-upi tr)) + (cell-observe-change o s p tv nil nil))))))) + +(defun 3c-awaken-ruled-cell (c) + (let ((s (cell-model c)) + (p (cell-predicate c)) + (tv (funcall (3c?-rule c) c nil nil))) + ;(trc "awakening ruled" p) + (setf (3c-cell-value c) tv) + (cell-observe-change c s p tv nil nil))) (defun 3c-make (type &key id) "Generates blank node and associates it with type and other options" (let ((node (new-blank-node))) (trc "3c-make storing type" type (type-of type)) - (add-triple node !ccc:instance-of type) ; (mk-upi type)) + (add-triple node !ccc:instance-of type) (when id (3c-register node id)) node)) +(defun 3c-register (node name) + (add-triple (mk-upi name) !ccc:id node)) + +(defun 3c-find-id (name) + (object (get-sp (mk-upi name) !ccc:id))) + +(defun clear-usage (cell) + (delete-triples :s cell :p !ccc:uses)) + +#+test +(progn + (make-tutorial-store) + (let ((x (3c-make ! :id "x-plane"))) + (3c-find-id "x-plane"))) --- /project/cells/cvsroot/triple-cells/dataflow.lisp 2007/12/23 10:04:56 1.1 +++ /project/cells/cvsroot/triple-cells/dataflow.lisp 2008/02/23 01:22:11 1.2 @@ -1,44 +1,25 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*- ;;; ;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 2008 by Kenneth William Tilton. ;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - (in-package :3c) (defun 3c-propagate (cell) - (loop for user in (get-triples-list :p !ccc:uses :o cell) - do (trc nil "propagating !!!!!!!!!!!!" cell :to (subject user)) - (3c-ensure-current (subject user)))) + (3c-ufb-add !ccc:ufb-tell-dependents cell)) ;;; --- integrity -----------------(part-value prior-value)----------------------------- (defun 3c-ensure-current (cell &optional s p) ;; when we don't have s/p extend to work backwards from cell (unless s - (setf s (cell-subject cell) - p (cell-predicate cell))) + (setf s (cell-model cell)) + (setf p (cell-predicate cell))) ;(trc "3c-ensure-current" s p) (when (and cell (3c-ruled? cell)) - (when (> *3c-pulse* (3c-pulse cell)) - ;(trc "old" (3c-cell-value cell)) + (unless (upi= (3c-pulse) (3c-cell-pulse cell)) + ; (trc "old" (3c-cell-value cell)) + ;(trc "HEY!!! what happened to checking if necessary to rerun rule?!") (let* ((prior-value (3c-cell-value cell)) (new-value (progn (clear-usage cell) @@ -48,12 +29,17 @@ (test (or (bwhen (test (get-sp-value cell !ccc:test)) (intern test)) 'EQL))) - ;(trc "prop new" new-value) - (unless (funcall test new-value prior-value) - (let ((prior-value (3c-cell-value cell))) - (setf (3c-cell-value cell) new-value) - (delete-triples :s s :p p) - (when new-value - (add-triple s p (mk-upi new-value))) - (3c-propagate cell) - (cell-observe-change cell s p new-value prior-value t))))))) + + (if (funcall test new-value prior-value) + (3c-cell-make-current cell) + (progn + ;(trc "prop new" new-value :prior prior-value) + (let ((prior-value (3c-cell-value cell))) + (setf (3c-cell-value cell) new-value) + (delete-triples :s s :p p) + (when new-value + (add-triple s p (mk-upi new-value))) + (3c-propagate cell) + (cell-observe-change cell s p new-value prior-value t) + (when (3c-ephemeral? cell) + (add-triple !ccc:ufb-reset-ephemerals (mk-upi 42) cell))))))))) --- /project/cells/cvsroot/triple-cells/defpackage.lisp 2007/12/20 13:08:17 1.1 +++ /project/cells/cvsroot/triple-cells/defpackage.lisp 2008/02/23 01:22:11 1.2 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*- ;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 2008 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal @@ -29,5 +29,5 @@ (defpackage :triple-cells (:nicknames :3c) - (:use #:common-lisp #:utils-kt #:db.agraph #:cells)) ;; cells just fro TRC (so far) + (:use #:common-lisp #:utils-kt #:db.agraph #:cells)) ;; cells just for TRC (so far) --- /project/cells/cvsroot/triple-cells/hello-world.lisp 2007/12/23 10:04:56 1.3 +++ /project/cells/cvsroot/triple-cells/hello-world.lisp 2008/02/23 01:22:11 1.4 @@ -1,124 +1,114 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*- ;;; ;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 2008 by Kenneth William Tilton. ;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. (in-package :3c) - -(defun 3c-test-reopen () - (close-triple-store) - (open-triple-store "hello-world" - :directory (project-path) - :if-does-not-exist :error) - (let ((dell (3c-find-id "dell")) - (happen !hw:happen) - (location !hw:location) - (response !hw:response)) - - (trc "start" (3c dell happen)(3c dell location)(3c dell response)) - (setf (3c dell happen) "knock-knock") - (setf (3c dell happen) "arrive") - (setf (3c dell happen) "knock-knock") - )) +#+test +(3c-test-reopen) #+test -(3c-test) +(3c-test-build) (defun 3c-test () + (3c-test-build) + (3c-test-reopen) + ) + +(defun 3c-test-build () (test-prep "3c") - (unwind-protect - (progn - (3c-init) + ; + ; initialize new DB altogether + ; + (create-triple-store "hello-world" + :if-exists :supersede + :directory (project-path)) + (register-namespace "hw" "helloworld#" :errorp nil) + (register-namespace "ccc" "triplecells#" :errorp nil) + ; + ; initialize new DB session + ; + (3c-init) + (let ((*synchronize-automatically* t)) (enable-print-decoded t) - (create-triple-store "hello-world" - :if-exists :supersede - :directory (project-path)) - (register-namespace "hw" "helloworld#" :errorp nil) - (register-namespace "ccc" "triplecells#" :errorp nil) - + (make-observer !hw:echo-happen (trc "happen:" new-value)) + (make-observer !hw:location (trc "We are now" new-value )) + (make-observer !hw:obs-response (trc "Speak:" new-value )) - (let ((dell (3c-make !hw:computer :id "dell")) - (happen !hw:happen) - (location !hw:location) - (response !hw:response)) - (assert dell) - - (make-observer !hw:echo-happen (trc "happen:" new-value)) - (make-observer !hw:obs-location (trc "We are now" new-value )) - (make-observer !hw:obs-response (trc "Speak:" new-value )) - - (stmt-new dell happen #+const "test" - (3c-in nil :ephemeral t - :observer !hw:echo-happen - :test 'equal)) - - (stmt-new dell location - (3c? ;(trc "RULE-ENTRY>" *3c-pulse*) - (let ((h (3c (3c-find-id "dell") !hw:happen))) - ;(trc "rule sees happen" h) - (cond - ((string-equal h "arrive") "home") - ((string-equal h "leave") "away") - (cache? cache) - (t "away"))) - :observer !hw:obs-location - :test 'equal)) - - (stmt-new dell response - (3c? (let* ((dell (3c-find-id "dell")) - (h (3c dell !hw:happen)) - (loc (3c dell !hw:location))) - ;(trc "response rule sees happen" h :loc loc) - (cond - ((string-equal h "knock-knock") - (cond - ((string-equal loc "home") "who's there?") - (t "silence"))) - ((string-equal h "arrive") - (cond - ((string-equal loc "home") "honey, i am home!"))) - ((string-equal h "leave") + (with-3c-integrity (:change) ;; change advances pulse + (let ((dell (3c-make !hw:computer :id "dell")) + (happen !hw:happen) + (location !hw:location) + (response !hw:response)) + (declare (ignorable response location)) + (assert dell) + + (stmt-new dell happen + (3c-in nil :ephemeral t + :observer !hw:echo-happen + :test 'equal)) + + + (stmt-new dell location + (3c? (let ((h (3c (3c-find-id "dell") !hw:happen))) + ;(trc "rule sees happen" h) (cond - ((string-equal loc "away") "bye-bye!"))) - (t cache))) - :observer !hw:obs-response - :test 'equal)) - - (time - (progn - (setf (3c dell happen) "knock-knock") - (loop repeat 2 do - (setf (3c dell happen) "knock-knock")) - (setf (3c dell happen) "arrive") + ((string-equal h "arrive") "home") + ((string-equal h "leave") "away") + (cache? cache) + (t "away"))) + :observer !hw:location + :test 'equal)) + ;;#+step2 + (progn - (setf (3c dell happen) "knock-knock") - (setf (3c dell happen) "leave"))) - - ))) - (dribble))) - + (stmt-new dell response + (3c? (let* ((dell (3c-find-id "dell")) + (h (3c dell !hw:happen)) + (loc (3c dell !hw:location))) + ;(trc "response rule sees happen" h :loc loc) + (cond + ((string-equal h "knock-knock") + (cond + ((string-equal loc "home") "who's there?") + (t "silence"))) + ((string-equal h "arrive") + (cond + ((string-equal loc "home") "honey, i am home!"))) + ((string-equal h "leave") + (cond + ((string-equal loc "away") "bye-bye!"))) + (t cache))) + :observer !hw:obs-response + :ephemeral t + :test 'equal))))))) +(defun 3c-test-reopen () + (close-triple-store) + (open-triple-store "hello-world" + :directory (project-path) + :if-does-not-exist :error) + (when (3c-integrity-managed?) (break "1")) + (time + (let ((dell (3c-find-id "dell")) + (happen !hw:happen) + (location !hw:location) + (response !hw:response)) + + (trc "---------------- start-------------------------- " (3c dell happen)(3c dell location)(3c dell response)) + (when (3c-integrity-managed?) (break "2")) + (setf (3c dell happen) "knock-knock") + (loop repeat 2 do + (setf (3c dell happen) "knock-knock")) + (setf (3c dell happen) "arrive") + + (setf (3c dell happen) "knock-knock") + (setf (3c dell happen) "leave") + ))) --- /project/cells/cvsroot/triple-cells/observer.lisp 2007/12/23 10:04:56 1.1 +++ /project/cells/cvsroot/triple-cells/observer.lisp 2008/02/23 01:22:11 1.2 @@ -1,26 +1,8 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*- ;;; ;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 2008 by Kenneth William Tilton. ;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - (in-package :3c) @@ -31,18 +13,46 @@ ,form))) (defun call-make-observer (id observer) - (trc "storing observer!!!!!!!!!!!" id !ccc:observer-id-rule (mk-upi (prin1-to-string observer))) (add-triple id !ccc:observer-id-rule (mk-upi (prin1-to-string observer))) (setf (3c-observer id) (eval observer))) ;; while we're at it ;;; --- 3cell observation -------------------------------------------------------- - (defun cell-observe-change (cell s p new-value prior-value prior-value?) - (bif (otr (get-sp cell !ccc:observer-is)) - (funcall (3c-observer (object otr)) s p new-value prior-value prior-value?) - (trc "unobserved" s p))) + (cond + (cell + (loop for observer in (get-triples-list :s cell :p !ccc:observer-is) + do (funcall (3c-observer (object observer)) s p + new-value prior-value prior-value?))) + (p (loop for observer in (get-triples-list :s p :p !ccc:observer-id-rule) + do (funcall (3c-observer-from-rule-triple observer) s p + new-value prior-value prior-value?))))) + +;;;(defun cell-observe-change (cell s p new-value prior-value prior-value?) +;;; (trc "observing" p new-value) +;;; (if (get-triple :s cell :p !ccc:observer-is) ; just need one to decide to schedule +;;; (let ((o (new-blank-node))) ;; o = observation, an instance of a cell to be observed and its parameters +;;; (add-triple o !ccc:obs-s cell) +;;; (add-triple o !ccc:obs-p cell) +;;; (add-triple o !ccc:obs-new-value (mk-upi new-value)) +;;; (add-triple o !ccc:obs-prior-value (mk-upi prior-value)) +;;; (add-triple o !ccc:obs-prior-value? (mk-upi prior-value?)) +;;; (add-triple !ccc:obs-queue (mk-upi (get-internal-real-time)) o)) +;;; (trc "unobserved" s p))) + +;;;(defun process-observer-queue () +;;; (index-new-triples) +;;; (let ((oq (get-triples-list :s !ccc:obs-queue))) +;;; (loop for observation in (mapcar 'object oq) +;;; for s = (object (get-sp observation !ccc:obs-s)) +;;; for p = (object (get-sp observation !ccc:obs-p)) +;;; for new-value = (get-sp-value observation !ccc:obs-new-value) +;;; for prior-value = (get-sp-value observation !ccc:obs-prior-value) +;;; for prior-value? = (get-sp-value observation !ccc:obs-prior-value) +;;; do (loop for observer in (get-triples-list :s s :p !ccc:observer-is) +;;; do (funcall (3c-observer (object observer)) s p +;;; new-value prior-value prior-value?))))) ;;; ---------------------------------------------------- @@ -60,3 +70,8 @@ (assert fn$) (eval (read-from-string fn$)))))) + +(defun 3c-observer-from-rule-triple (tr) + (let ((fn$ (triple-value tr))) + (assert fn$) + (eval (read-from-string fn$)))) --- /project/cells/cvsroot/triple-cells/triple-cells.lpr 2007/12/23 10:04:56 1.3 +++ /project/cells/cvsroot/triple-cells/triple-cells.lpr 2008/02/23 01:22:11 1.4 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Dec 2, 2007 6:32)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -6,14 +6,14 @@ (define-project :name :triple-cells :modules (list (make-instance 'module :name "defpackage.lisp") + (make-instance 'module :name "ag-utilities.lisp") (make-instance 'module :name "core.lisp") - (make-instance 'module :name "agraph-tutorial") - (make-instance 'module :name "namespace.lisp") (make-instance 'module :name "api.lisp") - (make-instance 'module :name "ag-utilities.lisp") (make-instance 'module :name "dataflow.lisp") (make-instance 'module :name "observer.lisp") - (make-instance 'module :name "hello-world.lisp")) + (make-instance 'module :name "hello-world.lisp") + (make-instance 'module :name "read-me.lisp") + (make-instance 'module :name "3c-integrity.lisp")) :projects (list (make-instance 'project-module :name "..\\Cells\\cells")) :libraries nil From ktilton at common-lisp.net Sat Feb 23 01:23:45 2008 From: ktilton at common-lisp.net (ktilton) Date: Fri, 22 Feb 2008 20:23:45 -0500 (EST) Subject: [cells-cvs] CVS triple-cells Message-ID: <20080223012345.78D74450CD@common-lisp.net> Update of /project/cells/cvsroot/triple-cells In directory clnet:/tmp/cvs-serv15444 Added Files: 3c-integrity.lisp ag-utilities.lisp read-me.lisp Log Message: --- /project/cells/cvsroot/triple-cells/3c-integrity.lisp 2008/02/23 01:23:45 NONE +++ /project/cells/cvsroot/triple-cells/3c-integrity.lisp 2008/02/23 01:23:45 1.1 (in-package :3c) (defmacro with-3c-integrity ((&optional opcode defer-info debug) &rest body) `(call-with-3c-integrity ,opcode ,defer-info (lambda (opcode defer-info) (declare (ignorable opcode defer-info)) ,(when debug `(trc "integrity action entry" opcode defer-info ',body)) , at body))) (defmacro with-3cc (id &body body) `(with-ec-integrity (:change ,id) , at body)) (defun 3c-integrity-managed? () (get-triple :s !ccc:integrity :p !ccc:within)) (defun (setf 3c-integrity-managed?) (on?) (if on? (if (get-triple :s !ccc:integrity :p !ccc:within) (break "integ already managed") (add-triple !ccc:integrity !ccc:within (new-blank-node))) (bif (tr (get-triple :s !ccc:integrity :p !ccc:within)) (delete-triple (triple-id tr)) (warn "integ not being managed, nothing to turn off")))) (defun call-with-3c-integrity (opcode defer-info action) (if (3c-integrity-managed?) (if opcode (3c-ufb-add opcode defer-info) (funcall action opcode defer-info)) (prog2 (setf (3c-integrity-managed?) t) (progn ;; let (*defer-changes*) (when (or (null (3c-pulse)) (eq opcode :change)) (3c-pulse-advance (cons opcode defer-info))) (prog1 (funcall action opcode defer-info) (3c-finish-business))) (setf (3c-integrity-managed?) nil)))) (defun 3c-ufb-add (opcode defer-info) (add-triple opcode (mk-upi (get-internal-real-time)) defer-info)) (defun 3c-finish-business () (tagbody tell-dependents (process-tell-dependents) (process-awaken) (when (get-triple :p !ccc:tell-dependents) (go tell-dependents)) ;;; ;--- process client queue ------------------------------ ;;; ; ;;; handle-clients ;;; (bwhen (clientq (ufb-queue :client)) ;;; (if *client-queue-handler* ;;; (funcall *client-queue-handler* clientq) ;; might be empty/not exist, so handlers must check ;;; (just-do-it clientq)) ;;; (when (fifo-peek (ufb-queue :client)) ;;; #+shhh (ukt::fifo-browse (ufb-queue :client) (lambda (entry) ;;; (trc "surprise client" entry))) ;;; (go handle-clients))) (process-reset-ephemerals) ;;; (bwhen (task-info (fifo-pop (ufb-queue :change))) ;;; (trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change))) ;;; (destructuring-bind (defer-info . task-fn) task-info ;;; (trc nil "finbiz: deferred state change" defer-info) ;;; (data-pulse-next (list :finbiz defer-info)) ;;; (funcall task-fn :change defer-info) ;;; (go tell-dependents))) )) (defun process-tell-dependents () (index-new-triples) (loop while (loop with any for cell in (prog1 (mapcar 'object (get-triples-list :s !ccc:ufb-tell-dependents)) (delete-triples :s !ccc:ufb-tell-dependents)) do (loop for user in (get-triples-list :p !ccc:uses :o cell) do (trc nil "propagating !!!!!!!!!!!!" cell :to (cell-predicate (subject user))) (setf any t) (3c-ensure-current (subject user))) finally (return any)))) (defun process-awaken () (index-new-triples) (loop for cell in (prog1 (mapcar 'object (get-triples-list :s !ccc:awaken-ruled-cell)) (delete-triples :s !ccc:awaken-ruled-cell)) do (3c-awaken-ruled-cell cell)) (loop for o in (prog1 (mapcar 'object (get-triples-list :s !ccc:observe)) (delete-triples :s !ccc:observe)) do (if (3c-cell? o) (cell-observe-change o (cell-model o) (cell-predicate o) (3c-cell-value o) nil nil) (let ((tr (get-triple-by-id (upi->value o)))) ;; must be a mod-pred-triple constant (trc "obsing k" tr (predicate tr)) (cell-observe-change nil (subject tr) (predicate tr) (upi->value (object tr)) nil nil))))) (defun process-reset-ephemerals () (let ((q !ccc:ufb-reset-ephemerals)) (index-new-triples) (loop for cell in (prog1 (mapcar 'object (get-triples-list :s q)) (delete-triples :s q)) for p = (cell-predicate cell) do ;(trc "resetting ephemeral" p) (delete-triples :s cell :p !ccc:value) (delete-triples :s (cell-model cell) :p p))))--- /project/cells/cvsroot/triple-cells/ag-utilities.lisp 2008/02/23 01:23:45 NONE +++ /project/cells/cvsroot/triple-cells/ag-utilities.lisp 2008/02/23 01:23:45 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*- ;;; ;;; ;;; Copyright (c) 2008 by Kenneth William Tilton. ;;; (in-package :3c) ;; --- ag utils ----------------------- #+test (progn (make-tutorial-store) (let ((s (mk-upi "a")) (p (new-blank-node))) (loop repeat 10 do (add-triple s (mk-upi (random 10)) p)) (index-new-triples) (loop for tr in (get-triples-list :s s) do (print (upi->value (predicate tr)))))) (defun triple-value (tr) (when tr (upi->value (object tr)))) (defun get-sp (s p) #+allegrocl (get-triple :s s :p p) #-allegrocl (car (get-triples-list :s s :p p))) (defun get-spo (s p o) #+allegrocl (get-triple :s s :p p :o o) #-allegrocl (car (get-triples-list :s s :p p :o o))) (defun get-sp-value (s p) (triple-value (get-sp s p))) (defun mk-upi (v) (typecase v (string (literal v)) (symbol (mk-upi (symbol-name v))) (integer (value->upi v :long)) (future-part v) (otherwise (if (upip v) v (break "not upi-able ~a ~a" (type-of v) v))))) (defun ensure-triple (s p o) (unless (get-spo s p o) (add-triple s p o))) --- /project/cells/cvsroot/triple-cells/read-me.lisp 2008/02/23 01:23:45 NONE +++ /project/cells/cvsroot/triple-cells/read-me.lisp 2008/02/23 01:23:45 1.1 #| Triple-Cells: (+ RDF Cells) --------------------------- Prerequisites ------------- Cells: http://common-lisp.net/project/cells/ Lotsa broken links. Use c-l.net repsoitories access to get to CVS: http://common-lisp.net/cgi-bin/viewcvs.cgi/?root=cells RDF: http://www.w3.org/RDF/ That is the RDF standard. Many implementations available, even from Oracle. Redland is an open one. Redland: http://librdf.org/ C, open, lotsa bindings to other languages, Lisp bindings and port of triple-cells left as an exercise. I use AllegroCL/Allegrograph. Free trial AG: http://www.franz.com/downloads/clp/agle_survey It is not clear whether you first need to download/install the free express edition of AllegroCL or whether this download does it all. Download of Triple-Cells itself ------------------------------- Start here: http://common-lisp.net/cgi-bin/viewcvs.cgi/?root=cells Then you need both Cells and triple-cells. Getting Cells just requires the contained utils-kt, but my favorite debug stuff is Cells-aware so resides there. Gotta refactor someday. hello-world.lisp includes a function 3c-test. Once that or 3c-test-build has been run, more fun is 3c-test-reopen, which shows the AG database has all the information needed to "run" a database, assuming triple-cells is loaded. |#