From 9257d518de208bbffd7862481b8f21e32e2e1baf Mon Sep 17 00:00:00 2001 Message-Id: <9257d518de208bbffd7862481b8f21e32e2e1baf.1716683981.git.mdw@distorted.org.uk> From: Mark Wooding Date: Sun, 27 Feb 2005 12:44:07 +0000 Subject: [PATCH] Reintroduced shape test Organization: Straylight/Edgeware From: espen --- examples/testgtk.lisp | 148 ++++++++++++++++++++---------------------- 1 file changed, 70 insertions(+), 78 deletions(-) diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index 82ee939..c587b26 100644 --- a/examples/testgtk.lisp +++ b/examples/testgtk.lisp @@ -15,7 +15,7 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: testgtk.lisp,v 1.19 2005-02-26 10:44:11 espen Exp $ +;; $Id: testgtk.lisp,v 1.20 2005-02-27 12:44:07 espen Exp $ ;(use-package "GTK") @@ -1119,86 +1119,78 @@ (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil) ;;; Shapes -;; (defun shape-create-icon (xpm-file x y px py type root-window destroy) -;; (let* ((window -;; (make-instance 'window -;; :type type :x x :y y -;; :events '(:button-motion :pointer-motion-hint :button-press))) -;; (fixed -;; (make-instance 'fixed -;; :parent window :width 100 :height 100))) +(defun create-shape-icon (xpm-file x y px py type root-window destroy) + (let ((window + (make-instance 'window + :type type :default-width 100 :default-height 100 + :events '(:button-motion :pointer-motion-hint :button-press) + :signal (list 'destroy destroy)))) -;; (widget-realize window) -;; (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file) -;; (let ((pixmap (pixmap-new source mask)) -;; (x-offset 0) -;; (y-offset 0)) -;; (declare (fixnum x-offset y-offset)) -;; (fixed-put fixed pixmap px py) -;; (widget-shape-combine-mask window mask px py) + (widget-realize window) + (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file) + (let ((fixed (make-instance 'fixed :parent window))) + (fixed-put fixed (create-image-widget source mask) px py)) + (widget-shape-combine-mask window mask px py)) -;; (signal-connect window 'button-press-event -;; #'(lambda (event) -;; (when (typep event 'gdk:button-press-event) -;; (setq x-offset (truncate (gdk:event-x event))) -;; (setq y-offset (truncate (gdk:event-y event))) -;; (grab-add window) -;; (gdk:pointer-grab -;; (widget-window window) t -;; '(:button-release :button-motion :pointer-motion-hint) -;; nil nil 0)) -;; t)) - -;; (signal-connect window 'button-release-event -;; #'(lambda (event) -;; (declare (ignore event)) -;; (grab-remove window) -;; (gdk:pointer-ungrab 0) -;; t)) + (let ((x-offset 0) + (y-offset 0)) + (declare (fixnum x-offset y-offset)) + (signal-connect window 'button-press-event + #'(lambda (event) + (when (typep event 'gdk:button-press-event) + (setq x-offset (truncate (gdk:event-x event))) + (setq y-offset (truncate (gdk:event-y event))) + (grab-add window) + (gdk:pointer-grab (widget-window window) + :events '(:button-release :button-motion :pointer-motion-hint) + :owner-events t :time event)))) + + (signal-connect window 'button-release-event + #'(lambda (event) + (grab-remove window) + (gdk:pointer-ungrab event))) -;; (signal-connect window 'motion-notify-event -;; #'(lambda (event) -;; (declare (ignore event)) -;; (multiple-value-bind (win xp yp mask) -;; (gdk:window-get-pointer root-window) -;; (declare (ignore mask win) (fixnum xp yp)) -;; (widget-set-uposition -;; window :x (- xp x-offset) :y (- yp y-offset))) -;; t)) -;; (signal-connect window 'destroy destroy))) + (signal-connect window 'motion-notify-event + #'(lambda (event) + (declare (ignore event)) + (multiple-value-bind (win xp yp mask) + (gdk:window-get-pointer root-window) + (declare (ignore mask win) (fixnum xp yp)) + (window-move window (- xp x-offset) (- yp y-offset)))))) -;; (widget-show-all window) -;; window)) - - -;; (let ((modeller nil) -;; (sheets nil) -;; (rings nil)) -;; (defun create-shapes () -;; (let ((root-window (gdk:get-root-window))) -;; (if (not modeller) -;; (setq -;; modeller -;; (shape-create-icon -;; "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window -;; #'(lambda () (widget-destroyed modeller)))) -;; (widget-destroy modeller)) - -;; (if (not sheets) -;; (setq -;; sheets -;; (shape-create-icon -;; "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window -;; #'(lambda () (widget-destroyed sheets)))) -;; (widget-destroy sheets)) - -;; (if (not rings) -;; (setq -;; rings -;; (shape-create-icon -;; "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window -;; #'(lambda () (widget-destroyed rings)))) -;; (widget-destroy rings))))) + (window-move window x y) + (widget-show-all window) + window)) + + +(let ((modeller nil) + (sheets nil) + (rings nil)) + (defun create-shapes () + (let ((root-window (gdk:get-root-window))) + (if (not modeller) + (setq + modeller + (create-shape-icon + "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window + #'(lambda () (setq modeller nil)))) + (widget-destroy modeller)) + + (if (not sheets) + (setq + sheets + (create-shape-icon + "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window + #'(lambda () (setq sheets nil)))) + (widget-destroy sheets)) + + (if (not rings) + (setq + rings + (create-shape-icon + "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window + #'(lambda () (setq rings nil)))) + (widget-destroy rings))))) @@ -1729,7 +1721,7 @@ (defun create-main-window () ;; ("saved position") ("scrolled windows" create-scrolled-windows) ("size group" create-size-group) -;; ("shapes" create-shapes) + ("shapes" create-shapes) ("spinbutton" create-spins) ("statusbar" create-statusbar) ("test idle" create-idle-test) -- [mdw]