graphic-forms-cvs June 2006

graphic-forms-cvs@common-lisp.net

1 participants
26 discussions

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

04 Jun '06

Author: junrue Date: Sun Jun 4 02:16:18 2006 New Revision: 147 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp Log: refactored flow-layout implementation, added initial code for :normalize style; still buggy Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jun 4 02:16:18 2006 @@ -602,7 +602,10 @@ style keywords: @table @code @item :horizontal -Specifies arrangement in a horizontal row. This style is the default. +Specifies arrangement in a horizontal row. This arrangement is the default. +@item :normalize +Instructs the @code{flow-layout} to size the children equally using the +maximum dimensions of the preferred sizes of all the children. @item :vertical Specifies arrangement in a vertical column. @item :wrap Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Jun 4 02:16:18 2006 @@ -470,6 +470,7 @@ #:style-of #:sub-menu #:text + #:text-baseline #:text-height #:text-limit #:thumb-size Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Jun 4 02:16:18 2006 @@ -205,6 +205,15 @@ (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*))) +(defun set-flow-layout-normalize (disp item time rect) + (declare (ignorable disp item time rect)) + (let* ((layout (gfw:layout-of *layout-tester-win*)) + (style (gfw:style-of layout))) + (if (find :normalize style) + (setf (gfw:style-of layout) (remove :normalize style)) + (setf (gfw:style-of layout) (push :normalize style))) + (gfw:layout *layout-tester-win*))) + (defun set-flow-layout-wrap (disp item time rect) (declare (ignorable disp item time rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) @@ -341,8 +350,11 @@ (gfw:append-submenu menu "Margin" margin-menu nil) (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-items) (gfw:append-submenu menu "Spacing" spacing-menu #'enable-flow-spacing-items) - (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) - (gfw:check it (find :wrap (gfw:style-of (gfw:layout-of *layout-tester-win*)))))) + (let ((style (gfw:style-of (gfw:layout-of *layout-tester-win*)))) + (setf it (gfw:append-item menu "Normalize" nil #'set-flow-layout-normalize)) + (gfw:check it (find :normalize style)) + (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) + (gfw:check it (find :wrap style))))) (defun exit-layout-callback (disp item time rect) (declare (ignorable disp item time rect)) 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 Sun Jun 4 02:16:18 2006 @@ -33,25 +33,30 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *minsize1* (gfs:make-size :width 20 :height 10)) -(defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *minsize1*) - (make-instance 'mock-widget :min-size *minsize1*) - (make-instance 'mock-widget :min-size *minsize1*))) +(defvar *large-size* (gfs:make-size :width 25 :height 5)) +(defvar *small-size* (gfs:make-size :width 20 :height 10)) +(defvar *flow-layout-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-layout-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*))) (defun validate-layout-rects (entries expected-rects) (let ((actual-rects (loop for entry in entries collect (cdr entry)))) (mapc #'(lambda (expected actual) (let ((pnt-a (gfs:location actual)) (sz-a (gfs:size actual))) - (assert-equal (gfs:point-x pnt-a) (first expected)) - (assert-equal (gfs:point-y pnt-a) (second expected)) - (assert-equal (gfs:size-width sz-a) (third expected)) - (assert-equal (gfs:size-height sz-a) (fourth expected)))) + (assert-equal (first expected) (gfs:point-x pnt-a)) + (assert-equal (second expected) (gfs:point-y pnt-a)) + (assert-equal (third expected) (gfs:size-width sz-a)) + (assert-equal (fourth expected) (gfs:size-height sz-a)))) expected-rects actual-rects))) (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 @@ -68,6 +73,7 @@ (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 @@ -84,6 +90,7 @@ (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 @@ -97,6 +104,7 @@ (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 @@ -110,6 +118,7 @@ (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 @@ -123,6 +132,7 @@ (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 @@ -136,6 +146,7 @@ (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 @@ -152,6 +163,7 @@ (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 @@ -168,6 +180,7 @@ (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 @@ -181,6 +194,7 @@ (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 @@ -194,6 +208,7 @@ (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 @@ -213,6 +228,7 @@ (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 @@ -229,3 +245,37 @@ (assert-equal 23 (gfs:size-width size)) (assert-equal 33 (gfs:size-height size)) (validate-layout-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-instance 'gfw:flow-layout :style '(:horizontal :normalize))) + (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) + (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -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-layout-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-instance 'gfw:flow-layout :style '(:vertical :normalize))) + (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) + (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -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-layout-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Sun Jun 4 02:16:18 2006 @@ -60,6 +60,9 @@ (defmethod initialize-instance :after ((widget mock-widget) &key) (setf (slot-value widget 'gfs:handle) (cffi:make-pointer #xFFFFFFFF))) +(defmethod gfw:location ((widget mock-widget)) + (gfs:make-point)) + (defmethod gfw:minimum-size ((widget mock-widget)) (gfs:make-size :width (gfs:size-width (min-size-of widget)) :height (gfs:size-height (min-size-of widget)))) @@ -75,5 +78,8 @@ (setf (gfs:size-height size) height-hint)) size)) +(defmethod gfw:text-baseline ((widget mock-widget)) + (floor (/ (* (gfs:size-height (min-size-of widget)) 3) 4))) + (defmethod gfw:visible-p ((widget mock-widget)) (visibility-of widget)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Jun 4 02:16:18 2006 @@ -37,89 +37,143 @@ ;;; helper functions ;;; -(defun flow-container-size (layout win-visible kids width-hint height-hint) - (let ((max -1) - (total 0) - (vert-orient (find :vertical (style-of layout)))) +(defun flow-container-size (layout visible kids width-hint height-hint) + (let ((kid-count (length kids)) + (vertical (find :vertical (style-of layout))) + (horizontal (find :horizontal (style-of layout))) + (normal (find :normalize (style-of layout))) + (horz-max 0) + (horz-total 0) + (vert-max 0) + (vert-total 0)) (loop for kid in kids - do (let ((size (preferred-size kid - (if vert-orient width-hint -1) - (if vert-orient -1 height-hint)))) - (when (or (visible-p kid) (not win-visible)) - (if vert-orient - (progn - (incf total (gfs:size-height size)) - (if (< max (gfs:size-width size)) - (setf max (gfs:size-width size)))) - (progn - (incf total (gfs:size-width size)) - (if (< max (gfs:size-height size)) - (setf max (gfs:size-height size)))))))) - (unless (null kids) - (incf total (* (spacing-of layout) (1- (length kids))))) - (if vert-orient - (progn - (incf max (+ (left-margin-of layout) (right-margin-of layout))) - (incf total (+ (top-margin-of layout) (bottom-margin-of layout))) - (gfs:make-size :width max :height total)) - (progn - (incf total (+ (left-margin-of layout) (right-margin-of layout))) - (incf max (+ (top-margin-of layout) (bottom-margin-of layout))) - (gfs:make-size :width total :height max))))) + do (let* ((size (preferred-size kid + (if vertical width-hint -1) + (if vertical -1 height-hint))) + (width (gfs:size-width size)) + (height (gfs:size-height size))) + (when (or (visible-p kid) (not visible)) + (incf horz-total width) + (incf vert-total height) + (if (< vert-max height) + (setf vert-max height)) + (if (< horz-max width) + (setf horz-max width))))) + (if (and normal vertical) + (setf vert-total (* vert-max kid-count)) + (if (and normal horizontal) + (setf horz-total (* horz-max kid-count)))) + (let ((spacing-total (* (spacing-of layout) (1- kid-count))) + (horz-margin-total (+ (left-margin-of layout) (right-margin-of layout))) + (vert-margin-total (+ (top-margin-of layout) (bottom-margin-of layout)))) + (cond + (vertical + (gfs:make-size :width (+ horz-max horz-margin-total) + :height (+ vert-total spacing-total vert-margin-total))) + (horizontal + (gfs:make-size :width (+ horz-total spacing-total horz-margin-total) + :height (+ vert-max vert-margin-total))) + (t + (error 'gfs:toolkit-error + :detail (format nil "unrecognized flow layout style: ~a" (style-of layout)))))))) + +(defstruct flow-data + (hint 0) + (kid-sizes nil) + (max-extent 0) + (max-distance 0) + (next-coord 0) + (wrap-coord 0) + (spacing 0) + (distance-fn nil) + (extent-fn nil) + (limit-margin-fn nil) + (start-margin-fn nil) + (current nil)) + +(defun init-flow-data (layout visible kids width-hint height-hint) + (let ((state (if (find :vertical (style-of layout)) + (make-flow-data :hint height-hint + :next-coord (top-margin-of layout) + :wrap-coord (left-margin-of layout) + :spacing (spacing-of layout) + :distance-fn #'gfs:size-height + :extent-fn #'gfs:size-width + :limit-margin-fn #'bottom-margin-of + :start-margin-fn #'top-margin-of) + (make-flow-data :hint width-hint + :next-coord (left-margin-of layout) + :wrap-coord (top-margin-of layout) + :spacing (spacing-of layout) + :distance-fn #'gfs:size-width + :extent-fn #'gfs:size-height + :limit-margin-fn #'right-margin-of + :start-margin-fn #'left-margin-of)))) + (loop for kid in kids + when (or (visible-p kid) (not visible)) + do (let* ((size (preferred-size kid -1 -1)) + (dist (funcall (flow-data-distance-fn state) size)) + (extent (funcall (flow-data-extent-fn state) size))) + (if (< (flow-data-max-distance state) dist) + (setf (flow-data-max-distance state) dist)) + (if (< (flow-data-max-extent state) extent) + (setf (flow-data-max-extent state) extent)) + (push (list kid size) (flow-data-kid-sizes state)))) + (nreverse (flow-data-kid-sizes state)) + state)) + +(defun wrap-needed-p (state layout kid-size) + (and (>= (flow-data-hint state) 0) + (> (+ (flow-data-next-coord state) + (funcall (flow-data-distance-fn state) kid-size) + (funcall (flow-data-limit-margin-fn state) layout)) + (flow-data-hint state)))) + +(defun wrap-flow (state layout) + (let ((curr-flow (flow-data-current state))) + (setf (flow-data-current state) nil) + (setf (flow-data-next-coord state) (funcall (flow-data-start-margin-fn state) layout)) + (incf (flow-data-wrap-coord state) (+ (flow-data-max-extent state) (flow-data-spacing state))) + (setf (flow-data-max-extent state) 0) + (reverse curr-flow))) + +(defun new-flow-element (state layout kid kid-size) + (let ((pnt (gfs:make-point)) + (vertical (find :vertical (style-of layout))) + (normal (find :normalize (style-of layout)))) + (cond + ((and vertical normal) + (setf (gfs:point-x pnt) (flow-data-wrap-coord state) + (gfs:point-y pnt) (flow-data-next-coord state)) + (setf (gfs:size-width kid-size) (flow-data-max-extent state) + (gfs:size-height kid-size) (flow-data-max-distance state))) + ((and vertical (not normal)) + (setf (gfs:point-x pnt) (flow-data-wrap-coord state) + (gfs:point-y pnt) (flow-data-next-coord state))) + ((and (not vertical) normal) + (setf (gfs:point-x pnt) (flow-data-next-coord state) + (gfs:point-y pnt) (flow-data-wrap-coord state)) + (setf (gfs:size-width kid-size) (flow-data-max-distance state) + (gfs:size-height kid-size) (flow-data-max-extent state))) + ((and (not vertical) (not normal)) + (setf (gfs:point-x pnt) (flow-data-next-coord state) + (gfs:point-y pnt) (flow-data-wrap-coord state)))) + (incf (flow-data-next-coord state) (+ (funcall (flow-data-distance-fn state) kid-size) + (flow-data-spacing state))) + (cons kid (make-instance 'gfs:rectangle :size kid-size :location pnt)))) (defun flow-container-layout (layout visible kids width-hint height-hint) - (let* ((flows nil) - (curr-flow nil) - (spacing (spacing-of layout)) - (style (style-of layout)) - (vert-orient (find :vertical style)) - (wrap (find :wrap style)) - (max-size -1) - (next-coord (if vert-orient (top-margin-of layout) (left-margin-of layout))) - (wrap-coord (if vert-orient (left-margin-of layout) (top-margin-of layout)))) - (loop for kid in kids - do (let ((size (preferred-size kid -1 -1)) - (pnt (gfs:make-point))) - (when (or (visible-p kid) (not visible)) - (if vert-orient - (progn - (when (and wrap - (>= height-hint 0) - (> (+ next-coord - (gfs:size-height size) - (bottom-margin-of layout)) - height-hint)) - (push (reverse curr-flow) flows) - (setf curr-flow nil) - (setf next-coord (top-margin-of layout)) - (incf wrap-coord (+ max-size spacing)) - (setf max-size -1)) - (setf (gfs:point-x pnt) wrap-coord) - (setf (gfs:point-y pnt) next-coord) - (if (< max-size (gfs:size-width size)) - (setf max-size (gfs:size-width size))) - (incf next-coord (+ (gfs:size-height size) spacing))) - (progn - (when (and wrap - (>= width-hint 0) - (> (+ next-coord - (gfs:size-width size) - (right-margin-of layout)) - width-hint)) - (push (reverse curr-flow) flows) - (setf curr-flow nil) - (setf next-coord (left-margin-of layout)) - (incf wrap-coord (+ max-size spacing)) - (setf max-size -1)) - (setf (gfs:point-x pnt) next-coord) - (setf (gfs:point-y pnt) wrap-coord) - (if (< max-size (gfs:size-height size)) - (setf max-size (gfs:size-height size))) - (incf next-coord (+ (gfs:size-width size) spacing)))) - (push (cons kid (make-instance 'gfs:rectangle :size size :location pnt)) curr-flow)))) - (unless (null curr-flow) - (push (reverse curr-flow) flows)) - (loop for flow in (nreverse flows) append flow))) + (let ((flows nil) + (state (init-flow-data layout visible kids width-hint height-hint)) + (max-distance 0)) + (loop with wrap = (find :wrap (style-of layout)) + for (kid kid-size) in (flow-data-kid-sizes state) + do (if (and wrap (wrap-needed-p state layout kid-size)) + (setf flows (append flows (wrap-flow state layout)))) + (push (new-flow-element state layout kid kid-size) (flow-data-current state))) + (if (flow-data-current state) + (setf flows (append flows (wrap-flow state layout)))) + flows)) ;;; ;;; methods @@ -131,7 +185,6 @@ (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) (with-children (win kids) - #+gf-debug-widgets (format t "compute-layout: ~a~%~a~%" win kids) (flow-container-layout layout (visible-p win) kids width-hint height-hint))) (defmethod initialize-instance :after ((layout flow-layout) &key)

1 0

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

03 Jun '06

Author: junrue Date: Sat Jun 3 02:42:56 2006 New Revision: 146 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/widgets/widget-classes.lisp Log: added documentation and initial defclass for group class Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat Jun 3 02:42:56 2006 @@ -375,6 +375,34 @@ @end deffn @end deftp +@anchor{group} +@deftp Class group layout children location size style +A @code{group} represents a logical rectangular aggregation +of @ref{window} children which has the following properties +and behaviors: +@itemize @bullet +@item @emph{layout management}@* +Each @code{group} participates in the layout management protocol +on behalf of an aggregate of a real window's children.@*@* +@item @emph{limited event handling}@* +As part of their participation in the layout management protocol, +@code{group}s process move and size events, but otherwise do not +have any event handling responsibilities.@*@* +@item @emph{nesting}@* +Multiple @code{group}s may be nested.@*@* +@item @emph{no visual representation}@* +A @code{group} has no visual representation in and of itself. +Also, drawing operations are not clipped by or with respect +to a @code{group}.@*@* +@item @emph{windowless}@* +A @code{group} has no underlying native window handle. +@end itemize +Thus while @code{group} objects have functionality somewhat +like windows, they are intended to be lightweight, virtual +containers appropriate in circumstances where scalability is +paramount; they are not intended to be a full replacement. +@end deftp + @anchor{item} @deftp Class item item-id The @code{item} class is the base class for all non-windowed user Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Jun 3 02:42:56 2006 @@ -39,6 +39,29 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) +(defclass group () + ((layout + :accessor layout-of + :initarg :layout + :initform nil) + (children + :accessor children-of + :initarg :children + :initform nil) + (location + :accessor location-of + :initarg :location + :initform nil) + (size + :accessor size-of + :initarg :size + :initform nil) + (style + :accessor style-of + :initarg :style + :initform nil)) + (:documentation "Instances of this class act as lightweight containers for other objects.")) + (defclass event-source (gfs:native-object) ((dispatcher :accessor dispatcher

1 0

[graphic-forms-cvs] r145 - in trunk: . src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 02 Jun '06

02 Jun '06

Author: junrue Date: Fri Jun 2 18:59:13 2006 New Revision: 145 Modified: trunk/build.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: added with-rect macro to simplify code using Win32 rect structure Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Fri Jun 2 18:59:13 2006 @@ -45,7 +45,7 @@ (defvar *project-root* "c:/projects/public/") (setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) -(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060514/")) +(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-0.9.0/")) (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) (setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Fri Jun 2 18:59:13 2006 @@ -175,15 +175,10 @@ (setf gfs::tablength tab-width) (setf gfs::leftmargin 0) (setf gfs::rightmargin 0) - (cffi:with-foreign-object (rect-ptr 'gfs::rect) - (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) rect-ptr gfs::rect) - (setf gfs::left 0 - gfs::right 0 - gfs::top 0 - gfs::bottom 0) - (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) - (setf (gfs:size-width sz) (- gfs::right gfs::left)) - (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))))) + (gfs::with-rect + (gfs::draw-text-ex hdc str -1 gfs::rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) + (setf (gfs:size-width sz) (- gfs::right gfs::left)) + (setf (gfs:size-height sz) (- gfs::bottom gfs::top)))))) (when (or (zerop len) (zerop (gfs:size-height sz))) (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) tm-ptr gfs::textmetrics) @@ -297,21 +292,19 @@ (let ((hdc (gfs:handle self)) (pnt (gfs:location rect)) (size (gfs:size rect))) - (cffi:with-foreign-object (rect-ptr 'gfs::rect) - (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) - rect-ptr gfs::rect) - (setf gfs::top (gfs:point-y pnt)) - (setf gfs::left (gfs:point-x pnt)) - (setf gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size))) - (setf gfs::right (+ (gfs:point-x pnt) (gfs:size-width size))) - (gfs::ext-text-out hdc - (gfs:point-x pnt) - (gfs:point-y pnt) - gfs::+eto-opaque+ - rect-ptr - "" - 0 - (cffi:null-pointer)))))) + (gfs::with-rect + (setf gfs::top (gfs:point-y pnt) + gfs::left (gfs:point-x pnt) + gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size)) + gfs::right (+ (gfs:point-x pnt) (gfs:size-width size))) + (gfs::ext-text-out hdc + (gfs:point-x pnt) + (gfs:point-y pnt) + gfs::+eto-opaque+ + rect-ptr + "" + 0 + (cffi:null-pointer))))) |# (defmethod draw-filled-rounded-rectangle ((self graphics-context) rect size) @@ -448,24 +441,22 @@ (setf gfs::tablength tb-width) (setf gfs::leftmargin 0) (setf gfs::rightmargin 0) - (cffi:with-foreign-object (rect-ptr 'gfs::rect) - (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) - rect-ptr gfs::rect) - (setf gfs::left (gfs:point-x pnt)) - (setf gfs::top (gfs:point-y pnt)) - (gfs::draw-text-ex (gfs:handle self) - text - -1 - rect-ptr - (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+))) - dt-ptr) - (gfs::draw-text-ex (gfs:handle self) - text - (length text) - rect-ptr - flags - dt-ptr) - (gfs::set-bk-mode (gfs:handle self) old-bk-mode))))))) + (gfs::with-rect + (setf gfs::left (gfs:point-x pnt)) + (setf gfs::top (gfs:point-y pnt)) + (gfs::draw-text-ex (gfs:handle self) + text + -1 + gfs::rect-ptr + (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+))) + dt-ptr) + (gfs::draw-text-ex (gfs:handle self) + text + (length text) + gfs::rect-ptr + flags + dt-ptr) + (gfs::set-bk-mode (gfs:handle self) old-bk-mode)))))) (defmethod (setf font) ((font font) (self graphics-context)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Fri Jun 2 18:59:13 2006 @@ -58,6 +58,13 @@ ;;; convenience macros ;;; +(defmacro with-rect (&body body) + `(cffi:with-foreign-object (rect-ptr 'gfs::rect) + (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) + rect-ptr gfs::rect) + (zero-mem rect-ptr gfs::rect) + ,@body))) + (defmacro with-hfont-selected ((hdc hfont) &body body) (let ((hfont-old (gensym))) `(let ((,hfont-old nil)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Jun 2 18:59:13 2006 @@ -169,19 +169,16 @@ (defmethod compute-outer-size ((win window) desired-client-size) (let ((hwnd (gfs:handle win)) (new-size (gfs:make-size))) - (cffi:with-foreign-object (rect-ptr 'gfs::rect) - (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) rect-ptr gfs::rect) - (setf gfs::left 0 - gfs::top 0 - gfs::right (gfs:size-width desired-client-size) - gfs::bottom (gfs:size-height desired-client-size)) - (if (zerop (gfs::adjust-window-rect rect-ptr - (gfs::get-window-long hwnd gfs::+gwl-style+) - (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) - (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) - (error 'gfs:win32-error :detail "adjust-window-rect failed")) - (setf (gfs:size-width new-size) (- gfs::right gfs::left) - (gfs:size-height new-size) (- gfs::bottom gfs::top)))) + (gfs::with-rect + (setf gfs::right (gfs:size-width desired-client-size) + gfs::bottom (gfs:size-height desired-client-size)) + (if (zerop (gfs::adjust-window-rect gfs::rect-ptr + (gfs::get-window-long hwnd gfs::+gwl-style+) + (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) + (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (error 'gfs:win32-error :detail "adjust-window-rect failed")) + (setf (gfs:size-width new-size) (- gfs::right gfs::left) + (gfs:size-height new-size) (- gfs::bottom gfs::top))) new-size)) (defmethod enable-layout :before ((win window) flag)

1 0

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

02 Jun '06

Author: junrue Date: Fri Jun 2 16:16:50 2006 New Revision: 144 Added: trunk/src/tests/uitoolkit/misc-unit-tests.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: fixed stupid bugs in obtain-displays; refactored display methods to call centralized query-display-info function Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Jun 2 16:16:50 2006 @@ -248,10 +248,6 @@ list of all @code{display}s (more than one if the system has multiple monitors), or @ref{obtain-primary-display} to get the primary. It derives from @ref{native-object}. -@deffn Reader primary-p -Returns T if the system regards this display as the primary -display; nil otherwise. -@end deffn @end deftp @anchor{event-dispatcher} @@ -965,6 +961,11 @@ must determine how tall it would be given that width. @end deffn +@deffn Function primary-p display +Returns T if the system regards the specified display as the primary +display; nil otherwise. +@end deffn + @deffn GenericFunction redraw self Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Fri Jun 2 16:16:50 2006 @@ -78,6 +78,7 @@ (:file "image-unit-tests") (:file "layout-unit-tests") (:file "widget-unit-tests") + (:file "misc-unit-tests") (:file "hello-world") (:file "event-tester") (:file "layout-tester") Added: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Fri Jun 2 16:16:50 2006 @@ -0,0 +1,46 @@ +;;;; +;;;; misc-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) + +(define-test primary-display-test + (let ((display (gfw:obtain-primary-display))) + (assert-true display) + (assert-true (gfw:primary-p display)) + (let ((size (gfw:size display))) + (assert-true (> (gfs:size-width size) 0)) + (assert-true (> (gfs:size-height size) 0))) + (let ((size (gfw:client-size display))) + (assert-true (> (gfs:size-width size)) 0) + (assert-true (> (gfs:size-height size)) 0)) + (assert-true (> (length (gfw:text display)) 0)))) Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Fri Jun 2 16:16:50 2006 @@ -54,6 +54,30 @@ (call-display-visitor-func (thread-context) hmonitor data) 1) +(defun query-display-info (hmonitor) + (let ((info nil)) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor gfs::work + gfs::flags gfs::device) + mi-ptr gfs::monitorinfoex) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::monitorinfoex)) + (if (zerop (gfs::get-monitor-info hmonitor mi-ptr)) + (error 'gfs:win32-warning :detail "get-monitor-info failed")) + (push (= (logand gfs::flags gfs::+monitorinfoof-primary+) gfs::+monitorinfoof-primary+) info) + (let ((str-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::device))) + (push (cffi:foreign-string-to-lisp str-ptr (1- gfs::+cchdevicename+)) info)) + (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::monitor))) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) + rect-ptr gfs::rect) + (push (gfs:make-size :width (- gfs::right gfs::left) :height (- gfs::bottom gfs::top)) + info))) + (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::work))) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) + rect-ptr gfs::rect) + (push (gfs:make-size :width (- gfs::right gfs::left) :height (- gfs::bottom gfs::top)) + info))))) + (reverse info))) + (defun mapdisplays (func) ;; ;; func should expect two parameters: @@ -65,8 +89,7 @@ (unwind-protect #+lispworks (let ((ptr (fli:make-pointer :address 0))) (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) -#+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) - (gfs::enum-display-monitors ptr ptr #'display_visitor 0)) +#+clisp (gfs::enum-display-monitors nil nil #'display_visitor nil) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -74,11 +97,9 @@ (defun obtain-displays () (mapdisplays (lambda (hmonitor data) - (let ((pflag (= (logand data gfs::+monitorinfoof-primary+) - gfs::+monitorinfoof-primary+)) - (display (make-instance 'display :handle hmonitor))) - (setf (slot-value display 'primary) pflag) - (push display (display-visitor-results (thread-context))))))) + (declare (ignore data)) + (push (make-instance 'display :handle hmonitor) + (display-visitor-results (thread-context)))))) (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) @@ -129,44 +150,30 @@ (defmethod client-size ((self display)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((size (gfs::make-size))) - (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) - (cffi:with-foreign-slots ((gfs::cbsize gfs::work) - mi-ptr gfs::monitorinfoex) - (gfs::get-monitor-info (gfs:handle self) mi-ptr) - (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::work))) - (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) - rect-ptr gfs::rect) - (setf (gfs:size-width size) (- gfs::right gfs::left)) - (setf (gfs:size-height size) (- gfs::bottom gfs::top)))))) - size)) + (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self)) + (declare (ignore primary name size)) + client-size)) (defmethod gfs:dispose ((self display)) (setf (slot-value self 'gfs:handle) nil)) +(defun primary-p (self) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self)) + (declare (ignore name size client-size)) + primary)) + (defmethod size ((self display)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((size (gfs::make-size))) - (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) - (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor) - mi-ptr gfs::monitorinfoex) - (gfs::get-monitor-info (gfs:handle self) mi-ptr) - (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::monitor))) - (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) - rect-ptr gfs::rect) - (setf (gfs:size-width size) (- gfs::right gfs::left)) - (setf (gfs:size-height size) (- gfs::bottom gfs::top)))))) + (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self)) + (declare (ignore primary name client-size)) size)) (defmethod text ((self display)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((name "")) - (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) - (cffi:with-foreign-slots ((gfs::cbsize gfs::device) - mi-ptr gfs::monitorinfoex) - (gfs::get-monitor-info (gfs:handle self) mi-ptr) - (let ((str-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::device))) - (setf name (cffi:foreign-string-to-lisp str-ptr (1- gfs::+cchdevicename+)))))) + (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self)) + (declare (ignore primary size client-size)) name)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Jun 2 16:16:50 2006 @@ -33,10 +33,7 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defclass display (gfs:native-object) - ((primary - :reader primary-p - :initform nil)) +(defclass display (gfs:native-object) () (:documentation "Instances of this class describe characteristics of monitors attached to the system.")) (defclass event-dispatcher () ()

1 0

[graphic-forms-cvs] r143 - trunk/docs/manual
by junrue＠common-lisp.net 01 Jun '06

01 Jun '06

Author: junrue Date: Thu Jun 1 18:26:31 2006 New Revision: 143 Modified: trunk/docs/manual/api.texinfo Log: fixed typo Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Jun 1 18:26:31 2006 @@ -988,7 +988,7 @@ @end deffn @deffn GenericFunction text-baseline self => integer -Returns the y coordinate value (relative to the top of the @code{self}'s +Returns the y coordinate value (relative to the top of @code{self}'s bounding box) that correlates to the baseline of the text of the @ref{control}, if any. For controls in which a text baseline is not meaningful, such as a @ref{label} with an @ref{image}, this function @@ -1016,7 +1016,7 @@ @end html @anchor{with-file-dialog} -@deffn Macro with-file-dialog (owner style paths &key default extension filters initial-directory initial-filename text) &body body +@deffn Macro with-file-dialog (owner style paths &key default-extension filters initial-directory initial-filename text) &body body This macro wraps the instantiation of a standard file open/save dialog and the subsequent retrieval of the user's file selections. @xref{file-dialog}.

1 0

[graphic-forms-cvs] r142 - trunk/src/uitoolkit/system
by junrue＠common-lisp.net 01 Jun '06

01 Jun '06

Author: junrue Date: Thu Jun 1 18:25:22 2006 New Revision: 142 Modified: trunk/src/uitoolkit/system/user32.lisp Log: added bindings for mouse capture/release Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Jun 1 18:25:22 2006 @@ -525,6 +525,10 @@ (wndclass LPTR)) (defcfun + ("ReleaseCapture" release-capture) + BOOL) + +(defcfun ("ReleaseDC" release-dc) INT (hwnd HANDLE) @@ -557,6 +561,11 @@ (hwnd HANDLE)) (defcfun + ("SetCapture" set-capture) + HANDLE + (hwnd HANDLE)) + +(defcfun ("SetFocus" set-focus) HANDLE (hwnd HANDLE))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

graphic-forms-cvs June 2006