November 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r397 - trunk/src/tests/uitoolkit
by junrue＠common-lisp.net 18 Nov '06

18 Nov '06

Author: junrue Date: Fri Nov 17 20:01:47 2006 New Revision: 397 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp Log: visual test case for border-layout Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Fri Nov 17 20:01:47 2006 @@ -142,10 +142,10 @@ (select-lb-content lb1 (gfw:selected-p btn)) (manage-lb-button-states lb1 btn-right nil btn-all btn-none) (setf latch nil))) - + (outer-layout (make-instance 'gfw:border-layout :spacing 4 :margins 4)) (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* - :layout (make-instance 'gfw:flow-layout :spacing 4 :margins 4))) + :layout outer-layout)) (lb1-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent outer-panel :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) @@ -163,6 +163,7 @@ :style '(:multiple-select) :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) + (setf (gfw:layout-attribute outer-layout lb1-panel :left) t) (setf btn-right (make-instance 'gfw:button :parent btn-panel :text " ==> " @@ -187,6 +188,7 @@ :style '(:check-box) :callback btn-select-callback)) (gfw:pack btn-panel) + (setf (gfw:layout-attribute outer-layout btn-panel :center) t) (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel @@ -194,6 +196,7 @@ :style '(:extend-select :scrollbar-always) :items (subseq *list-box-test-data* 4))) (gfw:pack lb2-panel) + (setf (gfw:layout-attribute outer-layout lb2-panel :right) t) (gfw:pack outer-panel) ;; FIXME: need to think of a more elegant solution for the following @@ -208,6 +211,7 @@ (setf (gfw:items-of lb1) *list-box-test-data*) (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) (gfw:delete-all lb2) + outer-panel)) (defun thumb->string (thing)

1 0

[graphic-forms-cvs] r396 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 17 Nov '06

17 Nov '06

Author: junrue Date: Fri Nov 17 18:46:33 2006 New Revision: 396 Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/widgets/border-layout.lisp Log: implemented border-layout margins Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Fri Nov 17 18:46:33 2006 @@ -93,6 +93,6 @@ #'make-border-layout *all-border-kids*) (define-layout-test border-layout-test7 - -1 25 80 25 - '((20 2 40 20) (0 0 80 2) (0 2 20 20) (0 22 80 2) (60 2 20 20)) - #'make-border-layout *all-border-kids*) + -1 -1 90 58 + '((24 8 40 40) (4 3 80 5) (4 8 20 40) (4 48 80 5) (64 8 20 40)) + #'make-border-layout *all-border-kids* 4 3 6 5) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Fri Nov 17 18:46:33 2006 @@ -48,19 +48,14 @@ (loop for kid in kids do (gfw::append-layout-item layout kid)) layout)) -(defun make-border-layout (kids &optional spacing left-margin top-margin right-margin bottom-margin) +(defun make-border-layout (kids &optional left-margin top-margin right-margin bottom-margin) (let ((layout (make-instance 'gfw:border-layout - :left-margin (or left-margin 0) + :left-margin (or left-margin 0) :top-margin (or top-margin 0) :right-margin (or right-margin 0) - :bottom-margin (or bottom-margin 0))) - (top-kid (first kids)) - (right-kid (second kids)) - (bottom-kid (third kids)) - (left-kid (fourth kids)) - (center-kid (fifth kids))) + :bottom-margin (or bottom-margin 0)))) (loop for kid in kids - for region in '(:top :left :bottom :right :center) + for region in '(:top :right :bottom :left :center) when kid do (progn (gfw::append-layout-item layout kid) Modified: trunk/src/uitoolkit/widgets/border-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/border-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/border-layout.lisp Fri Nov 17 18:46:33 2006 @@ -93,14 +93,18 @@ (gfs:size-height c-size) (gfs:size-height r-size)))) (setf (borders-outer-size data) - (gfs:make-size :width (max (gfs:size-width t-size) - (gfs:size-width b-size) - (+ (gfs:size-width l-size) - (gfs:size-width c-size) - (gfs:size-width r-size))) + (gfs:make-size :width (+ (max (gfs:size-width t-size) + (gfs:size-width b-size) + (+ (gfs:size-width l-size) + (gfs:size-width c-size) + (gfs:size-width r-size))) + (left-margin-of layout) + (right-margin-of layout)) :height (+ (gfs:size-height t-size) (gfs:size-height (borders-inside-size data)) - (gfs:size-height b-size)))) + (gfs:size-height b-size) + (top-margin-of layout) + (bottom-margin-of layout)))) data)) (defun top-border-rect (data) @@ -108,55 +112,68 @@ (return-from top-border-rect *empty-rect*)) (or (borders-top-rect data) (setf (borders-top-rect data) - (gfs:create-rectangle :width (gfs:size-width (borders-outer-size data)) - :height (borders-pref-top-height data))))) + (let ((layout (borders-layout data)) + (size (borders-outer-size data))) + (gfs:create-rectangle :x (left-margin-of layout) + :y (top-margin-of layout) + :width (- (gfs:size-width size) + (+ (left-margin-of layout) + (right-margin-of layout))) + :height (borders-pref-top-height data)))))) (defun bottom-border-rect (data) (unless (borders-bottom-widget data) (return-from bottom-border-rect *empty-rect*)) (or (borders-bottom-rect data) - (let ((ypos (- (gfs:size-height (borders-outer-size data)) - (borders-pref-bottom-height data)))) - (setf (borders-bottom-rect data) - (gfs:create-rectangle :y ypos - :width (gfs:size-width (borders-outer-size data)) + (setf (borders-bottom-rect data) + (let ((layout (borders-layout data)) + (size (borders-outer-size data))) + (gfs:create-rectangle :x (left-margin-of layout) + :y (- (gfs:size-height size) + (borders-pref-bottom-height data) + (bottom-margin-of layout)) + :width (- (gfs:size-width size) + (+ (left-margin-of layout) + (right-margin-of layout))) :height (borders-pref-bottom-height data)))))) (defun left-border-rect (data) (unless (borders-left-widget data) (return-from left-border-rect *empty-rect*)) (or (borders-left-rect data) - (let ((ypos (gfs:size-height (gfs:size (top-border-rect data)))) - (inside-height (gfs:size-height (borders-inside-size data)))) + (let ((layout (borders-layout data))) (setf (borders-left-rect data) - (gfs:create-rectangle :y ypos + (gfs:create-rectangle :x (left-margin-of layout) + :y (+ (top-margin-of layout) + (gfs:size-height (gfs:size (top-border-rect data)))) :width (borders-pref-left-width data) - :height inside-height))))) + :height (gfs:size-height (borders-inside-size data))))))) (defun right-border-rect (data) (unless (borders-right-widget data) (return-from right-border-rect *empty-rect*)) (or (borders-right-rect data) - (let ((xpos (+ (gfs:size-width (gfs:size (left-border-rect data))) - (gfs:size-width (gfs:size (center-border-rect data))))) - (ypos (gfs:size-height (gfs:size (top-border-rect data)))) - (inside-height (gfs:size-height (borders-inside-size data)))) + (let ((layout (borders-layout data))) (setf (borders-right-rect data) - (gfs:create-rectangle :x xpos - :y ypos + (gfs:create-rectangle :x (+ (left-margin-of layout) + (gfs:size-width (gfs:size (left-border-rect data))) + (gfs:size-width (gfs:size (center-border-rect data)))) + :y (+ (top-margin-of layout) + (gfs:size-height (gfs:size (top-border-rect data)))) :width (borders-pref-right-width data) - :height inside-height))))) + :height (gfs:size-height (borders-inside-size data))))))) (defun center-border-rect (data) (unless (borders-center-widget data) (return-from center-border-rect *empty-rect*)) (or (borders-center-rect data) - (let ((xpos (gfs:size-width (gfs:size (left-border-rect data)))) - (ypos (gfs:size-height (gfs:size (top-border-rect data)))) + (let ((layout (borders-layout data)) (size (borders-inside-size data))) (setf (borders-center-rect data) - (gfs:create-rectangle :x xpos - :y ypos + (gfs:create-rectangle :x (+ (left-margin-of layout) + (gfs:size-width (gfs:size (left-border-rect data)))) + :y (+ (top-margin-of layout) + (gfs:size-height (gfs:size (top-border-rect data)))) :width (gfs:size-width size) :height (gfs:size-height size))))))

1 0

[graphic-forms-cvs] r395 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Nov '06

17 Nov '06

Author: junrue Date: Fri Nov 17 14:34:40 2006 New Revision: 395 Modified: trunk/docs/manual/gfw-symbols.xml trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/widgets/border-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp Log: rewrote border-layout; added unit-test cases Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Fri Nov 17 14:34:40 2006 @@ -98,7 +98,11 @@ The :top and :bottom components may be stretched horizontally, while the :left and :right components may be stretched vertically. The :center component will be sized to fill the remaining space. Each component's extent on the - secondary axis is determined by <reftopic>gfw:preferred-size</reftopic>. + secondary axis is determined by <reftopic>gfw:preferred-size</reftopic>. When + positive <emphasis>width-hint</emphasis> and/or <emphasis>height-hint</emphasis> + values are provided to <reftopic>gfw:layout</reftopic>, the available space + is parceled out in amounts proportional to the preferred sizes for each + component. </para> </description> <initargs> Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Fri Nov 17 14:34:40 2006 @@ -33,32 +33,66 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *all-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) - (make-instance 'mock-widget :min-size *child-size-2*) - (make-instance 'mock-widget :min-size *child-size-1*) - (make-instance 'mock-widget :min-size *child-size-2*) - (make-instance 'mock-widget :min-size *child-size-3*))) - -(defvar *outer-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) - (make-instance 'mock-widget :min-size *child-size-2*) - (make-instance 'mock-widget :min-size *child-size-1*) - (make-instance 'mock-widget :min-size *child-size-2*) +(defvar *all-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top + (make-instance 'mock-widget :min-size *child-size-2*) ; right + (make-instance 'mock-widget :min-size *child-size-1*) ; bottom + (make-instance 'mock-widget :min-size *child-size-2*) ; left + (make-instance 'mock-widget :min-size *child-size-3*))) ; center + +(defvar *outer-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top + (make-instance 'mock-widget :min-size *child-size-2*) ; right + (make-instance 'mock-widget :min-size *child-size-1*) ; bottom + (make-instance 'mock-widget :min-size *child-size-2*) ; left nil)) +(defvar *top-right-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top + (make-instance 'mock-widget :min-size *child-size-2*) ; right + nil nil nil)) + +(defvar *top-bottom-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top + nil + (make-instance 'mock-widget :min-size *child-size-1*) ; bottom + nil nil)) + (defvar *center-border-kid* (list nil nil nil nil (make-instance 'mock-widget :min-size *child-size-3*))) +;;; +;;; NOTE: the rects to be validated in each test must be specified in the +;;; the following order: center, top, left, bottom, right +;;; + (define-layout-test border-layout-test1 -1 -1 80 50 - '((0 45 80 5) (60 5 20 40) (0 5 20 40) (0 0 80 5) (20 5 40 40)) + '((20 5 40 40) (0 0 80 5) (0 5 20 40) (0 45 80 5) (60 5 20 40)) #'make-border-layout *all-border-kids*) (define-layout-test border-layout-test2 -1 -1 40 20 - '((0 15 40 5) (20 5 20 10) (0 5 20 10) (0 0 40 5)) + '((0 0 40 5) (0 5 20 10) (0 15 40 5) (20 5 20 10)) #'make-border-layout *outer-border-kids*) (define-layout-test border-layout-test3 -1 -1 40 40 '((0 0 40 40)) #'make-border-layout *center-border-kid*) + +(define-layout-test border-layout-test4 + -1 -1 25 15 + '((0 0 25 5) (0 5 20 10)) + #'make-border-layout *top-right-border-kids*) + +(define-layout-test border-layout-test5 + -1 -1 25 10 + '((0 0 25 5) (0 5 25 5)) + #'make-border-layout *top-bottom-border-kids*) + +(define-layout-test border-layout-test6 + 26 -1 26 50 + '((6 5 13 40) (0 0 26 5) (0 5 6 40) (0 45 26 5) (19 5 6 40)) + #'make-border-layout *all-border-kids*) + +(define-layout-test border-layout-test7 + -1 25 80 25 + '((20 2 40 20) (0 0 80 2) (0 2 20 20) (0 22 80 2) (60 2 20 20)) + #'make-border-layout *all-border-kids*) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Fri Nov 17 14:34:40 2006 @@ -59,21 +59,12 @@ (bottom-kid (third kids)) (left-kid (fourth kids)) (center-kid (fifth kids))) - (when top-kid - (gfw::append-layout-item layout top-kid) - (setf (gfw:layout-attribute layout top-kid :top) t)) - (when right-kid - (gfw::append-layout-item layout right-kid) - (setf (gfw:layout-attribute layout right-kid :right) t)) - (when bottom-kid - (gfw::append-layout-item layout bottom-kid) - (setf (gfw:layout-attribute layout bottom-kid :bottom) t)) - (when left-kid - (gfw::append-layout-item layout left-kid) - (setf (gfw:layout-attribute layout left-kid :left) t)) - (when center-kid - (gfw::append-layout-item layout center-kid) - (setf (gfw:layout-attribute layout center-kid :center) t)) + (loop for kid in kids + for region in '(:top :left :bottom :right :center) + when kid + do (progn + (gfw::append-layout-item layout kid) + (setf (gfw:layout-attribute layout kid region) t))) layout)) (defun validate-image (image expected-size expected-depth) Modified: trunk/src/uitoolkit/widgets/border-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/border-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/border-layout.lisp Fri Nov 17 14:34:40 2006 @@ -37,67 +37,128 @@ ;;; helpers ;;; -(declaim (inline total-border-layout-width)) -(defun total-border-layout-width (cwidth twidth lwidth bwidth rwidth) - (max twidth bwidth (+ lwidth cwidth rwidth))) - -(declaim (inline inside-border-layout-width)) -(defun inside-border-layout-width (cwidth twidth lwidth bwidth rwidth) - (max cwidth (- twidth lwidth rwidth) (- bwidth lwidth rwidth))) - -(declaim (inline inside-border-layout-height)) -(defun inside-border-layout-height (cheight lheight rheight) - (max cheight lheight rheight)) - (eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro with-border-components ((layout center top left bottom right) &body body) - `(progn - (let ((,center (first (obtain-children-with-attribute ,layout :center))) - (,top (first (obtain-children-with-attribute ,layout :top))) - (,left (first (obtain-children-with-attribute ,layout :left))) - (,bottom (first (obtain-children-with-attribute ,layout :bottom))) - (,right (first (obtain-children-with-attribute ,layout :right)))) - ,@body))) - - (defmacro with-border-sizes ((layout center top left bottom right - total-width inside-width inside-height) &body body) - (let ((nil-size (gensym)) - (c-size (gensym)) - (t-size (gensym)) - (l-size (gensym)) - (b-size (gensym)) - (r-size (gensym)) - (c-widget (gensym)) - (t-widget (gensym)) - (l-widget (gensym)) - (r-widget (gensym)) - (b-widget (gensym))) - `(with-border-components (,layout ,c-widget ,t-widget ,l-widget ,b-widget ,r-widget) - (let* ((,nil-size (gfs:make-size)) - (,c-size (if ,c-widget (preferred-size (first ,c-widget) -1 -1) ,nil-size)) - (,t-size (if ,t-widget (preferred-size (first ,t-widget) -1 -1) ,nil-size)) - (,l-size (if ,l-widget (preferred-size (first ,l-widget) -1 -1) ,nil-size)) - (,b-size (if ,b-widget (preferred-size (first ,b-widget) -1 -1) ,nil-size)) - (,r-size (if ,r-widget (preferred-size (first ,r-widget) -1 -1) ,nil-size)) - (,center (cons (first ,c-widget) ,c-size)) - (,top (cons (first ,t-widget) ,t-size)) - (,left (cons (first ,l-widget) ,l-size)) - (,bottom (cons (first ,b-widget) ,b-size)) - (,right (cons (first ,r-widget) ,r-size)) - (,total-width (total-border-layout-width (gfs:size-width ,c-size) - (gfs:size-width ,t-size) - (gfs:size-width ,l-size) - (gfs:size-width ,b-size) - (gfs:size-width ,r-size))) - (,inside-width (inside-border-layout-width (gfs:size-width ,c-size) - (gfs:size-width ,t-size) - (gfs:size-width ,l-size) - (gfs:size-width ,b-size) - (gfs:size-width ,r-size))) - (,inside-height (inside-border-layout-height (gfs:size-height ,c-size) - (gfs:size-height ,l-size) - (gfs:size-height ,r-size)))) - ,@body))))) + (defstruct borders layout hint-size inside-size outer-size + pref-top-height pref-left-width pref-right-width pref-bottom-height + center-widget top-widget left-widget bottom-widget right-widget + center-rect top-rect left-rect bottom-rect right-rect)) + +(defun map-border-rects (data map-func) + (loop for region in '(center top left bottom right) + for sym = (symbol-name region) + for widget-acc = (find-symbol (concatenate 'string "BORDERS-" sym "-WIDGET") :gfw) + for rect-acc = (find-symbol (concatenate 'string "BORDERS-" sym "-RECT") :gfw) + for widget = (funcall widget-acc data) + when widget + collect (funcall map-func widget (funcall rect-acc data)))) + +(defun init-borders (layout width-hint height-hint) + (let* ((data (make-borders + :layout layout + :hint-size (gfs:make-size :width width-hint + :height height-hint) + :center-widget (first (first (obtain-children-with-attribute layout :center))) + :top-widget (first (first (obtain-children-with-attribute layout :top))) + :left-widget (first (first (obtain-children-with-attribute layout :left))) + :bottom-widget (first (first (obtain-children-with-attribute layout :bottom))) + :right-widget (first (first (obtain-children-with-attribute layout :right))))) + (c-size (if (borders-center-widget data) + (preferred-size (borders-center-widget data) -1 -1) + (gfs:size *empty-rect*))) + (t-size (if (borders-top-widget data) + (preferred-size (borders-top-widget data) -1 -1) + (gfs:size *empty-rect*))) + (l-size (if (borders-left-widget data) + (preferred-size (borders-left-widget data) -1 -1) + (gfs:size *empty-rect*))) + (b-size (if (borders-bottom-widget data) + (preferred-size (borders-bottom-widget data) -1 -1) + (gfs:size *empty-rect*))) + (r-size (if (borders-right-widget data) + (preferred-size (borders-right-widget data) -1 -1) + (gfs:size *empty-rect*)))) + (setf (borders-pref-top-height data) (gfs:size-height t-size) + (borders-pref-left-width data) (gfs:size-width l-size) + (borders-pref-right-width data) (gfs:size-width r-size) + (borders-pref-bottom-height data) (gfs:size-height b-size)) + (setf (borders-inside-size data) + (gfs:make-size :width (max (gfs:size-width c-size) + (- (gfs:size-width t-size) + (gfs:size-width l-size) + (gfs:size-width r-size)) + (- (gfs:size-width b-size) + (gfs:size-width l-size) + (gfs:size-width r-size))) + :height (max (gfs:size-height l-size) + (gfs:size-height c-size) + (gfs:size-height r-size)))) + (setf (borders-outer-size data) + (gfs:make-size :width (max (gfs:size-width t-size) + (gfs:size-width b-size) + (+ (gfs:size-width l-size) + (gfs:size-width c-size) + (gfs:size-width r-size))) + :height (+ (gfs:size-height t-size) + (gfs:size-height (borders-inside-size data)) + (gfs:size-height b-size)))) + data)) + +(defun top-border-rect (data) + (unless (borders-top-widget data) + (return-from top-border-rect *empty-rect*)) + (or (borders-top-rect data) + (setf (borders-top-rect data) + (gfs:create-rectangle :width (gfs:size-width (borders-outer-size data)) + :height (borders-pref-top-height data))))) + +(defun bottom-border-rect (data) + (unless (borders-bottom-widget data) + (return-from bottom-border-rect *empty-rect*)) + (or (borders-bottom-rect data) + (let ((ypos (- (gfs:size-height (borders-outer-size data)) + (borders-pref-bottom-height data)))) + (setf (borders-bottom-rect data) + (gfs:create-rectangle :y ypos + :width (gfs:size-width (borders-outer-size data)) + :height (borders-pref-bottom-height data)))))) + +(defun left-border-rect (data) + (unless (borders-left-widget data) + (return-from left-border-rect *empty-rect*)) + (or (borders-left-rect data) + (let ((ypos (gfs:size-height (gfs:size (top-border-rect data)))) + (inside-height (gfs:size-height (borders-inside-size data)))) + (setf (borders-left-rect data) + (gfs:create-rectangle :y ypos + :width (borders-pref-left-width data) + :height inside-height))))) + +(defun right-border-rect (data) + (unless (borders-right-widget data) + (return-from right-border-rect *empty-rect*)) + (or (borders-right-rect data) + (let ((xpos (+ (gfs:size-width (gfs:size (left-border-rect data))) + (gfs:size-width (gfs:size (center-border-rect data))))) + (ypos (gfs:size-height (gfs:size (top-border-rect data)))) + (inside-height (gfs:size-height (borders-inside-size data)))) + (setf (borders-right-rect data) + (gfs:create-rectangle :x xpos + :y ypos + :width (borders-pref-right-width data) + :height inside-height))))) + +(defun center-border-rect (data) + (unless (borders-center-widget data) + (return-from center-border-rect *empty-rect*)) + (or (borders-center-rect data) + (let ((xpos (gfs:size-width (gfs:size (left-border-rect data)))) + (ypos (gfs:size-height (gfs:size (top-border-rect data)))) + (size (borders-inside-size data))) + (setf (borders-center-rect data) + (gfs:create-rectangle :x xpos + :y ypos + :width (gfs:size-width size) + :height (gfs:size-height size)))))) ;;; ;;; methods @@ -105,59 +166,28 @@ (defmethod compute-size ((self border-layout) (container layout-managed) width-hint height-hint) (cleanup-disposed-items self) - (let ((layout-size (gfs:make-size))) - (with-border-sizes (self unused1 top unused2 bottom unused3 total-width unused4 inside-height) - (declare (ignore unused1 unused2 unused3 unused4)) - ;; - ;; remember that top and/or bottom might be nil - ;; - (setf (gfs:size-width layout-size) total-width - (gfs:size-height layout-size) (+ (gfs:size-height (cdr top)) - inside-height - (gfs:size-height (cdr bottom))))) + (let ((size (borders-outer-size (init-borders self width-hint height-hint)))) (if (>= width-hint 0) - (setf (gfs:size-width layout-size) width-hint)) + (setf (gfs:size-width size) width-hint)) (if (>= height-hint 0) - (setf (gfs:size-height layout-size) height-hint)) - layout-size)) + (setf (gfs:size-height size) height-hint)) + size)) (defmethod compute-layout ((self border-layout) (container layout-managed) width-hint height-hint) (cleanup-disposed-items self) - (let ((results nil)) - (with-border-sizes (self center top left bottom right total-width inside-width inside-height) - (let ((left-width (gfs:size-width (cdr left))) - (right-width (gfs:size-width (cdr right))) - (top-height (gfs:size-height (cdr top))) - (bottom-height (gfs:size-height (cdr bottom)))) - (when (car center) - (setf (cdr center) - (gfs:create-rectangle :x left-width - :y top-height - :width inside-width - :height inside-height)) - (push center results)) - (when (car top) - (setf (cdr top) - (gfs:create-rectangle :width total-width - :height top-height)) - (push top results)) - (when (car left) - (setf (cdr left) - (gfs:create-rectangle :y top-height - :width left-width - :height inside-height)) - (push left results)) - (when (car right) - (setf (cdr right) - (gfs:create-rectangle :x (+ left-width inside-width) - :y top-height - :width right-width - :height inside-height)) - (push right results)) - (when (car bottom) - (setf (cdr bottom) - (gfs:create-rectangle :y (+ top-height inside-height) - :width total-width - :height bottom-height)) - (push bottom results)))) - results)) + (let ((data (init-borders self width-hint height-hint))) + (loop for func in (list #'top-border-rect #'bottom-border-rect + #'left-border-rect #'right-border-rect + #'center-border-rect) + do (funcall func data)) + (if (or (>= width-hint 0) (>= height-hint 0)) + (let ((total-size (borders-outer-size data)) + (hint-size (gfs:make-size :width width-hint :height height-hint))) + (map-border-rects data + (lambda (widget rect) + (declare (ignore widget)) + (let ((pnt (gfs:location rect)) + (size (gfs:size rect))) + (setf (gfs:location rect) (scale-point total-size hint-size pnt) + (gfs:size rect) (scale-size total-size hint-size size))))))) + (map-border-rects data #'cons))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Nov 17 14:34:40 2006 @@ -70,6 +70,37 @@ (defun cleanup-disposed-items (layout) (setf (data-of layout) (remove-if #'gfs:disposed-p (data-of layout) :key #'first))) +(declaim (inline scale-coord)) +(defun scale-coord (total hint orig-value) + (if (and (> total 0) (>= hint 0)) + (floor (* (/ hint total) orig-value)) + orig-value)) + +(declaim (inline scale-point)) +(defun scale-point (total-size hint-size orig-pnt) + (gfs:make-point :x (scale-coord (gfs:size-width total-size) + (gfs:size-width hint-size) + (gfs:point-x orig-pnt)) + :y (scale-coord (gfs:size-height total-size) + (gfs:size-height hint-size) + (gfs:point-y orig-pnt)))) + +(declaim (inline scale-size)) +(defun scale-size (total-size hint-size orig-size) + (gfs:make-size :width (scale-coord (gfs:size-width total-size) + (gfs:size-width hint-size) + (gfs:size-width orig-size)) + :height (scale-coord (gfs:size-height total-size) + (gfs:size-height hint-size) + (gfs:size-height orig-size)))) + +(declaim (inline scale-rectangle)) +(defun scale-rectangle (total-size hint-size orig-rect) + (let ((pnt (gfs:location orig-rect)) + (size (gfs:size orig-rect))) + (gfs:make-rectangle :location (scale-point total-size hint-size pnt) + :size (scale-size total-size hint-size size)))) + (defun arrange-hwnds (kid-specs flags-func) (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) (loop for k in kid-specs Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Fri Nov 17 14:34:40 2006 @@ -105,3 +105,5 @@ gfs::+swp-noownerzorder+ gfs::+swp-noactivate+ gfs::+swp-nocopybits+))) + +(defvar *empty-rect* (gfs:make-rectangle))

1 0

[graphic-forms-cvs] r394 - trunk/src/tests/uitoolkit
by junrue＠common-lisp.net 13 Nov '06

13 Nov '06

Author: junrue Date: Mon Nov 13 18:23:39 2006 New Revision: 394 Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp Log: implemented define-layout-test convenience macro Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Mon Nov 13 18:23:39 2006 @@ -39,43 +39,26 @@ (make-instance 'mock-widget :min-size *child-size-2*) (make-instance 'mock-widget :min-size *child-size-3*))) -(define-test border-layout-test1 - ;; regions: all - ;; spacing: 0 - ;; margins: 0 - ;; - (let* ((layout (make-border-layout *all-border-kids*)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 45 80 5) (60 5 20 40) (0 5 20 40) (0 0 80 5) (20 5 40 40)))) - (assert-equal 80 (gfs:size-width size)) - (assert-equal 50 (gfs:size-height size)) - (validate-rects data expected-rects))) +(defvar *outer-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*) + nil)) -(define-test border-layout-test2 - ;; regions: all but center - ;; spacing: 0 - ;; margins: 0 - ;; - (let* ((kids (append (butlast *all-border-kids*) '(nil))) - (layout (make-border-layout kids)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 15 40 5) (20 5 20 10) (0 5 20 10) (0 0 40 5)))) - (assert-equal 40 (gfs:size-width size)) - (assert-equal 20 (gfs:size-height size)) - (validate-rects data expected-rects))) +(defvar *center-border-kid* (list nil nil nil nil + (make-instance 'mock-widget :min-size *child-size-3*))) -(define-test border-layout-test3 - ;; regions: center only - ;; spacing: 0 - ;; margins: 0 - ;; - (let* ((kids (append '(nil nil nil nil) (last *all-border-kids*))) - (layout (make-border-layout kids)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 40 40)))) - (assert-equal 40 (gfs:size-width size)) - (assert-equal 40 (gfs:size-height size)) - (validate-rects data expected-rects))) +(define-layout-test border-layout-test1 + -1 -1 80 50 + '((0 45 80 5) (60 5 20 40) (0 5 20 40) (0 0 80 5) (20 5 40 40)) + #'make-border-layout *all-border-kids*) + +(define-layout-test border-layout-test2 + -1 -1 40 20 + '((0 15 40 5) (20 5 20 10) (0 5 20 10) (0 0 40 5)) + #'make-border-layout *outer-border-kids*) + +(define-layout-test border-layout-test3 + -1 -1 40 40 + '((0 0 40 40)) + #'make-border-layout *center-border-kid*) 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 Nov 13 18:23:39 2006 @@ -40,222 +40,72 @@ (make-instance 'mock-widget :min-size *child-size-1*) (make-instance 'mock-widget :min-size *child-size-2*))) -(define-test flow-layout-test1 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal))) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) - (assert-equal 60 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test2 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical))) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test3 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width, unrestricted height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) - (data (gfw::compute-layout layout *mock-container* 45 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test4 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width, restricted height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) - (data (gfw::compute-layout layout *mock-container* -1 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test5 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) - (data (gfw::compute-layout layout *mock-container* 45 18)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test6 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) - (data (gfw::compute-layout layout *mock-container* 30 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test7 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 4)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) - (assert-equal 68 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test8 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 4)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 38 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test9 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)) - (data (gfw::compute-layout layout *mock-container* 45 18)) - (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test10 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)) - (data (gfw::compute-layout layout *mock-container* 30 25)) - (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test11 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) - (assert-equal 63 (gfs:size-width size)) - (assert-equal 13 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test12 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 23 (gfs:size-width size)) - (assert-equal 33 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test13 - ;; orient: horizontal - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-flow-layout *flow-mixed-kids* '(:horizontal :normalize))) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) - (assert-equal 75 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test14 - ;; orient: vertical - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-flow-layout *flow-mixed-kids* '(:vertical :normalize))) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) - (assert-equal 25 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-rects data expected-rects))) +(define-layout-test flow-layout-test1 + -1 -1 60 10 + '((0 0 20 10) (20 0 20 10) (40 0 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal)) + +(define-layout-test flow-layout-test2 + -1 -1 20 30 + '((0 0 20 10) (0 10 20 10) (0 20 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical)) + +(define-layout-test flow-layout-test3 + 45 -1 40 20 + '((0 0 20 10) (20 0 20 10) (0 10 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap)) + +(define-layout-test flow-layout-test4 + -1 25 20 20 + '((0 0 20 10) (0 10 20 10) (20 0 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap)) + +(define-layout-test flow-layout-test5 + 45 18 40 20 + '((0 0 20 10) (20 0 20 10) (0 10 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap)) + +(define-layout-test flow-layout-test6 + 30 25 40 20 + '((0 0 20 10) (0 10 20 10) (20 0 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap)) + +(define-layout-test flow-layout-test7 + -1 -1 68 10 + '((0 0 20 10) (24 0 20 10) (48 0 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal) 4) + +(define-layout-test flow-layout-test8 + -1 -1 20 38 + '((0 0 20 10) (0 14 20 10) (0 28 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical) 4) + +(define-layout-test flow-layout-test9 + 45 18 0 0 + '((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 + '((0 0 20 10) (0 14 20 10) (24 0 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4) + +(define-layout-test flow-layout-test11 + -1 -1 63 13 + '((3 3 20 10) (23 3 20 10) (43 3 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3) + +(define-layout-test flow-layout-test12 + -1 -1 23 33 + '((0 0 20 10) (0 10 20 10) (0 20 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3) + +(define-layout-test flow-layout-test13 + -1 -1 75 10 + '((0 0 25 10) (25 0 25 10) (50 0 25 10)) + #'make-flow-layout *flow-mixed-kids* '(:horizontal :normalize)) + +(define-layout-test flow-layout-test14 + -1 -1 25 30 + '((0 0 25 10) (0 10 25 10) (0 20 25 10)) + #'make-flow-layout *flow-mixed-kids* '(:vertical :normalize)) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Mon Nov 13 18:23:39 2006 @@ -95,3 +95,17 @@ (assert-equal (fourth expected) (gfs:size-height sz-a)))) expected-rects actual-rects))) + +(defmacro define-layout-test (name width-hint height-hint + expected-width expected-height expected-rects + factory &rest factory-args) + (let ((layout (gensym)) + (size (gensym)) + (data (gensym))) + `(define-test ,name + (let* ((,layout (apply ,factory (list ,@factory-args))) + (,size (gfw::compute-size ,layout *mock-container* ,width-hint ,height-hint)) + (,data (gfw::compute-layout ,layout *mock-container* ,width-hint ,height-hint))) + (assert-equal ,expected-width (gfs::size-width ,size)) + (assert-equal ,expected-height (gfs::size-height ,size)) + (validate-rects ,data ,expected-rects)))))

1 0

[graphic-forms-cvs] r393 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 13 Nov '06

13 Nov '06

Author: junrue Date: Mon Nov 13 01:58:13 2006 New Revision: 393 Added: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/uitoolkit/widgets/border-layout.lisp Modified: trunk/NEWS.txt trunk/docs/manual/Makefile trunk/docs/manual/gfs-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/tests.lisp Log: initial implementation of border-layout; added create-rectangle convenience function Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Nov 13 01:58:13 2006 @@ -1,5 +1,9 @@ +. Implemented a new layout manager called GFW:BORDER-LAYOUT which assigns + children to 5 possible regions identified by :top, :left, :right, + :bottom, or :center. + . GFW:APPEND-ITEM now accepts an optional classname argument so that applications can use custom item classes. Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Mon Nov 13 01:58:13 2006 @@ -1,4 +1,4 @@ -# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*- +# -*- Mode: Makefile; tab-width: 4; indent-tabs-mode: t -*- # # Makefile # Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Mon Nov 13 01:58:13 2006 @@ -264,6 +264,7 @@ </initargs> <seealso> <reftopic>gfs:copy-rectangle</reftopic> + <reftopic>gfs:create-rectangle</reftopic> <reftopic>gfs:location</reftopic> <reftopic>gfs:make-rectangle</reftopic> <reftopic>gfs:size</reftopic> @@ -410,7 +411,7 @@ <notarg name="point"/> <argument name=":size"> <description> - A <reftopic>gfs:size</reftopic> specifing the dimensions of the + A <reftopic>gfs:size</reftopic> specifying the dimensions of the rectangle. </description> </argument> @@ -425,6 +426,52 @@ </description> <seealso> <reftopic>gfs:copy-rectangle</reftopic> + <reftopic>gfs:create-rectangle</reftopic> + </seealso> + </function> + + <function name="create-rectangle"> + <syntax> + <arguments> + <argument name=":x"> + <description> + An <refclhs>integer</refclhs> specifying the X coordinate of the + upper-left corner of the rectangle. + </description> + </argument> + <notarg name="integer"/> + <argument name=":y"> + <description> + An <refclhs>integer</refclhs> specifying the Y coordinate of the + upper-left corner of the rectangle. + </description> + </argument> + <notarg name="integer"/> + <argument name=":width"> + <description> + An <refclhs>integer</refclhs> specifying the width of the + rectangle. + </description> + </argument> + <notarg name="integer"/> + <argument name=":height"> + <description> + An <refclhs>integer</refclhs> specifying the height of the + rectangle. + </description> + </argument> + <notarg name="integer"/> + </arguments> + <return> + <reftopic label="new rectangle">gfs:rectangle</reftopic> + </return> + </syntax> + <description> + Returns a new <reftopic>gfs:rectangle</reftopic>. This function is a + wrapper around <reftopic>gfs:make-rectangle</reftopic>. + </description> + <seealso> + <reftopic>gfs:copy-rectangle</reftopic> </seealso> </function> Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Mon Nov 13 01:58:13 2006 @@ -17,6 +17,130 @@  + <class name="border-layout"> + <description> + <hierarchy> + <inherits> + <reftopic>gfw:layout-manager</reftopic> + </inherits> + </hierarchy> + <para role="normal"> + This layout manager organizes the space within a container as 5 regions, + one region for each edge of the container and a center region. Applications + specify the region for each component via <reftopic>gfw:layout-attribute</reftopic>, + using one of the following keywords: + <enum> + <argument name=":center"> + <description> + Place the component in the central region of the container. + </description> + </argument> + <argument name=":bottom"> + <description> + Place the component in the bottom region of the container; note that + the bottom region extends to the left and right sides of the container. + </description> + </argument> + <argument name=":left"> + <description> + Place the component in the left-hand region of the container. This region + is bounded vertically by the top and bottom regions. + </description> + </argument> + <argument name=":right"> + <description> + Place the component in the right-hand region of the container. This region + is bounded vertically by the top and bottom regions. + </description> + </argument> + <argument name=":top"> + <description> + Place the component in the top region of the container; note that + the top region extends to the left and right sides of the container. + </description> + </argument> + </enum> + Note that only one child may be assigned to each region at a time. + </para> + <para role="normal"> + Spacing between adjacent regions can also be specified via + <reftopic>gfw:layout-attribute</reftopic> using one or more + of the following keywords (note that not all keywords apply + to all regions): + <enum> + <argument name=":center-spacing"> + <description> + An <refclhs>integer</refclhs> specifying the number of pixels between + the center region and a region on the perimeter. + </description> + </argument> + <argument name=":leading-spacing"> + <description> + An <refclhs>integer</refclhs> specifying the number of pixels between + neighboring regions on the leading edge of the specified region. + </description> + </argument> + <argument name=":trailing-spacing"> + <description> + An <refclhs>integer</refclhs> specifying the number of pixels between + neighboring regions on the trailing edge of the specified region. + </description> + </argument> + <argument name=":spacing"> + <description> + An <refclhs>integer</refclhs> specifying the number of pixels between + a region and its immediate neighbors. + </description> + </argument> + </enum> + </para> + <para role="normal"> + The :top and :bottom components may be stretched horizontally, while the + :left and :right components may be stretched vertically. The :center component + will be sized to fill the remaining space. Each component's extent on the + secondary axis is determined by <reftopic>gfw:preferred-size</reftopic>. + </para> + </description> + <initargs> + <argument name=":bottom-margin"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":left-margin"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":right-margin"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":top-margin"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":horizontal-margins"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":vertical-margins"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":margins"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + </initargs> + <para role="normal"/> + </class> + <class name="flow-layout"> <description> <hierarchy> @@ -30,7 +154,7 @@ <argument name=":spacing"> <description> An <refclhs>integer</refclhs> value specifying the number of pixels - between succeeding child widgets. + between neighboring child widgets. </description> </argument> <argument name=":style"> @@ -171,6 +295,7 @@ <description> <hierarchy> <inheritedby> + <reftopic>gfw:border-layout</reftopic> <reftopic>gfw:flow-layout</reftopic> <reftopic>gfw:heap-layout</reftopic> </inheritedby> @@ -187,22 +312,29 @@ <initargs> <argument name=":bottom-margin"> <description> - An <refclhs>integer</refclhs> value specifying margin thickness in pixels. + An <refclhs>integer</refclhs> value specifying the thickness of the margin + between the layout area and the bottom edge of the container, in pixels. </description> </argument> <argument name=":left-margin"> <description> - An <refclhs>integer</refclhs> value specifying margin thickness in pixels. + An <refclhs>integer</refclhs> value specifying the thickness of the + margin between the layout area and the left edge of the container, + in pixels. </description> </argument> <argument name=":right-margin"> <description> - An <refclhs>integer</refclhs> value specifying margin thickness in pixels. + An <refclhs>integer</refclhs> value specifying the thickness of the + margin between the layout area and the right edge of the container, + in pixels. </description> </argument> <argument name=":top-margin"> <description> - An <refclhs>integer</refclhs> value specifying margin thickness in pixels. + An <refclhs>integer</refclhs> value specifying the thickness of the + margin between the layout area and the top edge of the container, + in pixels. </description> </argument> <argument name=":horizontal-margins"> @@ -2159,10 +2291,9 @@ positioning <arg1/>'s children. </description> </argument> - <argument name="container"> + <argument name="thing"> <description> - A <reftopic>gfw:window</reftopic> or other type containing - children. + An object whose position and size are managed by <arg0/>. </description> </argument> <argument name="symbol"> @@ -2178,9 +2309,9 @@ </syntax> <description> Each <reftopic>gfw:layout-manager</reftopic> subclass can support attributes - that apply to each child of <arg1/>, which this function allows to be set + that apply to each <arg1/>, which this function allows to be set or retrieved. After setting attribute values, call <reftopic>gfw:layout</reftopic> - on <arg1/>. + on the container managed by <arg0/>. </description> </function> @@ -2493,7 +2624,7 @@ </argument> </arguments> <return> - <emphasis>undefined</emphasis> + <refclhs>list</refclhs> </return> </syntax> <description> @@ -2539,7 +2670,7 @@ </argument> </arguments> <return> - <emphasis>undefined</emphasis> + <reftopic>gfs:size</reftopic> </return> </syntax> <description> Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Nov 13 01:58:13 2006 @@ -149,6 +149,7 @@ (:file "panel") (:file "dialog") (:file "layout") + (:file "border-layout") (:file "heap-layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Nov 13 01:58:13 2006 @@ -59,9 +59,11 @@ ;; constants ;; methods, functions, macros + #:copy-rectangle #:copy-point #:copy-size #:copy-span + #:create-rectangle #:detail #:dispose #:disposed-p @@ -346,6 +348,7 @@ #:auto-vscroll-p #:background-color #:background-pattern + #:border-layout #:border-width #:bottom-margin-of #:capture-mouse @@ -365,7 +368,9 @@ #:column-index #:column-order #:columns + #:compute-layout #:compute-outer-size + #:compute-size #:copy-area #:copy-text #:cut-text Added: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Mon Nov 13 01:58:13 2006 @@ -0,0 +1,81 @@ +;;;; +;;;; border-layout-unit-tests.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.tests) + +(defvar *all-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-3*))) + +(define-test border-layout-test1 + ;; regions: all + ;; spacing: 0 + ;; margins: 0 + ;; + (let* ((layout (make-border-layout *all-border-kids*)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) + (expected-rects '((0 45 80 5) (60 5 20 40) (0 5 20 40) (0 0 80 5) (20 5 40 40)))) + (assert-equal 80 (gfs:size-width size)) + (assert-equal 50 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test border-layout-test2 + ;; regions: all but center + ;; spacing: 0 + ;; margins: 0 + ;; + (let* ((kids (append (butlast *all-border-kids*) '(nil))) + (layout (make-border-layout kids)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) + (expected-rects '((0 15 40 5) (20 5 20 10) (0 5 20 10) (0 0 40 5)))) + (assert-equal 40 (gfs:size-width size)) + (assert-equal 20 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test border-layout-test3 + ;; regions: center only + ;; spacing: 0 + ;; margins: 0 + ;; + (let* ((kids (append '(nil nil nil nil) (last *all-border-kids*))) + (layout (make-border-layout kids)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) + (expected-rects '((0 0 40 40)))) + (assert-equal 40 (gfs:size-width size)) + (assert-equal 40 (gfs:size-height size)) + (validate-rects data expected-rects))) 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 Nov 13 01:58:13 2006 @@ -33,17 +33,12 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *large-size* (gfs:make-size :width 25 :height 5)) -(defvar *small-size* (gfs:make-size :width 20 :height 10)) - -(defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*))) -(defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *large-size*) - (make-instance 'mock-widget :min-size *small-size*))) - -(defvar *flow-container* (make-instance 'mock-container)) +(defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-2*))) +(defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*))) (define-test flow-layout-test1 ;; orient: horizontal @@ -55,12 +50,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal))) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) - (assert-equal 60 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 60 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test2 ;; orient: vertical @@ -72,12 +67,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical))) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test3 ;; orient: horizontal @@ -89,9 +84,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) - (data (gfw::compute-layout layout *flow-container* 45 -1)) + (data (gfw::compute-layout layout *mock-container* 45 -1)) (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test4 ;; orient: vertical @@ -103,9 +98,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) - (data (gfw::compute-layout layout *flow-container* -1 25)) + (data (gfw::compute-layout layout *mock-container* -1 25)) (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test5 ;; orient: horizontal @@ -117,9 +112,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) - (data (gfw::compute-layout layout *flow-container* 45 18)) + (data (gfw::compute-layout layout *mock-container* 45 18)) (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test6 ;; orient: vertical @@ -131,9 +126,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) - (data (gfw::compute-layout layout *flow-container* 30 25)) + (data (gfw::compute-layout layout *mock-container* 30 25)) (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test7 ;; orient: horizontal @@ -145,12 +140,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 4)) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) - (assert-equal 68 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 68 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test8 ;; orient: vertical @@ -162,12 +157,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 4)) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 38 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 38 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test9 ;; orient: horizontal @@ -179,9 +174,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)) - (data (gfw::compute-layout layout *flow-container* 45 18)) + (data (gfw::compute-layout layout *mock-container* 45 18)) (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test10 ;; orient: vertical @@ -193,9 +188,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)) - (data (gfw::compute-layout layout *flow-container* 30 25)) + (data (gfw::compute-layout layout *mock-container* 30 25)) (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test11 ;; orient: horizontal @@ -207,12 +202,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3)) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) - (assert-equal 63 (gfs:size-width size)) - (assert-equal 13 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 63 (gfs:size-width size)) + (assert-equal 13 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test12 ;; orient: vertical @@ -224,12 +219,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3)) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 23 (gfs:size-width size)) - (assert-equal 33 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 23 (gfs:size-width size)) + (assert-equal 33 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test13 ;; orient: horizontal @@ -241,12 +236,12 @@ ;; kids: mixed ;; (let* ((layout (make-flow-layout *flow-mixed-kids* '(:horizontal :normalize))) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) - (assert-equal 75 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 75 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test14 ;; orient: vertical @@ -258,9 +253,9 @@ ;; kids: mixed ;; (let* ((layout (make-flow-layout *flow-mixed-kids* '(:vertical :normalize))) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) - (assert-equal 25 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 25 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Mon Nov 13 01:58:13 2006 @@ -36,14 +36,21 @@ (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle (cffi:make-pointer 1234))) (widget2 (make-instance 'mock-widget :handle (cffi:make-pointer 5678)))) - (let ((data1 `(,widget1 (a 1 b 2))) - (data2 `(,widget2 (a 10 c 30))) + (let ((data1 (list widget1 (list 'a 1 'b 2))) + (data2 (list widget2 (list 'a 10 'c 30))) (layout (make-instance 'gfw:layout-manager))) (setf (slot-value layout 'gfw::data) (list data1 data2)) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) (assert-equal 2 (gfw:layout-attribute layout widget1 'b)) + (let ((tmp (gfw::obtain-children-with-attribute layout 'b))) + (assert-equal 1 (length tmp)) + (assert-true (cffi:pointer-eq (gfs:handle (car (first tmp))) (gfs:handle widget1)))) (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (let ((tmp (gfw::obtain-children-with-attribute layout 'c))) + (assert-equal 1 (length tmp)) + (assert-true (cffi:pointer-eq (gfs:handle (car (first tmp))) (gfs:handle widget2)))) + (assert-true (null (gfw::obtain-children-with-attribute layout 'd))) (setf (gfw:layout-attribute layout widget1 'b) 66 (gfw:layout-attribute layout widget2 'd) 100) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Mon Nov 13 01:58:13 2006 @@ -57,6 +57,8 @@ :initarg :visibility :initform t))) +(defvar *mock-container* (make-instance 'mock-container)) + (defmethod gfw:visible-p ((self mock-container)) (visibility-of self)) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Mon Nov 13 01:58:13 2006 @@ -33,6 +33,10 @@ (in-package :graphic-forms.uitoolkit.tests) +(defvar *child-size-1* (gfs:make-size :width 25 :height 5)) +(defvar *child-size-2* (gfs:make-size :width 20 :height 10)) +(defvar *child-size-3* (gfs:make-size :width 40 :height 40)) + (defun make-flow-layout (kids style &optional spacing left-margin top-margin right-margin bottom-margin) (let ((layout (make-instance 'gfw:flow-layout :style style @@ -44,6 +48,34 @@ (loop for kid in kids do (gfw::append-layout-item layout kid)) layout)) +(defun make-border-layout (kids &optional spacing left-margin top-margin right-margin bottom-margin) + (let ((layout (make-instance 'gfw:border-layout + :left-margin (or left-margin 0) + :top-margin (or top-margin 0) + :right-margin (or right-margin 0) + :bottom-margin (or bottom-margin 0))) + (top-kid (first kids)) + (right-kid (second kids)) + (bottom-kid (third kids)) + (left-kid (fourth kids)) + (center-kid (fifth kids))) + (when top-kid + (gfw::append-layout-item layout top-kid) + (setf (gfw:layout-attribute layout top-kid :top) t)) + (when right-kid + (gfw::append-layout-item layout right-kid) + (setf (gfw:layout-attribute layout right-kid :right) t)) + (when bottom-kid + (gfw::append-layout-item layout bottom-kid) + (setf (gfw:layout-attribute layout bottom-kid :bottom) t)) + (when left-kid + (gfw::append-layout-item layout left-kid) + (setf (gfw:layout-attribute layout left-kid :left) t)) + (when center-kid + (gfw::append-layout-item layout center-kid) + (setf (gfw:layout-attribute layout center-kid :center) t)) + layout)) + (defun validate-image (image expected-size expected-depth) (declare (ignore expected-depth)) (assert-false (null image)) @@ -52,6 +84,7 @@ (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) (defun validate-rects (entries expected-rects) + (assert-equal (length expected-rects) (length entries)) (let ((actual-rects (loop for entry in entries collect (cdr entry)))) (mapc #'(lambda (expected actual) (let ((pnt-a (gfs:location actual)) Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Mon Nov 13 01:58:13 2006 @@ -41,6 +41,11 @@ (defstruct span (start 0) (end 0)) +(declaim (inline create-rectangle)) +(defun create-rectangle (&key (height 0) (width 0) (x 0) (y 0)) + (make-rectangle :location (make-point :x x :y y) + :size (make-size :width width :height height))) + (declaim (inline location)) (defun location (rect) (rectangle-location rect)) Added: trunk/src/uitoolkit/widgets/border-layout.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/border-layout.lisp Mon Nov 13 01:58:13 2006 @@ -0,0 +1,163 @@ +;;;; +;;;; border-layout.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) + +;;; +;;; helpers +;;; + +(declaim (inline total-border-layout-width)) +(defun total-border-layout-width (cwidth twidth lwidth bwidth rwidth) + (max twidth bwidth (+ lwidth cwidth rwidth))) + +(declaim (inline inside-border-layout-width)) +(defun inside-border-layout-width (cwidth twidth lwidth bwidth rwidth) + (max cwidth (- twidth lwidth rwidth) (- bwidth lwidth rwidth))) + +(declaim (inline inside-border-layout-height)) +(defun inside-border-layout-height (cheight lheight rheight) + (max cheight lheight rheight)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-border-components ((layout center top left bottom right) &body body) + `(progn + (let ((,center (first (obtain-children-with-attribute ,layout :center))) + (,top (first (obtain-children-with-attribute ,layout :top))) + (,left (first (obtain-children-with-attribute ,layout :left))) + (,bottom (first (obtain-children-with-attribute ,layout :bottom))) + (,right (first (obtain-children-with-attribute ,layout :right)))) + ,@body))) + + (defmacro with-border-sizes ((layout center top left bottom right + total-width inside-width inside-height) &body body) + (let ((nil-size (gensym)) + (c-size (gensym)) + (t-size (gensym)) + (l-size (gensym)) + (b-size (gensym)) + (r-size (gensym)) + (c-widget (gensym)) + (t-widget (gensym)) + (l-widget (gensym)) + (r-widget (gensym)) + (b-widget (gensym))) + `(with-border-components (,layout ,c-widget ,t-widget ,l-widget ,b-widget ,r-widget) + (let* ((,nil-size (gfs:make-size)) + (,c-size (if ,c-widget (preferred-size (first ,c-widget) -1 -1) ,nil-size)) + (,t-size (if ,t-widget (preferred-size (first ,t-widget) -1 -1) ,nil-size)) + (,l-size (if ,l-widget (preferred-size (first ,l-widget) -1 -1) ,nil-size)) + (,b-size (if ,b-widget (preferred-size (first ,b-widget) -1 -1) ,nil-size)) + (,r-size (if ,r-widget (preferred-size (first ,r-widget) -1 -1) ,nil-size)) + (,center (cons (first ,c-widget) ,c-size)) + (,top (cons (first ,t-widget) ,t-size)) + (,left (cons (first ,l-widget) ,l-size)) + (,bottom (cons (first ,b-widget) ,b-size)) + (,right (cons (first ,r-widget) ,r-size)) + (,total-width (total-border-layout-width (gfs:size-width ,c-size) + (gfs:size-width ,t-size) + (gfs:size-width ,l-size) + (gfs:size-width ,b-size) + (gfs:size-width ,r-size))) + (,inside-width (inside-border-layout-width (gfs:size-width ,c-size) + (gfs:size-width ,t-size) + (gfs:size-width ,l-size) + (gfs:size-width ,b-size) + (gfs:size-width ,r-size))) + (,inside-height (inside-border-layout-height (gfs:size-height ,c-size) + (gfs:size-height ,l-size) + (gfs:size-height ,r-size)))) + ,@body))))) + +;;; +;;; methods +;;; + +(defmethod compute-size ((self border-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((layout-size (gfs:make-size))) + (with-border-sizes (self unused1 top unused2 bottom unused3 total-width unused4 inside-height) + (declare (ignore unused1 unused2 unused3 unused4)) + ;; + ;; remember that top and/or bottom might be nil + ;; + (setf (gfs:size-width layout-size) total-width + (gfs:size-height layout-size) (+ (gfs:size-height (cdr top)) + inside-height + (gfs:size-height (cdr bottom))))) + (if (>= width-hint 0) + (setf (gfs:size-width layout-size) width-hint)) + (if (>= height-hint 0) + (setf (gfs:size-height layout-size) height-hint)) + layout-size)) + +(defmethod compute-layout ((self border-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((results nil)) + (with-border-sizes (self center top left bottom right total-width inside-width inside-height) + (let ((left-width (gfs:size-width (cdr left))) + (right-width (gfs:size-width (cdr right))) + (top-height (gfs:size-height (cdr top))) + (bottom-height (gfs:size-height (cdr bottom)))) + (when (car center) + (setf (cdr center) + (gfs:create-rectangle :x left-width + :y top-height + :width inside-width + :height inside-height)) + (push center results)) + (when (car top) + (setf (cdr top) + (gfs:create-rectangle :width total-width + :height top-height)) + (push top results)) + (when (car left) + (setf (cdr left) + (gfs:create-rectangle :y top-height + :width left-width + :height inside-height)) + (push left results)) + (when (car right) + (setf (cdr right) + (gfs:create-rectangle :x (+ left-width inside-width) + :y top-height + :width right-width + :height inside-height)) + (push right results)) + (when (car bottom) + (setf (cdr bottom) + (gfs:create-rectangle :y (+ top-height inside-height) + :width total-width + :height bottom-height)) + (push bottom results)))) + results)) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Mon Nov 13 01:58:13 2006 @@ -67,16 +67,16 @@ (let* ((size (client-size container)) (horz-margin (+ (left-margin-of self) (right-margin-of self))) (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) - (new-size (gfs:make-size :width (- (if (> width-hint horz-margin) - width-hint - (gfs:size-width size)) - horz-margin) - :height (- (if (> height-hint vert-margin) - height-hint - (gfs:size-height size)) - vert-margin))) - (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) - (bounds (gfs:make-rectangle :size new-size :location new-pnt))) + (bounds (gfs:create-rectangle :x (left-margin-of self) + :y (top-margin-of self) + :width (- (if (> width-hint horz-margin) + width-hint + (gfs:size-width size)) + horz-margin) + :height (- (if (> height-hint vert-margin) + height-hint + (gfs:size-height size)) + vert-margin)))) (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Mon Nov 13 01:58:13 2006 @@ -59,6 +59,9 @@ :initform nil)) (:documentation "Subclasses implement layout strategies to manage space within windows.")) +(defclass border-layout (layout-manager) () + (:documentation "Window children are assigned a position on the edges or center of a container.")) + (defclass flow-layout (layout-manager) ((spacing :accessor spacing-of Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Mon Nov 13 01:58:13 2006 @@ -39,20 +39,26 @@ (defun layout-attribute (layout thing name) "Return the value associated with name for thing; or NIL if no value is set." - (let ((items (assoc thing (data-of layout)))) - (unless items + (let ((item-data (assoc thing (data-of layout)))) + (unless item-data (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) - (getf (first (rest items)) name))) + (getf (second item-data) name))) (defun set-layout-attribute (layout thing name value) "Sets a value associated with name for thing in the specified layout." - (let ((items (assoc thing (data-of layout)))) - (unless items + (let ((item-data (assoc thing (data-of layout)))) + (unless item-data (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) - (setf (getf (first (rest items)) name) value))) + (setf (getf (second item-data) name) value))) (defsetf layout-attribute set-layout-attribute) +(defun obtain-children-with-attribute (layout name) + "Returns a list of layout entries that have the named attribute." + (loop for pair in (data-of layout) + when (getf (second pair) name) + collect pair)) + (defun append-layout-item (layout thing) "Adds thing to layout. Duplicate entries are not prevented." (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) @@ -68,24 +74,25 @@ (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) (loop for k in kid-specs for rect = (cdr k) + for widget = (car k) for size = (gfs:size rect) for pnt = (gfs:location rect) do (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) + (gfs::set-window-pos (gfs:handle widget) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) (gfs:size-width size) (gfs:size-height size) - (funcall flags-func (car k))) + (funcall flags-func widget)) (gfs::defer-window-pos hdwp - (gfs:handle (car k)) + (gfs:handle widget) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) (gfs:size-width size) (gfs:size-height size) - (funcall flags-func (car k))))) + (funcall flags-func widget)))) (unless (gfs:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp)))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Mon Nov 13 01:58:13 2006 @@ -43,5 +43,6 @@ "graphics-context-unit-tests" "image-unit-tests" "icon-bundle-unit-tests" "layout-unit-tests" "flow-layout-unit-tests" "widget-unit-tests" - "item-manager-unit-tests" "misc-unit-tests") + "item-manager-unit-tests" "misc-unit-tests" + "border-layout-unit-tests") do (load (merge-pathnames file *gf-tests-dir*))))

1 0

[graphic-forms-cvs] r392 - in trunk: docs/manual src/uitoolkit/widgets
by junrue＠common-lisp.net 07 Nov '06

07 Nov '06

Author: junrue Date: Tue Nov 7 16:02:04 2006 New Revision: 392 Modified: trunk/docs/manual/gfw-symbols.xml trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: text-baseline tweaked such that default is mid-point instead of height Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Tue Nov 7 16:02:04 2006 @@ -2789,7 +2789,7 @@ that correlates to the baseline of the text of the control, if any. For controls in which a text baseline is not meaningful, such as a <reftopic>gfw:label</reftopic> with a <reftopic>gfg:image</reftopic>, - this function returns the control's height. + this function returns half of the control's height. </para> <para role="normal"> By default, Graphic-Forms does not implement this function for Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Nov 7 16:02:04 2006 @@ -210,7 +210,7 @@ (format stream "text baseline: ~a" (text-baseline self)))) (defmethod text-baseline ((self control)) - (gfs:size-height (size self))) + (floor (gfs:size-height (size self)) 2)) (defmethod update-native-style ((self control) flags) (let ((hwnd (gfs:handle self))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Nov 7 16:02:04 2006 @@ -195,5 +195,5 @@ (let ((image (image self))) (if image (+ (gfs:size-height (gfg:size image)) b-width) - b-width)) + (floor b-width 2))) (widget-text-baseline self 0)))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Nov 7 16:02:04 2006 @@ -412,7 +412,7 @@ (:documentation "Sets self's text.")) (defgeneric text-baseline (self) - (:documentation "Returns the y coordinate of the object's text component, if any.")) + (:documentation "Returns the y coordinate of the baseline of self's text component, if any.")) (defgeneric text-for-pasting-p (self) (:documentation "Returns T if the clipboard has data in text format; nil otherwise.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Nov 7 16:02:04 2006 @@ -209,17 +209,15 @@ (defun widget-text-baseline (widget top-margin) (let ((size (gfw:size widget)) (b-width (border-width widget)) - (font (gfg:font widget)) - (baseline 0)) + (font (gfg:font widget))) (with-graphics-context (gc widget) (let ((metrics (gfg:metrics gc font))) - (setf baseline (+ b-width - top-margin - (gfg:ascent metrics) - (floor (- (gfs:size-height size) - (+ (gfg:ascent metrics) (gfg:descent metrics))) - 2))))) - baseline)) + (+ b-width + top-margin + (gfg:ascent metrics) + (floor (- (gfs:size-height size) + (+ (gfg:ascent metrics) (gfg:descent metrics))) + 2)))))) (defun check-box-size () (if *check-box-size*

1 0

[graphic-forms-cvs] r391 - trunk/docs/manual
by junrue＠common-lisp.net 05 Nov '06

05 Nov '06

Author: junrue Date: Sun Nov 5 17:38:08 2006 New Revision: 391 Modified: trunk/docs/manual/gfw-symbols.xml Log: documented the startup and shutdown functions Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Sun Nov 5 17:38:08 2006 @@ -2059,6 +2059,56 @@  + <function name="startup"> + <syntax> + <arguments> + <argument name="string"> + <description> + A <refclhs>string</refclhs> identifying the application's name. + </description> + </argument> + <argument name="function"> + <description> + A <emphasis>function</emphasis> with initialization code for the + application. + </description> + </argument> + </arguments> + <return> + <emphasis>undefined</emphasis> + </return> + </syntax> + <description> + This is the main entry point for applications. + </description> + <seealso> + <reftopic>gfw:shutdown</reftopic> + </seealso> + </function> + + <function name="shutdown"> + <syntax> + <arguments> + <argument name="integer"> + <description> + An <refclhs>integer</refclhs> exit code. + </description> + </argument> + </arguments> + <return> + <emphasis>undefined</emphasis> + </return> + </syntax> + <description> + Applications call this function to perform graceful cleanup and exit. + One of the side effects of this function is the posting of a WM_QUIT + message. + </description> + <seealso> + <reftopic>gfw:startup</reftopic> + </seealso> + </function> + <function name="capture-mouse"> <syntax> <arguments>

1 0

[graphic-forms-cvs] r390 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 05 Nov '06

05 Nov '06

Author: junrue Date: Sun Nov 5 16:06:36 2006 New Revision: 390 Modified: trunk/config.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/tests.lisp Log: more fixes for loading the system; minor cleanup in message-loop function; added a couple debug functions Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Sun Nov 5 16:06:36 2006 @@ -43,6 +43,7 @@ (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") (defvar *gf-dir* "graphic-forms/") +(defvar *gf-tests-dir* "graphic-forms/src/tests/uitoolkit/") (defvar *binary-data-dir* "src/external-libraries/practicals-1.0.3/Chapter08/") (defvar *macro-utilities-dir* "src/external-libraries/practicals-1.0.3/Chapter24/") (defvar *textedit-dir* "src/demos/textedit/") Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Sun Nov 5 16:06:36 2006 @@ -37,6 +37,14 @@ ;;; convenience functions ;;; +(defun debug-format (str &rest args) + (apply #'format *trace-output* str args) + (finish-output)) + +(defun debug-print (thing) + (print thing *trace-output*) + (finish-output)) + (defun recreate-array (array) (make-array (array-dimensions array) :element-type (array-element-type array) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Nov 5 16:06:36 2006 @@ -71,13 +71,7 @@ (cffi:with-foreign-object (msg-ptr 'gfs::msg) (loop (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) - (cffi:with-foreign-slots ((gfs::hwnd - gfs::message - gfs::wparam - gfs::lparam - gfs::time - gfs::pnt) - msg-ptr gfs::msg) + (cffi:with-foreign-slots ((gfs::message gfs::wparam) msg-ptr gfs::msg) (when (funcall msg-filter gm msg-ptr) (return-from message-loop gfs::wparam))))))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Nov 5 16:06:36 2006 @@ -34,14 +34,14 @@ (in-package #:graphic-forms-system) (defun load-tests () - (let ((tests-dir (concatenate 'string gfsys::*gf-dir* "src/tests/uitoolkit/"))) - (setf *default-pathname-defaults* (parse-namestring tests-dir)) - (setf *textedit-dir* (concatenate 'string gfsys::*gf-dir* gfsys::*textedit-dir*)) - (setf *unblocked-dir* (concatenate 'string gfsys::*gf-dir* gfsys::*unblocked-dir*)) + (setf *gf-tests-dir* (concatenate 'string gfsys::*gf-dir* "src/tests/uitoolkit/")) + (setf *textedit-dir* (concatenate 'string gfsys::*gf-dir* "src/demos/textedit/")) + (setf *unblocked-dir* (concatenate 'string gfsys::*gf-dir* "src/demos/unblocked/")) + (setf *default-pathname-defaults* (parse-namestring *gf-tests-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests) (loop for file in '("test-utils.lisp" "mock-objects" "color-unit-tests" "graphics-context-unit-tests" "image-unit-tests" "icon-bundle-unit-tests" "layout-unit-tests" "flow-layout-unit-tests" "widget-unit-tests" "item-manager-unit-tests" "misc-unit-tests") - do (load (merge-pathnames file tests-dir))))) + do (load (merge-pathnames file *gf-tests-dir*))))

1 0

[graphic-forms-cvs] r389 - trunk
by junrue＠common-lisp.net 01 Nov '06

01 Nov '06

Author: junrue Date: Wed Nov 1 17:56:18 2006 New Revision: 389 Removed: trunk/build.lisp Modified: trunk/config.lisp trunk/graphic-forms-tests.asd trunk/tests.lisp Log: fix config and load issues; stop using build.lisp locally Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Wed Nov 1 17:56:18 2006 @@ -43,15 +43,16 @@ (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") (defvar *gf-dir* "graphic-forms/") -(defvar *binary-data-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/binary-data/") -(defvar *macro-utilities-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/macro-utilities/") -(defvar *textedit-dir* "graphic-forms/src/demos/textedit/") -(defvar *unblocked-dir* "graphic-forms/src/demos/unblocked/") -(defvar *gf-tests-dir* "graphic-forms/src/tests/uitoolkit/") +(defvar *binary-data-dir* "src/external-libraries/practicals-1.0.3/Chapter08/") +(defvar *macro-utilities-dir* "src/external-libraries/practicals-1.0.3/Chapter24/") +(defvar *textedit-dir* "src/demos/textedit/") +(defvar *unblocked-dir* "src/demos/unblocked/") -(defvar *lisp-unit-file* "graphic-forms/src/external-libraries/practicals-1.0.3/lisp-unit.lisp") +(defvar *lisp-unit-file* "src/external-libraries/lisp-unit/lisp-unit.lisp") (defun configure-asdf () - (loop for var in '(*binary-data-dir* *cffi-dir* *closer-mop-dir* *lw-compat-dir* *macro-utilities-dir* *gf-dir*) - when (symbol-value var) - do (pushnew (symbol-value var) asdf:*central-registry* :test #'equal))) + (let ((dir-list (list (concatenate 'string *gf-dir* *binary-data-dir*) + (concatenate 'string *gf-dir* *macro-utilities-dir*) + *cffi-dir* *closer-mop-dir* *lw-compat-dir* *gf-dir*))) + (loop for var in dir-list + do (pushnew var asdf:*central-registry* :test #'equal)))) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Nov 1 17:56:18 2006 @@ -33,7 +33,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(load gfsys::*lisp-unit-file*) +(load (concatenate 'string gfsys::*gf-dir* gfsys::*lisp-unit-file*)) (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Wed Nov 1 17:56:18 2006 @@ -34,16 +34,14 @@ (in-package #:graphic-forms-system) (defun load-tests () - (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) - (asdf:operate 'asdf:load-op :graphic-forms-tests) - (load (merge-pathnames "test-utils.lisp" *gf-tests-dir*)) - (load (merge-pathnames "mock-objects" *gf-tests-dir*)) - (load (merge-pathnames "color-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "graphics-context-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "image-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "icon-bundle-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "layout-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "flow-layout-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "widget-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "item-manager-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "misc-unit-tests" *gf-tests-dir*))) + (let ((tests-dir (concatenate 'string gfsys::*gf-dir* "src/tests/uitoolkit/"))) + (setf *default-pathname-defaults* (parse-namestring tests-dir)) + (setf *textedit-dir* (concatenate 'string gfsys::*gf-dir* gfsys::*textedit-dir*)) + (setf *unblocked-dir* (concatenate 'string gfsys::*gf-dir* gfsys::*unblocked-dir*)) + (asdf:operate 'asdf:load-op :graphic-forms-tests) + (loop for file in '("test-utils.lisp" "mock-objects" "color-unit-tests" + "graphics-context-unit-tests" "image-unit-tests" + "icon-bundle-unit-tests" "layout-unit-tests" + "flow-layout-unit-tests" "widget-unit-tests" + "item-manager-unit-tests" "misc-unit-tests") + do (load (merge-pathnames file tests-dir)))))

1 0

[graphic-forms-cvs] r388 - in trunk: . docs/manual docs/website src src/demos/textedit src/demos/unblocked src/tests/mcclim src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 01 Nov '06

01 Nov '06

Author: junrue Date: Wed Nov 1 12:52:32 2006 New Revision: 388 Added: trunk/src/tests/mcclim/ trunk/src/tests/mcclim/hello-tester.lisp Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/Makefile trunk/docs/manual/gfw-symbols.xml trunk/docs/website/index.html trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/root-window.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: version bump for next release; enhanced append-item to accept an optional classname; added a few bits related to job tables; added a mcclim testcase; added convenience macro with-root-window Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Wed Nov 1 12:52:32 2006 @@ -1,4 +1,13 @@ + +. GFW:APPEND-ITEM now accepts an optional classname argument so that + applications can use custom item classes. + +. Implemented a new macro GFW:WITH-ROOT-WINDOW which manages the lifetime + of an instance of GFW:ROOT-WINDOW for use within the macro body. + +============================================================================== + Release 0.6.0 of Graphic-Forms, a Common Lisp library for Windows GUI programming, is now available. This is an alpha release, meaning that the feature set and API have not yet stabilized. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Nov 1 12:52:32 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.6.0 (22 October 2006) +Graphic-Forms README for version 0.7.0 (xx xxxxx 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Wed Nov 1 12:52:32 2006 @@ -5,7 +5,7 @@ # Copyright (c) 2006, Jack D. Unrue # -VERSION = 0.6 +VERSION = 0.7 CHM-DEPS = gfs-tmp-pkg.xml gfg-tmp-pkg.xml gfw-tmp-pkg.xml \ constants.xml api.xml \ Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Wed Nov 1 12:52:32 2006 @@ -4518,6 +4518,13 @@ initially checked. </description> </argument> + <argument name="classname"> + <description> + A <refclhs>symbol</refclhs> specifying an item subclass other than the + default type to be created; such a subclass must still represent an + item type appropriate for <arg0/>. + </description> + </argument> </arguments> <return> <reftopic>gfw:item</reftopic> @@ -5337,7 +5344,7 @@ The <reftopic>gfw:widget</reftopic> being resized. </description> </argument> - <argument name="point"> + <argument name="size"> <description> A <reftopic>gfs:size</reftopic> indicating <arg1/>'s new dimensions. </description> @@ -5945,6 +5952,33 @@ </seealso> </macro> + <macro name="with-root-window"> + <syntax> + <arguments> + <notarg name="("/> + <argument name="window"> + <description> + A <reftopic>gfw:root-window</reftopic> to query. + </description> + </argument> + <notarg name=")"/> + <notarg name="&body"/> + <argument name="body"> + <description> + Application code to make use of <arg0/>. + </description> + </argument> + </arguments> + <return> + <emphasis>results</emphasis> + </return> + </syntax> + <description> + This macro executes <arg1/> with <arg0/> bound to an instance of + <reftopic>gfw:root-window</reftopic>. + </description> + </macro> + <macro name="with-graphics-context"> <syntax> <arguments> Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Nov 1 12:52:32 2006 @@ -43,7 +43,7 @@ <p>The current version is <a href="http://sourceforge.net/project/showfiles.php?group_id=163034"> - 0.6.0</a>, released on 22 October 2006.</p> + 0.7.0</a>, released on xx xxxxxx 2006.</p> <p>Graphic-Forms is in the alpha stage of development, meaning new features are still being added and existing features require considerable testing. Brave souls who experiment with the code should expect Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Nov 1 12:52:32 2006 @@ -1,3 +1,5 @@ +;;; -*- Mode: Lisp -*- + ;;;; ;;;; graphic-forms-tests.asd ;;;; @@ -54,7 +56,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.6.0" + :version "0.7.0" :author "Jack D. Unrue" :licence "BSD" :components Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Nov 1 12:52:32 2006 @@ -1,3 +1,5 @@ +;;; -*- Mode: Lisp -*- + ;;;; ;;;; graphic-forms-uitoolkit.asd ;;;; @@ -39,7 +41,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.6.0" + :version "0.7.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") @@ -149,3 +151,6 @@ (:file "layout") (:file "heap-layout") (:file "flow-layout"))))))))) + +(defmethod perform :after ((op load-op) (c (eql (find-system :graphic-forms-uitoolkit)))) + (pushnew :graphic-forms *features*)) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Nov 1 12:52:32 2006 @@ -157,7 +157,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.6"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.7"))) (defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Wed Nov 1 12:52:32 2006 @@ -87,7 +87,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.6"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.7"))) (defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File" Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Nov 1 12:52:32 2006 @@ -540,6 +540,7 @@ #:with-file-dialog #:with-font-dialog #:with-graphics-context + #:with-root-window ;; conditions )) Added: trunk/src/tests/mcclim/hello-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/mcclim/hello-tester.lisp Wed Nov 1 12:52:32 2006 @@ -0,0 +1,37 @@ + +(defpackage :clim-graphic-forms-tests + (:use :clim :clim-lisp)) + +(in-package :clim-graphic-forms-tests) + +(define-application-frame hello-frame () + ((message :initform "Foo!" :accessor message)) + (:menu-bar menubar-command-table) + (:panes (some-pane :application :display-function 'display-some-pane)) + (:layouts (default + (vertically (:height 500 :width 400) + (:fill some-pane))))) + +(define-command com-hello () + (clim-graphic-forms::debug-print "com-hello called ") + (setf (message *application-frame*) "Hello there!")) + +(define-command com-hi () + (clim-graphic-forms::debug-print "com-hi called ") + (setf (message *application-frame*) "Hi there!")) + +(define-command-table menu-command-table + :menu (("Hello" :command com-hello) + ("Howdy" :command com-hi))) + +(define-command-table menubar-command-table + :menu (("Menu" :menu menu-command-table) + ("Quit" :command com-quit-frame))) + +(define-hello-frame-command (com-quit-frame :name "Quit" :menu t) + () + (frame-exit *application-frame*)) + +(defmethod display-some-pane ((frame hello-frame) stream) + (clim-graphic-forms::debug-print "display-some-pane called ") + (format stream (message frame))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Wed Nov 1 12:52:32 2006 @@ -120,8 +120,8 @@ (if items (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) items 'mock-item)))) -(defmethod gfw:append-item ((self mock-item-manager) thing (disp gfw:event-dispatcher) &optional checked disabled) - (declare (ignore disabled checked)) +(defmethod gfw:append-item ((self mock-item-manager) thing (disp gfw:event-dispatcher) &optional checked disabled classname) + (declare (ignore disabled checked classname)) (let ((item (gfw::create-item-with-callback (gfs:handle self) 'mock-item thing disp))) (vector-push-extend item (slot-value self 'gfw::items)) item)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Nov 1 12:52:32 2006 @@ -47,6 +47,8 @@ (defconstant +wm-user+ #x0400) (defconstant +wm-app+ #x8000) +(defconstant +wm-job-posting+ #x2112) + (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Wed Nov 1 12:52:32 2006 @@ -85,8 +85,8 @@ ;;; methods ;;; -(defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled) - (declare (ignore thing disp checked disabled)) +(defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled classname) + (declare (ignore thing disp checked disabled classname)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Wed Nov 1 12:52:32 2006 @@ -169,12 +169,12 @@ ;;; methods ;;; -(defmethod append-item ((self list-box) thing disp &optional disabled checked) +(defmethod append-item ((self list-box) thing disp &optional disabled checked classname) (declare (ignore disabled checked)) (let* ((tc (thread-context)) (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) - (item (create-item-with-callback hcontrol 'list-item thing disp))) + (item (create-item-with-callback hcontrol (or classname 'list-item) thing disp))) (lb-insert-item hcontrol #xFFFFFFFF text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (slot-value self 'items)) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Wed Nov 1 12:52:32 2006 @@ -90,10 +90,10 @@ ;;; methods ;;; -(defmethod append-item ((self menu) thing disp &optional disabled checked) +(defmethod append-item ((self menu) thing disp &optional disabled checked classname) (let* ((tc (thread-context)) (hmenu (gfs:handle self)) - (item (create-item-with-callback hmenu 'menu-item thing disp)) + (item (create-item-with-callback hmenu (or classname 'menu-item) thing disp)) (text (call-text-provider self thing))) (append-menuitem hmenu (item-id item) text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (put-item tc item) Modified: trunk/src/uitoolkit/widgets/root-window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/root-window.lisp (original) +++ trunk/src/uitoolkit/widgets/root-window.lisp Wed Nov 1 12:52:32 2006 @@ -34,6 +34,17 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; macros and helper functions +;;; + +(defmacro with-root-window ((win) &body body) + `(let ((,win (make-instance 'root-window))) + (unwind-protect + (progn + ,@body) + (gfs:dispose ,win)))) + +;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Wed Nov 1 12:52:32 2006 @@ -45,6 +45,7 @@ (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) (next-item-id :initform 10000 :reader next-item-id) + (next-job-id :initform 1 :reader next-job-id) (next-widget-id :initform 100 :reader next-widget-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) @@ -112,6 +113,9 @@ (defgeneric put-item (self item)) (defgeneric delete-tc-item (self item)) (defgeneric increment-item-id (self)) +(defgeneric put-job (self id closure)) +(defgeneric take-job (self id)) +(defgeneric increment-job-id (self)) (defgeneric get-timer (self id)) (defgeneric put-timer (self timer)) (defgeneric delete-timer (self timer)) @@ -225,6 +229,22 @@ (incf (slot-value tc 'next-item-id)) id)) +(defmethod put-job ((tc thread-context) id closure) + "Stores a closure using the specified ID for later retrieval." + ;; FIXME: thread-safety + (setf (gethash id (slot-value tc 'job-table)) closure)) + +(defmethod take-job ((tc thread-context) id) + (let ((closure (gethash id (slot-value tc 'job-table)))) + (remhash id (slot-value tc 'job-table)) + closure)) + +(defmethod increment-job-id ((tc thread-context)) + "Return the next job ID; also increment the internal value." + (let ((id (next-job-id tc))) + (incf (slot-value tc 'next-job-id)) + id)) + (defmethod get-timer ((tc thread-context) id) "Returns the timer identified by the specified (system-defined) id." (gethash id (slot-value tc 'timers-by-id))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Nov 1 12:52:32 2006 @@ -45,7 +45,7 @@ (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (self thing dispatcher &optional checked disabled) +(defgeneric append-item (self thing dispatcher &optional checked disabled classname) (:documentation "Adds a new item encapsulating thing to self, and returns the newly-created item.")) (defgeneric append-separator (self)

1 0