- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

[graphic-forms-cvs] r436 - in trunk: . src/uitoolkit/graphics src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Mar '07

17 Mar '07

Author: junrue Date: Sat Mar 17 12:12:49 2007 New Revision: 436 Modified: trunk/NEWS.txt trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/widgets/event.lisp Log: graphics-context clear now works for widgets and images, added surface-size slot Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Mar 17 12:12:49 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: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sat Mar 17 12:12:49 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: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sat Mar 17 12:12:49 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") - (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))))))))) + (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::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: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Mar 17 12:12:49 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))

1 0

[graphic-forms-cvs] r435 - trunk/src/uitoolkit/system
by junrue＠common-lisp.net 17 Mar '07

17 Mar '07

Author: junrue Date: Sat Mar 17 11:24:50 2007 New Revision: 435 Modified: trunk/src/uitoolkit/system/system-types.lisp Log: got rid of BYTE alias for :unsigned-char to avoid CFFI warning Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Sat Mar 17 11:24:50 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; system-types.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 @@ -48,7 +48,6 @@ (defctype ATOM :unsigned-short) ; shadowed in gfs: package (defctype BOOL :int) (defctype BOOLEAN :char) ; shadowed in gfs: package -(defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) (defctype DWORD :unsigned-long) (defctype HANDLE :pointer) @@ -121,18 +120,18 @@ (bcbitcount WORD)) (defcstruct bitmapinfo - (bisize DWORD) - (biwidth LONG) - (biheight LONG) - (biplanes WORD) - (bibitcount WORD) + (bisize DWORD) + (biwidth LONG) + (biheight LONG) + (biplanes WORD) + (bibitcount WORD) (bicompression DWORD) - (bisizeimage DWORD) - (bixpels LONG) - (biypels LONG) - (biclrused DWORD) - (biclrimp DWORD) - (bmicolors BYTE :count 1024)) ; allocate space for max palette (256 RGBQUADs) + (bisizeimage DWORD) + (bixpels LONG) + (biypels LONG) + (biclrused DWORD) + (biclrimp DWORD) + (bmicolors :unsigned-char :count 1024)) ; allocate space for max palette (256 RGBQUADs) (defctype bitmapinfo-pointer :pointer) (defctype bitmap-pixels-pointer :pointer) @@ -240,20 +239,20 @@ (hatch LONG)) (defcstruct logfont - (lfheight LONG) - (lfwidth LONG) - (lfescapement LONG) - (lforientation LONG) - (lfweight LONG) - (lfitalic BYTE) - (lfunderline BYTE) - (lfstrikeout BYTE) - (lfcharset BYTE) - (lfoutprec BYTE) - (lfclipprec BYTE) - (lfquality BYTE) - (lfpitchandfamily BYTE) - (lffacename TCHAR :count 32)) ; LF_FACESIZE is 32 + (lfheight LONG) + (lfwidth LONG) + (lfescapement LONG) + (lforientation LONG) + (lfweight LONG) + (lfitalic :unsigned-char) + (lfunderline :unsigned-char) + (lfstrikeout :unsigned-char) + (lfcharset :unsigned-char) + (lfoutprec :unsigned-char) + (lfclipprec :unsigned-char) + (lfquality :unsigned-char) + (lfpitchandfamily :unsigned-char) + (lffacename TCHAR :count 32)) ; LF_FACESIZE is 32 (defcstruct menuinfo (cbsize DWORD) @@ -300,15 +299,15 @@ (pnt point)) (defcstruct paintstruct - (hdc HANDLE) - (erase BOOL) - (rcpaint-x LONG) - (rcpaint-y LONG) - (rcpaint-width LONG) + (hdc HANDLE) + (erase BOOL) + (rcpaint-x LONG) + (rcpaint-y LONG) + (rcpaint-width LONG) (rcpaint-height LONG) - (restore BOOL) - (incupdate BOOL) - (reserved BYTE :count 32)) + (restore BOOL) + (incupdate BOOL) + (reserved :unsigned-char :count 32)) (defctype rect-pointer :pointer) @@ -366,10 +365,10 @@ (ofnexflags DWORD)) (defcstruct rgbquad - (rgbblue BYTE) - (rgbgreen BYTE) - (rgbred BYTE) - (rgbreserved BYTE)) + (rgbblue :unsigned-char) + (rgbgreen :unsigned-char) + (rgbred :unsigned-char) + (rgbreserved :unsigned-char)) (defcstruct scrollinfo (cbsize UINT) @@ -385,26 +384,26 @@ (cy LONG)) (defcstruct textmetrics - (tmheight LONG) - (tmascent LONG) - (tmdescent LONG) + (tmheight LONG) + (tmascent LONG) + (tmdescent LONG) (tminternalleading LONG) (tmexternalleading LONG) - (tmavgcharwidth LONG) - (tmmaxcharwidth LONG) - (tmweight LONG) - (tmoverhang LONG) - (tmdigaspectx LONG) - (tmdigaspecty LONG) - (tmfirstchar :char) - (tmlastchar :char) - (tmdefaultchar :char) - (tmbreakchar :char) - (tmitalic BYTE) - (tmunderlined BYTE) - (tmstruckout BYTE) - (tmpitchfam BYTE) - (tmcharset BYTE)) + (tmavgcharwidth LONG) + (tmmaxcharwidth LONG) + (tmweight LONG) + (tmoverhang LONG) + (tmdigaspectx LONG) + (tmdigaspecty LONG) + (tmfirstchar :char) + (tmlastchar :char) + (tmdefaultchar :char) + (tmbreakchar :char) + (tmitalic :unsigned-char) + (tmunderlined :unsigned-char) + (tmstruckout :unsigned-char) + (tmpitchfam :unsigned-char) + (tmcharset :unsigned-char)) (defcstruct windowinfo (cbsize DWORD)

1 0

[graphic-forms-cvs] r434 - branches/graphic-forms-newtypes/src/uitoolkit/system
by junrue＠common-lisp.net 17 Mar '07

17 Mar '07

Author: junrue Date: Sat Mar 17 11:24:02 2007 New Revision: 434 Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp Log: got rid of BYTE alias for :unsigned-char to avoid CFFI warning Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp Sat Mar 17 11:24:02 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; system-types.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 @@ -48,7 +48,6 @@ (defctype ATOM :unsigned-short) ; shadowed in gfs: package (defctype BOOL :int) (defctype BOOLEAN :char) ; shadowed in gfs: package -(defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) (defctype DWORD :unsigned-long) (defctype HANDLE :pointer) @@ -121,18 +120,18 @@ (bcbitcount WORD)) (defcstruct bitmapinfo - (bisize DWORD) - (biwidth LONG) - (biheight LONG) - (biplanes WORD) - (bibitcount WORD) + (bisize DWORD) + (biwidth LONG) + (biheight LONG) + (biplanes WORD) + (bibitcount WORD) (bicompression DWORD) - (bisizeimage DWORD) - (bixpels LONG) - (biypels LONG) - (biclrused DWORD) - (biclrimp DWORD) - (bmicolors BYTE :count 1024)) ; allocate space for max palette (256 RGBQUADs) + (bisizeimage DWORD) + (bixpels LONG) + (biypels LONG) + (biclrused DWORD) + (biclrimp DWORD) + (bmicolors :unsigned-char :count 1024)) ; allocate space for max palette (256 RGBQUADs) (define-foreign-type bitmapinfo-pointer-type () () (:actual-type :pointer) @@ -249,19 +248,19 @@ (hatch LONG)) (defcstruct logfont - (lfheight LONG) - (lfwidth LONG) - (lfescapement LONG) - (lforientation LONG) - (lfweight LONG) - (lfitalic BYTE) - (lfunderline BYTE) - (lfstrikeout BYTE) - (lfcharset BYTE) - (lfoutprec BYTE) - (lfclipprec BYTE) - (lfquality BYTE) - (lfpitchandfamily BYTE) + (lfheight LONG) + (lfwidth LONG) + (lfescapement LONG) + (lforientation LONG) + (lfweight LONG) + (lfitalic :unsigned-char) + (lfunderline :unsigned-char) + (lfstrikeout :unsigned-char) + (lfcharset :unsigned-char) + (lfoutprec :unsigned-char) + (lfclipprec :unsigned-char) + (lfquality :unsigned-char) + (lfpitchandfamily :unsigned-char) (lffacename TCHAR :count 32)) ; LF_FACESIZE is 32 (defcstruct menuinfo @@ -311,15 +310,15 @@ (pnt point)) (defcstruct paintstruct - (hdc HANDLE) - (erase BOOL) - (rcpaint-x LONG) - (rcpaint-y LONG) - (rcpaint-width LONG) + (hdc HANDLE) + (erase BOOL) + (rcpaint-x LONG) + (rcpaint-y LONG) + (rcpaint-width LONG) (rcpaint-height LONG) - (restore BOOL) - (incupdate BOOL) - (reserved BYTE :count 32)) + (restore BOOL) + (incupdate BOOL) + (reserved :unsigned-char :count 32)) (define-foreign-type rect-pointer-type () () (:actual-type :pointer) @@ -379,10 +378,10 @@ (ofnexflags DWORD)) (defcstruct rgbquad - (rgbblue BYTE) - (rgbgreen BYTE) - (rgbred BYTE) - (rgbreserved BYTE)) + (rgbblue :unsigned-char) + (rgbgreen :unsigned-char) + (rgbred :unsigned-char) + (rgbreserved :unsigned-char)) (defcstruct scrollinfo (cbsize UINT) @@ -398,26 +397,26 @@ (cy LONG)) (defcstruct textmetrics - (tmheight LONG) - (tmascent LONG) - (tmdescent LONG) + (tmheight LONG) + (tmascent LONG) + (tmdescent LONG) (tminternalleading LONG) (tmexternalleading LONG) - (tmavgcharwidth LONG) - (tmmaxcharwidth LONG) - (tmweight LONG) - (tmoverhang LONG) - (tmdigaspectx LONG) - (tmdigaspecty LONG) - (tmfirstchar :char) - (tmlastchar :char) - (tmdefaultchar :char) - (tmbreakchar :char) - (tmitalic BYTE) - (tmunderlined BYTE) - (tmstruckout BYTE) - (tmpitchfam BYTE) - (tmcharset BYTE)) + (tmavgcharwidth LONG) + (tmmaxcharwidth LONG) + (tmweight LONG) + (tmoverhang LONG) + (tmdigaspectx LONG) + (tmdigaspecty LONG) + (tmfirstchar :char) + (tmlastchar :char) + (tmdefaultchar :char) + (tmbreakchar :char) + (tmitalic :unsigned-char) + (tmunderlined :unsigned-char) + (tmstruckout :unsigned-char) + (tmpitchfam :unsigned-char) + (tmcharset :unsigned-char)) (defcstruct windowinfo (cbsize DWORD)

1 0

[graphic-forms-cvs] r433 - in branches/graphic-forms-newtypes/src/uitoolkit: graphics/plugins/default graphics/plugins/imagemagick system widgets
by junrue＠common-lisp.net 16 Mar '07

16 Mar '07

Author: junrue Date: Thu Mar 15 22:50:49 2007 New Revision: 433 Modified: branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp branches/graphic-forms-newtypes/src/uitoolkit/system/datastructs.lisp branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp Log: initial fixes for cffi-newtypes Modified: branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Thu Mar 15 22:50:49 2007 @@ -149,7 +149,7 @@ size) (defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) - (name (eql 'gfs::bitmapinfo-pointer))) + (type gfs::bitmapinfo-pointer-type)) (let ((bi-ptr (gfg::make-initial-bitmapinfo lisp-obj)) (colors (gfg:color-table (palette-of lisp-obj)))) (let ((ptr (cffi:foreign-slot-pointer bi-ptr 'gfs::bitmapinfo 'gfs::bmicolors))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Thu Mar 15 22:50:49 2007 @@ -122,7 +122,7 @@ size) (defmethod cffi:translate-to-foreign ((lisp-obj magick-data-plugin) - (name (eql 'gfs::bitmapinfo-pointer))) + (type gfs::bitmapinfo-pointer-type)) ;; FIXME: assume true-color for now ;; (gfg::make-initial-bitmapinfo lisp-obj)) Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/datastructs.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/datastructs.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/datastructs.lisp Thu Mar 15 22:50:49 2007 @@ -68,21 +68,21 @@ (and (= (size-width size1) (size-width size2)) (= (size-height size1) (size-height size2)))) -(defmethod cffi:free-translated-object (ptr (name (eql 'point-pointer)) param) +(defmethod cffi:free-translated-object (ptr (type point-pointer-type) param) (declare (ignore param)) (cffi:foreign-free ptr)) -(defmethod cffi:free-translated-object (ptr (name (eql 'rect-pointer)) param) +(defmethod cffi:free-translated-object (ptr (type rect-pointer-type) param) (declare (ignore param)) (cffi:foreign-free ptr)) -(defmethod cffi:translate-from-foreign (ptr (name (eql 'point-pointer))) +(defmethod cffi:translate-from-foreign (ptr (type point-pointer-type)) (if (cffi:null-pointer-p ptr) (make-point) (cffi:with-foreign-slots ((x y) ptr point) (make-point :x x :y y)))) -(defmethod cffi:translate-from-foreign (ptr (name (eql 'rect-pointer))) +(defmethod cffi:translate-from-foreign (ptr (type rect-pointer-type)) (if (cffi:null-pointer-p ptr) (make-rectangle) (cffi:with-foreign-slots ((left top right bottom) ptr rect) @@ -90,14 +90,14 @@ (size (make-size :width (- right left) :height (- bottom top)))) (make-rectangle :location pnt :size size))))) -(defmethod cffi:translate-to-foreign ((lisp-pnt point) (name (eql 'point-pointer))) +(defmethod cffi:translate-to-foreign ((lisp-pnt point) (type point-pointer-type)) (let ((ptr (cffi:foreign-alloc 'point))) (cffi:with-foreign-slots ((x y) ptr point) (setf x (point-x lisp-pnt) y (point-y lisp-pnt))) ptr)) -(defmethod cffi:translate-to-foreign ((lisp-rect rectangle) (name (eql 'rect-pointer))) +(defmethod cffi:translate-to-foreign ((lisp-rect rectangle) (type rect-pointer-type)) (let ((ptr (cffi:foreign-alloc 'rect)) (pnt (location lisp-rect)) (size (size lisp-rect))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp Thu Mar 15 22:50:49 2007 @@ -134,8 +134,13 @@ (biclrimp DWORD) (bmicolors BYTE :count 1024)) ; allocate space for max palette (256 RGBQUADs) -(defctype bitmapinfo-pointer :pointer) -(defctype bitmap-pixels-pointer :pointer) +(define-foreign-type bitmapinfo-pointer-type () () + (:actual-type :pointer) + (:simple-parser bitmapinfo-pointer)) + +(define-foreign-type bitmap-pixels-pointer-type () () + (:actual-type :pointer) + (:simple-parser bitmap-pixels-pointer)) (defcstruct bitmapinfoheader (bisize DWORD) @@ -185,7 +190,9 @@ (buildnum DWORD) (platform DWORD)) -(defctype dllversioninfo-pointer :pointer) +(define-foreign-type dllversioninfo-pointer-type () () + (:actual-type :pointer) + (:simple-parser dllversioninfo-pointer)) (defcstruct drawitemstruct (ctltype UINT) @@ -228,7 +235,9 @@ (hmask HANDLE) (hcolor HANDLE)) -(defctype iconinfo-pointer :pointer) +(define-foreign-type iconinfo-pointer-type () () + (:actual-type :pointer) + (:simple-parser iconinfo-pointer)) (defcstruct initcommoncontrolsex (size DWORD) @@ -278,7 +287,9 @@ (cch UINT) (hbmpitem HANDLE)) -(defctype point-pointer :pointer) +(define-foreign-type point-pointer-type () () + (:actual-type :pointer) + (:simple-parser point-pointer)) (defcstruct point (x LONG) @@ -310,7 +321,9 @@ (incupdate BOOL) (reserved BYTE :count 32)) -(defctype rect-pointer :pointer) +(define-foreign-type rect-pointer-type () () + (:actual-type :pointer) + (:simple-parser rect-pointer)) (defcstruct rect (left LONG) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp Thu Mar 15 22:50:49 2007 @@ -87,7 +87,7 @@ (error 'gfs:win32-warning :detail "get-monitor-info failed")) (push (= (logand gfs::flags gfs::+monitorinfoof-primary+) gfs::+monitorinfoof-primary+) info) (let ((str-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::device))) - (push (cffi:foreign-string-to-lisp str-ptr (1- gfs::+cchdevicename+)) info)) + (push (cffi:foreign-string-to-lisp str-ptr :count (1- gfs::+cchdevicename+)) info)) (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::monitor))) (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) rect-ptr gfs::rect)

1 0

[graphic-forms-cvs] r432 - branches/graphic-forms-newtypes
by junrue＠common-lisp.net 16 Mar '07

16 Mar '07

Author: junrue Date: Thu Mar 15 22:02:57 2007 New Revision: 432 Added: branches/graphic-forms-newtypes/ - copied from r431, trunk/ Log: creating a branch for development with cffi-newtypes

1 0

[graphic-forms-cvs] r431 - trunk/src/uitoolkit/system
by junrue＠common-lisp.net 11 Mar '07

11 Mar '07

Author: junrue Date: Sun Mar 11 12:45:20 2007 New Revision: 431 Modified: trunk/src/uitoolkit/system/metrics.lisp Log: fix for CFFI API change: foreign-funcall cannot be used on pointers any more Modified: trunk/src/uitoolkit/system/metrics.lisp ============================================================================== --- trunk/src/uitoolkit/system/metrics.lisp (original) +++ trunk/src/uitoolkit/system/metrics.lisp Sun Mar 11 12:45:20 2007 @@ -44,7 +44,7 @@ (cffi:with-foreign-slots ((gfs::size gfs::vermajor gfs::verminor gfs::buildnum) info-ptr gfs::dllversioninfo) (setf gfs::size (cffi:foreign-type-size 'gfs::dllversioninfo)) - (cffi:foreign-funcall func-ptr gfs::dllversioninfo info-ptr gfs::hresult) + (cffi:foreign-funcall-pointer func-ptr (:cconv :stdcall) :pointer info-ptr gfs::hresult) (setf version (list gfs::vermajor gfs::verminor gfs::buildnum)))))) (gfs::free-library hmodule))) version))

1 0

[graphic-forms-cvs] r430 - in trunk: docs/manual src src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 31 Jan '07

31 Jan '07

Author: junrue Date: Wed Jan 31 09:17:41 2007 New Revision: 430 Modified: trunk/docs/manual/gfg-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/scroll-text-panel.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: Modified: trunk/docs/manual/gfg-symbols.xml ============================================================================== --- trunk/docs/manual/gfg-symbols.xml (original) +++ trunk/docs/manual/gfg-symbols.xml Wed Jan 31 09:17:41 2007 @@ -794,6 +794,33 @@  + <generic-function name="clear"> + <syntax> + <arguments> + <argument name="graphics-context"> + <description> + A <reftopic>gfg:graphics-context</reftopic> on which to draw. + </description> + </argument> + <argument name="color"> + <description> + The <reftopic>gfg:color</reftopic> with which to fill the + window associated with <arg0/>. + </description> + </argument> + </arguments> + <return> + <emphasis>undefined</emphasis> + </return> + </syntax> + <description> + Fills the window associated with <arg0/> using <arg1/>. + </description> + <seealso> + <reftopic>colors</reftopic> + </seealso> + </generic-function> + <generic-function name="draw-arc"> <syntax> <arguments> Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Wed Jan 31 09:17:41 2007 @@ -843,7 +843,7 @@ used. </para> <para role="normal"> - Like other system dialogs in Graphic-Forms, file-dialog is derived from + Like other system dialogs in Graphic-Forms, color-dialog is derived from <reftopic>gfw:widget</reftopic> rather than <reftopic>gfw:dialog</reftopic> since the majority of its functionality is implemented by the system. A future release will provide a customization mechanism. @@ -3867,7 +3867,7 @@ return the same value by default as would <reftopic>gfw:preferred-size</reftopic>. </para> <para role="normal"> - If the new minimum size provided via the SET function is larger than the + If the new minimum size provided via the SETF function is larger than the current size, the widget is resized to the new minimum. </para> </description> Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Wed Jan 31 09:17:41 2007 @@ -46,10 +46,7 @@ :initform nil))) (defmethod clear-buffer ((self double-buffered-event-dispatcher) gc) - (let ((image (image-buffer-of self))) - (setf (gfg:background-color gc) *background-color*) - (setf (gfg:foreground-color gc) *background-color*) - (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfg:size image))))) + (gfg:clear gc *background-color*)) (defmethod dispose ((self double-buffered-event-dispatcher)) (let ((image (image-buffer-of self))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Jan 31 09:17:41 2007 @@ -200,6 +200,7 @@ #:background-pattern #:blue-mask #:blue-shift + #:clear #:clipped-p #:clipping-rectangle #:color->rgb Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Wed Jan 31 09:17:41 2007 @@ -66,10 +66,8 @@ (drawing-exit-fn self nil)) (defmethod gfw:event-paint ((self drawing-win-events) window gc rect) - (declare (ignore rect)) - (setf (gfg:background-color gc) gfg:*color-white*) - (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) + (declare (ignore window rect)) + (gfg:clear gc gfg:*color-white*) (let ((func (draw-func-of self))) (unless (null func) (funcall func gc)))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Wed Jan 31 09:17:41 2007 @@ -48,10 +48,8 @@ (exit-fn disp nil)) (defmethod gfw:event-paint ((disp hellowin-events) window gc rect) - (declare (ignore rect)) - (setf (gfg:background-color gc) gfg:*color-white*) - (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) + (declare (ignore window rect)) + (gfg:clear gc gfg:*color-white-smoke*) (setf (gfg:background-color gc) gfg:*color-red*) (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Wed Jan 31 09:17:41 2007 @@ -73,10 +73,8 @@ :initform 0))) (defmethod gfw:event-paint ((self layout-tester-widget-events) window gc rect) - (declare (ignore rect)) - (setf (gfg:background-color gc) gfg:*color-white*) - (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) + (declare (ignore window rect)) + (gfg:clear gc gfg:*color-white*)) (defclass test-panel (gfw:panel) ()) Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-grid-panel.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Wed Jan 31 09:17:41 2007 @@ -77,10 +77,7 @@ (defmethod gfw:event-paint ((disp scroll-grid-panel-events) window gc rect) (declare (ignore window)) - (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) - (setf (gfg:background-color gc) color - (gfg:foreground-color gc) color)) - (gfg:draw-filled-rectangle gc rect) + (gfg:clear gc gfg:*color-button-face*) (setf (gfg:foreground-color gc) gfg:*color-black* (gfg:pen-style gc) '(:solid :flat-endcap)) (let* ((pnt (gfs:location rect)) Modified: trunk/src/tests/uitoolkit/scroll-text-panel.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-text-panel.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-text-panel.lisp Wed Jan 31 09:17:41 2007 @@ -107,9 +107,7 @@ (defmethod gfw:event-paint ((disp scroll-text-panel-events) window gc rect) (declare (ignore window)) - (setf (gfg:background-color gc) gfg:*color-white* - (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc rect) + (gfg:clear gc gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-black* (gfg:font gc) (font-of disp)) (let* ((metrics (gfg:metrics gc (font-of disp))) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Wed Jan 31 09:17:41 2007 @@ -219,6 +219,28 @@ (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb))) +(defmethod clear ((self graphics-context) (color color)) + (if (gfs:disposed-p self) + (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") + (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))))))))) + (defmethod gfs:dispose ((self graphics-context)) (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+)) (gfs::delete-object (pen-handle-of self)) @@ -282,31 +304,6 @@ (error 'gfs:disposed-error)) (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect)) -;;; 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))) - (gfs::with-rect (rect-ptr) - (setf gfs::top (gfs:point-y pnt) - gfs::left (gfs:point-x pnt) - gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size)) - gfs::right (+ (gfs:point-x pnt) (gfs:size-width size))) - (gfs::ext-text-out hdc - (gfs:point-x pnt) - (gfs:point-y pnt) - gfs::+eto-opaque+ - rect-ptr - "" - 0 - (cffi:null-pointer))))) -|# - (defmethod draw-filled-rounded-rectangle ((self graphics-context) rect size) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Wed Jan 31 09:17:41 2007 @@ -39,6 +39,9 @@ (defgeneric (setf background-color) (color self) (:documentation "Sets the current background color.")) +(defgeneric clear (self color) + (:documentation "Fills self with the specified color.")) + (defgeneric data-object (self &optional gc) (:documentation "Returns the data structure representing the raw form of self.")) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Wed Jan 31 09:17:41 2007 @@ -838,6 +838,11 @@ (rct LPTR)) (defcfun + ("WindowFromDC" window-from-dc) + HANDLE + (hdc HANDLE)) + +(defcfun ("WindowFromPoint" window-from-point) HANDLE (pnt :pointer)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed Jan 31 09:17:41 2007 @@ -187,7 +187,7 @@ (gfs::send-message (gfs:handle sbar) gfs::+wm-size+ (event-wparam event) - (event-lparam event)))) + (logand (event-lparam event) #xFFFFFFFF)))) (call-next-method)) (defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Wed Jan 31 09:17:41 2007 @@ -152,7 +152,7 @@ (gfs::send-message (gfs:handle sbar) gfs::+wm-size+ (event-wparam event) - (event-lparam event)))) + (logand (event-lparam event) #xFFFFFFFF)))) (call-next-method)) (defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys)

1 0

[graphic-forms-cvs] r429 - in trunk/src: demos uitoolkit/widgets
by junrue＠common-lisp.net 27 Jan '07

27 Jan '07

Author: junrue Date: Sat Jan 27 17:13:08 2007 New Revision: 429 Modified: trunk/src/demos/demo-utils.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: further work on coordination betweeen layout managers and status bar Modified: trunk/src/demos/demo-utils.lisp ============================================================================== --- trunk/src/demos/demo-utils.lisp (original) +++ trunk/src/demos/demo-utils.lisp Sat Jan 27 17:13:08 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; demo-utils.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 @@ -63,7 +63,7 @@ :text " ")) (line3 (make-instance 'gfw:label :parent text-panel - :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) + :text (format nil "Copyright ~c 2006-2007 by Jack D. Unrue" (code-char 169)))) (line4 (make-instance 'gfw:label :parent text-panel :text "All Rights Reserved.")) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Sat Jan 27 17:13:08 2007 @@ -121,12 +121,13 @@ (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idcancel+) (update-native-style cancel-widget style))) -(defmethod client-size ((self dialog)) - (let ((sbar (status-bar-of self)) - (client-size (call-next-method))) +(defmethod compute-outer-size ((self dialog) desired-client-size) + (declare (ignore desired-client-size)) + (let ((size (call-next-method)) + (sbar (status-bar-of self))) (if sbar - (decf (gfs:size-height client-size) (gfs:size-height (preferred-size sbar -1 -1)))) - client-size)) + (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) + size)) (defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) @@ -208,6 +209,14 @@ ;; (init-window self *dialog-classname* #'register-dialog-class owner text)) +(defmethod preferred-size ((self dialog) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (let ((size (call-next-method)) + (sbar (status-bar-of self))) + (if sbar + (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) + size)) + (defmethod show ((self dialog) flag) (let ((app-modal (find :application-modal (style-of self))) (owner-modal (find :owner-modal (style-of self))) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sat Jan 27 17:13:08 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; flow-layout.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 Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Sat Jan 27 17:13:08 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; heap-layout.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 @@ -63,21 +63,22 @@ size)) (defmethod compute-layout ((self heap-layout) (container layout-managed) width-hint height-hint) + (declare (ignore width-hint height-hint)) (cleanup-disposed-items self) - (let* ((size (client-size container)) - (horz-margin (+ (left-margin-of self) (right-margin-of self))) - (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) - (bounds (gfs:create-rectangle :x (left-margin-of self) - :y (top-margin-of self) - :width (- (if (> width-hint horz-margin) - width-hint - (gfs:size-width size)) - horz-margin) - :height (- (if (> height-hint vert-margin) - height-hint - (gfs:size-height size)) - vert-margin)))) - (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))) + (let ((size (client-size container)) + (sbar (if (or (typep container 'top-level) (typep container 'dialog)) + (status-bar-of container)))) + (if sbar + (decf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) + (let* ((horz-margin (+ (left-margin-of self) (right-margin-of self))) + (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) + (bounds (gfs:create-rectangle :x (left-margin-of self) + :y (top-margin-of self) + :width (- (gfs:size-width size) + horz-margin) + :height (- (gfs:size-height size) + vert-margin)))) + (mapcar (lambda (item) (cons (first item) bounds)) (data-of self))))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) (if (layout-p container) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sat Jan 27 17:13:08 2007 @@ -68,12 +68,13 @@ ;;; methods ;;; -(defmethod client-size ((self top-level)) - (let ((sbar (status-bar-of self)) - (client-size (call-next-method))) +(defmethod compute-outer-size ((self top-level) desired-client-size) + (declare (ignore desired-client-size)) + (let ((size (call-next-method)) + (sbar (status-bar-of self))) (if sbar - (decf (gfs:size-height client-size) (gfs:size-height (preferred-size sbar -1 -1)))) - client-size)) + (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) + size)) (defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) @@ -204,6 +205,14 @@ (when (and (maximum-size self) min-size) (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) +(defmethod preferred-size ((self top-level) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (let ((size (call-next-method)) + (sbar (status-bar-of self))) + (if sbar + (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) + size)) + (defmethod print-object ((self top-level) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self))

1 0

[graphic-forms-cvs] r427 - in trunk/src: demos/textedit demos/unblocked uitoolkit/system uitoolkit/widgets
by junrue＠common-lisp.net 22 Jan '07

22 Jan '07

Author: junrue Date: Mon Jan 22 00:07:43 2007 New Revision: 427 Modified: trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/status-bar.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: starting to update geometry management to account for status bars (and later, toolbars) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Mon Jan 22 00:07:43 2007 @@ -148,7 +148,7 @@ (defmethod gfw:event-activate ((self textedit-win-events) window) (declare (ignore window)) - (if *textedit-control* + (when *textedit-control* (gfw:give-focus *textedit-control*))) (defmethod gfw:event-close ((disp textedit-win-events) window) @@ -200,7 +200,6 @@ (gfw:text *textedit-win*) *textedit-new-title*) (let ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*))) (setf (gfw:image *textedit-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "textedit.ico")))) - (gfw::stb-set-text (gfw:status-bar-of *textedit-win*) "Testing...1, 2, 3") (gfw:show *textedit-win* t))) (defun textedit () Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Jan 22 00:07:43 2007 @@ -108,7 +108,7 @@ :style :vertical :spacing +spacing+ :margins +margin+) - :style '(:workspace))) + :style '(:workspace :status-bar))) (setf (gfw:menu-bar *unblocked-win*) menubar) (setf *scoreboard-panel* (make-instance 'scoreboard-panel :parent *unblocked-win* Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Mon Jan 22 00:07:43 2007 @@ -325,11 +325,20 @@ (flags DWORD) (device TCHAR :count 32)) ; CCHDEVICENAME -(defcstruct nccalcsize_params - (clientnewrect rect) - (destvalidrect rect) - (srcvalidrect rect) - (lppos LPTR)) +(defcstruct nccalcsize-params + (clientnewleft LONG) + (clientnewtop LONG) + (clientnewright LONG) + (clientnewbottom LONG) + (destvalidleft LONG) + (destvalidtop LONG) + (destvalidright LONG) + (destvalidbottom LONG) + (srcvalidleft LONG) + (srcvalidtop LONG) + (srcvalidright LONG) + (srcvalidbottom LONG) + (lppos LPTR)) (defcstruct openfilename (ofnsize DWORD) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Jan 22 00:07:43 2007 @@ -64,7 +64,7 @@ ;; FIXME: this is a temporary hack to allow layout management testing; ;; it won't work if virtual containers like group are implemented. ;; - (when (and parent (layout-of parent)) + (when (and parent (layout-of parent) (not (typep ctrl 'status-bar))) (append-layout-item (layout-of parent) ctrl)) hwnd))) @@ -205,7 +205,8 @@ (defmethod print-object ((self control) stream) (print-unreadable-object (self stream :type t) - (call-next-method) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a" (dispatcher self)) (unless (gfs:disposed-p self) (format stream "size: ~a " (size self)) (format stream "text baseline: ~a" (text-baseline self))))) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Mon Jan 22 00:07:43 2007 @@ -121,6 +121,13 @@ (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idcancel+) (update-native-style cancel-widget style))) +(defmethod client-size ((self dialog)) + (let ((sbar (status-bar-of self)) + (client-size (call-next-method))) + (if sbar + (decf (gfs:size-height client-size) (gfs:size-height (preferred-size sbar -1 -1)))) + client-size)) + (defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Jan 22 00:07:43 2007 @@ -127,6 +127,25 @@ (#.gfs::+lbn-selchange+ (event-select disp widget)) (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget))))) +(defun process-nccalcsize-message (widget wparam lparam) + ;; NOTE: this function is currently a stub until there is actually + ;; a need to process WM_NCCALCSIZE messages. + ;; + (let ((size (gfs:make-size))) + (cond + ((zerop wparam) + (cffi:with-foreign-slots ((gfs::bottom) + (cffi:make-pointer (logand #xFFFFFFFF lparam)) + gfs::rect) + (setf gfs::bottom (- gfs::bottom (gfs:size-height size)))) + 0) + (t + (cffi:with-foreign-slots ((gfs::clientnewbottom) + (cffi:make-pointer (logand #xFFFFFFFF lparam)) + gfs::nccalcsize-params) + (setf gfs::clientnewbottom (- gfs::clientnewbottom (gfs:size-height size)))) + 0)))) + (defun process-ctlcolor-message (wparam lparam) (let* ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) (hdc (cffi:make-pointer wparam)) @@ -531,6 +550,24 @@ gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size)))))) 1) +#| +(defmethod process-message (hwnd (msg (eql gfs::+wm-nccalcsize+)) wparam lparam) + (let ((widget (get-widget (thread-context) hwnd))) + (cond + ((typep widget 'dialog) + (let ((retval (gfs::def-dlg-proc hwnd msg wparam lparam))) + (if (status-bar-of widget) + (setf retval (process-nccalcsize-message widget wparam lparam))) + retval)) + ((typep widget 'top-level) + (let ((retval (gfs::def-window-proc hwnd msg wparam lparam))) + (if (status-bar-of widget) + (setf retval (process-nccalcsize-message widget wparam lparam))) + retval)) + (t + (gfs::def-window-proc hwnd msg wparam lparam))))) +|# + (defmethod process-message (hwnd (msg (eql gfs::+wm-timer+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Jan 22 00:07:43 2007 @@ -122,6 +122,9 @@ (let ((kid-count (length (data-of self))) (horz-margin-total (+ (left-margin-of self) (right-margin-of self))) (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self))) + (sbar-height (if (status-bar-of container) + (gfs:size-height (preferred-size (status-bar-of container) -1 -1)) + 0)) (vertical (find :vertical (style-of self))) (horizontal (find :horizontal (style-of self)))) (let ((spacing-total (* (spacing-of self) (1- kid-count))) @@ -137,14 +140,16 @@ (gfs:make-size :width (+ (flow-data-distance-total state) horz-margin-total spacing-total) - :height (+ (flow-data-max-extent state) - vert-margin-total))) + :height (- (+ (flow-data-max-extent state) + vert-margin-total) + sbar-height))) (vertical (gfs:make-size :width (+ (flow-data-max-extent state) horz-margin-total) - :height (+ (flow-data-distance-total state) - vert-margin-total - spacing-total))) + :height (- (+ (flow-data-distance-total state) + vert-margin-total + spacing-total) + sbar-height))) (t (error 'gfs:toolkit-error :detail (format nil "unrecognized flow layout style: ~a" (style-of self)))))))) Modified: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/status-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Mon Jan 22 00:07:43 2007 @@ -114,11 +114,16 @@ (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths))))) (defmethod preferred-size ((self status-bar) width-hint height-hint) + (declare (ignore height-hint)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((client-area (client-size (parent self))) - (tmp-size (compute-size (layout-of self) self width-hint height-hint)) + (let ((tmp-size (if (data-of (layout-of self)) + (compute-size (layout-of self) self width-hint -1) + (widget-text-size self + (lambda (widget) + (declare (ignore widget)) + "X") + gfs::+dt-singleline+))) (widths (stb-get-border-widths self))) - (gfs:make-size :width (gfs:size-width client-area)) - :height (+ (gfs:size-height tmp-size) (* (first widths) 2)))) - + (gfs:make-size :width 0 + :height (+ (gfs:size-height tmp-size) (* (second widths) 2) 1)))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Mon Jan 22 00:07:43 2007 @@ -68,6 +68,13 @@ ;;; methods ;;; +(defmethod client-size ((self top-level)) + (let ((sbar (status-bar-of self)) + (client-size (call-next-method))) + (if sbar + (decf (gfs:size-height client-size) (gfs:size-height (preferred-size sbar -1 -1)))) + client-size)) + (defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) @@ -126,14 +133,13 @@ (values std-flags ex-flags))) (defmethod gfs:dispose ((self top-level)) - (let ((menu (menu-bar self)) - (sbar (status-bar-of self)) - (tc (thread-context))) + (let ((menu (menu-bar self))) (when menu (visit-menu-tree menu #'menu-cleanup-callback) - (delete-widget tc (gfs:handle menu))) + (delete-widget (thread-context) (gfs:handle menu)))) + (let ((sbar (status-bar-of self))) (when sbar - (delete-widget tc (gfs:handle sbar)) + (delete-widget (thread-context) (gfs:handle sbar)) (setf (slot-value self 'status-bar) nil))) (call-next-method)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Jan 22 00:07:43 2007 @@ -65,6 +65,9 @@ (layout :accessor layout-of :initarg :layout + :initform nil) + (status-bar + :reader status-bar-of :initform nil)) (:documentation "Instances of this class employ a layout manager to organize their children.")) @@ -261,10 +264,7 @@ :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) -(defclass dialog (window) - ((status-bar - :reader status-bar-of - :initform nil)) +(defclass dialog (window) () (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) (defclass panel (window) () @@ -273,10 +273,7 @@ (defclass root-window (window) () (:documentation "This class encapsulates the root of the desktop window hierarchy.")) -(defclass top-level (window) - ((status-bar - :reader status-bar-of - :initform nil)) +(defclass top-level (window) () (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) (defclass timer (event-source) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Jan 22 00:07:43 2007 @@ -274,8 +274,8 @@ (defmethod event-resize (disp (self window) size type) (declare (ignore disp size type)) (unless (null (layout-of self)) - (let ((sz (client-size self))) - (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) + (let ((client-size (client-size self))) + (perform (layout-of self) self (gfs:size-width client-size) (gfs:size-height client-size))))) (defmethod focus-p :before ((self window)) (if (gfs:disposed-p self)

1 0

[graphic-forms-cvs] r426 - in trunk: . docs/manual src src/tests/mcclim src/uitoolkit/widgets
by junrue＠common-lisp.net 21 Jan '07

21 Jan '07

Author: junrue Date: Sun Jan 21 12:13:49 2007 New Revision: 426 Added: trunk/src/tests/mcclim/buttons.lisp Modified: trunk/docs/manual/clhs-table.xml trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/status-bar.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: miscellaneous tweaks and fixes, some of it originating from McCLIM backend work Modified: trunk/docs/manual/clhs-table.xml ============================================================================== --- trunk/docs/manual/clhs-table.xml (original) +++ trunk/docs/manual/clhs-table.xml Sun Jan 21 12:13:49 2007 @@ -15,6 +15,7 @@ <entry name="hash-table" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_hash_t.htm"/> <entry name="integer" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_intege.htm"/> <entry name="list" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_list.htm"/> + <entry name="load" url="http://www.lispworks.com/documentation/HyperSpec/Body/f_load.htm"/> <entry name="namestring" url="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_n.htm#namestri…"/> <entry name="pathname" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_pn.htm"/> <entry name="string" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_string.htm"/> Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Jan 21 12:13:49 2007 @@ -51,7 +51,7 @@ #:windlg)) (print "Graphic-Forms UI Toolkit Tests") -(print "Copyright (c) 2006 by Jack D. Unrue") +(print "Copyright (c) 2006-2007 by Jack D. Unrue") (print " ") (defsystem graphic-forms-tests Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Jan 21 12:13:49 2007 @@ -36,7 +36,7 @@ ;(in-package #:graphic-forms-system) (print "Graphic-Forms UI Toolkit") -(print "Copyright (c) 2006 by Jack D. Unrue") +(print "Copyright (c) 2006-2007 by Jack D. Unrue") (print " ") (defsystem graphic-forms-uitoolkit Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Jan 21 12:13:49 2007 @@ -511,6 +511,7 @@ #:peer #:preferred-size #:primary-p + #:process-events #:redraw #:redrawing-p #:release-mouse Added: trunk/src/tests/mcclim/buttons.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/mcclim/buttons.lisp Sun Jan 21 12:13:49 2007 @@ -0,0 +1,16 @@ + +(defpackage :clim-graphic-forms-tests + (:use :clim :clim-lisp)) + +(in-package :clim-graphic-forms-tests) + +;;; +;;; (run-frame-top-level (make-application-frame 'buttons)) +;;; + +(define-application-frame buttons () () + (:menu-bar nil) + (:layouts + (default + (vertically (:equalize-width t) + (make-pane 'push-button :label "First"))))) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Jan 21 12:13:49 2007 @@ -205,10 +205,10 @@ (defmethod print-object ((self control) stream) (print-unreadable-object (self stream :type t) - (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "size: ~a " (size self)) - (format stream "text baseline: ~a" (text-baseline self)))) + (call-next-method) + (unless (gfs:disposed-p self) + (format stream "size: ~a " (size self)) + (format stream "text baseline: ~a" (text-baseline self))))) (defmethod text-baseline ((self control)) (floor (gfs:size-height (size self)) 2)) Modified: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/status-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Sun Jan 21 12:13:49 2007 @@ -114,7 +114,6 @@ (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths))))) (defmethod preferred-size ((self status-bar) width-hint height-hint) - (declare (ignore width-hint height-hint)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((client-area (client-size (parent self))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Jan 21 12:13:49 2007 @@ -165,8 +165,7 @@ (defun get-widget-text (widget) (if (gfs:disposed-p widget) (error 'gfs:disposed-error)) - (let* ((text "") - (hwnd (gfs:handle widget)) + (let* ((hwnd (gfs:handle widget)) (length (gfs::get-window-text-length hwnd))) (if (zerop length) ""

1 0