From junrue at common-lisp.net Sun Apr 1 04:01:48 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sat, 31 Mar 2007 23:01:48 -0500 (EST)
Subject: [graphic-forms-cvs] r452 - in branches/graphic-forms-newtypes/src:
tests/uitoolkit uitoolkit/widgets
Message-ID: <20070401040148.7252249021@common-lisp.net>
Author: junrue
Date: Sat Mar 31 23:01:47 2007
New Revision: 452
Modified:
branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp
branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp
branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp
branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp
Log:
stop double-counting status-bar height; add additional testcase
Modified: branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp (original)
+++ branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp Sat Mar 31 23:01:47 2007
@@ -1,7 +1,7 @@
;;;;
;;;; widget-tester.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
@@ -275,7 +275,7 @@
(setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))
(setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'widget-tester-events)
:layout (make-instance 'gfw:heap-layout)
- :style '(:frame)))
+ :style '(:frame :status-bar)))
(let* ((layout (gfw:layout-of *widget-tester-win*))
(test-panels (list (populate-list-box-test-panel)
(populate-slider-test-panel)))
Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp (original)
+++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp Sat Mar 31 23:01:47 2007
@@ -122,9 +122,6 @@
(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)))
@@ -140,16 +137,14 @@
(gfs:make-size :width (+ (flow-data-distance-total state)
horz-margin-total
spacing-total)
- :height (- (+ (flow-data-max-extent state)
- vert-margin-total)
- sbar-height)))
+ :height (+ (flow-data-max-extent state)
+ vert-margin-total)))
(vertical
(gfs:make-size :width (+ (flow-data-max-extent state)
horz-margin-total)
- :height (- (+ (flow-data-distance-total state)
- vert-margin-total
- spacing-total)
- sbar-height)))
+ :height (+ (flow-data-distance-total state)
+ vert-margin-total
+ spacing-total)))
(t
(error 'gfs:toolkit-error
:detail (format nil "unrecognized flow layout style: ~a" (style-of self))))))))
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 Sat Mar 31 23:01:47 2007
@@ -68,14 +68,6 @@
;;; methods
;;;
-(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
- (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))
(let ((std-flags 0)
Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp (original)
+++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Sat Mar 31 23:01:47 2007
@@ -75,7 +75,7 @@
(let* ((tc (thread-context))
(child (get-widget tc hwnd))
(parent (get-widget tc (cffi:make-pointer lparam))))
- (unless (or (null parent) (null child))
+ (unless (or (null parent) (null child) (typep child 'status-bar))
(let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+))
(tmp-list (child-visitor-results tc)))
(if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd)
From junrue at common-lisp.net Sun Apr 1 04:02:11 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sat, 31 Mar 2007 23:02:11 -0500 (EST)
Subject: [graphic-forms-cvs] r453 - in trunk/src: tests/uitoolkit
uitoolkit/widgets
Message-ID: <20070401040211.5366949021@common-lisp.net>
Author: junrue
Date: Sat Mar 31 23:02:09 2007
New Revision: 453
Modified:
trunk/src/tests/uitoolkit/widget-tester.lisp
trunk/src/uitoolkit/widgets/flow-layout.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
stop double-counting status-bar height; add additional testcase
Modified: trunk/src/tests/uitoolkit/widget-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/widget-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/widget-tester.lisp Sat Mar 31 23:02:09 2007
@@ -1,7 +1,7 @@
;;;;
;;;; widget-tester.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
@@ -275,7 +275,7 @@
(setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))
(setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'widget-tester-events)
:layout (make-instance 'gfw:heap-layout)
- :style '(:frame)))
+ :style '(:frame :status-bar)))
(let* ((layout (gfw:layout-of *widget-tester-win*))
(test-panels (list (populate-list-box-test-panel)
(populate-slider-test-panel)))
Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/flow-layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sat Mar 31 23:02:09 2007
@@ -122,9 +122,6 @@
(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)))
@@ -140,16 +137,14 @@
(gfs:make-size :width (+ (flow-data-distance-total state)
horz-margin-total
spacing-total)
- :height (- (+ (flow-data-max-extent state)
- vert-margin-total)
- sbar-height)))
+ :height (+ (flow-data-max-extent state)
+ vert-margin-total)))
(vertical
(gfs:make-size :width (+ (flow-data-max-extent state)
horz-margin-total)
- :height (- (+ (flow-data-distance-total state)
+ :height (+ (flow-data-distance-total state)
vert-margin-total
- spacing-total)
- sbar-height)))
+ spacing-total)))
(t
(error 'gfs:toolkit-error
:detail (format nil "unrecognized flow layout style: ~a" (style-of self))))))))
Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp (original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Sat Mar 31 23:02:09 2007
@@ -68,14 +68,6 @@
;;; methods
;;;
-(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
- (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))
(let ((std-flags 0)
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Sat Mar 31 23:02:09 2007
@@ -75,7 +75,7 @@
(let* ((tc (thread-context))
(child (get-widget tc hwnd))
(parent (get-widget tc (cffi:make-pointer lparam))))
- (unless (or (null parent) (null child))
+ (unless (or (null parent) (null child) (typep child 'status-bar))
(let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+))
(tmp-list (child-visitor-results tc)))
(if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd)
From junrue at common-lisp.net Sun Apr 1 05:30:18 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 1 Apr 2007 00:30:18 -0500 (EST)
Subject: [graphic-forms-cvs] r454 - in branches/graphic-forms-newtypes/src:
demos/unblocked uitoolkit/widgets
Message-ID: <20070401053018.EA4D913010@common-lisp.net>
Author: junrue
Date: Sun Apr 1 00:30:17 2007
New Revision: 454
Modified:
branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp
branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp
branches/graphic-forms-newtypes/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: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp (original)
+++ branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp Sun Apr 1 00:30:17 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)
- (regenerate-model-tiles)
+ (progn
+ (regenerate-model-tiles)
+ (update-status-bar "Ready."))
(update-model-tiles shape-pnts))
(update-panel (get-scoreboard-panel))
(update-panel (get-tiles-panel)))
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 Sun Apr 1 00:30:17 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: 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 Sun Apr 1 00:30:17 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))
From junrue at common-lisp.net Sun Apr 1 05:30:43 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 1 Apr 2007 00:30:43 -0500 (EST)
Subject: [graphic-forms-cvs] r455 - in trunk/src: demos/unblocked
uitoolkit/widgets
Message-ID: <20070401053043.8CAB913010@common-lisp.net>
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))
From junrue at common-lisp.net Tue Apr 3 02:37:04 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 2 Apr 2007 22:37:04 -0400 (EDT)
Subject: [graphic-forms-cvs] r456 - in branches/graphic-forms-newtypes: .
docs/manual src/demos/unblocked src/uitoolkit/widgets
Message-ID: <20070403023704.180C1671A6@common-lisp.net>
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 @@
One or more of the following optional styles:
+
+
+ The resulting window cannot be dragged to a new size, but a layout
+ manager can still resize it programmatically.
+
+
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))
From junrue at common-lisp.net Tue Apr 3 02:37:55 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 2 Apr 2007 22:37:55 -0400 (EDT)
Subject: [graphic-forms-cvs] r457 - in trunk: docs/manual
src/demos/unblocked src/uitoolkit/widgets
Message-ID: <20070403023755.36CA7742F8@common-lisp.net>
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 @@
One or more of the following optional styles:
+
+
+ The resulting window cannot be dragged to a new size, but a layout
+ manager can still resize it programmatically.
+
+
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))
From junrue at common-lisp.net Tue Apr 3 02:39:40 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 2 Apr 2007 22:39:40 -0400 (EDT)
Subject: [graphic-forms-cvs] r458 - trunk
Message-ID: <20070403023940.A6A60742F8@common-lisp.net>
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.
From junrue at common-lisp.net Tue Apr 3 04:45:20 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Tue, 3 Apr 2007 00:45:20 -0400 (EDT)
Subject: [graphic-forms-cvs] r459 - in branches/graphic-forms-newtypes: .
src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20070403044520.2272B4E008@common-lisp.net>
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
From junrue at common-lisp.net Tue Apr 3 04:45:39 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Tue, 3 Apr 2007 00:45:39 -0400 (EDT)
Subject: [graphic-forms-cvs] r460 - in trunk: . src/uitoolkit/system
src/uitoolkit/widgets
Message-ID: <20070403044539.241CC4E008@common-lisp.net>
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
From junrue at common-lisp.net Thu Apr 5 04:25:55 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu, 5 Apr 2007 00:25:55 -0400 (EDT)
Subject: [graphic-forms-cvs] r461 - in branches/graphic-forms-newtypes: .
src src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20070405042555.EBBD83C04C@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.")
From junrue at common-lisp.net Thu Apr 5 04:26:14 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu, 5 Apr 2007 00:26:14 -0400 (EDT)
Subject: [graphic-forms-cvs] r462 - in trunk: . src/uitoolkit/widgets
Message-ID: <20070405042614.A5C333C04E@common-lisp.net>
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")
From junrue at common-lisp.net Thu Apr 5 04:27:34 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu, 5 Apr 2007 00:27:34 -0400 (EDT)
Subject: [graphic-forms-cvs] r463 - in branches/graphic-forms-newtypes: .
src/uitoolkit/widgets
Message-ID: <20070405042734.C7B7F3C04C@common-lisp.net>
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")
From junrue at common-lisp.net Thu Apr 5 04:30:17 2007
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu, 5 Apr 2007 00:30:17 -0400 (EDT)
Subject: [graphic-forms-cvs] r464 - in trunk: . src/uitoolkit/system
src/uitoolkit/widgets
Message-ID: <20070405043017.74F913C04C@common-lisp.net>
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.")