graphic-forms-cvs March 2006

graphic-forms-cvs@common-lisp.net

2 participants
62 discussions

[graphic-forms-cvs] r44 - in trunk: . src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 16 Mar '06

16 Mar '06

Author: junrue Date: Wed Mar 15 20:24:52 2006 New Revision: 44 Added: trunk/src/tests/uitoolkit/windlg.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented thread context cleanup; implemented +style-popup+ window style; implemented draw-filled-rectangle method Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Mar 15 20:24:52 2006 @@ -53,4 +53,5 @@ (:file "layout-unit-tests") (:file "hello-world") (:file "event-tester") - (:file "layout-tester"))))))))) + (:file "layout-tester") + (:file "windlg"))))))))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Wed Mar 15 20:24:52 2006 @@ -33,38 +33,35 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defparameter *hellowin* nil) - -(defun exit-hello-world () - (let ((w *hellowin*)) - (setf *hellowin* nil) - (gfi:dispose w)) - (gfw:shutdown 0)) - (defclass hellowin-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((d hellowin-events) widget time) (declare (ignore widget time)) - (exit-hello-world)) + (gfw:shutdown 0)) (defmethod gfw:event-paint ((d hellowin-events) window time gc rect) - (declare (ignorable window time rect)) + (declare (ignore window time rect)) + (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) + :size (gfw:client-size window))) + (setf (gfg:background-color gc) gfg:+color-white+) + (gfg:draw-filled-rectangle gc rect) (setf (gfg:background-color gc) gfg:+color-red+) (setf (gfg:foreground-color gc) gfg:+color-green+) (gfg:draw-text gc "Hello World!" (gfi:make-point))) (defun exit-fn (disp item time rect) (declare (ignorable disp item time rect)) - (exit-hello-world)) + (gfw:shutdown 0)) (defun run-hello-world-internal () - (let ((menubar nil)) - (setf *hellowin* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) - (gfw:realize *hellowin* nil :style-workspace) + (let ((menubar nil) + (window nil)) + (setf window (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) + (gfw:realize window nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) - (setf (gfw:menu-bar *hellowin*) menubar) - (gfw:show *hellowin* t))) + (setf (gfw:menu-bar window) menubar) + (gfw:show window t))) (defun run-hello-world () (gfw:startup "Hello World" #'run-hello-world-internal)) Added: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed Mar 15 20:24:52 2006 @@ -0,0 +1,88 @@ +;;;; +;;;; windlg.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) + +(defclass main-win-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((d main-win-events) window time) + (declare (ignore time)) + (gfi:dispose window) + (gfw:shutdown 0)) + +(defclass test-win-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((d test-win-events) window time) + (declare (ignore time)) + (gfi:dispose window)) + +(defmethod gfw:event-paint ((d test-win-events) window time gc rect) + (declare (ignore time)) + (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) + :size (gfw:client-size window))) + (setf (gfg:background-color gc) gfg:+color-white+) + (gfg:draw-filled-rectangle gc rect)) + +(defun create-borderless-win ()) + +(defun create-miniframe-win ()) + +(defun create-popup-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-win-events)))) + (gfw:realize window nil :style-popup) + (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfi:make-size :width 75 :height 125)) + (setf (gfw:text window) "Popup") + (gfw:show window t))) + +(defun exit-callback (disp item time rect) + (declare (ignore disp item time rect)) + (gfw:shutdown 0)) + +(defun run-windlg-internal () + (let ((menubar nil) + (window nil)) + (setf window (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) + (gfw:realize window nil :style-workspace) + (setf menubar (gfw:defmenusystem ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-callback))) + (:item "&Windows" + :submenu ((:item "&Borderless" :callback #'create-borderless-win) + (:item "&Mini Frame" :callback #'create-miniframe-win) + (:item "&Popup" :callback #'create-popup-win)))))) + (setf (gfw:menu-bar window) menubar) + (gfw:show window t))) + +(defun run-windlg () + (gfw:startup "Window/Dialog Tester" #'run-windlg-internal)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Wed Mar 15 20:24:52 2006 @@ -60,6 +60,28 @@ (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb))) +(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfi:rectangle)) + (if (gfi:disposed-p gc) + (error 'gfi:disposed-error)) + (let ((hdc (gfi:handle gc)) + (pnt (gfi:location rect)) + (size (gfi: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 (gfi:point-y pnt)) + (setf gfs::left (gfi:point-x pnt)) + (setf gfs::bottom (+ (gfi:point-y pnt) (gfi:size-height size))) + (setf gfs::right (+ (gfi:point-x pnt) (gfi:size-width size))) + (gfs::ext-text-out hdc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::+eto-opaque+ + rect-ptr + "" + 0 + (cffi:null-pointer)))))) + (defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point)) (if (gfi:disposed-p gc) (error 'gfi:disposed-error)) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Wed Mar 15 20:24:52 2006 @@ -93,6 +93,18 @@ (params LPTR)) (defcfun + ("ExtTextOutA" ext-text-out) + BOOL + (hdc HANDLE) + (x INT) + (y INT) + (options UINT) + (rect LPRECT) + (str :string) + (count UINT) + (dx LPTR)) + +(defcfun ("GetBkColor" get-bk-color) COLORREF (hdc HANDLE)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Mar 15 20:24:52 2006 @@ -173,6 +173,15 @@ (defconstant +dt-hideprefix+ #x00100000) (defconstant +dt-prefixonly+ #x00200000) +(defconstant +eto-opaque+ #x0002) +(defconstant +eto-clipped+ #x0004) +(defconstant +eto-glyph_index+ #x0010) +(defconstant +eto-rtlreading+ #x0080) +(defconstant +eto-numericslocal+ #x0400) +(defconstant +eto-numericslatin+ #x0800) +(defconstant +eto-ignorelanguage+ #x1000) +(defconstant +eto-pdy+ #x2000) + (defconstant +ga-parent+ 1) (defconstant +ga-root+ 2) (defconstant +ga-rootowner+ 3) @@ -634,6 +643,7 @@ (defconstant +ws-minimizebox+ #x00020000) (defconstant +ws-maximizebox+ #x00010000) (defconstant +ws-popupwindow+ #x80880000) +(defconstant +ws-overlappedwindow+ #x00CF0000) (defconstant +ws-ex-dlgmodalframe+ #x00000001) (defconstant +ws-ex-noparentnotify+ #x00000004) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Wed Mar 15 20:24:52 2006 @@ -56,6 +56,9 @@ #+clisp (defun thread-context () *the-thread-context*) +#+clisp (defun dispose-thread-context () + (setf *the-thread-context* nil)) + #+lispworks (defun thread-context () (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) (when (null tc) @@ -63,6 +66,9 @@ (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc)) tc)) +#+lispworks (defun dispose-thread-context () + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) + (defmethod call-child-visitor-func ((tc thread-context) parent child) "Call the closure at the top of the child window visitor function stack." (let ((fn (first (slot-value tc 'child-visitor-stack)))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Wed Mar 15 20:24:52 2006 @@ -49,7 +49,8 @@ (run-default-message-loop))))) (defun shutdown (exit-code) - (gfs::post-quit-message exit-code)) + (gfs::post-quit-message exit-code) + (dispose-thread-context)) (defun clear-all (w) (let ((count (gfw:item-count w))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed Mar 15 20:24:52 2006 @@ -154,53 +154,50 @@ (declare (ignore win)) (let ((std-flags 0) (ex-flags 0)) - (mapcar #'(lambda (sym) - (cond - ;; styles that can be combined - ;; - ((eq sym :style-hscroll) - (setf std-flags (logior std-flags gfs::+ws-hscroll+))) - ((eq sym :style-max) - (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :style-min) - (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :style-resize) - (setf std-flags (logior std-flags gfs::+ws-thickframe+))) - ((eq sym :style-sysmenu) - (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :style-title) - (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :style-top) - (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) - ((eq sym :style-vscroll) - (setf std-flags (logior std-flags gfs::+ws-vscroll+))) - - ;; pre-packaged combinations of window styles - ;; - ((eq sym :style-no-title) - (setf std-flags 0) - (setf ex-flags gfs::+ws-ex-windowedge+)) - ((eq sym :style-splash) - (setf std-flags (logior gfs::+ws-overlapped+ - gfs::+ws-popup+ - gfs::+ws-clipsiblings+ - gfs::+ws-border+ - gfs::+ws-visible+)) - (setf ex-flags 0)) - ((eq sym :style-tool) - (setf std-flags 0) - (setf ex-flags gfs::+ws-ex-palettewindow+)) - ((eq sym :style-workspace) - (setf std-flags (logior gfs::+ws-overlapped+ - gfs::+ws-clipsiblings+ - gfs::+ws-clipchildren+ - gfs::+ws-caption+ - gfs::+ws-sysmenu+ - gfs::+ws-thickframe+ - gfs::+ws-minimizebox+ - gfs::+ws-maximizebox+)) - (setf ex-flags 0)))) - (flatten style)) + (mapc #'(lambda (sym) + (cond + ;; styles that can be combined + ;; + ((eq sym :style-hscroll) + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) +#| + ((eq sym :style-max) + (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) + ((eq sym :style-min) + (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) + ((eq sym :style-resize) + (setf std-flags (logior std-flags gfs::+ws-thickframe+))) + ((eq sym :style-sysmenu) + (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) + ((eq sym :style-title) + (setf std-flags (logior std-flags gfs::+ws-caption+))) + ((eq sym :style-top) + (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) +|# + ((eq sym :style-vscroll) + (setf std-flags (logior std-flags gfs::+ws-vscroll+))) + + ;; pre-packaged combinations of window styles + ;; + ((eq sym :style-popup) + (setf std-flags (logior gfs::+ws-popupwindow+ gfs::+ws-caption+)) + (setf ex-flags gfs::+ws-ex-toolwindow+)) + ((eq sym :style-splash) + (setf std-flags (logior gfs::+ws-overlapped+ + gfs::+ws-popup+ + gfs::+ws-clipsiblings+ + gfs::+ws-border+ + gfs::+ws-visible+)) + (setf ex-flags 0)) + ((eq sym :style-tool) + (setf std-flags 0) + (setf ex-flags gfs::+ws-ex-palettewindow+)) + ((eq sym :style-workspace) + (setf std-flags (logior gfs::+ws-overlappedwindow+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+)) + (setf ex-flags 0)))) + (flatten style)) (values std-flags ex-flags))) (defmethod gfi:dispose ((win window)) @@ -300,3 +297,9 @@ (let ((sz (gfi:make-size))) (outer-size win sz) sz)) + +(defmethod text ((win window)) + (get-widget-text win)) + +(defmethod (setf text) (str (win window)) + (set-widget-text win str))

1 0

[graphic-forms-cvs] r43 - in trunk/docs: manual website
by junrue＠common-lisp.net 15 Mar '06

15 Mar '06

Author: junrue Date: Wed Mar 15 14:40:07 2006 New Revision: 43 Added: trunk/docs/manual/glossary.texinfo trunk/docs/manual/overview.texinfo trunk/docs/manual/packages.texinfo trunk/docs/manual/reference.texinfo trunk/docs/website/docs.html trunk/docs/website/download.html trunk/docs/website/screenshots.html Removed: trunk/docs/manual/graphic-forms-reference.texinfo Modified: trunk/docs/manual/Makefile trunk/docs/website/index.html trunk/docs/website/style.css Log: documentation updates Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Wed Mar 15 14:40:07 2006 @@ -32,15 +32,12 @@ # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # -# -# TODO: upgrade MSYS version of makeinfo so "--css-include=style.css" works -# docs: - makeinfo --html graphic-forms-reference.texinfo + makeinfo --html --css-include=style.css reference.texinfo clean: find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \; - rm -rf graphic-forms-reference + rm -rf reference # # TODO: implement an upload target Added: trunk/docs/manual/glossary.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/glossary.texinfo Wed Mar 15 14:40:07 2006 @@ -0,0 +1,29 @@ + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@c =================================================================== +@c CHAPTER: Glossary + +@node Glossary +@chapter Glossary + +Terms and definitions. + +@table @samp +@item control +A control is a thing. + +@item dialog +A dialog is something else. + +@item menu +A collection of menu items. + +@end table + +@cindex control +@cindex dialog +@cindex menu Added: trunk/docs/manual/overview.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/overview.texinfo Wed Mar 15 14:40:07 2006 @@ -0,0 +1,79 @@ + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@c =================================================================== +@c CHAPTER: Overview + +@node Overview +@chapter Overview + +Graphic-Forms is a user interface library implemented in Common Lisp +focusing on the Windows@registeredsymbol{} platform. Graphic-Forms is +licensed under the terms of the BSD License. + +Graphic-Forms has two primary goals: + +@itemize @bullet +@item +in the short term, provide a toolkit encapsulating the underlying +window system primitives, custom controls and dialogs, and +platform-specific features + +@item +in the longer-term, implement an application framework on +top of the toolkit -- as an analogy, consider the relationship between +SWT and JFace in the Eclipse framework. +@end itemize + +Support for multiple Common Lisp implementations is planned; see the +project website for up-to-date information on supported vendors and +current known issues. + +Why implement another UI toolkit? The niche for Graphic-Forms is that +it emphasizes the use of Windows@registeredsymbol{} features without +comprising functionality due to portability constraints. Applications +that need portability across windowing systems are already served by +projects such as McCLIM and LTK in the open-source world or the +toolkits provided by commercial vendors. Or you might consider helping +new portable UI projects such as wxCL. This project is aimed +specifically at Windows@registeredsymbol{} developers. + +The remainder of this chapter provides basic information for +programmers that want to use Graphic-Forms in their projects as well +as maintainers/contributors. + +The main project website: @* +@indicateurl{http://common-lisp.net/project/graphic-forms} + + +@section Dependencies + +The libraries that Graphic-Forms relies upon. + + +@section Mailing Lists and Bug Reports + +Announcements mailing list: @* +@indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-announce} + +Developer mailing list (for both users and maintainers): @* +@indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel} + +Source control log mailing list: @* +@indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-cvs} + +The bug tracking system: @* +@indicateurl{http://sourceforge.net/tracker/?group_id=20959&atid=120959} + + +@section Submitting Patches + +Please use the SourceForge patch tracking mechanism to contribute patches: + + +@section Running the Library Tests + +How to run unit-tests and ad-hoc tests. Added: trunk/docs/manual/packages.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/packages.texinfo Wed Mar 15 14:40:07 2006 @@ -0,0 +1,28 @@ + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@c =================================================================== +@c CHAPTER: Packages + +@node Packages +@chapter Packages + +General comments about the packages. + +@section Intrinsics +@cindex Intrinsics Package + +@section Graphics +@cindex Graphics Package + +@section System +@cindex System Package + +@section Tests +@cindex Tests Package + +@section Widgets +@cindex Widgets Package Added: trunk/docs/manual/reference.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/reference.texinfo Wed Mar 15 14:40:07 2006 @@ -0,0 +1,160 @@ +\input texinfo @c -*- Mode: Texinfo; Mode: auto-fill -*- +@c %**start of header + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@setfilename reference.info +@settitle Graphic-Forms Programming Reference +@exampleindent 2 + +@c ============================= Macros ============================= + +@macro Function {args} +@defun \args\ +@end defun +@end macro + +@macro Macro {args} +@defmac \args\ +@end defmac +@end macro + +@macro Accessor {args} +@deffn {Accessor} \args\ +@end deffn +@end macro + +@macro GenericFunction {args} +@deffn {Generic Function} \args\ +@end deffn +@end macro + +@macro Variable {args} +@defvr {Special Variable} \args\ +@end defvr +@end macro + +@macro Condition {args} +@deftp {Condition Type} \args\ +@end deftp +@end macro + +@macro GFI +@acronym{GFW} +@end macro + +@macro GFG +@acronym{GFW} +@end macro + +@macro GFS +@acronym{GFW} +@end macro + +@macro GFW +@acronym{GFW} +@end macro + +@macro impnote {text} +@quotation +@strong{Implementor's note:} @emph{\text\} +@end quotation +@end macro + +@c Info "requires" that x-refs end in a period or comma, or ) in the +@c case of @pxref. So the following implements that requirement for +@c the "See also" subheadings that permeate this manual, but only in +@c Info mode. +@ifinfo +@macro seealso {name} +@ref{\name\}. +@end macro +@end ifinfo + +@ifnotinfo +@alias seealso = ref +@end ifnotinfo + +@c ==========================End Macros ============================= + +@c Coallesce all the index types into one master index. +@syncodeindex fn cp +@syncodeindex ky cp +@syncodeindex tp cp +@syncodeindex vr cp + +@copying +Copyright @copyright{} 2006, Jack D. Unrue <jdunrue at gmail.com> @* + +@quotation +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. + +@sc{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 +DISCLAIMED. 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.} +@end quotation +@end copying +@c %**end of header + +@titlepage +@title Graphic-Forms Programming Reference +@c @subtitle Version 0.2.0 +@c @author Jack D. Unrue + +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@ifnottex +@node Top +@top Graphic-Forms Programming Reference +@insertcopying +@end ifnottex + +@majorheading Major Topics List + +@menu +* Overview:: Notes on using Graphic-Forms and how to get help. +* Glossary:: Terms and definitions. +* Packages:: Summary of the library packages. +* Master Index:: +@end menu + +@contents + +@include overview.texinfo +@include glossary.texinfo +@include packages.texinfo + +@c =================================================================== +@c Index + +@node Master Index +@unnumbered Master Index +@printindex cp + +@bye Added: trunk/docs/website/docs.html ============================================================================== --- (empty file) +++ trunk/docs/website/docs.html Wed Mar 15 14:40:07 2006 @@ -0,0 +1,24 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + +<head> + <title>Graphic-Forms Documentation</title> + <link rel="stylesheet" type="text/css" href="style.css"> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> +</head> + +<body> + + <h3><a href="reference/index.html">Programming Reference</a></h3> + + <h3>FAQ</h3> + + <h3>Articles</h3> + + <div class="footer"> + <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> + Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + </div> + +</body> +</html> Added: trunk/docs/website/download.html ============================================================================== --- (empty file) +++ trunk/docs/website/download.html Wed Mar 15 14:40:07 2006 @@ -0,0 +1,38 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + +<head> + <title>Graphic-Forms Source Control</title> + <link rel="stylesheet" type="text/css" href="style.css"> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> +</head> + +<body> + + <p>Graphic-Forms is distributed in source code form. Please choose from + one of the following options: + + <ul> + <li> + <a href="http://sourceforge.net/project/showfiles.php?group_id=1355">Download</a> + a release tarball. + </li> + <li> + <a href="http://common-lisp.net/faq.shtml">Download</a> + the current development tree via anonymous Subversion. + Note: <i><project-name></i> is <i>graphic-forms</i>. + </li> + <li> + <a href="http://common-lisp.net/websvn/listing.php?repname=graphic-forms&path=%2F&sc…">Browse</a> + the Subversion repository. + </li> + </ul> + </p> + + <div class="footer"> + <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> + Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + </div> + +</body> +</html> Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Mar 15 14:40:07 2006 @@ -1,18 +1,27 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> -<head> -<title>Graphic-Forms project</title> - <link rel="stylesheet" type="text/css" href="style.css"> - <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> - </head> +<head> + <title>Graphic-Forms project</title> + <link rel="stylesheet" type="text/css" href="style.css"> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> +</head> - <body> +<body> <div class="header"> <h1>Graphic-Forms</h1> <h2>A user interface toolkit for the Windows® platform.</h2> </div> + <div class="NavBar"> + <a class="barfirst" href="http://awayrepl.blogspot.com/">News</a> + <a class="barcenter" href="screenshots.html">Screenshots</a> + <a class="barcenter" href="download.html">Download</a> + <a class="barcenter" href="docs.html">Documentation</a> + <a class="barlast" href="http://sourceforge.net/tracker/?group_id=1355&atid=101355">Bug Database</a> +</div> + + <h3>Introduction</h3> <p>Graphic-Forms is a user interface library implemented in @@ -44,45 +53,38 @@ in the open-source world or the toolkits provided by commercial vendors. Or you might consider helping new portable UI projects such as <a href="http://www.wxcl-project.org">wxCL</a>. <i>This - project</i> is aimed specifically at Windows® developers. + project</i> is aimed specifically at Windows® developers.</p> - <h3>Current Status</h3> + <h3>Status</h3> - <p>The Subversion repository will be populated with an initial code - drop in the near future. Additional documentation will be - made available at that time, as will screenshots.</p> + <p>The first release will be version 0.2.0 and should be + available shortly.</p> - <p>NOTE: This library is in the early implementation stage. Brave souls who + <p>This library is in the early implementation stage. Brave souls who experiment with the code should expect significant API and - behavior changes in the preliminary releases leading up to the 1.0 release.<p> + behavior changes in the preliminary releases leading up to the 1.0 release.</p> - <h3>Mailing Lists</h3> + <h3 id="mailinglists">Mailing Lists</h3> <ul> <li> <a href="http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel"> graphic-forms-devel</a><br>for both developers and users</li> <li> <a href="http://www.common-lisp.net/mailman/listinfo/graphic-forms-cvs"> - graphic-forms-cvs</a><br>CVS log feed</li> + graphic-forms-cvs</a><br>Subversion log feed</li> <li> <a href="http://www.common-lisp.net/mailman/listinfo/graphic-forms-announce"> graphic-forms-announce</a><br>for announcements</li> - </ul> - <h3>Download</h3> - - <p>This project has not released any files.</p> - - <h3>Revision Control</h3> - - <p>You can <a href="http://common-lisp.net/websvn/listing.php?repname=graphic-forms&path=%2F&sc…"> -browse the Subversion repository</a> or download the current development tree via - anonymous svn, as described <a href="http://common-lisp.net/faq.shtml">here</a>.</p> - - <div class="footer"> - Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> - </div> + <div class="footer"> + <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> + Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + </div> + + </body> </html> Added: trunk/docs/website/screenshots.html ============================================================================== --- (empty file) +++ trunk/docs/website/screenshots.html Wed Mar 15 14:40:07 2006 @@ -0,0 +1,20 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + +<head> + <title>Graphic-Forms Screenshots</title> + <link rel="stylesheet" type="text/css" href="style.css"> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> +</head> + +<body> + + <p>Screenshots coming soon...stay tuned!</p> + + <div class="footer"> + <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> + Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + </div> + +</body> +</html> Modified: trunk/docs/website/style.css ============================================================================== --- trunk/docs/website/style.css (original) +++ trunk/docs/website/style.css Wed Mar 15 14:40:07 2006 @@ -24,19 +24,24 @@ .footer a:link { font-weight:bold; color:#ffffff; - text-decoration:underline; } .footer a:visited { font-weight:bold; color:#ffffff; - text-decoration:underline; } -.footer a:hover { +:link.footerleft { font-weight:bold; - color:#002244; - text-decoration:underline; } + float: left; + color:#ffffff; +} + +:visited.footerleft { + font-weight:bold; + float: left; + color:#ffffff; +} .check {font-size: x-small; text-align:right;} @@ -52,3 +57,52 @@ .check a:hover { font-weight:bold; color:#000000; text-decoration:underline; } + +div.NavBar { + padding: 4px 0px 4px 0px; + float: right; + font-weight:bold; +} + +.barfirst { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; +} + +.barcenter { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; +} + +.barlast { + padding: 0px 5px 0px 5px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; +} + +:hover.barfirst { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; + background-color:#e4e4e4; +} + +:hover.barcenter { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; + background-color:#e4e4e4; +} + +:hover.barlast { + padding: 0px 5px 0px 5px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; + background-color:#e4e4e4; +}

1 0

[graphic-forms-cvs] r42 - trunk/docs/website
by junrue＠common-lisp.net 15 Mar '06

15 Mar '06

Author: junrue Date: Tue Mar 14 20:19:46 2006 New Revision: 42 Added: trunk/docs/website/style.css Log: check in stylesheet for project website Added: trunk/docs/website/style.css ============================================================================== --- (empty file) +++ trunk/docs/website/style.css Tue Mar 14 20:19:46 2006 @@ -0,0 +1,54 @@ + +.header { + font-size: medium; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 5px; + border-color:#002244; + padding: 1mm 1mm 1mm 5mm; +} + +.footer { + font-size: small; + font-style: italic; + text-align: right; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 2px; + border-color:#002244; + padding: 1mm 1mm 1mm 1mm; +} + +.footer a:link { + font-weight:bold; + color:#ffffff; + text-decoration:underline; +} + +.footer a:visited { + font-weight:bold; + color:#ffffff; + text-decoration:underline; +} + +.footer a:hover { + font-weight:bold; + color:#002244; + text-decoration:underline; } + +.check {font-size: x-small; + text-align:right;} + +.check a:link { font-weight:bold; + color:#a0a0ff; + text-decoration:underline; } + +.check a:visited { font-weight:bold; + color:#a0a0ff; + text-decoration:underline; } + +.check a:hover { font-weight:bold; + color:#000000; + text-decoration:underline; }

1 0

[graphic-forms-cvs] r41 - in trunk/src: . tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 15 Mar '06

15 Mar '06

Author: junrue Date: Tue Mar 14 19:18:51 2006 New Revision: 41 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp Log: implemented flow layout margins Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 14 19:18:51 2006 @@ -312,6 +312,7 @@ #:background-color #:background-pattern #:border-width + #:bottom-margin-of #:caret #:check #:check-all @@ -400,6 +401,7 @@ #:layout #:layout-of #:layout-p + #:left-margin-of #:lines-visible-p #:location #:lock @@ -431,6 +433,7 @@ #:replace-selection #:resizable-p #:retrieve-span + #:right-margin-of #:run-default-message-loop #:scroll #:select @@ -459,6 +462,7 @@ #:thumb-size #:tooltip-text #:top-index + #:top-margin-of #:traverse #:traverse-order #:trim-sizes Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Mar 14 19:18:51 2006 @@ -36,6 +36,7 @@ (defconstant +btn-text-before+ "Push Me") (defconstant +btn-text-after+ "Again!") (defconstant +label-text+ "Test Label") +(defconstant +margin-delta+ 4) (defconstant +spacing-delta+ 3) (defvar *widget-counter* 0) @@ -211,22 +212,102 @@ (incf (gfw:spacing-of layout) +spacing-delta+) (gfw:layout *layout-tester-win*))) +(defun enable-left-flow-margin-items (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (gfw:enable (gfw:item-at menu 0) (> (gfw:left-margin-of layout) 0)))) + +(defun enable-top-flow-margin-items (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (gfw:enable (gfw:item-at menu 0) (> (gfw:top-margin-of layout) 0)))) + +(defun enable-right-flow-margin-items (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (gfw:enable (gfw:item-at menu 0) (> (gfw:right-margin-of layout) 0)))) + +(defun enable-bottom-flow-margin-items (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (gfw:enable (gfw:item-at menu 0) (> (gfw:bottom-margin-of layout) 0)))) + +(defun inc-left-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (incf (gfw:left-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun inc-top-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (incf (gfw:top-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun inc-right-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (incf (gfw:right-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun inc-bottom-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (incf (gfw:bottom-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun dec-left-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (decf (gfw:left-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun dec-top-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (decf (gfw:top-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun dec-right-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (decf (gfw:right-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun dec-bottom-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (decf (gfw:bottom-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + (defun flow-mod-callback (disp menu time) (declare (ignore disp time)) (gfw:clear-all menu) (let ((it nil) - (margin-menu (gfw:defmenusystem ((:item "Top" - :submenu ((:item "Decrease") - (:item "Increase"))) - (:item "Left" - :submenu ((:item "Decrease") - (:item "Increase"))) + (margin-menu (gfw:defmenusystem ((:item "Left" + :callback #'enable-left-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-left-flow-margin) + (:item "Increase" + :callback #'inc-left-flow-margin))) + (:item "Top" + :callback #'enable-top-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-top-flow-margin) + (:item "Increase" + :callback #'inc-top-flow-margin))) (:item "Right" - :submenu ((:item "Decrease") - (:item "Increase"))) + :callback #'enable-right-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-right-flow-margin) + (:item "Increase" + :callback #'inc-right-flow-margin))) (:item "Bottom" - :submenu ((:item "Decrease") - (:item "Increase")))))) + :callback #'enable-bottom-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-bottom-flow-margin) + (:item "Increase" + :callback #'inc-bottom-flow-margin)))))) (orient-menu (gfw:defmenusystem ((:item "Horizontal" :callback #'set-flow-horizontal) (:item "Vertical" @@ -257,7 +338,8 @@ :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) :layout (make-instance 'gfw:flow-layout - :spacing +spacing-delta+))) + :spacing +spacing-delta+ + :margins +margin-delta+))) (gfw:realize *layout-tester-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" 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 Tue Mar 14 19:18:51 2006 @@ -191,3 +191,41 @@ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test11 + ;; orient: horizontal + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-instance 'gfw:flow-layout + :style '(:horizontal) + :left-margin 3 + :top-margin 3)) + (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) + (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) + (assert-equal 63 (gfi:size-width size)) + (assert-equal 13 (gfi:size-height size)) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test12 + ;; orient: vertical + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-instance 'gfw:flow-layout + :style '(:vertical) + :right-margin 3 + :bottom-margin 3)) + (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) + (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) + (assert-equal 23 (gfi:size-width size)) + (assert-equal 33 (gfi:size-height size)) + (validate-layout-rects data expected-rects))) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Tue Mar 14 19:18:51 2006 @@ -55,26 +55,28 @@ (incf total (gfi:size-width size)) (if (< max (gfi:size-height size)) (setf max (gfi:size-height size)))))))) - (if (< (spacing-of layout) 0) - (error 'gfs:toolkit-error :detail "layout spacing must be non-negative")) (unless (null kids) (incf total (* (spacing-of layout) (1- (length kids))))) (if vert-orient - (gfi:make-size :width max :height total) - (gfi:make-size :width total :height max)))) + (progn + (incf max (+ (left-margin-of layout) (right-margin-of layout))) + (incf total (+ (top-margin-of layout) (bottom-margin-of layout))) + (gfi: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))) + (gfi:make-size :width total :height max))))) (defun flow-container-layout (layout visible kids width-hint height-hint) (let* ((flows nil) (curr-flow nil) - (max-size -1) - (next-coord 0) - (wrap-coord 0) (spacing (spacing-of layout)) (style (style-of layout)) (vert-orient (find :vertical style)) - (wrap (find :wrap style))) - (if (< spacing 0) - (error 'gfs:toolkit-error :detail "layout spacing must be non-negative")) + (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 (gfi:make-point))) @@ -83,10 +85,13 @@ (progn (when (and wrap (>= height-hint 0) - (> (+ next-coord (gfi:size-height size)) height-hint)) + (> (+ next-coord + (gfi:size-height size) + (bottom-margin-of layout)) + height-hint)) (push (reverse curr-flow) flows) (setf curr-flow nil) - (setf next-coord 0) + (setf next-coord (top-margin-of layout)) (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) (setf (gfi:point-x pnt) wrap-coord) @@ -97,10 +102,13 @@ (progn (when (and wrap (>= width-hint 0) - (> (+ next-coord (gfi:size-width size)) width-hint)) + (> (+ next-coord + (gfi:size-width size) + (right-margin-of layout)) + width-hint)) (push (reverse curr-flow) flows) (setf curr-flow nil) - (setf next-coord 0) + (setf next-coord (left-margin-of layout)) (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) (setf (gfi:point-x pnt) next-coord) @@ -125,9 +133,22 @@ (with-children (win kids) (flow-container-layout layout (visible-p win) kids width-hint height-hint))) -(defmethod initialize-instance :after ((layout flow-layout) &key style) +(defmethod initialize-instance :after ((layout flow-layout) + &key style margins horz-margins vert-margins + &allow-other-keys) (unless (listp style) (setf style (list style))) (if (and (null (find :horizontal style)) (null (find :vertical style))) (push :horizontal style)) - (setf (style-of layout) style)) + (setf (style-of layout) style) + (unless (null margins) + (setf (left-margin-of layout) margins) + (setf (right-margin-of layout) margins) + (setf (top-margin-of layout) margins) + (setf (bottom-margin-of layout) margins)) + (unless (null horz-margins) + (setf (left-margin-of layout) horz-margins) + (setf (right-margin-of layout) horz-margins)) + (unless (null vert-margins) + (setf (top-margin-of layout) vert-margins) + (setf (bottom-margin-of layout) vert-margins))) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Tue Mar 14 19:18:51 2006 @@ -44,5 +44,21 @@ ((spacing :accessor spacing-of :initarg :spacing + :initform 0) + (left-margin + :accessor left-margin-of + :initarg :left-margin + :initform 0) + (top-margin + :accessor top-margin-of + :initarg :top-margin + :initform 0) + (right-margin + :accessor right-margin-of + :initarg :right-margin + :initform 0) + (bottom-margin + :accessor bottom-margin-of + :initarg :bottom-margin :initform 0)) (:documentation "Window children are arranged in a row or column."))

1 0

[graphic-forms-cvs] r40 - in trunk/src: . tests/uitoolkit uitoolkit/system uitoolkit/widgets
by junrue＠common-lisp.net 14 Mar '06

14 Mar '06

Author: junrue Date: Tue Mar 14 01:20:02 2006 New Revision: 40 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented widget and menu item enabling/disabling; implemented flow layout spacing Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 14 01:20:02 2006 @@ -448,6 +448,7 @@ #:show-selection #:shutdown #:size + #:spacing-of #:startup #:step-increment #:style-of Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Mar 14 01:20:02 2006 @@ -36,6 +36,7 @@ (defconstant +btn-text-before+ "Push Me") (defconstant +btn-text-after+ "Again!") (defconstant +label-text+ "Test Label") +(defconstant +spacing-delta+ 3) (defvar *widget-counter* 0) @@ -157,7 +158,7 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) -(defun check-flow-orient-item (disp menu time) +(defun check-flow-orient-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout))) @@ -190,6 +191,26 @@ (setf (gfw:style-of layout) (push :wrap style))) (gfw:layout *layout-tester-win*))) +(defun enable-flow-spacing-items (disp menu time) + (declare (ignore disp time)) + (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) + (gfw:enable (gfw:item-at menu 0) (> spacing 0)))) + +(defun decrease-flow-spacing (disp item time rect) + (declare (ignore disp item time rect)) + (let* ((layout (gfw:layout-of *layout-tester-win*)) + (spacing (gfw:spacing-of layout))) + (unless (zerop spacing) + (decf spacing +spacing-delta+) + (setf (gfw:spacing-of layout) spacing) + (gfw:layout *layout-tester-win*)))) + +(defun increase-flow-spacing (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (incf (gfw:spacing-of layout) +spacing-delta+) + (gfw:layout *layout-tester-win*))) + (defun flow-mod-callback (disp menu time) (declare (ignore disp time)) (gfw:clear-all menu) @@ -210,11 +231,13 @@ :callback #'set-flow-horizontal) (:item "Vertical" :callback #'set-flow-vertical)))) - (spacing-menu (gfw:defmenusystem ((:item "Decrease") - (:item "Increase"))))) + (spacing-menu (gfw:defmenusystem ((:item "Decrease" + :callback #'decrease-flow-spacing) + (:item "Increase" + :callback #'increase-flow-spacing))))) (gfw:append-submenu menu "Margin" margin-menu nil) - (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item) - (gfw:append-submenu menu "Spacing" spacing-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*)))))) @@ -233,7 +256,8 @@ (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) - :layout (make-instance 'gfw:flow-layout))) + :layout (make-instance 'gfw:flow-layout + :spacing +spacing-delta+))) (gfw:realize *layout-tester-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" 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 Tue Mar 14 01:20:02 2006 @@ -53,6 +53,8 @@ (define-test flow-layout-test1 ;; orient: horizontal ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: unrestricted width and height ;; kids: uniform ;; @@ -67,6 +69,8 @@ (define-test flow-layout-test2 ;; orient: vertical ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: unrestricted width and height ;; kids: uniform ;; @@ -81,6 +85,8 @@ (define-test flow-layout-test3 ;; orient: horizontal ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: restricted width, unrestricted height ;; kids: uniform ;; @@ -92,6 +98,8 @@ (define-test flow-layout-test4 ;; orient: vertical ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: unrestricted width, restricted height ;; kids: uniform ;; @@ -103,6 +111,8 @@ (define-test flow-layout-test5 ;; orient: horizontal ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: restricted width and height ;; kids: uniform ;; @@ -114,6 +124,8 @@ (define-test flow-layout-test6 ;; orient: vertical ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: restricted width and height ;; kids: uniform ;; @@ -121,3 +133,61 @@ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test7 + ;; orient: horizontal + ;; wrap: disabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal))) + (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) + (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) + (assert-equal 68 (gfi:size-width size)) + (assert-equal 10 (gfi:size-height size)) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test8 + ;; orient: vertical + ;; wrap: disabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical))) + (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) + (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) + (assert-equal 20 (gfi:size-width size)) + (assert-equal 38 (gfi:size-height size)) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test9 + ;; orient: horizontal + ;; wrap: enabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal :wrap))) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18)) + (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test10 + ;; orient: vertical + ;; wrap: enabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical :wrap))) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) + (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) + (validate-layout-rects data expected-rects))) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Mar 14 01:20:02 2006 @@ -128,6 +128,19 @@ (hwnd HANDLE)) (defcfun + ("EnableMenuItem" enable-menu-item) + BOOL + (hmenu HANDLE) + (id UINT) + (flag UINT)) + +(defcfun + ("EnableWindow" enable-window) + BOOL + (hwnd HANDLE) + (enable BOOL)) + +(defcfun ("EndDeferWindowPos" end-defer-window-pos) BOOL (posinfo HANDLE)) @@ -303,6 +316,11 @@ (erase BOOL)) (defcfun + ("IsWindowEnabled" is-window-enabled) + BOOL + (hwnd HANDLE)) + +(defcfun ("IsWindowVisible" is-window-visible) BOOL (hwnd HANDLE)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Tue Mar 14 01:20:02 2006 @@ -55,6 +55,10 @@ (incf total (gfi:size-width size)) (if (< max (gfi:size-height size)) (setf max (gfi:size-height size)))))))) + (if (< (spacing-of layout) 0) + (error 'gfs:toolkit-error :detail "layout spacing must be non-negative")) + (unless (null kids) + (incf total (* (spacing-of layout) (1- (length kids))))) (if vert-orient (gfi:make-size :width max :height total) (gfi:make-size :width total :height max)))) @@ -65,9 +69,12 @@ (max-size -1) (next-coord 0) (wrap-coord 0) + (spacing (spacing-of layout)) (style (style-of layout)) (vert-orient (find :vertical style)) (wrap (find :wrap style))) + (if (< spacing 0) + (error 'gfs:toolkit-error :detail "layout spacing must be non-negative")) (loop for kid in kids do (let ((size (preferred-size kid -1 -1)) (pnt (gfi:make-point))) @@ -80,13 +87,13 @@ (push (reverse curr-flow) flows) (setf curr-flow nil) (setf next-coord 0) - (incf wrap-coord max-size) + (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) (setf (gfi:point-x pnt) wrap-coord) (setf (gfi:point-y pnt) next-coord) (if (< max-size (gfi:size-width size)) (setf max-size (gfi:size-width size))) - (incf next-coord (gfi:size-height size))) + (incf next-coord (+ (gfi:size-height size) spacing))) (progn (when (and wrap (>= width-hint 0) @@ -94,13 +101,13 @@ (push (reverse curr-flow) flows) (setf curr-flow nil) (setf next-coord 0) - (incf wrap-coord max-size) + (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) (setf (gfi:point-x pnt) next-coord) (setf (gfi:point-y pnt) wrap-coord) (if (< max-size (gfi:size-height size)) (setf max-size (gfi:size-height size))) - (incf next-coord (gfi:size-width size)))) + (incf next-coord (+ (gfi:size-width size) spacing)))) (push (cons kid (make-instance 'gfi:rectangle :size size :location pnt)) curr-flow)))) (unless (null curr-flow) (push (reverse curr-flow) flows)) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Tue Mar 14 01:20:02 2006 @@ -40,5 +40,9 @@ :initform nil)) (:documentation "Subclasses implement layout strategies on behalf of window objects.")) -(defclass flow-layout (layout-manager) () +(defclass flow-layout (layout-manager) + ((spacing + :accessor spacing-of + :initarg :spacing + :initform 0)) (:documentation "Window children are arranged in a row or column.")) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Tue Mar 14 01:20:02 2006 @@ -37,6 +37,30 @@ ;;; helper functions ;;; +(defun get-menuitem-state (hmenu mid) + (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type + gfs::state gfs::id gfs::hsubmenu + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+)) + (setf gfs::type 0) + (setf gfs::state 0) + (setf gfs::id mid) + (setf gfs::hsubmenu (cffi:null-pointer)) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata (cffi:null-pointer)) + (setf gfs::cch 0) + (setf gfs::hbmpitem (cffi:null-pointer)) + (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr)) + (error 'gfs:win32-error :detail "get-menu-item-info failed")) + gfs::state))) + (defun get-menuitem-text (hmenu mid) (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type @@ -58,7 +82,7 @@ (setf gfs::cch 0) (setf gfs::hbmpitem (cffi:null-pointer)) (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr)) - (error 'gfs::win32-error :detail "get-menu-item-info failed")) + (error 'gfs:win32-error :detail "get-menu-item-info failed")) (incf gfs::cch) (let ((str-ptr (cffi:foreign-alloc :char :count gfs::cch)) (result "")) @@ -66,7 +90,7 @@ (progn (setf gfs::tdata str-ptr) (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr)) - (error 'gfs::win32-error :detail "get-menu-item-info failed")) + (error 'gfs:win32-error :detail "get-menu-item-info failed")) (setf result (cffi:foreign-string-to-lisp str-ptr)) (cffi:foreign-free str-ptr))) result)))) @@ -184,9 +208,17 @@ (setf (item-id it) 0) (setf (slot-value it 'gfi:handle) nil))) -(defmethod enable ((item menu-item) flag) - ;; FIXME: need to implement -) +(defmethod enable ((it menu-item) flag) + (let ((bits 0)) + (if flag + (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-enabled+)) + (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-grayed+))) + (gfs::enable-menu-item (gfi:handle it) (item-id it) bits))) + +(defmethod enabled-p ((it menu-item)) + (= (logand (get-menuitem-state (gfi:handle it) (item-id it)) + gfs::+mfs-enabled+) + gfs::+mfs-enabled+)) (defmethod item-owner ((it menu-item)) (let ((hmenu (gfi:handle it))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Mar 14 01:20:02 2006 @@ -105,6 +105,21 @@ (error 'gfs:win32-error :detail "destroy-window failed")))) (setf (slot-value w 'gfi:handle) nil)) +(defmethod enable :before ((w widget) flag) + (declare (ignore flag)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod enable ((w widget) flag) + (gfs::enable-window (gfi:handle w) (if (null flag) 0 1))) + +(defmethod enabled-p :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod enabled-p ((w widget)) + (not (zerop (gfs::is-window-enabled (gfi:handle w))))) + (defmethod location :before ((w widget)) (if (gfi:disposed-p w) (error 'gfi:disposed-error)))

1 0

[graphic-forms-cvs] r39 - in trunk/src: . tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 14 Mar '06

14 Mar '06

Author: junrue Date: Tue Mar 14 00:01:18 2006 New Revision: 39 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: renamed window layout accessor Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 14 00:01:18 2006 @@ -398,7 +398,7 @@ #:key-down-p #:key-toggled-p #:layout - #:layout-manager + #:layout-of #:layout-p #:lines-visible-p #:location Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Mar 14 00:01:18 2006 @@ -159,13 +159,13 @@ (defun check-flow-orient-item (disp menu time) (declare (ignore disp time)) - (let ((layout (gfw:layout-manager *layout-tester-win*))) + (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout))) (gfw:check (gfw:item-at menu 1) (find :vertical (gfw:style-of layout))))) (defun set-flow-horizontal (disp item time rect) (declare (ignorable disp item time rect)) - (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :vertical style)) (push :horizontal style) @@ -174,7 +174,7 @@ (defun set-flow-vertical (disp item time rect) (declare (ignorable disp item time rect)) - (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :horizontal style)) (push :vertical style) @@ -183,7 +183,7 @@ (defun set-flow-layout-wrap (disp item time rect) (declare (ignorable disp item time rect)) - (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (if (find :wrap style) (setf (gfw:style-of layout) (remove :wrap style)) @@ -216,7 +216,7 @@ (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item) (gfw:append-submenu menu "Spacing" spacing-menu nil) (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) - (gfw:check it (find :wrap (gfw:style-of (gfw:layout-manager *layout-tester-win*)))))) + (gfw:check it (find :wrap (gfw:style-of (gfw:layout-of *layout-tester-win*)))))) (defun exit-layout-callback (disp item time rect) (declare (ignorable disp item time rect)) @@ -233,7 +233,7 @@ (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) - :layout-manager (make-instance 'gfw:flow-layout))) + :layout (make-instance 'gfw:flow-layout))) (gfw:realize *layout-tester-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Tue Mar 14 00:01:18 2006 @@ -40,7 +40,7 @@ (defun perform-layout (win width-hint height-hint) "Calls compute-layout for a window and then handles the actual moving and resizing of its children." - (let ((layout (layout-manager win)) + (let ((layout (layout-of win)) (kids nil) (hdwp nil)) (when (and (layout-p win) layout) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Mar 14 00:01:18 2006 @@ -85,8 +85,8 @@ ((layout-p :reader layout-p :initform t) - (layout-manager - :accessor layout-manager - :initarg :layout-manager + (layout + :accessor layout-of + :initarg :layout :initform nil)) (:documentation "The window class is the base class for widgets that serve as containers (including top-level windows).")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Mar 14 00:01:18 2006 @@ -262,9 +262,9 @@ (call-next-method)) (defmethod preferred-size ((win window) width-hint height-hint) - (let ((mgr (layout-manager win))) - (if (and (layout-p win) mgr) - (let ((new-client-sz (compute-size mgr win width-hint height-hint))) + (let ((layout (layout-of win))) + (if (and (layout-p win) layout) + (let ((new-client-sz (compute-size layout win width-hint height-hint))) (compute-outer-size win new-client-sz)) (size win))))

1 0

[graphic-forms-cvs] r38 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 14 Mar '06

14 Mar '06

Author: junrue Date: Mon Mar 13 23:37:44 2006 New Revision: 38 Modified: trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp Log: implemented wrap style for flow layout; refactored flow layout unit tests Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Mar 13 23:37:44 2006 @@ -165,14 +165,29 @@ (defun set-flow-horizontal (disp item time rect) (declare (ignorable disp item time rect)) - (let ((layout (gfw:layout-manager *layout-tester-win*))) - (setf (gfw:style-of layout) (list :horizontal)) + (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (style (gfw:style-of layout))) + (setf style (remove :vertical style)) + (push :horizontal style) + (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*))) (defun set-flow-vertical (disp item time rect) (declare (ignorable disp item time rect)) - (let ((layout (gfw:layout-manager *layout-tester-win*))) - (setf (gfw:style-of layout) (list :vertical)) + (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (style (gfw:style-of layout))) + (setf style (remove :horizontal style)) + (push :vertical style) + (setf (gfw:style-of layout) 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-manager *layout-tester-win*)) + (style (gfw:style-of layout))) + (if (find :wrap style) + (setf (gfw:style-of layout) (remove :wrap style)) + (setf (gfw:style-of layout) (push :wrap style))) (gfw:layout *layout-tester-win*))) (defun flow-mod-callback (disp menu time) @@ -200,9 +215,8 @@ (gfw:append-submenu menu "Margin" margin-menu nil) (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item) (gfw:append-submenu menu "Spacing" spacing-menu nil) - (setf it (gfw:append-item menu "Fill" nil nil)) - (gfw:check it t) - (gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2))))) + (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) + (gfw:check it (find :wrap (gfw:style-of (gfw:layout-manager *layout-tester-win*)))))) (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 Mon Mar 13 23:37:44 2006 @@ -34,50 +34,90 @@ (in-package :graphic-forms.uitoolkit.tests) (defvar *minsize1* (gfi:make-size :width 20 :height 10)) -(defvar *flow-layout-kids1* (list (make-instance 'mock-widget :min-size *minsize1*) - (make-instance 'mock-widget :min-size *minsize1*) - (make-instance 'mock-widget :min-size *minsize1*))) - -(defun validate-layout-points (actual-entries expected-pnts) - (mapc #'(lambda (pnt entry) - (let ((pnt2 (gfi:location (cdr entry)))) - (assert-true (and (= (gfi:point-x pnt) (gfi:point-x pnt2)) - (= (gfi:point-y pnt) (gfi:point-y pnt2)))))) - expected-pnts - actual-entries)) +(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*))) + +(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 (gfi:location actual)) + (sz-a (gfi:size actual))) + (assert-equal (gfi:point-x pnt-a) (first expected)) + (assert-equal (gfi:point-y pnt-a) (second expected)) + (assert-equal (gfi:size-width sz-a) (third expected)) + (assert-equal (gfi:size-height sz-a) (fourth expected)))) + expected-rects + actual-rects))) (define-test flow-layout-test1 ;; orient: horizontal ;; wrap: disabled - ;; fill: disabled - ;; container: visible + ;; container: unrestricted width and height ;; kids: uniform ;; (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal))) - (size (gfw::flow-container-size layout t *flow-layout-kids1* -1 -1)) - (actual (gfw::flow-container-layout layout t *flow-layout-kids1* -1 -1)) - (expected-pnts nil)) - (push (gfi:make-point :x 40 :y 0) expected-pnts) - (push (gfi:make-point :x 20 :y 0) expected-pnts) - (push (gfi:make-point :x 0 :y 0) expected-pnts) + (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) + (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) (assert-equal 60 (gfi:size-width size)) (assert-equal 10 (gfi:size-height size)) - (validate-layout-points actual expected-pnts))) + (validate-layout-rects data expected-rects))) (define-test flow-layout-test2 ;; orient: vertical ;; wrap: disabled - ;; fill: disabled - ;; container: visible + ;; container: unrestricted width and height ;; kids: uniform ;; (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical))) - (size (gfw::flow-container-size layout t *flow-layout-kids1* -1 -1)) - (actual (gfw::flow-container-layout layout t *flow-layout-kids1* -1 -1)) - (expected-pnts nil)) - (push (gfi:make-point :x 0 :y 20) expected-pnts) - (push (gfi:make-point :x 0 :y 10) expected-pnts) - (push (gfi:make-point :x 0 :y 0) expected-pnts) + (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) + (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) (assert-equal 20 (gfi:size-width size)) (assert-equal 30 (gfi:size-height size)) - (validate-layout-points actual expected-pnts))) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test3 + ;; orient: horizontal + ;; wrap: enabled + ;; container: restricted width, unrestricted height + ;; kids: uniform + ;; + (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap))) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 -1)) + (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test4 + ;; orient: vertical + ;; wrap: enabled + ;; container: unrestricted width, restricted height + ;; kids: uniform + ;; + (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap))) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 25)) + (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test5 + ;; orient: horizontal + ;; wrap: enabled + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap))) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18)) + (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test6 + ;; orient: vertical + ;; wrap: enabled + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap))) + (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) + (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) + (validate-layout-rects data expected-rects))) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Mar 13 23:37:44 2006 @@ -59,35 +59,52 @@ (gfi:make-size :width max :height total) (gfi:make-size :width total :height max)))) -(defun flow-container-layout (layout win-visible kids width-hint height-hint) - (let ((entries nil) - (last-coord 0) - (last-dim 0) - (vert-orient (find :vertical (style-of layout)))) +(defun flow-container-layout (layout visible kids width-hint height-hint) + (let* ((flows nil) + (curr-flow nil) + (max-size -1) + (next-coord 0) + (wrap-coord 0) + (style (style-of layout)) + (vert-orient (find :vertical style)) + (wrap (find :wrap style))) (loop for kid in kids - do (let ((size (preferred-size kid - (if vert-orient width-hint -1) - (if vert-orient -1 height-hint))) + do (let ((size (preferred-size kid -1 -1)) (pnt (gfi:make-point))) - (when (or (visible-p kid) (not win-visible)) + (when (or (visible-p kid) (not visible)) (if vert-orient (progn - (setf (gfi:point-y pnt) (+ last-coord last-dim)) - (if (>= width-hint 0) - (setf (gfi:size-width size) width-hint)) - (setf last-coord (gfi:point-y pnt)) - (setf last-dim (gfi:size-height size))) + (when (and wrap + (>= height-hint 0) + (> (+ next-coord (gfi:size-height size)) height-hint)) + (push (reverse curr-flow) flows) + (setf curr-flow nil) + (setf next-coord 0) + (incf wrap-coord max-size) + (setf max-size -1)) + (setf (gfi:point-x pnt) wrap-coord) + (setf (gfi:point-y pnt) next-coord) + (if (< max-size (gfi:size-width size)) + (setf max-size (gfi:size-width size))) + (incf next-coord (gfi:size-height size))) (progn - (setf (gfi:point-x pnt) (+ last-coord last-dim)) - (if (>= height-hint 0) - (setf (gfi:size-height size) height-hint)) - (setf last-coord (gfi:point-x pnt)) - (setf last-dim (gfi:size-width size)))) - (push (cons kid (make-instance 'gfi:rectangle - :size size - :location pnt)) - entries)))) - (nreverse entries))) + (when (and wrap + (>= width-hint 0) + (> (+ next-coord (gfi:size-width size)) width-hint)) + (push (reverse curr-flow) flows) + (setf curr-flow nil) + (setf next-coord 0) + (incf wrap-coord max-size) + (setf max-size -1)) + (setf (gfi:point-x pnt) next-coord) + (setf (gfi:point-y pnt) wrap-coord) + (if (< max-size (gfi:size-height size)) + (setf max-size (gfi:size-height size))) + (incf next-coord (gfi:size-width size)))) + (push (cons kid (make-instance 'gfi:rectangle :size size :location pnt)) curr-flow)))) + (unless (null curr-flow) + (push (reverse curr-flow) flows)) + (loop for flow in (nreverse flows) append flow))) ;;; ;;; methods @@ -105,5 +122,5 @@ (unless (listp style) (setf style (list style))) (if (and (null (find :horizontal style)) (null (find :vertical style))) - (setf (style-of layout) '(:horizontal)) - (setf (style-of layout) style))) + (push :horizontal style)) + (setf (style-of layout) style))

1 0

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

13 Mar '06

Author: junrue Date: Mon Mar 13 00:40:49 2006 New Revision: 37 Added: trunk/docs/manual/ trunk/docs/manual/Makefile trunk/docs/manual/graphic-forms-reference.texinfo trunk/docs/manual/style.css Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp Log: stub out reference manual Added: trunk/docs/manual/Makefile ============================================================================== --- (empty file) +++ trunk/docs/manual/Makefile Mon Mar 13 00:40:49 2006 @@ -0,0 +1,47 @@ +# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*- +# +# Makefile +# +# 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. +# + +# +# TODO: upgrade MSYS version of makeinfo so "--css-include=style.css" works +# +docs: + makeinfo --html graphic-forms-reference.texinfo + +clean: + find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \; + rm -rf graphic-forms-reference + +# +# TODO: implement an upload target +# Added: trunk/docs/manual/graphic-forms-reference.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/graphic-forms-reference.texinfo Mon Mar 13 00:40:49 2006 @@ -0,0 +1,155 @@ +\input texinfo @c -*- Mode: Texinfo; Mode: auto-fill -*- +@c %**start of header +@setfilename graphic-forms-reference.info +@settitle Graphic-Forms Programming Reference +@exampleindent 2 + +@c @documentencoding utf-8 + +@c ============================= Macros ============================= + +@macro Function {args} +@defun \args\ +@end defun +@end macro + +@macro Macro {args} +@defmac \args\ +@end defmac +@end macro + +@macro Accessor {args} +@deffn {Accessor} \args\ +@end deffn +@end macro + +@macro GenericFunction {args} +@deffn {Generic Function} \args\ +@end deffn +@end macro + +@macro Variable {args} +@defvr {Special Variable} \args\ +@end defvr +@end macro + +@macro Condition {args} +@deftp {Condition Type} \args\ +@end deftp +@end macro + +@macro GFI +@acronym{GFW} +@end macro + +@macro GFG +@acronym{GFW} +@end macro + +@macro GFS +@acronym{GFW} +@end macro + +@macro GFW +@acronym{GFW} +@end macro + +@macro impnote {text} +@quotation +@strong{Implementor's note:} @emph{\text\} +@end quotation +@end macro + +@c Info "requires" that x-refs end in a period or comma, or ) in the +@c case of @pxref. So the following implements that requirement for +@c the "See also" subheadings that permeate this manual, but only in +@c Info mode. +@ifinfo +@macro seealso {name} +@ref{\name\}. +@end macro +@end ifinfo + +@ifnotinfo +@alias seealso = ref +@end ifnotinfo + +@c ==========================End Macros ============================= + +@c Show types, functions, and concepts in the same index. +@syncodeindex tp cp +@syncodeindex fn cp + +@copying +Copyright @copyright{} 2006, Jack D. Unrue <jdunrue at gmail.com> @* + +@quotation +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. + +@sc{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 +DISCLAIMED. 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.} +@end quotation +@end copying +@c %**end of header + +@titlepage +@title Graphic-Forms Programming Reference +@c @subtitle Version 0.2.0 +@c @author Jack D. Unrue + +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@contents + +@ifnottex +@node Top +@top Graphic-Forms Programming Reference +@insertcopying +@end ifnottex + +@menu +* Introduction:: +* Known Issues:: +@end menu + +@c =================================================================== +@c CHAPTER: Introduction + +@node Introduction +@chapter Introduction + +This will be introductory discussion of the Graphic-Forms library. + +@c =================================================================== +@c CHAPTER: Known Issues + +@node Known Issues +@chapter Known Issues + +This will be a list of known issues in the library. + +@bye Added: trunk/docs/manual/style.css ============================================================================== --- (empty file) +++ trunk/docs/manual/style.css Mon Mar 13 00:40:49 2006 @@ -0,0 +1,48 @@ +body {font-family: century schoolbook, serif; + line-height: 1.3; + padding-left: 5em; padding-right: 1em; + padding-bottom: 1em; max-width: 60em;} +table {border-collapse: collapse} +span.roman { font-family: century schoolbook, serif; font-weight: normal; } +h1, h2, h3, h4, h5, h6 {font-family: Helvetica, sans-serif} +/*h4 {padding-top: 0.75em;}*/ +dfn {font-family: inherit; font-variant: italic; font-weight: bolder } +kbd {font-family: monospace; text-decoration: underline} +/*var {font-family: Helvetica, sans-serif; font-variant: slanted}*/ +var {font-variant: slanted;} +td {padding-right: 1em; padding-left: 1em} +sub {font-size: smaller} +.node {padding: 0; margin: 0} + +.lisp { font-family: monospace; + background-color: #F4F4F4; border: 1px solid #AAA; + padding-top: 0.5em; padding-bottom: 0.5em; } + +/* coloring */ + +.lisp-bg { background-color: #F4F4F4 ; color: black; } +.lisp-bg:hover { background-color: #F4F4F4 ; color: black; } + +.symbol { font-weight: bold; color: #770055; background-color : transparent; border: 0px; margin: 0px;} +a.symbol:link { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:active { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:visited { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:hover { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +.special { font-weight: bold; color: #FF5000; background-color: inherit; } +.keyword { font-weight: bold; color: #770000; background-color: inherit; } +.comment { font-weight: normal; color: #007777; background-color: inherit; } +.string { font-weight: bold; color: #777777; background-color: inherit; } +.character { font-weight: bold; color: #0055AA; background-color: inherit; } +.syntaxerror { font-weight: bold; color: #FF0000; background-color: inherit; } +span.paren1 { font-weight: bold; color: #777777; } +span.paren1:hover { color: #777777; background-color: #BAFFFF; } +span.paren2 { color: #777777; } +span.paren2:hover { color: #777777; background-color: #FFCACA; } +span.paren3 { color: #777777; } +span.paren3:hover { color: #777777; background-color: #FFFFBA; } +span.paren4 { color: #777777; } +span.paren4:hover { color: #777777; background-color: #CACAFF; } +span.paren5 { color: #777777; } +span.paren5:hover { color: #777777; background-color: #CAFFCA; } +span.paren6 { color: #777777; } +span.paren6:hover { color: #777777; background-color: #FFBAFF; } Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Mon Mar 13 00:40:49 2006 @@ -53,8 +53,9 @@ ;; container: visible ;; kids: uniform ;; - (let* ((size (gfw::flow-container-size '(:horizontal) t *flow-layout-kids1* -1 -1)) - (actual (gfw::flow-container-layout '(:horizontal) t *flow-layout-kids1* -1 -1)) + (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal))) + (size (gfw::flow-container-size layout t *flow-layout-kids1* -1 -1)) + (actual (gfw::flow-container-layout layout t *flow-layout-kids1* -1 -1)) (expected-pnts nil)) (push (gfi:make-point :x 40 :y 0) expected-pnts) (push (gfi:make-point :x 20 :y 0) expected-pnts) @@ -70,8 +71,9 @@ ;; container: visible ;; kids: uniform ;; - (let* ((size (gfw::flow-container-size '(:vertical) t *flow-layout-kids1* -1 -1)) - (actual (gfw::flow-container-layout '(:vertical) t *flow-layout-kids1* -1 -1)) + (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical))) + (size (gfw::flow-container-size layout t *flow-layout-kids1* -1 -1)) + (actual (gfw::flow-container-layout layout t *flow-layout-kids1* -1 -1)) (expected-pnts nil)) (push (gfi:make-point :x 0 :y 20) expected-pnts) (push (gfi:make-point :x 0 :y 10) expected-pnts) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Mar 13 00:40:49 2006 @@ -37,10 +37,10 @@ ;;; helper functions ;;; -(defun flow-container-size (style win-visible kids width-hint height-hint) +(defun flow-container-size (layout win-visible kids width-hint height-hint) (let ((max -1) (total 0) - (vert-orient (find :vertical style))) + (vert-orient (find :vertical (style-of layout)))) (loop for kid in kids do (let ((size (preferred-size kid (if vert-orient width-hint -1) @@ -59,11 +59,11 @@ (gfi:make-size :width max :height total) (gfi:make-size :width total :height max)))) -(defun flow-container-layout (style win-visible kids width-hint height-hint) +(defun flow-container-layout (layout win-visible kids width-hint height-hint) (let ((entries nil) (last-coord 0) (last-dim 0) - (vert-orient (find :vertical style))) + (vert-orient (find :vertical (style-of layout)))) (loop for kid in kids do (let ((size (preferred-size kid (if vert-orient width-hint -1) @@ -95,11 +95,11 @@ (defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) (with-children (win kids) - (flow-container-size (style-of layout) (visible-p win) kids width-hint height-hint))) + (flow-container-size layout (visible-p win) kids width-hint height-hint))) (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) (with-children (win kids) - (flow-container-layout (style-of layout) (visible-p win) kids width-hint height-hint))) + (flow-container-layout layout (visible-p win) kids width-hint height-hint))) (defmethod initialize-instance :after ((layout flow-layout) &key style) (unless (listp style)

1 0

[graphic-forms-cvs] r36 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 13 Mar '06

13 Mar '06

Author: junrue Date: Sun Mar 12 21:06:21 2006 New Revision: 36 Modified: trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: enhance append-submenu so it can take callback or dispatcher Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Mar 12 21:06:21 2006 @@ -157,6 +157,12 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) +(defun check-flow-orient-item (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-manager *layout-tester-win*))) + (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout))) + (gfw:check (gfw:item-at menu 1) (find :vertical (gfw:style-of layout))))) + (defun set-flow-horizontal (disp item time rect) (declare (ignorable disp item time rect)) (let ((layout (gfw:layout-manager *layout-tester-win*))) @@ -191,9 +197,9 @@ :callback #'set-flow-vertical)))) (spacing-menu (gfw:defmenusystem ((:item "Decrease") (:item "Increase"))))) - (gfw:append-submenu menu "Margin" margin-menu) - (gfw:append-submenu menu "Orientation" orient-menu) - (gfw:append-submenu menu "Spacing" spacing-menu) + (gfw:append-submenu menu "Margin" margin-menu nil) + (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item) + (gfw:append-submenu menu "Spacing" spacing-menu nil) (setf it (gfw:append-item menu "Fill" nil nil)) (gfw:check it t) (gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2))))) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Mar 12 21:06:21 2006 @@ -87,7 +87,7 @@ :size size :location pnt)) entries)))) - (reverse entries))) + (nreverse entries))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Mar 12 21:06:21 2006 @@ -45,7 +45,6 @@ (hdwp nil)) (when (and (layout-p win) layout) (setf kids (compute-layout layout win width-hint height-hint)) -(loop for x in kids do (format t "~a~%" (cdr x))) (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids do (let* ((rect (cdr k)) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Sun Mar 12 21:06:21 2006 @@ -211,9 +211,9 @@ (vector-push-extend it (items owner)))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) - (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher)) + (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) (parent (first (menu-stack-of gen))) - (item (append-submenu parent label submenu))) + (item (append-submenu parent label submenu dispatcher))) (push submenu (menu-stack-of gen)) (enable item (not disabled)))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Sun Mar 12 21:06:21 2006 @@ -141,7 +141,7 @@ (vector-push-extend item (items owner)) item)) -(defmethod append-submenu ((parent menu) text (submenu menu)) +(defmethod append-submenu ((parent menu) text (submenu menu) disp) (if (or (gfi:disposed-p parent) (gfi:disposed-p submenu)) (error 'gfi:disposed-error)) (let* ((tc (thread-context)) @@ -154,6 +154,16 @@ (put-menuitem tc item) (vector-push-extend item (items parent)) (put-widget tc submenu) + (cond + ((null disp)) + ((functionp disp) + (let ((class (define-dispatcher `((event-activate . ,disp))))) + (setf (dispatcher submenu) (make-instance (class-name class))))) + ((typep disp 'gfw:event-dispatcher) + (setf (dispatcher submenu) disp)) + (t + (error 'gfs:toolkit-error + :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) item)) (defun menu-cleanup-callback (menu item) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Mar 12 21:06:21 2006 @@ -48,7 +48,7 @@ (defgeneric append-item (object text image dispatcher) (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) -(defgeneric append-submenu (object text submenu) +(defgeneric append-submenu (object text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) (defgeneric background-color (object)

1 0

[graphic-forms-cvs] r35 - in trunk: . src/intrinsics/datastructs src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 13 Mar '06

13 Mar '06

Author: junrue Date: Sun Mar 12 19:19:36 2006 New Revision: 35 Added: trunk/src/intrinsics/datastructs/datastruct.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp - copied, changed from r32, trunk/src/uitoolkit/widgets/layouts.lisp Removed: trunk/src/uitoolkit/widgets/layouts.lisp Modified: trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/tests/uitoolkit/layout-tester.lisp trunk/tests.lisp Log: flow layout unit-test code; bug fixes for vertical flow layout style Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Mar 12 19:19:36 2006 @@ -49,6 +49,8 @@ :components ((:module "uitoolkit" :components - ((:file "hello-world") + ((:file "mock-objects") + (:file "layout-unit-tests") + (:file "hello-world") (:file "event-tester") (:file "layout-tester"))))))))) Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Mar 12 19:19:36 2006 @@ -51,7 +51,8 @@ :components ((:module "datastructs" :components - ((:file "datastruct-classes"))) + ((:file "datastruct-classes") + (:file "datastruct"))) (:module "system" :components ((:file "native-classes") @@ -106,4 +107,5 @@ (:file "menu-language") (:file "event") (:file "window") - (:file "layouts"))))))))) + (:file "layout") + (:file "flow-layout"))))))))) Added: trunk/src/intrinsics/datastructs/datastruct.lisp ============================================================================== --- (empty file) +++ trunk/src/intrinsics/datastructs/datastruct.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,38 @@ +;;;; +;;;; datastruct.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.intrinsics) + +(defmethod print-object ((obj rectangle) stream) + (print-unreadable-object (obj stream :type t) + (format stream "location: ~a size: ~a" (location obj) (size obj)))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Mar 12 19:19:36 2006 @@ -157,6 +157,18 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) +(defun set-flow-horizontal (disp item time rect) + (declare (ignorable disp item time rect)) + (let ((layout (gfw:layout-manager *layout-tester-win*))) + (setf (gfw:style-of layout) (list :horizontal)) + (gfw:layout *layout-tester-win*))) + +(defun set-flow-vertical (disp item time rect) + (declare (ignorable disp item time rect)) + (let ((layout (gfw:layout-manager *layout-tester-win*))) + (setf (gfw:style-of layout) (list :vertical)) + (gfw:layout *layout-tester-win*))) + (defun flow-mod-callback (disp menu time) (declare (ignore disp time)) (gfw:clear-all menu) @@ -173,8 +185,10 @@ (:item "Bottom" :submenu ((:item "Decrease") (:item "Increase")))))) - (orient-menu (gfw:defmenusystem ((:item "Horizontal") - (:item "Vertical")))) + (orient-menu (gfw:defmenusystem ((:item "Horizontal" + :callback #'set-flow-horizontal) + (:item "Vertical" + :callback #'set-flow-vertical)))) (spacing-menu (gfw:defmenusystem ((:item "Decrease") (:item "Increase"))))) (gfw:append-submenu menu "Margin" margin-menu) Added: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,81 @@ +;;;; +;;;; layout-unit-tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defvar *minsize1* (gfi:make-size :width 20 :height 10)) +(defvar *flow-layout-kids1* (list (make-instance 'mock-widget :min-size *minsize1*) + (make-instance 'mock-widget :min-size *minsize1*) + (make-instance 'mock-widget :min-size *minsize1*))) + +(defun validate-layout-points (actual-entries expected-pnts) + (mapc #'(lambda (pnt entry) + (let ((pnt2 (gfi:location (cdr entry)))) + (assert-true (and (= (gfi:point-x pnt) (gfi:point-x pnt2)) + (= (gfi:point-y pnt) (gfi:point-y pnt2)))))) + expected-pnts + actual-entries)) + +(define-test flow-layout-test1 + ;; orient: horizontal + ;; wrap: disabled + ;; fill: disabled + ;; container: visible + ;; kids: uniform + ;; + (let* ((size (gfw::flow-container-size '(:horizontal) t *flow-layout-kids1* -1 -1)) + (actual (gfw::flow-container-layout '(:horizontal) t *flow-layout-kids1* -1 -1)) + (expected-pnts nil)) + (push (gfi:make-point :x 40 :y 0) expected-pnts) + (push (gfi:make-point :x 20 :y 0) expected-pnts) + (push (gfi:make-point :x 0 :y 0) expected-pnts) + (assert-equal 60 (gfi:size-width size)) + (assert-equal 10 (gfi:size-height size)) + (validate-layout-points actual expected-pnts))) + +(define-test flow-layout-test2 + ;; orient: vertical + ;; wrap: disabled + ;; fill: disabled + ;; container: visible + ;; kids: uniform + ;; + (let* ((size (gfw::flow-container-size '(:vertical) t *flow-layout-kids1* -1 -1)) + (actual (gfw::flow-container-layout '(:vertical) t *flow-layout-kids1* -1 -1)) + (expected-pnts nil)) + (push (gfi:make-point :x 0 :y 20) expected-pnts) + (push (gfi:make-point :x 0 :y 10) expected-pnts) + (push (gfi:make-point :x 0 :y 0) expected-pnts) + (assert-equal 20 (gfi:size-width size)) + (assert-equal 30 (gfi:size-height size)) + (validate-layout-points actual expected-pnts))) Added: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,79 @@ +;;;; +;;;; mock-objects.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) + +(defconstant +max-widget-size+ 5000) + +;;; +;;; stand-ins for widgets that would be children of windows, to be organized +;;; via layout managers +;;; + +(defclass mock-widget (gfw:widget) + ((visibility + :accessor visibility-of + :initform t) + (actual-size + :accessor actual-size-of + :initarg :actual-size + :initform (gfi:make-size)) + (max-size + :accessor max-size-of + :initarg :max-size + :initform (gfi:make-size :width +max-widget-size+ :height +max-widget-size+)) + (min-size + :accessor min-size-of + :initarg :min-size + :initform (gfi:make-size)))) + +(defmethod initialize-instance :after ((widget mock-widget) &key &allow-other-keys) + (setf (slot-value widget 'gfi:handle) (cffi:make-pointer #xFFFFFFFF))) + +(defmethod gfw:minimum-size ((widget mock-widget)) + (gfi:make-size :width (gfi:size-width (min-size-of widget)) + :height (gfi:size-height (min-size-of widget)))) + +(defmethod gfw:preferred-size ((widget mock-widget) width-hint height-hint) + (let ((size (gfi:make-size)) + (min-size (min-size-of widget))) + (if (< width-hint 0) + (setf (gfi:size-width size) (gfi:size-width min-size)) + (setf (gfi:size-width size) width-hint)) + (if (< height-hint 0) + (setf (gfi:size-height size) (gfi:size-height min-size)) + (setf (gfi:size-height size) height-hint)) + size)) + +(defmethod gfw:visible-p ((widget mock-widget)) + (visibility-of widget)) Added: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,109 @@ +;;;; +;;;; flow-layout.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; helper functions +;;; + +(defun flow-container-size (style win-visible kids width-hint height-hint) + (let ((max -1) + (total 0) + (vert-orient (find :vertical style))) + (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 (gfi:size-height size)) + (if (< max (gfi:size-width size)) + (setf max (gfi:size-width size)))) + (progn + (incf total (gfi:size-width size)) + (if (< max (gfi:size-height size)) + (setf max (gfi:size-height size)))))))) + (if vert-orient + (gfi:make-size :width max :height total) + (gfi:make-size :width total :height max)))) + +(defun flow-container-layout (style win-visible kids width-hint height-hint) + (let ((entries nil) + (last-coord 0) + (last-dim 0) + (vert-orient (find :vertical style))) + (loop for kid in kids + do (let ((size (preferred-size kid + (if vert-orient width-hint -1) + (if vert-orient -1 height-hint))) + (pnt (gfi:make-point))) + (when (or (visible-p kid) (not win-visible)) + (if vert-orient + (progn + (setf (gfi:point-y pnt) (+ last-coord last-dim)) + (if (>= width-hint 0) + (setf (gfi:size-width size) width-hint)) + (setf last-coord (gfi:point-y pnt)) + (setf last-dim (gfi:size-height size))) + (progn + (setf (gfi:point-x pnt) (+ last-coord last-dim)) + (if (>= height-hint 0) + (setf (gfi:size-height size) height-hint)) + (setf last-coord (gfi:point-x pnt)) + (setf last-dim (gfi:size-width size)))) + (push (cons kid (make-instance 'gfi:rectangle + :size size + :location pnt)) + entries)))) + (reverse entries))) + +;;; +;;; methods +;;; + +(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) + (with-children (win kids) + (flow-container-size (style-of layout) (visible-p win) kids width-hint height-hint))) + +(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) + (with-children (win kids) + (flow-container-layout (style-of layout) (visible-p win) kids width-hint height-hint))) + +(defmethod initialize-instance :after ((layout flow-layout) &key style) + (unless (listp style) + (setf style (list style))) + (if (and (null (find :horizontal style)) (null (find :vertical style))) + (setf (style-of layout) '(:horizontal)) + (setf (style-of layout) style))) Copied: trunk/src/uitoolkit/widgets/layout.lisp (from r32, trunk/src/uitoolkit/widgets/layouts.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/layouts.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Mar 12 19:19:36 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; layouts.lisp +;;;; layout.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -45,6 +45,7 @@ (hdwp nil)) (when (and (layout-p win) layout) (setf kids (compute-layout layout win width-hint height-hint)) +(loop for x in kids do (format t "~a~%" (cdr x))) (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids do (let* ((rect (cdr k)) @@ -68,65 +69,3 @@ +window-pos-flags+))))) (unless (gfi:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp))))) - -;;; -;;; flow-layout methods -;;; - -(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (let ((max -1) - (total 0) - (vert-orient (find :vertical (style-of layout)))) - (with-children (win kids) - (loop for k in kids - do (let ((kid-size (preferred-size k - (if vert-orient width-hint -1) - (if vert-orient -1 height-hint)))) - (when (or (visible-p k) (not (visible-p win))) - (if (not vert-orient) - (progn - (incf total (gfi:size-width kid-size)) - (if (< max (gfi:size-height kid-size)) - (setf max (gfi:size-height kid-size)))) - (progn - (incf total (gfi:size-height kid-size)) - (if (< max (gfi:size-width kid-size)) - (setf max (gfi:size-width kid-size))))))))) - (if vert-orient - (gfi:make-size :width max :height total) - (gfi:make-size :width total :height max)))) - -(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) - (let ((entries nil) - (last-coord 0) - (last-dim 0) - (vert-orient (find :vertical (style-of layout)))) - (with-children (win kids) - (loop for k in kids - do (let ((kid-size (preferred-size k - (if vert-orient width-hint -1) - (if vert-orient -1 height-hint))) - (pnt (gfi:make-point))) - (when (or (visible-p k) (not (visible-p win))) - (if (not vert-orient) - (progn - (setf (gfi:point-x pnt) (+ last-coord last-dim)) - (if (>= height-hint 0) - (setf (gfi:size-height kid-size) height-hint)) - (setf last-coord (gfi:point-x pnt)) - (setf last-dim (gfi:size-width kid-size))) - (progn - (setf (gfi:point-y pnt) (+ last-coord last-dim)) - (if (>= width-hint 0) - (setf (gfi:size-width kid-size) width-hint)) - (setf last-coord (gfi:point-y pnt)) - (setf last-dim (gfi:size-height kid-size)))) - (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries))))) - (reverse entries))) - -(defmethod initialize-instance :after ((layout flow-layout) &key style) - (unless (listp style) - (setf style (list style))) - (if (and (null (find :horizontal style)) (null (find :vertical style))) - (setf (style-of layout) '(:horizontal)) - (setf (style-of layout) style))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Mar 12 19:19:36 2006 @@ -33,15 +33,15 @@ (in-package #:graphic-forms-system) -(defvar *lisp-unit-srcfile* (concatenate 'string *library-root* "lisp-unit.lisp")) +(defvar *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) -(load (compile-file *lisp-unit-srcfile*)) +(load (compile-file *lisp-unit-file*)) (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) (:use :common-lisp :lisp-unit)) -(defun load-adhoc-tests () +(defun load-tests () (if *external-build-dirs* (chdir *gf-build-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

graphic-forms-cvs March 2006