April 2007 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r464 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 05 Apr '07

05 Apr '07

Author: junrue Date: Thu Apr 5 00:30:16 2007 New Revision: 464 Modified: trunk/NEWS.txt trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/progress-bar.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: further implementation of progress-bar control Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Thu Apr 5 00:30:16 2007 @@ -6,10 +6,14 @@ . Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) -. Implemented simple-mode status bars, which have a single text field. +. Implemented GFW:STATUS-BAR which currently allow a single text field. Multi-part status bars, and nested widget support, will be added in a future release. +. Implemented GFW:PROGRESS-BAR, which provides visual progress feedback. This + control can be configured for horizontal or vertical orientation, and can + display a segmented or continuous indicator. + . Simplified the mechanism for specifying fixed, non-resizable windows by adding a new GFW:TOP-LEVEL style called :FIXED-SIZE and enhancing GFW:PACK to do the right thing if that style flag has been specified. Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Apr 5 00:30:16 2007 @@ -869,6 +869,8 @@ (defconstant +pbm-setstate+ #x0410) ; (WM_USER+16) (defconstant +pbm-getstate+ #x0411) ; (WM_USER+17) +(defconstant +pbs-smooth+ #x01) +(defconstant +pbs-vertical+ #x04) (defconstant +pbs-marquee+ #x08) (defconstant +pbs-smoothreverse+ #x10) Modified: trunk/src/uitoolkit/widgets/progress-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/progress-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/progress-bar.lisp Thu Apr 5 00:30:16 2007 @@ -1,5 +1,5 @@ ;;;; -;;;; progressbar.lisp +;;;; progress-bar.lisp ;;;; ;;;; Copyright (C) 2007, Jack D. Unrue ;;;; All rights reserved. @@ -54,6 +54,10 @@ "Returns the step increment for a progress bar." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getstep+ 0 0)) +(declaim (inline pb-horz-flags)) +(defun pb-horz-flags (flags) + (logand flags (lognot gfs::+pbs-vertical+))) + (declaim (inline pb-set-pos-absolute)) (defun pb-set-pos-absolute (p-bar pos) "Sets the absolute position of a progress bar and redraws it; returns the previous position." @@ -78,7 +82,50 @@ "Sets the step increment for a progress bar; returns the previous increment." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setstep+ (logand increment #xFFFF) 0)) +(declaim (inline pb-smooth-flags)) +(defun pb-smooth-flags (flags) + (logior flags gfs::+pbs-smooth+)) + (declaim (inline pb-stepit)) (defun pb-stepit (p-bar) "Advances the progress bar's position by its step increment and redraws it; returns the previous position." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-stepit+ 0 0)) + +(declaim (inline pb-vert-flags)) +(defun pb-vert-flags (flags) + (logior flags gfs::+pbs-vertical+)) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((pbar progress-bar) &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags +default-child-style+) + (style (style-of pbar))) + (loop for sym in style + do (ecase sym + ;; primary progress-bar styles + ;; + (:horizontal (setf std-flags (pb-horz-flags std-flags))) + (:vertical (setf std-flags (pb-vert-flags std-flags))) + + ;; styles that can be combined + ;; + (:smooth (setf std-flags (pb-smooth-flags std-flags))))) + (values std-flags 0))) + +(defmethod initialize-instance :after ((pbar progress-bar) &key parent &allow-other-keys) + (create-control pbar parent "" gfs::+icc-win95-classes+)) + +(defmethod preferred-size ((pbar progress-bar) width-hint height-hint) + (let ((size (gfs:make-size :width width-hint :height height-hint)) + (b-width (* (border-width pbar) 2))) + (if (<= width-hint 0) + (setf (gfs:size-width size) +default-widget-width+)) + (incf (gfs:size-width size) b-width) + (if (<= height-hint 0) + (setf (gfs:size-height size) + (floor (* (gfs::get-system-metrics gfs::+sm-cyvscroll+) 3) 4))) + (incf (gfs:size-height size) b-width) + size)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu Apr 5 00:30:16 2007 @@ -218,7 +218,7 @@ (item-manager)) (define-control-class - progressbar + progress-bar "msctls_progress" 'event-select "This class represents controls that provide visual feedback for progress.")

1 0

[graphic-forms-cvs] r463 - in branches/graphic-forms-newtypes: . src/uitoolkit/widgets
by junrue＠common-lisp.net 05 Apr '07

05 Apr '07

Author: junrue Date: Thu Apr 5 00:27:34 2007 New Revision: 463 Added: branches/graphic-forms-newtypes/src/uitoolkit/widgets/progress-bar.lisp - copied unchanged from r461, branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp Removed: branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp Modified: branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd Log: renamed progressbar to progress-bar Modified: branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd ============================================================================== --- branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd (original) +++ branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd Thu Apr 5 00:27:34 2007 @@ -143,7 +143,7 @@ (:file "menu") (:file "menu-item") (:file "menu-language") - (:file "progressbar") + (:file "progress-bar") (:file "event") (:file "scrolling-helper") (:file "scrollbar")

1 0

[graphic-forms-cvs] r462 - in trunk: . src/uitoolkit/widgets
by junrue＠common-lisp.net 05 Apr '07

05 Apr '07

Author: junrue Date: Thu Apr 5 00:26:11 2007 New Revision: 462 Added: trunk/src/uitoolkit/widgets/progress-bar.lisp - copied unchanged from r460, trunk/src/uitoolkit/widgets/progressbar.lisp Removed: trunk/src/uitoolkit/widgets/progressbar.lisp Modified: trunk/graphic-forms-uitoolkit.asd Log: renamed progressbar to progress-bar Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Apr 5 00:26:11 2007 @@ -143,7 +143,7 @@ (:file "menu") (:file "menu-item") (:file "menu-language") - (:file "progressbar") + (:file "progress-bar") (:file "event") (:file "scrolling-helper") (:file "scrollbar")

1 0

[graphic-forms-cvs] r461 - in branches/graphic-forms-newtypes: . src src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 05 Apr '07

05 Apr '07

Author: junrue Date: Thu Apr 5 00:25:54 2007 New Revision: 461 Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/src/packages.lisp branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp Log: further implementation of progress-bar control Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Thu Apr 5 00:25:54 2007 @@ -6,10 +6,14 @@ . Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) -. Implemented simple-mode status bars, which have a single text field. +. Implemented GFW:STATUS-BAR which currently allow a single text field. Multi-part status bars, and nested widget support, will be added in a future release. +. Implemented GFW:PROGRESS-BAR, which provides visual progress feedback. This + control can be configured for horizontal or vertical orientation, and can + display a segmented or continuous indicator. + . Simplified the mechanism for specifying fixed, non-resizable windows by adding a new GFW:TOP-LEVEL style called :FIXED-SIZE and enhancing GFW:PACK to do the right thing if that style flag has been specified. Modified: branches/graphic-forms-newtypes/src/packages.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/packages.lisp (original) +++ branches/graphic-forms-newtypes/src/packages.lisp Thu Apr 5 00:25:54 2007 @@ -555,6 +555,7 @@ #:preferred-size #:primary-p #:process-events + #:progress-bar #:redraw #:redrawing-p #:release-mouse Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp Thu Apr 5 00:25:54 2007 @@ -869,6 +869,8 @@ (defconstant +pbm-setstate+ #x0410) ; (WM_USER+16) (defconstant +pbm-getstate+ #x0411) ; (WM_USER+17) +(defconstant +pbs-smooth+ #x01) +(defconstant +pbs-vertical+ #x04) (defconstant +pbs-marquee+ #x08) (defconstant +pbs-smoothreverse+ #x10) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp Thu Apr 5 00:25:54 2007 @@ -1,5 +1,5 @@ ;;;; -;;;; progressbar.lisp +;;;; progress-bar.lisp ;;;; ;;;; Copyright (C) 2007, Jack D. Unrue ;;;; All rights reserved. @@ -53,6 +53,10 @@ (defun pb-get-step (p-bar) "Returns the step increment for a progress bar." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getstep+ 0 0)) + +(declaim (inline pb-horz-flags)) +(defun pb-horz-flags (flags) + (logand flags (lognot gfs::+pbs-vertical+))) (declaim (inline pb-set-pos-absolute)) (defun pb-set-pos-absolute (p-bar pos) @@ -78,7 +82,50 @@ "Sets the step increment for a progress bar; returns the previous increment." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setstep+ (logand increment #xFFFF) 0)) +(declaim (inline pb-smooth-flags)) +(defun pb-smooth-flags (flags) + (logior flags gfs::+pbs-smooth+)) + (declaim (inline pb-stepit)) (defun pb-stepit (p-bar) "Advances the progress bar's position by its step increment and redraws it; returns the previous position." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-stepit+ 0 0)) + +(declaim (inline pb-vert-flags)) +(defun pb-vert-flags (flags) + (logior flags gfs::+pbs-vertical+)) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((pbar progress-bar) &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags +default-child-style+) + (style (style-of pbar))) + (loop for sym in style + do (ecase sym + ;; primary progress-bar styles + ;; + (:horizontal (setf std-flags (pb-horz-flags std-flags))) + (:vertical (setf std-flags (pb-vert-flags std-flags))) + + ;; styles that can be combined + ;; + (:smooth (setf std-flags (pb-smooth-flags std-flags))))) + (values std-flags 0))) + +(defmethod initialize-instance :after ((pbar progress-bar) &key parent &allow-other-keys) + (create-control pbar parent "" gfs::+icc-win95-classes+)) + +(defmethod preferred-size ((pbar progress-bar) width-hint height-hint) + (let ((size (gfs:make-size :width width-hint :height height-hint)) + (b-width (* (border-width pbar) 2))) + (if (<= width-hint 0) + (setf (gfs:size-width size) +default-widget-width+)) + (incf (gfs:size-width size) b-width) + (if (<= height-hint 0) + (setf (gfs:size-height size) + (floor (* (gfs::get-system-metrics gfs::+sm-cyvscroll+) 3) 4))) + (incf (gfs:size-height size) b-width) + size)) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp Thu Apr 5 00:25:54 2007 @@ -218,7 +218,7 @@ (item-manager)) (define-control-class - progressbar + progress-bar "msctls_progress" 'event-select "This class represents controls that provide visual feedback for progress.")

1 0

[graphic-forms-cvs] r460 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Apr '07

03 Apr '07

Author: junrue Date: Tue Apr 3 00:45:38 2007 New Revision: 460 Added: trunk/src/uitoolkit/widgets/progressbar.lisp Modified: trunk/NEWS.txt trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: initial steps toward progress-bar implementation; fixed typo in top-level override for pack method Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Tue Apr 3 00:45:38 2007 @@ -1,7 +1,10 @@ . Latest CFFI is required to take advantage of built-in support for the - stdcall calling convention (FIXME: change checked in this past Feb., need - to narrow down which snapshot actually has it). + stdcall calling convention. + +. Ported the library to Allegro CL 8.0. + +. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) . Implemented simple-mode status bars, which have a single text field. Multi-part status bars, and nested widget support, will be added in a @@ -14,10 +17,6 @@ . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner. -. Ported the library to Allegro CL 8.0. - -. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) - . Implemented a new graphics context function GFG:CLEAR that is a convenient way to fill a window or image with a background color. Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Apr 3 00:45:38 2007 @@ -143,6 +143,7 @@ (:file "menu") (:file "menu-item") (:file "menu-language") + (:file "progressbar") (:file "event") (:file "scrolling-helper") (:file "scrollbar") Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Apr 3 00:45:38 2007 @@ -848,6 +848,34 @@ (defconstant +out-screen-outline-precis+ 9) (defconstant +out-ps-only-precis+ 10) +;;; +;;; progress bar messages and style bits +;;; + +(defconstant +pbm-setrange+ #x0401) ; (WM_USER+1) +(defconstant +pbm-setpos+ #x0402) ; (WM_USER+2) +(defconstant +pbm-deltapos+ #x0403) ; (WM_USER+3) +(defconstant +pbm-setstep+ #x0404) ; (WM_USER+4) +(defconstant +pbm-stepit+ #x0405) ; (WM_USER+5) +(defconstant +pbm-setrange32+ #x0406) ; (WM_USER+6) +(defconstant +pbm-getrange+ #x0407) ; (WM_USER+7) +(defconstant +pbm-getpos+ #x0408) ; (WM_USER+8) +(defconstant +pbm-setbarcolor+ #x0409) ; (WM_USER+9) +(defconstant +pbm-setbkcolor+ #x2001) ; CCM_SETBKCOLOR +(defconstant +pbm-setmarquee+ #x040a) ; (WM_USER+10) +(defconstant +pbm-getstep+ #x040d) ; (WM_USER+13) +(defconstant +pbm-getbkcolor+ #x040e) ; (WM_USER+14) +(defconstant +pbm-getbarcolor+ #x040f) ; (WM_USER+15) +(defconstant +pbm-setstate+ #x0410) ; (WM_USER+16) +(defconstant +pbm-getstate+ #x0411) ; (WM_USER+17) + +(defconstant +pbs-marquee+ #x08) +(defconstant +pbs-smoothreverse+ #x10) + +(defconstant +pbst-normal+ #x0001) +(defconstant +pbst-error+ #x0002) +(defconstant +pbst-paused+ #x0003) + (defconstant +pderr-printercodes+ #x1000) (defconstant +pderr-setupfailure+ #x1001) (defconstant +pderr-parsefailure+ #x1002) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Apr 3 00:45:38 2007 @@ -309,6 +309,10 @@ (incupdate BOOL) (reserved :unsigned-char :count 32)) +(defcstruct pbrange + (low INT) + (high INT)) + (defctype rect-pointer :pointer) (defcstruct rect Added: trunk/src/uitoolkit/widgets/progressbar.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/progressbar.lisp Tue Apr 3 00:45:38 2007 @@ -0,0 +1,84 @@ +;;;; +;;;; progressbar.lisp +;;;; +;;;; Copyright (C) 2007, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; helper functions +;;; + +(declaim (inline pb-get-pos)) +(defun pb-get-pos (p-bar) + "Returns the current position of a progress bar." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getpos+ 0 0)) + +(defun pb-get-range (p-bar) + "Returns the range of a progress bar." + (cffi:with-foreign-object (r-ptr 'gfs::pbrange) + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getrange+ 0 (cffi:pointer-address r-ptr)) + (cffi:with-foreign-slots ((gfs::low gfs::high) r-ptr gfs::pbrange) + (gfs:make-span :start gfs::low :end gfs::high)))) + +(declaim (inline pb-get-step)) +(defun pb-get-step (p-bar) + "Returns the step increment for a progress bar." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getstep+ 0 0)) + +(declaim (inline pb-set-pos-absolute)) +(defun pb-set-pos-absolute (p-bar pos) + "Sets the absolute position of a progress bar and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setpos+ (logand pos #xFFFF) 0)) + +(declaim (inline pb-set-pos-delta)) +(defun pb-set-pos-delta (p-bar delta) + "Updates the position of a progress bar by delta and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-deltapos+ (logand delta #xFFFF) 0)) + +(defun pb-set-range (p-bar span) + "Sets the range of a progress bar; returns the previous range." + (let ((result (gfs::send-message (gfs:handle p-bar) + gfs::+pbm-setrange32+ + (logand (gfs:span-start span) #xFFFFFFFF) + (logand (gfs:span-end span) #xFFFFFFFF)))) + (gfs:make-span :start (gfs::lparam-low-word result) + :end (gfs::lparam-high-word result)))) + +(declaim (inline pb-set-step)) +(defun pb-set-step (p-bar increment) + "Sets the step increment for a progress bar; returns the previous increment." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setstep+ (logand increment #xFFFF) 0)) + +(declaim (inline pb-stepit)) +(defun pb-stepit (p-bar) + "Advances the progress bar's position by its step increment and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-stepit+ 0 0)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Apr 3 00:45:38 2007 @@ -195,7 +195,7 @@ (when (and (maximum-size self) min-size) (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) -(defmethod pack ((win window)) +(defmethod pack ((win top-level)) (if (find :fixed-size (style-of win)) (let ((size (gfw:preferred-size win -1 -1))) (setf (gfw:minimum-size win) size Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Apr 3 00:45:38 2007 @@ -218,6 +218,12 @@ (item-manager)) (define-control-class + progressbar + "msctls_progress" + 'event-select + "This class represents controls that provide visual feedback for progress.") + +(define-control-class scrollbar "scrollbar" 'event-scroll

1 0

[graphic-forms-cvs] r459 - in branches/graphic-forms-newtypes: . src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Apr '07

03 Apr '07

Author: junrue Date: Tue Apr 3 00:45:18 2007 New Revision: 459 Added: branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp Log: initial steps toward progress-bar implementation; fixed typo in top-level override for pack method Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Tue Apr 3 00:45:18 2007 @@ -1,7 +1,10 @@ . Latest CFFI is required to take advantage of built-in support for the - stdcall calling convention (FIXME: change checked in this past Feb., need - to narrow down which snapshot actually has it). + stdcall calling convention. + +. Ported the library to Allegro CL 8.0. + +. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) . Implemented simple-mode status bars, which have a single text field. Multi-part status bars, and nested widget support, will be added in a @@ -14,10 +17,6 @@ . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner. -. Ported the library to Allegro CL 8.0. - -. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) - . Implemented a new graphics context function GFG:CLEAR that is a convenient way to fill a window or image with a background color. Modified: branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd ============================================================================== --- branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd (original) +++ branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd Tue Apr 3 00:45:18 2007 @@ -143,6 +143,7 @@ (:file "menu") (:file "menu-item") (:file "menu-language") + (:file "progressbar") (:file "event") (:file "scrolling-helper") (:file "scrollbar") Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp Tue Apr 3 00:45:18 2007 @@ -848,6 +848,34 @@ (defconstant +out-screen-outline-precis+ 9) (defconstant +out-ps-only-precis+ 10) +;;; +;;; progress bar messages and style bits +;;; + +(defconstant +pbm-setrange+ #x0401) ; (WM_USER+1) +(defconstant +pbm-setpos+ #x0402) ; (WM_USER+2) +(defconstant +pbm-deltapos+ #x0403) ; (WM_USER+3) +(defconstant +pbm-setstep+ #x0404) ; (WM_USER+4) +(defconstant +pbm-stepit+ #x0405) ; (WM_USER+5) +(defconstant +pbm-setrange32+ #x0406) ; (WM_USER+6) +(defconstant +pbm-getrange+ #x0407) ; (WM_USER+7) +(defconstant +pbm-getpos+ #x0408) ; (WM_USER+8) +(defconstant +pbm-setbarcolor+ #x0409) ; (WM_USER+9) +(defconstant +pbm-setbkcolor+ #x2001) ; CCM_SETBKCOLOR +(defconstant +pbm-setmarquee+ #x040a) ; (WM_USER+10) +(defconstant +pbm-getstep+ #x040d) ; (WM_USER+13) +(defconstant +pbm-getbkcolor+ #x040e) ; (WM_USER+14) +(defconstant +pbm-getbarcolor+ #x040f) ; (WM_USER+15) +(defconstant +pbm-setstate+ #x0410) ; (WM_USER+16) +(defconstant +pbm-getstate+ #x0411) ; (WM_USER+17) + +(defconstant +pbs-marquee+ #x08) +(defconstant +pbs-smoothreverse+ #x10) + +(defconstant +pbst-normal+ #x0001) +(defconstant +pbst-error+ #x0002) +(defconstant +pbst-paused+ #x0003) + (defconstant +pderr-printercodes+ #x1000) (defconstant +pderr-setupfailure+ #x1001) (defconstant +pderr-parsefailure+ #x1002) 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 Tue Apr 3 00:45:18 2007 @@ -320,6 +320,10 @@ (incupdate BOOL) (reserved :unsigned-char :count 32)) +(defcstruct pbrange + (low INT) + (high INT)) + (define-foreign-type rect-pointer-type () () (:actual-type :pointer) (:simple-parser rect-pointer)) Added: branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp ============================================================================== --- (empty file) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp Tue Apr 3 00:45:18 2007 @@ -0,0 +1,84 @@ +;;;; +;;;; progressbar.lisp +;;;; +;;;; Copyright (C) 2007, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; helper functions +;;; + +(declaim (inline pb-get-pos)) +(defun pb-get-pos (p-bar) + "Returns the current position of a progress bar." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getpos+ 0 0)) + +(defun pb-get-range (p-bar) + "Returns the range of a progress bar." + (cffi:with-foreign-object (r-ptr 'gfs::pbrange) + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getrange+ 0 (cffi:pointer-address r-ptr)) + (cffi:with-foreign-slots ((gfs::low gfs::high) r-ptr gfs::pbrange) + (gfs:make-span :start gfs::low :end gfs::high)))) + +(declaim (inline pb-get-step)) +(defun pb-get-step (p-bar) + "Returns the step increment for a progress bar." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getstep+ 0 0)) + +(declaim (inline pb-set-pos-absolute)) +(defun pb-set-pos-absolute (p-bar pos) + "Sets the absolute position of a progress bar and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setpos+ (logand pos #xFFFF) 0)) + +(declaim (inline pb-set-pos-delta)) +(defun pb-set-pos-delta (p-bar delta) + "Updates the position of a progress bar by delta and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-deltapos+ (logand delta #xFFFF) 0)) + +(defun pb-set-range (p-bar span) + "Sets the range of a progress bar; returns the previous range." + (let ((result (gfs::send-message (gfs:handle p-bar) + gfs::+pbm-setrange32+ + (logand (gfs:span-start span) #xFFFFFFFF) + (logand (gfs:span-end span) #xFFFFFFFF)))) + (gfs:make-span :start (gfs::lparam-low-word result) + :end (gfs::lparam-high-word result)))) + +(declaim (inline pb-set-step)) +(defun pb-set-step (p-bar increment) + "Sets the step increment for a progress bar; returns the previous increment." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setstep+ (logand increment #xFFFF) 0)) + +(declaim (inline pb-stepit)) +(defun pb-stepit (p-bar) + "Advances the progress bar's position by its step increment and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-stepit+ 0 0)) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp Tue Apr 3 00:45:18 2007 @@ -195,7 +195,7 @@ (when (and (maximum-size self) min-size) (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) -(defmethod pack ((win window)) +(defmethod pack ((win top-level)) (if (find :fixed-size (style-of win)) (let ((size (gfw:preferred-size win -1 -1))) (setf (gfw:minimum-size win) size Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp Tue Apr 3 00:45:18 2007 @@ -218,6 +218,12 @@ (item-manager)) (define-control-class + progressbar + "msctls_progress" + 'event-select + "This class represents controls that provide visual feedback for progress.") + +(define-control-class scrollbar "scrollbar" 'event-scroll

1 0

[graphic-forms-cvs] r458 - trunk
by junrue＠common-lisp.net 03 Apr '07

03 Apr '07

Author: junrue Date: Mon Apr 2 22:39:40 2007 New Revision: 458 Modified: trunk/NEWS.txt Log: sync up NEWS.txt with newtypes branch Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Apr 2 22:39:40 2007 @@ -3,6 +3,14 @@ stdcall calling convention (FIXME: change checked in this past Feb., need to narrow down which snapshot actually has it). +. Implemented simple-mode status bars, which have a single text field. + Multi-part status bars, and nested widget support, will be added in a + future release. + +. Simplified the mechanism for specifying fixed, non-resizable windows by + adding a new GFW:TOP-LEVEL style called :FIXED-SIZE and enhancing GFW:PACK + to do the right thing if that style flag has been specified. + . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner.

1 0

[graphic-forms-cvs] r457 - in trunk: docs/manual src/demos/unblocked src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Apr '07

03 Apr '07

Author: junrue Date: Mon Apr 2 22:37:50 2007 New Revision: 457 Modified: trunk/docs/manual/gfw-symbols.xml trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/status-bar.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: implemented new top-level style :fixed-size and modified gfw:pack to set min and max sizes when :fixed-size has been set; added another optional parameter to CREATE-CONTROL convenience function to allow control initializers to pass params to their implementations of COMPUTE-STYLE-FLAGS Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Mon Apr 2 22:37:50 2007 @@ -1419,6 +1419,12 @@ </enum> One or more of the following optional styles: <enum> + <argument name=":fixed-size"> + <description> + The resulting window cannot be dragged to a new size, but a layout + manager can still resize it programmatically. + </description> + </argument> <argument name=":horizontal-scrollbar"/> <argument name=":status-bar"/> <argument name=":vertical-scrollbar"/> Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Apr 2 22:37:50 2007 @@ -112,7 +112,7 @@ :style :vertical :spacing +spacing+ :margins +margin+) - :style '(:workspace :status-bar))) + :style '(:fixed-size :workspace :status-bar))) (setf (gfw:menu-bar *unblocked-win*) menubar) (setf *scoreboard-panel* (make-instance 'scoreboard-panel :parent *unblocked-win* @@ -126,10 +126,7 @@ :buffer-size tile-buffer-size))) (setf (gfw:text *unblocked-win*) "UnBlocked") - (setf (gfw:resizable-p *unblocked-win*) nil) - (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) - (setf (gfw:minimum-size *unblocked-win*) size - (gfw:maximum-size *unblocked-win*) size)) + (gfw:pack *unblocked-win*) (new-unblocked nil nil) (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Apr 2 22:37:50 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; control.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 @@ -45,10 +45,10 @@ (if (and (zerop (gfs::init-common-controls ic-ptr)) (/= (gfs::get-last-error) 0)) (warn 'gfs:win32-warning :detail "init-common-controls failed")))) -(defun create-control (ctrl parent text icc-flags &optional id) +(defun create-control (ctrl parent text icc-flags &optional id extra-data) (initialize-comctl-classes icc-flags) (multiple-value-bind (std-style ex-style) - (compute-style-flags ctrl) + (compute-style-flags ctrl extra-data) (let ((hwnd (create-window (system-classname-of ctrl) (or text " ") (gfs:handle parent) Modified: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/status-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Mon Apr 2 22:37:50 2007 @@ -104,11 +104,16 @@ (max (first widths) (second widths)))) (defmethod compute-style-flags ((self status-bar) &rest extra-data) - (declare (ignore extra-data)) - (values (logior gfs::+ws-child+ gfs::+ws-visible+ gfs::+sbars-sizegrip+) 0)) + (let ((extra-bits (if (first extra-data) 0 gfs::+sbars-sizegrip+))) + (values (logior gfs::+ws-child+ gfs::+ws-visible+ extra-bits) 0))) (defmethod initialize-instance :after ((self status-bar) &key parent &allow-other-keys) - (let ((hctl (create-control self parent "" gfs::+icc-win95-classes+))) + (let ((hctl (create-control self + parent + "" + gfs::+icc-win95-classes+ + nil + (find :fixed-size (style-of parent))))) (gfs::send-message hctl gfs::+sb-simple+ 1 0)) (let ((widths (stb-get-border-widths self))) (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths))))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Mon Apr 2 22:37:50 2007 @@ -111,13 +111,10 @@ ;; styles that can be combined ;; -#| - (:max (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - (:min (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - (:sysmenu (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - (:title (setf std-flags (logior std-flags gfs::+ws-caption+))) - (:top (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) -|# + (:fixed-size + (setf std-flags (logand std-flags + (lognot (logior gfs::+ws-maximizebox+ + gfs::+ws-thickframe+))))) (:horizontal-scrollbar (setf std-flags (logior std-flags gfs::+ws-hscroll+))) (:status-bar) ;; nothing to do, but need to allow this style symbol @@ -198,6 +195,13 @@ (when (and (maximum-size self) min-size) (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) +(defmethod pack ((win window)) + (if (find :fixed-size (style-of win)) + (let ((size (gfw:preferred-size win -1 -1))) + (setf (gfw:minimum-size win) size + (gfw:maximum-size win) size))) + (call-next-method)) + (defmethod preferred-size ((self top-level) width-hint height-hint) (declare (ignore width-hint height-hint)) (let ((size (call-next-method))

1 0

[graphic-forms-cvs] r456 - in branches/graphic-forms-newtypes: . docs/manual src/demos/unblocked src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Apr '07

03 Apr '07

Author: junrue Date: Mon Apr 2 22:37:00 2007 New Revision: 456 Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/docs/manual/gfw-symbols.xml branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/control.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp Log: implemented new top-level style :fixed-size and modified gfw:pack to set min and max sizes when :fixed-size has been set; added another optional parameter to CREATE-CONTROL convenience function to allow control initializers to pass params to their implementations of COMPUTE-STYLE-FLAGS Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Mon Apr 2 22:37:00 2007 @@ -3,6 +3,14 @@ stdcall calling convention (FIXME: change checked in this past Feb., need to narrow down which snapshot actually has it). +. Implemented simple-mode status bars, which have a single text field. + Multi-part status bars, and nested widget support, will be added in a + future release. + +. Simplified the mechanism for specifying fixed, non-resizable windows by + adding a new GFW:TOP-LEVEL style called :FIXED-SIZE and enhancing GFW:PACK + to do the right thing if that style flag has been specified. + . 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/docs/manual/gfw-symbols.xml ============================================================================== --- branches/graphic-forms-newtypes/docs/manual/gfw-symbols.xml (original) +++ branches/graphic-forms-newtypes/docs/manual/gfw-symbols.xml Mon Apr 2 22:37:00 2007 @@ -1419,6 +1419,12 @@ </enum> One or more of the following optional styles: <enum> + <argument name=":fixed-size"> + <description> + The resulting window cannot be dragged to a new size, but a layout + manager can still resize it programmatically. + </description> + </argument> <argument name=":horizontal-scrollbar"/> <argument name=":status-bar"/> <argument name=":vertical-scrollbar"/> Modified: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp (original) +++ branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp Mon Apr 2 22:37:00 2007 @@ -112,7 +112,7 @@ :style :vertical :spacing +spacing+ :margins +margin+) - :style '(:workspace :status-bar))) + :style '(:fixed-size :workspace :status-bar))) (setf (gfw:menu-bar *unblocked-win*) menubar) (setf *scoreboard-panel* (make-instance 'scoreboard-panel :parent *unblocked-win* @@ -126,10 +126,7 @@ :buffer-size tile-buffer-size))) (setf (gfw:text *unblocked-win*) "UnBlocked") - (setf (gfw:resizable-p *unblocked-win*) nil) - (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) - (setf (gfw:minimum-size *unblocked-win*) size - (gfw:maximum-size *unblocked-win*) size)) + (gfw:pack *unblocked-win*) (new-unblocked nil nil) (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/control.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/control.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/control.lisp Mon Apr 2 22:37:00 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; control.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 @@ -45,10 +45,10 @@ (if (and (zerop (gfs::init-common-controls ic-ptr)) (/= (gfs::get-last-error) 0)) (warn 'gfs:win32-warning :detail "init-common-controls failed")))) -(defun create-control (ctrl parent text icc-flags &optional id) +(defun create-control (ctrl parent text icc-flags &optional id extra-data) (initialize-comctl-classes icc-flags) (multiple-value-bind (std-style ex-style) - (compute-style-flags ctrl) + (compute-style-flags ctrl extra-data) (let ((hwnd (create-window (system-classname-of ctrl) (or text " ") (gfs:handle parent) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp Mon Apr 2 22:37:00 2007 @@ -104,11 +104,16 @@ (max (first widths) (second widths)))) (defmethod compute-style-flags ((self status-bar) &rest extra-data) - (declare (ignore extra-data)) - (values (logior gfs::+ws-child+ gfs::+ws-visible+ gfs::+sbars-sizegrip+) 0)) + (let ((extra-bits (if (first extra-data) 0 gfs::+sbars-sizegrip+))) + (values (logior gfs::+ws-child+ gfs::+ws-visible+ extra-bits) 0))) (defmethod initialize-instance :after ((self status-bar) &key parent &allow-other-keys) - (let ((hctl (create-control self parent "" gfs::+icc-win95-classes+))) + (let ((hctl (create-control self + parent + "" + gfs::+icc-win95-classes+ + nil + (find :fixed-size (style-of parent))))) (gfs::send-message hctl gfs::+sb-simple+ 1 0)) (let ((widths (stb-get-border-widths self))) (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths))))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp Mon Apr 2 22:37:00 2007 @@ -111,13 +111,10 @@ ;; styles that can be combined ;; -#| - (:max (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - (:min (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - (:sysmenu (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - (:title (setf std-flags (logior std-flags gfs::+ws-caption+))) - (:top (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) -|# + (:fixed-size + (setf std-flags (logand std-flags + (lognot (logior gfs::+ws-maximizebox+ + gfs::+ws-thickframe+))))) (:horizontal-scrollbar (setf std-flags (logior std-flags gfs::+ws-hscroll+))) (:status-bar) ;; nothing to do, but need to allow this style symbol @@ -198,6 +195,13 @@ (when (and (maximum-size self) min-size) (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) +(defmethod pack ((win window)) + (if (find :fixed-size (style-of win)) + (let ((size (gfw:preferred-size win -1 -1))) + (setf (gfw:minimum-size win) size + (gfw:maximum-size win) size))) + (call-next-method)) + (defmethod preferred-size ((self top-level) width-hint height-hint) (declare (ignore width-hint height-hint)) (let ((size (call-next-method))

1 0

[graphic-forms-cvs] r455 - in trunk/src: demos/unblocked uitoolkit/widgets
by junrue＠common-lisp.net 01 Apr '07

01 Apr '07

Author: junrue Date: Sun Apr 1 00:30:42 2007 New Revision: 455 Modified: trunk/src/demos/unblocked/unblocked-controller.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/status-bar.lisp Log: implemented text and (setf text) for status-bar; unblocked now displays shape count and points scored via status-bar messages Modified: trunk/src/demos/unblocked/unblocked-controller.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-controller.lisp (original) +++ trunk/src/demos/unblocked/unblocked-controller.lisp Sun Apr 1 00:30:42 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; unblocked-controller.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 @@ -37,11 +37,13 @@ (defun ctrl-start-game () (model-new) + (update-status-bar "Ready.") (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) (defun ctrl-restart-game () (model-rollback) + (update-status-bar "Ready.") (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) @@ -82,10 +84,17 @@ (let ((tile-pnt (window->tiles point))) (when (and (eql button :left-button) shape-pnts) (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) - (let ((prev-level (model-level))) + (let ((prev-level (model-level)) + (orig-score (score-of *game*))) (update-model-score shape-pnts) + (update-status-bar (format nil + "Removed ~d tiles for ~d points." + (length shape-pnts) + (- (score-of *game*) orig-score))) (if (> (model-level) prev-level) + (progn (regenerate-model-tiles) + (update-status-bar "Ready.")) (update-model-tiles shape-pnts)) (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Apr 1 00:30:42 2007 @@ -61,6 +61,10 @@ (update-buffer (gfw:dispatcher panel)) (gfw:redraw panel)) +(defun update-status-bar (msg) + (if *unblocked-win* + (setf (gfw:text (gfw:status-bar-of *unblocked-win*)) msg))) + (defun reveal-unblocked (disp item) (declare (ignore disp item)) (ctrl-reveal-move)) @@ -129,7 +133,8 @@ (new-unblocked nil nil) (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) - (setf (gfw:image *unblocked-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) + (setf (gfw:image *unblocked-win*) + (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/status-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Sun Apr 1 00:30:42 2007 @@ -127,3 +127,9 @@ (widths (stb-get-border-widths self))) (gfs:make-size :width 0 :height (+ (gfs:size-height tmp-size) (* (second widths) 2) 1)))) + +(defmethod text ((sbar status-bar)) + (stb-get-text sbar 0)) + +(defmethod (setf text) (str (sbar status-bar)) + (stb-set-text sbar str))

1 0