[graphic-forms-cvs] r461 - in branches/graphic-forms-newtypes: . src src/uitoolkit/system src/uitoolkit/widgets

[junrue at common-lisp.net]

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.")