graphic-forms-cvs April 2006

graphic-forms-cvs@common-lisp.net

1 participants
30 discussions

[graphic-forms-cvs] r114 - in trunk: . docs/manual src src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 30 Apr '06

30 Apr '06

Author: junrue Date: Sun Apr 30 02:08:25 2006 New Revision: 114 Added: trunk/src/uitoolkit/widgets/heap-layout.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layout-generics.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/window.lisp Log: initial implementation of heap-layout, possible container cleanup issues needing investigation; also made some layout-related doc enhancements Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 30 02:08:25 2006 @@ -502,7 +502,7 @@ @end deffn @deffn Initarg :layout @end deffn -@deffn Accessor layout +@deffn Accessor layout-of @end deffn @end deftp @@ -513,17 +513,59 @@ @strong{NOTE:} A future release will provide additional layout manager classes. -@anchor{layout-manager} -@deftp Class layout-manager style -Subclasses implement layout strategies on behalf of window objects. +@anchor{flow-layout} +@deftp Class flow-layout spacing +This @ref{layout-manager} subclass arranges dialog or window children +in a row or column, with optional spacing (specified in pixels) +between children. +@deffn Initarg :style +This initarg accepts a list containing one of the following +style keywords: +@table @code +@item :horizontal +Specifies arrangement in a horizontal row. This style is the default. +@item :vertical +Specifies arrangement in a vertical column. +@item :wrap +This style keyword enables the arrangement of children to be +wrapped if the available horizontal (or vertical) space within +the container is less than the layout requests for a full +row (or column). The default behavior is unwrapped. +@end table +@end deffn @end deftp -@anchor{flow-layout} -@deftp Class flow-layout spacing left-margin top-margin right-margin bottom-margin -This @ref{layout-manager} subclass arranges window children in a row -or column, with optional margins around the row/column and spacing in -between children. The layout can wrap the window children if desired -and the available horizontal (or vertical) space is constrained. +@anchor{heap-layout} +@deftp Class heap-layout top-child +This @ref{layout-manager} subclass resizes all children to the same +size and stacks them on top of each other. +@deffn Initarg :top-child +Use this initarg to specify the child widget that should be visible. +The corresponding accessor @code{top-child-of} can be set +subsequently, followed by calling @ref{layout} on the container, in +order to make a different child visible. +@end deffn +@end deftp + +@anchor{layout-manager} +@deftp Class layout-manager style left-margin top-margin right-margin bottom-margin +Subclasses implement layout strategies on behalf of window +objects. Every layout manager allows optional margins (specified in +pixels) within the perimeter of the container being managed.@*@* The +values accepted by the @code{:style} initarg vary depending on the +actual @code{layout-manager} subclass being used. +@deffn Initarg :horizontal-margins +This initarg accepts a horizontal margin value that is applied to both +the left and right sides of the container. +@end deffn +@deffn Initarg :margins +This initarg accepts a margin value that is applied to all sides of +the container. +@end deffn +@deffn Initarg :vertical-margins +This initarg accepts a vertical margin value that is applied to both +the top and bottom of the container. +@end deffn @end deftp @@ -709,6 +751,7 @@ Return the zero-based index of the location of the other object in this object. @end deffn +@anchor{layout} @deffn GenericFunction layout self Set the size and location of this object's children. @end deffn @@ -861,19 +904,42 @@ @node layout functions @section layout functions -@deffn GenericFunction compute-layout layout window width-hint height-hint -Returns a list of conses @code{(window . rectangle)} describing the +These functions comprise the protocol for @ref{layout-manager}s. As +such, they are not normally called by application code, but instead +are the concern of layout-manager implementers. + +The @code{width-hint} and @code{height-hint} parameters are a +mechanism to express the @emph{what-if} scenario where the total width +or height of the container is fixed; the proper response is to +calculate the container's desired dimension on the opposite +axis. While this behavior is primarily the concern of child windows +and/or controls, layout manager implementations should look for +non-negative values for either @code{width-hint} or +@code{height-hint}, indicating that the container's size is +constrained. + +@anchor{compute-layout} +@deffn GenericFunction compute-layout layout container width-hint height-hint +Returns a list of conses @code{(child . rectangle)} describing the new bounds of each child window or control. A @ref{layout-manager} subclass implements this method based on its particular layout strategy, taking into account attributes set by the user. Certain Graphic-Forms functions -call this method to accomplish layout within a window. +call this method to accomplish layout within a container. @end deffn -@deffn GenericFunction compute-size layout window width-hint height-hint -Computes and returns the new @ref{size} of the window's client area. A -@ref{layout-manager} subclass implements this method based on its -particular layout strategy, taking into account attributes set by the -user. The @ref{pack} function ultimately calls this method. +@deffn GenericFunction compute-size layout container width-hint height-hint +Computes and returns the new @ref{size} of the @code{container}'s +client area. A @ref{layout-manager} subclass implements this method +based on its particular layout strategy, taking into account +attributes set by the user. The @ref{pack} function ultimately calls +this method. +@end deffn + +@deffn GenericFunction perform layout container width-hint height-hint +Calls @ref{compute-layout} for @code{container} and then moves and +resizes @code{container}'s children. Layout subclasses may override +this method -- most derivations should call @sc{CALL-NEXT-METHOD} to +allow the base implementation to execute. @end deffn Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Apr 30 02:08:25 2006 @@ -112,4 +112,5 @@ (:file "dialog") (:file "file-dialog") (:file "layout") + (:file "heap-layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Apr 30 02:08:25 2006 @@ -222,6 +222,7 @@ #:event-source #:file-dialog #:flow-layout + #:heap-layout #:item #:layout-manager #:menu @@ -463,6 +464,7 @@ #:text-limit #:thumb-size #:tooltip-text + #:top-child-of #:top-index #:top-margin-of #:traverse Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Apr 30 02:08:25 2006 @@ -33,6 +33,14 @@ (in-package :graphic-forms.uitoolkit.system) +;;; +;;; The following variables are used with set-window-pos +;;; +(defvar *hwnd-top* (cffi:null-pointer)) +(defvar *hwnd-bottom* (cffi:make-pointer #x00000001)) +(defvar *hwnd-topmost* (cffi:make-pointer #xFFFFFFFF)) +(defvar *hwnd-notopmost* (cffi:make-pointer #xFFFFFFFE)) + (defconstant +button-classname+ "button") (defconstant +static-classname+ "static") Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Apr 30 02:08:25 2006 @@ -134,22 +134,6 @@ #+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 style margins horz-margins vert-margins - &allow-other-keys) - (unless (listp style) - (setf style (list style))) - (if (and (null (find :horizontal style)) (null (find :vertical style))) - (push :horizontal style)) - (setf (style-of layout) style) - (unless (null margins) - (setf (left-margin-of layout) margins) - (setf (right-margin-of layout) margins) - (setf (top-margin-of layout) margins) - (setf (bottom-margin-of layout) margins)) - (unless (null horz-margins) - (setf (left-margin-of layout) horz-margins) - (setf (right-margin-of layout) horz-margins)) - (unless (null vert-margins) - (setf (top-margin-of layout) vert-margins) - (setf (bottom-margin-of layout) vert-margins))) +(defmethod initialize-instance :after ((layout flow-layout) &key) + (unless (intersection (style-of layout) '(:horizontal :vertical)) + (setf (style-of layout) (list :horizontal)))) Added: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Sun Apr 30 02:08:25 2006 @@ -0,0 +1,104 @@ +;;;; +;;;; heap-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) + +;;; +;;; methods +;;; + +(defmethod compute-size ((self heap-layout) win width-hint height-hint) + (let ((size (gfs:make-size))) + (with-children (win kids) + (loop for kid in kids + do (let ((kid-size (preferred-size kid width-hint height-hint))) + (setf (gfs:size-width size) (max (gfs:size-width size) + (gfs:size-width kid-size)) + (gfs:size-height size) (max (gfs:size-height size) + (gfs:size-height kid-size)))))) + (incf (gfs:size-width size) (+ (left-margin-of self) (right-margin-of self))) + (incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self))) + size)) + +(defmethod compute-layout ((self heap-layout) win width-hint height-hint) + (let* ((size (client-size win)) + (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 (make-instance 'gfs:rectangle :size new-size :location new-pnt))) + (with-children (win kids) + (loop for kid in kids collect (cons kid bounds))))) + +(defmethod perform ((self heap-layout) win width-hint height-hint) + (let ((kids nil) + (hdwp (cffi:null-pointer)) + (top (top-child-of self))) + (when (layout-p win) + (setf kids (compute-layout self win width-hint height-hint)) + (setf hdwp (gfs::begin-defer-window-pos (length kids))) + (loop for k in kids + do (let* ((rect (cdr k)) + (sz (gfs:size rect)) + (pnt (gfs:location rect)) + (kid-win (car k)) + (hwnd-after (cffi:null-pointer)) + (flags (logior +window-pos-flags+ gfs::+swp-hidewindow+))) + (when (cffi:pointer-eq (gfs:handle kid-win) (gfs:handle top)) + (setf hwnd-after gfs::*hwnd-top* + flags (logior +window-pos-flags+ gfs::+swp-showwindow+))) + (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle kid-win) + hwnd-after + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width sz) + (gfs:size-height sz) + flags) + (setf hdwp (gfs::defer-window-pos hdwp + (gfs:handle kid-win) + hwnd-after + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width sz) + (gfs:size-height sz) + flags))))) + (unless (gfs:null-handle-p hdwp) + (gfs::end-defer-window-pos hdwp))))) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Sun Apr 30 02:08:25 2006 @@ -37,14 +37,7 @@ ((style :accessor style-of :initarg :style - :initform nil)) - (:documentation "Subclasses implement layout strategies on behalf of window objects.")) - -(defclass flow-layout (layout-manager) - ((spacing - :accessor spacing-of - :initarg :spacing - :initform 0) + :initform nil) (left-margin :accessor left-margin-of :initarg :left-margin @@ -61,4 +54,18 @@ :accessor bottom-margin-of :initarg :bottom-margin :initform 0)) + (:documentation "Subclasses implement layout strategies on behalf of window objects.")) + +(defclass flow-layout (layout-manager) + ((spacing + :accessor spacing-of + :initarg :spacing + :initform 0)) (:documentation "Window children are arranged in a row or column.")) + +(defclass heap-layout (layout-manager) + ((top-child + :accessor top-child-of + :initarg :top-child + :initform nil)) + (:documentation "Window children are stacked one on top of the other.")) Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Sun Apr 30 02:08:25 2006 @@ -38,3 +38,6 @@ (defgeneric compute-layout (layout win width-hint height-hint) (:documentation "Returns a list of conses (window . rectangle) describing the new bounds of each child window.")) + +(defgeneric perform (layout window widget-hint height-hint) + (:documentation "Moves and resizes window children based on layout strategy.")) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Apr 30 02:08:25 2006 @@ -38,12 +38,31 @@ gfs::+swp-noactivate+ gfs::+swp-nocopybits+)) -(defun perform-layout (win width-hint height-hint) +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((layout layout-manager) + &key style margins horizontal-margins vertical-margins + &allow-other-keys) + (setf (style-of layout) (if (listp style) style (list style))) + (unless (null margins) + (setf (left-margin-of layout) margins) + (setf (right-margin-of layout) margins) + (setf (top-margin-of layout) margins) + (setf (bottom-margin-of layout) margins)) + (unless (null horizontal-margins) + (setf (left-margin-of layout) horizontal-margins) + (setf (right-margin-of layout) horizontal-margins)) + (unless (null vertical-margins) + (setf (top-margin-of layout) vertical-margins) + (setf (bottom-margin-of layout) vertical-margins))) + +(defmethod perform ((layout layout-manager) win width-hint height-hint) "Calls compute-layout for a window and then handles the actual moving and resizing of its children." - (let ((layout (layout-of win)) - (kids nil) - (hdwp nil)) - (when (and (layout-p win) layout) + (let ((kids nil) + (hdwp (cffi:null-pointer))) + (when (layout-p win) (setf kids (compute-layout layout win width-hint height-hint)) (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 30 02:08:25 2006 @@ -156,10 +156,10 @@ m))) (defmethod (setf maximum-size) :after (max-size (win top-level)) - (unless (gfs:disposed-p win) + (unless (or (gfs:disposed-p win) (null (layout-of win))) (let ((size (constrain-new-size max-size (size win) #'min))) (setf (size win) size) - (perform-layout win (gfs:size-width size) (gfs:size-height size))))) + (perform (layout-of win) win (gfs:size-width size) (gfs:size-height size))))) (defmethod (setf menu-bar) :before ((m menu) (win top-level)) (declare (ignore m)) @@ -178,10 +178,10 @@ (gfs::draw-menu-bar hwnd))) (defmethod (setf minimum-size) :after (min-size (win top-level)) - (unless (gfs:disposed-p win) + (unless (or (gfs:disposed-p win) (null (layout-of win))) (let ((size (constrain-new-size min-size (size win) #'max))) (setf (size win) size) - (perform-layout win (gfs:size-width size) (gfs:size-height size))))) + (perform (layout-of win) win (gfs:size-width size) (gfs:size-height size))))) (defmethod print-object ((self top-level) stream) (print-unreadable-object (self stream :type t) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Apr 30 02:08:25 2006 @@ -174,14 +174,15 @@ (defmethod enable-layout ((win window) flag) (setf (slot-value win 'layout-p) flag) - (if flag + (if (and flag (layout-of win)) (let ((sz (client-size win))) - (perform-layout win (gfs:size-width sz) (gfs:size-height sz))))) + (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) (defmethod event-resize ((d event-dispatcher) (win window) time size type) (declare (ignorable d time size type)) - (let ((sz (client-size win))) - (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) + (unless (null (layout-of win)) + (let ((sz (client-size win))) + (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) (defmethod focus-p :before ((win window)) (if (gfs:disposed-p win) @@ -207,11 +208,13 @@ pnt)) (defmethod layout ((win window)) - (let ((sz (client-size win))) - (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) + (unless (null (layout-of win)) + (let ((sz (client-size win))) + (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) (defmethod pack ((win window)) - (perform-layout win -1 -1) + (unless (null (layout-of win)) + (perform (layout-of win) win -1 -1)) (call-next-method)) (defmethod preferred-size ((win window) width-hint height-hint)

1 0

[graphic-forms-cvs] r113 - in trunk: docs/manual docs/website src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 29 Apr '06

29 Apr '06

Author: junrue Date: Sat Apr 29 11:11:47 2006 New Revision: 113 Modified: trunk/docs/manual/api.texinfo trunk/docs/website/index.html trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event.lisp Log: implemented event-focus-gain/event-focus-loss methods Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat Apr 29 11:11:47 2006 @@ -551,6 +551,16 @@ @ref{dispose}, not the garbage collector). @end deffn +@anchor{event-focus-gain} +@deffn GenericFunction event-focus-gain dispatcher widget time +Implement this to respond to an object gaining keyboard focus. +@end deffn + +@anchor{event-focus-loss} +@deffn GenericFunction event-focus-gain dispatcher widget time +Implement this to respond to an object losing keyboard focus. +@end deffn + @deffn GenericFunction event-key-down dispatcher widget time keycode char Implement this to respond to a key down event. @end deffn Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Sat Apr 29 11:11:47 2006 @@ -57,7 +57,7 @@ <h3>Status</h3> - <p>The first release, version 0.2.0, is now available.</p> + <p>The current release is version 0.3.0.</p> <p>This library is in the early implementation stage. Brave souls who experiment with the code should expect significant API and Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat Apr 29 11:11:47 2006 @@ -748,6 +748,13 @@ (defconstant +wm-move+ #x0003) (defconstant +wm-size+ #x0005) (defconstant +wm-activate+ #x0006) +(defconstant +wm-setfocus+ #x0007) +(defconstant +wm-killfocus+ #x0008) +(defconstant +wm-enable+ #x000A) +(defconstant +wm-setredraw+ #x000B) +(defconstant +wm-settext+ #x000C) +(defconstant +wm-gettext+ #x000D) +(defconstant +wm-gettextlength+ #x000E) (defconstant +wm-paint+ #x000F) (defconstant +wm-close+ #x0010) (defconstant +wm-getminmaxinfo+ #x0024) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Apr 29 11:11:47 2006 @@ -318,6 +318,22 @@ (declare (ignore wparam)) (process-mouse-message #'event-mouse-up hwnd lparam :right-button)) +(defmethod process-message (hwnd (msg (eql gfs::+wm-killfocus+)) wparam lparam) + (declare (ignore wparam lparam)) + (let* ((tc (thread-context)) + (widget (get-widget tc hwnd))) + (if widget + (event-focus-loss (dispatcher widget) widget (event-time tc)))) + 0) + +(defmethod process-message (hwnd (msg (eql gfs::+wm-setfocus+)) wparam lparam) + (declare (ignore wparam lparam)) + (let* ((tc (thread-context)) + (widget (get-widget tc hwnd))) + (if widget + (event-focus-gain (dispatcher widget) widget (event-time tc)))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-getminmaxinfo+)) wparam lparam) (declare (ignore wparam)) (let* ((tc (thread-context))

1 0

[graphic-forms-cvs] r112 - tags/release-0.3.0
by junrue＠common-lisp.net 26 Apr '06

26 Apr '06

Author: junrue Date: Wed Apr 26 13:02:03 2006 New Revision: 112 Added: tags/release-0.3.0/ - copied from r111, trunk/ Log: tagging the 0.3.0 release

1 0

[graphic-forms-cvs] r111 - in trunk/src: . uitoolkit/widgets
by junrue＠common-lisp.net 26 Apr '06

26 Apr '06

Author: junrue Date: Wed Apr 26 12:29:35 2006 New Revision: 111 Modified: trunk/src/packages.lisp trunk/src/uitoolkit/widgets/event.lisp Log: remove dangling references to obsolete stop function Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Apr 26 12:29:35 2006 @@ -454,10 +454,8 @@ #:shutdown #:size #:spacing-of - #:start #:startup #:step-increment - #:stop #:style-of #:sub-menu #:text Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed Apr 26 12:29:35 2006 @@ -377,7 +377,7 @@ (gfs::kill-timer (cffi:null-pointer) wparam) (progn (if (<= (delay-of timer) 0) - (stop timer) + (enable timer nil) (reset-timer-to-delay timer (delay-of timer))) (event-timer (dispatcher timer) timer (event-time tc))))) 0)

1 0

[graphic-forms-cvs] r110 - in trunk: . src
by junrue＠common-lisp.net 26 Apr '06

26 Apr '06

Author: junrue Date: Wed Apr 26 12:23:40 2006 New Revision: 110 Modified: trunk/README.txt trunk/src/packages.lisp Log: pre-0.3.0 cleanup Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Apr 26 12:23:40 2006 @@ -72,6 +72,11 @@ in the gaps). This demo program is not yet finished, but the source code can still serve as sample code. +5. The text-extent generic function currently does not return + the correct text height. As a workaround, get the text metrics + for the desired font and base height calculations on that + value. The text-extent function does return the correct width. + How To Configure and Build Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Apr 26 12:23:40 2006 @@ -392,7 +392,6 @@ #:item-height #:item-id #:item-index - #:item-owner #:items #:key-down-p #:key-toggled-p

1 0

[graphic-forms-cvs] r109 - in trunk: . docs/manual src/demos/unblocked src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 26 Apr '06

26 Apr '06

Author: junrue Date: Wed Apr 26 12:14:57 2006 New Revision: 109 Modified: trunk/README.txt trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/widgets/timer.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: made API change for timers -- use existing enable generic function instead of start/stop; miscellaneous doc updates Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Apr 26 12:14:57 2006 @@ -34,6 +34,12 @@ http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html +Supported Common Lisp Implementations +------------------------------------- + +Graphic-Forms currently supports CLISP 2.38 and LispWorks 4.4.6. + + Known Problems -------------- @@ -46,7 +52,7 @@ http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1… may result in intermittent GPFs when windows with layout managers are - resized or when timer objects are initialized. + resized or when timer objects are enabled. 2. Image loading currently requires installation of the ImageMagick library as described in the next section. I have tested with Windows @@ -60,10 +66,12 @@ not get disabled. However, the GFW:ENABLE function does otherwise work correctly for menu items. -4. Graphic-Forms supports CLISP 2.38 and LispWorks 4.4.6. The - intention is to support additional Lisp vendors, but currently - the library will not run on anything but CLISP or LW due to some - vendor-specific features that have to be used. +4. The src/demos/unblocked directory contains a start at a demo + program (a simple game where one clicks on block shapes to + score points, where the rest of the blocks fall down to fill + in the gaps). This demo program is not yet finished, but the + source code can still serve as sample code. + How To Configure and Build @@ -145,6 +153,8 @@ (in-package :gft) (run-tests) ;; runs the unit tests (many more to be added) + (gft::run-drawing-tester) + (gft::run-event-tester) (gft::run-image-tester) Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed Apr 26 12:14:57 2006 @@ -415,18 +415,24 @@ @end quotation @end deftp +@anchor{timer} @deftp Class timer A timer is a non-windowed object that generates events at a regular -(adjustable) frequency. It derives from @ref{event-source}. -@deffn Reader id-of -@end deffn +(adjustable) frequency. Applications handle timer events by +implementing the @ref{event-timer} generic function. This class +derives from @ref{event-source}. @deffn Initarg :initial-delay -@end deffn -@deffn Reader initial-delay +This initarg accepts a milliseconds value specifying how much of a +delay should occur between the call to @ref{enable} the timer and the +first tick event. If specified, this value must be non-negative. @end deffn @deffn Initarg :delay -@end deffn -@deffn Accessor delay +This initarg accepts a milliseconds value specifying how much delay +should occur between subsequent tick events. If @code{:initial-delay} +was not specified, then this value will be used as the initial delay +time as well. Setting @code{:delay} to zero and setting +@code{:initial-delay} to a positive value has the effect of creating a +@emph{one-shot} timer. @end deffn @end deftp @@ -588,6 +594,7 @@ Implement this to respond to an object (or item within) being selected. @end deffn +@anchor{event-timer} @deffn GenericFunction event-timer dispatcher timer time Implement this to respond to a tick from a specific timer. @end deffn @@ -664,9 +671,11 @@ from display-relative coordinates to this object's coordinate system. @end deffn +@anchor{enable} @deffn GenericFunction enable self flag -Enables or disables the object, causing it to be redrawn with its -default look and allows it to be selected. +For widgets, this function enables or disables the object, causing it +to be redrawn with its default look and allows it to be selected. This +function is also used to start and stop @ref{timer}s. @end deffn @deffn GenericFunction enable-layout self flag @@ -817,14 +826,6 @@ parent's coordinate system. @end deffn -@deffn GenericFunction start self -Enable event generation at regular intervals. -@end deffn - -@deffn GenericFunction stop self -Stop producing events. -@end deffn - @deffn GenericFunction text self Returns the object's text. @end deffn Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Wed Apr 26 12:14:57 2006 @@ -111,6 +111,7 @@ (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) (setf (gfw:minimum-size *unblocked-win*) size) (setf (gfw:maximum-size *unblocked-win*) size)) + (new-unblocked nil nil nil nil) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Wed Apr 26 12:14:57 2006 @@ -207,12 +207,12 @@ (declare (ignore disp item time rect)) (if *timer* (progn - (gfw:stop *timer*) + (gfw:enable *timer* nil) (setf *timer* nil) (setf *event-tester-text* "timer stopped by user")) (progn (setf *timer* (make-instance 'gfw:timer :delay 1000 :dispatcher (make-instance 'event-tester-echo-dispatcher))) - (gfw:start *timer*) + (gfw:enable *timer* t) (setf *event-tester-text* (format nil "timer ~d started init delay: ~d delay ~d" (gfw:id-of *timer*) Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Wed Apr 26 12:14:57 2006 @@ -108,18 +108,18 @@ (setf (slot-value self 'initial-delay) init-delay) (setf (slot-value self 'delay) delay))) -(defmethod start ((self timer)) - ;; use init-delay as the elapse interval for the very first - ;; tick; the interval will be adjusted (or the timer killed) - ;; as part of processing the first event - ;; - (let ((init-delay (initial-delay-of self))) - (if (> init-delay 0) - (reset-timer-to-delay self init-delay) - (reset-timer-to-delay self (delay-of self))))) - -(defmethod stop ((self timer)) - (remove-timer (thread-context) self)) ;; kill-timer will be called on the next tick +(defmethod enable ((self timer) flag) + (if flag + (progn + ;; use init-delay as the elapse interval for the very first + ;; tick; the interval will be adjusted (or the timer killed) + ;; as part of processing the first event + ;; + (let ((init-delay (initial-delay-of self))) + (if (> init-delay 0) + (reset-timer-to-delay self init-delay) + (reset-timer-to-delay self (delay-of self))))) + (remove-timer (thread-context) self))) ;; kill-timer will be called on the next tick (defmethod running-p ((self timer)) (get-timer (thread-context) (id-of self))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Apr 26 12:14:57 2006 @@ -330,15 +330,9 @@ (defgeneric size (self) (:documentation "Returns a size object describing the size of the object in its parent's coordinate system.")) -(defgeneric start (self) - (:documentation "Enable event generation at regular intervals.")) - (defgeneric step-increment (self) (:documentation "Return an integer representing the configured step size for the object.")) -(defgeneric stop (self) - (:documentation "Stop producing events.")) - (defgeneric text (self) (:documentation "Returns the object's text."))

1 0

[graphic-forms-cvs] r108 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system
by junrue＠common-lisp.net 26 Apr '06

26 Apr '06

Author: junrue Date: Wed Apr 26 11:46:18 2006 New Revision: 108 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp Log: implemented :transparent style for text drawing Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed Apr 26 11:46:18 2006 @@ -1244,15 +1244,15 @@ following text style keywords: @table @code @item :mnemonic -underline the mnemonic character (specified in the original string -by preceding the character with an ampersand @samp{&}) +Underline the mnemonic character (specified in the original string +by preceding the character with an ampersand @samp{&}). @item :tab -expand tabs when the string is rendered; by default the tab-width +Expand tabs when the string is rendered; by default the tab-width is 8 characters, but the optional @code{tab-width} parameter may -be used to specify a different width +be used to specify a different width. @item :transparent -@emph{This style is not yet implemented.} the background of the -rectangular area where text is drawn will not be modified +The background of the rectangular area where text is drawn will not be +modified. @end table @end deffn Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Wed Apr 26 11:46:18 2006 @@ -306,15 +306,13 @@ (setf pnt (draw-a-string gc pnt (format nil "tab~ctab~ctab" #\Tab #\Tab) "Verdana" 10 nil '(:tab))) (setf pnt (draw-a-string gc pnt (format nil "even~cmore~ctabs" #\Tab #\Tab) "Verdana" 10 nil '(:tab))) (setf pnt (draw-a-string gc pnt " " "Verdana" 10 nil nil)) - (setf pnt (draw-a-string gc pnt "and a &mnemonic" "Verdana" 10 nil '(:mnemonic))))) + (setf pnt (draw-a-string gc pnt "and a &mnemonic" "Verdana" 10 nil '(:mnemonic))) -#| (setf pnt (draw-a-string gc pnt " " "Arial" 18 nil nil)) (draw-a-string gc pnt "transparent" "Arial" 18 '(:bold) nil) (incf (gfs:point-x pnt) 50) (setf (gfg:foreground-color gc) gfg:*color-red*) - (draw-a-string gc pnt "text" "Arial" 10 '(:bold) '(:transparent)) -|# + (draw-a-string gc pnt "text" "Arial" 12 nil '(:transparent)))) (defun select-text (disp item time rect) (declare (ignore disp time rect)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Wed Apr 26 11:46:18 2006 @@ -437,7 +437,10 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((flags (compute-draw-text-style style)) - (tb-width (if (null tab-width) 0 tab-width))) + (tb-width (if (null tab-width) 0 tab-width)) + (old-bk-mode (gfs::get-bk-mode (gfs:handle self)))) + (if (find :transparent style) + (gfs::set-bk-mode (gfs:handle self) gfs::+transparent+)) (cffi:with-foreign-object (dt-ptr 'gfs::drawtextparams) (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin) dt-ptr gfs::drawtextparams) @@ -461,7 +464,8 @@ (length text) rect-ptr flags - dt-ptr))))))) + 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/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Wed Apr 26 11:46:18 2006 @@ -207,6 +207,11 @@ (hdc HANDLE)) (defcfun + ("GetBkMode" get-bk-mode) + INT + (hdc HANDLE)) + +(defcfun ("GetDCBrushColor" get-dc-brush-color) COLORREF (hdc HANDLE)) @@ -365,6 +370,12 @@ (color COLORREF)) (defcfun + ("SetBkMode" set-bk-mode) + INT + (hdc HANDLE) + (mode INT)) + +(defcfun ("SetDCBrushColor" set-dc-brush-color) COLORREF (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Apr 26 11:46:18 2006 @@ -926,3 +926,9 @@ (defconstant +bltalignment+ 119) (defconstant +shadeblendcaps+ 120) (defconstant +colormgmtcaps+ 121) + +;;; +;;; Background modes (Get/SetBkMode) +;;; +(defconstant +transparent+ 1) +(defconstant +opaque+ 2)

1 0

[graphic-forms-cvs] r107 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 26 Apr '06

26 Apr '06

Author: junrue Date: Tue Apr 25 23:20:11 2006 New Revision: 107 Modified: trunk/src/uitoolkit/widgets/event.lisp Log: key event processing bug fix Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Apr 25 23:20:11 2006 @@ -215,19 +215,18 @@ (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) - (when (and w (= ch 0)) + (when w (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam) (declare (ignore lparam)) (let ((tc (thread-context))) - (unless (zerop (virtual-key tc)) - (let* ((wparam-lo (lo-word wparam)) - (ch (gfs::map-virtual-key wparam-lo 2)) - (w (get-widget tc hwnd))) - (when w - (event-key-up (dispatcher w) w (event-time tc) wparam-lo (code-char ch))))) + (let* ((wparam-lo (lo-word wparam)) + (ch (gfs::map-virtual-key wparam-lo 2)) + (w (get-widget tc hwnd))) + (when w + (event-key-up (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) (setf (virtual-key tc) 0)) 0)

1 0

[graphic-forms-cvs] r106 - in trunk: docs/manual src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 26 Apr '06

26 Apr '06

Author: junrue Date: Tue Apr 25 21:24:16 2006 New Revision: 106 Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/overview.texinfo trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented focus-p and give-focus methods for widgets; enabled repeated event delivery for virtual keys; some other miscellaneous doc cleanup Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Apr 25 21:24:16 2006 @@ -674,7 +674,16 @@ @end deffn @deffn GenericFunction enabled-p self -Returns T if the object is enabled; nil otherwise. +Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise. +@end deffn + +@deffn GenericFunction focus-p self +Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} +otherwise. +@end deffn + +@deffn GenericFunction give-focus self +Places keyboard focus on @code{self}. @end deffn @deffn GenericFunction item-index self item @@ -694,9 +703,9 @@ @anchor{maximum-size} @deffn GenericFunction maximum-size self Returns a @ref{size} object describing the largest dimensions to which -the user may resize this widget; by default returns @code{nil}, +the user may resize this widget; by default returns @sc{nil}, indicating that there is effectively no constraint. The corresponding -@code{setf} function sets this value; if the new maximum size is +@sc{setf} function sets this value; if the new maximum size is smaller than the current size, the widget is resized to the new maximum. @xref{minimum-size}. @end deffn @@ -708,9 +717,9 @@ @anchor{minimum-size} @deffn GenericFunction minimum-size self Returns a @ref{size} object describing the smallest dimensions to -which the user may resize this widget; by default returns @code{nil}, +which the user may resize this widget; by default returns @sc{nil}, indicating that the minimum constraint is determined by the windowing -system's configuration. The corresponding @code{setf} function sets +system's configuration. The corresponding @sc{setf} function sets this value; if the new minimum size is larger than the current size, the widget is resized to the new minimum. @xref{maximum-size}. @end deffn @@ -741,7 +750,7 @@ @ref{top-level}s and dialogs. And it is possible for a window to be unowned but still have a @ref{parent}. Consequently, calling @ref{parent} on a @ref{top-level} will return an instance of -@ref{root-window}, but calling @ref{owner} may return @code{nil}. In +@ref{root-window}, but calling @ref{owner} may return @sc{nil}. In a reply to an entry at @url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, Raymond Chen says: @@ -766,7 +775,7 @@ @ref{top-level} window. In the case of a dialog or @ref{top-level}, then a @ref{root-window} is returned. In the case of a @code{submenu}, this will be the @ref{menu}'s ancestor in the hierarchy; but for a -menubar or context @ref{menu}, @code{parent} returns @code{nil}. In a +menubar or context @ref{menu}, @code{parent} returns @sc{nil}. In a reply to an entry at @url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, Raymond Chen says: @@ -1007,7 +1016,7 @@ The default pen style is equivalent to @code{(:flat :square-endcap :round-bevel)}. -Specifying @code{nil} for @code{pen-style} equates to selecting the +Specifying @sc{nil} for @code{pen-style} equates to selecting the Win32 @sc{PS_NULL} pen style, meaning that the pen is invisible. @end deffn @anchor{pen-width} Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Tue Apr 25 21:24:16 2006 @@ -61,12 +61,12 @@ @item ASDF @url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf} +@item Cells +@url{http://common-lisp.net/project/cells} + @item CFFI @url{http://common-lisp.net/project/cffi} -@item lw-compat -@url{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz} - @item Closer to MOP @url{http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.tar.gz} @@ -75,6 +75,9 @@ @item lisp-unit @url{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html} + +@item lw-compat +@url{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz} @end table Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Apr 25 21:24:16 2006 @@ -274,6 +274,10 @@ HANDLE) (defcfun + ("GetFocus" get-focus) + HANDLE) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT)) @@ -470,6 +474,11 @@ (lparam WPARAM)) (defcfun + ("SetFocus" set-focus) + HANDLE + (hwnd HANDLE)) + +(defcfun ("SetMenu" set-menu) BOOL (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Apr 25 21:24:16 2006 @@ -61,6 +61,22 @@ (declare (ignore ctrl)) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) +(defmethod focus-p :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod focus-p ((ctrl control)) + (let ((focus-hwnd (gfs::get-focus))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle ctrl))))) + +(defmethod give-focus :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod give-focus ((ctrl control)) + (if (gfs:null-handle-p (gfs::set-focus (gfs:handle ctrl))) + (error 'gfs:toolkit-error "set-focus failed"))) + (defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) (if (gfs:disposed-p parent) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Tue Apr 25 21:24:16 2006 @@ -37,6 +37,22 @@ ;;; methods ;;; +(defmethod focus-p :before ((dlg dialog)) + (if (gfs:disposed-p dlg) + (error 'gfs:disposed-error))) + +(defmethod focus-p ((dlg dialog)) + (let ((focus-hwnd (gfs::get-focus))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle dlg))))) + +(defmethod give-focus :before ((dlg dialog)) + (if (gfs:disposed-p dlg) + (error 'gfs:disposed-error))) + +(defmethod give-focus ((dlg dialog)) + (if (gfs:null-handle-p (gfs::set-focus (gfs:handle dlg))) + (error 'gfs:toolkit-error "set-focus failed"))) + (defmethod print-object ((self dialog) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Apr 25 21:24:16 2006 @@ -209,12 +209,13 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) + (declare (ignore lparam)) (let* ((tc (thread-context)) (wparam-lo (lo-word wparam)) (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) - (when (and w (= ch 0) (= (logand lparam #x40000000) 0)) + (when (and w (= ch 0)) (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) 0) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Apr 25 21:24:16 2006 @@ -183,6 +183,22 @@ (let ((sz (client-size win))) (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) +(defmethod focus-p :before ((win window)) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) + +(defmethod focus-p ((win window)) + (let ((focus-hwnd (gfs::get-focus))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle win))))) + +(defmethod give-focus :before ((win window)) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error))) + +(defmethod give-focus ((win window)) + (if (gfs:null-handle-p (gfs::set-focus (gfs:handle win))) + (error 'gfs:toolkit-error "set-focus failed"))) + (defmethod location ((win window)) (if (gfs:disposed-p win) (error 'gfs:disposed-error))

1 0

[graphic-forms-cvs] r105 - in trunk: . src/uitoolkit/graphics
by junrue＠common-lisp.net 24 Apr '06

24 Apr '06

Author: junrue Date: Mon Apr 24 13:46:06 2006 New Revision: 105 Modified: trunk/README.txt trunk/config.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/tests.lisp Log: revised image loading code such that it relies on merge-pathnames and *default-pathname-defaults* rather than the current working directory; also made some cleanup edits in preparation for 0.3.0 release Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Apr 24 13:46:06 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.2.0 +Graphic-Forms README for version 0.3.0 Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -15,6 +15,9 @@ - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ + - Cells + http://common-lisp.net/project/cells/ + - CFFI 0.9.0 http://common-lisp.net/project/cffi/ @@ -34,36 +37,30 @@ Known Problems -------------- -Aside from the fact that there are a myriad number of classes, functions, -and features in general that are not yet implemented, this section lists +Aside from the fact that there are a myriad of classes, functions, and +features in general that are not yet implemented, this section lists known problems in this release: -1. When running the layout-tester application on CLISP, you may experience - intermittent GPFs given sufficient playing around with window sizing, - or adding/removing/hiding/showing controls if the flow layout is set to - wrap. - - This problem needs further in-depth investigation. +1. The following bug filed against CLISP 2.38 -2. When running the event-tester application on CLISP, you may experience - intermittent GPFs after selecting File | Start Timer to start the - timer test. + http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1… - This problem needs further in-depth investigation. + may result in intermittent GPFs when windows with layout managers are + resized or when timer objects are initialized. -3. Image loading currently requires installation of the ImageMagick +2. Image loading currently requires installation of the ImageMagick library as described in the next section. I have tested with Windows BMP files (and this is what the image-tester application displays). ImageMagick itself supports many image formats, but Graphic-Forms has not been tested with all of them. Therefore, images may not display properly, expecially when a transparency is selected. -4. The event-tester application's menu definition specifies that the +3. The event-tester application's menu definition specifies that the Test Menu | Submenu | Item A item should be disabled but it does not get disabled. However, the GFW:ENABLE function does otherwise work correctly for menu items. -5. Graphic-Forms supports CLISP 2.38 and LispWorks 4.4.6. The +4. Graphic-Forms supports CLISP 2.38 and LispWorks 4.4.6. The intention is to support additional Lisp vendors, but currently the library will not run on anything but CLISP or LW due to some vendor-specific features that have to be used. @@ -91,14 +88,15 @@ (load "config.lisp") ;; - ;; If ImageMagic is not installed in the default location, execute: + ;; If ImageMagick is not installed in the default location, execute: ;; - (setf gfsys::*imagemagick-dir* "c:/path/to/your/ImageMagick/install/") + (setf cl-user::*magick-library-directory* "c:/path/to/your/ImageMagick/install/") ;; setf these variables as needed for your specific environment to ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; + ;; gfsys::*cells-dir* ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* ;; gfsys::*lw-compat-dir* @@ -119,9 +117,14 @@ ;; (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit) -6. Proceed to the next section to run the tests, or start coding! - (note: I will add instructions in the future for building the - documentation) +6. You may optionally compile the reference manual. GNU Make and + makeinfo are prerequisites. Assuming you already have those + components installed, the reference manual can be built by + opening a command prompt and cd'ing to the `docs\manual' + subdirectory, then typing `make'. The output will be + produced within a subdirectory called `reference'. + +7. Proceed to the next section to run the tests, or start coding! How To Run Tests And Samples @@ -136,15 +139,10 @@ (asdf:operate 'asdf:load-op :graphic-forms-tests) - ;; Change the working directory to the uitoolkit tests - ;; directory. - ;; - - (chdir "c:/example/path/graphic-forms/src/tests/uitoolkit/") - - ;; then execute one or more of the following: + ;; execute one or more of the following: ;; + (in-package :gft) (run-tests) ;; runs the unit tests (many more to be added) (gft::run-event-tester) @@ -159,13 +157,15 @@ Support and Feedback -------------------- -Please provide feedback via the development mailing list: +Please provide feedback via the following channels: + +The development mailing list: http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel -Bug reports via the bug tracking system: - http://sourceforge.net/tracker/?group_id=163034&atid=826147 +The bug tracking system: + http://sourceforge.net/tracker/?group_id=163034&atid=826145 -Patches via the patch tracker: +The patch tracker: http://sourceforge.net/tracker/?group_id=163034&atid=826147 Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Mon Apr 24 13:46:06 2006 @@ -47,11 +47,6 @@ (defvar *lisp-unit-file* "lisp-unit") -#+lispworks (defmacro chdir (path) - `(hcl:change-directory ,path)) -#+clisp (defmacro chdir (path) - `(ext:cd ,path)) - (defun configure-asdf () (pushnew *cells-dir* asdf:*central-registry* :test #'equal) (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Apr 24 13:46:06 2006 @@ -206,8 +206,8 @@ (defmethod load ((data image-data) path) (setf path (cond - ((typep path 'pathname) (namestring path)) - ((typep path 'string) path) + ((typep path 'pathname) (namestring (merge-pathnames path))) + ((typep path 'string) (namestring (merge-pathnames path))) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) (let ((handle (gfs:handle data))) @@ -220,7 +220,7 @@ (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) (error 'gfs:toolkit-error :detail (format nil "exception reason: ~s" - (cffi:foreign-slot-value ex 'exception-info 'reason)))) + (cffi:foreign-slot-value ex 'exception-info 'reason)))) (if (cffi:null-pointer-p handle) (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) (setf (slot-value data 'gfs:handle) handle)))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Mon Apr 24 13:46:06 2006 @@ -36,5 +36,5 @@ (load (compile-file *lisp-unit-file*)) (defun load-tests () - (asdf:operate 'asdf:load-op :graphic-forms-tests) - (chdir *gf-tests-dir*)) + (setf *default-pathname-defaults* (parse-namestring *gf-tests-dir*)) + (asdf:operate 'asdf:load-op :graphic-forms-tests))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

graphic-forms-cvs April 2006