[graphic-forms-cvs] r11 - in trunk: . src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Feb 19 21:50:51 UTC 2006
Author: junrue
Date: Sun Feb 19 15:50:50 2006
New Revision: 11
Added:
trunk/src/uitoolkit/widgets/layout-classes.lisp
trunk/src/uitoolkit/widgets/layouts.lisp
Modified:
trunk/graphic-forms-uitoolkit.asd
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/event-generics.lisp
trunk/src/uitoolkit/widgets/layout-generics.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
flow layout implementation
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Sun Feb 19 15:50:50 2006
@@ -87,6 +87,7 @@
:components
((:file "widget-constants")
(:file "widget-classes")
+ (:file "layout-classes")
(:file "thread-context")
(:file "message-generics")
(:file "event-generics")
@@ -100,4 +101,5 @@
(:file "widget-with-items")
(:file "menu")
(:file "event")
- (:file "window")))))))))
+ (:file "window")
+ (:file "layouts")))))))))
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Sun Feb 19 15:50:50 2006
@@ -205,7 +205,9 @@
#:control
#:event-dispatcher
#:event-source
+ #:flow-layout
#:item
+ #:layout-manager
#:menu
#:menu-item
#:widget
@@ -305,7 +307,6 @@
#:column-order
#:columns
#:compute-outer-size
- #:compute-size
#:copy
#:copy-area
#:current-font
@@ -408,7 +409,6 @@
#: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 Sun Feb 19 15:50:50 2006
@@ -67,8 +67,7 @@
(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))
- (pnt (gfi:make-point)))
+ (w (make-instance primary-type :dispatcher be)))
(setf (widget be) w)
(cond
((eql sub-type :push-button)
@@ -89,11 +88,8 @@
(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)))
- (gfw:pack w)
- (setf (gfw:location w) pnt)))
+ (setf (gfw:text w) (funcall (toggle-fn be)))))
(defmethod gfw:event-select ((d layout-tester-widget-events) time item rect)
(declare (ignorable time rect))
@@ -107,12 +103,11 @@
(let* ((mb (gfw:menu-bar *layout-tester-win*))
(menu (gfw:sub-menu mb 1)))
(gfw:clear-all menu)
- (gfw:with-children (*layout-tester-win* child-list)
- (mapc #'(lambda (child)
- (let ((it (make-instance 'gfw:menu-item)))
- (gfw:item-append menu it)
- (setf (gfw:text it) (gfw:text child))))
- child-list))))
+ (gfw:with-children (*layout-tester-win* kids)
+ (loop for k in kids
+ do (let ((it (make-instance 'gfw:menu-item)))
+ (gfw:item-append menu it)
+ (setf (gfw:text it) (gfw:text k)))))))
(defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
@@ -125,7 +120,8 @@
(let* ((menubar nil)
(fed (make-instance 'layout-tester-exit-dispatcher))
(cmd (make-instance 'layout-tester-child-menu-dispatcher)))
- (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)))
+ (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)
+ :layout-manager (make-instance 'gfw:flow-layout)))
(gfw:realize *layout-tester-win* nil :style-workspace)
(setf (gfw:size *layout-tester-win*) (gfi:make-size :width 250 :height 150))
(setf menubar (gfw:defmenusystem `(((:menu "&File")
@@ -136,6 +132,7 @@
(add-layout-tester-widget 'gfw:button :push-button)
(add-layout-tester-widget 'gfw:button :push-button)
(add-layout-tester-widget 'gfw:button :push-button)
+ (gfw:layout *layout-tester-win*)
(gfw:show *layout-tester-win*)))
(defun run-layout-tester ()
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Sun Feb 19 15:50:50 2006
@@ -39,10 +39,9 @@
(load-foreign-library "user32.dll")
(defcfun
- ("GetAncestor" get-ancestor)
+ ("BeginDeferWindowPos" begin-defer-window-pos)
HANDLE
- (hwnd HANDLE)
- (flags UINT))
+ (numwin INT))
(defcfun
("BeginPaint" begin-paint)
@@ -89,6 +88,18 @@
(param LPVOID))
(defcfun
+ ("DeferWindowPos" defer-window-pos)
+ HANDLE
+ (posinfo HANDLE)
+ (hwnd HANDLE)
+ (hwndafter HANDLE)
+ (x INT)
+ (y INT)
+ (cx INT)
+ (cy INT)
+ (flags UINT))
+
+(defcfun
("DefWindowProcA" def-window-proc)
LRESULT
(hwnd HANDLE)
@@ -117,6 +128,11 @@
(hwnd HANDLE))
(defcfun
+ ("EndDeferWindowPos" end-defer-window-pos)
+ BOOL
+ (posinfo HANDLE))
+
+(defcfun
("EndPaint" end-paint)
BOOL
(hwnd HANDLE)
@@ -158,6 +174,12 @@
(:return-type ffi:int))
(defcfun
+ ("GetAncestor" get-ancestor)
+ HANDLE
+ (hwnd HANDLE)
+ (flags UINT))
+
+(defcfun
("GetAsyncKeyState" get-async-key-state)
SHORT
(virtkey INT))
Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Feb 19 15:50:50 2006
@@ -121,7 +121,7 @@
(defgeneric event-mouse-down (dispatcher time point btn)
(:documentation "Implement this to respond to a mouse down event.")
(:method (dispatcher time point btn)
- (declare (ignorable dispatcher time ptn btn))))
+ (declare (ignorable dispatcher time point btn))))
(defgeneric event-mouse-enter (dispatcher time point btn)
(:documentation "Implement this to respond to a mouse passing into the bounds of an object.")
Added: trunk/src/uitoolkit/widgets/layout-classes.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/layout-classes.lisp Sun Feb 19 15:50:50 2006
@@ -0,0 +1,44 @@
+;;;;
+;;;; layout-classes.lisp
+;;;;
+;;;; Copyright (C) 2006, 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)
+
+(defclass layout-manager ()
+ ((style
+ :accessor style
+ :initarg :style
+ :initform nil))
+ (:documentation "Subclasses implement layout strategies on behalf of window objects."))
+
+(defclass flow-layout (layout-manager) ()
+ (:documentation "Window children are arranged in a row or column."))
Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout-generics.lisp Sun Feb 19 15:50:50 2006
@@ -33,8 +33,8 @@
(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 compute-size (layout win width-hint height-hint)
+ (:documentation "Computes and returns the size of the window's client area based on the layout's strategy."))
-(defgeneric perform-layout (mgr win)
- (:documentation "Lays out the children of the window based on this layout's strategy."))
+(defgeneric compute-layout (layout win width-hint height-hint)
+ (:documentation "Returns a list of conses (window . rectangle) describing the new bounds of each child window."))
Added: trunk/src/uitoolkit/widgets/layouts.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/layouts.lisp Sun Feb 19 15:50:50 2006
@@ -0,0 +1,106 @@
+;;;;
+;;;; layouts.lisp
+;;;;
+;;;; Copyright (C) 2006, 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)
+
+(defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+
+ gfs::+swp-noownerzorder+
+ gfs::+swp-noactivate+
+ gfs::+swp-nocopybits+))
+
+(defun perform-layout (layout win)
+ "Calls compute-layout and then handles the actual moving and resizing of a window's children."
+ (let* ((win-size (client-size win))
+ (kids (compute-layout layout win (gfi:size-width win-size) (gfi:size-height win-size)))
+ (hdwp (gfs::begin-defer-window-pos (length kids))))
+ (loop for k in kids
+ do (let* ((rect (cdr k))
+ (sz (gfi:size rect))
+ (pnt (gfi:location rect)))
+ (if (gfi:null-handle-p hdwp)
+ (gfs::set-window-pos (gfi:handle (car k))
+ (cffi:null-pointer)
+ (gfi:point-x pnt)
+ (gfi:point-y pnt)
+ (gfi:size-width sz)
+ (gfi:size-height sz)
+ +window-pos-flags+)
+ (setf hdwp (gfs::defer-window-pos hdwp
+ (gfi:handle (car k))
+ (cffi:null-pointer)
+ (gfi:point-x pnt)
+ (gfi:point-y pnt)
+ (gfi:size-width sz)
+ (gfi:size-height sz)
+ +window-pos-flags+)))))
+ (unless (gfi:null-handle-p hdwp)
+ (gfs::end-defer-window-pos hdwp))))
+
+;;;
+;;; flow-layout methods
+;;;
+
+(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint)
+ (error "not yet implemented"))
+
+(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint)
+ (let ((layout-style (gfw:style layout))
+ (entries nil)
+ (last-coord 0)
+ (last-dim 0))
+ (with-children (win kids)
+ (loop for k in kids
+ do (let ((kid-size (preferred-size k width-hint height-hint))
+ (pnt (gfi:make-point)))
+ (if (not (find :vertical layout-style))
+ (progn
+ (setf (gfi:point-x pnt) (+ last-coord last-dim))
+ (if (>= height-hint 0)
+ (setf (gfi:size-height kid-size) height-hint))
+ (setf last-coord (gfi:point-x pnt))
+ (setf last-dim (gfi:size-width kid-size)))
+ (progn
+ (setf (gfi:point-y pnt) (+ last-coord last-dim))
+ (if (>= width-hint 0)
+ (setf (gfi:size-width kid-size) width-hint))
+ (setf last-coord (gfi:point-y pnt))
+ (setf last-dim (gfi:size-height kid-size))))
+ (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries))))
+ (reverse entries)))
+
+(defmethod initialize-instance :after ((layout flow-layout) &key style)
+ (unless (listp style)
+ (setf style (list style)))
+ (if (and (null (find :horizontal style)) (null (find :vertical style)))
+ (setf (slot-value layout 'style) '(:horizontal))
+ (setf (slot-value layout 'style) style)))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Feb 19 15:50:50 2006
@@ -36,9 +36,6 @@
(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
@@ -80,7 +77,7 @@
(defclass window (widget)
((layout-p
- :reader :layout-p
+ :reader layout-p
:initform t)
(layout-manager
:accessor layout-manager
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Sun Feb 19 15:50:50 2006
@@ -126,6 +126,7 @@
(visit-child-widgets ,win #'(lambda (parent child)
(if (gfw:ancestor-p parent child)
(push child ,var))))
+ (nreverse ,var)
, at body))
(defun register-workspace-window-class ()
@@ -215,6 +216,10 @@
(setf (slot-value win 'layout-p) t)
(layout win))
+(defmethod event-resize ((d dispatcher) time size type)
+ (declare (ignorable time size type))
+ (layout win)) ; FIXME: this is a big flaw in event handling -- need the window here!
+
(defmethod hide ((win window))
(gfs::show-window (gfi:handle win) gfs::+sw-hide+))
More information about the Graphic-forms-cvs
mailing list