Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv29136/cells-gtk

Modified Files: buttons.lisp cairo-drawing-area.lisp dialogs.lisp drawing-area.lisp gtk-app.lisp tree-view.lisp widgets.lisp Log Message: now runs with the cells-store inside

--- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/16 14:41:28 1.3 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/20 13:05:02 1.4 @@ -59,11 +59,6 @@ (let ((state (gtk-toggle-button-get-active widget))) (setf (value self) state)))))

-(defobserver .value ((self toggle-button)) - (trc "observing toggle-button .value" self (value self)) - (with-integrity (:change 'toggle-button-value) - (trc "with integrity"))) - #+test (DEF-GTK WIDGET TOGGLE-BUTTON (BUTTON) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL)) (MODE ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/14 16:43:41 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/20 13:05:02 1.3 @@ -110,10 +110,10 @@

(defmodel cairo-drawing-area (drawing-area) ((cairo-context :accessor cairo-context :cell nil :initform nil) - (canvas :accessor canvas :cell t :initform (c-in nil) :initarg :canvas) - (.canvas :accessor .canvas :initform (c-in nil)) + (canvas :accessor canvas :initform (c-in nil) :initarg :canvas :owning t) + (.canvas :accessor .canvas :initform (c-in nil) :owning t) (prims :reader prims :initform (c? (append (canvas self) (.canvas self)))) - (widget :reader widget :cell t :initform (c? self)) + (widget :reader widget :initform (c? self)) ;; the primitive the mouse is currently hovering over (hover :accessor hover :cell nil :initform nil) (hover-history :accessor hover-history :cell nil :initform nil) @@ -122,7 +122,7 @@ ;; callback (on-dragged [widget] [button] [primtitive] [start] [end]) (on-dragged :accessor on-dragged :cell nil :initform nil :initarg :on-dragged)

- (dragging :accessor dragging :cell t :initform (c-in nil)) + (dragging :accessor dragging :initform (c-in nil))

(drag-start :accessor drag-start :cell nil :initform nil) (drag-offset :accessor drag-offset :cell nil :initform nil) @@ -131,7 +131,7 @@

(selection-color :accessor selection-color :cell nil :initform '(1 1 .27)) (drag-threshold :accessor drag-threshold :cell nil :initform 3 :initarg :drag-threshold) - (selection :accessor selection :cell t :initform (c-in nil))) + (selection :accessor selection :initform (c-in nil))) (:default-initargs :on-pressed #'cairo-drawing-area-button-press :on-released #'cairo-drawing-area-button-release @@ -312,6 +312,11 @@

;;;; ------ destroy methods ----------------------------------------------

+(defmethod not-to-be :before ((self cairo-drawing-area)) + (trc "not-to-be cairo-drawing area erasing everything" self) + (setf (canvas self) nil + (.canvas self) nil)) + (defgeneric remove-primitive (primitive) (:documentation "Removes primitive"))

@@ -479,8 +484,12 @@ ((polar (2d:polar-coords (^delta))) (mouse-over-p (when (^widget) (with-accessors ((mouse mouse-pos)) (widget self) - (and (2d:point-in-box-p mouse (^p1) (^p2) :tol (line-width self)) - (< (2d:distance-point-line mouse (^p1) (^p2)) (* (^line-width) 2))))))) + (when-bind* ((p1 (^p1)) + (p2 (^p2)) + (line-width (^line-width))) + (and mouse + (2d:point-in-box-p mouse p1 p2 :tol line-width) + (< (2d:distance-point-line mouse p1 p2) (* line-width 2)))))))) :no-redraw (polar mouse-over-p)))

--- /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/20 13:05:02 1.2 @@ -60,18 +60,23 @@ (defun show-dialog (dlg-class &rest inits) (let ((self (apply #'make-instance dlg-class :awaken-on-init-p t inits))) (wtrc (0 100 "processing dlg") - (let* ((response (gtk-dialog-run (id self))) - (result (funcall (fn-response self) self response))) + (let* ((response (wtrc (0 100 "running dialog") + (gtk-dialog-run (id self)))) + (result (funcall (fn-response self) self response))) + (trc "showed dialog" response result) (with-slots (content-area) self (when content-area (trc "reading content area" (value content-area)) (setf result (value content-area)) (trc "forgetting content-area") - (gtk-object-forget (id content-area) content-area))) - (trc "destroying self") - (gtk-widget-destroy (id self)) - (trc "forgetting self") - (gtk-object-forget (id self) self) + (not-to-be content-area) + #+not-necessary (gtk-object-forget (id content-area) content-area))) + (trc "destroying self (not-to-be)") + (not-to-be self) + #+not-necessary (progn + (gtk-widget-destroy (id self)) + (trc "forgetting self") + (gtk-object-forget (id self) self)) result))))

(defun show-message (text &rest inits) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/14 16:43:42 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/20 13:05:02 1.3 @@ -27,7 +27,7 @@

(def-widget drawing-area () ((mouse-pos :accessor mouse-pos :cell t :initform (c-in (2d:v 0 0))) - (canvas :accessor canvas :cell t :initform (c-in nil) :initarg :canvas) + (canvas :accessor canvas :cell t :initform (c-in nil) :initarg :canvas :owning t) ; (on-draw self) (on-draw :accessor on-draw :cell nil :initarg :on-draw :initform nil) ;n/a @@ -142,7 +142,8 @@ (defmethod redraw ((self drawing-area)) "Queues a redraw with GTK." (trc nil "queue redraw" self) - (gtk-widget-queue-draw (id self))) + (unless (mdead self) + (gtk-widget-queue-draw (id self))))

--- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/16 14:41:28 1.4 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/20 13:05:02 1.5 @@ -187,7 +187,8 @@ :visible (c-in nil))) (gtk-window-set-auto-startup-notification nil) (to-be splash) - (setf (visible splash) t) + (with-integrity (:change :make-splash-visible) + (setf (visible splash) t)) (not-to-be (make-instance 'window)) ; kick gtk ... ugly (loop while (gtk-events-pending) do (gtk-main-iteration))))) @@ -205,8 +206,9 @@ (when splash (not-to-be splash) (gtk-window-set-auto-startup-notification t)) - - (setf (visible app) t) + + (with-integrity (:change :make-app-visible) + (setf (visible app) t))

(not-to-be (make-instance 'window :visible nil)) ; ph: kick gtk ... ugly app)) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/16 14:41:28 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/20 13:05:02 1.3 @@ -363,7 +363,7 @@ (when old-value (loop for col in old-value do (gtk-tree-view-remove-column (id self) (id col)) - (gtk-object-forget (id col) col))) + #+not-necessary (gtk-object-forget (id col) col))) ; ph 042008 (when new-value (loop for col in new-value for pos from 0 --- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/16 14:41:28 1.3 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/20 13:05:02 1.4 @@ -57,34 +57,33 @@

(defun gtk-objects-init () (setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100) - *widgets* (make-hash-table :test #'equal))) + *widgets* (make-instance 'cells-store)))

;;; id lookup

(defun gtk-object-store (gtk-id gtk-object &aux (hash-id (cffi:pointer-address gtk-id))) (unless *gtk-objects* (gtk-objects-init)) - (setf (gethash (md-name gtk-object) *widgets*) gtk-object) + (bwhen (name (md-name gtk-object)) + (store-add name *widgets* gtk-object)) (let ((known (gethash hash-id *gtk-objects*))) (cond ((eql known gtk-object)) (t - (when known + #+ssh (when known (warn (format nil "Object ~a has been reclaimed by GTK. Cells-gtk might have stale references" known))) (setf (gethash hash-id *gtk-objects*) gtk-object)))))

(defun gtk-object-forget (gtk-id gtk-object) (when (and gtk-id gtk-object) - (trc nil " forgetting id/obj" gtk-id gtk-object) + (trc " forgetting id/obj" gtk-id gtk-object) (let ((ptr (cffi:pointer-address gtk-id))) - (assert *widgets*) - (when (eql (gethash (md-name gtk-object) *widgets*) gtk-object) - (remhash (md-name gtk-object) *widgets*)) (assert *gtk-objects*) (remhash ptr *gtk-objects*) - (mapc (lambda (k) (gtk-object-forget (slot-value k 'id) k)) - (slot-value gtk-object '.kids))))) + #+unnecessary (mapc (lambda (k) (gtk-object-forget (slot-value k 'id) k)) + (slot-value gtk-object '.kids))) ; unnecessary, ph + (trc " done" gtk-id gtk-object)))

(defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (cffi:pointer-address gtk-id))) (when *gtk-objects* @@ -99,15 +98,13 @@

;;; name lookup

-(defun find-widget (name &optional default) - (gethash name *widgets* default)) - (defmacro with-widget ((widget name &optional alternative) &body body) - `(bif (,widget (find-widget ,name)) - (progn - (trc "with widget" ,widget ',body) - ,@body) - ,alternative)) + `(bwhen-c-stored (,widget ,name *widgets* ,alternative) + ,@body)) + +(defun find-widget (name &optional default) + (with-widget (w name default) + w))

(defmacro with-widget-value ((val name &key (accessor '(quote value)) (alternative nil)) &body body) (with-gensyms (widget) @@ -382,14 +379,24 @@ (gtk-widget-show (id self)) (gtk-widget-hide (id self))))

-(defmethod not-to-be :after ((self widget)) +(defmethod not-to-be :around ((self gtk-object)) + (trc "gtk-object not-to-be :around" (md-name self) self) + (trc " store-remove") + (when (eql (store-lookup (md-name self) *widgets*) self) + (store-remove (md-name self) *widgets*)) + (trc " object-forget") + (gtk-object-forget (id self) self) + + (trc " call-next-method") + (call-next-method) + + (trc " widget-destroy") (when *gtk-debug* - (trc "WIDGET DESTROY" (md-name self) (type-of self) self) + (trc "WIDGET DESTROY" (slot-value self '.md-name) (type-of self) self) (force-output)) - (gtk-object-forget (slot-value self 'id) self) - (trc nil "not-to-be destroys" self (slot-value self 'id)) (gtk-widget-destroy (slot-value self 'id)) - (trc nil " done")) + (trc " done")) +

(defun assert-bin (container) (assert (null (rest (kids container)))