cells-cvs June 2008

cells-cvs@common-lisp.net

2 participants
11 discussions

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

16 Jun '08

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

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

16 Jun '08

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

[cells-cvs] CVS cells/gui-geometry
by ktilton 16 Jun '08

16 Jun '08

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

[cells-cvs] CVS Celtk
by ktilton 16 Jun '08

16 Jun '08

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

[cells-cvs] CVS Celtk/gears
by ktilton 16 Jun '08

16 Jun '08

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

[cells-cvs] CVS cells-ode
by phildebrandt 02 Jun '08

02 Jun '08

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

[cells-cvs] CVS cells-gtk3/cells-gtk
by phildebrandt 02 Jun '08

02 Jun '08

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

[cells-cvs] CVS cells-gtk3/cells-gtk
by phildebrandt 02 Jun '08

02 Jun '08

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

[cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk
by phildebrandt 02 Jun '08

02 Jun '08

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

[cells-cvs] CVS cells-gtk3/gtk-ffi
by phildebrandt 02 Jun '08

02 Jun '08

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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs June 2008