[cells-cvs] CVS cells-gtk3/cells-gtk
phildebrandt
phildebrandt at common-lisp.net
Sun Apr 20 13:05:02 UTC 2008
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)
- , at body)
- ,alternative))
+ `(bwhen-c-stored (,widget ,name *widgets* ,alternative)
+ , at 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)))
More information about the Cells-cvs
mailing list