[graphic-forms-cvs] r471 - in trunk/src: tests/uitoolkit uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Aug 13 05:09:34 UTC 2007
Author: junrue
Date: Mon Aug 13 01:09:25 2007
New Revision: 471
Modified:
trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp
trunk/src/uitoolkit/widgets/flow-layout.lisp
trunk/src/uitoolkit/widgets/layout-generics.lisp
trunk/src/uitoolkit/widgets/layout.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
fixed longstanding regression in calculation of wrapping extents; fixed flow layout unit tests
Modified: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp (original)
+++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Mon Aug 13 01:09:25 2007
@@ -1,7 +1,7 @@
;;;;
;;;; flow-layout-unit-tests.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
@@ -59,7 +59,7 @@
#'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))
(define-layout-test flow-layout-test4
- -1 25 20 20
+ -1 25 40 20
nil
'((0 0 20 10) (0 10 20 10) (20 0 20 10))
#'make-flow-layout *flow-uniform-kids* '(:vertical :wrap))
@@ -89,13 +89,13 @@
#'make-flow-layout *flow-uniform-kids* '(:vertical) 4)
(define-layout-test flow-layout-test9
- 45 18 0 0
+ 45 18 44 24
nil
'((0 0 20 10) (24 0 20 10) (0 14 20 10))
#'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)
(define-layout-test flow-layout-test10
- 30 25 0 0
+ 30 25 44 24
nil
'((0 0 20 10) (0 14 20 10) (24 0 20 10))
#'make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)
Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/flow-layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Aug 13 01:09:25 2007
@@ -34,24 +34,38 @@
(in-package :graphic-forms.uitoolkit.widgets)
;;;
-;;; helper functions
+;;; This implementation attempts to maximize code re-use by handling both
+;;; possible orientations with the same logic. Hence the terminology is a
+;;; little confusing. Here is a quick primer:
+;;;
+;;; primary axis -- the axis parallel to the layout's orientation
+;;;
+;;; secondary axis -- the axis orthogonal to the layout's orientation
+;;;
+;;; distance -- offset from one point to the next along the primary axis
+;;;
+;;; extent -- offset from one point to the next along the secondary axis
;;;
(defstruct flow-data
- (hint 0)
- (kid-sizes nil)
- (distance-total 0)
- (max-distance 0)
- (extent-total 0)
- (max-extent 0)
- (next-coord 0)
- (wrap-coord 0)
- (spacing 0)
- (distance-fn nil)
- (extent-fn nil)
- (limit-margin-fn nil)
- (start-margin-fn nil)
- (current nil))
+ (hint 0) ; the width or height hint passed to the layout manager
+ (kid-sizes nil) ; list of pairs of child widgets and their sizes
+ (distance-total 0) ; total (un-wrapped) widget size in primary axis
+ (max-distance 0) ; maximum widget size in primary axis
+ (max-extent 0) ; maximum widget size in secondary axis
+ (last-wrap-max-extent 0) ; maximum widget size in secondary axis for previous wrap
+ (next-coord 0) ; position in primary axis where next widget goes
+ (wrap-coord 0) ; position in secondary axis where next widget wraps to
+ (spacing 0) ; layout's spacing attribute
+ (distance-fn nil) ; either #'gfs:size-width or #'gfs:size-height
+ (extent-fn nil) ; opposite of distance-fn
+ (limit-margin-fn nil) ; either #'bottom-margin-of or #'right-margin-of
+ (start-margin-fn nil) ; either #'top-margin-of or #'left-margin-of
+ (current nil)) ; flow data list
+
+;;;
+;;; helper functions
+;;;
(defun init-flow-data (layout visible items width-hint height-hint)
(let ((state (if (find :vertical (style-of layout))
@@ -78,7 +92,6 @@
(dist (funcall (flow-data-distance-fn state) size))
(extent (funcall (flow-data-extent-fn state) size)))
(incf (flow-data-distance-total state) dist)
- (incf (flow-data-extent-total state) extent)
(if (< (flow-data-max-distance state) dist)
(setf (flow-data-max-distance state) dist))
(if (< (flow-data-max-extent state) extent)
@@ -98,12 +111,15 @@
(let ((curr-flow (flow-data-current state)))
(setf (flow-data-current state) nil)
(setf (flow-data-next-coord state) (funcall (flow-data-start-margin-fn state) layout))
- (incf (flow-data-wrap-coord state) (+ (flow-data-max-extent state) (flow-data-spacing state)))
+ (incf (flow-data-wrap-coord state) (+ (flow-data-last-wrap-max-extent state)
+ (flow-data-spacing state)))
+ (setf (flow-data-last-wrap-max-extent state) 0)
(reverse curr-flow)))
(defun new-flow-element (state layout kid kid-size)
(let ((pnt (gfs:make-point))
- (vertical (find :vertical (style-of layout))))
+ (vertical (find :vertical (style-of layout)))
+ (extent (funcall (flow-data-extent-fn state) kid-size)))
(if vertical
(setf (gfs:point-x pnt) (flow-data-wrap-coord state)
(gfs:point-y pnt) (flow-data-next-coord state))
@@ -111,6 +127,8 @@
(gfs:point-y pnt) (flow-data-wrap-coord state)))
(incf (flow-data-next-coord state) (+ (funcall (flow-data-distance-fn state) kid-size)
(flow-data-spacing state)))
+ (if (> extent (flow-data-last-wrap-max-extent state))
+ (setf (flow-data-last-wrap-max-extent state) extent))
(cons kid (gfs:make-rectangle :size kid-size :location pnt))))
;;;
@@ -118,36 +136,12 @@
;;;
(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint)
- (cleanup-disposed-items self)
- (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)))
- (vertical (find :vertical (style-of self)))
- (horizontal (find :horizontal (style-of self))))
- (let ((spacing-total (* (spacing-of self) (1- kid-count)))
- (state (init-flow-data self
- (visible-p container)
- (data-of self)
- (if vertical width-hint -1)
- (if vertical -1 height-hint))))
- (if (find :normalize (style-of self))
- (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count)))
- (cond
- (horizontal
- (gfs:make-size :width (+ (flow-data-distance-total state)
- horz-margin-total
- spacing-total)
- :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)))
- (t
- (error 'gfs:toolkit-error
- :detail (format nil "unrecognized flow layout style: ~a" (style-of self))))))))
+ (let ((data (compute-layout self container width-hint height-hint)))
+ (gfs:size (layout-bounds data
+ (list (left-margin-of self)
+ (top-margin-of self)
+ (right-margin-of self)
+ (bottom-margin-of self))))))
(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint)
(cleanup-disposed-items self)
Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout-generics.lisp Mon Aug 13 01:09:25 2007
@@ -1,7 +1,7 @@
;;;;
;;;; layout-generics.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
Modified: trunk/src/uitoolkit/widgets/layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout.lisp Mon Aug 13 01:09:25 2007
@@ -1,7 +1,7 @@
;;;;
;;;; layout.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
@@ -127,6 +127,22 @@
(unless (gfs:null-handle-p hdwp)
(gfs::end-defer-window-pos hdwp))))
+(defun layout-bounds (children margins)
+ (multiple-value-bind (min-x min-y max-x max-y)
+ (loop for entry in children
+ for location = (gfs:location (cdr entry))
+ for size = (gfs:size (cdr entry))
+ minimizing (gfs:point-x location) into min-x
+ minimizing (gfs:point-y location) into min-y
+ maximizing (+ (gfs:point-x location) (gfs:size-width size)) into max-x
+ maximizing (+ (gfs:point-y location) (gfs:size-height size)) into max-y
+ finally (return (values min-x min-y max-x max-y)))
+ (let ((location (gfs:make-point :x (- min-x (first margins))
+ :y (- min-y (second margins))))
+ (size (gfs:make-size :width (+ max-x (third margins))
+ :height (+ max-y (fourth margins)))))
+ (gfs:make-rectangle :location location :size size))))
+
;;;
;;; methods
;;;
@@ -162,6 +178,4 @@
(defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint)
(if (layout-p container)
(arrange-hwnds (compute-layout self container width-hint height-hint)
- (lambda (item)
- (declare (ignore item))
- +window-pos-flags+))))
+ (constantly +window-pos-flags+))))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Mon Aug 13 01:09:25 2007
@@ -181,7 +181,7 @@
(defmethod gfg:background-color ((self window))
(let ((hwnd (gfs:handle self))
(color nil))
- (if (string= (get-window-class-name self) *toplevel-erasebkgnd-window-classname*)
+ (if (string= (get-window-class-name hwnd) *toplevel-erasebkgnd-window-classname*)
(setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+)))
(setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))
color))
More information about the Graphic-forms-cvs
mailing list