Author: junrue Date: Sat Mar 17 12:13:55 2007 New Revision: 437
Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-classes.lisp branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-context.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp Log: graphics-context clear now works for widgets and images, added surface-size slot
Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Sat Mar 17 12:13:55 2007 @@ -1,4 +1,8 @@
+. Latest CFFI is required to take advantage of newly-added support for the + stdcall calling convention (FIXME: change checked in this past Feb., need + to narrow down which snapshot actually has it). + . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner.
Modified: branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-classes.lisp Sat Mar 17 12:13:55 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; graphics-classes.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -113,6 +113,10 @@ (widget-handle :accessor widget-handle-of :initform nil) + (surface-size + :accessor surface-size-of + :initarg :surface-size + :initform nil) (logbrush-style :accessor logbrush-style-of :initform gfs::+bs-solid+)
Modified: branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-context.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-context.lisp Sat Mar 17 12:13:55 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; graphics-context.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -224,22 +224,16 @@ (error 'gfs:disposed-error)) (setf (background-color self) color (foreground-color self) color) - (let* ((hdc (gfs:handle self)) - (hwnd (gfs::window-from-dc hdc))) - (if (gfs:null-handle-p hwnd) - (warn 'gfs:toolkit-warning :detail "could not retrieve window handle for DC") - (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) - (cffi:with-foreign-slots ((gfs::cbsize gfs::clientright gfs::clientbottom) - wi-ptr gfs::windowinfo) - (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (if (zerop (gfs::get-window-info hwnd wi-ptr)) - (warn 'gfs:win32-warning :detail "get-window-info failed") + (let ((hdc (gfs:handle self)) + (size (surface-size-of self))) + (if size (gfs::with-rect (rect-ptr) (setf gfs::top 0 gfs::left 0 - gfs::bottom gfs::clientbottom - gfs::right gfs::clientright) - (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer))))))))) + gfs::right (gfs:size-width size) + gfs::bottom (gfs:size-height size)) + (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer))) + (warn 'gfs:toolkit-warning :detail "null surface size"))))
(defmethod gfs:dispose ((self graphics-context)) (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+)) @@ -250,6 +244,7 @@ (if (null (widget-handle-of self)) (funcall fn (gfs:handle self)) (funcall fn (widget-handle-of self) (gfs:handle self))))) + (setf (surface-size-of self) nil) (setf (widget-handle-of self) nil) (setf (slot-value self 'gfs:handle) (cffi:null-pointer)))
@@ -483,9 +478,11 @@ (progn (setf hdc (gfs::get-dc (gfs:handle widget))) (setf (dc-destructor-of self) #'gfs::release-dc) - (setf (widget-handle-of self) (gfs:handle widget)))) + (setf (widget-handle-of self) (gfs:handle widget)) + (setf (surface-size-of self) (gfw:client-size widget)))) (setf (slot-value self 'gfs:handle) hdc) (unless (null image) + (setf (surface-size-of self) (gfg:size image)) (gfs::select-object hdc (gfs:handle image))))) ;; ensure world-to-device transformation conformance (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+)
Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp Sat Mar 17 12:13:55 2007 @@ -410,6 +410,7 @@ (pnt (gfs:make-point :x gfs::rcpaint-x :y gfs::rcpaint-y)) (size (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) (disp (dispatcher widget))) + (setf (gfg::surface-size-of gc) (client-size widget)) (unwind-protect (let ((parent (gfw:parent widget))) (when (and parent (typep (dispatcher parent) 'scrolling-helper))