February 2008 - cells-cvs@common-lisp.net

[cells-cvs] CVS cells/utils-kt
by ktilton 16 Feb '08

16 Feb '08

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")

1 0

[cells-cvs] CVS cells/cells-test
by ktilton 16 Feb '08

16 Feb '08

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?)

1 0

[cells-cvs] CVS cells
by ktilton 16 Feb '08

16 Feb '08

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

1 0

[cells-cvs] CVS kennysarc2
by ktilton 14 Feb '08

14 Feb '08

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))) +

1 0

[cells-cvs] CVS kennysarc2
by ktilton 14 Feb '08

14 Feb '08

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 ,@forms)) (prn) ,@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.

1 0

[cells-cvs] CVS cells
by phildebrandt 11 Feb '08

11 Feb '08

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

1 0

[cells-cvs] CVS cells
by phildebrandt 11 Feb '08

11 Feb '08

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

1 0

[cells-cvs] CVS cells/utils-kt
by phildebrandt 11 Feb '08

11 Feb '08

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!

1 0

[cells-cvs] CVS cells-ode
by phildebrandt 09 Feb '08

09 Feb '08

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 ,@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 ,@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+))) + ,@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)))

1 0

[cells-cvs] CVS cells-ode
by phildebrandt 08 Feb '08

08 Feb '08

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

1 0