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)