anchor.diff:  ;; 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")
  
positive.code: ;; 	    ("saved position")
   	    ("scrolled windows" create-scrolled-windows)
  	    ("size group" create-size-group)
  ;; 	    ("shapes" create-shapes)
   	    ("spinbutton" create-spins)
   	    ("statusbar" create-statusbar)
   	    ("test idle" create-idle-test)
  
negative.code: 
  ;;; Shapes
  
  (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) (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))
  	
      (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))
  	     (window-move window (- xp x-offset) (- yp y-offset))))))
      
      (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)))))
  
  
  
  