[graphic-forms-cvs] r72 - in trunk/src: tests/uitoolkit uitoolkit/graphics uitoolkit/system uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sat Mar 25 04:23:25 UTC 2006
Author: junrue
Date: Fri Mar 24 23:23:24 2006
New Revision: 72
Modified:
trunk/src/tests/uitoolkit/drawing-tester.lisp
trunk/src/tests/uitoolkit/hello-world.lisp
trunk/src/tests/uitoolkit/windlg.lisp
trunk/src/uitoolkit/graphics/graphics-classes.lisp
trunk/src/uitoolkit/graphics/graphics-context.lisp
trunk/src/uitoolkit/system/gdi32.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/system-types.lisp
trunk/src/uitoolkit/widgets/event.lisp
Log:
overhauled graphics-context to make use of ExtCreatePen for all pen attribute settings; updated wm-paint process-message accordingly
Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp Fri Mar 24 23:23:24 2006
@@ -52,18 +52,25 @@
(drawing-exit-fn self nil nil 0))
(defmethod gfw:event-paint ((self drawing-win-events) window time gc rect)
- (declare (ignore window time))
+ (declare (ignore time rect))
(setf (gfg:background-color gc) gfg:*color-white*)
- (gfg:draw-filled-rectangle gc rect)
+ (setf (gfg:foreground-color gc) gfg:*color-white*)
+ (gfg:draw-filled-rectangle gc
+ (make-instance 'gfs:rectangle :location (gfs:make-point)
+ :size (gfw:client-size window)))
(let ((func (draw-func-of self)))
(unless (null func)
(funcall func gc))))
(defun draw-rects (gc)
- (setf (gfg:background-color gc) gfg:*color-blue*)
- (gfg:draw-filled-rectangle gc
- (make-instance 'gfs:rectangle :location (gfs:make-point :x 10 :y 10)
- :size (gfs:make-size :width 100 :height 75))))
+ (let ((pnt (gfs:make-point :x 10 :y 10))
+ (size (gfs:make-size :width 80 :height 65)))
+ (setf (gfg:foreground-color gc) gfg:*color-blue*)
+ (setf (gfg:background-color gc) gfg:*color-green*)
+ (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))
+ (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
+ (setf (gfg:foreground-color gc) gfg:*color-green*)
+ (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))))
(defun select-rects (disp item time rect)
(declare (ignore disp item time rect))
@@ -80,6 +87,7 @@
(setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher*
:style '(:style-workspace)))
(setf (gfw:menu-bar *drawing-win*) menubar)
+ (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310))
(gfw:show *drawing-win* t)))
(defun run-drawing-tester ()
Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp (original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp Fri Mar 24 23:23:24 2006
@@ -47,6 +47,7 @@
(setf rect (make-instance 'gfs:rectangle :location (gfs:make-point)
:size (gfw:client-size window)))
(setf (gfg:background-color gc) gfg:*color-white*)
+ (setf (gfg:foreground-color gc) gfg:*color-white*)
(gfg:draw-filled-rectangle gc rect)
(setf (gfg:background-color gc) gfg:*color-red*)
(setf (gfg:foreground-color gc) gfg:*color-green*)
Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp (original)
+++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 24 23:23:24 2006
@@ -54,6 +54,7 @@
(setf rect (make-instance 'gfs:rectangle :location (gfs:make-point)
:size (gfw:client-size window)))
(setf (gfg:background-color gc) gfg:*color-white*)
+ (setf (gfg:foreground-color gc) gfg:*color-white*)
(gfg:draw-filled-rectangle gc rect))
(defclass test-mini-events (test-win-events) ())
Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Fri Mar 24 23:23:24 2006
@@ -82,7 +82,31 @@
(defclass font (gfs:native-object) ()
(:documentation "This class encapsulates a realized native font."))
-(defclass graphics-context (gfs:native-object) ()
+(defclass graphics-context (gfs:native-object)
+ ((owns-dc
+ :accessor owns-dc
+ :initform nil)
+ (logbrush-style
+ :accessor logbrush-style-of
+ :initform gfs::+bs-solid+)
+ (logbrush-color
+ :accessor logbrush-color-of
+ :initform 0) ; initialize-instance sets this to black
+ (logbrush-hatch
+ :accessor logbrush-hatch-of
+ :initform gfs::+hs-bdiagonal+) ; doesn't matter because +bs-solid+ is set
+ (pen-style
+ :accessor pen-style-of
+ :initform (logior gfs::+ps-cosmetic+ gfs::+ps-solid+)) ; fast by default
+ (pen-width
+ :accessor pen-width-of
+ :initform 1)
+ (pen-handle
+ :accessor pen-handle-of
+ :initform (cffi:null-pointer))
+ (orig-pen-handle
+ :accessor orig-pen-handle-of
+ :initform (cffi:null-pointer)))
(:documentation "This class represents the context associated with drawing primitives."))
(defclass image (gfs:native-object)
Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-context.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-context.lisp Fri Mar 24 23:23:24 2006
@@ -37,33 +37,85 @@
;;; helper functions
;;;
+(defun update-pen-for-gc (gc)
+ (cffi:with-foreign-object (lb-ptr 'gfs::logbrush)
+ (cffi:with-foreign-slots ((gfs::style gfs::color gfs::hatch) lb-ptr gfs::logbrush)
+ (setf gfs::style (logbrush-style-of gc))
+ (setf gfs::color (logbrush-color-of gc))
+ (setf gfs::hatch (logbrush-hatch-of gc))
+ (let ((old-hpen (cffi:null-pointer))
+ (new-hpen (gfs::ext-create-pen (pen-style-of gc)
+ (pen-width-of gc)
+ lb-ptr 0
+ (cffi:null-pointer))))
+ (if (gfs:null-handle-p new-hpen)
+ (error 'gfs:win32-error :detail "ext-create-pen failed"))
+ (setf (pen-handle-of gc) new-hpen)
+ (setf old-hpen (gfs::select-object (gfs:handle gc) new-hpen))
+ (if (gfs:null-handle-p (orig-pen-handle-of gc))
+ (setf (orig-pen-handle-of gc) old-hpen)
+ (unless (gfs:null-handle-p old-hpen)
+ (gfs::delete-object old-hpen)))))))
+
;;;
;;; methods
;;;
-(defmethod gfs:dispose ((gc graphics-context))
- (gfs::delete-dc (gfs:handle gc))
- (setf (slot-value gc 'gfs:handle) nil))
-
-(defmethod background-color ((gc graphics-context))
- (if (gfs:disposed-p gc)
+(defmethod background-color ((self graphics-context))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (gfs::get-bk-color (gfs:handle gc)))
+ (gfs::get-bk-color (gfs:handle self)))
-(defmethod (setf background-color) ((clr color) (gc graphics-context))
- (if (gfs:disposed-p gc)
+(defmethod (setf background-color) ((clr color) (self graphics-context))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (let ((hdc (gfs:handle gc))
+ (let ((hdc (gfs:handle self))
(hbrush (gfs::get-stock-object gfs::+dc-brush+))
(rgb (color-as-rgb clr)))
(gfs::select-object hdc hbrush)
(gfs::set-dc-brush-color hdc rgb)
(gfs::set-bk-color hdc rgb)))
-(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfs:rectangle))
- (if (gfs:disposed-p gc)
+(defmethod gfs:dispose ((self graphics-context))
+ (unless (gfs:null-handle-p (orig-pen-handle-of self))
+ (gfs::select-object (gfs:handle self) (orig-pen-handle-of self)))
+ (setf (orig-pen-handle-of self) nil)
+ (gfs::delete-object (pen-handle-of self))
+ (setf (pen-handle-of self) nil)
+ (if (owns-dc self)
+ (gfs::delete-dc (gfs:handle self)))
+ (setf (slot-value self 'gfs:handle) nil))
+
+(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (let ((hdc (gfs:handle gc))
+ (let ((hdc (gfs:handle self))
+ (pnt (gfs:location rect))
+ (size (gfs:size rect)))
+ (gfs::rectangle hdc
+ (gfs:point-x pnt)
+ (gfs:point-y pnt)
+ (+ (gfs:point-x pnt) (gfs:size-width size))
+ (+ (gfs:point-y pnt) (gfs:size-height size)))))
+
+(defmethod draw-rectangle ((self graphics-context) (rect gfs:rectangle))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (let* ((hdc (gfs:handle self))
+ (tmp-hbr (gfs::get-stock-object gfs::+null-brush+))
+ (orig-hbr (gfs::select-object hdc tmp-hbr)))
+ (unwind-protect
+ (draw-filled-rectangle self rect)
+ (gfs::select-object hdc orig-hbr))))
+
+;;; FIXME: consider preserving this version as a "fast path"
+;;; rectangle filler.
+;;;
+#|
+(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (let ((hdc (gfs:handle self))
(pnt (gfs:location rect))
(size (gfs:size rect)))
(cffi:with-foreign-object (rect-ptr 'gfs::rect)
@@ -81,16 +133,17 @@
""
0
(cffi:null-pointer))))))
+|#
;;;
;;; TODO: support addressing elements within bitmap as if it were an array
;;;
-(defmethod draw-image ((gc graphics-context) (im image) (pnt gfs:point))
- (if (gfs:disposed-p gc)
+(defmethod draw-image ((self graphics-context) (im image) (pnt gfs:point))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error))
(if (gfs:disposed-p im)
(error 'gfs:disposed-error))
- (let ((gc-dc (gfs:handle gc))
+ (let ((gc-dc (gfs:handle self))
(himage (gfs:handle im))
(memdc (gfs::create-compatible-dc (cffi:null-pointer))))
(cffi:with-foreign-object (bmp-ptr 'gfs::bitmap)
@@ -137,21 +190,21 @@
0 0 gfs::+blt-srccopy+)))))
(gfs::delete-dc memdc)))
-(defmethod draw-text ((gc graphics-context) text (pnt gfs:point))
- (if (gfs:disposed-p gc)
+(defmethod draw-text ((self graphics-context) text (pnt gfs:point))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error))
(cffi:with-foreign-object (rect-ptr 'gfs::rect)
(cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom)
rect-ptr gfs::rect)
(setf gfs::left (gfs:point-x pnt))
(setf gfs::top (gfs:point-y pnt))
- (gfs::draw-text (gfs:handle gc)
+ (gfs::draw-text (gfs:handle self)
text
-1
rect-ptr
(logior gfs::+dt-calcrect+ gfs::+dt-singleline+)
(cffi:null-pointer))
- (gfs::draw-text (gfs:handle gc)
+ (gfs::draw-text (gfs:handle self)
text
(length text)
rect-ptr
@@ -161,17 +214,22 @@
gfs::+dt-vcenter+)
(cffi:null-pointer)))))
-(defmethod foreground-color ((gc graphics-context))
- (if (gfs:disposed-p gc)
+(defmethod foreground-color ((self graphics-context))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (gfs::get-text-color (gfs:handle gc)))
+ (gfs::get-text-color (gfs:handle self)))
-(defmethod (setf foreground-color) ((clr color) (gc graphics-context))
- (if (gfs:disposed-p gc)
+(defmethod (setf foreground-color) ((clr color) (self graphics-context))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (let ((hdc (gfs:handle gc))
- (hpen (gfs::get-stock-object gfs::+dc-pen+))
- (rgb (color-as-rgb clr)))
- (gfs::select-object hdc hpen)
- (gfs::set-dc-pen-color hdc rgb)
- (gfs::set-text-color hdc rgb)))
+ (let ((rgb (color-as-rgb clr)))
+ (gfs::set-text-color (gfs:handle self) rgb)
+ (setf (logbrush-color-of self) rgb)
+ (update-pen-for-gc self)))
+
+(defmethod initialize-instance :after ((self graphics-context) &key)
+ (when (null (gfs:handle self))
+ (setf (owns-dc self) t)
+ (setf (slot-value self 'gfs:handle) (gfs::create-compatible-dc (cffi:null-pointer))))
+ (setf (logbrush-color-of self) (color-as-rgb (make-color :red 0 :green 0 :blue 0)))
+ (update-pen-for-gc self))
Modified: trunk/src/uitoolkit/system/gdi32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/gdi32.lisp (original)
+++ trunk/src/uitoolkit/system/gdi32.lisp Fri Mar 24 23:23:24 2006
@@ -99,6 +99,13 @@
(offset DWORD))
(defcfun
+ ("CreatePen" create-pen)
+ HANDLE
+ (style INT)
+ (width INT)
+ (color COLORREF))
+
+(defcfun
("DeleteDC" delete-dc)
BOOL
(hdc HANDLE))
@@ -119,6 +126,15 @@
(params LPTR))
(defcfun
+ ("ExtCreatePen" ext-create-pen)
+ HANDLE
+ (style DWORD)
+ (width DWORD)
+ (logbrush LPTR)
+ (count DWORD)
+ (stylearray LPTR))
+
+(defcfun
("ExtTextOutA" ext-text-out)
BOOL
(hdc HANDLE)
@@ -203,6 +219,15 @@
(rop DWORD))
(defcfun
+ ("Rectangle" rectangle)
+ BOOL
+ (hdc HANDLE)
+ (x1 INT)
+ (y1 INT)
+ (x2 INT)
+ (y2 INT))
+
+(defcfun
("SelectObject" select-object)
HANDLE
(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 Fri Mar 24 23:23:24 2006
@@ -61,6 +61,18 @@
(defconstant +blt-captureblt+ #x40000000)
(defconstant +blt-nomirrorbitmap+ #x80000000)
+(defconstant +bs-solid+ 0)
+(defconstant +bs-null+ 1)
+(defconstant +bs-hollow+ 1)
+(defconstant +bs-hatched+ 2)
+(defconstant +bs-pattern+ 3)
+(defconstant +bs-indexed+ 4)
+(defconstant +bs-dibpattern+ 5)
+(defconstant +bs-dibpatternpt+ 6)
+(defconstant +bs-pattern8x8+ 7)
+(defconstant +bs-dibpattern8x8+ 8)
+(defconstant +bs-monopattern+ 9)
+
(defconstant +bs-pushbutton+ #x00000000)
(defconstant +bs-defpushbutton+ #x00000001)
(defconstant +bs-checkbox+ #x00000002)
@@ -208,6 +220,13 @@
(defconstant +gwl-exstyle+ -20)
(defconstant +gwl-userdata+ -21)
+(defconstant +hs-horizontal+ 0)
+(defconstant +hs-vertical+ 1)
+(defconstant +hs-fdiagonal+ 2)
+(defconstant +hs-bdiagonal+ 3)
+(defconstant +hs-cross+ 4)
+(defconstant +hs-diagcross+ 5)
+
(defconstant +image-bitmap+ 0)
(defconstant +image-icon+ 1)
(defconstant +image-cursor+ 2)
@@ -384,6 +403,28 @@
(defconstant +pm-qs-paint+ (ash +qs-paint+ 16))
(defconstant +pm-qs-sendmessage+ (ash +qs-sendmessage+ 16))
+(defconstant +ps-solid+ 0)
+(defconstant +ps-dash+ 1)
+(defconstant +ps-dot+ 2)
+(defconstant +ps-dashdot+ 3)
+(defconstant +ps-dashdotdot+ 4)
+(defconstant +ps-null+ 5)
+(defconstant +ps-insideframe+ 6)
+(defconstant +ps-userstyle+ 7)
+(defconstant +ps-alternate+ 8)
+(defconstant +ps-style_mask+ #x0000000f)
+(defconstant +ps-endcap_round+ #x00000000)
+(defconstant +ps-endcap_square+ #x00000100)
+(defconstant +ps-endcap_flat+ #x00000200)
+(defconstant +ps-endcap_mask+ #x00000f00)
+(defconstant +ps-join_round+ #x00000000)
+(defconstant +ps-join_bevel+ #x00001000)
+(defconstant +ps-join_miter+ #x00002000)
+(defconstant +ps-join_mask+ #x0000f000)
+(defconstant +ps-cosmetic+ #x00000000)
+(defconstant +ps-geometric+ #x00010000)
+(defconstant +ps-type_mask+ #x000f0000)
+
(defconstant +size-restored+ 0)
(defconstant +size-minimized+ 1)
(defconstant +size-maximized+ 2)
Modified: trunk/src/uitoolkit/system/system-types.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-types.lisp (original)
+++ trunk/src/uitoolkit/system/system-types.lisp Fri Mar 24 23:23:24 2006
@@ -114,6 +114,11 @@
(biclrused DWORD)
(biclrimp DWORD))
+(defcstruct logbrush
+ (style UINT)
+ (color COLORREF)
+ (hatch LONG))
+
(defcstruct menuinfo
(cbsize DWORD)
(mask DWORD)
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Fri Mar 24 23:23:24 2006
@@ -285,9 +285,8 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam)
(declare (ignore wparam lparam))
(let* ((tc (thread-context))
- (w (get-widget tc hwnd))
- (gc (make-instance 'gfg:graphics-context)))
- (if w
+ (widget (get-widget tc hwnd)))
+ (if widget
(let ((rct (make-instance 'gfs:rectangle)))
(cffi:with-foreign-object (ps-ptr 'gfs::paintstruct)
(cffi:with-foreign-slots ((gfs::rcpaint-x
@@ -295,14 +294,15 @@
gfs::rcpaint-width
gfs::rcpaint-height)
ps-ptr gfs::paintstruct)
- (setf (slot-value gc 'gfs:handle) (gfs::begin-paint hwnd ps-ptr))
(setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x
- :y gfs::rcpaint-y))
+ :y gfs::rcpaint-y))
(setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width
- :height gfs::rcpaint-height))
- (unwind-protect
- (event-paint (dispatcher w) w (event-time tc) gc rct)
- (gfs::end-paint hwnd ps-ptr)))))
+ :height gfs::rcpaint-height))
+ (let* ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr))))
+ (unwind-protect
+ (event-paint (dispatcher widget) widget (event-time tc) gc rct)
+ (gfs:dispose gc)
+ (gfs::end-paint hwnd ps-ptr))))))
(error 'gfs:toolkit-error :detail "no object for hwnd")))
0)
More information about the Graphic-forms-cvs
mailing list