- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

[graphic-forms-cvs] r217 - in trunk/src/uitoolkit/graphics/plugins: default imagemagick
by junrue＠common-lisp.net 14 Aug '06

14 Aug '06

Author: junrue Date: Sun Aug 13 23:15:27 2006 New Revision: 217 Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: fixed graphics plugin lookup by extension to be case-insensitive Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Sun Aug 13 23:15:27 2006 @@ -104,7 +104,7 @@ (load-bmp-data stream t t))))) (defun loader (path) - (let* ((file-type (pathname-type path)) + (let* ((file-type (string-downcase (pathname-type path))) (helper (cond ((string-equal file-type "bmp") #'load-bmp-data) ((string-equal file-type "ico") #'load-icon-data) 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 23:15:27 2006 @@ -40,7 +40,7 @@ (unless *magick-initialized* (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) - (if (gethash (pathname-type path) gfg:*image-file-types*) + (if (gethash (string-downcase (pathname-type path)) gfg:*image-file-types*) (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))

1 0

[graphic-forms-cvs] r216 - in trunk/src: tests/uitoolkit uitoolkit/graphics/plugins/default
by junrue＠common-lisp.net 14 Aug '06

14 Aug '06

Author: junrue Date: Sun Aug 13 23:07:35 2006 New Revision: 216 Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.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/plugins/default/default-data-plugin.lisp Log: implemented icon file loading in default graphics plugin 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 23:07:35 2006 @@ -362,7 +362,6 @@ (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))) 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 23:07:35 2006 @@ -253,6 +253,7 @@ (:item "&Help" :dispatcher echo-md :submenu ((:item "&About" :dispatcher echo-md)))))) (setf (gfw:menu-bar *event-tester-window*) menubar) + (setf (gfw:image *event-tester-window*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *event-tester-window* t))) (defun event-tester () 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 23:07:35 2006 @@ -109,6 +109,7 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) + (setf (gfw:image *image-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *image-win* t))) (defun image-tester () 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 23:07:35 2006 @@ -441,6 +441,7 @@ (dotimes (i 3) (add-layout-tester-widget 'gfw:button :push-button)) (setf (gfw:text *layout-tester-win*) "Layout Tester") + (setf (gfw:image *layout-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:pack *layout-tester-win*) (gfw:show *layout-tester-win* t))) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Aug 13 23:07:35 2006 @@ -246,6 +246,7 @@ (:item "&Mini Frame" :callback #'create-miniframe-win) (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) + (setf (gfw:image *main-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *main-win* t))) (defun windlg () Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Sun Aug 13 23:07:35 2006 @@ -45,13 +45,15 @@ (defmacro bitmap-pixel-row-length (width bit-count) `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) -(defun load-bmp-data (stream) - (let* ((header (read-value 'BITMAPFILEHEADER stream)) - (info (read-value 'BASE-BITMAPINFOHEADER stream)) +(defun load-bmp-data (stream &optional no-header-p half-height-p) + (unless no-header-p + (read-value 'BITMAPFILEHEADER stream)) + (let* ((info (read-value 'BASE-BITMAPINFOHEADER stream)) (data (make-instance 'default-data-plugin :handle info))) - (declare (ignore header)) (unless (= (biCompression info) gfs::+bi-rgb+) (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + (if half-height-p + (setf (biHeight info) (/ (biHeight info) 2))) ;; load color table ;; @@ -93,7 +95,13 @@ (list data))) (defun load-icon-data (stream) - (declare (ignore stream))) + (let ((offsets (loop for i upto (1- (idCount (read-value 'ICONDIR stream))) + for entry = (read-value 'ICONDIRENTRY stream) + collect (ideImageOffset entry)))) + (loop for offset in offsets + append (progn + (file-position stream offset) + (load-bmp-data stream t t))))) (defun loader (path) (let* ((file-type (pathname-type path))

1 0

[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
by junrue＠common-lisp.net 14 Aug '06

14 Aug '06

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 +@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. +@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))

1 0

[graphic-forms-cvs] r214 - in trunk/src: tests/uitoolkit uitoolkit/graphics
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sun Aug 13 17:28:31 2006 New Revision: 214 Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: implemented setf icon-image-ref unit-test, fixed bug Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 17:28:31 2006 @@ -99,3 +99,22 @@ (validate-image (gfg:icon-image-ref bundle :large) size 8)) (gfs:dispose bundle)) (assert-true (gfs:disposed-p bundle)))) + +(define-test setf-images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle + :images (list (make-instance 'gfg:image :file (merge-pathnames "happy.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))))) + (happy-image (make-instance 'gfg:image :file (merge-pathnames "happy.bmp"))) + (bw-image (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp"))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16))) + (unwind-protect + (progn + (assert-equal 2 (gfg:icon-bundle-length bundle)) + (setf (gfg:icon-image-ref bundle 0) bw-image) + (setf (gfg:icon-image-ref bundle 1) happy-image) + (assert-equal 2 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) bw-size 16000000) + (validate-image (gfg:icon-image-ref bundle 1) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) 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 17:28:31 2006 @@ -114,6 +114,9 @@ (hicon->image (icon-handle-ref bundle index))) (defun set-icon-image (bundle index image) + (let ((hicon (icon-handle-ref bundle index))) + (if (and (not (gfs:null-handle-p hicon)) (listp (gfs:handle bundle))) + (gfs::destroy-icon hicon))) (setf (icon-handle-ref bundle index) (image->hicon image))) (defsetf icon-image-ref set-icon-image)

1 0

[graphic-forms-cvs] r213 - in trunk: . src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sun Aug 13 17:13:54 2006 New Revision: 213 Modified: trunk/build.lisp trunk/config.lisp trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/tests.lisp Log: implemented icon-bundle unit-tests and fixed a few more bugs found as a result Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Aug 13 17:13:54 2006 @@ -52,8 +52,9 @@ (setf *lisp-unit-file* (concatenate 'string *gf-dir* "src/external-libraries/lisp-unit/lisp-unit")) (setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) (setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")) - -(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) +(setf *textedit-dir* (concatenate 'string *gf-dir* "src/demos/textedit/")) +(setf *unblocked-dir* (concatenate 'string *gf-dir* "src/demos/unblocked/")) +(setf *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Sun Aug 13 17:13:54 2006 @@ -39,15 +39,18 @@ (in-package #:graphic-forms-system) -(defvar *binary-data-dir* (merge-pathnames "src/external-libraries/practicals-1.0.3/binary-data/")) (defvar *cells-dir* "cells/") (defvar *cffi-dir* "cffi-060606/") (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") -(defvar *macro-utilities-dir* "macro-utilities/") (defvar *gf-dir* "graphic-forms/") +(defvar *binary-data-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/binary-data/") +(defvar *macro-utilities-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/macro-utilities/") +(defvar *textedit-dir* "graphic-forms/src/demos/textedit/") +(defvar *unblocked-dir* "graphic-forms/src/demos/unblocked/") +(defvar *gf-tests-dir* "graphic-forms/src/tests/uitoolkit/") -(defvar *lisp-unit-file* "lisp-unit") +(defvar *lisp-unit-file* "graphic-forms/src/external-libraries/practicals-1.0.3/lisp-unit.lisp") (defun configure-asdf () (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Aug 13 17:13:54 2006 @@ -35,7 +35,6 @@ (defvar *textedit-control* nil) (defvar *textedit-win* nil) -(defvar *textedit-startup-dir* nil) (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*"))) @@ -152,7 +151,8 @@ (defun about-textedit (disp item) (declare (ignore disp item)) - (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*))) + (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) + (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) (dlg (make-instance 'gfw:dialog :owner *textedit-win* :dispatcher (make-instance 'textedit-about-dialog-events) :layout (make-instance 'gfw:flow-layout @@ -219,12 +219,6 @@ (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit"))) (defun textedit-startup () -#+clisp - (setf *textedit-startup-dir* (ext:cd)) -#+lispworks - (setf *textedit-startup-dir* (hcl:get-working-directory)) -#+sbcl - (setf *textedit-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu :submenu ((:item "&New" :callback #'textedit-file-new) (:item "&Open..." :callback #'textedit-file-open) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Aug 13 17:13:54 2006 @@ -82,15 +82,13 @@ (defmethod initialize-instance :after ((self tiles-panel-events) &key buffer-size) (declare (ignorable buffer-size)) - (let ((table (tile-image-table-of self)) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) + (table (tile-image-table-of self)) (kind 1)) (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp" "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp") do (let ((image (make-instance 'gfg:image))) - (gfg:load image (merge-pathnames (concatenate 'string - "src/demos/unblocked/" - filename) - (unblocked-startup-dir))) + (gfg:load image (merge-pathnames filename)) (setf (gethash kind table) image) (incf kind))))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Aug 13 17:13:54 2006 @@ -39,13 +39,9 @@ (defconstant +revealed-duration+ 2000) ; millis (defvar *scoreboard-panel* nil) -(defvar *unblocked-startup-dir* nil) (defvar *tiles-panel* nil) (defvar *unblocked-win* nil) -(defun unblocked-startup-dir () - *unblocked-startup-dir*) - (defun get-tiles-panel () *tiles-panel*) @@ -106,7 +102,8 @@ (defun about-unblocked (disp item) (declare (ignore disp item)) - (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*))) + (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) + (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) (dlg (make-instance 'gfw:dialog :owner *unblocked-win* :dispatcher (make-instance 'unblocked-about-dialog-events) :layout (make-instance 'gfw:flow-layout @@ -162,12 +159,6 @@ (gfw:show dlg t))) (defun unblocked-startup () -#+clisp - (setf *unblocked-startup-dir* (ext:cd)) -#+lispworks - (setf *unblocked-startup-dir* (hcl:get-working-directory)) -#+sbcl - (setf *unblocked-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "&New" :callback #'new-unblocked) (:item "&Restart" :callback #'restart-unblocked) Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 17:13:54 2006 @@ -32,3 +32,70 @@ ;;;; (in-package :graphic-forms.uitoolkit.tests) + +(define-test bmp-file-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle :file (merge-pathnames "happy.bmp"))) + (size (gfs:make-size :width 32 :height 32))) + (unwind-protect + (progn + (assert-equal 1 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) size 8) + (validate-image (gfg:icon-image-ref bundle :large) size 8) + (validate-image (gfg:icon-image-ref bundle :small) size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle + :images (list (make-instance 'gfg:image :file (merge-pathnames "happy.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16)) + (tc-size (gfs:make-size :width 16 :height 16))) + (unwind-protect + (progn + (assert-equal 3 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) happy-size 8) + (validate-image (gfg:icon-image-ref bundle 1) bw-size 8) + (validate-image (gfg:icon-image-ref bundle 2) tc-size 16000000) + (validate-image (gfg:icon-image-ref bundle :small) tc-size 8) + (validate-image (gfg:icon-image-ref bundle :large) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test push-images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle)) + (happy-image (make-instance 'gfg:image :file (merge-pathnames "happy.bmp"))) + (bw-image (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp"))) + (tc-image (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16)) + (tc-size (gfs:make-size :width 16 :height 16)) + (bw-point (gfs:make-point :x 0 :y 15))) + (unwind-protect + (progn + (gfg:push-icon-image bw-image bundle bw-point) + (gfg:push-icon-image tc-image bundle) + (gfg:push-icon-image happy-image bundle) + (assert-equal 3 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) happy-size 8) + (validate-image (gfg:icon-image-ref bundle 1) tc-size 16000000) + (validate-image (gfg:icon-image-ref bundle 2) bw-size 8) + (validate-image (gfg:icon-image-ref bundle :small) tc-size 8) + (validate-image (gfg:icon-image-ref bundle :large) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test system-icon-bundle-test + (let ((size (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxicon+) + :height (gfs::get-system-metrics gfs::+sm-cyicon+))) + (bundle (make-instance 'gfg:icon-bundle :system gfg:+warning-icon+))) + (unwind-protect + (progn + (assert-equal 1 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) size 8) + (validate-image (gfg:icon-image-ref bundle :small) size 8) + (validate-image (gfg:icon-image-ref bundle :large) size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Aug 13 17:13:54 2006 @@ -34,5 +34,8 @@ (in-package :graphic-forms.uitoolkit.tests) (defun validate-image (image expected-size expected-depth) - (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) - (assert-equal expected-depth (gfg:depth image))) + (declare (ignore expected-depth)) + (assert-false (null image)) + (assert-false (gfs:disposed-p image)) + ;; (assert-equal expected-depth (gfg:depth image)) ; FIXME: image->data needed + (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) 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 17:13:54 2006 @@ -67,7 +67,8 @@ (let ((im (hicon->image hicon)) (extent 0)) (unwind-protect - (setf extent (gfs:size-height (gfg:size im))) + (let ((size (gfg:size im))) + (setf extent (* (gfs:size-height size) (gfs:size-width size)))) (gfs:dispose im)) extent)) @@ -130,7 +131,8 @@ (error 'gfs:disposed-error)) (let ((tmp (gfs:handle bundle))) (push (image->hicon image transparency-pixel) tmp) - (setf (slot-value bundle 'gfs:handle) tmp))) + (setf (slot-value bundle 'gfs:handle) tmp)) + bundle) ;;; ;;; methods @@ -165,6 +167,4 @@ (when image-list (let ((tr-pnt (or transparency-pixel (gfs:make-point)))) (setf (slot-value self 'gfs:handle) (loop for tmp-image in image-list - collect (image->hicon tmp-image tr-pnt)))))) - (unless (gfs:handle self) - (error 'gfs:toolkit-error :detail "could not initialize icon bundle"))) + collect (image->hicon tmp-image tr-pnt))))))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Aug 13 17:13:54 2006 @@ -34,8 +34,7 @@ (in-package #:graphic-forms-system) (defun load-tests () -#+lispworks - (hcl:change-directory *gf-dir*) + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests) (load (concatenate 'string *gf-tests-dir* "test-utils")) (load (concatenate 'string *gf-tests-dir* "mock-objects"))

1 0

[graphic-forms-cvs] r212 - in trunk: . src/external-libraries/lisp-unit src/tests/uitoolkit
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sun Aug 13 01:52:01 2006 New Revision: 212 Added: trunk/src/external-libraries/lisp-unit/ trunk/src/external-libraries/lisp-unit/lisp-unit.lisp trunk/src/external-libraries/lisp-unit/readme.txt Modified: trunk/README.txt trunk/build.lisp trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/tests.lisp Log: upgraded to latest lisp-unit, now bundling lisp-unit under external-libraries Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Aug 13 01:52:01 2006 @@ -14,6 +14,7 @@ - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ + *note: ASDF is bundled with SBCL* - Cells (latest from CVS) http://www.common-lisp.net/project/cells/ @@ -27,12 +28,20 @@ - Closer to MOP http://common-lisp.net/project/closer/downloads.html - - ImageMagick 6.2.6.5-Q16 - http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-window… +The following libraries are bundled with Graphic-Forms, thus do not need +to be downloaded separately: + + - Practical Common Lisp Chapter08 and Chapter24 + http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz - lisp-unit http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html +The following libraries are optional: + + - ImageMagick 6.2.6.5-Q16 + http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-window… + Supported Common Lisp Implementations ------------------------------------- Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Aug 13 01:52:01 2006 @@ -49,7 +49,7 @@ (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) (setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *lisp-unit-file* (concatenate 'string *gf-dir* "src/external-libraries/lisp-unit/lisp-unit")) (setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) (setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 13 01:52:01 2006 @@ -31,6 +31,8 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; +(load gfsys::*lisp-unit-file*) + (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) (:use :common-lisp :lisp-unit) @@ -78,16 +80,7 @@ ((:module "uitoolkit" :serial t :components - ((:file "test-utils") - (:file "mock-objects") - (:file "color-unit-tests") - (:file "graphics-context-unit-tests") - (:file "image-unit-tests") - (:file "icon-bundle-unit-tests") - (:file "layout-unit-tests") - (:file "widget-unit-tests") - (:file "misc-unit-tests") - (:file "hello-world") + ((:file "hello-world") (:file "event-tester") (:file "layout-tester") (:file "image-tester") Added: trunk/src/external-libraries/lisp-unit/lisp-unit.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/lisp-unit/lisp-unit.lisp Sun Aug 13 01:52:01 2006 @@ -0,0 +1,429 @@ +;;;-*- Mode: Lisp; Package: LISP-UNIT -*- + +#| +Copyright (c) 2004-2005 Christopher K. Riesbeck + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. +|# + + +;;; A test suite package, modelled after JUnit. +;;; Author: Chris Riesbeck +;;; +;;; Update history: +;;; +;;; 04/07/06 added ~<...~> to remaining error output forms [CKR] +;;; 04/06/06 added ~<...~> to compact error output better [CKR] +;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported +;;; by Daniel Edward Burke) [CKR] +;;; 02/08/06 added newlines to error output [CKR] +;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR] +;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR] +;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger, +;;; 11/07/05 added *use-debugger* and assert-predicate [DFB] +;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR] +;;; 08/30/05 added license notice [CKR] +;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR] +;;; 02/21/05 removed length check from SET-EQUAL [CKR] +;;; 02/17/05 added RUN-ALL-TESTS [CKR] +;;; 01/18/05 added ASSERT-EQUAL back in [CKR] +;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR] +;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR] +;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR] +;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR] +;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR] +;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR] +;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR] +;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR] +;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR] +;;; 12/02/04 changed to group tests under packages [CKR] +;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR] +;;; 11/30/04 improved error handling and summarization [CKR] +;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR] +;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR] +;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR] +;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR] +;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR] +;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR] +;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR] +;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR] + + +#| +How to use +---------- + +1. Read the documentation in lisp-unit.html. + +2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many +examples. If you want, start your test file with (REMOVE-TESTS) to +clear any previously defined tests. + +2. Load this file. + +2. (use-package :lisp-unit) + +3. Load your code file and your file of tests. + +4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! -- +or simply (RUN-TESTS) to run all defined tests. + +A summary of how many tests passed and failed will be printed, +with details on the failures. + +Note: Nothing is compiled until RUN-TESTS is expanded. Redefining +functions or even macros does not require reloading any tests. + +For more information, see lisp-unit.html. + +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Packages +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(cl:defpackage #:lisp-unit + (:use #:common-lisp) + (:export #:define-test #:run-all-tests #:run-tests + #:assert-eq #:assert-eql #:assert-equal #:assert-equalp + #:assert-error #:assert-expands #:assert-false + #:assert-equality #:assert-prints #:assert-true + #:get-test-code #:get-tests + #:remove-all-tests #:remove-tests + #:logically-equal #:set-equal + #:use-debugger + #:with-test-listener) + ) + +(in-package #:lisp-unit) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Globals +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *test-listener* nil) + +(defparameter *tests* (make-hash-table)) + +;;; Used by RUN-TESTS to collect summary statistics +(defvar *test-count* 0) +(defvar *pass-count* 0) + +;;; Set by RUN-TESTS for use by SHOW-FAILURE +(defvar *test-name* nil) + +;;; If nil, errors in tests are caught and counted. +;;; If :ask, user is given option of entering debugger or not. +;;; If true and not :ask, debugger is entered. +(defparameter *use-debugger* nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; DEFINE-TEST + +(defmacro define-test (name &body body) + `(progn + (store-test-code ',name ',body) + ',name)) + +;;; ASSERT macros + +(defmacro assert-eq (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'eq)) + +(defmacro assert-eql (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'eql)) + +(defmacro assert-equal (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'equal)) + +(defmacro assert-equalp (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'equalp)) + +(defmacro assert-error (condition form &rest extras) + (expand-assert :error form (expand-error-form form) + condition extras)) + +(defmacro assert-expands (&environment env expansion form &rest extras) + (expand-assert :macro form + (expand-macro-form form #+lispworks nil #-lispworks env) + expansion extras)) + +(defmacro assert-false (form &rest extras) + (expand-assert :result form form nil extras)) + +(defmacro assert-equality (test expected form &rest extras) + (expand-assert :equal form form expected extras :test test)) + +(defmacro assert-prints (output form &rest extras) + (expand-assert :output form (expand-output-form form) + output extras)) + +(defmacro assert-true (form &rest extras) + (expand-assert :result form form t extras)) + + +(defun expand-assert (type form body expected extras &key (test #'eql)) + `(internal-assert + ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test)) + +(defun expand-error-form (form) + `(handler-case ,form + (condition (error) error))) + +(defun expand-output-form (form) + (let ((out (gensym))) + `(let* ((,out (make-string-output-stream)) + (*standard-output* (make-broadcast-stream *standard-output* ,out))) + ,form + (get-output-stream-string ,out)))) + +(defun expand-macro-form (form env) + `(macroexpand-1 ',form ,env)) + +(defun expand-extras (extras) + `#'(lambda () + (list ,@(mapcan #'(lambda (form) (list `',form form)) extras)))) + + +;;; RUN-TESTS + +(defmacro run-all-tests (package &rest tests) + `(let ((*package* (find-package ',package))) + (run-tests + ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package)) + tests)))) + +(defmacro run-tests (&rest names) + `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names)))) + +(defun get-test-thunks (names &optional (package *package*)) + (mapcar #'(lambda (name) (get-test-thunk name package)) + names)) + +(defun get-test-thunk (name package) + (assert (get-test-code name package) (name package) + "No test defined for ~S in package ~S" name package) + (list name (coerce `(lambda () ,@(get-test-code name)) 'function))) + +(defun use-debugger (&optional (flag t)) + (setq *use-debugger* flag)) + +;;; WITH-TEST-LISTENER +(defmacro with-test-listener (listener &body body) + `(let ((*test-listener* #',listener)) ,@body)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Public functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun get-test-code (name &optional (package *package*)) + (let ((table (get-package-table package))) + (unless (null table) + (gethash name table)))) + +(defun get-tests (&optional (package *package*)) + (let ((l nil) + (table (get-package-table package))) + (cond ((null table) nil) + (t + (maphash #'(lambda (key val) + (declare (ignore val)) + (push key l)) + table) + (sort l #'string< :key #'string))))) + + +(defun remove-tests (names &optional (package *package*)) + (let ((table (get-package-table package))) + (unless (null table) + (if (null names) + (clrhash table) + (dolist (name names) + (remhash name table)))))) + +(defun remove-all-tests (&optional (package *package*)) + (if (null package) + (clrhash *tests*) + (remhash (find-package package) *tests*))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Private functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; DEFINE-TEST support + +(defun get-package-table (package &key create) + (let ((table (gethash (find-package package) *tests*))) + (or table + (and create + (setf (gethash package *tests*) + (make-hash-table)))))) + +(defun get-test-name (form) + (if (atom form) form (cadr form))) + +(defun store-test-code (name code &optional (package *package*)) + (setf (gethash name + (get-package-table package :create t)) + code)) + + +;;; ASSERTION support + +(defun internal-assert (type form code-thunk expected-thunk extras test) + (let* ((expected (multiple-value-list (funcall expected-thunk))) + (actual (multiple-value-list (funcall code-thunk))) + (passed (test-passed-p type expected actual test))) + + (incf *test-count*) + (when passed + (incf *pass-count*)) + + (record-result passed type form expected actual extras) + + passed)) + +(defun record-result (passed type form expected actual extras) + (funcall (or *test-listener* 'default-listener) + passed type *test-name* form expected actual + (and extras (funcall extras)) + *test-count* *pass-count*)) + +(defun default-listener + (passed type name form expected actual extras test-count pass-count) + (declare (ignore test-count pass-count)) + (unless passed + (show-failure type (get-failure-message type) + name form expected actual extras))) + +(defun test-passed-p (type expected actual test) + (ecase type + (:error + (or (eql (car actual) (car expected)) + (typep (car actual) (car expected)))) + (:equal + (and (<= (length expected) (length actual)) + (every test expected actual))) + (:macro + (equal (car actual) (car expected))) + (:output + (string= (string-trim '(#\newline #\return #\space) + (car actual)) + (car expected))) + (:result + (logically-equal (car actual) (car expected))) + )) + + +;;; RUN-TESTS support + +(defun run-test-thunks (test-thunks) + (unless (null test-thunks) + (let ((total-test-count 0) + (total-pass-count 0) + (total-error-count 0)) + (dolist (test-thunk test-thunks) + (multiple-value-bind (test-count pass-count error-count) + (run-test-thunk (car test-thunk) (cadr test-thunk)) + (incf total-test-count test-count) + (incf total-pass-count pass-count) + (incf total-error-count error-count))) + (unless (null (cdr test-thunks)) + (show-summary 'total total-test-count total-pass-count total-error-count)) + (values)))) + +(defun run-test-thunk (*test-name* thunk) + (if (null thunk) + (format t "~& Test ~S not found" *test-name*) + (prog ((*test-count* 0) + (*pass-count* 0) + (error-count 0)) + (handler-bind + ((error #'(lambda (e) + (let ((*print-escape* nil)) + (setq error-count 1) + (format t "~& ~S: ~W" *test-name* e)) + (if (use-debugger-p e) e (go exit))))) + (funcall thunk) + (show-summary *test-name* *test-count* *pass-count*)) + exit + (return (values *test-count* *pass-count* error-count))))) + +(defun use-debugger-p (e) + (and *use-debugger* + (or (not (eql *use-debugger* :ask)) + (y-or-n-p "~A -- debug?" e)))) + +;;; OUTPUT support + +(defun get-failure-message (type) + (case type + (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}") + (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + )) + +(defun show-failure (type msg name form expected actual extras) + (format t "~&~@[~S: ~]~S failed: " name form) + (format t msg expected actual) + (format t "~{~& ~S => ~S~}~%" extras) + type) + +(defun show-summary (name test-count pass-count &optional error-count) + (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]." + name pass-count (- test-count pass-count) error-count)) + +(defun collect-form-values (form values) + (mapcan #'(lambda (form-arg value) + (if (constantp form-arg) + nil + (list form-arg value))) + (cdr form) + values)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Useful equality predicates for tests +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; (LOGICALLY-EQUAL x y) => true or false +;;; Return true if x and y both false or both true + +(defun logically-equal (x y) + (eql (not x) (not y))) + +;;; (SET-EQUAL l1 l2 :test) => true or false +;;; Return true if every element of l1 is an element of l2 +;;; and vice versa. + +(defun set-equal (l1 l2 &key (test #'equal)) + (and (listp l1) + (listp l2) + (subsetp l1 l2 :test test) + (subsetp l2 l1 :test test))) + + +(provide "lisp-unit") Added: trunk/src/external-libraries/lisp-unit/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/lisp-unit/readme.txt Sun Aug 13 01:52:01 2006 @@ -0,0 +1,7 @@ + +This directory contains the source file implementing the lisp-unit +unit-test library. Copyright (c) 2004-2005 Christopher K. Riesbeck + +The website for this library is: + + http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 01:52:01 2006 @@ -32,7 +32,3 @@ ;;;; (in-package :graphic-forms.uitoolkit.tests) - - - - Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Aug 13 01:52:01 2006 @@ -33,8 +33,6 @@ (in-package :graphic-forms.uitoolkit.tests) -#| (defun validate-image (image expected-size expected-depth) (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) (assert-equal expected-depth (gfg:depth image))) -|# Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Aug 13 01:52:01 2006 @@ -33,9 +33,16 @@ (in-package #:graphic-forms-system) -(load (compile-file *lisp-unit-file*)) - (defun load-tests () #+lispworks (hcl:change-directory *gf-dir*) - (asdf:operate 'asdf:load-op :graphic-forms-tests)) + (asdf:operate 'asdf:load-op :graphic-forms-tests) + (load (concatenate 'string *gf-tests-dir* "test-utils")) + (load (concatenate 'string *gf-tests-dir* "mock-objects")) + (load (concatenate 'string *gf-tests-dir* "color-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "graphics-context-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "image-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "misc-unit-tests")))

1 0

[graphic-forms-cvs] r211 - in trunk: docs/manual src src/uitoolkit/graphics
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sat Aug 12 23:55:37 2006 New Revision: 211 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: fixed icon-handle-ref to not re-order handles, removed doc language about load order preservation, implemented and documented push-icon-image Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 12 23:55:37 2006 @@ -539,25 +539,20 @@ @defun icon-image-ref @ref{icon-bundle} subscript => @ref{image} (setf (@strong{icon-image-ref} @var{icon-bundle} @var{subscript}) @var{image})@*@* This function uses an integer or keyword -based @var{subscript} to address -the images comprising @var{icon-bundle}, either to retrieve an image -or add/replace an image via @sc{setf}. +the images comprising @var{icon-bundle}. @table @var @item icon-bundle Contains images to be used for frame decorations. @item subscript This argument can be zero-based, in which case @var{icon-bundle} -is treated as though it were an array of images. Add a new image -by specifying @var{subscript} 0.@*@* -Alternatively, @var{subscript} -can be one of the following keywords:@*@* +is treated as though it were an array of images. Alternatively, +@var{subscript} can be one of the following keywords:@*@* @table @code @item :large Identifies the largest image of the @var{icon-bundle}. @item :small -Identifies the smallest image of the @var{icon-bundle}.@*@* +Identifies the smallest image of the @var{icon-bundle}. @end table -Note that adding an image addressed by one of these -keywords will succeed, but the result may be counter-intuitive. @end table To find out how many images are stored in @var{icon-bundle}, and hence what constitutes a valid range of subscripts for this function, @@ -588,6 +583,21 @@ where @var{self} is a @ref{graphics-context}. @end deffn +@defun push-icon-image @ref{image} @ref{icon-bundle} &optional transparency-pixel => icon-bundle +Use this function to prepend a new image to an existing icon-bundle. +Note that @var{icon-bundle} takes ownership of @var{image}. +@table @var +@item image +The new image to be prepended. +@item icon-bundle +The icon-bundle to receive @var{image}. +@item transparency-pixel +A @ref{point} object identifying a pixel in @var{image} with the color to +be used for transparency. If not specified, the pixel at @code{(0, 0)} will +be used. +@end table +@end defun + @deffn GenericFunction size self => @ref{size} Returns a size object describing the dimensions of @var{self}. @end deffn Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 12 23:55:37 2006 @@ -265,7 +265,7 @@ This is the base class for user interface objects that generate events@footnote{Actually, events are generated by underlying native window objects, which are represented in the class hierarchy by -the event-source class}. It derives from @ref{native-object}. +the event-source class.}. It derives from @ref{native-object}. @table @var @item callback-event-name This is an (@code{:allocation :class}) slot that holds a symbol @@ -792,10 +792,10 @@ Implement this method to respond to @var{widget} being activated. For a @ref{top-level} @ref{window} or @ref{dialog}, this means that @var{widget} was brought to the foreground and its trim (titlebar and -border) was highlighted to indicate that it is now the active -window. For a @ref{menu}, it means that the user has clicked on the -@ref{item} invoking @ref{widget} and it is about to be shown; this is -an opportunity to update the menu's contents. @xref{event-deactivate}. +border) became highlighted. For a @ref{menu}, it means that the user +has clicked on the @ref{item} invoking @ref{widget} and it is about +to be shown; this is an opportunity to update the menu's contents. +@xref{event-deactivate}. @table @var @event-dispatcher-arg @item widget @@ -841,8 +841,8 @@ @deffn GenericFunction event-dispose dispatcher widget Implement this method to respond to @var{widget} being disposed (explicitly -via @ref{dispose}, not collected via the garbage collector). This -event function is called while the contents of @var{widget} are still +via @ref{dispose}; this event is not associated with garbage collection). +This event function is called while the contents of @var{widget} are still valid. @table @var @event-dispatcher-arg Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 12 23:55:37 2006 @@ -208,6 +208,7 @@ #:multiply #:pen-style #:pen-width + #:push-icon-image #:rgb->color #:red-mask #:red-shift Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sat Aug 12 23:55:37 2006 @@ -71,10 +71,6 @@ (gfs:dispose im)) extent)) -;;; Note: this function needs to return a place not -;;; just a handle, to facilitate a defsetf further -;;; on below -;;; (defun icon-handle-ref (bundle index) (let ((handles (gfs:handle bundle))) (unless handles @@ -86,16 +82,16 @@ (elt handles index) (error 'gfs:toolkit-error :detail "invalid image index")) (if (zerop index) - (gfs:handle bundle) + handles (error 'gfs:toolkit-error :detail "invalid image index")))) ((eql index :small) (if (listp handles) - (first (stable-sort handles #'< :key #'icon-extent)) - (gfs:handle bundle))) + (first (sort (copy-list handles) #'< :key #'icon-extent)) + handles)) ((eql index :large) (if (listp handles) - (first (last (stable-sort handles #'< :key #'icon-extent))) - (gfs:handle bundle))) + (first (sort (copy-list handles) #'> :key #'icon-extent)) + handles)) (t (error 'gfs:toolkit-error :detail "an integer index, or one of :small or :large, is required"))))) @@ -129,6 +125,13 @@ (length handles) 1))) +(defun push-icon-image (image bundle &optional transparency-pixel) + (if (gfs:disposed-p image) + (error 'gfs:disposed-error)) + (let ((tmp (gfs:handle bundle))) + (push (image->hicon image transparency-pixel) tmp) + (setf (slot-value bundle 'gfs:handle) tmp))) + ;;; ;;; methods ;;;

1 0

[graphic-forms-cvs] r210 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics
by junrue＠common-lisp.net 12 Aug '06

12 Aug '06

Author: junrue Date: Sat Aug 12 01:44:13 2006 New Revision: 210 Added: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/system-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-tests.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: icon-bundle testing and bug fixing Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat Aug 12 01:44:13 2006 @@ -14,9 +14,9 @@ of the package names are prefixed with @code{graphic-forms.uitoolkit}. @menu -* graphics package:: -* system package:: -* widgets package:: +* GFS package:: +* GFG package:: +* GFW package:: @end menu @include graphics-api.texinfo Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,15 +5,15 @@ @c Copyright (c) 2006, Jack D. Unrue -@node graphics package, widgets package, system package, API -@section graphics package -@cindex graphics package - -Nickname: GFG - -This package represents graphical functionality, particularly drawing -operations. Support for the ImageMagick library is defined here. This -package and GFW together constitute the bulk of the public API. +@node GFG package +@section GFG package +@cindex GFG package + +Full package name: @emph{graphic-forms.uitoolkit.graphics} + +This package contains the symbols corresponding to graphics-related +classes, drawing operations, and meta-data. This package and +@sc{gfw} together comprise the bulk of the library API. @menu * graphics types:: @@ -205,23 +205,26 @@ Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN documentation for further discussion of standard icon sizes, color depths and file format.@*@* +The implementation of @code{icon-bundle} includes the concept of +there being large and small versions. The actual size to be used +depends on the context in which the icon is needed. To retrieve +or set an individual image, call @ref{icon-image-ref}. To find +out how many @ref{image}s are stored, call @ref{icon-bundle-length}.@*@* @code{icon-bundle} derives from @ref{native-object}. @deffn Initarg :file This initarg accepts a @sc{cl:pathname} identifying a file -with @ref{image-data} to be loaded, as described for the @ref{image} -class @code{:file} initarg. Note that the @sc{ico} format can -store multiple icons, all of which will be loaded. Application -code should not assume that load order is preserved. Since +with in a supported format to be loaded, as described for the +image class @code{:file} initarg. Note that the @sc{ico} format +can store multiple images, all of which will be loaded. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the -proper transparency @ref{color}; by default, the pixel color at -@code{(0, 0)} in each image will be used. @emph{FIXME: link -to documentation of graphics plugins here}. +proper transparency @ref{color}; or else by default, the pixel +color at @code{(0, 0)} in each image will be used. @emph{FIXME: +link to documentation of graphics plugins here}. @end deffn @deffn Initarg :images -This initarg accepts a @sc{cl:list} of image objects. Application -code should not assume that image order is preserved. Since +This initarg accepts a @sc{cl:list} of image objects. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, the application may either @sc{setf} @ref{transparency-pixel} for each image ahead of time (especially @@ -527,28 +530,38 @@ Returns a color object corresponding to the current foreground color. @end deffn -@anchor{icon-image} -@defun icon-image @ref{icon-bundle} index => @ref{image} -This function uses an integer or keyword -based @var{index} to address -the images comprising an icon-bundle, either to retrieve an image -or add/replace an image via @sc{setf}. Application code should not -assume that image load order was preserved when this function is called. +@anchor{icon-bundle-length} +@defun icon-bundle-length @ref{icon-bundle} => integer +Returns a count of the number of icon handles held by @var{icon-bundle}. +@end defun + +@anchor{icon-image-ref} +@defun icon-image-ref @ref{icon-bundle} subscript => @ref{image} +(setf (@strong{icon-image-ref} @var{icon-bundle} @var{subscript}) @var{image})@*@* +This function uses an integer or keyword -based @var{subscript} to address +the images comprising @var{icon-bundle}, either to retrieve an image +or add/replace an image via @sc{setf}. @table @var @item icon-bundle -This is an icon-bundle containing images to be updated or retrieved. -@item index -This argument can be a zero-based, with new images added by -specifying @var{index} 0. Or @var{index} can be one of the following -keywords: +Contains images to be used for frame decorations. +@item subscript +This argument can be zero-based, in which case @var{icon-bundle} +is treated as though it were an array of images. Add a new image +by specifying @var{subscript} 0.@*@* +Alternatively, @var{subscript} +can be one of the following keywords:@*@* @table @code @item :large -Specifies the largest image of the icon-bundle. +Identifies the largest image of the @var{icon-bundle}. @item :small -Specifies the smallest image of the icon-bundle. +Identifies the smallest image of the @var{icon-bundle}.@*@* @end table +Note that adding an image addressed by one of these +keywords will succeed, but the result may be counter-intuitive. @end table -To find out how many images are stored in an icon-bundle, call -@ref{size}. +To find out how many images are stored in @var{icon-bundle}, and hence +what constitutes a valid range of subscripts for this function, +call @ref{icon-bundle-length}. @end defun @anchor{load} Modified: trunk/docs/manual/system-api.texinfo ============================================================================== --- trunk/docs/manual/system-api.texinfo (original) +++ trunk/docs/manual/system-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,16 +5,16 @@ @c Copyright (c) 2006, Jack D. Unrue -@node system package, graphics package, , API -@section system package -@cindex system package +@node GFS package +@section GFS package +@cindex GFS package -Nickname: GFS +Full package name: @emph{graphic-forms.uitoolkit.system} The symbols in this package correspond to system-level functionality, -examples of which include bindings for Win32 API functions and associated -constants. The majority of the symbols herein are not exported, except for -a few fundamental types and methods +such as foreign function declarations for the Win32 @sc{api}. The +majority of the symbols herein are not exported, except +for a few fundamental types, conditions, and methods. @menu * system types:: Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,15 +5,16 @@ @c Copyright (c) 2006, Jack D. Unrue -@node widgets package, , graphics package, API -@section widgets package -@cindex widgets package - -Nickname: GFW - -This package contains symbols for all of the widgets, event methods, -and other UI objects defined by Graphic-Forms. This package and GFG -together constitute the bulk of the public API. +@node GFW package +@section GFW package +@cindex GFW package + +Full package name: @emph{graphic-forms.uitoolkit.widgets} + +This package contains symbols for user interface widget +classes, event-handling methods, and management functions. This +package and @sc{gfg} together constitute the bulk of the library +API. @menu * event functions:: Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sat Aug 12 01:44:13 2006 @@ -65,6 +65,7 @@ ((:file "textedit-document") (:file "textedit-window"))) (:module "unblocked" + :serial t :components ((:file "tiles") (:file "unblocked-model") @@ -75,11 +76,14 @@ (:module "tests" :components ((:module "uitoolkit" + :serial t :components - ((:file "mock-objects") + ((:file "test-utils") + (:file "mock-objects") (:file "color-unit-tests") (:file "graphics-context-unit-tests") (:file "image-unit-tests") + (:file "icon-bundle-unit-tests") (:file "layout-unit-tests") (:file "widget-unit-tests") (:file "misc-unit-tests") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 12 01:44:13 2006 @@ -188,7 +188,8 @@ #:green-mask #:green-shift #:height - #:icon-image + #:icon-bundle-length + #:icon-image-ref #:invert #:leading #:line-cap-style Added: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sat Aug 12 01:44:13 2006 @@ -0,0 +1,38 @@ +;;;; +;;;; icon-bundle-unit-tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + + + + Added: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sat Aug 12 01:44:13 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; test-utils.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +#| +(defun validate-image (image expected-size expected-depth) + (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) + (assert-equal expected-depth (gfg:depth image))) +|# Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sat Aug 12 01:44:13 2006 @@ -41,11 +41,28 @@ (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) (gfs::zero-mem info-ptr gfs::iconinfo) (if (zerop (gfs::get-icon-info hicon info-ptr)) - (error 'gfs::win32-error :detail "get-icon-info failed")) + (error 'gfs:win32-error :detail "get-icon-info failed")) (cffi:with-foreign-slots ((gfs::hmask gfs::hcolor) info-ptr gfs::iconinfo) (gfs::delete-object gfs::hmask) (make-instance 'image :handle gfs::hcolor)))) +(defun image->hicon (image &optional point) + (unless (typep point 'gfs:point) + (setf point (transparency-pixel-of image)) + (unless point + (setf point (gfs:make-point)))) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (setf gfs::flag 1) + (with-image-transparency (image point) + (setf gfs::hcolor (gfs:handle image)) + (setf gfs::hmask (gfs:handle (transparency-mask image))) + (let ((hicon (gfs::create-icon-indirect info-ptr))) + (if (gfs:null-handle-p hicon) + (error 'gfs:win32-error :detail "create-icon-indirect failed")) + hicon))))) + (defun icon-extent (hicon) (let ((im (hicon->image hicon)) (extent 0)) @@ -54,30 +71,63 @@ (gfs:dispose im)) extent)) -(defun icon-handle (bundle index) +;;; Note: this function needs to return a place not +;;; just a handle, to facilitate a defsetf further +;;; on below +;;; +(defun icon-handle-ref (bundle index) (let ((handles (gfs:handle bundle))) (unless handles (error 'gfs:disposed-error)) (cond ((typep index 'integer) - (if (zerop index) - (if (listp handles) + (if (listp handles) + (if (< index (length handles)) (elt handles index) - handles))) + (error 'gfs:toolkit-error :detail "invalid image index")) + (if (zerop index) + (gfs:handle bundle) + (error 'gfs:toolkit-error :detail "invalid image index")))) ((eql index :small) (if (listp handles) (first (stable-sort handles #'< :key #'icon-extent)) - handles)) + (gfs:handle bundle))) ((eql index :large) (if (listp handles) (first (last (stable-sort handles #'< :key #'icon-extent))) - handles)) + (gfs:handle bundle))) (t (error 'gfs:toolkit-error :detail "an integer index, or one of :small or :large, is required"))))) -(defun icon-image (bundle index) - (hicon->image (icon-handle bundle index))) +(defsetf icon-handle-ref (bundle index) (hicon) + `(progn + (if (gfs:null-handle-p ,hicon) + (error 'gfs:disposed-error)) + (cond + ((listp (gfs:handle ,bundle)) + (replace (gfs:handle ,bundle) (list ,hicon) :start1 ,index)) + ((and (zerop ,index) (not (null (gfs:handle ,bundle)))) + (setf (slot-value ,bundle 'gfs:handle) ,hicon)) + (t + (error 'gfs:toolkit-error :detail "illegal arguments for (setf icon-handle-ref)"))) + ,hicon)) + +(defun icon-image-ref (bundle index) + (hicon->image (icon-handle-ref bundle index))) + +(defun set-icon-image (bundle index image) + (setf (icon-handle-ref bundle index) (image->hicon image))) + +(defsetf icon-image-ref set-icon-image) + +(defun icon-bundle-length (bundle) + (let ((handles (gfs:handle bundle))) + (unless handles + (error 'gfs:disposed-error)) + (if (listp handles) + (length handles) + 1))) ;;; ;;; methods @@ -104,26 +154,14 @@ (otherwise nil)))) (cond (resource-id - (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) - (file - (let ((tmp-image (make-instance 'image))) - (setf image-list (load tmp-image file)))) - (images - (setf image-list images))) + (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)))) + ((listp images) + (setf image-list images))) (when image-list - (let ((handles nil) - (default-pnt (gfs:make-point))) - (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) - (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) - (gfs::zero-mem info-ptr gfs::iconinfo) - (setf gfs::flag 1) - (loop for tmp-image in image-list - do (with-image-transparency (tmp-image (or transparency-pixel default-pnt)) - (setf gfs::hcolor (gfs:handle tmp-image)) - (setf gfs::hmask (gfs:handle (transparency-mask tmp-image))) - (let ((hicon (gfs::create-icon-indirect info-ptr))) - (unless (gfs:null-handle-p hicon) - (push hicon handles))))))) - (setf (slot-value self 'gfs:handle) handles)))) + (let ((tr-pnt (or transparency-pixel (gfs:make-point)))) + (setf (slot-value self 'gfs:handle) (loop for tmp-image in image-list + collect (image->hicon tmp-image tr-pnt)))))) (unless (gfs:handle self) (error 'gfs:toolkit-error :detail "could not initialize icon bundle")))

1 0

[graphic-forms-cvs] r209 - in trunk: . docs/manual
by junrue＠common-lisp.net 11 Aug '06

11 Aug '06

Author: junrue Date: Fri Aug 11 15:47:54 2006 New Revision: 209 Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/overview.texinfo Log: added note about SBCL support Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Fri Aug 11 15:47:54 2006 @@ -1,4 +1,12 @@ + +. SBCL 0.9.15 is now a supported Common Lisp implementation. Graphic-Forms + includes a small patch to enable the stdcall calling convention for alien + callbacks, located in src/external-libraries/sbcl-callback-patch + + +============================================================================== + Release 0.4.0 of Graphic-Forms, a Common Lisp library for Windows GUI programming, is now available. This is an alpha release, meaning that the feature set and API have not yet stabilized. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Fri Aug 11 15:47:54 2006 @@ -37,7 +37,8 @@ Supported Common Lisp Implementations ------------------------------------- -Graphic-Forms currently supports CLISP 2.38 and LispWorks 4.4.6. +Graphic-Forms currently supports CLISP 2.38, LispWorks 4.4.6, and SBCL 0.9.15 +(the latter with a small patch). Known Problems Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Fri Aug 11 15:47:54 2006 @@ -52,8 +52,11 @@ Graphic-Forms is currently developed and tested with: @itemize @bullet -@item CLISP 2.38 +@item CLISP 2.38 or later @item LispWorks 4.4.6 +@item SBCL 0.9.15 or later@footnote{a small patch to enable the +@sc{stdcall} calling convention for callbacks is temporarily +bundled with Graphic-Forms, see @code{src/external-libraries/sbcl-callback-patch/}} @end itemize @@ -61,7 +64,7 @@ @itemize @bullet @item XP SP2 -@item Vista (testing on Beta 2 is in-progress as of this release) +@item Vista@footnote{testing on Beta 2 is in-progress as of this release} @end itemize

1 0

[graphic-forms-cvs] r207 - in trunk/src: demos/textedit demos/unblocked uitoolkit/widgets
by junrue＠common-lisp.net 11 Aug '06

11 Aug '06

Author: junrue Date: Thu Aug 10 22:28:29 2006 New Revision: 207 Modified: trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: last of the tweaks for SBCL Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Thu Aug 10 22:28:29 2006 @@ -223,6 +223,8 @@ (setf *textedit-startup-dir* (ext:cd)) #+lispworks (setf *textedit-startup-dir* (hcl:get-working-directory)) +#+sbcl + (setf *textedit-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu :submenu ((:item "&New" :callback #'textedit-file-new) (:item "&Open..." :callback #'textedit-file-open) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Thu Aug 10 22:28:29 2006 @@ -166,6 +166,8 @@ (setf *unblocked-startup-dir* (ext:cd)) #+lispworks (setf *unblocked-startup-dir* (hcl:get-working-directory)) +#+sbcl + (setf *unblocked-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "&New" :callback #'new-unblocked) (:item "&Restart" :callback #'restart-unblocked) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu Aug 10 22:28:29 2006 @@ -307,7 +307,7 @@ (defmethod redraw ((self widget)) (let ((hwnd (gfs:handle self))) (unless (gfs:null-handle-p hwnd) - (gfs::invalidate-rect hwnd nil 1)))) + (gfs::invalidate-rect hwnd (cffi:null-pointer) 1)))) (defmethod resizable-p :before ((self widget)) (if (gfs:disposed-p self)

1 0