Author: junrue Date: Sun Apr 16 02:14:03 2006 New Revision: 98 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: revised label control to support both text and image content Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 16 02:14:03 2006 @@ -238,9 +238,46 @@ @end deffn @end deftp +@anchor{label} @deftp Class label -This @ref{control} class represents non-selectable controls that -display a string or image. +This @ref{control} subclass represents non-selectable controls that +display a string, image, or etched line. +@deffn Initarg :image +Supply an @ref{image} object as the value of this initarg to configure +the label to display the image rather than text. +@end deffn +@deffn Initarg :separator +Supply @sc{t} for the value of this initarg to configure the label to +render itself as an etched horizontal (or vertical) divider. The +@code{:style} initarg is used to select the desired orientation. +@end deffn +@deffn Initarg :style +When configured as a @code{text} label, the following keyword symbols +are relevant: +@itemize bullet +@item @code{:beginning} +@item @code{:center} +@item @code{:ellipsis} +@item @code{:end} +@item @code{:wrap} +@end itemize +The following style style keywords apply for both @code{text} and +@code{image} modes: +@itemize bullet +@item @code{:raised} +@item @code{:sunken} +@end itemize +Finally, the following style keywords apply when a label is +configured as a @code{separator}: +@itemize bullet +@item @code{:horizontal} +@item @code{:vertical} +@end itemize +@end deffn +@deffn Initarg :text +Supply a string as the value of this initarg to configure the label to +act as a text label. This mode is also the default. +@end deffn @end deftp @anchor{menu} @@ -893,9 +930,22 @@ @end deffn @end deftp +@anchor{image} +@deftp Class image +This subclass of @ref{native-object} wraps a native image object. +Instances may be drawn directly via a graphics-context (see +@ref{draw-image}) or set as the content of a @ref{label} control. +@deffn Initarg :size +Supply a @ref{size} object via this initarg to create a new image +object with the desired width and height. +@end deffn +@xref{image-data}. +@end deftp + +@anchor{image-data} @deftp Class image-data This subclass of @ref{native-object} maintains image attributes, -color, and pixel data. +color, and pixel data. @xref{image}. @end deftp @node graphics functions @@ -1020,6 +1070,7 @@ determined by @code{arc-size}. @end deffn +@anchor{draw-image} @deffn GenericFunction draw-image self image point Draws @code{image} in the receiver where @code{point} identifies the position of the upper-left corner of the image. Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Apr 16 02:14:03 2006 @@ -184,6 +184,7 @@ #:multiply #:pen-style #:pen-width + #:rgb->color #:red-mask #:red-shift #:rotate Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Apr 16 02:14:03 2006 @@ -103,6 +103,12 @@ (setf flag nil) (format nil "~d ~a" (id be) +btn-text-after+)))))) (setf (gfw:text w) (funcall (toggle-fn be)))) + ((eql subtype :image-label) + ;; NOTE: we are leaking a bitmap handle by not tracking the + ;; image being created here + (let ((tmp-image (make-instance 'gfg:image :file "happy.bmp"))) + (gfg:with-image-transparency (tmp-image (gfs:make-point)) + (setf (gfw:image w) tmp-image)))) ((eql subtype :text-label) (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+)))) (incf *widget-counter*))) @@ -350,6 +356,8 @@ (add-btn-disp (make-instance 'add-child-dispatcher)) (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel :subtype :panel)) + (add-image-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label + :subtype :image-label)) (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) @@ -366,7 +374,8 @@ (:item "&Children" :submenu ((:item "Add" :submenu ((:item "Button" :dispatcher add-btn-disp) - (:item "Label" :dispatcher add-text-label-disp) + (:item "Label - Image" :dispatcher add-image-label-disp) + (:item "Label - Text" :dispatcher add-text-label-disp) (:item "Panel" :dispatcher add-panel-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Apr 16 02:14:03 2006 @@ -82,25 +82,28 @@ (gfs:dispose im)) (setf (slot-value im 'gfs:handle) (data->image id))) -(defmethod initialize-instance :after ((image image) &key size &allow-other-keys) - (unless (null size) - (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) - (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) - (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes - gfs::bibitcount gfs::bicompression) - bih-ptr gfs::bitmapinfoheader) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biwidth (gfs:size-width size) - gfs::biheight (- (gfs:size-height size)) - gfs::biplanes 1 - gfs::bibitcount 32 - gfs::bicompression gfs::+bi-rgb+) - (let ((nptr (cffi:null-pointer)) - (hbmp (cffi:null-pointer))) - (cffi:with-foreign-object (buffer :pointer) - (gfs::with-compatible-dcs (nptr memdc) - (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) - (setf (slot-value image 'gfs:handle) hbmp)))))) +(defmethod initialize-instance :after ((image image) &key file size &allow-other-keys) + (cond + (file + (load image file)) + (size + (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) + (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes + gfs::bibitcount gfs::bicompression) + bih-ptr gfs::bitmapinfoheader) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biwidth (gfs:size-width size) + gfs::biheight (- (gfs:size-height size)) + gfs::biplanes 1 + gfs::bibitcount 32 + gfs::bicompression gfs::+bi-rgb+) + (let ((nptr (cffi:null-pointer)) + (hbmp (cffi:null-pointer))) + (cffi:with-foreign-object (buffer :pointer) + (gfs::with-compatible-dcs (nptr memdc) + (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) + (setf (slot-value image 'gfs:handle) hbmp))))))) (defmethod load ((im image) path) (let ((data (make-instance 'image-data))) @@ -127,18 +130,20 @@ (hbmp (gfs:handle im)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer))) - (unless (null pixel-pnt) - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) - (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) - (if (gfs:null-handle-p hmask) - (error 'gfs:win32-error :detail "create-bitmap failed")) - (gfs::with-compatible-dcs (nptr memdc1 memdc2) - (gfs::select-object memdc1 hbmp) - (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 - (gfs:point-x pixel-pnt) - (gfs:point-y pixel-pnt))) - (gfs::select-object memdc2 hmask) - (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+))) - (make-instance 'image :handle hmask))))) + (if pixel-pnt + (progn + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) + (if (gfs:null-handle-p hmask) + (error 'gfs:win32-error :detail "create-bitmap failed")) + (gfs::with-compatible-dcs (nptr memdc1 memdc2) + (gfs::select-object memdc1 hbmp) + (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 + (gfs:point-x pixel-pnt) + (gfs:point-y pixel-pnt))) + (gfs::select-object memdc2 hmask) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+)))) + (make-instance 'image :handle hmask)) + nil))) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Apr 16 02:14:03 2006 @@ -602,6 +602,17 @@ (defconstant +ss-wordellipsis+ #x0000C000) (defconstant +ss-ellipsismask+ #x0000C000) +(defconstant +stm-seticon+ #x0170) +(defconstant +stm-geticon+ #x0171) +(defconstant +stm-setimage+ #x0172) +(defconstant +stm-getimage+ #x0173) +(defconstant +stm-msgmax+ #x0174) + +(defconstant +stn-clicked+ 0) +(defconstant +stn-dblclk+ 1) +(defconstant +stn-enable+ 2) +(defconstant +stn-disable+ 3) + (defconstant +sw-hide+ 0) (defconstant +sw-shownormal+ 1) (defconstant +sw-normal+ 1) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Apr 16 02:14:03 2006 @@ -323,6 +323,11 @@ (pos INT)) (defcfun + ("GetSysColor" get-sys-color) + DWORD + (index INT)) + +(defcfun ("GetSystemMetrics" get-system-metrics) INT (index INT)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun Apr 16 02:14:03 2006 @@ -37,8 +37,8 @@ ;;; methods ;;; -(defmethod compute-style-flags ((btn button) style) - (declare (ignore btn)) +(defmethod compute-style-flags ((btn button) style &rest extra-data) + (declare (ignore btn extra-data)) (let ((std-flags 0) (ex-flags 0)) (setf style (gfs:flatten style)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Apr 16 02:14:03 2006 @@ -53,6 +53,14 @@ ;;; methods ;;; +(defmethod background-color :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod background-color ((ctrl control)) + (declare (ignore ctrl)) + (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) + (defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) (if (gfs:disposed-p parent) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Sun Apr 16 02:14:03 2006 @@ -37,77 +37,157 @@ ;;; methods ;;; -(defmethod compute-style-flags ((label label) style) - (declare (ignore label)) - (let ((std-flags 0) - (ex-flags 0)) - (setf style (gfs:flatten style)) - (unless (or (find :beginning style) - (find :center style) - (find :end style)) - (setf std-flags gfs::+ss-leftnowordwrap+)) +(defun compute-image-style-flags (style) + (let ((flags (logior gfs::+ss-bitmap+ gfs::+ss-realsizeimage+ gfs::+ss-centerimage+))) + (when (find :raised style) + (setf flags (logand (lognot gfs::+ss-sunken+) flags)) + (setf flags (logior flags gfs::+ss-etchedframe+))) + (when (find :sunken style) + (setf flags (logand (lognot gfs::+ss-etchedframe+) flags)) + (setf flags (logior flags gfs::+ss-sunken+))) + flags)) + +(defun compute-text-style-flags (style) + (let ((flags 0)) + (unless (intersection style (list :beginning :center :end)) + (setf flags gfs::+ss-leftnowordwrap+)) (loop for sym in style do (cond - ;; primary static styles + ;; primary text static styles ;; ((eq sym :beginning) - (setf std-flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n + (setf flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n ((eq sym :center) - (setf std-flags gfs::+ss-center+)) + (setf flags gfs::+ss-center+)) ((eq sym :end) - (setf std-flags gfs::+ss-right+)) ; FIXME: i18n + (setf flags gfs::+ss-right+)) ; FIXME: i18n ;; styles that can be combined ;; ((eq sym :ellipsis) - (setf std-flags (logior std-flags gfs::+ss-endellipsis+))) + (setf flags (logior flags gfs::+ss-endellipsis+))) ((eq sym :raised) - (setf std-flags (logand (lognot gfs::+ss-sunken+) std-flags)) - (setf std-flags (logior std-flags gfs::+ss-etchedframe+))) + (setf flags (logand (lognot gfs::+ss-sunken+) flags)) + (setf flags (logior flags gfs::+ss-etchedframe+))) ((eq sym :sunken) - (setf std-flags (logand (lognot gfs::+ss-etchedframe+) std-flags)) - (setf std-flags (logior std-flags gfs::+ss-sunken+))) + (setf flags (logand (lognot gfs::+ss-etchedframe+) flags)) + (setf flags (logior flags gfs::+ss-sunken+))) ((eq sym :wrap) - (setf std-flags (logand (lognot gfs::+ss-leftnowordwrap+) std-flags)) - (setf std-flags (logior std-flags gfs::+ss-left+))))) - (values std-flags ex-flags))) + (setf flags (logand (lognot gfs::+ss-leftnowordwrap+) flags)) + (setf flags (logior flags gfs::+ss-left+))))) + flags)) + +(defmethod compute-style-flags ((label label) style &rest extra-data) + (declare (ignore label)) + (if (> (count-if-not #'null extra-data) 1) + (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) + (values (cond + ((first extra-data) + (compute-image-style-flags (gfs:flatten style))) + ((second extra-data) + (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) + (t + (compute-text-style-flags (gfs:flatten style)))) + 0)) + +(defmethod image ((label label)) + (if (gfs:disposed-p label) + (error 'gfs:disposed-error)) + (let ((addr (gfs::send-message (gfs:handle label) gfs::+stm-getimage+ gfs::+image-bitmap+ 0))) + (if (zerop addr) + nil + (make-instance 'gfg:image :handle (cffi:make-pointer addr))))) + +(defmethod (setf image) ((image gfg:image) (label label)) + (if (or (gfs:disposed-p label) (gfs:disposed-p image)) + (error 'gfs:disposed-error)) + (let* ((hwnd (gfs:handle label)) + (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) + (logand orig-flags gfs::+ss-sunken+))) + (flags (logior etch-flags + gfs::+ss-bitmap+ + gfs::+ss-realsizeimage+ + gfs::+ss-centerimage+ + gfs::+ws-child+ + gfs::+ws-visible+)) + (tr-pnt (gfg:transparency-pixel-of image))) + (if tr-pnt + (let* ((color (background-color label)) + (size (gfg:size image)) + (bounds (make-instance 'gfs:rectangle :size size)) + (tmp-image (make-instance 'gfg:image :size size)) + (gc (make-instance 'gfg:graphics-context :image tmp-image))) + (unwind-protect + (progn + (setf (gfg:background-color gc) color) + (let ((orig-color (gfg:foreground-color gc))) + (setf (gfg:foreground-color gc) color) + (gfg:draw-filled-rectangle gc bounds) + (setf (gfg:foreground-color gc) orig-color)) + (gfg:draw-image gc image (gfs:location bounds))) + (gfs:dispose gc)) + (setf image tmp-image))) + (if (/= orig-flags flags) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags)) + (gfs::send-message hwnd + gfs::+stm-setimage+ + gfs::+image-bitmap+ + (cffi:pointer-address (gfs:handle image))))) -(defmethod initialize-instance :after ((label label) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((label label) &key image parent separator style text &allow-other-keys) (if (not (listp style)) (setf style (list style))) (multiple-value-bind (std-style ex-style) - (compute-style-flags label style) + (compute-style-flags label style image separator text) (let ((hwnd (create-window gfs::+static-classname+ - " " + (or text " ") (gfs:handle parent) (logior std-style gfs::+ws-child+ gfs::+ws-visible+) ex-style))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value label 'gfs:handle) hwnd))) + (setf (slot-value label 'gfs:handle) hwnd) + (if image + (setf (image label) image)))) (init-control label)) - (defmethod preferred-size ((label label) width-hint height-hint) + (declare (ignorable width-hint height-hint)) (let* ((hwnd (gfs:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (b-width (border-width label)) - (sz nil) - (flags (logior gfs::+dt-editcontrol+ - gfs::+dt-expandtabs+))) - (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) - (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf sz (widget-text-size label flags)) - (if (>= width-hint 0) - (setf (gfs:size-width sz) width-hint)) - (if (>= height-hint 0) - (setf (gfs:size-height sz) height-hint)) - (incf (gfs:size-width sz) (* b-width 2)) - (incf (gfs:size-height sz) (* b-width 2)) - sz)) + (sz nil)) + (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) ; SS_BITMAP is not a single bit + (let ((image (image label))) + (if image + (gfg:size image) + (gfs:make-size))) + (let ((flags (logior gfs::+dt-editcontrol+ gfs::+dt-expandtabs+))) + (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) + (setf flags (logior flags gfs::+dt-wordbreak+))) + (setf sz (widget-text-size label flags)) + (if (>= width-hint 0) + (setf (gfs:size-width sz) width-hint)) + (if (>= height-hint 0) + (setf (gfs:size-height sz) height-hint)) + (incf (gfs:size-width sz) (* b-width 2)) + (incf (gfs:size-height sz) (* b-width 2)) + sz)))) (defmethod text ((label label)) (get-widget-text label)) (defmethod (setf text) (str (label label)) + (let* ((hwnd (gfs:handle label)) + (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) + (logand orig-flags gfs::+ss-sunken+)))) + (multiple-value-bind (std-flags ex-flags) + (compute-style-flags label nil nil nil str) + (declare (ignore ex-flags)) + (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags + std-flags + gfs::+ws-child+ + gfs::+ws-visible+)))) (set-widget-text label str)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Sun Apr 16 02:14:03 2006 @@ -49,7 +49,8 @@ ;;; methods ;;; -(defmethod compute-style-flags ((self panel) style) +(defmethod compute-style-flags ((self panel) style &rest extra-data) + (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) (ex-flags 0)) (mapc #'(lambda (sym) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 16 02:14:03 2006 @@ -63,8 +63,8 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) style) - (declare (ignore win)) +(defmethod compute-style-flags ((win top-level) style &rest extra-data) + (declare (ignore win extra-data)) (let ((std-flags 0) (ex-flags 0)) (mapc #'(lambda (sym) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Apr 16 02:14:03 2006 @@ -105,7 +105,7 @@ (defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (self style) +(defgeneric compute-style-flags (self style &rest extra-data) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) (defgeneric compute-outer-size (self desired-client-size) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Apr 16 02:14:03 2006 @@ -149,6 +149,9 @@ ;;; methods ;;; +(defmethod background-color ((win window)) + (gfg:rgb->color (gfs::get-class-long (gfs:handle win) gfs::+gclp-hbrbackground+))) + (defmethod compute-outer-size ((win window) desired-client-size) ;; TODO: consider reimplementing this with AdjustWindowRect ;;