[cells-cvs] CVS cells-gtk3/cells-gtk
phildebrandt
phildebrandt at common-lisp.net
Mon May 19 10:18:35 UTC 2008
Update of /project/cells/cvsroot/cells-gtk3/cells-gtk
In directory clnet:/tmp/cvs-serv27464/cells-gtk
Modified Files:
cairo-drawing-area.lisp gtk-app.lisp widgets.lisp
Log Message:
With Ingo's utf-8 patch for clisp and cells-store support
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/20 13:05:02 1.3
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/05/19 10:18:32 1.4
@@ -509,7 +509,7 @@
(with-accessors ((mouse mouse-pos)) (widget self)
(and (2d:point-in-box-p mouse (^p1) (^p2) :tol (^line-width))
(if (not (^filled))
- (not (2d:point-in-box-p mouse (^p1) (^p2) :tol (^line-width)))
+ (2d:point-in-box-p mouse (^p1) (^p2) :tol (^line-width))
t))))))
:no-redraw (mouse-over-p)))
@@ -646,6 +646,8 @@
(^arrow-length))))))))
(defmodify arrow-line (arrow-angle arrow-length))
+(def-mk-primitive arrow-line (self initargs))
+
;;;; -----------------------------------------------------------
;;;; event handlers
;;;; -----------------------------------------------------------
@@ -666,7 +668,7 @@
(setf (button-down-position self) pos)
(case button
(1
- (trc "button down on" (hover self))
+ (trc nil "button down on" (hover self))
(bif (prim (hover self))
;; prim --> select/toggle
(with-slot-accessors (selection) self
@@ -674,7 +676,7 @@
(if (contains-any '(:shift :control) state)
;; toggle if ctrl/shift
(progn
- (trc "CTRL/SHIFT -- toggeling" prim)
+ (trc nil "CTRL/SHIFT -- toggeling" prim)
(if (selected-p prim)
(setf selection (delete prim selection))
(push prim selection)))
@@ -684,7 +686,7 @@
;(deb "selection: ~a" selection)))
;; no prim --> draw a select box
(progn
- (trc "START SELECT-BOX")
+ (trc nil "START SELECT-BOX")
(unless (contains-any '(:shift :control) state)
(setf (selection self) nil))
(setf (select-box self) (mk-primitive self
@@ -698,10 +700,10 @@
:fill-alpha .1))
(trc nil "select box is" (select-box self)))))
(t (bwhen (box (select-box self))
- (trc "CANCEL SELECT-BOX")
+ (trc nil "CANCEL SELECT-BOX")
(setf box (remove-primitive box)))
(when (dragging self)
- (trc "CANCEL DRAG")
+ (trc nil "CANCEL DRAG")
(dolist (prim (selection self))
(setf (dragged-p prim) nil))
(setf (dragging self) nil
@@ -714,7 +716,7 @@
(cond
((dragging self)
;; this is the button release after a dragging event
- (trc "FINISH DRAGGING")
+ (trc nil "FINISH DRAGGING")
(with-slot-accessors (dragging on-dragged drag-offset drag-start selection) self
(dolist (prim selection)
;; call on-dragged [widget] [button] [primitive] [start-pos] [end-pos]
@@ -730,15 +732,15 @@
drag-start nil
drag-offset nil)))
((select-box self)
- (trc "FINISH SELECT-BOX")
+ (trc nil "FINISH SELECT-BOX")
(with-slot-accessors (selection prims button-down-position select-box) self
(dolist (prim prims)
- (trc "checking" prim)
+ (trc nil "checking" prim)
(and (selectable prim)
(2d:point-in-box-p (c-o-g prim) button-down-position pos)
(push prim selection)
- (trc "--> selected " prim)))
- (trc "selection is now" selection)
+ (trc nil "--> selected " prim)))
+ (trc nil "selection is now" selection)
(setf select-box (remove-primitive select-box))))
(t (with-slot-accessors (selection hover) self
(unless (contains-any '(:shift :control) state)
@@ -760,7 +762,7 @@
((bwhen (start-pos (button-down-position self))
(and (not (select-box self))
(> (2d:polar-radius (2d:v- start-pos pos)) (drag-threshold self))))
- (trc "START DRAGGING")
+ (trc nil "START DRAGGING")
;; initiate dragging
(with-slot-accessors (drag-offset drag-start selection dragging) self
(setf drag-offset (make-hash-table)
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/20 13:05:02 1.5
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/05/19 10:18:32 1.6
@@ -253,11 +253,14 @@
(gtk-main))
;; clean-up forms -- application windows are taken down by gtk-quit-add callbacks
+ (trc "cells-gtk clean-up code")
(loop for i below (gtk-main-level)
+ do (trc " gtk-main-quit")
do (gtk-main-quit))
;; Next is a work-around for a problem with gtk and lispwork-created .exe files
#+(and Lispworks win32)(loop for i from 1 to 30 do (gtk-main-quit))
(loop while (gtk-events-pending)
+ do (trc " gtk-main-iteration-do")
do (gtk-main-iteration-do nil))))
;;;
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/20 13:05:02 1.4
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/05/19 10:18:34 1.5
@@ -77,13 +77,13 @@
(defun gtk-object-forget (gtk-id gtk-object)
(when (and gtk-id gtk-object)
- (trc " forgetting id/obj" gtk-id gtk-object)
+ (trc nil " forgetting id/obj" gtk-id gtk-object)
(let ((ptr (cffi:pointer-address gtk-id)))
(assert *gtk-objects*)
(remhash ptr *gtk-objects*)
#+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)))
+ (trc nil " 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*
@@ -340,11 +340,11 @@
#+libcellsgtk
(cffi:defcallback reshape-widget-handler :int ((widget :pointer) (event :pointer) (data :pointer))
(declare (ignore data event))
- (trc "reshape" widget)
+ (trc nil "reshape" widget)
(bwhen (self (gtk-object-find widget))
(let ((new-width (gtk-adds-widget-width widget))
(new-height (gtk-adds-widget-height widget)))
- (trc "reshape widget to new size" self widget new-width new-height)
+ (trc nil "reshape widget to new size" self widget new-width new-height)
(with-integrity (:change :adjust-widget-size)
(setf (allocated-width self) new-width
(allocated-height self) new-height))))
@@ -380,22 +380,22 @@
(gtk-widget-hide (id self))))
(defmethod not-to-be :around ((self gtk-object))
- (trc "gtk-object not-to-be :around" (md-name self) self)
- (trc " store-remove")
+ (trc nil "gtk-object not-to-be :around" (md-name self) self)
+ (trc nil " store-remove")
(when (eql (store-lookup (md-name self) *widgets*) self)
(store-remove (md-name self) *widgets*))
- (trc " object-forget")
+ (trc nil " object-forget")
(gtk-object-forget (id self) self)
- (trc " call-next-method")
+ (trc nil " call-next-method")
(call-next-method)
- (trc " widget-destroy")
+ (trc nil " widget-destroy")
(when *gtk-debug*
- (trc "WIDGET DESTROY" (slot-value self '.md-name) (type-of self) self)
+ (trc nil "WIDGET DESTROY" (slot-value self '.md-name) (type-of self) self)
(force-output))
(gtk-widget-destroy (slot-value self 'id))
- (trc " done"))
+ (trc nil " done"))
(defun assert-bin (container)
More information about the Cells-cvs
mailing list