cells-cvs
Threads by month
- ----- 2025 -----
- July
- June
- May
- April
- March
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2006 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2005 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2004 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2003 -----
- December
- November
June 2008
- 2 participants
- 11 discussions
Update of /project/cells/cvsroot/cells/utils-kt
In directory clnet:/tmp/cvs-serv8789/utils-kt
Modified Files:
core.lisp debug.lisp detritus.lisp flow-control.lisp
Log Message:
nothing special
--- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/04/23 03:20:10 1.9
+++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/06/16 12:38:04 1.10
@@ -46,41 +46,26 @@
value)))
,@(when docstring (list docstring)))))
-
-(export! exe-path exe-dll font-path)
-
-#-iamnotkenny
-(defun exe-path ()
- #+its-alive!
- (excl:current-directory)
- #-its-alive!
+(defun test-setup (&optional drib)
+ #+(and allegro ide)
+ (ide.base::find-new-prompt-command
+ (cg.base::find-window :listener-frame))
+ (when drib
+ (dribble (merge-pathnames
+ (make-pathname :name drib :type "TXT")
+ (project-path)))))
+
+(export! test-setup test-prep test-init)
+(export! project-path)
+(defun project-path ()
+ #+(and allegro ide)
(excl:path-pathname (ide.base::project-file ide.base:*current-project*)))
-#-iamnotkenny
-(defun font-path ()
- (merge-pathnames
- (make-pathname
- :directory #+its-alive! (list :relative "font")
- #-its-alive! (append (butlast (pathname-directory
- (exe-path)
- ))
- (list "TY Extender" "font")))
- (exe-path)))
-
#+test
-(list (exe-path)(font-path))
+(test-setup)
-(defmacro exe-dll (&optional filename)
- (assert filename)
- (concatenate 'string filename ".dll"))
+(defun test-prep (&optional drib)
+ (test-setup drib))
-#+chya
-(defun exe-dll (&optional filename)
- (merge-pathnames
- (make-pathname :name filename :type "DLL"
- :directory (append (butlast (pathname-directory (exe-path)))
- (list "dll")))
- (exe-path)))
-
-#+test
-(probe-file (exe-dll "openal32"))
+(defun test-init (&optional drib)
+ (test-setup drib))
\ No newline at end of file
--- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/03/15 15:18:34 1.19
+++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/06/16 12:38:04 1.20
@@ -55,13 +55,13 @@
(defmacro count-it (&rest keys)
(declare (ignorable keys))
- #+(or) `(progn)
- `(when (car *counting*)
+ `(progn)
+ #+(or) `(when (car *counting*)
(call-count-it ,@keys)))
(defun call-count-it (&rest keys)
(declare (ignorable keys))
- (when (find (car keys) '(:trcfailed :TGTNILEVAL))
+ #+nahh (when (find (car keys) '(:trcfailed :TGTNILEVAL))
(break "clean up time ~a" keys))
(let ((entry (assoc keys *count* :test #'equal)))
(if entry
@@ -85,6 +85,7 @@
(when clearp (count-clear "show-count")))
+
;-------------------- timex ---------------------------------
(export! timex)
--- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/03/15 15:18:34 1.20
+++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/06/16 12:38:04 1.21
@@ -59,30 +59,6 @@
(defun collect-if (test list)
(remove-if-not test list))
-(defun test-setup (&optional drib)
- #-(or iamnotkenny its-alive!)
- (ide.base::find-new-prompt-command
- (cg.base::find-window :listener-frame))
- (when drib
- (dribble (merge-pathnames
- (make-pathname :name drib :type "TXT")
- (project-path)))))
-
-(export! project-path)
-(defun project-path ()
- #+allegro (excl:path-pathname (ide.base::project-file ide.base:*current-project*)))
-
-#+test
-(test-setup)
-
-(defun test-prep (&optional drib)
- (test-setup drib))
-
-(defun test-init (&optional drib)
- (test-setup drib))
-
-(export! test-setup test-prep test-init)
-
;;; --- FIFO Queue -----------------------------
(defun make-fifo-queue (&rest init-data)
--- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/03/15 15:18:34 1.13
+++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/06/16 12:38:04 1.14
@@ -150,11 +150,15 @@
(defun -1?1 (x) (* -1?1 x))
(defun prime? (n)
- (and (> n 1)
- (or (= 2 n)(oddp n))
- (loop for d upfrom 3 by 2 to (sqrt n)
- when (zerop (mod n d)) return nil
- finally (return t))))
+ (when (> n 1)
+ (cond
+ ((= 2 n) t)
+ ((evenp n) (values nil 2))
+ (t (loop for d upfrom 3 by 2 to (sqrt n)
+ when (zerop (mod n d)) do (return-from prime? (values nil d))
+ finally (return t))))))
+
+
; --- cloucell support for struct access of slots ------------------------
1
0
Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv8789
Modified Files:
cells-manifesto.txt cells.lisp defmodel.lisp family.lisp
fm-utilities.lisp integrity.lisp link.lisp md-slot-value.lisp
md-utilities.lisp model-object.lisp propagate.lisp
test-propagation.lisp trc-eko.lisp
Log Message:
nothing special
--- /project/cells/cvsroot/cells/cells-manifesto.txt 2008/03/15 15:18:34 1.13
+++ /project/cells/cvsroot/cells/cells-manifesto.txt 2008/06/16 12:38:03 1.14
@@ -13,8 +13,8 @@
(make-instance 'menu-item
:label "Cut"
:enabled (c? (bwhen (f (focus *window*))
- (and (typep focus 'text-widget)
- (selection-range focus)))))
+ (and (typep f 'text-widget)
+ (selection-range f)))))
Translated, the enabled state of the Cut menu item follows
whether or not the user is focused on a text-edit widget and
@@ -102,7 +102,9 @@
in principle impossible.
Which brings us to Cells. See also [axiom] Phillip Eby's developing axiomatic
-definition he is developing in support of Ryan Forseth's SoC project.
+definition he is developing in support of Ryan Forseth's SoC project. Mr. Eby was
+inspired by his involvement to develop Trellis, his own Cells work-alike library
+for Python.
DEFMODEL and Slot types
-----------------------
@@ -351,6 +353,9 @@
http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM
http://www.cs.utk.edu/~bvz/quickplan.html
+Flow-based programming, developed by J. Paul Morrison at IBM, 1971.
+ http://en.wikipedia.org/wiki/Flow-based_programming
+
Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963.
Steele himself cites Sketchpad as inexplicably unappreciated prior
art to his Constraints system:
--- /project/cells/cvsroot/cells/cells.lisp 2008/04/23 03:20:09 1.28
+++ /project/cells/cvsroot/cells/cells.lisp 2008/06/16 12:38:03 1.29
@@ -150,30 +150,31 @@
(break "~&i say, unhandled <c-enabling>: ~s" condition))))
(define-condition c-fatal (xcell)
- ((name :initarg :name :reader name)
- (model :initarg :model :reader model)
- (cell :initarg :cell :reader cell))
+ ((name :initform :anon :initarg :name :reader name)
+ (model :initform nil :initarg :model :reader model)
+ (cell :initform nil :initarg :cell :reader cell))
(:report (lambda (condition stream)
(format stream "~&fatal cell programming error: ~s" condition)
(format stream "~& : ~s" (name condition))
(format stream "~& : ~s" (model condition))
(format stream "~& : ~s" (cell condition)))))
-(define-condition c-unadopted (c-fatal)
- ()
+
+(define-condition asker-midst-askers (c-fatal)
+ ())
+;; "see listener for cell rule cycle diagnotics"
+
+(define-condition c-unadopted (c-fatal) ()
(:report
(lambda (condition stream)
(format stream "~&unadopted cell >: ~s" (cell condition))
(format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error"))))
-
(defun c-break (&rest args)
(unless *stop*
(let ((*print-level* 5)
(*print-circle* t)
(args2 (mapcar 'princ-to-string args)))
- (c-stop args)
-
- (format t "~&c-break > stopping > ~{~a ~}" args2)
- (print `(c-break-args ,@args2))
+ (c-stop :c-break)
+ ;(format t "~&c-break > stopping > ~{~a ~}" args2)
(apply 'error args2))))
\ No newline at end of file
--- /project/cells/cvsroot/cells/defmodel.lisp 2008/05/21 10:46:52 1.21
+++ /project/cells/cvsroot/cells/defmodel.lisp 2008/06/16 12:38:03 1.22
@@ -185,6 +185,8 @@
(list* `(:default-initargs ,@definitargs)
(nreverse class-options)))))))))
+
+
#+test
(progn
(defclass md-test-super ()())
--- /project/cells/cvsroot/cells/family.lisp 2008/04/23 03:20:09 1.28
+++ /project/cells/cvsroot/cells/family.lisp 2008/06/16 12:38:04 1.29
@@ -26,9 +26,13 @@
((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name)
(.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent)
(.value :initform nil :accessor value :initarg :value)
+ (register? :cell nil :initform nil :initarg :register? :reader register?)
(zdbg :initform nil :accessor dbg :initarg :dbg))
)
+(defmethod initialize-instance :after ((self model) &key)
+ (when (register? self)
+ (fm-register self)))
(defmethod print-cell-object ((md model))
(or (md-name md) :md?))
@@ -92,7 +96,14 @@
(.kids :initform (c-in nil) ;; most useful
:owning t
:accessor kids
- :initarg :kids)))
+ :initarg :kids)
+ (registry? :cell nil
+ :initform nil
+ :initarg :registry?
+ :accessor registry?)
+ (registry :cell nil
+ :initform nil
+ :accessor registry)))
#+test
(let ((c (find-class 'family)))
@@ -143,14 +154,11 @@
`(let ((,kid ,self))
(find-prior ,kid (kids (fm-parent ,kid))))))
-
-(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self)))
-
+(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self)))
(c-assert self)
(c-assert fm-parent)
(c-assert (typep fm-parent 'family))
-
(trc nil "md be adopted >" :kid self (adopt-ct self) :by fm-parent)
(when (plusp (adopt-ct self))
@@ -209,5 +217,45 @@
(declare (ignorable self))
(list ,@slot-defs)))
+; --- registry "namespacing" ---
+
+(defmethod registry? (other) (declare (ignore other)) nil)
+
+(defmethod initialize-instance :after ((self family) &key)
+ (when (registry? self)
+ (setf (registry self) (make-hash-table :test 'eq))))
+
+(defmethod fm-register (self &optional (guest self))
+ (assert self)
+ (if (registry? self)
+ (progn
+ (trc "fm-registering" (md-name guest) :with self)
+ (setf (gethash (md-name guest) (registry self)) guest))
+ (fm-register (fm-parent self) guest)))
+
+(defmethod fm-check-out (self &optional (guest self))
+ (assert self () "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent))
+ (if (registry? self)
+ (remhash (md-name guest) (registry self))
+ (bif (p (fm-parent self))
+ (fm-check-out p guest)
+ (break "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent)))))
+
+(defmethod fm-find-registered (id self &optional (must-find? self must-find?-supplied?))
+ (or (if (registry? self)
+ (gethash id (registry self))
+ (bwhen (p (fm-parent self))
+ (fm-find-registered id p must-find?)))
+ (when (and must-find? (not must-find?-supplied?))
+ (break "fm-find-registered failed seeking ~a starting search at node ~a" id self))))
+
+(export! rg? rg!)
+
+(defmacro rg? (id)
+ `(fm-find-registered ,id self nil))
+
+(defmacro rg! (id)
+ `(fm-find-registered ,id self))
+
\ No newline at end of file
--- /project/cells/cvsroot/cells/fm-utilities.lisp 2008/05/24 19:24:05 1.20
+++ /project/cells/cvsroot/cells/fm-utilities.lisp 2008/06/16 12:38:04 1.21
@@ -14,7 +14,7 @@
See the Lisp Lesser GNU Public License for more details.
-$Header: /project/cells/cvsroot/cells/fm-utilities.lisp,v 1.20 2008/05/24 19:24:05 fgoenninger Exp $
+$Header: /project/cells/cvsroot/cells/fm-utilities.lisp,v 1.21 2008/06/16 12:38:04 ktilton Exp $
|#
(in-package :cells)
@@ -702,7 +702,6 @@
:global-search global-search))))
(when (and must-find (null match))
(trc "fm-find-one > erroring fm-not-found, in family: " family :seeking md-name :global? global-search)
- ;;(inspect family)
(setq diag t must-find nil)
(fm-traverse family #'matcher
:skip-tree skip-tree
--- /project/cells/cvsroot/cells/integrity.lisp 2008/04/23 03:20:09 1.22
+++ /project/cells/cvsroot/cells/integrity.lisp 2008/06/16 12:38:04 1.23
@@ -66,6 +66,7 @@
*unfinished-business*
*defer-changes*)
(trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info)
+ (when *c-debug* (assert (boundp '*istack*)))
(when (or (zerop *data-pulse-id*)
(eq opcode :change))
(eko (nil "!!! New pulse, event" *data-pulse-id* defer-info)
@@ -77,15 +78,17 @@
(let ((*istack* (list (list opcode defer-info)
(list :trigger code)
(list :start-dp *data-pulse-id*))))
+ (trc "*istack* bound")
(handler-case
(go-go)
- (t (c)
+ (xcell (c)
(if (functionp *c-debug*)
(funcall *c-debug* c (nreverse *istack*))
(loop for f in (nreverse *istack*)
do (format t "~&istk> ~(~a~) " f)
finally (describe c)
- (break "integ backtrace: see listener for deets"))))))
+ (break "integ backtrace: see listener for deets")))))
+ (trc "*istack* unbinding"))
(go-go)))))
(defun ufb-queue (opcode)
@@ -163,7 +166,7 @@
; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem.
(bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
- #+x42 (trc "retelling dependenst, one new one being" uqp)
+ #+xxx (trc "retelling dependenst, one new one being" uqp)
(go tell-dependents))
;--- process client queue ------------------------------
--- /project/cells/cvsroot/cells/link.lisp 2008/03/15 15:18:34 1.26
+++ /project/cells/cvsroot/cells/link.lisp 2008/06/16 12:38:04 1.27
@@ -58,8 +58,7 @@
(defun c-unlink-unused (c &aux (usage (cd-usage c))
(usage-size (array-dimension (cd-usage c) 0))
- (dbg nil)) ;; #+not (and (typep (c-model c) 'mathx::mx-solver-stack)
- ;;(eq (c-slot-name c) '.kids))))
+ (dbg nil))
(declare (ignorable dbg usage-size))
(when (cd-useds c)
(let (rev-pos)
--- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/22 10:11:50 1.46
+++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/06/16 12:38:04 1.47
@@ -23,9 +23,11 @@
(defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
(when (and (not *not-to-be*)
(mdead self))
- (trc "md-slot-value passed dead self, returning NIL" self slot-name c)
- #-sbcl (inspect self)
- (break "see inspector for dead ~a" self)
+ (unless *stop*
+ (setf *stop* t)
+ (trc "md-slot-value passed dead self, returning NIL" self slot-name c)
+ #-sbcl (inspect self)
+ (break "see inspector for dead ~a" self))
(return-from md-slot-value nil))
(tagbody
retry
@@ -47,7 +49,7 @@
;; (count-it :md-slot-value slot-name)
(if c
(cell-read c)
- (values (bd-slot-value self slot-name) nil)))
+ (values (slot-value self slot-name) nil)))
(defun cell-read (c)
(assert (typep c 'cell))
@@ -61,12 +63,6 @@
(when (mdead s)
(break "model ~a is dead at ~a" s key)))
-;;;(defmethod trcp ((c cell))
-;;; (and *dbg*
-;;; (case (c-slot-name c)
-;;; (mathx::show-time t)
-;;; (ctk::app-time t))))
-
(defvar *trc-ensure* nil)
(defmethod ensure-value-is-current (c debug-id ensurer)
@@ -145,6 +141,7 @@
nil)
v)))
+
(defun calculate-and-set (c)
(flet ((body ()
(when (c-stopped)
@@ -154,19 +151,18 @@
#-its-alive!
(bwhen (x (find c *call-stack*)) ;; circularity
(unless nil ;; *stop*
- (let ((stack (copy-list *call-stack*)))
- (trc "calculating cell ~a appears in call stack: ~a" c x stack )))
- (setf *stop* t)
- (c-break "yep" c)
- (loop with caller-reiterated
- for caller in *call-stack*
- until caller-reiterated
- do (trc "caller:" caller)
- ;; not necessary (pprint (cr-code c))
- (setf caller-reiterated (eq caller c)))
+ (let ()
+ (inspect c)
+ (trc "calculating cell:" c (cr-code c))
+ (trc "appears-in-call-stack (newest first): " (length *call-stack*))
+ (loop for caller in (copy-list *call-stack*)
+ for n below (length *call-stack*)
+ do (trc "caller> " caller #+shhh (cr-code caller))
+ when (eq caller c) do (loop-finish))))
+ (setf *stop* t)
(c-break ;; break is problem when testing cells on some CLs
"cell ~a midst askers (see above)" c)
- (error "see listener for cell rule cycle diagnotics"))
+ (error 'asker-midst-askers :cell c))
(multiple-value-bind (raw-value propagation-code)
(calculate-and-link c)
@@ -197,6 +193,20 @@
(funcall (cr-rule c) c)
(c-unlink-unused c))))
+#+theabove!
+(defun calculate-and-set (c)
+ (multiple-value-bind (raw-value propagation-code)
+ (let ((*call-stack* (cons c *call-stack*))
+ (*depender* c)
+ (*defer-changes* t))
+ (cd-usage-clear-all c)
+ (multiple-value-prog1
+ (funcall (cr-rule c) c)
+ (c-unlink-unused c)))
+ (unless (c-optimized-away-p c)
+ (md-slot-value-assume c raw-value propagation-code))))
+
+
;-------------------------------------------------------------
(defun md-slot-makunbound (self slot-name
--- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/23 03:20:09 1.22
+++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/06/16 12:38:04 1.23
@@ -54,7 +54,7 @@
(:method ((self model-object))
(md-quiesce self))
-
+
(:method :before ((self model-object))
(loop for slot-name in (md-owning-slots self)
do (not-to-be (slot-value self slot-name))))
@@ -62,8 +62,7 @@
(:method :around ((self model-object))
(declare (ignorable self))
(let ((*not-to-be* t)
- (dbg nil #+not (or (eq (md-name self) :eclm-owner)
- (typep self '(or mathx::eclm-2008 clo:ix-form mathx::a1-panel mathx::edit-caret ctk:window)))))
+ (dbg nil))
(flet ((gok ()
(unless (eq (md-state self) :eternal-rest)
@@ -85,13 +84,15 @@
(mapcar 'type-of (slot-value self '.kids))))
(gok)
(when dbg (trc "finished nailing" self))))))))
-
+
(defun md-quiesce (self)
(trc nil "md-quiesce nailing cells" self (type-of self))
(md-map-cells self nil (lambda (c)
(trc nil "quiescing" c)
(c-assert (not (find c *call-stack*)))
- (c-quiesce c))))
+ (c-quiesce c)))
+ (when (register? self)
+ (fm-check-out self)))
(defun c-quiesce (c)
(typecase c
@@ -112,3 +113,78 @@
,@initargs
:fm-parent (progn (assert self) self)))
+(export! self-owned self-owned?)
+
+(defun (setf self-owned) (new-value self thing)
+ (if (consp thing)
+ (loop for e in thing do
+ (setf (self-owned self e) new-value))
+ (if new-value
+ (progn
+ (assert (not (find thing (z-owned self))))
+ (push thing (z-owned self)))
+ (progn
+ (assert (find thing (z-owned self)))
+ (setf (z-owned self)(delete thing (z-owned self)))))))
+
+(defun self-owned? (self thing)
+ (find thing (z-owned self)))
+
+(defvar *c-d-d*)
+(defvar *max-d-d*)
+
+
+(defun count-model (self)
+ (setf *c-d-d* (make-hash-table :test 'eq) *max-d-d* 0)
+ (with-metrics (t nil "cells statistics for" self)
+ (labels ((cc (self)
+ (count-it :thing)
+ (count-it :thing (type-of self))
+ ;(count-it :thing-type (type-of self))
+ (loop for (id . c) in (cells self)
+ do (count-it :live-cell)
+ ;(count-it :live-cell id)
+
+ (typecase c
+ (c-dependent
+ (count-it :dependent-cell)
+ (loop repeat (length (c-useds c))
+ do (count-it :cell-useds)
+ (count-it :dep-depth (c-depend-depth c))))
+ (otherwise (if (c-inputp c)
+ (count-it :c-input id)
+ (count-it :c-unknow))))
+
+ (loop repeat (length (c-callers c))
+ do (count-it :cell-callers)))
+
+ (loop repeat (length (cells-flushed self))
+ do (count-it :flushed-cell #+toomuchinfo id))
+
+ (loop for slot in (md-owning-slots self) do
+ (loop for k in (let ((sv (SLOT-VALUE self slot)))
+ (if (listp sv) sv (list sv)))
+ do (cc k)))))
+ (cc self))))
+
+(defun c-depend-depth (ctop)
+ (if (null (c-useds ctop))
+ 0
+ (or (gethash ctop *c-d-d*)
+ (labels ((cdd (c &optional (depth 1) chain)
+ (when (and (not (c-useds c))
+ (> depth *max-d-d*))
+ (setf *max-d-d* depth)
+ (trc "new dd champ from user" depth :down-to c)
+ (when (= depth 41)
+ (trc "end at" (c-slot-name c) :of (type-of (c-model c)))
+ (loop for c in chain do
+ (trc "called by" (c-slot-name c) :of (type-of (c-model c))))))
+ (setf (gethash c *c-d-d*)
+ ;(break "c-depend-depth ~a" c)
+ (progn
+ ;(trc "dd" c)
+ (1+ (loop for u in (c-useds c)
+ maximizing (cdd u (1+ depth) (cons c chain))))))))
+ (cdd ctop)))))
+
\ No newline at end of file
--- /project/cells/cvsroot/cells/model-object.lisp 2008/04/23 03:20:09 1.21
+++ /project/cells/cvsroot/cells/model-object.lisp 2008/06/16 12:38:04 1.22
@@ -21,15 +21,17 @@
;;; --- model-object ----------------------
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(md-name fm-parent .parent)))
+ (export '(md-name fm-parent .parent z-owned)))
(defclass model-object ()
((.md-state :initform :nascent :accessor md-state) ; [nil | :nascent | :alive | :doomed]
- (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p) ; [nil | :nascent | :alive | :doomed]
+ (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p)
(.cells :initform nil :accessor cells)
(.cells-flushed :initform nil :accessor cells-flushed
:documentation "cells supplied but un-whenned or optimized-away")
- (adopt-ct :initform 0 :accessor adopt-ct)))
+ (adopt-ct :initform 0 :accessor adopt-ct)
+ (z-owned :initform nil :accessor z-owned ;; experimental, not yet operative
+ :documentation "Things such as kids to be taken down when self is taken down")))
(defmethod md-state ((self symbol))
:alive)
@@ -202,7 +204,8 @@
(dolist (super (class-precedence-list (find-class class-name))
(setf (md-slot-cell-type class-name slot-name) nil))
(bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types)))
- (return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))))
+ (return-from md-slot-cell-type
+ (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))))
(defun (setf md-slot-cell-type) (new-type class-name slot-name)
(assert class-name)
@@ -216,12 +219,6 @@
do (setf (md-slot-cell-type (class-name c) slot-name) new-type)))
(cdar (push (cons slot-name new-type) (get class-name :cell-types)))))))
-#+hunh
-(md-slot-owning? 'mathx::prb-solver '.kids)
-
-#+hunh
-(cdr (assoc '.value (get 'm-index :indirect-ownings)))
-
#+test
(md-slot-owning? 'm-index '.value)
@@ -289,6 +286,10 @@
(defun (setf md-slot-cell) (new-cell self slot-name)
(if self ;; not on def-c-variables
(bif (entry (assoc slot-name (cells self)))
+ ; this next branch guessed it would only occur during kid-slotting,
+ ; before any dependency-ing could have happened, but a math-editor
+ ; is silently switching between implied-multiplication and mixed numbers
+ ; while they type and it
(let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
(declare (ignorable old))
(c-assert (null (c-callers old)))
--- /project/cells/cvsroot/cells/propagate.lisp 2008/04/23 03:20:09 1.36
+++ /project/cells/cvsroot/cells/propagate.lisp 2008/06/16 12:38:04 1.37
@@ -58,12 +58,8 @@
(setf (c-pulse c) *data-pulse-id*))
;--------------- propagate ----------------------------
-
-
; n.b. the cell argument may have been optimized away,
; though it is still receiving final processing here.
-;
-
(defparameter *per-cell-handler* nil)
--- /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/02 00:09:28 1.2
+++ /project/cells/cvsroot/cells/test-propagation.lisp 2008/06/16 12:38:04 1.3
@@ -22,7 +22,7 @@
(defun tcprop ()
(untrace)
- (test-prep)
+ (ukt:test-prep)
(LET ((box (make-instance 'tcp)))
(trc "changing top to 10" *data-pulse-id*)
(setf (top box) 10)
--- /project/cells/cvsroot/cells/trc-eko.lisp 2008/03/15 15:18:34 1.10
+++ /project/cells/cvsroot/cells/trc-eko.lisp 2008/06/16 12:38:04 1.11
@@ -19,13 +19,12 @@
(in-package :cells)
;----------- trc -------------------------------------------
-
+(defparameter *last-trc* (get-internal-real-time))
(defparameter *trcdepth* 0)
(defun trcdepth-reset ()
(setf *trcdepth* 0))
-
(defmacro trc (tgt-form &rest os)
(if (eql tgt-form 'nil)
'(progn)
@@ -45,8 +44,23 @@
(count-it :trcfailed)))
(count-it :tgtnileval)))))))
-(export! brk brkx .bgo)
+(defun call-trc (stream s &rest os)
+ ;(break)
+ (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
+ *trcdepth*)
+ (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
+ (format stream "~&"))
+ ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10))
+ (setf *last-trc* (get-internal-real-time))
+ (format stream "~a" s)
+ (let (pkwp)
+ (dolist (o os)
+ (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like
+ (setf pkwp (keywordp o))))
+ (force-output stream)
+ (values))
+(export! brk brkx .bgo)
(define-symbol-macro .bgo (break "go"))
@@ -68,23 +82,8 @@
nconcing (list (intern (format nil "~a" obj) :keyword) obj))))))
-(defparameter *last-trc* (get-internal-real-time))
-(defun call-trc (stream s &rest os)
- ;(break)
- (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
- *trcdepth*)
- (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
- (format stream "~&"))
- ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10))
- (setf *last-trc* (get-internal-real-time))
- (format stream "~a" s)
- (let (pkwp)
- (dolist (o os)
- (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like
- (setf pkwp (keywordp o))))
- (force-output stream)
- (values))
+
(defun call-trc-to-string (fmt$ &rest fmt-args)
(let ((o$ (make-array '(0) :element-type 'base-char
1
0
Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv8789/gui-geometry
Modified Files:
geo-family.lisp
Log Message:
nothing special
--- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2008/04/11 09:19:41 1.13
+++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2008/06/16 12:38:04 1.14
@@ -102,6 +102,7 @@
(^prior-sib-pr self (spacing .parent)))))))))))
+
(defun ^prior-sib-pb (self &optional (spacing 0)) ;; just keeping with -pt variant till both converted to defun
(bif (psib (find-prior self (kids .parent)
:test (lambda (sib)
@@ -118,23 +119,35 @@
(c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) -2))))
;--------------- geo.row.flow ----------------------------
-(export! geo-row-flow)
+(export! geo-row-flow fixed-col-width ^fixed-col-width ^spacing-hz spacing-hz
+ max-per-row ^max-per-row)
(defmd geo-row-flow (geo-inline)
(spacing-hz 0)
(spacing-vt 0)
(aligned :cell nil)
+ fixed-col-width
+ max-per-row
(row-flow-layout
(c? (loop with max-pb = 0 and pl = 0 and pt = 0
for k in (^kids)
- for kpr = (+ pl (l-width k))
+ for kn upfrom 0
+ for kw = (or (^fixed-col-width) (l-width k))
+ for kpr = (+ pl kw)
when (unless (= pl 0)
- (> kpr (- (l-width self) (outset self)))) do
+ (if (^max-per-row)
+ (zerop (mod kn (^max-per-row)))
+ (> kpr (- (l-width self) (outset self)))))
+ do
+ (when (> kpr (- (l-width self) (outset self)))
+ (trc nil "LR overflow break" kpr :gt (- (l-width self) (outset self))))
+ (when (zerop (mod kn (^max-per-row)))
+ (trc nil "max/row break" kn (^max-per-row) (mod kn (^max-per-row))))
(setf pl 0
pt (+ max-pb (downs (^spacing-vt))))
-
+
collect (cons pl pt) into pxys
- do (incf pl (+ (l-width k)(^spacing-hz)))
+ do (incf pl (+ kw (^spacing-hz)))
(setf max-pb (min max-pb (+ pt (downs (l-height k)))))
finally (return (cons max-pb pxys)))))
:lb (c? (+ (bif (xys (^row-flow-layout))
1
0
Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv8311
Modified Files:
CELTK.lpr CelloTk.lpr Celtk.lisp composites.lisp demos.lisp
lotsa-widgets.lisp run.lisp tk-object.lisp tk-structs.lisp
Added Files:
notebook.lisp
Log Message:
Notebook.lisp from Andy and random other recent work
--- /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/23 23:47:42 1.25
+++ /project/cells/cvsroot/Celtk/CELTK.lpr 2008/06/16 12:35:52 1.26
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.1 [Windows] (Mar 4, 2008 15:30)"; cg: "1.103.2.10"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Jun 3, 2008 13:12)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
@@ -33,7 +33,8 @@
(make-instance 'module :name "ltktest-ci.lisp")
(make-instance 'module :name "lotsa-widgets.lisp")
(make-instance 'module :name "demos.lisp")
- (make-instance 'module :name "andy-expander.lisp"))
+ (make-instance 'module :name "andy-expander.lisp")
+ (make-instance 'module :name "notebook.lisp"))
:projects (list (make-instance 'project-module :name
"..\\cells\\cells")
(make-instance 'project-module :name
--- /project/cells/cvsroot/Celtk/CelloTk.lpr 2008/01/03 20:23:30 1.3
+++ /project/cells/cvsroot/Celtk/CelloTk.lpr 2008/06/16 12:35:55 1.4
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Mar 11, 2007 7:25)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Apr 15, 2008 21:33)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
@@ -33,68 +33,76 @@
:main-form nil
:compilation-unit t
:verbose nil
- :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane
- :cg.bitmap-pane.clipboard :cg.bitmap-stream
- :cg.button :cg.caret :cg.check-box :cg.choice-list
- :cg.choose-printer :cg.clipboard
- :cg.clipboard-stack :cg.clipboard.pixmap
- :cg.color-dialog :cg.combo-box :cg.common-control
- :cg.comtab :cg.cursor-pixmap :cg.curve
- :cg.dialog-item :cg.directory-dialog
- :cg.directory-dialog-os :cg.drag-and-drop
- :cg.drag-and-drop-image :cg.drawable
- :cg.drawable.clipboard :cg.dropping-outline
- :cg.edit-in-place :cg.editable-text
- :cg.file-dialog :cg.fill-texture
- :cg.find-string-dialog :cg.font-dialog
- :cg.gesture-emulation :cg.get-pixmap
- :cg.get-position :cg.graphics-context
- :cg.grid-widget :cg.grid-widget.drag-and-drop
- :cg.group-box :cg.header-control :cg.hotspot
- :cg.html-dialog :cg.html-widget :cg.icon
- :cg.icon-pixmap :cg.ie :cg.item-list
- :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu
- :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget
- :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip
- :cg.message-dialog :cg.multi-line-editable-text
- :cg.multi-line-lisp-text :cg.multi-picture-button
- :cg.multi-picture-button.drag-and-drop
- :cg.multi-picture-button.tooltip :cg.ocx
- :cg.os-widget :cg.os-window :cg.outline
- :cg.outline.drag-and-drop
- :cg.outline.edit-in-place :cg.palette
- :cg.paren-matching :cg.picture-widget
- :cg.picture-widget.palette :cg.pixmap
- :cg.pixmap-widget :cg.pixmap.file-io
- :cg.pixmap.printing :cg.pixmap.rotate :cg.printing
- :cg.progress-indicator :cg.project-window
- :cg.property :cg.radio-button :cg.rich-edit
- :cg.rich-edit-pane :cg.rich-edit-pane.clipboard
- :cg.rich-edit-pane.printing :cg.sample-file-menu
- :cg.scaling-stream :cg.scroll-bar
- :cg.scroll-bar-mixin :cg.selected-object
- :cg.shortcut-menu :cg.static-text :cg.status-bar
- :cg.string-dialog :cg.tab-control
- :cg.template-string :cg.text-edit-pane
- :cg.text-edit-pane.file-io :cg.text-edit-pane.mark
- :cg.text-or-combo :cg.text-widget :cg.timer
- :cg.toggling-widget :cg.toolbar :cg.tooltip
- :cg.trackbar :cg.tray :cg.up-down-control
- :cg.utility-dialog :cg.web-browser
- :cg.web-browser.dde :cg.wrap-string
- :cg.yes-no-list :cg.yes-no-string :dde)
+ :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-pane
+ :cg.bitmap-pane.clipboard :cg.bitmap-stream
+ :cg.button :cg.caret :cg.check-box
+ :cg.choice-list :cg.choose-printer
+ :cg.clipboard :cg.clipboard-stack
+ :cg.clipboard.pixmap :cg.color-dialog
+ :cg.combo-box :cg.common-control :cg.comtab
+ :cg.cursor-pixmap :cg.curve :cg.dialog-item
+ :cg.directory-dialog :cg.directory-dialog-os
+ :cg.drag-and-drop :cg.drag-and-drop-image
+ :cg.drawable :cg.drawable.clipboard
+ :cg.dropping-outline :cg.edit-in-place
+ :cg.editable-text :cg.file-dialog
+ :cg.fill-texture :cg.find-string-dialog
+ :cg.font-dialog :cg.gesture-emulation
+ :cg.get-pixmap :cg.get-position
+ :cg.graphics-context :cg.grid-widget
+ :cg.grid-widget.drag-and-drop :cg.group-box
+ :cg.header-control :cg.hotspot :cg.html-dialog
+ :cg.html-widget :cg.icon :cg.icon-pixmap
+ :cg.ie :cg.item-list :cg.keyboard-shortcuts
+ :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane
+ :cg.lisp-text :cg.lisp-widget :cg.list-view
+ :cg.mci :cg.menu :cg.menu.tooltip
+ :cg.message-dialog
+ :cg.multi-line-editable-text
+ :cg.multi-line-lisp-text
+ :cg.multi-picture-button
+ :cg.multi-picture-button.drag-and-drop
+ :cg.multi-picture-button.tooltip :cg.ocx
+ :cg.os-widget :cg.os-window :cg.outline
+ :cg.outline.drag-and-drop
+ :cg.outline.edit-in-place :cg.palette
+ :cg.paren-matching :cg.picture-widget
+ :cg.picture-widget.palette :cg.pixmap
+ :cg.pixmap-widget :cg.pixmap.file-io
+ :cg.pixmap.printing :cg.pixmap.rotate
+ :cg.printing :cg.progress-indicator
+ :cg.project-window :cg.property
+ :cg.radio-button :cg.rich-edit
+ :cg.rich-edit-pane
+ :cg.rich-edit-pane.clipboard
+ :cg.rich-edit-pane.printing
+ :cg.sample-file-menu :cg.scaling-stream
+ :cg.scroll-bar :cg.scroll-bar-mixin
+ :cg.selected-object :cg.shortcut-menu
+ :cg.static-text :cg.status-bar
+ :cg.string-dialog :cg.tab-control
+ :cg.template-string :cg.text-edit-pane
+ :cg.text-edit-pane.file-io
+ :cg.text-edit-pane.mark :cg.text-or-combo
+ :cg.text-widget :cg.timer :cg.toggling-widget
+ :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray
+ :cg.up-down-control :cg.utility-dialog
+ :cg.web-browser :cg.web-browser.dde
+ :cg.wrap-string :cg.yes-no-list
+ :cg.yes-no-string :dde)
:splash-file-module (make-instance 'build-module :name "")
:icon-file-module (make-instance 'build-module :name "")
- :include-flags '(:top-level :debugger)
- :build-flags '(:allow-runtime-debug :purify)
+ :include-flags (list :top-level :debugger)
+ :build-flags (list :allow-runtime-debug :purify)
:autoload-warning t
:full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
:default-command-line-arguments "+M +t \"Console for Debugging\""
- :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 'celtk::cellogears
+ :on-initialization 'celtk::test
:on-restart 'do-default-restart)
;; End of Project Definition
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2008/01/03 20:23:30 1.42
+++ /project/cells/cvsroot/Celtk/Celtk.lisp 2008/06/16 12:35:55 1.43
@@ -16,10 +16,11 @@
|#
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.42 2008/01/03 20:23:30 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.43 2008/06/16 12:35:55 ktilton Exp $
;(pushnew :tile *features*) ;; frgo, 2007-09-21: Need to do this only when tile actually loaded
+
(defpackage :celtk
(:nicknames "CTK")
(:use :common-lisp :utils-kt :cells :cffi)
--- /project/cells/cvsroot/Celtk/composites.lisp 2008/04/11 09:23:51 1.28
+++ /project/cells/cvsroot/Celtk/composites.lisp 2008/06/16 12:35:56 1.29
@@ -148,6 +148,7 @@
Actually holds last event code, :focusin or :focusout")
on-key-down
on-key-up
+ (post-event-do nil :cell nil) ;; such as pop up alert for user
(show-tool-tips? (c-in t))
:width (c?n 800)
:height (c?n 600))
@@ -201,6 +202,8 @@
(setf (keyboard-modifiers .tkw)
(delete mod (keyboard-modifiers .tkw))))))
+
+
;;; Helper function that actually executes decoration change
(defun %%do-decoration (widget decoration)
(let ((path (path widget)))
--- /project/cells/cvsroot/Celtk/demos.lisp 2007/01/29 06:48:41 1.27
+++ /project/cells/cvsroot/Celtk/demos.lisp 2008/06/16 12:35:56 1.28
@@ -87,7 +87,7 @@
(make-instance 'entry
:id :entree
:fm-parent *parent*
- :value (c-in "Boots")))))))))
+ :value (c-in "kenzo")))))))))
(defun one-deep-menubar ()
(mk-menubar
--- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2008/01/03 20:23:30 1.11
+++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2008/06/16 12:35:56 1.12
@@ -37,7 +37,7 @@
(mk-label :text "aaa"
:image-files (list (list 'kt (data-pathname "kt69" "gif")))
:height 400
- :width 300
+ :width 200
:image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt)))
(assorted-canvas-items)
--- /project/cells/cvsroot/Celtk/run.lisp 2008/04/11 09:23:51 1.29
+++ /project/cells/cvsroot/Celtk/run.lisp 2008/06/16 12:35:56 1.30
@@ -29,11 +29,15 @@
(defun run-window (root-class &optional (resetp t) &rest window-initargs)
(assert (symbolp root-class))
(setf *tkw* nil)
+
(when resetp
(cells-reset 'tk-user-queue-handler))
(tk-interp-init-ensure)
(setf *tki* (Tcl_CreateInterp))
+ ;(break "ok?")
+ ;(deep)
+
;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42)
(tk-app-init *tki*)
(tk-togl-init *tki*)
@@ -53,25 +57,28 @@
(tcl-create-command *tki* "do-key-down" (get-callback 'do-on-key-down) (null-pointer) (null-pointer))
(tcl-create-command *tki* "do-key-up" (get-callback 'do-on-key-up) (null-pointer) (null-pointer))
-
+ (tcl-create-command *tki* "do-double-click-1" (get-callback 'do-on-double-click-1) (null-pointer) (null-pointer))
+ (trc "integ" cells::*within-integrity*)
+
(with-integrity () ;; w/i somehow ensures tkwin slot gets populated
(setf *app*
(make-instance 'application
:kids (c? (the-kids
(setf *tkw* (apply 'make-instance root-class
:fm-parent *parent*
- window-initargs))))
- )))
+ window-initargs)))))))
(assert (tkwin *tkw*))
(tk-format `(:fini) "wm deiconify .")
- (tk-format-now "bind . <Escape> {destroy .}")
+ #-its-alive! (tk-format-now "bind . <Escape> {destroy .}")
;
; see above for why we are converting key x-events to application key virtual events:
;
(tk-format-now "bind . <KeyPress> {do-key-down %W %K}")
(tk-format-now "bind . <KeyRelease> {do-key-up %W %K}")
+ (tk-format-now "bind . <Double-ButtonPress-1> {do-double-click-1 %W %K; break}")
+
(block nil
(bwhen (ifn (start-up-fn *tkw*))
(funcall ifn *tkw*))
@@ -152,6 +159,9 @@
(otherwise
(give-to-window)))))
(otherwise (give-to-window)))
+ (bwhen (do (post-event-do self))
+ (setf (post-event-do self) nil)
+ (funcall do self))
0)))
;; Our own event loop ! - Use this if it is desirable to do something
@@ -220,4 +230,5 @@
;
(defcommand key-down)
(defcommand key-up)
+(defcommand double-click-1)
--- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 23:47:42 1.16
+++ /project/cells/cvsroot/Celtk/tk-object.lisp 2008/06/16 12:35:56 1.17
@@ -31,7 +31,9 @@
:documentation "Long story. Tcl C API weak for keypress events. This gets dispatched
eventually thanks to DEFCOMMAND")
(on-key-up :initarg :on-key-up :accessor on-key-up :initform nil)
+ (on-double-click-1 :initarg :on-double-click-1 :accessor on-double-click-1 :initform nil)
(user-errors :initarg :user-errors :accessor user-errors :initform nil)
+
(tile? :initform t :cell nil :reader tile? :initarg :tile?))
(:documentation "Root class for widgets and (canvas) items"))
--- /project/cells/cvsroot/Celtk/tk-structs.lisp 2008/01/03 20:23:30 1.7
+++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2008/06/16 12:35:56 1.8
@@ -162,6 +162,8 @@
(defun xbe-x (xbe) (xbe x xbe))
(defun xbe-y (xbe) (xbe y xbe))
+(defun xbe-button (xbe) (xbe button xbe))
+(export! xbe-x xbe-y xbe-button xbe)
;; --------------------------------------------
--- /project/cells/cvsroot/Celtk/notebook.lisp 2008/06/16 12:35:56 NONE
+++ /project/cells/cvsroot/Celtk/notebook.lisp 2008/06/16 12:35:56 1.1
(in-package :celtk)
;--- n o t e b o o k ----------------------------------------------
#+test
(test-nb)
(deftk notebook (widget decoration-mixin)
()
(:tk-spec notebook
-height -padding -width)
(:default-initargs
:id (gentemp "NB")
:packing nil))
(defmethod make-tk-instance ((self notebook))
(tk-format `(:make-tk ,self) "ttk::notebook ~a" (^path))
(tk-format `(:pack ,self) "pack ~a -expand yes -fill both" (^path)))
(defobserver .kids ((self notebook))
(loop for k in (^kids)
do (trc "ttk::notebook adds" k (type-of k) (md-name k) (path k))
(tk-format `(:post-make-tk ,self) "~a add ~a -text ~a"
(^path)
(path k)
(text k))))
;--- t a b -----------------------------------------------------------
(deftk tab (frame-stack widget)
()
(:tk-spec tab
-state -sticky -padding -text -image)
(:default-initargs
:id (gentemp "TB")))
(defmacro mk-tab ((&rest inits) &body body)
`(make-instance 'tab :fm-parent *parent* ,@inits
:kids (c? (the-kids
,@body))))
(defmethod make-tk-instance ((self tab))
(tk-format `(:make-tk ,self) "frame ~a" (^path)))
;--- example usage ---------------------------------------------------
(defmd nb-test (window)
(kids (c? (the-kids
(mk-notebook
:width 100
:kids (c? (the-kids
(mk-tab (:text "first")
(mk-stack ("tab with container")
(mk-label :text "hi")))
(mk-tab (:text "second")
(mk-label :text "a")
(mk-label :text "b")))))))))
(defun test-nb ()
(test-window 'nb-test))
1
0
Update of /project/cells/cvsroot/Celtk/gears
In directory clnet:/tmp/cvs-serv8311/gears
Modified Files:
gears.lpr
Log Message:
Notebook.lisp from Andy and random other recent work
--- /project/cells/cvsroot/Celtk/gears/gears.lpr 2006/10/02 02:56:01 1.2
+++ /project/cells/cvsroot/Celtk/gears/gears.lpr 2008/06/16 12:35:56 1.3
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Apr 15, 2008 21:33)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
@@ -17,68 +17,76 @@
:main-form nil
:compilation-unit t
:verbose nil
- :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane
- :cg.bitmap-pane.clipboard :cg.bitmap-stream
- :cg.button :cg.caret :cg.check-box :cg.choice-list
- :cg.choose-printer :cg.clipboard
- :cg.clipboard-stack :cg.clipboard.pixmap
- :cg.color-dialog :cg.combo-box :cg.common-control
- :cg.comtab :cg.cursor-pixmap :cg.curve
- :cg.dialog-item :cg.directory-dialog
- :cg.directory-dialog-os :cg.drag-and-drop
- :cg.drag-and-drop-image :cg.drawable
- :cg.drawable.clipboard :cg.dropping-outline
- :cg.edit-in-place :cg.editable-text
- :cg.file-dialog :cg.fill-texture
- :cg.find-string-dialog :cg.font-dialog
- :cg.gesture-emulation :cg.get-pixmap
- :cg.get-position :cg.graphics-context
- :cg.grid-widget :cg.grid-widget.drag-and-drop
- :cg.group-box :cg.header-control :cg.hotspot
- :cg.html-dialog :cg.html-widget :cg.icon
- :cg.icon-pixmap :cg.ie :cg.item-list
- :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu
- :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget
- :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip
- :cg.message-dialog :cg.multi-line-editable-text
- :cg.multi-line-lisp-text :cg.multi-picture-button
- :cg.multi-picture-button.drag-and-drop
- :cg.multi-picture-button.tooltip :cg.ocx
- :cg.os-widget :cg.os-window :cg.outline
- :cg.outline.drag-and-drop
- :cg.outline.edit-in-place :cg.palette
- :cg.paren-matching :cg.picture-widget
- :cg.picture-widget.palette :cg.pixmap
- :cg.pixmap-widget :cg.pixmap.file-io
- :cg.pixmap.printing :cg.pixmap.rotate :cg.printing
- :cg.progress-indicator :cg.project-window
- :cg.property :cg.radio-button :cg.rich-edit
- :cg.rich-edit-pane :cg.rich-edit-pane.clipboard
- :cg.rich-edit-pane.printing :cg.sample-file-menu
- :cg.scaling-stream :cg.scroll-bar
- :cg.scroll-bar-mixin :cg.selected-object
- :cg.shortcut-menu :cg.static-text :cg.status-bar
- :cg.string-dialog :cg.tab-control
- :cg.template-string :cg.text-edit-pane
- :cg.text-edit-pane.file-io :cg.text-edit-pane.mark
- :cg.text-or-combo :cg.text-widget :cg.timer
- :cg.toggling-widget :cg.toolbar :cg.tooltip
- :cg.trackbar :cg.tray :cg.up-down-control
- :cg.utility-dialog :cg.web-browser
- :cg.web-browser.dde :cg.wrap-string
- :cg.yes-no-list :cg.yes-no-string :dde)
+ :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-pane
+ :cg.bitmap-pane.clipboard :cg.bitmap-stream
+ :cg.button :cg.caret :cg.check-box
+ :cg.choice-list :cg.choose-printer
+ :cg.clipboard :cg.clipboard-stack
+ :cg.clipboard.pixmap :cg.color-dialog
+ :cg.combo-box :cg.common-control :cg.comtab
+ :cg.cursor-pixmap :cg.curve :cg.dialog-item
+ :cg.directory-dialog :cg.directory-dialog-os
+ :cg.drag-and-drop :cg.drag-and-drop-image
+ :cg.drawable :cg.drawable.clipboard
+ :cg.dropping-outline :cg.edit-in-place
+ :cg.editable-text :cg.file-dialog
+ :cg.fill-texture :cg.find-string-dialog
+ :cg.font-dialog :cg.gesture-emulation
+ :cg.get-pixmap :cg.get-position
+ :cg.graphics-context :cg.grid-widget
+ :cg.grid-widget.drag-and-drop :cg.group-box
+ :cg.header-control :cg.hotspot :cg.html-dialog
+ :cg.html-widget :cg.icon :cg.icon-pixmap
+ :cg.ie :cg.item-list :cg.keyboard-shortcuts
+ :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane
+ :cg.lisp-text :cg.lisp-widget :cg.list-view
+ :cg.mci :cg.menu :cg.menu.tooltip
+ :cg.message-dialog
+ :cg.multi-line-editable-text
+ :cg.multi-line-lisp-text
+ :cg.multi-picture-button
+ :cg.multi-picture-button.drag-and-drop
+ :cg.multi-picture-button.tooltip :cg.ocx
+ :cg.os-widget :cg.os-window :cg.outline
+ :cg.outline.drag-and-drop
+ :cg.outline.edit-in-place :cg.palette
+ :cg.paren-matching :cg.picture-widget
+ :cg.picture-widget.palette :cg.pixmap
+ :cg.pixmap-widget :cg.pixmap.file-io
+ :cg.pixmap.printing :cg.pixmap.rotate
+ :cg.printing :cg.progress-indicator
+ :cg.project-window :cg.property
+ :cg.radio-button :cg.rich-edit
+ :cg.rich-edit-pane
+ :cg.rich-edit-pane.clipboard
+ :cg.rich-edit-pane.printing
+ :cg.sample-file-menu :cg.scaling-stream
+ :cg.scroll-bar :cg.scroll-bar-mixin
+ :cg.selected-object :cg.shortcut-menu
+ :cg.static-text :cg.status-bar
+ :cg.string-dialog :cg.tab-control
+ :cg.template-string :cg.text-edit-pane
+ :cg.text-edit-pane.file-io
+ :cg.text-edit-pane.mark :cg.text-or-combo
+ :cg.text-widget :cg.timer :cg.toggling-widget
+ :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray
+ :cg.up-down-control :cg.utility-dialog
+ :cg.web-browser :cg.web-browser.dde
+ :cg.wrap-string :cg.yes-no-list
+ :cg.yes-no-string :dde)
:splash-file-module (make-instance 'build-module :name "")
:icon-file-module (make-instance 'build-module :name "")
- :include-flags '(:top-level :debugger)
- :build-flags '(:allow-runtime-debug :purify)
+ :include-flags (list :top-level :debugger)
+ :build-flags (list :allow-runtime-debug :purify)
:autoload-warning t
:full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
:default-command-line-arguments "+M +t \"Console for Debugging\""
- :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 'gears::nehe-02
+ :on-initialization 'gears::gears
:on-restart 'do-default-restart)
;; End of Project Definition
1
0
Update of /project/cells/cvsroot/cells-ode
In directory clnet:/tmp/cvs-serv3184
Modified Files:
joints.lisp test-c-ode.lisp
Log Message:
attach joints by using slots body-1, body-2
--- /project/cells/cvsroot/cells-ode/joints.lisp 2008/06/01 20:26:49 1.4
+++ /project/cells/cvsroot/cells-ode/joints.lisp 2008/06/02 14:12:53 1.5
@@ -25,6 +25,8 @@
(def-ode-model joint ()
((joint-type :type int :ode-slot type :read-only t) ; returns one constant +ode:joint-type-...+
(feedback-struct :ode nil :cell nil :initform (foreign-alloc 'ode:joint-feedback))
+ (body-1 :ode nil)
+ (body-2 :ode nil)
(force-1 :ode nil)
(torque-1 :ode nil)
(force-2 :ode nil)
@@ -138,6 +140,15 @@
(def-ode-method attach ((self joint) (body1 object) (body2 object)))
(def-ode-method set-fixed ((self joint)))
(def-ode-method get-body ((self joint) (index int)) object)
+
+(defobserver body-1 ((self joint))
+ (when (and new-value (^body-2))
+ (attach self new-value (^body-2))))
+
+(defobserver body-2 ((self joint))
+ (when (and new-value (^body-1))
+ (attach self (^body-1) new-value)))
+
(defmethod bodies ((self joint))
(list (get-body self 0) (get-body self 1)))
--- /project/cells/cvsroot/cells-ode/test-c-ode.lisp 2008/06/01 20:26:49 1.4
+++ /project/cells/cvsroot/cells-ode/test-c-ode.lisp 2008/06/02 14:12:53 1.5
@@ -55,11 +55,12 @@
(make-instance 'body :md-name :body1 :position (c-in #(10 0 .5)) :mass (make-instance 'sphere-mass :mass 30))
(make-instance 'geom-box :md-name :geom1 :size #(1 1 1) :body (obj :body1))
- (make-instance 'body :md-name :body2 :position (c-in #(10 2 .5)) :mass (make-instance 'sphere-mass :mass .1))
- (make-instance 'geom-box :md-name :geom2 :size #(.1 .1 .1) :body (obj :body2))
+ (make-instance 'body :md-name :body2 :position (c-in #(10.6 0 .5)) :mass (make-instance 'sphere-mass :mass .5))
+ (make-instance 'geom-box :md-name :geom2 :size #(.1 .5 .1) :body (obj :body2))
- (make-instance 'hinge-joint :md-name :joint :axis #(0 1 0) :anchor #(10 1.2 .5))
- (attach (obj :joint) (obj :body1) (obj :body2)))
+ (make-instance 'hinge-joint :md-name :joint :axis #(1 0 0) :anchor #(10.5 0.5 .5) :body-1 (obj :body1) :body-2 (obj :body2))
+ ; (attach (obj :joint) (obj :body1) (obj :body2))
+ )
(defun tst-run (&key (diag nil) (step-size .01))
1
0
Update of /project/cells/cvsroot/cells-gtk3/cells-gtk
In directory clnet:/tmp/cvs-serv32220/cells-gtk
Modified Files:
widgets.lisp
Log Message:
fixed configure event
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/06/02 13:38:15 1.6
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/06/02 13:50:08 1.7
@@ -36,7 +36,6 @@
(let ((id (apply (symbol-function (new-function-name self))
(new-args self))))
(gtk-object-store id self)
- #+libcellsgtk (gtk-signal-connect-swap id "configure-event" (cffi:get-callback 'reshape-widget-handler) :data id)
id))))
(callbacks :cell nil :accessor callbacks
@@ -352,6 +351,10 @@
(allocated-height self) new-height))))
0)
+#+libcellsgtk
+(defmethod md-awaken :after ((self widget))
+ (gtk-signal-connect-swap (id self) "configure-event" (cffi:get-callback 'reshape-widget-handler) :data (id self)))
+
(defmethod focus ((self widget))
(gtk-widget-grab-focus (id self)))
1
0
Update of /project/cells/cvsroot/cells-gtk3/cells-gtk
In directory clnet:/tmp/cvs-serv29766/cells-gtk
Modified Files:
actions.lisp addon.lisp buttons.lisp callback.lisp
cells-gtk.asd dialogs.lisp display.lisp entry.lisp
gl-drawing-area.lisp layout.lisp menus.lisp textview.lisp
widgets.lisp
Log Message:
Ingo's patches: activate features in test-gtk.asd, clisp fixes, cells2 leftovers
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/actions.lisp 2008/04/13 10:59:16 1.1
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/actions.lisp 2008/06/02 13:38:15 1.2
@@ -14,17 +14,17 @@
()
:new-args (c_1 (list (name self) nil nil (stock-id self))))
-(def-c-output visible ((self action))
+(defobserver visible ((self action))
(gtk-ffi::gtk-object-set-property (id self) "visible" 'boolean new-value))
-(def-c-output sensitive ((self action))
+(defobserver sensitive ((self action))
(gtk-ffi::gtk-object-set-property (id self) "sensitive" 'boolean new-value))
-(def-c-output label ((self action))
+(defobserver label ((self action))
(when new-value
(gtk-ffi::with-gtk-string (str new-value)
(gtk-ffi::gtk-object-set-property (id self) "label" 'c-pointer str))))
-(def-c-output tooltip ((self action))
+(defobserver tooltip ((self action))
(when new-value
(gtk-ffi::with-gtk-string (str new-value)
(gtk-ffi::gtk-object-set-property (id self) "tooltip" 'c-pointer str))))
@@ -37,18 +37,17 @@
()
:new-args (c_1 (list (name self))))
-(def-c-output sensitive ((self action-group))
+(defobserver sensitive ((self action-group))
(gtk-ffi::gtk-action-group-set-sensitive (id self) new-value))
-(def-c-output visible ((self action-group))
+(defobserver visible ((self action-group))
(gtk-ffi::gtk-action-group-set-visible (id self) new-value))
-(def-c-output .kids ((self action-group))
+(defobserver .kids ((self action-group))
(dolist (kid old-value)
(gtk-ffi::gtk-action-group-remove-action (id self) (id kid)))
(dolist (kid new-value)
- (gtk-ffi::gtk-action-group-add-action-with-accel (id self) (id kid) (accel kid)))
- #+clisp (call-next-method))
+ (gtk-ffi::gtk-action-group-add-action-with-accel (id self) (id kid) (accel kid))))
(def-object ui-manager ()
((action-groups :accessor action-groups :initform (c-in nil))
@@ -56,7 +55,7 @@
()
())
-(def-c-output tearoffs ((self ui-manager))
+(defobserver tearoffs ((self ui-manager))
(gtk-ffi::gtk-ui-manager-set-add-tearoffs (id self) new-value))
(defmethod add-action-group ((self ui-manager) (group action-group) &optional pos)
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/addon.lisp 2008/04/13 10:59:16 1.1
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/addon.lisp 2008/06/02 13:38:15 1.2
@@ -42,7 +42,7 @@
(setf (value self) new-value)))
-(def-widget arrow ()
+(def-widget arrow (widget misc)
((type :accessor arrow-type :initarg :type :initform nil)
(type-id :accessor type-id
:initform (c? (case (arrow-type self)
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/20 13:05:02 1.4
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/06/02 13:38:15 1.5
@@ -38,8 +38,7 @@
(defobserver .kids ((self button))
(assert-bin self)
(dolist (kid (kids self))
- (gtk-container-add (id self) (id kid)))
- #+clisp (call-next-method))
+ (gtk-container-add (id self) (id kid))))
(defobserver stock ((self button))
(when new-value
@@ -98,5 +97,4 @@
(defobserver .value ((self radio-button))
(when (and new-value (upper self box))
(with-integrity (:change 'radio-up-to-box)
- (setf (value (upper self box)) (md-name self))))
- #+clisp (call-next-method))
+ (setf (value (upper self box)) (md-name self)))))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/callback.lisp 2008/04/13 10:59:16 1.1
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/callback.lisp 2008/06/02 13:38:15 1.2
@@ -29,7 +29,7 @@
(format nil "gtk_server_connect(~A, ~A, :callback ~A)"
(id self) event (register-callback self event fn)))
-(def-c-output bindings () ;;; (w widget) event fun)
+(defobserver bindings () ;;; (w widget) event fun)
(loop for binding in new-value
do (destructuring-bind (event . fn) binding
(declare (ignorable event))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/14 16:43:42 1.2
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/06/02 13:38:15 1.3
@@ -11,13 +11,13 @@
;;;
;;; run gtk in its own thread (requires bordeaux-threads)
-(pushnew :cells-gtk-threads *features*)
+;;(pushnew :cells-gtk-threads *features*)
;;; drawing-area widget using cairo (requires cl-cairo2)
-(pushnew :cells-gtk-cairo *features*)
+;;(pushnew :cells-gtk-cairo *features*)
;;; drawing-area widget using OpenGL (requires libgtkglext1)
-(pushnew :cells-gtk-opengl *features*)
+;;(pushnew :cells-gtk-opengl *features*)
(asdf:defsystem :cells-gtk
:name "cells-gtk"
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/20 13:05:02 1.2
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/06/02 13:38:15 1.3
@@ -169,5 +169,15 @@
+c-null+)))
(defun file-chooser (&rest inits)
- (apply #'show-dialog 'file-chooser-dialog inits))
+ (bwhen (fn-string (apply #'show-dialog 'file-chooser-dialog inits))
+ (let ((fn (parse-namestring fn-string))
+ (action (getf inits :action)))
+ (flet ((fail (format-string &rest format-args)
+ (show-message (apply #'format nil format-string format-args)
+ :title (format nil "File ~(~a~) error" action))
+ nil))
+ (case action
+ (:open (or (and (file-namestring fn) (probe-file fn))
+ (fail "\"~a\" is not a valid filename." fn-string)))
+ (t fn-string))))))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/display.lisp 2008/04/13 10:59:17 1.1
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/display.lisp 2008/06/02 13:38:15 1.2
@@ -49,14 +49,43 @@
`(format nil "~a ~a </span>" ,markup-start (format nil "~{~a~}" (list ,@rest))))))
-(def-widget label ()
+;;;
+;;; misc
+;;;
+
+;;; adds padding and alignment to label, arrow, image, and (pixmap)
+
+(defmd misc ()
+ xalign :xalign (c-in .5)
+ yalign :yalign (c-in .5)
+ xpad :xpad (c-in 0.0)
+ ypad :ypad (c-in 0.0))
+
+(defobserver xalign ((self misc))
+ (gtk-misc-set-alignment (id self) (^xalign) (^yalign)))
+
+(defobserver yalign ((self misc))
+ (gtk-misc-set-alignment (id self) (^xalign) (^yalign)))
+
+(defobserver xpad ((self misc))
+ (gtk-misc-set-padding (id self) (^xpad) (^ypad)))
+
+(defobserver ypad ((self misc))
+ (gtk-misc-set-padding (id self) (^xpad) (^ypad)))
+
+;;;
+;;; label
+;;;
+
+(def-widget label (widget misc)
((markup :accessor markup :initarg :markup :initform nil)
(text :accessor text :initarg :text :initform nil))
(line-wrap selectable use-markup)
()
:text (c-in nil)
:use-markup (c? (not (null (markup self))))
- :new-args (c_1 (list nil)))
+ :new-args (c_1 (list nil))
+ :xalign (c-in 0.0))
(defobserver text ((self label))
(when new-value
@@ -72,7 +101,7 @@
()
:id (c_1 (gtk-accel-label-new (text self))))
-(def-widget image ()
+(def-widget image (widget misc)
((filename :accessor filename :initarg :filename :initform nil)
(stock :accessor stock :initarg :stock :initform nil)
(stock-id :accessor stock-id
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/entry.lisp 2008/04/13 10:59:17 1.1
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/entry.lisp 2008/06/02 13:38:15 1.2
@@ -38,22 +38,23 @@
(init :accessor init :initarg :init :initform nil))
(editable has-frame max-length)
(changed activate)
- :on-changed (callback-if (auto-update self)
+ :on-changed (callback-if (auto-update self) ; this is broken and never gets called
(widget event data)
(with-integrity (:change 'entry-changed-cb)
+ (trc "entry on-changed")
(let ((txt (get-gtk-string (gtk-entry-get-text widget))))
- (trc nil "ENTRY (ON-CHANGED)" txt) (force-output)
+ (trc "ENTRY (ON-CHANGED)" txt) (force-output)
(setf (value self) txt))))
- :on-activate (callback-if (not (auto-update self))
+ :on-activate (callback-if (not (auto-update self)) ; this is called on pressing enter
(widget event data)
+ (trc "entry on-activate")
(with-integrity (:change 'entry-activate-cb)
(let ((txt (get-gtk-string (gtk-entry-get-text widget))))
(trc nil "ENTRY (ON-ACTIVATE)" txt) (force-output)
(setf (value self) (if (equal txt "") nil txt))))))
(defobserver text ((self entry))
- (when new-value
- (gtk-entry-set-text (id self) new-value)))
+ (gtk-entry-set-text (id self) (or new-value "")))
(defobserver init ((self entry))
(when (stringp new-value) ;; could be null or numeric for spin button
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/14 16:43:42 1.2
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/06/02 13:38:15 1.3
@@ -1,4 +1,4 @@
-
+
(in-package :cgtk)
@@ -24,6 +24,7 @@
(defun gl-init ()
(gtk-gl-init +c-null+ +c-null+)
+ (glut:init)
(setf *gl-config* (get-gl-config)))
@@ -66,12 +67,22 @@
(defun %resize (self)
(let ((width (allocated-width self))
(height (allocated-height self)))
- (when (and (plusp width) (plusp height))
- (trc "%resize to" width height)
- (with-gl-context (self)
- (gl:viewport 0 0 width height)
- (bwhen (resize-fn (resize self))
- (funcall resize-fn self))))))
+ (when (and (plusp width) (plusp height))
+ (trc "%resize to" width height)
+ (with-gl-context (self)
+ (gl:viewport 0 0 width height)
+
+ ;; set projection to account for aspect
+ (gl:matrix-mode :projection)
+ (gl:load-identity)
+ (glu:perspective 90 (/ width height) 0.5 20) ; 90 degrees field of view y, clip 0.5-20 z
+
+ ;; set modelview to identity
+ (gl:matrix-mode :modelview)
+ (gl:load-identity)
+
+ (bwhen (resize-fn (resize self))
+ (funcall resize-fn self))))))
;;;
;;; Widget
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/layout.lisp 2008/04/13 10:59:17 1.1
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/layout.lisp 2008/06/02 13:38:15 1.2
@@ -30,8 +30,7 @@
(when new-value
(dolist (kid new-value)
(gtk-box-pack-start (id self) (id kid)
- (expand? kid) (fill? kid) (padding? kid)))
- #+clisp (call-next-method)))
+ (expand? kid) (fill? kid) (padding? kid)))))
(def-widget hbox (box)
() () ()
@@ -93,8 +92,7 @@
(and (cadr new-value)
(gtk-paned-add2 (id self) (id (make-be 'frame
:shadow 'in
- :kids (kids-list? (cadr new-value)))))))
- #+clisp (call-next-method))
+ :kids (kids-list? (cadr new-value))))))))
(def-widget vpaned ()
((divider-pos :accessor divider-pos :initarg :divider-pos :initform (c-in 0)))
@@ -113,9 +111,7 @@
(and (cadr new-value)
(gtk-paned-add2 (id self) (id (make-be 'frame
:shadow 'in
- :kids (kids-list? (cadr new-value)))))))
- #+clisp (call-next-method))
-
+ :kids (kids-list? (cadr new-value))))))))
(def-widget frame (container)
((shadow :accessor shadow? :initarg :shadow :initform nil)
@@ -143,8 +139,7 @@
(defobserver .kids ((self frame))
(assert-bin self)
(dolist (kid new-value)
- (gtk-container-add (id self) (id kid)))
- #+clisp (call-next-method))
+ (gtk-container-add (id self) (id kid))))
(def-widget aspect-frame (frame)
((xalign :accessor xalign :initarg :xalign :initform 0.5)
@@ -178,8 +173,7 @@
(defobserver .kids ((self expander))
(assert-bin self)
(dolist (kid new-value)
- (gtk-container-add (id self) (id kid)))
- #+clisp (call-next-method))
+ (gtk-container-add (id self) (id kid))))
(def-widget scrolled-window (container)
()
@@ -194,20 +188,25 @@
(dolist (kid new-value)
(if (member (class-name (class-of kid)) '(listbox treebox tree-view text-view layout) :test #'equal)
(gtk-container-add (id self) (id kid))
- (gtk-scrolled-window-add-with-viewport (id self) (id kid))))
- #+clisp (call-next-method))
+ (gtk-scrolled-window-add-with-viewport (id self) (id kid)))))
(def-widget notebook (container)
((tab-labels :accessor tab-labels :initarg :tab-labels :initform (c-in nil))
(tab-labels-widgets :accessor tab-labels-widgets :initform (c-in nil))
(show-page :accessor show-page :initarg :show-page :initform (c-in 0))
- (tab-pos :accessor tab-pos :initarg :tab-pos :initform (c-in nil)))
+ (tab-pos :accessor tab-pos :initarg :tab-pos :initform (c-in nil))
+ (selected-page :accessor selected-page :initform (c-in nil)))
(current-page show-tabs show-border scrollable tab-border
homogeneous-tabs)
- ()
+ (select-page)
:current-page (c-in nil)
- :show-tabs (c-in t))
-
+ :show-tabs (c-in t)
+ :on-select-page (callback (w e d)
+ (with-integrity (:change :selected-page)
+ (trc "on select page is called" self (when self (kids self)))
+ (when (and self (kids self))
+ (setf (selected-page self)
+ (nth (gtk-notebook-get-current-page (id self)) (kids self)))))))
(defobserver tab-pos ((self notebook))
(when new-value
@@ -243,8 +242,7 @@
(loop for page from 0 to (length new-value) do
(setf (current-page self) page))
(when (and (show-page self) (>= (show-page self) 0) (< (show-page self) (length new-value)))
- (setf (current-page self) (show-page self)))
- #+clisp (call-next-method)))
+ (setf (current-page self) (show-page self)))))
(defobserver show-tabs ((self notebook))
(gtk-notebook-set-show-tabs (id self) new-value))
@@ -304,5 +302,4 @@
(defobserver .kids ((self alignment))
(assert-bin self)
(dolist (kid new-value)
- (gtk-container-add (id self) (id kid)))
- #+clisp (call-next-method))
+ (gtk-container-add (id self) (id kid))))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/menus.lisp 2008/04/13 10:59:17 1.1
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/menus.lisp 2008/06/02 13:38:15 1.2
@@ -160,8 +160,7 @@
(assert-bin self)
(when new-value
(dolist (kid new-value)
- (gtk-container-add (id self) (id kid))))
- #+clisp (call-next-method))
+ (gtk-container-add (id self) (id kid)))))
(def-widget separator-tool-item (tool-item)
()
@@ -202,8 +201,7 @@
(defobserver .kids ((self menu-shell))
(when new-value
(dolist (kid new-value)
- (gtk-menu-shell-append (id self) (id kid))))
- #+clisp (call-next-method))
+ (gtk-menu-shell-append (id self) (id kid)))))
(def-widget menu-bar (menu-shell)
() () ())
@@ -295,8 +293,7 @@
(defobserver .value ((self radio-menu-item))
(with-integrity (:change 'radio-menu-item-value)
(when (and new-value (upper self menu-item))
- (setf (value (upper self menu-item)) (md-name self))))
- #+clisp (call-next-method))
+ (setf (value (upper self menu-item)) (md-name self)))))
(def-widget image-menu-item (menu-item)
((stock :accessor stock :initarg :stock :initform nil)
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/textview.lisp 2008/04/13 10:59:17 1.1
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/textview.lisp 2008/06/02 13:38:15 1.2
@@ -151,7 +151,7 @@
(buf (gtk-text-view-get-buffer view)))
(with-text-iters (s-iter)
(gtk-text-buffer-get-iter-at-offset buf s-iter pos)
- (gtk-text-view-scroll-to-iter view s-iter 0.0 nil 0.0 0.0))))
+ (gtk-text-view-scroll-to-iter view s-iter 0.0d0 nil 0.0d0 0.0d0))))
;;; The next two can be used to check and clear the the modified flag.
;;; The event is registered when you use :on-modified-changed on a text-buffer.
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/05/19 10:18:34 1.5
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/06/02 13:38:15 1.6
@@ -190,6 +190,7 @@
(def-gtk-event-handler delete-event)
(def-gtk-event-handler destroy-event)
(def-gtk-event-handler modified-changed)
+(def-gtk-event-handler select-page)
(defparameter *widget-callbacks*
(list (cons 'clicked (cffi:get-callback 'clicked-handler))
@@ -201,7 +202,8 @@
(cons 'toggled (cffi:get-callback 'toggled-handler))
(cons 'delete-event (cffi:get-callback 'delete-event-handler))
(cons 'destroy-event (cffi:get-callback 'destroy-event-handler))
- (cons 'modified-changed (cffi:get-callback 'modified-changed-handler))))
+ (cons 'modified-changed (cffi:get-callback 'modified-changed-handler))
+ (cons 'select-page (cffi:get-callback 'select-page-handler))))
(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -311,7 +313,7 @@
r))))
(c-id (cffi:foreign-alloc :int :initial-element id)))
(trc nil "timeout-add > passing cb data, *data" c-id (cffi:mem-aref c-id :int 0))
- (g-timeout-add milliseconds (cffi:get-callback 'timeout-handler-callback) c-id)))
+ (g-timeout-add (floor milliseconds) (cffi:get-callback 'timeout-handler-callback) c-id)))
(def-object widget ()
((tooltip :accessor tooltip :initarg :tooltip :initform (c-in nil))
@@ -473,8 +475,7 @@
(dolist (kid new-value)
; (when *gtk-debug* (format t "~% window ~A has kid ~A" self kid))
(when *gtk-debug* (trc "WINDOW ADD KID" (md-name self) (md-name kid)) (force-output))
- (gtk-container-add (id self) (id kid)))
- #+clisp (call-next-method))
+ (gtk-container-add (id self) (id kid))))
(def-widget event-box (container)
((visible-window :accessor visible-window :initarg :visible-window :initform nil))
1
0
Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk
In directory clnet:/tmp/cvs-serv29766/cells-gtk/test-gtk
Modified Files:
test-gtk.asd
Log Message:
Ingo's patches: activate features in test-gtk.asd, clisp fixes, cells2 leftovers
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.asd 2008/04/14 16:43:48 1.2
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.asd 2008/06/02 13:38:21 1.3
@@ -3,11 +3,11 @@
;;; run gtk in its own thread (requires bordeaux-threads)
(pushnew :cells-gtk-threads *features*)
-;;; drawing-area widget using cairo (requires cl-cairo2)
+;;; drawing-area widget using cairo
+;;; (requires cl-cairo2, libgtkglext1 and libcellsgtk)
(pushnew :cells-gtk-cairo *features*)
-
-;;; drawing-area widget using OpenGL (requires libgtkglext1)
(pushnew :cells-gtk-opengl *features*)
+(pushnew :libcellsgtk *features*)
(asdf:defsystem :test-gtk
1
0
Update of /project/cells/cvsroot/cells-gtk3/gtk-ffi
In directory clnet:/tmp/cvs-serv29766/gtk-ffi
Modified Files:
gtk-ffi.asd gtk-other.lisp
Log Message:
Ingo's patches: activate features in test-gtk.asd, clisp fixes, cells2 leftovers
--- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.asd 2008/04/14 16:43:55 1.2
+++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.asd 2008/06/02 13:38:21 1.3
@@ -9,7 +9,7 @@
;;; Step 2 -- If you built or downloaded the libcellsgtk library, uncomment the next line.
;;; features
-(pushnew :libcellsgtk *features*)
+;;(pushnew :libcellsgtk *features*)
(asdf:defsystem :gtk-ffi
:name "gtk-ffi"
--- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-other.lisp 2008/05/05 15:30:14 1.3
+++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-other.lisp 2008/06/02 13:38:21 1.4
@@ -20,9 +20,9 @@
(def-gtk-lib-functions :gtk
- ;; main-loop
- (gtk-init :void
- ((argc :pointer) (argv :pointer)))
+ ;; main-loop
+ (gtk-init :void
+ ((argc :pointer) (argv :pointer)))
(gtk-init-check gtk-boolean
((argc :pointer)
(argv :pointer)))
@@ -41,6 +41,15 @@
(gtk-main-level :int ())
(gtk-get-current-event-time :unsigned-int ())
+ ;; misc
+ (gtk-misc-set-alignment :void
+ ((widget :pointer)
+ (xalign :float)
+ (yalign :float)))
+ (gtk-misc-set-padding :void
+ ((widget :pointer)
+ (xpad :float)
+ (ypad :float)))
;;container
(gtk-container-add :pointer
((container :pointer)
@@ -54,10 +63,10 @@
(gtk-container-get-border-width :unsigned-int
((container :pointer)))
(gtk-container-set-resize-mode :void
- ((container :pointer)
- (mode :unsigned-int)))
+ ((container :pointer)
+ (mode :unsigned-int)))
(gtk-container-get-resize-mode :unsigned-int
- ((container :pointer)))
+ ((container :pointer)))
;;box
(gtk-box-pack-start :void
((box :pointer)
@@ -257,6 +266,8 @@
(gtk-notebook-set-current-page :void
((notebook :pointer)
(page-num :int)))
+ (gtk-notebook-get-current-page :int
+ ((notebook :pointer)))
(gtk-notebook-set-tab-pos :void
((notebook :pointer)
(pos :int)))
1
0
Update of /project/cells/cvsroot/cells-ode
In directory clnet:/tmp/cvs-serv28676
Modified 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:
added license
--- /project/cells/cvsroot/cells-ode/bodies.lisp 2008/02/09 11:18:12 1.2
+++ /project/cells/cvsroot/cells-ode/bodies.lisp 2008/06/01 20:26:48 1.3
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
(in-package :c-ode)
@@ -30,6 +47,10 @@
(:default-initargs
:ode-id (call-ode body-create ((*world* object)))))
+(export! ode-position)
+(defmethod ode-position ((self body))
+ (^position))
+
(defmethod initialize-instance :after ((self body) &rest initargs))
(defmethod ode-destroy ((self body))
--- /project/cells/cvsroot/cells-ode/cells-ode.asd 2008/02/09 11:18:12 1.2
+++ /project/cells/cvsroot/cells-ode/cells-ode.asd 2008/06/01 20:26:49 1.3
@@ -1,3 +1,19 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
(asdf:defsystem :cells-ode
:name "cells-ode"
--- /project/cells/cvsroot/cells-ode/collision.lisp 2008/02/09 14:02:16 1.3
+++ /project/cells/cvsroot/cells-ode/collision.lisp 2008/06/01 20:26:49 1.4
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
;;; -----------------------------------------------------------------------------------------------
;;; collision detection
--- /project/cells/cvsroot/cells-ode/core.lisp 2008/02/09 11:18:12 1.2
+++ /project/cells/cvsroot/cells-ode/core.lisp 2008/06/01 20:26:49 1.3
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
(in-package :cells-ode)
@@ -215,7 +232,7 @@
(defmethod update ((self ,name))
,@updaters
(call-next-method))
- (eval-now! (export ',exports))))))))
+ (eval-now! (export ',(append (list name) exports)))))))))
--- /project/cells/cvsroot/cells-ode/geoms.lisp 2008/02/09 11:18:12 1.2
+++ /project/cells/cvsroot/cells-ode/geoms.lisp 2008/06/01 20:26:49 1.3
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
;;;
;;; geom
@@ -19,6 +36,10 @@
))
+(export! ode-space)
+(defmethod ode-space ((self general-geom))
+ (^space))
+
(defmethod ode-destroy ((self general-geom))
(call-ode geom-destroy ((self object)))
(call-next-method))
@@ -45,6 +66,10 @@
(quaternion :type quaternion :result-arg t)
))
+(export! ode-position)
+(defmethod ode-position ((self geom))
+ (^position))
+
(defmethod echo-slots append ((self geom))
'(position quaternion))
@@ -81,6 +106,10 @@
(:default-initargs
:geom-obj (call-ode create-capsule ((*space* object) (1 number) (1 number)))))
+(export! ode-length)
+(defmethod ode-length ((self geom-capsule))
+ (^length))
+
(def-ode-method set-params ((self geom-capsule) (radius number) (length number)))
(defobserver radius ((self geom-capsule) newval)
@@ -123,6 +152,10 @@
(:default-initargs
:geom-obj (call-ode create-ray ((*space* object) (1 number)))))
+(export! ode-length)
+(defmethod ode-length ((self geom-ray))
+ (^length))
+
(def-ode-method (ray-set :ode-name set) ((self geom-ray) (starting-point vector) (direction vector)))
(defobserver starting-point ((self geom-ray) newval)
@@ -163,3 +196,4 @@
+
--- /project/cells/cvsroot/cells-ode/joints.lisp 2008/02/09 11:18:12 1.3
+++ /project/cells/cvsroot/cells-ode/joints.lisp 2008/06/01 20:26:49 1.4
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
(in-package :c-ode)
@@ -24,11 +41,12 @@
(defmacro propagate-feedback (feedback-struct joint)
`(with-foreign-slots ((ode:f-1 ode:t-1 ode:f-2 ode:t-2) ,feedback-struct ode:joint-feedback)
- ,@(loop for (ode slot) on '(f-1 force-1 t-1 torque-1 f-2 torque-2) by #'cddr
+ ,@(loop for (ode slot) on '(f-1 force-1 t-1 torque-1 f-2 force-2 t-2 torque-2) by #'cddr
collect `(setf (,slot ,joint) (coerce (loop for i from 0 below 3 collecting (mem-aref ,(intern (string ode) :ode) 'real i)) 'vector)))))
(defmethod update :after ((self joint))
- (propagate-feedback (feedback-struct self) self))
+ (unless (typep self 'contact-joint)
+ (propagate-feedback (feedback-struct self) self)))
;;;
--- /project/cells/cvsroot/cells-ode/mass.lisp 2008/02/09 14:02:17 1.3
+++ /project/cells/cvsroot/cells-ode/mass.lisp 2008/06/01 20:26:49 1.4
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
(in-package :c-ode)
--- /project/cells/cvsroot/cells-ode/objects.lisp 2008/02/09 14:02:17 1.3
+++ /project/cells/cvsroot/cells-ode/objects.lisp 2008/06/01 20:26:49 1.4
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
;;;
--- /project/cells/cvsroot/cells-ode/ode-compat.lisp 2008/02/09 11:18:12 1.2
+++ /project/cells/cvsroot/cells-ode/ode-compat.lisp 2008/06/01 20:26:49 1.3
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
;;; this is to correct typos and inconsistencies in cl-ode
--- /project/cells/cvsroot/cells-ode/package.lisp 2008/02/09 11:18:12 1.2
+++ /project/cells/cvsroot/cells-ode/package.lisp 2008/06/01 20:26:49 1.3
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
(in-package :cl-user)
--- /project/cells/cvsroot/cells-ode/primitives.lisp 2008/02/09 11:18:12 1.2
+++ /project/cells/cvsroot/cells-ode/primitives.lisp 2008/06/01 20:26:49 1.3
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
;;;
;;; code to implement primitives (body + mass + geom)
--- /project/cells/cvsroot/cells-ode/simulate.lisp 2008/02/09 14:02:17 1.3
+++ /project/cells/cvsroot/cells-ode/simulate.lisp 2008/06/01 20:26:49 1.4
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
(in-package :c-ode)
@@ -6,6 +23,8 @@
;;; init & cleanup
;;;
+(export! ode-init ode-cleanup ode-step)
+
(defun ode-init ()
(when *objects* (ode-cleanup))
(ode:init-ode)
--- /project/cells/cvsroot/cells-ode/test-c-ode.lisp 2008/02/09 11:18:12 1.3
+++ /project/cells/cvsroot/cells-ode/test-c-ode.lisp 2008/06/01 20:26:49 1.4
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
(in-package :c-ode)
--- /project/cells/cvsroot/cells-ode/types.lisp 2008/02/09 14:02:17 1.3
+++ /project/cells/cvsroot/cells-ode/types.lisp 2008/06/01 20:26:49 1.4
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
;;;
;;; ODE Type conversion
--- /project/cells/cvsroot/cells-ode/utility.lisp 2008/02/09 11:18:12 1.2
+++ /project/cells/cvsroot/cells-ode/utility.lisp 2008/06/01 20:26:49 1.3
@@ -1,4 +1,22 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+
;;;
;;; utilty funcs --------------------------------------------------------------------------
;;;
--- /project/cells/cvsroot/cells-ode/world.lisp 2008/02/09 14:02:17 1.4
+++ /project/cells/cvsroot/cells-ode/world.lisp 2008/06/01 20:26:49 1.5
@@ -1,3 +1,20 @@
+#|
+
+ Cells-ODE -- A cells driven interface to cl-ode
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html) known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
(in-package :cells-ode)
@@ -23,7 +40,7 @@
(defvar *world* nil "ODE world")
-
+(export! *world*)
(def-ode-model world ()
((gravity :type vector :initform (c-in #(0 0 -9.81)) :auto-update nil)
1
0