From junrue at common-lisp.net Thu Jun 1 22:25:23 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 1 Jun 2006 18:25:23 -0400 (EDT) Subject: [graphic-forms-cvs] r142 - trunk/src/uitoolkit/system Message-ID: <20060601222523.3B9BC2009@common-lisp.net> 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)) From junrue at common-lisp.net Thu Jun 1 22:26:31 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 1 Jun 2006 18:26:31 -0400 (EDT) Subject: [graphic-forms-cvs] r143 - trunk/docs/manual Message-ID: <20060601222631.B04922009@common-lisp.net> 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} - at deffn Macro with-file-dialog (owner style paths &key default extension filters initial-directory initial-filename text) &body body + at 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}. From junrue at common-lisp.net Fri Jun 2 20:16:51 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 2 Jun 2006 16:16:51 -0400 (EDT) Subject: [graphic-forms-cvs] r144 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060602201651.965B65B00A@common-lisp.net> 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}. - at deffn Reader primary-p -Returns T if the system regards this display as the primary -display; nil otherwise. - at end deffn @end deftp @anchor{event-dispatcher} @@ -965,6 +961,11 @@ must determine how tall it would be given that width. @end deffn + at deffn Function primary-p display +Returns T if the system regards the specified display as the primary +display; nil otherwise. + at 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 () () From junrue at common-lisp.net Fri Jun 2 22:59:14 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 2 Jun 2006 18:59:14 -0400 (EDT) Subject: [graphic-forms-cvs] r145 - in trunk: . src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060602225914.867AF32008@common-lisp.net> 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) + , at 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) From junrue at common-lisp.net Sat Jun 3 06:42:56 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 3 Jun 2006 02:42:56 -0400 (EDT) Subject: [graphic-forms-cvs] r146 - in trunk: docs/manual src/uitoolkit/widgets Message-ID: <20060603064256.A3BE534025@common-lisp.net> 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 + at anchor{group} + at 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: + at itemize @bullet + at item @emph{layout management}@* +Each @code{group} participates in the layout management protocol +on behalf of an aggregate of a real window's children.@*@* + at item @emph{limited event handling}@* +As part of their participation in the layout management protocol, + at code{group}s process move and size events, but otherwise do not +have any event handling responsibilities.@*@* + at item @emph{nesting}@* +Multiple @code{group}s may be nested.@*@* + at 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}.@*@* + at item @emph{windowless}@* +A @code{group} has no underlying native window handle. + at 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. + at 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 From junrue at common-lisp.net Sun Jun 4 06:16:20 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 4 Jun 2006 02:16:20 -0400 (EDT) Subject: [graphic-forms-cvs] r147 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060604061620.2560C64017@common-lisp.net> 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. + at 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) From junrue at common-lisp.net Sun Jun 4 06:52:57 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 4 Jun 2006 02:52:57 -0400 (EDT) Subject: [graphic-forms-cvs] r148 - trunk/src/uitoolkit/widgets Message-ID: <20060604065257.ECF575D096@common-lisp.net> Author: junrue Date: Sun Jun 4 02:52:57 2006 New Revision: 148 Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp Log: flow-layout bug fix 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:52:57 2006 @@ -119,7 +119,7 @@ (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)) + (setf (flow-data-kid-sizes state) (reverse (flow-data-kid-sizes state))) state)) (defun wrap-needed-p (state layout kid-size) @@ -134,7 +134,6 @@ (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) @@ -164,8 +163,7 @@ (defun flow-container-layout (layout visible kids width-hint height-hint) (let ((flows nil) - (state (init-flow-data layout visible kids width-hint height-hint)) - (max-distance 0)) + (state (init-flow-data layout visible kids -1 -1))) (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)) From junrue at common-lisp.net Sun Jun 4 17:24:24 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 4 Jun 2006 13:24:24 -0400 (EDT) Subject: [graphic-forms-cvs] r149 - trunk/src/uitoolkit/widgets Message-ID: <20060604172424.BDA6222019@common-lisp.net> Author: junrue Date: Sun Jun 4 13:24:24 2006 New Revision: 149 Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp Log: fixed a couple flow-layout regressions 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 13:24:24 2006 @@ -163,10 +163,12 @@ (defun flow-container-layout (layout visible kids width-hint height-hint) (let ((flows nil) - (state (init-flow-data layout visible kids -1 -1))) + (state (init-flow-data layout visible kids width-hint height-hint))) (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)) + do (if (and wrap + (flow-data-current state) + (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) From junrue at common-lisp.net Sun Jun 4 19:50:41 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 4 Jun 2006 15:50:41 -0400 (EDT) Subject: [graphic-forms-cvs] r150 - in trunk/src: tests/uitoolkit uitoolkit/widgets Message-ID: <20060604195041.F1E1213005@common-lisp.net> Author: junrue Date: Sun Jun 4 15:50:41 2006 New Revision: 150 Modified: trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp Log: :normalize style for flow-layout is now working Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Jun 4 15:50:41 2006 @@ -154,7 +154,7 @@ (btn-panel (make-instance 'gfw:panel :layout (make-instance 'gfw:flow-layout :spacing 4 - :style '(:vertical)) + :style '(:vertical :normalize)) :parent dlg)) (ok-btn (make-instance 'gfw:button :callback (lambda (disp btn time rect) 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 15:50:41 2006 @@ -37,51 +37,13 @@ ;;; helper functions ;;; -(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 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) + (distance-total 0) (max-distance 0) + (extent-total 0) + (max-extent 0) (next-coord 0) (wrap-coord 0) (spacing 0) @@ -114,6 +76,8 @@ do (let* ((size (preferred-size kid -1 -1)) (dist (funcall (flow-data-distance-fn state) size)) (extent (funcall (flow-data-extent-fn state) size))) + (incf (flow-data-distance-total state) dist) + (incf (flow-data-extent-total state) extent) (if (< (flow-data-max-distance state) dist) (setf (flow-data-max-distance state) dist)) (if (< (flow-data-max-extent state) extent) @@ -122,6 +86,37 @@ (setf (flow-data-kid-sizes state) (reverse (flow-data-kid-sizes state))) state)) +(defun flow-container-size (layout visible kids width-hint height-hint) + (let ((kid-count (length kids)) + (horz-margin-total (+ (left-margin-of layout) (right-margin-of layout))) + (vert-margin-total (+ (top-margin-of layout) (bottom-margin-of layout))) + (vertical (find :vertical (style-of layout))) + (horizontal (find :horizontal (style-of layout)))) + (let ((spacing-total (* (spacing-of layout) (1- kid-count))) + (state (init-flow-data layout + visible + kids + (if vertical width-hint -1) + (if vertical -1 height-hint)))) + (if (find :normalize (style-of layout)) + (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count))) + (cond + (horizontal + (gfs:make-size :width (+ (flow-data-distance-total state) + horz-margin-total + spacing-total) + :height (+ (flow-data-max-extent state) + vert-margin-total))) + (vertical + (gfs:make-size :width (+ (flow-data-max-extent state) + horz-margin-total) + :height (+ (flow-data-distance-total state) + vert-margin-total + spacing-total))) + (t + (error 'gfs:toolkit-error + :detail (format nil "unrecognized flow layout style: ~a" (style-of layout)))))))) + (defun wrap-needed-p (state layout kid-size) (and (>= (flow-data-hint state) 0) (> (+ (flow-data-next-coord state) @@ -138,39 +133,35 @@ (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)))) + (vertical (find :vertical (style-of layout)))) + (if vertical + (setf (gfs:point-x pnt) (flow-data-wrap-coord state) + (gfs:point-y pnt) (flow-data-next-coord state)) + (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) + (normal (find :normalize (style-of layout))) + (vertical (find :vertical (style-of layout))) (state (init-flow-data layout visible kids width-hint height-hint))) (loop with wrap = (find :wrap (style-of layout)) for (kid kid-size) in (flow-data-kid-sizes state) - do (if (and wrap + do (cond + ((and normal vertical) + (setf (gfs:size-width kid-size) (flow-data-max-extent state) + (gfs:size-height kid-size) (flow-data-max-distance state))) + ((and normal (not vertical)) + (setf (gfs:size-width kid-size) (flow-data-max-distance state) + (gfs:size-height kid-size) (flow-data-max-extent state)))) + (if (and wrap (flow-data-current state) (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))) + (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)) From junrue at common-lisp.net Mon Jun 5 17:18:10 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 5 Jun 2006 13:18:10 -0400 (EDT) Subject: [graphic-forms-cvs] r151 - in trunk/src: tests/uitoolkit uitoolkit/graphics uitoolkit/system uitoolkit/widgets Message-ID: <20060605171810.3EF103000F@common-lisp.net> Author: junrue Date: Mon Jun 5 13:18:09 2006 New Revision: 151 Modified: trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/graphics/font.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: enabled and fixed the :check-box, :radio-button, and :toggle button styles; fixed a problem with creating a font with an existing font handle Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Jun 5 13:18:09 2006 @@ -35,7 +35,7 @@ (defconstant +btn-text-before+ "Push Me") (defconstant +btn-text-after+ "Again!") -(defconstant +label-text+ "Test Label") +(defconstant +label-text+ "Label") (defconstant +margin-delta+ 4) (defconstant +spacing-delta+ 3) @@ -86,30 +86,51 @@ (declare (ignore win)) "Test Panel") +(defun create-button-toggler (be) + (let ((flag nil)) + (lambda () + (if (null flag) + (progn + (setf flag t) + (format nil "~d ~a" (id be) +btn-text-before+)) + (progn + (setf flag nil) + (format nil "~d ~a" (id be) +btn-text-after+)))))) + (defun add-layout-tester-widget (widget-class subtype) - (let* ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) - (w (make-instance widget-class :parent *layout-tester-win* :dispatcher be))) + (let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) + (w nil)) (cond - ((eql subtype :push-button) - (setf (toggle-fn be) (let ((flag nil)) - (lambda () - (if (null flag) - (progn - (setf flag t) - (format nil "~d ~a" (id be) +btn-text-before+)) - (progn - (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) + ((or (eql subtype :check-box) + (eql subtype :push-button) + (eql subtype :radio-button) + (eql subtype :toggle-button)) + (setf w (make-instance widget-class + :parent *layout-tester-win* + :dispatcher be + :style (list subtype))) + (setf (toggle-fn be) (create-button-toggler be)) (setf (gfw:text w) (funcall (toggle-fn be)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here + (setf w (make-instance widget-class + :parent *layout-tester-win* + :dispatcher be)) (setf (gfg:background-color w) (gfg:background-color *layout-tester-win*)) (let ((tmp-image (make-instance 'gfg:image :file "happy.bmp"))) (gfg:with-image-transparency (tmp-image (gfs:make-point)) (setf (gfw:image w) tmp-image)))) ((eql subtype :text-label) - (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+)))) + (setf w (make-instance widget-class + :parent *layout-tester-win* + :dispatcher be + :style '(:sunken))) + (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+))) + (t + (setf w (make-instance widget-class + :parent *layout-tester-win* + :dispatcher be)))) (incf *widget-counter*))) (defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) @@ -365,6 +386,9 @@ (let ((menubar nil) (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) + (add-checkbox-disp (make-instance 'add-child-dispatcher :subtype :check-box)) + (add-radio-disp (make-instance 'add-child-dispatcher :subtype :radio-button)) + (add-toggle-disp (make-instance 'add-child-dispatcher :subtype :toggle-button)) (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel :subtype :panel)) (add-image-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label @@ -385,9 +409,12 @@ (:item "&Children" :submenu ((:item "Add" :submenu ((:item "Button" :dispatcher add-btn-disp) + (:item "Checkbox" :dispatcher add-checkbox-disp) (:item "Label - Image" :dispatcher add-image-label-disp) (:item "Label - Text" :dispatcher add-text-label-disp) - (:item "Panel" :dispatcher add-panel-disp))) + (:item "Panel" :dispatcher add-panel-disp) + (:item "Radiobutton" :dispatcher add-radio-disp) + (:item "Toggle" :dispatcher add-toggle-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) (:item "Visible" :dispatcher vis-menu-disp Modified: trunk/src/uitoolkit/graphics/font.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font.lisp (original) +++ trunk/src/uitoolkit/graphics/font.lisp Mon Jun 5 13:18:09 2006 @@ -44,4 +44,5 @@ (setf (slot-value fn 'gfs:handle) nil)) (defmethod initialize-instance :after ((font font) &key gc data &allow-other-keys) - (setf (slot-value font 'gfs:handle) (data->font (gfs:handle gc) data))) + (if gc + (setf (slot-value font 'gfs:handle) (data->font (gfs:handle gc) data)))) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Mon Jun 5 13:18:09 2006 @@ -476,6 +476,12 @@ (id UINT)) (defcfun + ("LoadBitmapA" load-bitmap) + HANDLE + (hinst HANDLE) + (name LPTR)) ; LPTR to make it easier to pass constants like +obm-checkboxes+ + +(defcfun ("LoadImageA" load-image) HANDLE (instance HANDLE) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Mon Jun 5 13:18:09 2006 @@ -49,15 +49,15 @@ ;; primary button styles ;; ((eq sym :check-box) - (setf std-flags (logior std-flags gfs::+bs-checkbox+))) + (setf std-flags (logior std-flags gfs::+bs-autocheckbox+))) ((eq sym :default-button) (setf std-flags (logior std-flags gfs::+bs-defpushbutton+))) ((or (eq sym :push-button) (eq sym :cancel-button)) (setf std-flags (logior std-flags gfs::+bs-pushbutton+))) ((eq sym :radio-button) - (setf std-flags (logior std-flags gfs::+bs-radiobutton+))) + (setf std-flags (logior std-flags gfs::+bs-autoradiobutton+))) ((eq sym :toggle-button) - (setf std-flags (logior std-flags gfs::+bs-pushbox+))))) + (setf std-flags (logior std-flags gfs::+bs-autocheckbox+ gfs::+bs-pushlike+))))) (if (null style) (logior std-flags gfs::+bs-pushbutton+)) (values std-flags 0))) @@ -85,15 +85,33 @@ (init-control btn)) (defmethod preferred-size ((self button) width-hint height-hint) - (let ((size (widget-text-size self gfs::+dt-singleline+))) - (if (>= width-hint 0) - (setf (gfs:size-width size) width-hint) - (setf (gfs:size-width size) (+ (gfs:size-width size) - (* +horizontal-button-text-margin+ 2)))) - (if (>= height-hint 0) - (setf (gfs:size-height size) height-hint) - (setf (gfs:size-height size) (+ (gfs:size-height size) - ( * +vertical-button-text-margin+ 2)))) + (let ((text-size (widget-text-size self gfs::+dt-singleline+)) + (size (gfs:make-size)) + (b-width (* (border-width self) 2)) + (need-cb-size (intersection '(:check-box :radio-button) (style-of self))) + (cb-size (check-box-size))) + (cond + ((>= width-hint 0) + (setf (gfs:size-width size) width-hint)) + (need-cb-size + (setf (gfs:size-width size) (+ +horizontal-button-text-margin+ + (gfs:size-width cb-size) + (gfs:size-width text-size)))) + (t + (setf (gfs:size-width size) (+ b-width + (* +horizontal-button-text-margin+ 2) + (gfs:size-width text-size))))) + (cond + ((>= height-hint 0) + (setf (gfs:size-height size) height-hint)) + (need-cb-size + (setf (gfs:size-height size) (+ (* +vertical-button-text-margin+ 2) + (max (gfs:size-height text-size) + (gfs:size-height cb-size))))) + (t + (setf (gfs:size-height size) (+ b-width + (* +vertical-button-text-margin+ 2) + (gfs:size-height text-size))))) size)) (defmethod text ((self button)) @@ -103,6 +121,4 @@ (set-widget-text self str)) (defmethod text-baseline ((self button)) - (let ((font (gfg:font self)) - (gc (make-instance 'gfg:graphics-context :widget self))) - (+ +vertical-button-text-margin+ (gfg:ascent (gfg:metrics gc font))))) + (widget-text-baseline self +vertical-button-text-margin+)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Jun 5 13:18:09 2006 @@ -103,12 +103,14 @@ (defmethod gfg:font ((self control)) (let ((font (font-of self))) (unless font - (let ((result (gfs::send-message (gfs:handle self) gfs::+wm-getfont+ 0 0))) + (let ((result (gfs::send-message (gfs:handle self) gfs::+wm-getfont+ 0 0)) + (gc nil)) (if (zerop result) - (let ((gc (make-instance 'gfg:graphics-context :widget self))) - (unwind-protect + (unwind-protect + (progn + (setf gc (make-instance 'gfg:graphics-context :widget self)) (setf font (gfg:font gc))) - (gfs:dispose gc)) + (gfs:dispose gc)) (setf font (make-instance 'gfg:font :handle (cffi:make-pointer result)))))) font)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Jun 5 13:18:09 2006 @@ -314,8 +314,15 @@ (textcolor (text-color-of widget)) (ret-val 0)) (when widget - (if (not (typep widget 'label)) - (error 'gfs:toolkit-error :detail "incorrect widget type received WM_CTLCOLORSTATIC")) +#| + ;; temporarily disabling this until I decide whether this sort + ;; of sanity check really makes sense (for one thing, I didn't + ;; expect buttons with BS_CHECKBOX or BS_RADIOBUTTON to send + ;; WM_CTLCOLORSTATIC, but I guess it makes sense). + ;; + (if (not (or (typep widget 'button) (typep widget 'label))) + (warn 'gfs:toolkit-warning :detail "incorrect widget type received WM_CTLCOLORSTATIC")) +|# (let ((font (font-of widget))) (if font (gfs::select-object hdc (gfs:handle font)))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Jun 5 13:18:09 2006 @@ -39,7 +39,7 @@ (defun compute-image-style-flags (style) (let ((flags (logior gfs::+ss-bitmap+ gfs::+ss-realsizeimage+ gfs::+ss-centerimage+))) - (when (find :raised style) + (when (find :raised style) ; FIXME: this style not yet working (setf flags (logand (lognot gfs::+ss-sunken+) flags)) (setf flags (logior flags gfs::+ss-etchedframe+))) (when (find :sunken style) @@ -50,23 +50,23 @@ (defun compute-text-style-flags (style) (let ((flags 0)) (unless (intersection style (list :beginning :center :end)) - (setf flags gfs::+ss-leftnowordwrap+)) + (setf flags (logior gfs::+ss-center+ gfs::+ss-centerimage+ flags))) (loop for sym in style do (cond ;; primary text static styles ;; ((eq sym :beginning) - (setf flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n + (setf flags (logior flags gfs::+ss-leftnowordwrap+))) ; FIXME: i18n ((eq sym :center) - (setf flags gfs::+ss-center+)) + (setf flags (logior flags gfs::+ss-center+))) ((eq sym :end) - (setf flags gfs::+ss-right+)) ; FIXME: i18n + (setf flags (logior flags gfs::+ss-right+))) ; FIXME: i18n ;; styles that can be combined ;; ((eq sym :ellipsis) (setf flags (logior flags gfs::+ss-endellipsis+))) - ((eq sym :raised) + ((eq sym :raised) ; FIXME: this style not yet working (setf flags (logand (lognot gfs::+ss-sunken+) flags)) (setf flags (logior flags gfs::+ss-etchedframe+))) ((eq sym :sunken) @@ -169,55 +169,54 @@ (setf (image label) image)))) (init-control label)) -(defmethod preferred-size ((label label) width-hint height-hint) - (declare (ignorable width-hint height-hint)) - (let* ((hwnd (gfs:handle label)) +(defmethod preferred-size ((self label) width-hint height-hint) + (let* ((hwnd (gfs:handle self)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) - (b-width (border-width label)) - (sz nil)) + (b-width (* (border-width self) 2))) (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) - (let ((image (image label))) + (let ((image (image self))) (if image - (gfg:size image) + (let ((size (gfg:size image))) + (gfs:make-size :width (+ (gfs:size-width size) b-width) + :height (+ (gfs:size-height size) b-width))) (gfs:make-size))) - (let ((flags (logior gfs::+dt-editcontrol+ gfs::+dt-expandtabs+))) + (let ((flags (logior gfs::+dt-editcontrol+ gfs::+dt-expandtabs+)) + (size nil)) (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf sz (widget-text-size label flags)) + (setf size (widget-text-size self flags)) (if (>= width-hint 0) - (setf (gfs:size-width sz) width-hint)) + (setf (gfs:size-width size) width-hint) + (incf (gfs:size-width size) b-width)) (if (>= height-hint 0) - (setf (gfs:size-height sz) height-hint)) - (incf (gfs:size-width sz) (* b-width 2)) - (incf (gfs:size-height sz) (* b-width 2)) - sz)))) + (setf (gfs:size-height size) height-hint) + (incf (gfs:size-width size) b-width)) + size)))) -(defmethod text ((label label)) - (get-widget-text label)) +(defmethod text ((self label)) + (get-widget-text self)) -(defmethod (setf text) (str (label label)) - (let* ((hwnd (gfs:handle label)) +(defmethod (setf text) (str (self label)) + (let* ((hwnd (gfs:handle self)) (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+)))) (multiple-value-bind (std-flags ex-flags) - (compute-style-flags label nil nil str) + (compute-style-flags self nil nil str) (declare (ignore ex-flags)) (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags std-flags gfs::+ws-child+ gfs::+ws-visible+)))) - (set-widget-text label str)) + (set-widget-text self str)) (defmethod text-baseline ((self label)) - (if (= (logand (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+) - gfs::+ss-bitmap+) - gfs::+ss-bitmap+) - (let ((image (image self))) - (if image - (gfs:size-height (gfg:size image)) - 0)) - (let ((font (gfg:font self)) - (gc (make-instance 'gfg:graphics-context :widget self)) - (b-width (border-width self))) - (+ b-width (gfg:ascent (gfg:metrics gc font)))))) + (let ((b-width (border-width self))) + (if (= (logand (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+) + gfs::+ss-bitmap+) + gfs::+ss-bitmap+) + (let ((image (image self))) + (if image + (+ (gfs:size-height (gfg:size image)) b-width) + b-width)) + (widget-text-baseline self 0)))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Jun 5 13:18:09 2006 @@ -33,6 +33,9 @@ (in-package #:graphic-forms.uitoolkit.widgets) +(defvar *check-box-size* nil) + + (defun translate-and-dispatch (msg-ptr) (gfs::translate-message msg-ptr) (gfs::dispatch-message msg-ptr)) @@ -148,6 +151,50 @@ (gfs::with-hfont-selected (hdc hfont) (gfg::text-bounds hdc (text widget) dt-flags 0))))) +;;; +;;; This algorithm adapted from the calculate_best_bounds() +;;; function in ui_core_implementation.cpp from the +;;; Adobe Source Libraries / UI Core Widget API +;;; +(defun widget-text-baseline (widget top-margin) + (let ((size (gfw:size widget)) + (b-width (border-width widget)) + (font (gfg:font widget)) + (gc (make-instance 'gfg:graphics-context :widget widget)) + (baseline 0)) + (unwind-protect + (let ((metrics (gfg:metrics gc font))) + (setf baseline (+ b-width + top-margin + (gfg:ascent metrics) + (floor (/ (- (gfs:size-height size) + (+ (gfg:ascent metrics) (gfg:descent metrics))) + 2))))) + (gfs:dispose gc)) + baseline)) + +(defun check-box-size () + (if *check-box-size* + (return-from check-box-size (gfs:copy-size *check-box-size*))) + (let ((hbitmap (gfs::load-bitmap (cffi:null-pointer) + (cffi:make-pointer gfs::+obm-checkboxes+)))) + (if (gfs:null-handle-p hbitmap) + ;; if for some reason the OBM_CHECKBOXES resource could not be retrieved, + ;; use scrollbar system metric values as a rough approximation + ;; + (return-from check-box-size + (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxvscroll+) + :height (gfs::get-system-metrics gfs::+sm-cyvscroll+)))) + + (unwind-protect + (cffi:with-foreign-object (bm-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bm-ptr gfs::bitmap) + (gfs::get-object hbitmap (cffi:foreign-type-size 'gfs::bitmap) bm-ptr) + (setf *check-box-size* (gfs:make-size :width (floor (/ gfs::width 4)) + :height (floor (/ gfs::height 3)))))) + (gfs::delete-object hbitmap))) + (gfs:copy-size *check-box-size*)) + (defun extract-foreign-strings (buffer) (let ((strings nil)) (do ((curr-ptr buffer)) From junrue at common-lisp.net Mon Jun 5 18:33:21 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 5 Jun 2006 14:33:21 -0400 (EDT) Subject: [graphic-forms-cvs] r152 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060605183321.E249544054@common-lisp.net> Author: junrue Date: Mon Jun 5 14:33:21 2006 New Revision: 152 Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/glossary.texinfo trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/button.lisp Log: added :tri-state button style; added documentation for button styles Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jun 5 14:33:21 2006 @@ -177,22 +177,50 @@ @anchor{button} @deftp Class button -This @ref{control} class represents selectable controls that issue -notifications when clicked.@*@* -The following initargs are supported: +This @ref{control} class represents selectable controls that invoke +the @ref{event-select} method defined for an @ref{event-dispatcher} +associated with the @code{button}. @deffn Initarg :image +Supplies an image to be used as the @code{button} label. @end deffn @deffn Initarg :style @table @code @item :cancel-button +Placing a @code{:cancel-button} in a @ref{dialog} enables the + at sc{escape} key @ref{accelerator} for dismissing the dialog. This +action should be interpreted as the user discarding the content of the +dialog. @item :check-box +This style specifies a @code{button} having a small box, which may +contain a check mark depending on the @code{button}'s selection state, +adjacent to a text label. @item :default-button +Placing a @code{:default-button} in a dialog enables the @sc{return} +key @ref{accelerator} for dismissing the dialog. This action should be +interpreted as the user accepting the content of the dialog. Also, the + at code{button} is rendered with an extra thick border. @item :push-button +This style specifies a traditional push button control. No special +keyboard accelerators are enabled. @item :radio-button +This style specifies a @code{button} having a small circle, which may +be filled or unfilled depending on the @code{button}'s selection +state, adjacent to a text label. Radio @code{button}s are typically +used in groups and are managed such that only one member of the group +is enabled at a time. @item :toggle-button +This style specifies a control that when unselected looks like a push + at code{button}. But when in the selected state, the @code{button} +maintains a sunken look. It is similar in function to a + at code{:check-box}. + at item :tri-state +This style specifies a control that looks similar to a @code{:check-box}, +but the box can be grayed as well as checked or cleared. The grayed look +is used to indicate an undetermined state. @end table @end deffn @deffn Initarg :text +Supplies the text for the @code{button} label. @end deffn @end deftp Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Mon Jun 5 14:33:21 2006 @@ -13,6 +13,19 @@ Terms and definitions. Content will be added in due time. @table @samp + + at item accelerator + at anchor{accelerator} + at cindex accelerator +An accelerator is a key sequence assigned to an application function +that allows a user to bypass navigation of the menu or control +hierarchy normally required to invoke the function. Some accelerators +are established by Windows style guidelines, such as @sc{control-c} +for the clipboard copy operation from an Edit menu. Applications may +define other accelerators as appropriate. Accelerators are generally +intended for more knowledgeable users and should not be the sole +mechanism for invoking functionality. Compare with @ref{mnemonic}. + @item control @cindex control A control is a system-defined window class that accepts user input @@ -29,4 +42,13 @@ @cindex menu A collection of menu items. + at item mnemonic + at anchor{mnemonic} + at cindex mnemonic +A mnemonic is a key sequence (usually a single character modified by +the @sc{alt} key) that enables mouse-free navigation of a menu or +control hierarchy to invoke an application function. Depending on +the user's system settings, mnemonic characters may be hidden until +the user presses the @sc{alt} key. Compare with @ref{accelerator}. + @end table Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Jun 5 14:33:21 2006 @@ -104,7 +104,8 @@ ((or (eql subtype :check-box) (eql subtype :push-button) (eql subtype :radio-button) - (eql subtype :toggle-button)) + (eql subtype :toggle-button) + (eql subtype :tri-state)) (setf w (make-instance widget-class :parent *layout-tester-win* :dispatcher be @@ -389,6 +390,7 @@ (add-checkbox-disp (make-instance 'add-child-dispatcher :subtype :check-box)) (add-radio-disp (make-instance 'add-child-dispatcher :subtype :radio-button)) (add-toggle-disp (make-instance 'add-child-dispatcher :subtype :toggle-button)) + (add-tri-state-disp (make-instance 'add-child-dispatcher :subtype :tri-state)) (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel :subtype :panel)) (add-image-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label @@ -414,7 +416,8 @@ (:item "Label - Text" :dispatcher add-text-label-disp) (:item "Panel" :dispatcher add-panel-disp) (:item "Radiobutton" :dispatcher add-radio-disp) - (:item "Toggle" :dispatcher add-toggle-disp))) + (:item "Toggle" :dispatcher add-toggle-disp) + (:item "Tri-State" :dispatcher add-tri-state-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) (:item "Visible" :dispatcher vis-menu-disp Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Mon Jun 5 14:33:21 2006 @@ -57,7 +57,9 @@ ((eq sym :radio-button) (setf std-flags (logior std-flags gfs::+bs-autoradiobutton+))) ((eq sym :toggle-button) - (setf std-flags (logior std-flags gfs::+bs-autocheckbox+ gfs::+bs-pushlike+))))) + (setf std-flags (logior std-flags gfs::+bs-autocheckbox+ gfs::+bs-pushlike+))) + ((eq sym :tri-state) + (setf std-flags (logior std-flags gfs::+bs-auto3state+))))) (if (null style) (logior std-flags gfs::+bs-pushbutton+)) (values std-flags 0))) @@ -88,7 +90,7 @@ (let ((text-size (widget-text-size self gfs::+dt-singleline+)) (size (gfs:make-size)) (b-width (* (border-width self) 2)) - (need-cb-size (intersection '(:check-box :radio-button) (style-of self))) + (need-cb-size (intersection '(:check-box :radio-button :tri-state) (style-of self))) (cb-size (check-box-size))) (cond ((>= width-hint 0) From junrue at common-lisp.net Mon Jun 5 18:42:47 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 5 Jun 2006 14:42:47 -0400 (EDT) Subject: [graphic-forms-cvs] r153 - in trunk: docs/manual src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/widgets Message-ID: <20060605184247.DB16144054@common-lisp.net> Author: junrue Date: Mon Jun 5 14:42:47 2006 New Revision: 153 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/graphics/magick-core-api.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: fixed silly redundant floor forms Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jun 5 14:42:47 2006 @@ -225,7 +225,7 @@ @end deftp @anchor{control} - at deftp Class control + at deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color The base class for widgets having pre-defined native behavior. It derives from @ref{widget}. @end deftp Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Jun 5 14:42:47 2006 @@ -46,8 +46,8 @@ (gfs:make-point :x xpos :y ypos)))) (defun window->tiles (pnt) - (let ((xpos (floor (/ (1- (gfs:point-x pnt)) +tile-bmp-width+))) - (ypos (- +vert-tile-count+ (1+ (floor (/ (1- (gfs:point-y pnt)) +tile-bmp-height+)))))) + (let ((xpos (floor (1- (gfs:point-x pnt)) +tile-bmp-width+)) + (ypos (- +vert-tile-count+ (1+ (floor (1- (gfs:point-y pnt)) +tile-bmp-height+))))) (if (or (>= xpos +horz-tile-count+) (>= ypos +vert-tile-count+)) nil (gfs:make-point :x xpos :y ypos)))) Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Jun 5 14:42:47 2006 @@ -301,7 +301,7 @@ (setf pnt (draw-a-string gc pnt nil "Courier New" 14 '(:italic :bold :underline) nil)) (setf pnt (draw-a-string gc pnt nil "Courier New" 18 '(:strikeout) nil)) - (setf (gfs:point-x pnt) (+ (floor (/ (gfs:size-width (gfw:client-size *drawing-win*)) 2)) 10)) + (setf (gfs:point-x pnt) (+ (floor (gfs:size-width (gfw:client-size *drawing-win*)) 2) 10)) (setf (gfs:point-y pnt) 0) (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))) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Jun 5 14:42:47 2006 @@ -52,7 +52,7 @@ (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-blue*) (let* ((sz (gfw:client-size window)) - (pnt (gfs:make-point :x 0 :y (floor (/ (gfs:size-height sz) 2))))) + (pnt (gfs:make-point :x 0 :y (floor (gfs:size-height sz) 2)))) (gfg:draw-text gc *event-tester-text* pnt))) (defmethod gfw:event-close ((d event-tester-window-events) widget time) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Mon Jun 5 14:42:47 2006 @@ -79,7 +79,7 @@ size)) (defmethod gfw:text-baseline ((widget mock-widget)) - (floor (/ (* (gfs:size-height (min-size-of widget)) 3) 4))) + (floor (* (gfs:size-height (min-size-of widget)) 3) 4)) (defmethod gfw:visible-p ((widget mock-widget)) (visibility-of widget)) Modified: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Mon Jun 5 14:42:47 2006 @@ -135,7 +135,7 @@ (height :unsigned-long)) (defun scale-quantum-to-byte (quant) - (floor (/ quant 257))) + (floor quant 257)) ;;; ;;; translated from magick.h Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Jun 5 14:42:47 2006 @@ -167,9 +167,9 @@ (setf baseline (+ b-width top-margin (gfg:ascent metrics) - (floor (/ (- (gfs:size-height size) - (+ (gfg:ascent metrics) (gfg:descent metrics))) - 2))))) + (floor (- (gfs:size-height size) + (+ (gfg:ascent metrics) (gfg:descent metrics))) + 2)))) (gfs:dispose gc)) baseline)) @@ -190,8 +190,8 @@ (cffi:with-foreign-object (bm-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bm-ptr gfs::bitmap) (gfs::get-object hbitmap (cffi:foreign-type-size 'gfs::bitmap) bm-ptr) - (setf *check-box-size* (gfs:make-size :width (floor (/ gfs::width 4)) - :height (floor (/ gfs::height 3)))))) + (setf *check-box-size* (gfs:make-size :width (floor gfs::width 4) + :height (floor gfs::height 3))))) (gfs::delete-object hbitmap))) (gfs:copy-size *check-box-size*)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Jun 5 14:42:47 2006 @@ -41,7 +41,7 @@ (+ ancest-coord (floor (- (/ ancest-size 2) (/ desc-size 2))))) (defun centered-coord-outside (ancest-coord ancest-size desc-size) - (- ancest-coord (floor (/ (- desc-size ancest-size) 2)))) + (- ancest-coord (floor (- desc-size ancest-size) 2))) (defun center-object (ancestor descendant) (let* ((ancest-size (client-size ancestor)) From junrue at common-lisp.net Wed Jun 7 04:26:44 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 7 Jun 2006 00:26:44 -0400 (EDT) Subject: [graphic-forms-cvs] r154 - trunk Message-ID: <20060607042644.29FCB232BC@common-lisp.net> Author: junrue Date: Wed Jun 7 00:26:43 2006 New Revision: 154 Modified: trunk/config.lisp Log: upgrade to CFFI snapshot 060606 which has a fix for foreign structure corruption problem on LW Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Wed Jun 7 00:26:43 2006 @@ -40,7 +40,7 @@ (in-package #:graphic-forms-system) (defvar *cells-dir* "cells/") -(defvar *cffi-dir* "cffi-060514/") +(defvar *cffi-dir* "cffi-060606/") (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") (defvar *gf-dir* "graphic-forms/") From junrue at common-lisp.net Thu Jun 8 21:16:13 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 8 Jun 2006 17:16:13 -0400 (EDT) Subject: [graphic-forms-cvs] r155 - trunk/src/uitoolkit/widgets Message-ID: <20060608211613.74E9078000@common-lisp.net> Author: junrue Date: Thu Jun 8 17:16:12 2006 New Revision: 155 Modified: trunk/src/uitoolkit/widgets/dialog.lisp Log: got rid of default event-close method for dialogs, applications must explicitly decide when dialogs are to be closed Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu Jun 8 17:16:12 2006 @@ -174,9 +174,11 @@ ;; (init-window self +dialog-classname+ #'register-dialog-class owner text)) +#| (defmethod event-close ((self event-dispatcher) (dlg dialog) time) (declare (ignore time)) (show dlg nil)) +|# (defmethod show ((self dialog) flag) (let ((app-modal (find :application-modal (style-of self))) From junrue at common-lisp.net Thu Jun 8 21:35:25 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 8 Jun 2006 17:35:25 -0400 (EDT) Subject: [graphic-forms-cvs] r156 - in trunk/src: demos/unblocked uitoolkit/widgets Message-ID: <20060608213525.659F517034@common-lisp.net> Author: junrue Date: Thu Jun 8 17:35:25 2006 New Revision: 156 Modified: trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/uitoolkit/widgets/dialog.lisp Log: updated unblocked model code based on some loop style feedback; set a variable to create new random state when game starts Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Thu Jun 8 17:35:25 2006 @@ -35,8 +35,13 @@ (defstruct tile (kind 0) (location (gfs:make-point))) +(defvar *unblocked-random-state* nil) + (defun init-tiles (width height kinds) - (let* ((tiles (make-array width :initial-element nil))) + (if (null *unblocked-random-state*) + (setf *unblocked-random-state* (make-random-state))) + (let ((tiles (make-array width :initial-element nil)) + (*random-state* *unblocked-random-state*)) (dotimes (i width) (let ((column (make-array height :initial-element 0))) (setf (aref tiles i) column) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Thu Jun 8 17:35:25 2006 @@ -43,11 +43,10 @@ collect (* 250 level level))) (defun lookup-level-reached (score) - (let ((level 1)) - (loop for entry in *points-needed-table* - until (> entry score) - do (incf level)) - level)) + (loop for entry in *points-needed-table* + until (> entry score) + for level from 1 + finally (return level))) (cells:defmodel unblocked-game-model () ((level @@ -69,9 +68,9 @@ +vert-tile-count+ (1- +max-tile-kinds+)))) (data - (let ((tmp (clone-tiles cells:.cache))) - (loop for pnt in data do (set-tile tmp pnt 0)) - (collapse-tiles tmp))) + (loop with tmp = (clone-tiles cells:.cache) + for pnt in data do (set-tile tmp pnt 0) + finally (return (collapse-tiles tmp)))) (t cells:.cache))))))) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu Jun 8 17:35:25 2006 @@ -174,12 +174,6 @@ ;; (init-window self +dialog-classname+ #'register-dialog-class owner text)) -#| -(defmethod event-close ((self event-dispatcher) (dlg dialog) time) - (declare (ignore time)) - (show dlg nil)) -|# - (defmethod show ((self dialog) flag) (let ((app-modal (find :application-modal (style-of self))) (owner-modal (find :owner-modal (style-of self))) From junrue at common-lisp.net Thu Jun 22 17:10:05 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 22 Jun 2006 13:10:05 -0400 (EDT) Subject: [graphic-forms-cvs] r157 - in trunk: . src/demos/unblocked src/tests/uitoolkit Message-ID: <20060622171005.7555A6800C@common-lisp.net> Author: junrue Date: Thu Jun 22 13:10:03 2006 New Revision: 157 Added: trunk/src/demos/unblocked/about.bmp (contents, props changed) trunk/src/demos/unblocked/blue-tile.bmp - copied unchanged from r90, trunk/src/tests/uitoolkit/blue-tile.bmp trunk/src/demos/unblocked/brown-tile.bmp - copied unchanged from r90, trunk/src/tests/uitoolkit/brown-tile.bmp trunk/src/demos/unblocked/gold-tile.bmp - copied unchanged from r90, trunk/src/tests/uitoolkit/gold-tile.bmp trunk/src/demos/unblocked/green-tile.bmp - copied unchanged from r90, trunk/src/tests/uitoolkit/green-tile.bmp trunk/src/demos/unblocked/pink-tile.bmp - copied unchanged from r90, trunk/src/tests/uitoolkit/pink-tile.bmp trunk/src/demos/unblocked/red-tile.bmp - copied unchanged from r90, trunk/src/tests/uitoolkit/red-tile.bmp Removed: trunk/src/tests/uitoolkit/blue-tile.bmp trunk/src/tests/uitoolkit/brown-tile.bmp trunk/src/tests/uitoolkit/gold-tile.bmp trunk/src/tests/uitoolkit/green-tile.bmp trunk/src/tests/uitoolkit/pink-tile.bmp trunk/src/tests/uitoolkit/red-tile.bmp Modified: trunk/build.lisp trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/tests.lisp Log: added about dialog to unblocked demo; revised code that loads images for tests Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Thu Jun 22 13:10:03 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-0.9.0/")) +(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/")) (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/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Thu Jun 22 13:10:03 2006 @@ -31,8 +31,6 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -; (in-package #:graphic-forms-system) - (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) (:use :common-lisp :lisp-unit) Added: trunk/src/demos/unblocked/about.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Thu Jun 22 13:10:03 2006 @@ -89,7 +89,9 @@ (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp" "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp") do (let ((image (make-instance 'gfg:image))) - (gfg:load image filename) + (gfg:load image (complete-pathname (concatenate 'string + "src/demos/unblocked/" + filename))) (setf (gethash kind table) image) (incf kind))))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Thu Jun 22 13:10:03 2006 @@ -34,11 +34,15 @@ (in-package :graphic-forms.uitoolkit.tests) (defconstant +spacing+ 4) -(defconstant +margin+ 4) +(defconstant +margin+ 4) -(defvar *scoreboard-panel* nil) -(defvar *tiles-panel* nil) -(defvar *unblocked-win* nil) +(defvar *scoreboard-panel* nil) +(defvar *unblocked-startup-dir* nil) +(defvar *tiles-panel* nil) +(defvar *unblocked-win* nil) + +(defun complete-pathname (path-segment) + (merge-pathnames path-segment *unblocked-startup-dir*)) (defun get-tiles-panel () *tiles-panel*) @@ -76,7 +80,78 @@ (declare (ignore window time)) (quit-unblocked disp nil nil nil)) +(defclass unblocked-about-dialog-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog) time) + (declare (ignore time)) + (call-next-method) + (gfs:dispose dlg)) + +(defun about-unblocked (disp item time rect) + (declare (ignore disp item time rect)) + (let* ((image (make-instance 'gfg:image :file (complete-pathname "src/demos/unblocked/about.bmp"))) + (dlg (make-instance 'gfw:dialog :owner *unblocked-win* + :dispatcher (make-instance 'unblocked-about-dialog-events) + :layout (make-instance 'gfw:flow-layout + :margins 8 + :spacing 8) + :style '(:owner-modal) + :text (concatenate 'string "About UnBlocked"))) + (label (make-instance 'gfw:label :parent dlg)) + (text-panel (make-instance 'gfw:panel + :layout (make-instance 'gfw:flow-layout + :margins 0 + :spacing 2 + :style '(:vertical)) + :parent dlg)) + (line1 (make-instance 'gfw:label + :parent text-panel + :text "UnBlocked version 0.4")) + (line2 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (line3 (make-instance 'gfw:label + :parent text-panel + :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) + (line4 (make-instance 'gfw:label + :parent text-panel + :text "All Rights Reserved.")) + (line5 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (line6 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (btn-panel (make-instance 'gfw:panel + :parent dlg + :layout (make-instance 'gfw:flow-layout + :margins 0 + :spacing 0 + :style '(:vertical :normalize)))) + (close-btn (make-instance 'gfw:button + :callback (lambda (disp btn time rect) + (declare (ignore disp btn time rect)) + (gfs:dispose dlg)) + :style '(:cancel-button) + :text "Close" + :parent btn-panel))) + (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) + (unwind-protect + (gfg:with-image-transparency (image (gfs:make-point)) + (setf (gfw:image label) image)) + (gfs:dispose image)) + (gfw:pack dlg) + (gfw:center-on-owner dlg) + ;; FIXME: Close button not getting initial focus; looks like + ;; labels or panels are getting it, because I can tab to the + ;; button with enough tabs + (gfw:show dlg t))) + (defun unblocked-startup () +#+clisp + (setf *unblocked-startup-dir* (ext:cd)) +#+lispworks + (setf *unblocked-startup-dir* (hcl:get-working-directory)) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "&New" :callback #'new-unblocked) (:item "&Restart" :callback #'restart-unblocked) @@ -84,7 +159,7 @@ (:item "" :separator) (:item "E&xit" :callback #'quit-unblocked))) (:item "&Help" - :submenu ((:item "&About")))))) + :submenu ((:item "&About" :callback #'about-unblocked)))))) (scoreboard-buffer-size (compute-scoreboard-size)) (tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+) 2) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Thu Jun 22 13:10:03 2006 @@ -94,6 +94,7 @@ (gfw:shutdown 0)) (defun run-image-tester-internal () + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((menubar nil)) (setf *happy-image* (make-instance 'gfg:image)) (setf *bw-image* (make-instance 'gfg:image)) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Jun 22 13:10:03 2006 @@ -383,6 +383,7 @@ (exit-layout-tester)) (defun run-layout-tester-internal () + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (setf *widget-counter* 0) (let ((menubar nil) (pack-disp (make-instance 'pack-layout-dispatcher)) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Thu Jun 22 13:10:03 2006 @@ -36,5 +36,6 @@ (load (compile-file *lisp-unit-file*)) (defun load-tests () - (setf *default-pathname-defaults* (parse-namestring *gf-tests-dir*)) +#+lispworks + (hcl:change-directory *gf-dir*) (asdf:operate 'asdf:load-op :graphic-forms-tests)) From junrue at common-lisp.net Sun Jun 25 01:46:37 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 24 Jun 2006 21:46:37 -0400 (EDT) Subject: [graphic-forms-cvs] r158 - trunk/src/demos/unblocked Message-ID: <20060625014637.BB14C6911A@common-lisp.net> Author: junrue Date: Sat Jun 24 21:46:36 2006 New Revision: 158 Modified: trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: implemented game restart in UnBlocked Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sat Jun 24 21:46:36 2006 @@ -48,6 +48,13 @@ for level from 1 finally (return level))) +(defun revise-tiles (active-tiles orig-tiles shape-data) + (if shape-data + (loop with tmp = (clone-tiles active-tiles) + for pnt in shape-data do (set-tile tmp pnt 0) + finally (return (collapse-tiles tmp))) + orig-tiles)) + (cells:defmodel unblocked-game-model () ((level :accessor level @@ -59,29 +66,29 @@ (shape-data :accessor shape-data :initform (cells:c-in nil)) - (tiles - :accessor tiles - :initform (cells:c? (let ((data (^shape-data))) - (cond - ((null cells:.cache) - (collapse-tiles (init-tiles +horz-tile-count+ - +vert-tile-count+ - (1- +max-tile-kinds+)))) - (data - (loop with tmp = (clone-tiles cells:.cache) - for pnt in data do (set-tile tmp pnt 0) - finally (return (collapse-tiles tmp)))) - (t - cells:.cache))))))) + (original-tiles + :accessor original-tiles + :initarg :original-tiles + :initform (cells:c-in (collapse-tiles (init-tiles +horz-tile-count+ + +vert-tile-count+ + (1- +max-tile-kinds+))))) + (active-tiles + :accessor active-tiles + :initform (cells:c? (revise-tiles cells:.cache (^original-tiles) (^shape-data)))))) (defvar *game* (make-instance 'unblocked-game-model)) -(defun reset-game () +(defun new-game () (cells:cells-reset) (setf *game* (make-instance 'unblocked-game-model))) +(defun restart-game () + (let ((saved-tiles (original-tiles *game*))) + (cells:cells-reset) + (setf *game* (make-instance 'unblocked-game-model :original-tiles saved-tiles)))) + (defun game-tiles () - (tiles *game*)) + (active-tiles *game*)) (defun game-shape-data (pnts) (setf (shape-data *game*) pnts)) @@ -102,5 +109,5 @@ (cells:defobserver score ((self unblocked-game-model)) (update-panel (get-scoreboard-panel))) -(cells:defobserver tiles ((self unblocked-game-model)) +(cells:defobserver active-tiles ((self unblocked-game-model)) (update-panel (get-tiles-panel))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sat Jun 24 21:46:36 2006 @@ -52,16 +52,15 @@ (defun new-unblocked (disp item time rect) (declare (ignore disp item time rect)) - (reset-game) - (let ((tiles-disp (gfw:dispatcher *tiles-panel*)) - (scoreboard-disp (gfw:dispatcher *scoreboard-panel*))) - (update-buffer scoreboard-disp) - (update-buffer tiles-disp) - (gfw:redraw *scoreboard-panel*) - (gfw:redraw *tiles-panel*))) + (new-game) + (update-panel *scoreboard-panel*) + (update-panel *tiles-panel*)) (defun restart-unblocked (disp item time rect) - (declare (ignore disp item time rect))) + (declare (ignore disp item time rect)) + (restart-game) + (update-panel *scoreboard-panel*) + (update-panel *tiles-panel*)) (defun reveal-unblocked (disp item time rect) (declare (ignore disp item time rect))) From junrue at common-lisp.net Sun Jun 25 23:22:53 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 25 Jun 2006 19:22:53 -0400 (EDT) Subject: [graphic-forms-cvs] r159 - trunk/src/demos/unblocked Message-ID: <20060625232253.2CBAE26096@common-lisp.net> Author: junrue Date: Sun Jun 25 19:22:52 2006 New Revision: 159 Modified: trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: implemented reveal-unblocked Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Jun 25 19:22:52 2006 @@ -110,13 +110,9 @@ (if (and (eql button :left-button) (> tile-kind 0)) (shape-tiles tiles tile-pnt tmp-table)) (when (> (hash-table-count tmp-table) 1) - (maphash #'(lambda (pnt kind) - (declare (ignore kind)) - (push pnt shape-pnts)) - tmp-table) (setf (shape-kind-of self) tile-kind) - (setf (shape-pnts-of self) shape-pnts) - (draw-tiles-directly panel shape-pnts +max-tile-kinds+)))) + (setf (shape-pnts-of self) (shape-tile-points tmp-table)) + (draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+)))) (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) (declare (ignore time)) Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Sun Jun 25 19:22:52 2006 @@ -110,6 +110,28 @@ when (= kind (obtain-tile tiles pnt2)) do (shape-tiles tiles pnt2 results))))) +(defun shape-tile-points (shape) + (let ((shape-pnts nil)) + (maphash (lambda (pnt kind) + (declare (ignore kind)) + (push pnt shape-pnts)) + shape) + shape-pnts)) + +(defun shape-size (shape) + (hash-table-count shape)) + +(defun shape-kind (shape) + (if (null shape) + (return-from shape-kind 0)) + (let ((kind nil)) + (maphash (lambda (pnt k) + (declare (ignore pnt)) + (if (null kind) + (setf kind k))) + shape) + kind)) + (defun collapse-column (column-tiles) (let ((new-column (make-array (length column-tiles) :initial-element 0)) (new-index 0) @@ -133,3 +155,37 @@ (dotimes (i width) (setf (aref new-tiles i) (copy-seq (aref orig-tiles i)))) new-tiles)) + +(defun find-shape (tiles accept-p) + (if (null *unblocked-random-state*) + (setf *unblocked-random-state* (make-random-state))) + (let ((*random-state* *unblocked-random-state*) + (candidate-shapes nil)) + (dotimes (col-index (length tiles)) + (let ((column-tiles (aref tiles col-index))) + (dotimes (tile-index (length column-tiles)) + (let ((shape (make-hash-table :test #'equalp))) + (shape-tiles tiles (gfs:make-point :x col-index :y tile-index) shape) + (if (funcall accept-p shape) + (push shape candidate-shapes)))))) + (unless candidate-shapes + (return-from find-shape nil)) + (elt candidate-shapes (random (length candidate-shapes))))) + +#| +(defun find-shape (tiles accept-p) + (if (null *unblocked-random-state*) + (setf *unblocked-random-state* (make-random-state))) + (let ((*random-state* *unblocked-random-state*) + (shape nil)) + (loop for col-index = (random (length tiles)) + for column-tiles = (aref tiles col-index) + for tile-index = (random (length column-tiles)) + for tmp-shape = (make-hash-table :test #'equalp) + until shape + do (progn + (shape-tiles tiles (gfs:make-point :x col-index :y tile-index) tmp-shape) + (if (and (> (shape-size tmp-shape) 1) (funcall accept-p tmp-shape)) + (setf shape tmp-shape)))) + shape)) +|# \ No newline at end of file Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jun 25 19:22:52 2006 @@ -33,8 +33,10 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +spacing+ 4) -(defconstant +margin+ 4) +(defconstant +spacing+ 4) +(defconstant +margin+ 4) + +(defconstant +revealed-duration+ 2000) ; millis (defvar *scoreboard-panel* nil) (defvar *unblocked-startup-dir* nil) @@ -62,8 +64,21 @@ (update-panel *scoreboard-panel*) (update-panel *tiles-panel*)) +(defun accept-shape-p (shape) + (let ((size (shape-size shape)) + (kind (shape-kind shape))) + (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) + (defun reveal-unblocked (disp item time rect) - (declare (ignore disp item time rect))) + (declare (ignore disp item time rect)) + (let ((shape (find-shape (game-tiles) #'accept-shape-p))) + (when shape + (let ((shape-pnts (shape-tile-points shape)) + (timer (make-instance 'gfw:timer :initial-delay +revealed-duration+ + :delay 0 + :dispatcher (gfw:dispatcher *unblocked-win*)))) + (draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+) + (gfw:enable timer t))))) (defun quit-unblocked (disp item time rect) (declare (ignore disp item time rect)) @@ -79,6 +94,10 @@ (declare (ignore window time)) (quit-unblocked disp nil nil nil)) +(defmethod gfw:event-timer ((disp unblocked-win-events) timer time) + (declare (ignore timer time)) + (update-panel *tiles-panel*)) + (defclass unblocked-about-dialog-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog) time) From junrue at common-lisp.net Sun Jun 25 23:31:00 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 25 Jun 2006 19:31:00 -0400 (EDT) Subject: [graphic-forms-cvs] r160 - trunk/src/demos/unblocked Message-ID: <20060625233100.196452E18A@common-lisp.net> Author: junrue Date: Sun Jun 25 19:31:00 2006 New Revision: 160 Modified: trunk/src/demos/unblocked/unblocked-model.lisp Log: fixed a glitch in usage of loop that manifested itself under LW Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sun Jun 25 19:31:00 2006 @@ -44,8 +44,8 @@ (defun lookup-level-reached (score) (loop for entry in *points-needed-table* - until (> entry score) for level from 1 + until (> entry score) finally (return level))) (defun revise-tiles (active-tiles orig-tiles shape-data) From junrue at common-lisp.net Mon Jun 26 04:25:54 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 26 Jun 2006 00:25:54 -0400 (EDT) Subject: [graphic-forms-cvs] r161 - in trunk: docs/manual src src/demos/unblocked src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060626042554.2419F102A@common-lisp.net> Author: junrue Date: Mon Jun 26 00:25:52 2006 New Revision: 161 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/label.lisp Log: corrected an early mistake whereby rectangle should have been a structure originally Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jun 26 00:25:52 2006 @@ -81,8 +81,6 @@ foreign pointer but should be treated as an opaque cookie. @deffn Initarg :handle @end deffn - at deffn Reader handle - at end deffn @end deftp @anchor{point} @@ -91,18 +89,10 @@ @end deftp @anchor{rectangle} - at deftp Class rectangle location size -This class identifies a region in the Cartesian coordinate system -consisting of an upper-left coordinate and bounds. See @ref{point} and + at deftp Structure rectangle location size +This structure identifies a region in the Cartesian coordinate system +consisting of an upper-left coordinate and size. See @ref{point} and @ref{size}. - at deffn Initarg :location - at end deffn - at deffn Initarg :size - at end deffn - at deffn Accessor location - at end deffn - at deffn Accessor size - at end deffn @end deftp @anchor{size} @@ -112,7 +102,7 @@ @anchor{span} @deftp Structure span start end -This structure represents a range of values or times in a collection. +This structure represents a range of values. @end deftp @@ -132,10 +122,18 @@ but secondary initialization code has not yet executed. @end deffn + at deffn Macro location rect +This macro returns the @code{location} slot of a @ref{rectangle}. + at end deffn + @deffn Function make-point :x :y :z This function creates a new @ref{point} object. @end deffn + at deffn Function make-rectangle :location :size +This function creates a new @ref{rectangle} object. + at end deffn + @deffn Function make-size :width :height :depth This function creates a new @ref{size} object. @end deffn @@ -144,6 +142,10 @@ This function creates a new @ref{span} object. @end deffn + at deffn Macro size rect +This macro returns the @code{size} slot of a @ref{rectangle}. + at end deffn + @node system conditions @section system conditions Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Mon Jun 26 00:25:52 2006 @@ -49,7 +49,7 @@ (let ((image (image-buffer-of self))) (setf (gfg:background-color gc) *background-color*) (setf (gfg:foreground-color gc) *background-color*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfg:size image))))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfg:size image))))) (defmethod dispose ((self double-buffered-event-dispatcher)) (let ((image (image-buffer-of self))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Jun 26 00:25:52 2006 @@ -69,6 +69,7 @@ #:handle #:location #:make-point + #:make-rectangle #:make-size #:make-span #:null-handle-p Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Jun 26 00:25:52 2006 @@ -69,7 +69,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) (let ((func (draw-func-of self))) (unless (null func) (funcall func gc)))) @@ -145,7 +145,7 @@ (defun draw-arcs (gc) (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) (rect-size (gfs:make-size :width 80 :height 65)) - (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (start-pnt (gfs:make-point :x 15 :y 60)) (end-pnt (gfs:make-point :x 75 :y 25)) (delta-x (+ (gfs:size-width rect-size) 10)) @@ -154,12 +154,12 @@ (incf (gfs:point-y rect-pnt) delta-y) (incf (gfs:point-y start-pnt) delta-y) (incf (gfs:point-y end-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-chord nil) (incf (gfs:point-y rect-pnt) delta-y) (incf (gfs:point-y start-pnt) delta-y) (incf (gfs:point-y end-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil))) (defun select-arcs (disp item time rect) @@ -194,12 +194,12 @@ (defun draw-ellipses (gc) (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) (rect-size (gfs:make-size :width 80 :height 65)) - (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (delta-x (+ (gfs:size-width rect-size) 10)) (delta-y (+ (gfs:size-height rect-size) 10))) (draw-rectangular gc rect nil delta-x #'gfg:draw-filled-ellipse t) (incf (gfs:point-y rect-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil))) (defun select-ellipses (disp item time rect) @@ -249,19 +249,19 @@ (defun draw-rects (gc) (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) (rect-size (gfs:make-size :width 80 :height 50)) - (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (delta-x (+ (gfs:size-width rect-size) 10)) (delta-y (+ (gfs:size-height rect-size) 10)) (arc-size (gfs:make-size :width 10 :height 10))) (draw-rectangular gc rect arc-size delta-x #'gfg:draw-filled-rounded-rectangle t) (incf (gfs:point-y rect-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-filled-rectangle t) (incf (gfs:point-y rect-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect arc-size delta-x #'gfg:draw-rounded-rectangle nil) (incf (gfs:point-y rect-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil))) (defun select-rects (disp item time rect) @@ -323,7 +323,7 @@ (defun draw-wedges (gc) (let* ((rect-pnt (gfs:make-point :x 5 :y 10)) (rect-size (gfs:make-size :width 80 :height 65)) - (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (delta-x (+ (gfs:size-width rect-size) 10)) (delta-y (gfs:size-height rect-size)) (start-pnt (gfs:make-point :x 35 :y 75)) @@ -333,7 +333,7 @@ (incf (gfs:point-y rect-pnt) delta-y) (incf (gfs:point-y start-pnt) delta-y) (incf (gfs:point-y end-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil))) (defun select-wedges (disp item time rect) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Jun 26 00:25:52 2006 @@ -51,7 +51,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-red*) (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Jun 26 00:25:52 2006 @@ -74,7 +74,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window)))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) (defclass test-panel (gfw:panel) ()) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Jun 26 00:25:52 2006 @@ -53,7 +53,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window)))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) (defclass test-mini-events (test-win-events) ()) @@ -129,7 +129,7 @@ (let ((parent (gfw:parent panel))) (setf (gfg:background-color gc) (gfg:background-color parent)) (setf (gfg:foreground-color gc) (gfg:background-color parent)) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:size panel))))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:size panel))))) (defclass dialog-events (gfw:event-dispatcher) ()) Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Mon Jun 26 00:25:52 2006 @@ -37,19 +37,12 @@ (defstruct size (width 0) (height 0) (depth 0)) +(defstruct rectangle (location (make-point)) (size (make-size))) + (defstruct span (start 0) (end 0)) -(defclass rectangle () - ((location - :accessor location - :initarg :location - :initform (make-point)) - (size - :accessor size - :initarg :size - :initform (make-size))) - (:documentation "Describes the perimeter of a rectangular region in a given coordinate system.")) +(defmacro location (rect) + `(rectangle-location ,rect)) -(defmethod print-object ((obj rectangle) stream) - (print-unreadable-object (obj stream :type t) - (format stream "location: ~a size: ~a" (location obj) (size obj)))) +(defmacro size (rect) + `(rectangle-size ,rect)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Jun 26 00:25:52 2006 @@ -152,7 +152,7 @@ (event-select (dispatcher item) item (event-time tc) - (make-instance 'gfs:rectangle)))))) ; FIXME + (gfs:make-rectangle)))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t @@ -163,7 +163,7 @@ (event-select (dispatcher w) w (event-time tc) - (make-instance 'gfs:rectangle))))))) ; FIXME + (gfs:make-rectangle))))))) ; FIXME (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) @@ -286,7 +286,7 @@ (let* ((tc (thread-context)) (widget (get-widget tc hwnd))) (if widget - (let ((rct (make-instance 'gfs:rectangle))) + (let ((rct (gfs:make-rectangle))) (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) (cffi:with-foreign-slots ((gfs::rcpaint-x gfs::rcpaint-y Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Jun 26 00:25:52 2006 @@ -141,7 +141,7 @@ (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)))) + (cons kid (gfs:make-rectangle :size kid-size :location pnt)))) (defun flow-container-layout (layout visible kids width-hint height-hint) (let ((flows nil) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Mon Jun 26 00:25:52 2006 @@ -63,7 +63,7 @@ (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))) + (bounds (gfs:make-rectangle :size new-size :location new-pnt))) (with-children (win kids) (loop for kid in kids collect (cons kid bounds))))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Jun 26 00:25:52 2006 @@ -132,7 +132,7 @@ (if tr-pnt (let* ((color (gfg:background-color label)) (size (gfg:size image)) - (bounds (make-instance 'gfs:rectangle :size size)) + (bounds (gfs:make-rectangle :size size)) (tmp-image (make-instance 'gfg:image :size size)) (gc (make-instance 'gfg:graphics-context :image tmp-image))) (unwind-protect From junrue at common-lisp.net Mon Jun 26 12:30:25 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 26 Jun 2006 08:30:25 -0400 (EDT) Subject: [graphic-forms-cvs] r162 - in trunk: docs/manual src src/demos/unblocked src/uitoolkit/widgets Message-ID: <20060626123025.0DC0752002@common-lisp.net> Author: junrue Date: Mon Jun 26 08:30:24 2006 New Revision: 162 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented and documented capture-mouse/release-mouse functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jun 26 08:30:24 2006 @@ -813,6 +813,17 @@ widget must be a @ref{button} and is typically labelled @emph{Cancel}. @end deffn + at anchor{capture-mouse} + at deffn Function capture-mouse self +Enables the @ref{window} identified by @code{self} to receive mouse +input events even when the mouse pointer is outside of the bounds +of @code{self}. Only one window at a time can capture the mouse. This +function is primarily intended for use with a window in the foreground; +background windows may still capture the mouse, but only mouse move +events will be received and those only when the mouse hotspot is within +the visible portions of such a window. @xref{release-mouse}. + at end deffn + @anchor{center-on-owner} @deffn GenericFunction center-on-owner self Position @code{self} such that it is centrally located relative to its @@ -1031,6 +1042,12 @@ Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn + at anchor{release-mouse} + at deffn Function release-mouse +Clears the mouse capture state to restore normal mouse input processing. + at xref{capture-mouse}. + at end deffn + @anchor{show} @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Jun 26 08:30:24 2006 @@ -110,19 +110,19 @@ (if (and (eql button :left-button) (> tile-kind 0)) (shape-tiles tiles tile-pnt tmp-table)) (when (> (hash-table-count tmp-table) 1) + (gfw:capture-mouse panel) (setf (shape-kind-of self) tile-kind) (setf (shape-pnts-of self) (shape-tile-points tmp-table)) (draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+)))) (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) (declare (ignore time)) + (gfw:release-mouse) (let ((tile-pnt (window->tiles point)) (shape-pnts (shape-pnts-of self))) - (if (and (eql button :left-button) - shape-pnts - (find tile-pnt shape-pnts :test #'eql-point)) - (game-shape-data shape-pnts) - (if shape-pnts + (when (and (eql button :left-button) shape-pnts) + (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) + (game-shape-data shape-pnts) (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) (setf (shape-kind-of self) 0) (setf (shape-pnts-of self) nil)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Jun 26 08:30:24 2006 @@ -318,6 +318,7 @@ #:background-pattern #:border-width #:bottom-margin-of + #:capture-mouse #:caret #:center-on-owner #:center-on-parent @@ -441,6 +442,7 @@ #:primary-p #:redraw #:redrawing-p + #:release-mouse #:remove-all #:remove-item #:remove-span Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Jun 26 08:30:24 2006 @@ -141,6 +141,16 @@ retval (error 'gfs::win32-error :detail "register-class failed"))))))) +(defun capture-mouse (self) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (typep self 'window) + (error 'gfs:toolkit-error :detail "capture-mouse is restricted to window subclasses")) + (gfs::set-capture (gfs:handle self))) + +(defun release-mouse () + (gfs::release-capture)) + (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-children ((win var) &body body) (let ((hwnd (gensym))) From junrue at common-lisp.net Mon Jun 26 22:28:52 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 26 Jun 2006 18:28:52 -0400 (EDT) Subject: [graphic-forms-cvs] r163 - in trunk: . docs/manual src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060626222852.963EB17034@common-lisp.net> Author: junrue Date: Mon Jun 26 18:28:49 2006 New Revision: 163 Added: trunk/src/uitoolkit/system/comctl32.lisp trunk/src/uitoolkit/widgets/edit.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: preparation for implementing edit control Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jun 26 18:28:49 2006 @@ -280,6 +280,55 @@ derives from @ref{native-object}. @end deftp + at anchor{edit} + at deftp Class edit +This subclass of @ref{control} represents a rectangular area that +permits the user to enter and edit text. The @ref{event-focus-gain} +and @ref{event-focus-loss} methods of each @code{edit control}'s + at ref{event-dispatcher} are invoked when focus is given or taken +away. The @ref{event-modify} method is invoked when the user edits +content. + at deffn Initarg :style + at table @code + at item :auto-hscroll +Specifies that the @code{edit control} will scroll text content to the +right by 10 characters when the user types a character at the end +of the line. + at item :auto-vscroll +Specifies that the @code{edit control} will scroll text up by a page +when the user types @sc{enter} on the last line. This style keyword +is only meaningful when @code{:multi-line} is also specified. + at item :mask-characters +Specifies that each character of text be masked by an echo character +instead of the one literally typed. The character can be changed via +the @ref{echo-character} @sc{setf} method. + at item :multi-line +By default, @code{edit control}s are single-line text fields. By specifying + at code{:multi-line}, multiple lines of text can be supplied. When the + at code{edit control} is in a @ref{dialog}, the @sc{enter} key will invoke +the default @ref{button}'s @ref{event-dispatcher}, unless + at code{:want-return} is also specified. If @code{:auto-hscroll} is not +specified, then text will be automatically word-wrapped. + at item :no-border +By default, an @code{edit control} is rendered with a border; this style +keyword disables that feature. + at item :no-hide-selection +This specifies that any selection remain rendered even when the + at code{edit control} loses input focus. By default, the selection +is hidden when focus is lost. + at item :read-only +Specifies that the @code{edit control}'s contents cannot be modified by +the user. + at item :want-return +Specifies that a carriage return be inserted when the user types + at sc{enter}. This style keyword only applies when the @code{:multi-line} +style is also specified. Without this style, within a dialog the +act of typing @sc{enter} has the same effect as pressing the dialog's +default button. + at end table + at end deffn + at end deftp + @anchor{event-dispatcher} @deftp Class event-dispatcher This is the base class of objects responsible for processing events on @@ -732,6 +781,12 @@ Implement this to respond to a key up event. @end deffn + at anchor{event-modify} + at deffn GenericFunction event-modify dispatcher widget time +Implement this to respond to changes within a @ref{widget}, for example +when the user types text inside an @ref{edit} control. + at end deffn + @deffn GenericFunction event-mouse-double dispatcher widget time point button Implement this to respond to a mouse double-click. @end deffn @@ -883,6 +938,14 @@ from display-relative coordinates to this object's coordinate system. @end deffn + at anchor{echo-character} + at deffn GenericFunction echo-character self => character +Returns the character currently set to be used to mask text content, +such as inside an @ref{edit} control created with the @code{:password} +style keyword, or @sc{nil} if none has been set. The corresponding + at sc{setf} function sets this value. + at end deffn + @anchor{enable} @deffn GenericFunction enable self flag For widgets, this function enables or disables the object, causing it Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Jun 26 18:28:49 2006 @@ -60,6 +60,7 @@ (:file "datastructs") (:file "clib") (:file "comdlg32") + (:file "comctl32") (:file "gdi32") (:file "kernel32") (:file "user32") @@ -98,6 +99,7 @@ (:file "item") (:file "widget") (:file "control") + (:file "edit") (:file "label") (:file "button") (:file "widget-with-items") Added: trunk/src/uitoolkit/system/comctl32.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/comctl32.lisp Mon Jun 26 18:28:49 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; comctl32.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.system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(load-foreign-library "comctl32.dll") + +(defcfun + ("InitCommonControlsEx" init-common-controls) + BOOL + (init LPTR)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Mon Jun 26 18:28:49 2006 @@ -230,6 +230,21 @@ (defconstant +dt-hideprefix+ #x00100000) (defconstant +dt-prefixonly+ #x00200000) +(defconstant +es-left+ #x0000) +(defconstant +es-center+ #x0001) +(defconstant +es-right+ #x0002) +(defconstant +es-multiline+ #x0004) +(defconstant +es-uppercase+ #x0008) +(defconstant +es-lowercase+ #x0010) +(defconstant +es-password+ #x0020) +(defconstant +es-autovscroll+ #x0040) +(defconstant +es-autohscroll+ #x0080) +(defconstant +es-nohidesel+ #x0100) +(defconstant +es-oemconvert+ #x0400) +(defconstant +es-readonly+ #x0800) +(defconstant +es-wantreturn+ #x1000) +(defconstant +es-number+ #x2000) + (defconstant +eto-opaque+ #x0002) (defconstant +eto-clipped+ #x0004) (defconstant +eto-glyph-index+ #x0010) @@ -303,6 +318,24 @@ (defconstant +hs-cross+ 4) (defconstant +hs-diagcross+ 5) +(defconstant +icc-listview-classes+ #x00000001) +(defconstant +icc-treeview-classes+ #x00000002) +(defconstant +icc-bar-classes+ #x00000004) +(defconstant +icc-tab-classes+ #x00000008) +(defconstant +icc-updown-class+ #x00000010) +(defconstant +icc-progress-class+ #x00000020) +(defconstant +icc-hotkey-class+ #x00000040) +(defconstant +icc-animate-class+ #x00000080) +(defconstant +icc-win95-classes+ #x000000FF) +(defconstant +icc-date-classes+ #x00000100) +(defconstant +icc-userex-classes+ #x00000200) +(defconstant +icc-cool-classes+ #x00000400) +(defconstant +icc-internet-classes+ #x00000800) +(defconstant +icc-pagescroller-class+ #x00001000) +(defconstant +icc-nativefntctl-class+ #x00002000) +(defconstant +icc-standard-classes+ #x00004000) +(defconstant +icc-link-class+ #x00008000) + (defconstant +idok+ 1) (defconstant +idcancel+ 2) (defconstant +idabort+ 3) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Mon Jun 26 18:28:49 2006 @@ -121,6 +121,10 @@ (rightmargin INT) (lengthdrawn UINT)) +(defcstruct initcommoncontrolsex + (size DWORD) + (icc DWORD)) + (defcstruct logbrush (style UINT) (color COLORREF) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Mon Jun 26 18:28:49 2006 @@ -42,9 +42,9 @@ (defmethod compute-style-flags ((btn button) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) + (let ((std-flags +default-child-style+) (style (style-of btn))) - (loop for sym in (style-of btn) + (loop for sym in style do (cond ;; primary button styles ;; Added: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/edit.lisp Mon Jun 26 18:28:49 2006 @@ -0,0 +1,62 @@ +;;;; +;;;; edit.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-style-flags ((self edit) &rest extra-data) + (declare (ignore extra-data)) + (let ((border-flag (if (find :no-border (style-of self)) 0 gfs::+ws-border+))) + (values (loop for sym in (style-of self) + for std-flags = (logior +default-child-style+ border-flag) + then (logior std-flags + (ecase sym + ;; primary edit styles + ;; + (:multi-line (logior +default-child-style+ + gfs::+es-multiline+ + border-flag)) + + ;; styles that can be combined + ;; + (:auto-hscroll gfs::+es-autohscroll+) + (:auto-vscroll gfs::+es-autovscroll+) + (:mask-characters gfs::+es-password+) + (:no-hide-selection gfs::+es-nohidesel+) + (:read-only gfs::+es-readonly+) + (:want-return gfs::+es-wantreturn+))) + finally (return std-flags)) + 0))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Jun 26 18:28:49 2006 @@ -94,8 +94,7 @@ (defmethod compute-style-flags ((label label) &rest extra-data) (if (> (count-if-not #'null extra-data) 1) (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) - (let ((std-style (logior gfs::+ws-child+ - gfs::+ws-visible+ + (let ((std-style (logior +default-child-style+ (cond ((first extra-data) (compute-image-style-flags (style-of label))) @@ -126,8 +125,7 @@ gfs::+ss-bitmap+ gfs::+ss-realsizeimage+ gfs::+ss-centerimage+ - gfs::+ws-child+ - gfs::+ws-visible+)) + +default-child-style+)) (tr-pnt (gfg:transparency-pixel-of image))) (if tr-pnt (let* ((color (gfg:background-color label)) @@ -206,8 +204,7 @@ (declare (ignore ex-flags)) (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags std-flags - gfs::+ws-child+ - gfs::+ws-visible+)))) + +default-child-style+)))) (set-widget-text self str)) (defmethod text-baseline ((self label)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Mon Jun 26 18:28:49 2006 @@ -55,7 +55,7 @@ (defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) + (let ((std-flags +default-child-style+)) (mapc #'(lambda (sym) (cond ;; styles that can be combined Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Jun 26 18:28:49 2006 @@ -118,6 +118,9 @@ (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked.")) +(defclass edit (control) () + (:documentation "This class represents a control in which the user may enter and edit text.")) + (defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image.")) Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Mon Jun 26 18:28:49 2006 @@ -33,63 +33,66 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +vk-break+ #x03) -(defconstant +vk-backspace+ #x08) -(defconstant +vk-tab+ #x09) -(defconstant +vk-clear+ #x0C) ; numpad-5 when numlock off -(defconstant +vk-return+ #x0D) -(defconstant +vk-shift+ #x10) -(defconstant +vk-control+ #x11) -(defconstant +vk-alt+ #x12) -(defconstant +vk-pause+ #x13) -(defconstant +vk-caps-lock+ #x14) -(defconstant +vk-escape+ #x1B) -(defconstant +vk-page-up+ #x21) -(defconstant +vk-page-down+ #x22) -(defconstant +vk-end+ #x23) -(defconstant +vk-home+ #x24) -(defconstant +vk-left+ #x25) -(defconstant +vk-up+ #x26) -(defconstant +vk-right+ #x27) -(defconstant +vk-down+ #x28) -(defconstant +vk-insert+ #x2D) -(defconstant +vk-delete+ #x2E) -(defconstant +vk-help+ #x2F) -(defconstant +vk-left-win+ #x5B) -(defconstant +vk-right-win+ #x5C) -(defconstant +vk-applications+ #x5D) -(defconstant +vk-numpad-0+ #x60) -(defconstant +vk-numpad-1+ #x61) -(defconstant +vk-numpad-2+ #x62) -(defconstant +vk-numpad-3+ #x63) -(defconstant +vk-numpad-4+ #x64) -(defconstant +vk-numpad-5+ #x65) -(defconstant +vk-numpad-6+ #x66) -(defconstant +vk-numpad-7+ #x67) -(defconstant +vk-numpad-8+ #x68) -(defconstant +vk-numpad-9+ #x69) -(defconstant +vk-numpad-*+ #x6A) -(defconstant +vk-numpad-++ #x6B) -(defconstant +vk-numpad--+ #x6D) -(defconstant +vk-numpad-.+ #x6E) -(defconstant +vk-numpad-/+ #x6F) -(defconstant +vk-numpad-f1+ #x70) -(defconstant +vk-numpad-f2+ #x71) -(defconstant +vk-numpad-f3+ #x72) -(defconstant +vk-numpad-f4+ #x73) -(defconstant +vk-numpad-f5+ #x74) -(defconstant +vk-numpad-f6+ #x75) -(defconstant +vk-numpad-f7+ #x76) -(defconstant +vk-numpad-f8+ #x77) -(defconstant +vk-numpad-f9+ #x78) -(defconstant +vk-numpad-f10+ #x79) -(defconstant +vk-numpad-f11+ #x7A) -(defconstant +vk-numpad-f12+ #x7B) -(defconstant +vk-num-lock+ #x90) -(defconstant +vk-scroll-lock+ #x91) -(defconstant +vk-left-shift+ #xA0) -(defconstant +vk-right-shift+ #xA1) -(defconstant +vk-left-control+ #xA2) -(defconstant +vk-right-control+ #xA3) -(defconstant +vk-left-alt+ #xA4) -(defconstant +vk-right-alt+ #xA5) +(defconstant +vk-break+ #x03) +(defconstant +vk-backspace+ #x08) +(defconstant +vk-tab+ #x09) +(defconstant +vk-clear+ #x0C) ; numpad-5 when numlock off +(defconstant +vk-return+ #x0D) +(defconstant +vk-shift+ #x10) +(defconstant +vk-control+ #x11) +(defconstant +vk-alt+ #x12) +(defconstant +vk-pause+ #x13) +(defconstant +vk-caps-lock+ #x14) +(defconstant +vk-escape+ #x1B) +(defconstant +vk-page-up+ #x21) +(defconstant +vk-page-down+ #x22) +(defconstant +vk-end+ #x23) +(defconstant +vk-home+ #x24) +(defconstant +vk-left+ #x25) +(defconstant +vk-up+ #x26) +(defconstant +vk-right+ #x27) +(defconstant +vk-down+ #x28) +(defconstant +vk-insert+ #x2D) +(defconstant +vk-delete+ #x2E) +(defconstant +vk-help+ #x2F) +(defconstant +vk-left-win+ #x5B) +(defconstant +vk-right-win+ #x5C) +(defconstant +vk-applications+ #x5D) +(defconstant +vk-numpad-0+ #x60) +(defconstant +vk-numpad-1+ #x61) +(defconstant +vk-numpad-2+ #x62) +(defconstant +vk-numpad-3+ #x63) +(defconstant +vk-numpad-4+ #x64) +(defconstant +vk-numpad-5+ #x65) +(defconstant +vk-numpad-6+ #x66) +(defconstant +vk-numpad-7+ #x67) +(defconstant +vk-numpad-8+ #x68) +(defconstant +vk-numpad-9+ #x69) +(defconstant +vk-numpad-*+ #x6A) +(defconstant +vk-numpad-++ #x6B) +(defconstant +vk-numpad--+ #x6D) +(defconstant +vk-numpad-.+ #x6E) +(defconstant +vk-numpad-/+ #x6F) +(defconstant +vk-numpad-f1+ #x70) +(defconstant +vk-numpad-f2+ #x71) +(defconstant +vk-numpad-f3+ #x72) +(defconstant +vk-numpad-f4+ #x73) +(defconstant +vk-numpad-f5+ #x74) +(defconstant +vk-numpad-f6+ #x75) +(defconstant +vk-numpad-f7+ #x76) +(defconstant +vk-numpad-f8+ #x77) +(defconstant +vk-numpad-f9+ #x78) +(defconstant +vk-numpad-f10+ #x79) +(defconstant +vk-numpad-f11+ #x7A) +(defconstant +vk-numpad-f12+ #x7B) +(defconstant +vk-num-lock+ #x90) +(defconstant +vk-scroll-lock+ #x91) +(defconstant +vk-left-shift+ #xA0) +(defconstant +vk-right-shift+ #xA1) +(defconstant +vk-left-control+ #xA2) +(defconstant +vk-right-control+ #xA3) +(defconstant +vk-left-alt+ #xA4) +(defconstant +vk-right-alt+ #xA5) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Jun 26 18:28:49 2006 @@ -129,7 +129,7 @@ (defgeneric display-to-object (self pnt) (:documentation "Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system.")) -(defgeneric echo-char (self) +(defgeneric echo-character (self) (:documentation "Returns the character that will be displayed when the user types text, or nil if no echo character has been set.")) (defgeneric enable (self flag) From junrue at common-lisp.net Wed Jun 28 02:15:01 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 27 Jun 2006 22:15:01 -0400 (EDT) Subject: [graphic-forms-cvs] r164 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060628021501.F384678000@common-lisp.net> Author: junrue Date: Tue Jun 27 22:15:00 2006 New Revision: 164 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: edit controls can now be created, minimally tested via layout-tester Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Jun 27 22:15:00 2006 @@ -293,11 +293,14 @@ @item :auto-hscroll Specifies that the @code{edit control} will scroll text content to the right by 10 characters when the user types a character at the end -of the line. +of the line. For single-line @code{edit control}s, this style is set +by the library. @item :auto-vscroll Specifies that the @code{edit control} will scroll text up by a page when the user types @sc{enter} on the last line. This style keyword is only meaningful when @code{:multi-line} is also specified. + at item :horizontal-scrollbar +Specifies that a horizontal scrollbar should be displayed. @item :mask-characters Specifies that each character of text be masked by an echo character instead of the one literally typed. The character can be changed via @@ -319,6 +322,8 @@ @item :read-only Specifies that the @code{edit control}'s contents cannot be modified by the user. + at item :vertical-scrollbar +Specifies that a vertical scrollbar should be displayed. @item :want-return Specifies that a carriage return be inserted when the user types @sc{enter}. This style keyword only applies when the @code{:multi-line} @@ -327,6 +332,9 @@ default button. @end table @end deffn + at deffn Initarg :text +Supplies the initial text for the @code{edit control}. + at end deffn @end deftp @anchor{event-dispatcher} @@ -987,8 +995,13 @@ Set the size and location of this object's children. @end deffn - at deffn GenericFunction location self -Returns a @ref{point} object describing the coordinates of the + at anchor{line-count} + at deffn GenericFunction line-count self => integer +Returns the total number of lines (e.g., of text) contained by @code{self}. + at end deffn + + at deffn GenericFunction location self => @ref{point} +Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system. @xref{parent}. @end deffn Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Jun 27 22:15:00 2006 @@ -227,6 +227,7 @@ #:control #:dialog #:display + #:edit #:event-dispatcher #:event-source #:file-dialog @@ -414,6 +415,7 @@ #:layout-of #:layout-p #:left-margin-of + #:line-count #:lines-visible-p #:location #:lock Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Jun 27 22:15:00 2006 @@ -34,10 +34,11 @@ (in-package #:graphic-forms.uitoolkit.tests) (defconstant +btn-text-before+ "Push Me") -(defconstant +btn-text-after+ "Again!") -(defconstant +label-text+ "Label") -(defconstant +margin-delta+ 4) -(defconstant +spacing-delta+ 3) +(defconstant +btn-text-after+ "Again!") +(defconstant +edit-text+ "something to edit") +(defconstant +label-text+ "Label") +(defconstant +margin-delta+ 4) +(defconstant +spacing-delta+ 3) (defvar *widget-counter* 0) @@ -99,7 +100,7 @@ (defun add-layout-tester-widget (widget-class subtype) (let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) - (w nil)) + (w nil)) (cond ((or (eql subtype :check-box) (eql subtype :push-button) @@ -112,6 +113,10 @@ :style (list subtype))) (setf (toggle-fn be) (create-button-toggler be)) (setf (gfw:text w) (funcall (toggle-fn be)))) + ((eql subtype :single-line-edit) + (setf w (make-instance widget-class + :parent *layout-tester-win* + :text (format nil "~d ~a" (id be) +edit-text+)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here @@ -389,6 +394,8 @@ (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) (add-checkbox-disp (make-instance 'add-child-dispatcher :subtype :check-box)) + (add-edit-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:edit + :subtype :single-line-edit)) (add-radio-disp (make-instance 'add-child-dispatcher :subtype :radio-button)) (add-toggle-disp (make-instance 'add-child-dispatcher :subtype :toggle-button)) (add-tri-state-disp (make-instance 'add-child-dispatcher :subtype :tri-state)) @@ -411,14 +418,15 @@ :callback #'exit-layout-callback))) (:item "&Children" :submenu ((:item "Add" - :submenu ((:item "Button" :dispatcher add-btn-disp) - (:item "Checkbox" :dispatcher add-checkbox-disp) + :submenu ((:item "Button" :dispatcher add-btn-disp) + (:item "Checkbox" :dispatcher add-checkbox-disp) + (:item "Edit" :dispatcher add-edit-disp) (:item "Label - Image" :dispatcher add-image-label-disp) - (:item "Label - Text" :dispatcher add-text-label-disp) - (:item "Panel" :dispatcher add-panel-disp) - (:item "Radiobutton" :dispatcher add-radio-disp) - (:item "Toggle" :dispatcher add-toggle-disp) - (:item "Tri-State" :dispatcher add-tri-state-disp))) + (:item "Label - Text" :dispatcher add-text-label-disp) + (:item "Panel" :dispatcher add-panel-disp) + (:item "Radiobutton" :dispatcher add-radio-disp) + (:item "Toggle" :dispatcher add-toggle-disp) + (:item "Tri-State" :dispatcher add-tri-state-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) (:item "Visible" :dispatcher vis-menu-disp Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Jun 27 22:15:00 2006 @@ -34,6 +34,7 @@ (in-package :graphic-forms.uitoolkit.system) (defconstant +button-classname+ "button") +(defconstant +edit-classname+ "edit") (defconstant +static-classname+ "static") (defconstant +ad-counterclockwise+ 1) @@ -47,31 +48,31 @@ (defconstant +bi-png+ 5) (defconstant +blt-blackness+ #x00000042) -(defconstant +blt-notsrcerase+ #x001100a6) +(defconstant +blt-notsrcerase+ #x001100A6) (defconstant +blt-notsrccopy+ #x00330008) (defconstant +blt-srcerase+ #x00440328) (defconstant +blt-dstinvert+ #x00550009) -(defconstant +blt-patinvert+ #x005a0049) +(defconstant +blt-patinvert+ #x005A0049) (defconstant +blt-srcinvert+ #x00660046) -(defconstant +blt-srcand+ #x008800c6) -(defconstant +blt-mergecopy+ #x00c000ca) -(defconstant +blt-mergepaint+ #x00bb0226) -(defconstant +blt-srccopy+ #x00cc0020) -(defconstant +blt-srcpaint+ #x00ee0086) -(defconstant +blt-patcopy+ #x00f00021) -(defconstant +blt-patpaint+ #x00fb0a09) -(defconstant +blt-whiteness+ #x00ff0062) +(defconstant +blt-srcand+ #x008800C6) +(defconstant +blt-mergecopy+ #x00C000CA) +(defconstant +blt-mergepaint+ #x00BB0226) +(defconstant +blt-srccopy+ #x00CC0020) +(defconstant +blt-srcpaint+ #x00EE0086) +(defconstant +blt-patcopy+ #x00F00021) +(defconstant +blt-patpaint+ #x00FB0A09) +(defconstant +blt-whiteness+ #x00FF0062) (defconstant +blt-captureblt+ #x40000000) (defconstant +blt-nomirrorbitmap+ #x80000000) -(defconstant +bm-getcheck+ #x00f0) -(defconstant +bm-setcheck+ #x00f1) -(defconstant +bm-getstate+ #x00f2) -(defconstant +bm-setstate+ #x00f3) -(defconstant +bm-setstyle+ #x00f4) -(defconstant +bm-click+ #x00f5) -(defconstant +bm-getimage+ #x00f6) -(defconstant +bm-setimage+ #x00f7) +(defconstant +bm-getcheck+ #x00F0) +(defconstant +bm-setcheck+ #x00F1) +(defconstant +bm-getstate+ #x00F2) +(defconstant +bm-setstate+ #x00F3) +(defconstant +bm-setstyle+ #x00F4) +(defconstant +bm-click+ #x00F5) +(defconstant +bm-getimage+ #x00F6) +(defconstant +bm-setimage+ #x00F7) (defconstant +bs-solid+ 0) (defconstant +bs-null+ 1) @@ -139,7 +140,7 @@ (defconstant +cderr-memallocfailure+ #x0009) (defconstant +cderr-memlockfailure+ #x000a) (defconstant +cderr-nohook+ #x000b) -(defconstant +cderr-registermsgfail+ #x000c) +(defconstant +cderr-registermsgfail+ #x000C) (defconstant +cferr-choosefontcodes+ #x2000) (defconstant +cferr-nofonts+ #x2001) @@ -230,6 +231,46 @@ (defconstant +dt-hideprefix+ #x00100000) (defconstant +dt-prefixonly+ #x00200000) +(defconstant +em-getsel+ #x00B0) +(defconstant +em-setsel+ #x00B1) +(defconstant +em-getrect+ #x00B2) +(defconstant +em-setrect+ #x00B3) +(defconstant +em-setrectnp+ #x00B4) +(defconstant +em-scroll+ #x00B5) +(defconstant +em-linescroll+ #x00B6) +(defconstant +em-scrollcaret+ #x00B7) +(defconstant +em-getmodify+ #x00B8) +(defconstant +em-setmodify+ #x00B9) +(defconstant +em-getlinecount+ #x00BA) +(defconstant +em-lineindex+ #x00BB) +(defconstant +em-sethandle+ #x00BC) +(defconstant +em-gethandle+ #x00BD) +(defconstant +em-getthumb+ #x00BE) +(defconstant +em-linelength+ #x00C1) +(defconstant +em-replacesel+ #x00C2) +(defconstant +em-getline+ #x00C4) +(defconstant +em-limittext+ #x00C5) +(defconstant +em-canundo+ #x00C6) +(defconstant +em-undo+ #x00C7) +(defconstant +em-fmtlines+ #x00C8) +(defconstant +em-linefromchar+ #x00C9) +(defconstant +em-settabstops+ #x00CB) +(defconstant +em-setpasswordchar+ #x00CC) +(defconstant +em-emptyundobuffer+ #x00CD) +(defconstant +em-getfirstvisibleline+ #x00CE) +(defconstant +em-setreadonly+ #x00CF) +(defconstant +em-setwordbreakproc+ #x00D0) +(defconstant +em-getwordbreakproc+ #x00D1) +(defconstant +em-getpasswordchar+ #x00D2) +(defconstant +em-setmargins+ #x00D3) +(defconstant +em-getmargins+ #x00D4) +(defconstant +em-setlimittext+ #x00C5) +(defconstant +em-getlimittext+ #x00D5) +(defconstant +em-posfromchar+ #x00D6) +(defconstant +em-charfrompos+ #x00D7) +(defconstant +em-setimestatus+ #x00D8) +(defconstant +em-getimestatus+ #x00D9) + (defconstant +es-left+ #x0000) (defconstant +es-center+ #x0001) (defconstant +es-right+ #x0002) @@ -545,8 +586,8 @@ (defconstant +pderr-nodefaultprn+ #x1008) (defconstant +pderr-dndmmismatch+ #x1009) (defconstant +pderr-createicfailure+ #x100a) -(defconstant +pderr-printernotfound+ #x100b) -(defconstant +pderr-defaultdifferent+ #x100c) +(defconstant +pderr-printernotfound+ #x100B) +(defconstant +pderr-defaultdifferent+ #x100C) (defconstant +qs-key+ #x0001) (defconstant +qs-mousemove+ #x0002) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Jun 27 22:15:00 2006 @@ -40,10 +40,10 @@ ;;; methods ;;; -(defmethod compute-style-flags ((btn button) &rest extra-data) +(defmethod compute-style-flags ((self button) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags +default-child-style+) - (style (style-of btn))) + (style (style-of self))) (loop for sym in style do (cond ;; primary button styles @@ -64,27 +64,26 @@ (logior std-flags gfs::+bs-pushbutton+)) (values std-flags 0))) -(defmethod initialize-instance :after ((btn button) &key parent text &allow-other-keys) +(defmethod initialize-instance :after ((self button) &key parent text &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) - (compute-style-flags btn) + (compute-style-flags self) (let ((hwnd (create-window gfs::+button-classname+ (or text " ") (gfs:handle parent) std-style ex-style (cond - ((find :default-button (style-of btn)) + ((find :default-button (style-of self)) gfs::+idok+) - ((find :cancel-button (style-of btn)) + ((find :cancel-button (style-of self)) gfs::+idcancel+) (t (increment-widget-id (thread-context))))))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) (unless (zerop (logand std-style gfs::+bs-defpushbutton+)) (gfs::send-message (gfs:handle parent) gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0)) - (setf (slot-value btn 'gfs:handle) hwnd))) - (init-control btn)) + (setf (slot-value self 'gfs:handle) hwnd))) + (init-control self)) (defmethod preferred-size ((self button) width-hint height-hint) (let ((text-size (widget-text-size self gfs::+dt-singleline+)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Jun 27 22:15:00 2006 @@ -43,11 +43,7 @@ (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfs:null-handle-p hfont) - (unless (zerop (gfs::send-message hwnd - gfs::+wm-setfont+ - (cffi:pointer-address hfont) - 0)) - (error 'gfs:win32-error :detail "send-message failed")))))) + (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Jun 27 22:15:00 2006 @@ -33,30 +33,71 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defconstant +horizontal-edit-text-margin+ 2) +(defconstant +vertical-edit-text-margin+ 2) + ;;; ;;; methods ;;; (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) - (let ((border-flag (if (find :no-border (style-of self)) 0 gfs::+ws-border+))) - (values (loop for sym in (style-of self) - for std-flags = (logior +default-child-style+ border-flag) - then (logior std-flags - (ecase sym - ;; primary edit styles - ;; - (:multi-line (logior +default-child-style+ - gfs::+es-multiline+ - border-flag)) - - ;; styles that can be combined - ;; - (:auto-hscroll gfs::+es-autohscroll+) - (:auto-vscroll gfs::+es-autovscroll+) - (:mask-characters gfs::+es-password+) - (:no-hide-selection gfs::+es-nohidesel+) - (:read-only gfs::+es-readonly+) - (:want-return gfs::+es-wantreturn+))) - finally (return std-flags)) - 0))) + (let ((std-flags +default-child-style+) + (style (style-of self))) + (loop for sym in style + do (ecase sym + ;; primary edit styles + ;; + (:multi-line (setf std-flags (logior +default-child-style+ + gfs::+es-multiline+))) + ;; styles that can be combined + ;; + (:auto-hscroll (setf std-flags (logior std-flags gfs::+es-autohscroll+))) + (:auto-vscroll (setf std-flags (logior std-flags gfs::+es-autovscroll+))) + (:mask-characters (setf std-flags (logior std-flags gfs::+es-password+))) + (:no-hide-selection (setf std-flags (logior std-flags gfs::+es-nohidesel+))) + (:read-only (setf std-flags (logior std-flags gfs::+es-readonly+))) + (:want-return (setf std-flags (logior std-flags gfs::+es-wantreturn+))))) + (if (not (find :multi-line style)) + (setf std-flags (logior std-flags gfs::+es-autohscroll+))) + (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+)))) + +(defmethod initialize-instance :after ((self edit) &key parent text &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self) + (let ((hwnd (create-window gfs::+edit-classname+ + (or text "") + (gfs:handle parent) + std-style + ex-style + (increment-widget-id (thread-context))))) + (setf (slot-value self 'gfs:handle) hwnd))) + (init-control self)) + +(defmethod line-count ((self edit)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::send-message (gfs:handle self) gfs::+em-getlinecount+ 0 0)) + +(defmethod preferred-size ((self edit) width-hint height-hint) + (let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) + (size (gfs:make-size)) + (b-width (* (border-width self) 2))) + (if (>= width-hint 0) + (setf (gfs:size-width size) width-hint) + (setf (gfs:size-width size) (+ b-width + (gfs:size-width text-size) + (* +horizontal-edit-text-margin+ 2)))) + (if (>= height-hint 0) + (setf (gfs:size-height size) height-hint) + (setf (gfs:size-height size) (+ b-width + (* (gfs:size-height text-size) (line-count self)) + (* +vertical-edit-text-margin+ 2)))) + size)) + +(defmethod text ((self edit)) + (get-widget-text self)) + +(defmethod (setf text) (str (self edit)) + (set-widget-text self str)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Jun 27 22:15:00 2006 @@ -115,7 +115,7 @@ (if (zerop (gfs::set-window-long hwnd gfs::+gwlp-wndproc+ (cffi:pointer-address - (cffi:get-callback 'subclassing_wndproc)))) + (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed"))) ;;; Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Jun 27 22:15:00 2006 @@ -152,6 +152,7 @@ (cffi:pointer-address (gfs:handle image))))) (defmethod initialize-instance :after ((label label) &key image parent separator text &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags label image separator text) (let ((hwnd (create-window gfs::+static-classname+ @@ -160,8 +161,6 @@ (logior std-style) ex-style (increment-widget-id (thread-context))))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) (setf (slot-value label 'gfs:handle) hwnd) (if image (setf (image label) image)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Jun 27 22:15:00 2006 @@ -99,8 +99,6 @@ gfs::+ws-border+ gfs::+ws-popup+) 0))) - (if (gfs:null-handle-p hwnd) - (error 'gfs:win32-error :detail "create-window failed")) (setf (slot-value tc 'utility-hwnd) hwnd))) (defmethod call-child-visitor-func ((tc thread-context) parent child) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Jun 27 22:15:00 2006 @@ -189,6 +189,9 @@ (defgeneric layout (self) (:documentation "Set the size and location of this object's children.")) +(defgeneric line-count (self) + (:documentation "Returns the total number of lines (e.g., of text).")) + (defgeneric lines-visible-p (self) (:documentation "Returns T if the object's lines are visible; nil otherwise.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Jun 27 22:15:00 2006 @@ -78,24 +78,34 @@ (unless (zerop count) (gfw:clear-span w (gfs:make-span :start 0 :end (1- count)))))) +(defun initialize-comctl-classes (icc-flags) + (cffi:with-foreign-object (ic-ptr 'gfs::initcommoncontrolsex) + (cffi:with-foreign-slots ((gfs::size gfs::icc) ic-ptr gfs::initcommoncontrolsex) + (setf gfs::size (cffi:foreign-type-size 'gfs::initcommoncontrolsex) + gfs::icc icc-flags)) + (if (zerop (gfs::init-common-controls ic-ptr)) + (warn 'gfs:toolkit-warning :detail "init-common-controls failed")))) + (defun create-window (class-name title parent-hwnd std-style ex-style &optional child-id) (cffi:with-foreign-string (cname-ptr class-name) (cffi:with-foreign-string (title-ptr title) - (gfs::create-window - ex-style - cname-ptr - title-ptr - (if child-id (logior std-style gfs::+ws-tabstop+) std-style) - gfs::+cw-usedefault+ - gfs::+cw-usedefault+ - gfs::+cw-usedefault+ - gfs::+cw-usedefault+ - parent-hwnd - (if (zerop (logand gfs::+ws-child+ std-style)) - (cffi:null-pointer) - (cffi:make-pointer (or child-id (increment-widget-id (thread-context))))) - (cffi:null-pointer) - 0)))) + (let ((hwnd (gfs::create-window ex-style + cname-ptr + title-ptr + (if child-id (logior std-style gfs::+ws-tabstop+) std-style) + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + parent-hwnd + (if (zerop (logand gfs::+ws-child+ std-style)) + (cffi:null-pointer) + (cffi:make-pointer (or child-id (increment-widget-id (thread-context))))) + (cffi:null-pointer) + 0))) + (if (gfs:null-handle-p hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + hwnd)))) (defun get-widget-text (w) (if (gfs:disposed-p w) From junrue at common-lisp.net Wed Jun 28 03:22:46 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 27 Jun 2006 23:22:46 -0400 (EDT) Subject: [graphic-forms-cvs] r165 - in trunk/src: tests/uitoolkit uitoolkit/widgets Message-ID: <20060628032246.3C0CB21013@common-lisp.net> Author: junrue Date: Tue Jun 27 23:22:46 2006 New Revision: 165 Modified: trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: more edit control testing via windlg Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Tue Jun 27 23:22:46 2006 @@ -118,19 +118,6 @@ :initial-directory #P"c:/") (print paths))) -(defclass dlg-test-panel (gfw:panel) ()) - -(defmethod gfw:preferred-size ((win dlg-test-panel) width-hint height-hint) - (declare (ignore width-hint height-hint)) - (gfs:make-size :width 280 :height 200)) - -(defmethod gfw:event-paint ((self gfw:event-dispatcher) (panel dlg-test-panel) time gc rect) - (declare (ignore time rect)) - (let ((parent (gfw:parent panel))) - (setf (gfg:background-color gc) (gfg:background-color parent)) - (setf (gfg:foreground-color gc) (gfg:background-color parent)) - (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:size panel))))) - (defclass dialog-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time) @@ -144,13 +131,42 @@ :dispatcher (make-instance 'dialog-events) :layout (make-instance 'gfw:flow-layout :margins 8 - :spacing 4 + :spacing 8 :style '(:horizontal)) :style style :text title)) - (panel (make-instance 'dlg-test-panel - :style '(:border) - :parent dlg)) + (left-panel (make-instance 'gfw:panel + :layout (make-instance 'gfw:flow-layout + :spacing 4 + :style '(:vertical)) + :parent dlg)) + (name-label (make-instance 'gfw:label + :text "Name:" + :parent left-panel)) + (name-edit (make-instance 'gfw:edit + :text "WWWWWWWWWWWWWWWWWWWWWWWW" + :parent left-panel)) + (serial-label (make-instance 'gfw:label + :text "Serial Number:" + :parent left-panel)) + (serial-edit (make-instance 'gfw:edit + :style '(:read-only) + :text "323K DSKL3 DSKE23" + :parent left-panel)) + (pw-label (make-instance 'gfw:label + :text "Password:" + :parent left-panel)) + (pw-edit (make-instance 'gfw:edit + :style '(:mask-characters) + :text "WWWWWWWWWWWWWWWWWWWWWWWW" + :parent left-panel)) + (desc-label (make-instance 'gfw:label + :text "Description:" + :parent left-panel)) + (desc-edit (make-instance 'gfw:edit + :style '(:multi-line :auto-hscroll :auto-vscroll :vertical-scrollbar :want-return) + :text (format nil "WWWWWWWWWWWWWWWWWWWWWWWW~%W~%W~%W~%W~%W") + :parent left-panel)) (btn-panel (make-instance 'gfw:panel :layout (make-instance 'gfw:flow-layout :spacing 4 @@ -170,8 +186,11 @@ :style '(:cancel-button) :text "Cancel" :parent btn-panel))) - (declare (ignore panel ok-btn cancel-btn)) + (declare (ignore name-label serial-label serial-edit pw-label desc-label ok-btn cancel-btn)) (gfw:pack dlg) + (setf (gfw:text name-edit) "" + (gfw:text pw-edit) "" + (gfw:text desc-edit) "") (gfw:center-on-owner dlg) (gfw:show dlg t) dlg)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Jun 27 23:22:46 2006 @@ -42,7 +42,7 @@ (defmethod compute-style-flags ((self button) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags +default-child-style+) + (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+)) (style (style-of self))) (loop for sym in style do (cond Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Jun 27 23:22:46 2006 @@ -42,22 +42,26 @@ (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags +default-child-style+) + (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+)) (style (style-of self))) (loop for sym in style do (ecase sym ;; primary edit styles ;; - (:multi-line (setf std-flags (logior +default-child-style+ - gfs::+es-multiline+))) + (:multi-line (setf std-flags (logior +default-child-style+ + gfs::+ws-tabstop+ + gfs::+es-multiline+))) ;; styles that can be combined ;; - (:auto-hscroll (setf std-flags (logior std-flags gfs::+es-autohscroll+))) - (:auto-vscroll (setf std-flags (logior std-flags gfs::+es-autovscroll+))) - (:mask-characters (setf std-flags (logior std-flags gfs::+es-password+))) - (:no-hide-selection (setf std-flags (logior std-flags gfs::+es-nohidesel+))) - (:read-only (setf std-flags (logior std-flags gfs::+es-readonly+))) - (:want-return (setf std-flags (logior std-flags gfs::+es-wantreturn+))))) + (:auto-hscroll (setf std-flags (logior std-flags gfs::+es-autohscroll+))) + (:auto-vscroll (setf std-flags (logior std-flags gfs::+es-autovscroll+))) + (:horizontal-scrollbar (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:mask-characters (setf std-flags (logior std-flags gfs::+es-password+))) + (:no-border ) + (:no-hide-selection (setf std-flags (logior std-flags gfs::+es-nohidesel+))) + (:read-only (setf std-flags (logior std-flags gfs::+es-readonly+))) + (:vertical-scrollbar (setf std-flags (logior std-flags gfs::+ws-vscroll+))) + (:want-return (setf std-flags (logior std-flags gfs::+es-wantreturn+))))) (if (not (find :multi-line style)) (setf std-flags (logior std-flags gfs::+es-autohscroll+))) (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+)))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Jun 27 23:22:46 2006 @@ -92,7 +92,7 @@ (let ((hwnd (gfs::create-window ex-style cname-ptr title-ptr - (if child-id (logior std-style gfs::+ws-tabstop+) std-style) + std-style gfs::+cw-usedefault+ gfs::+cw-usedefault+ gfs::+cw-usedefault+ From junrue at common-lisp.net Wed Jun 28 16:33:32 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 28 Jun 2006 12:33:32 -0400 (EDT) Subject: [graphic-forms-cvs] r166 - in trunk/src/uitoolkit: system widgets Message-ID: <20060628163332.91EA514003@common-lisp.net> Author: junrue Date: Wed Jun 28 12:33:32 2006 New Revision: 166 Modified: trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/edit.lisp Log: added activation context data structure, which will be needed in the future for enabling common control theme support Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Wed Jun 28 12:33:32 2006 @@ -53,6 +53,7 @@ (defctype DWORD :unsigned-long) (defctype HANDLE :pointer) (defctype INT :int) +(defctype LANGID :short) (defctype LONG :long) (defctype LPARAM :long) (defctype LPCSTR :pointer) @@ -68,9 +69,21 @@ (defctype TCHAR :char) (defctype UINT :unsigned-int) (defctype ULONG :unsigned-long) +(defctype USHORT :unsigned-short) (defctype WORD :short) (defctype WPARAM :unsigned-int) +(defcstruct actctx + (cbsize ULONG) + (flags DWORD) + (source :string) + (arch USHORT) + (langid LANGID) + (dir :string) + (resname :string) + (appname :string) + (hmodule HANDLE)) + (defcstruct bitmap (type LONG) (width LONG) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Wed Jun 28 12:33:32 2006 @@ -105,3 +105,6 @@ (defmethod (setf text) (str (self edit)) (set-widget-text self str)) + +(defmethod text-baseline ((self edit)) + (widget-text-baseline self +vertical-edit-text-margin+)) From junrue at common-lisp.net Wed Jun 28 21:44:08 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 28 Jun 2006 17:44:08 -0400 (EDT) Subject: [graphic-forms-cvs] r167 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets Message-ID: <20060628214408.6536844062@common-lisp.net> Author: junrue Date: Wed Jun 28 17:44:07 2006 New Revision: 167 Modified: trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event.lisp Log: introduced infrastructure for dispatching control notifications, and used this to implement event-focus-gain/event-focus-loss and event-modify for edit controls Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed Jun 28 17:44:07 2006 @@ -126,6 +126,23 @@ (call-next-method) (gfs:dispose dlg)) +(defclass edit-control-events (gfw:event-dispatcher) ()) + +(defun truncate-text (str) + (subseq str 0 (min (length str) 5))) + +(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit) time) + (declare (ignore time)) + (format t "gained focus: ~a...~%" (truncate-text (gfw:text ctrl)))) + +(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit) time) + (declare (ignore time)) + (format t "lost focus: ~a...~%" (truncate-text (gfw:text ctrl)))) + +(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit) time) + (declare (ignore time)) + (format t "modified: ~a...~%" (truncate-text (gfw:text ctrl)))) + (defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* :dispatcher (make-instance 'dialog-events) @@ -135,6 +152,7 @@ :style '(:horizontal)) :style style :text title)) + (edit-disp (make-instance 'edit-control-events)) (left-panel (make-instance 'gfw:panel :layout (make-instance 'gfw:flow-layout :spacing 4 @@ -145,6 +163,7 @@ :parent left-panel)) (name-edit (make-instance 'gfw:edit :text "WWWWWWWWWWWWWWWWWWWWWWWW" + :dispatcher edit-disp :parent left-panel)) (serial-label (make-instance 'gfw:label :text "Serial Number:" @@ -152,6 +171,7 @@ (serial-edit (make-instance 'gfw:edit :style '(:read-only) :text "323K DSKL3 DSKE23" + :dispatcher edit-disp :parent left-panel)) (pw-label (make-instance 'gfw:label :text "Password:" @@ -159,6 +179,7 @@ (pw-edit (make-instance 'gfw:edit :style '(:mask-characters) :text "WWWWWWWWWWWWWWWWWWWWWWWW" + :dispatcher edit-disp :parent left-panel)) (desc-label (make-instance 'gfw:label :text "Description:" @@ -166,6 +187,7 @@ (desc-edit (make-instance 'gfw:edit :style '(:multi-line :auto-hscroll :auto-vscroll :vertical-scrollbar :want-return) :text (format nil "WWWWWWWWWWWWWWWWWWWWWWWW~%W~%W~%W~%W~%W") + :dispatcher edit-disp :parent left-panel)) (btn-panel (make-instance 'gfw:panel :layout (make-instance 'gfw:flow-layout Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Jun 28 17:44:07 2006 @@ -271,6 +271,17 @@ (defconstant +em-setimestatus+ #x00D8) (defconstant +em-getimestatus+ #x00D9) +(defconstant +en-setfocus+ #x0100) +(defconstant +en-killfocus+ #x0200) +(defconstant +en-change+ #x0300) +(defconstant +en-update+ #x0400) +(defconstant +en-errspace+ #x0500) +(defconstant +en-maxtext+ #x0501) +(defconstant +en-hscroll+ #x0601) +(defconstant +en-vscroll+ #x0602) +(defconstant +en-align-ltr-ec+ #x0700) +(defconstant +en-align-rtl-ec+ #x0701) + (defconstant +es-left+ #x0000) (defconstant +es-center+ #x0001) (defconstant +es-right+ #x0002) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed Jun 28 17:44:07 2006 @@ -118,6 +118,15 @@ (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed"))) +(defun dispatch-notification (widget wparam-hi) + (let ((disp (dispatcher widget)) + (time (event-time (thread-context)))) + (case wparam-hi + (0 (event-select disp widget time (gfs:make-rectangle))) ; FIXME: debug + (#.gfs::+en-killfocus+ (event-focus-loss disp widget time)) + (#.gfs::+en-setfocus+ (event-focus-gain disp widget time)) + (#.gfs::+en-update+ (event-modify disp widget time))))) + ;;; ;;; process-message methods ;;; @@ -156,14 +165,10 @@ ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t - (let ((w (get-widget tc (cffi:make-pointer lparam)))) - (if (null w) - (warn 'gfs:toolkit-warning :detail "no object for hwnd") - (unless (null (dispatcher w)) - (event-select (dispatcher w) - w - (event-time tc) - (gfs:make-rectangle))))))) ; FIXME + (let ((widget (get-widget tc (cffi:make-pointer lparam)))) + (when (and widget (dispatcher widget)) + ; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) + (dispatch-notification widget wparam-hi))))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0)