[graphic-forms-cvs] r117 - in trunk/src: . tests/uitoolkit uitoolkit/system uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu May 4 20:22:48 UTC 2006
Author: junrue
Date: Thu May 4 16:22:47 2006
New Revision: 117
Modified:
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/system/gdi32.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/label.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
implemented background-color/foreground-color/font customization for labels, infrastructure is in place for other controls too
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Thu May 4 16:22:47 2006
@@ -59,6 +59,9 @@
;; constants
;; methods, functions, macros
+ #:copy-point
+ #:copy-size
+ #:copy-span
#:detail
#:dispose
#:disposed-p
@@ -98,6 +101,7 @@
(:export
;; classes and structs
+ #:color
#:font
#:font-data
#:font-metrics
@@ -132,6 +136,9 @@
#:color-red
#:color-table
#:copy-area
+ #:copy-color
+ #:copy-font-data
+ #:copy-font-metrics
#:data-obj
#:depth
#:descent
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu May 4 16:22:47 2006
@@ -104,6 +104,7 @@
((eql subtype :image-label)
;; NOTE: we are leaking a bitmap handle by not tracking the
;; image being created here
+ (setf (gfg:background-color w) (gfg:background-color *layout-tester-win*))
(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))))
Modified: trunk/src/uitoolkit/system/gdi32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/gdi32.lisp (original)
+++ trunk/src/uitoolkit/system/gdi32.lisp Thu May 4 16:22:47 2006
@@ -152,6 +152,11 @@
(path :string))
(defcfun
+ ("CreateSolidBrush" create-solid-brush)
+ HANDLE
+ (color COLORREF))
+
+(defcfun
("DeleteDC" delete-dc)
BOOL
(hdc HANDLE))
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Thu May 4 16:22:47 2006
@@ -800,6 +800,13 @@
(defconstant +wm-initmenupopup+ #x0117)
(defconstant +wm-menuselect+ #x011F)
(defconstant +wm-menuchar+ #x0120)
+(defconstant +wm-ctlcolormsgbox+ #x0132)
+(defconstant +wm-ctlcoloredit+ #x0133)
+(defconstant +wm-ctlcolorlistbox+ #x0134)
+(defconstant +wm-ctlcolorbtn+ #x0135)
+(defconstant +wm-ctlcolordlg+ #x0136)
+(defconstant +wm-ctlcolorscrollbar+ #x0137)
+(defconstant +wm-ctlcolorstatic+ #x0138)
(defconstant +wm-mousefirst+ #x0200) ; for use with peek-message
(defconstant +wm-mousemove+ #x0200)
(defconstant +wm-lbuttondown+ #x0201)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Thu May 4 16:22:47 2006
@@ -259,6 +259,13 @@
(index INT))
(defcfun
+ ("GetClassNameA" get-class-name)
+ INT
+ (hwnd HANDLE)
+ (classname LPTSTR)
+ (maxcount INT))
+
+(defcfun
("GetClientRect" get-client-rect)
BOOL
(hwnd HANDLE)
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Thu May 4 16:22:47 2006
@@ -53,13 +53,40 @@
;;; methods
;;;
-(defmethod background-color :before ((ctrl control))
+(defmethod gfg: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 gfg:background-color ((ctrl control))
+ (or (brush-color-of ctrl) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))))
+
+(defmethod (setf gfg:background-color) :before (color (ctrl control))
+ (declare (ignore color))
+ (if (gfs:disposed-p ctrl)
+ (error 'gfs:disposed-error)))
+
+(defmethod (setf gfg:background-color) (color (ctrl control))
+ (let ((hbrush (brush-handle-of ctrl)))
+ (when (not (gfs:null-handle-p hbrush))
+ (gfs::delete-object hbrush)
+ (setf (brush-handle-of ctrl) (cffi:null-pointer)))
+ (setf hbrush (gfs::create-solid-brush (gfg:color->rgb color)))
+ (if (gfs:null-handle-p hbrush)
+ (error 'gfs:win32-error :detail "create-solid-brush failed"))
+ (setf (brush-color-of ctrl) (gfg:copy-color color))
+ (setf (brush-handle-of ctrl) hbrush))
+ (redraw ctrl))
+
+(defmethod gfs:dispose ((ctrl control))
+ (let ((hbrush (brush-handle-of ctrl))
+ (font (font-of ctrl)))
+ (if font
+ (gfs:dispose font))
+ (setf (font-of ctrl) nil)
+ (if (not (gfs:null-handle-p hbrush))
+ (gfs::delete-object hbrush))
+ (setf (brush-handle-of ctrl) (cffi:null-pointer)))
+ (call-next-method))
(defmethod focus-p :before ((ctrl control))
(if (gfs:disposed-p ctrl)
@@ -69,6 +96,38 @@
(let ((focus-hwnd (gfs::get-focus)))
(and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle ctrl)))))
+(defmethod gfg:font :before ((ctrl control))
+ (if (gfs:disposed-p ctrl)
+ (error 'gfs:disposed-error)))
+
+(defmethod gfg:font ((ctrl control))
+ (font-of ctrl))
+
+(defmethod (setf gfg:font) :before (font (ctrl control))
+ (declare (ignore color))
+ (if (or (gfs:disposed-p ctrl) (gfs:disposed-p font))
+ (error 'gfs:disposed-error)))
+
+(defmethod (setf gfg:font) (font (ctrl control))
+ (setf (font-of ctrl) font)
+ (redraw ctrl))
+
+(defmethod gfg:foreground-color :before ((ctrl control))
+ (if (gfs:disposed-p ctrl)
+ (error 'gfs:disposed-error)))
+
+(defmethod gfg:foreground-color ((ctrl control))
+ (or (text-color-of ctrl) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btntext+))))
+
+(defmethod (setf gfg:foreground-color) :before (color (ctrl control))
+ (declare (ignore color))
+ (if (gfs:disposed-p ctrl)
+ (error 'gfs:disposed-error)))
+
+(defmethod (setf gfg:foreground-color) (color (ctrl control))
+ (setf (text-color-of ctrl) (gfg:copy-color color))
+ (redraw ctrl))
+
(defmethod give-focus :before ((ctrl control))
(if (gfs:disposed-p ctrl)
(error 'gfs:disposed-error)))
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Thu May 4 16:22:47 2006
@@ -306,6 +306,27 @@
(error 'gfs:toolkit-error :detail "no object for hwnd")))
0)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam)
+ (declare (ignore hwnd))
+ (let* ((tc (thread-context))
+ (widget (get-widget tc (cffi:make-pointer lparam)))
+ (hdc (cffi:make-pointer wparam))
+ (bkgdcolor (brush-color-of widget))
+ (textcolor (text-color-of widget))
+ (ret-val 0))
+ (when widget
+ (if (not (typep widget 'label))
+ (error 'gfs:toolkit-error :detail "incorrect widget type received WM_CTLCOLORSTATIC"))
+ (let ((font (font-of widget)))
+ (if font
+ (gfs::select-object hdc (gfs:handle font))))
+ (if bkgdcolor
+ (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor)))
+ (if textcolor
+ (gfs::set-text-color hdc (gfg:color->rgb textcolor)))
+ (setf ret-val (cffi:pointer-address (brush-handle-of widget))))
+ ret-val))
+
(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam)
(declare (ignore wparam))
(process-mouse-message #'event-mouse-double hwnd lparam :right-button))
Modified: trunk/src/uitoolkit/widgets/label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/label.lisp (original)
+++ trunk/src/uitoolkit/widgets/label.lisp Thu May 4 16:22:47 2006
@@ -34,7 +34,7 @@
(in-package :graphic-forms.uitoolkit.widgets)
;;;
-;;; methods
+;;; helper functions
;;;
(defun compute-image-style-flags (style)
@@ -77,6 +77,20 @@
(setf flags (logior flags gfs::+ss-left+)))))
flags))
+;;;
+;;; methods
+;;;
+
+(defmethod (setf gfg:background-color) (color (label label))
+ (declare (ignorable color))
+ (call-next-method)
+ (let ((image (image label))
+ (pnt (pixel-point-of label)))
+ (when image
+ (if pnt
+ (setf (gfg:transparency-pixel-of image) pnt))
+ (setf (image label) image))))
+
(defmethod compute-style-flags ((label label) style &rest extra-data)
(declare (ignore label))
(if (> (count-if-not #'null extra-data) 1)
@@ -113,7 +127,7 @@
gfs::+ws-visible+))
(tr-pnt (gfg:transparency-pixel-of image)))
(if tr-pnt
- (let* ((color (background-color label))
+ (let* ((color (gfg:background-color label))
(size (gfg:size image))
(bounds (make-instance 'gfs:rectangle :size size))
(tmp-image (make-instance 'gfg:image :size size))
@@ -125,7 +139,8 @@
(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)))
+ (gfg:draw-image gc image (gfs:location bounds))
+ (setf (pixel-point-of label) (gfs:copy-point tr-pnt)))
(gfs:dispose gc))
(setf image tmp-image)))
(if (/= orig-flags flags)
Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp (original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Thu May 4 16:22:47 2006
@@ -33,9 +33,6 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd")
-(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")
-
(defconstant +default-window-title+ "New Window")
;;;
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu May 4 16:22:47 2006
@@ -65,7 +65,22 @@
(defclass caret (widget) ()
(:documentation "The caret class provides an i-beam typically representing an insertion point."))
-(defclass control (widget) ()
+(defclass control (widget)
+ ((brush-color
+ :accessor brush-color-of
+ :initform nil)
+ (brush-handle
+ :accessor brush-handle-of
+ :initform (cffi:null-pointer))
+ (font
+ :accessor font-of
+ :initform nil)
+ (text-color
+ :accessor text-color-of
+ :initform nil)
+ (pixel-point
+ :accessor pixel-point-of
+ :initform nil))
(:documentation "The base class for widgets having pre-defined native behavior."))
(defclass button (control) ()
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu May 4 16:22:47 2006
@@ -51,9 +51,6 @@
(defgeneric append-submenu (self text submenu dispatcher)
(:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))
-(defgeneric background-color (self)
- (:documentation "Returns a color object corresponding to the current background color."))
-
(defgeneric border-width (self)
(:documentation "Returns the object's border width."))
@@ -156,9 +153,6 @@
(defgeneric focus-p (self)
(:documentation "Returns T if this object has the keyboard focus; nil otherwise."))
-(defgeneric foreground-color (self)
- (:documentation "Returns a color object corresponding to the current foreground color."))
-
(defgeneric give-focus (self)
(:documentation "Causes this object to have the keyboard focus."))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Thu May 4 16:22:47 2006
@@ -33,6 +33,9 @@
(in-package :graphic-forms.uitoolkit.widgets)
+(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd")
+(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")
+
;;;
;;; helper functions
;;;
@@ -151,8 +154,15 @@
;;; methods
;;;
-(defmethod background-color ((win window))
- (gfg:rgb->color (gfs::get-class-long (gfs:handle win) gfs::+gclp-hbrbackground+)))
+(defmethod gfg:background-color ((win window))
+ (let ((hwnd (gfs:handle win))
+ (color nil))
+ (cffi:with-foreign-pointer-as-string (str-ptr 64)
+ (gfs::get-class-name hwnd str-ptr 64)
+ (if (string= (cffi:foreign-string-to-lisp str-ptr) +toplevel-erasebkgnd-window-classname+)
+ (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+)))
+ (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+)))))
+ color))
(defmethod compute-outer-size ((win window) desired-client-size)
;; TODO: consider reimplementing this with AdjustWindowRect
More information about the Graphic-forms-cvs
mailing list