[graphic-forms-cvs] r10 - in trunk/src: . tests/uitoolkit uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Feb 14 06:27:31 UTC 2006
Author: junrue
Date: Tue Feb 14 00:27:31 2006
New Revision: 10
Modified:
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/widgets/layout-generics.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
initial implementation of window side of the layout management protocol
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Tue Feb 14 00:27:31 2006
@@ -304,7 +304,8 @@
#:column-index
#:column-order
#:columns
- #:compute-trim
+ #:compute-outer-size
+ #:compute-size
#:copy
#:copy-area
#:current-font
@@ -407,6 +408,7 @@
#:parent
#:paste
#:peer
+ #:perform-layout
#:preferred-size
#:realize
#:redraw
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Feb 14 00:27:31 2006
@@ -67,7 +67,8 @@
(defun add-layout-tester-widget (primary-type sub-type)
(let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*))
- (w (make-instance primary-type :dispatcher be)))
+ (w (make-instance primary-type :dispatcher be))
+ (pnt (gfi:make-point)))
(setf (widget be) w)
(cond
((eql sub-type :push-button)
@@ -81,22 +82,18 @@
(setf flag nil)
(format nil "~d ~a" (id be) +btn-text-after+))))))
(incf *button-counter*)))
+#|
+ (gfw:with-children (*layout-tester-win* child-list)
+ (let ((child (first (reverse (rest child-list)))))
+ (unless (null child)
+ (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location child))
+ (gfi:size-width (gfw:size child)))))))
+|#
+ (setf (gfi:point-x pnt) (* 77 (1- *button-counter*)))
(gfw:realize w *layout-tester-win* sub-type)
(setf (gfw:text w) (funcall (toggle-fn be)))
- (let ((pnt (gfi:make-point)))
- (gfw:with-children (*layout-tester-win* child-list)
- (let ((last-child (car (last (cdr child-list)))))
- (unless (null last-child)
-(format t "****~%")
-(format t "widget: ~a~%" (gfw:text last-child))
-(format t "location: ~a~%" (gfw:location last-child))
-(format t "size: ~a~%" (gfw:size last-child))
- (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location last-child))
- (gfi:size-width (gfw:size last-child)))))))
- (setf (gfw:location w) pnt)
-(format t "++++~%")
-(format t "location: ~a~%" (gfw:location w)))
- (setf (gfw:size w) (gfw:preferred-size w -1 -1))))
+ (gfw:pack w)
+ (setf (gfw:location w) pnt)))
(defmethod gfw:event-select ((d layout-tester-widget-events) time item rect)
(declare (ignorable time rect))
Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout-generics.lisp Tue Feb 14 00:27:31 2006
@@ -32,3 +32,9 @@
;;;;
(in-package :graphic-forms.uitoolkit.widgets)
+
+(defgeneric compute-size (mgr win width-hint height-hint)
+ (:documentation "Computes and returns the size of the window's client area based on this layout's strategy."))
+
+(defgeneric perform-layout (mgr win)
+ (:documentation "Lays out the children of the window based on this layout's strategy."))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Feb 14 00:27:31 2006
@@ -36,6 +36,9 @@
(defclass event-dispatcher () ()
(:documentation "Instances of this class receive events on behalf of user interface objects."))
+(defclass layout-manager () ()
+ (:documentation "Subclasses implement layout strategies on behalf of window objects."))
+
(defclass event-source (gfi:native-object)
((dispatcher
:accessor dispatcher
@@ -75,5 +78,12 @@
(defclass menu (widget-with-items) ()
(:documentation "The menu class represents a container for menu items (and submenus)."))
-(defclass window (widget) ()
- (:documentation "The window class is the base class for top-level window objects."))
+(defclass window (widget)
+ ((layout-p
+ :reader :layout-p
+ :initform t)
+ (layout-manager
+ :accessor layout-manager
+ :initarg :layout-manager
+ :initform nil))
+ (:documentation "The window class is the base class for widgets that serve as containers (including top-level windows)."))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Feb 14 00:27:31 2006
@@ -96,8 +96,8 @@
(defgeneric compute-style-flags (object &rest style)
(:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports."))
-(defgeneric compute-trim (object desired-rect)
- (:documentation "Return a rectangle describing the area require to enclose the specified desired client area and this object's trim."))
+(defgeneric compute-outer-size (object desired-client-size)
+ (:documentation "Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim."))
(defgeneric copy (object)
(:documentation "Copies the current selection to the clipboard."))
@@ -222,12 +222,6 @@
(defgeneric layout (object)
(:documentation "Set the size and location of this object's children."))
-(defgeneric layout-manager (object)
- (:documentation "Returns the layout manager associated with this object."))
-
-(defgeneric layout-p (object)
- (:documentation "Return T if this object is configured to allow layout management of children, or nil if layout has been disabled."))
-
(defgeneric lines-visible-p (object)
(:documentation "Returns T if the object's lines are visible; nil otherwise."))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Tue Feb 14 00:27:31 2006
@@ -105,6 +105,9 @@
gfs::+swp-nosize+))
(error 'gfs:win32-error :detail "set-window-pos failed")))
+(defmethod pack ((w widget))
+ (setf (size w) (preferred-size w -1 -1)))
+
(defmethod redraw ((w widget))
(let ((hwnd (gfi:handle w)))
(unless (gfi:null-handle-p hwnd)
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Tue Feb 14 00:27:31 2006
@@ -137,6 +137,17 @@
;;; methods
;;;
+(defmethod compute-outer-size ((win window) desired-client-size)
+ (let ((client-sz (client-size win))
+ (outer-sz (size win))
+ (trim-sz (gfi:make-size :width (gfi:size-width desired-client-size)
+ :height (gfi:size-height desired-client-size))))
+ (incf (gfi:size-width trim-sz) (- (gfi:size-width outer-sz)
+ (gfi:size-width client-sz)))
+ (incf (gfi:size-height trim-sz) (- (gfi:size-height outer-sz)
+ (gfi:size-height client-sz)))
+ trim-sz))
+
(defmethod compute-style-flags ((win window) &rest style)
(declare (ignore win))
(let ((std-flags 0)
@@ -190,6 +201,9 @@
(flatten style))
(values std-flags ex-flags)))
+(defmethod disable-layout ((win window))
+ (setf (slot-value win 'layout-p) nil))
+
(defmethod gfi:dispose ((win window))
(let ((m (menu-bar win)))
(unless (null m)
@@ -197,6 +211,10 @@
(remove-widget (thread-context) (gfi:handle m))))
(call-next-method))
+(defmethod enable-layout ((win window))
+ (setf (slot-value win 'layout-p) t)
+ (layout win))
+
(defmethod hide ((win window))
(gfs::show-window (gfi:handle win) gfs::+sw-hide+))
@@ -207,6 +225,11 @@
(outer-location w pnt)
pnt))
+(defmethod layout ((win window))
+ (let ((mgr (layout-manager win)))
+ (when (and (layout-p win) mgr)
+ (perform-layout mgr win))))
+
(defmethod menu-bar ((win window))
(let ((hmenu (gfs::get-menu (gfi:handle win))))
(if (gfi:null-handle-p hmenu)
@@ -227,6 +250,17 @@
(gfs::set-menu hwnd (gfi:handle m))
(gfs::draw-menu-bar hwnd)))
+(defmethod pack ((win window))
+ (layout win)
+ (call-next-method))
+
+(defmethod preferred-size ((win window) width-hint height-hint)
+ (let ((mgr (layout-manager win)))
+ (if (and (layout-p win) mgr)
+ (let ((new-client-sz (compute-size mgr win width-hint height-hint)))
+ (compute-outer-size win new-client-sz))
+ (size win))))
+
(defmethod realize ((win window) parent &rest style)
(if (not (null parent))
(error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future
More information about the Graphic-forms-cvs
mailing list