[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