[graphic-forms-cvs] r215 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/graphics/plugins/imagemagick src/uitoolkit/system src/uitoolkit/widgets

junrue at common-lisp.net junrue at common-lisp.net
Mon Aug 14 02:04:19 UTC 2006


Author: junrue
Date: Sun Aug 13 22:04:18 2006
New Revision: 215

Modified:
   trunk/README.txt
   trunk/docs/manual/widgets-api.texinfo
   trunk/graphic-forms-tests.asd
   trunk/src/tests/uitoolkit/default.ico
   trunk/src/tests/uitoolkit/drawing-tester.lisp
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/tests/uitoolkit/hello-world.lisp
   trunk/src/tests/uitoolkit/image-tester.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/tests/uitoolkit/windlg.lisp
   trunk/src/uitoolkit/graphics/icon-bundle.lisp
   trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp
   trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
fixed problems in multiple-image icon bundles and in the ImageMagick plugin

Modified: trunk/README.txt
==============================================================================
--- trunk/README.txt	(original)
+++ trunk/README.txt	Sun Aug 13 22:04:18 2006
@@ -157,21 +157,26 @@
 
   (asdf:operate 'asdf:load-op :graphic-forms-tests)
 
-  ;; execute one or more of the following:
+  ;; execute demos and test programs
   ;;
+  (gft:unblocked)
 
-  (in-package :gft)
-  (run-tests)  ;; runs the unit tests (many more to be added)
+  (gft:textedit)
+
+  (gft:drawing-tester)
 
-  (gft::run-drawing-tester)
+  (gft:event-tester)
 
-  (gft::run-event-tester)
+  (gft:image-tester)
 
-  (gft::run-image-tester)
+  (gft:layout-tester)
 
-  (gft::run-windlg)
+  (gft:windlg)
 
-  (gft::run-layout-tester)
+  ;; execute the unit-tests
+  ;;
+  (in-package :gft)
+  (run-tests)
 
 
 Support and Feedback

Modified: trunk/docs/manual/widgets-api.texinfo
==============================================================================
--- trunk/docs/manual/widgets-api.texinfo	(original)
+++ trunk/docs/manual/widgets-api.texinfo	Sun Aug 13 22:04:18 2006
@@ -1333,6 +1333,16 @@
 scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}.
 @end deffn
 
+ at deffn GenericFunction image self => @ref{image}
+
+(setf (@strong{image} @var{self}) @var{image})@*
+
+Returns the image currently associated with @var{self}. The @sc{setf} function
+changes the image. If @var{self} is a @ref{window}, then this function returns
+an @ref{icon-bundle}. And in that case, the @sc{setf} function accepts either
+an image or an icon-bundle.
+ at end deffn
+
 @deffn GenericFunction item-index self item
 Return the zero-based index of the location of the other object in this object.
 @end deffn

Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd	(original)
+++ trunk/graphic-forms-tests.asd	Sun Aug 13 22:04:18 2006
@@ -37,14 +37,14 @@
   (:nicknames #:gft)
   (:use :common-lisp :lisp-unit)
   (:export
-    #:run-drawing-tester
-    #:run-event-tester
-    #:run-hello-world
-    #:run-image-tester
-    #:run-layout-tester
-    #:run-windlg
+    #:drawing-tester
+    #:event-tester
+    #:hello-world
+    #:image-tester
+    #:layout-tester
     #:textedit
-    #:unblocked))
+    #:unblocked
+    #:windlg))
 
 (print "Graphic-Forms UI Toolkit Tests")
 (print "Copyright (c) 2006 by Jack D. Unrue")

Modified: trunk/src/tests/uitoolkit/default.ico
==============================================================================
Binary files. No diff available.

Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp	Sun Aug 13 22:04:18 2006
@@ -342,7 +342,7 @@
   (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges)
   (gfw:redraw *drawing-win*))
 
-(defun run-drawing-tester-internal ()
+(defun drawing-tester-internal ()
   (setf *last-checked-drawing-item* nil)
   (let ((menubar (gfw:defmenu ((:item "&File"
                                 :submenu ((:item "E&xit" :callback #'drawing-exit-fn)))
@@ -362,7 +362,9 @@
     (setf (gfw:menu-bar *drawing-win*) menubar)
     (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310))
     (setf (gfw:text *drawing-win*) "Drawing Tester")
+#+load-imagemagick-plugin
+    (setf (gfw:image *drawing-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico")))
     (gfw:show *drawing-win* t)))
 
-(defun run-drawing-tester ()
-  (gfw:startup "Drawing Tester" #'run-drawing-tester-internal))
+(defun drawing-tester ()
+  (gfw:startup "Drawing Tester" #'drawing-tester-internal))

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Sun Aug 13 22:04:18 2006
@@ -233,7 +233,7 @@
                                         (gfw:delay-of *timer*)))))
   (gfw:redraw *event-tester-window*))
 
-(defun run-event-tester-internal ()
+(defun event-tester-internal ()
   (setf *event-tester-text* "Hello!")
   (setf *event-counter* 0)
   (let ((echo-md (make-instance 'event-tester-echo-dispatcher))
@@ -255,5 +255,5 @@
     (setf (gfw:menu-bar *event-tester-window*) menubar)
     (gfw:show *event-tester-window* t)))
 
-(defun run-event-tester ()
-  (gfw:startup "Event Tester" #'run-event-tester-internal))
+(defun event-tester ()
+  (gfw:startup "Event Tester" #'event-tester-internal))

Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp	(original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp	Sun Aug 13 22:04:18 2006
@@ -56,7 +56,7 @@
   (setf (gfg:foreground-color gc) gfg:*color-green*)
   (gfg:draw-text gc "Hello World!" (gfs:make-point)))
 
-(defun run-hello-world-internal ()
+(defun hello-world-internal ()
   (let ((menubar nil))
     (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events)
                                                     :style '(:frame)))
@@ -65,5 +65,5 @@
     (setf (gfw:menu-bar *hello-win*) menubar)
     (gfw:show *hello-win* t)))
 
-(defun run-hello-world ()
-  (gfw:startup "Hello World" #'run-hello-world-internal))
+(defun hello-world ()
+  (gfw:startup "Hello World" #'hello-world-internal))

Modified: trunk/src/tests/uitoolkit/image-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/image-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/image-tester.lisp	Sun Aug 13 22:04:18 2006
@@ -93,7 +93,7 @@
   (setf *image-win* nil)
   (gfw:shutdown 0))
 
-(defun run-image-tester-internal ()
+(defun image-tester-internal ()
   (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))
   (let ((menubar nil))
     (setf *happy-image* (make-instance 'gfg:image))
@@ -111,5 +111,5 @@
     (setf (gfw:menu-bar *image-win*) menubar)
     (gfw:show *image-win* t)))
 
-(defun run-image-tester ()
-  (gfw:startup "Image Tester" #'run-image-tester-internal))
+(defun image-tester ()
+  (gfw:startup "Image Tester" #'image-tester-internal))

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Aug 13 22:04:18 2006
@@ -387,7 +387,7 @@
   (declare (ignorable disp item))
   (exit-layout-tester))
 
-(defun run-layout-tester-internal ()
+(defun layout-tester-internal ()
   (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))
   (setf *widget-counter* 0)
   (let ((menubar nil)
@@ -444,5 +444,5 @@
     (gfw:pack *layout-tester-win*)
     (gfw:show *layout-tester-win* t)))
 
-(defun run-layout-tester ()
-  (gfw:startup "Layout Tester" #'run-layout-tester-internal))
+(defun layout-tester ()
+  (gfw:startup "Layout Tester" #'layout-tester-internal))

Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp	(original)
+++ trunk/src/tests/uitoolkit/windlg.lisp	Sun Aug 13 22:04:18 2006
@@ -228,7 +228,7 @@
   (declare (ignore disp item))
   (open-dlg "Modeless" '(:modeless)))
 
-(defun run-windlg-internal ()
+(defun windlg-internal ()
   (let ((menubar nil))
     (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events)
                                                    :style '(:workspace)))
@@ -248,5 +248,5 @@
     (setf (gfw:menu-bar *main-win*) menubar)
     (gfw:show *main-win* t)))
 
-(defun run-windlg ()
-  (gfw:startup "Window/Dialog Tester" #'run-windlg-internal))
+(defun windlg ()
+  (gfw:startup "Window/Dialog Tester" #'windlg-internal))

Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/icon-bundle.lisp	(original)
+++ trunk/src/uitoolkit/graphics/icon-bundle.lisp	Sun Aug 13 22:04:18 2006
@@ -164,7 +164,9 @@
       (resource-id
          (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id)))
       ((typep file 'pathname)
-         (setf image-list (list (make-instance 'image :file file))))
+         (let ((data (load-image-data file)))
+           (setf image-list (loop for entry in data
+                                  collect (make-instance 'gfg:image :handle (data->image entry))))))
       ((listp images)
          (setf image-list images)))
     (when image-list

Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp	(original)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp	Sun Aug 13 22:04:18 2006
@@ -149,6 +149,11 @@
   (images     :pointer))      ;; Image*
 
 (defcfun
+  ("GetImageListLength" get-image-list-length)
+  :unsigned-long
+  (images     :pointer))      ;; Image*
+
+(defcfun
   ("GetNextImageInList" get-next-image-in-list)
   :pointer                    ;; Image*
   (images     :pointer))      ;; Image*

Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp	(original)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp	Sun Aug 13 22:04:18 2006
@@ -41,15 +41,15 @@
     (initialize-magick (cffi:null-pointer))
     (setf *magick-initialized* t))
   (if (gethash (pathname-type path) gfg:*image-file-types*)
-    (with-image-path (path info ex)
+    (with-image-path ((if (typep path 'pathname) (namestring path) path) info ex)
       (let ((images-ptr (read-image info ex)))
         (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))
           (error 'gfs:toolkit-error :detail (format nil
                                                     "exception reason: ~s"
                                                     (cffi:foreign-slot-value ex 'exception-info 'reason))))
-        (loop for ptr = (get-next-image-in-list images-ptr)
-              until (cffi:null-pointer-p ptr)
-              collect (make-instance 'magic-data-plugin :handle ptr))))
+        (loop for ptr = images-ptr then (get-next-image-in-list ptr)
+              while (and ptr (not (gfs:null-handle-p ptr)))
+              collect (make-instance 'magick-data-plugin :handle ptr))))
     nil))
 
 (push #'loader gfg::*image-plugins*)

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Sun Aug 13 22:04:18 2006
@@ -480,6 +480,10 @@
 (defconstant +icc-standard-classes+    #x00004000)
 (defconstant +icc-link-class+          #x00008000)
 
+(defconstant +icon-small+                       0)
+(defconstant +icon-big+                         1)
+(defconstant +icon-small2+                      2)
+
 (defconstant +idok+                             1)
 (defconstant +idcancel+                         2)
 (defconstant +idabort+                          3)
@@ -1004,6 +1008,12 @@
 (defconstant +wm-chartoitem+               #x002F)
 (defconstant +wm-setfont+                  #x0030)
 (defconstant +wm-getfont+                  #x0031)
+(defconstant +wm-contextmenu+              #x007B)
+(defconstant +wm-stylechanging+            #x007C)
+(defconstant +wm-stylechanged+             #x007D)
+(defconstant +wm-displaychange+            #x007E)
+(defconstant +wm-geticon+                  #x007F)
+(defconstant +wm-seticon+                  #x0080)
 (defconstant +wm-ncmousemove+              #x00A0)
 (defconstant +wm-nclbuttondown+            #x00A1)
 (defconstant +wm-nclbuttonup+              #x00A2)

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Sun Aug 13 22:04:18 2006
@@ -210,6 +210,15 @@
 (defmethod enabled-p ((w widget))
   (not (zerop (gfs::is-window-enabled (gfs:handle w)))))
 
+(defmethod image :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod (setf image) :before (image (self widget))
+  (declare (ignore image))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
 (defmethod initialize-instance :after ((w widget) &key style &allow-other-keys)
   (setf (slot-value w 'style) (if (listp style) style (list style))))
 

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Aug 13 22:04:18 2006
@@ -165,43 +165,65 @@
   (delete-kbdnav-widget (thread-context) self)
   (call-next-method))
 
-(defmethod enable-layout :before ((win window) flag)
+(defmethod enable-layout :before ((self window) flag)
   (declare (ignore flag))
-  (if (gfs:disposed-p win)
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod enable-layout ((win window) flag)
-  (setf (slot-value win 'layout-p) flag)
-  (if (and flag (layout-of win))
-    (let ((sz (client-size win)))
-      (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz)))))
+(defmethod enable-layout ((self window) flag)
+  (setf (slot-value self 'layout-p) flag)
+  (if (and flag (layout-of self))
+    (let ((sz (client-size self)))
+      (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))
 
-(defmethod event-resize ((d event-dispatcher) (win window) size type)
+(defmethod event-resize ((d event-dispatcher) (self window) size type)
   (declare (ignore size type))
-  (unless (null (layout-of win))
-    (let ((sz (client-size win)))
-      (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz)))))
+  (unless (null (layout-of self))
+    (let ((sz (client-size self)))
+      (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))
 
-(defmethod focus-p :before ((win window))
-  (if (gfs:disposed-p win)
+(defmethod focus-p :before ((self window))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod focus-p ((win window))
+(defmethod focus-p ((self window))
   (let ((focus-hwnd (gfs::get-focus)))
-    (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle win)))))
+    (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle self)))))
 
-(defmethod give-focus :before ((win window))
-  (if (gfs:disposed-p win)
+(defmethod give-focus :before ((self window))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod give-focus ((win window))
-  (gfs::set-focus (gfs:handle win)))
+(defmethod give-focus ((self window))
+  (gfs::set-focus (gfs:handle self)))
 
-(defmethod location ((win window))
-  (if (gfs:disposed-p win)
+(defmethod image ((self window))
+  (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0))
+        (large (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-big+ 0))
+        (handles nil))
+    (unless (zerop small)
+      (push (cffi:make-pointer small) handles))
+    (unless (zerop large)
+      (push (cffi:make-pointer large) handles))
+    (make-instance 'gfg:icon-bundle :handle handles)))
+
+(defmethod (setf image) ((image gfg:image) (self window))
+  (setf (image self) (make-instance 'gfg:icon-bundle :images (list image))))
+
+(defmethod (setf image) ((bundle gfg:icon-bundle) (self window))
+  (let ((hwnd (gfs:handle self))
+        (small (gfg::icon-handle-ref bundle :small))
+        (large (gfg::icon-handle-ref bundle :large)))
+    (unless (gfs:null-handle-p small)
+      (gfs::send-message hwnd gfs::+wm-seticon+ gfs::+icon-small+ (cffi:pointer-address small)))
+    (unless (gfs:null-handle-p large)
+      (gfs::send-message hwnd gfs::+wm-seticon+ gfs::+icon-big+ (cffi:pointer-address large)))))
+
+(defmethod location ((self window))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error))
   (let ((pnt (gfs:make-point)))
-    (outer-location win pnt)
+    (outer-location self pnt)
     pnt))
 
 (defmethod layout ((self window))



More information about the Graphic-forms-cvs mailing list