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)