From junrue at common-lisp.net Wed Nov 1 17:52:35 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 1 Nov 2006 12:52:35 -0500 (EST) Subject: [graphic-forms-cvs] r388 - in trunk: . docs/manual docs/website src src/demos/textedit src/demos/unblocked src/tests/mcclim src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20061101175235.3FE724F005@common-lisp.net> Author: junrue Date: Wed Nov 1 12:52:32 2006 New Revision: 388 Added: trunk/src/tests/mcclim/ trunk/src/tests/mcclim/hello-tester.lisp Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/Makefile trunk/docs/manual/gfw-symbols.xml trunk/docs/website/index.html trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/root-window.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: version bump for next release; enhanced append-item to accept an optional classname; added a few bits related to job tables; added a mcclim testcase; added convenience macro with-root-window Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Wed Nov 1 12:52:32 2006 @@ -1,4 +1,13 @@ + +. GFW:APPEND-ITEM now accepts an optional classname argument so that + applications can use custom item classes. + +. Implemented a new macro GFW:WITH-ROOT-WINDOW which manages the lifetime + of an instance of GFW:ROOT-WINDOW for use within the macro body. + +============================================================================== + Release 0.6.0 of Graphic-Forms, a Common Lisp library for Windows GUI programming, is now available. This is an alpha release, meaning that the feature set and API have not yet stabilized. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Nov 1 12:52:32 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.6.0 (22 October 2006) +Graphic-Forms README for version 0.7.0 (xx xxxxx 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Wed Nov 1 12:52:32 2006 @@ -5,7 +5,7 @@ # Copyright (c) 2006, Jack D. Unrue # -VERSION = 0.6 +VERSION = 0.7 CHM-DEPS = gfs-tmp-pkg.xml gfg-tmp-pkg.xml gfw-tmp-pkg.xml \ constants.xml api.xml \ Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Wed Nov 1 12:52:32 2006 @@ -4518,6 +4518,13 @@ initially checked. + + + A symbol specifying an item subclass other than the + default type to be created; such a subclass must still represent an + item type appropriate for . + + gfw:item @@ -5337,7 +5344,7 @@ The gfw:widget being resized. - + A gfs:size indicating 's new dimensions. @@ -5945,6 +5952,33 @@ + + + + + + + A gfw:root-window to query. + + + + + + + Application code to make use of . + + + + + results + + + + This macro executes with bound to an instance of + gfw:root-window. + + + Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Nov 1 12:52:32 2006 @@ -43,7 +43,7 @@

The current version is - 0.6.0, released on 22 October 2006.

+ 0.7.0, released on xx xxxxxx 2006.

Graphic-Forms is in the alpha stage of development, meaning new features are still being added and existing features require considerable testing. Brave souls who experiment with the code should expect Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Nov 1 12:52:32 2006 @@ -1,3 +1,5 @@ +;;; -*- Mode: Lisp -*- + ;;;; ;;;; graphic-forms-tests.asd ;;;; @@ -54,7 +56,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.6.0" + :version "0.7.0" :author "Jack D. Unrue" :licence "BSD" :components Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Nov 1 12:52:32 2006 @@ -1,3 +1,5 @@ +;;; -*- Mode: Lisp -*- + ;;;; ;;;; graphic-forms-uitoolkit.asd ;;;; @@ -39,7 +41,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.6.0" + :version "0.7.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") @@ -149,3 +151,6 @@ (:file "layout") (:file "heap-layout") (:file "flow-layout"))))))))) + +(defmethod perform :after ((op load-op) (c (eql (find-system :graphic-forms-uitoolkit)))) + (pushnew :graphic-forms *features*)) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Nov 1 12:52:32 2006 @@ -157,7 +157,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.6"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.7"))) (defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Wed Nov 1 12:52:32 2006 @@ -87,7 +87,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.6"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.7"))) (defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File" Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Nov 1 12:52:32 2006 @@ -540,6 +540,7 @@ #:with-file-dialog #:with-font-dialog #:with-graphics-context + #:with-root-window ;; conditions )) Added: trunk/src/tests/mcclim/hello-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/mcclim/hello-tester.lisp Wed Nov 1 12:52:32 2006 @@ -0,0 +1,37 @@ + +(defpackage :clim-graphic-forms-tests + (:use :clim :clim-lisp)) + +(in-package :clim-graphic-forms-tests) + +(define-application-frame hello-frame () + ((message :initform "Foo!" :accessor message)) + (:menu-bar menubar-command-table) + (:panes (some-pane :application :display-function 'display-some-pane)) + (:layouts (default + (vertically (:height 500 :width 400) + (:fill some-pane))))) + +(define-command com-hello () + (clim-graphic-forms::debug-print "com-hello called ") + (setf (message *application-frame*) "Hello there!")) + +(define-command com-hi () + (clim-graphic-forms::debug-print "com-hi called ") + (setf (message *application-frame*) "Hi there!")) + +(define-command-table menu-command-table + :menu (("Hello" :command com-hello) + ("Howdy" :command com-hi))) + +(define-command-table menubar-command-table + :menu (("Menu" :menu menu-command-table) + ("Quit" :command com-quit-frame))) + +(define-hello-frame-command (com-quit-frame :name "Quit" :menu t) + () + (frame-exit *application-frame*)) + +(defmethod display-some-pane ((frame hello-frame) stream) + (clim-graphic-forms::debug-print "display-some-pane called ") + (format stream (message frame))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Wed Nov 1 12:52:32 2006 @@ -120,8 +120,8 @@ (if items (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) items 'mock-item)))) -(defmethod gfw:append-item ((self mock-item-manager) thing (disp gfw:event-dispatcher) &optional checked disabled) - (declare (ignore disabled checked)) +(defmethod gfw:append-item ((self mock-item-manager) thing (disp gfw:event-dispatcher) &optional checked disabled classname) + (declare (ignore disabled checked classname)) (let ((item (gfw::create-item-with-callback (gfs:handle self) 'mock-item thing disp))) (vector-push-extend item (slot-value self 'gfw::items)) item)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Nov 1 12:52:32 2006 @@ -47,6 +47,8 @@ (defconstant +wm-user+ #x0400) (defconstant +wm-app+ #x8000) +(defconstant +wm-job-posting+ #x2112) + (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Wed Nov 1 12:52:32 2006 @@ -85,8 +85,8 @@ ;;; methods ;;; -(defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled) - (declare (ignore thing disp checked disabled)) +(defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled classname) + (declare (ignore thing disp checked disabled classname)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Wed Nov 1 12:52:32 2006 @@ -169,12 +169,12 @@ ;;; methods ;;; -(defmethod append-item ((self list-box) thing disp &optional disabled checked) +(defmethod append-item ((self list-box) thing disp &optional disabled checked classname) (declare (ignore disabled checked)) (let* ((tc (thread-context)) (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) - (item (create-item-with-callback hcontrol 'list-item thing disp))) + (item (create-item-with-callback hcontrol (or classname 'list-item) thing disp))) (lb-insert-item hcontrol #xFFFFFFFF text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (slot-value self 'items)) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Wed Nov 1 12:52:32 2006 @@ -90,10 +90,10 @@ ;;; methods ;;; -(defmethod append-item ((self menu) thing disp &optional disabled checked) +(defmethod append-item ((self menu) thing disp &optional disabled checked classname) (let* ((tc (thread-context)) (hmenu (gfs:handle self)) - (item (create-item-with-callback hmenu 'menu-item thing disp)) + (item (create-item-with-callback hmenu (or classname 'menu-item) thing disp)) (text (call-text-provider self thing))) (append-menuitem hmenu (item-id item) text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (put-item tc item) Modified: trunk/src/uitoolkit/widgets/root-window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/root-window.lisp (original) +++ trunk/src/uitoolkit/widgets/root-window.lisp Wed Nov 1 12:52:32 2006 @@ -34,6 +34,17 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; macros and helper functions +;;; + +(defmacro with-root-window ((win) &body body) + `(let ((,win (make-instance 'root-window))) + (unwind-protect + (progn + , at body) + (gfs:dispose ,win)))) + +;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Wed Nov 1 12:52:32 2006 @@ -45,6 +45,7 @@ (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) (next-item-id :initform 10000 :reader next-item-id) + (next-job-id :initform 1 :reader next-job-id) (next-widget-id :initform 100 :reader next-widget-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) @@ -112,6 +113,9 @@ (defgeneric put-item (self item)) (defgeneric delete-tc-item (self item)) (defgeneric increment-item-id (self)) +(defgeneric put-job (self id closure)) +(defgeneric take-job (self id)) +(defgeneric increment-job-id (self)) (defgeneric get-timer (self id)) (defgeneric put-timer (self timer)) (defgeneric delete-timer (self timer)) @@ -225,6 +229,22 @@ (incf (slot-value tc 'next-item-id)) id)) +(defmethod put-job ((tc thread-context) id closure) + "Stores a closure using the specified ID for later retrieval." + ;; FIXME: thread-safety + (setf (gethash id (slot-value tc 'job-table)) closure)) + +(defmethod take-job ((tc thread-context) id) + (let ((closure (gethash id (slot-value tc 'job-table)))) + (remhash id (slot-value tc 'job-table)) + closure)) + +(defmethod increment-job-id ((tc thread-context)) + "Return the next job ID; also increment the internal value." + (let ((id (next-job-id tc))) + (incf (slot-value tc 'next-job-id)) + id)) + (defmethod get-timer ((tc thread-context) id) "Returns the timer identified by the specified (system-defined) id." (gethash id (slot-value tc 'timers-by-id))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Nov 1 12:52:32 2006 @@ -45,7 +45,7 @@ (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (self thing dispatcher &optional checked disabled) +(defgeneric append-item (self thing dispatcher &optional checked disabled classname) (:documentation "Adds a new item encapsulating thing to self, and returns the newly-created item.")) (defgeneric append-separator (self) From junrue at common-lisp.net Wed Nov 1 22:56:18 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 1 Nov 2006 17:56:18 -0500 (EST) Subject: [graphic-forms-cvs] r389 - trunk Message-ID: <20061101225618.D85F083004@common-lisp.net> Author: junrue Date: Wed Nov 1 17:56:18 2006 New Revision: 389 Removed: trunk/build.lisp Modified: trunk/config.lisp trunk/graphic-forms-tests.asd trunk/tests.lisp Log: fix config and load issues; stop using build.lisp locally Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Wed Nov 1 17:56:18 2006 @@ -43,15 +43,16 @@ (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") (defvar *gf-dir* "graphic-forms/") -(defvar *binary-data-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/binary-data/") -(defvar *macro-utilities-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/macro-utilities/") -(defvar *textedit-dir* "graphic-forms/src/demos/textedit/") -(defvar *unblocked-dir* "graphic-forms/src/demos/unblocked/") -(defvar *gf-tests-dir* "graphic-forms/src/tests/uitoolkit/") +(defvar *binary-data-dir* "src/external-libraries/practicals-1.0.3/Chapter08/") +(defvar *macro-utilities-dir* "src/external-libraries/practicals-1.0.3/Chapter24/") +(defvar *textedit-dir* "src/demos/textedit/") +(defvar *unblocked-dir* "src/demos/unblocked/") -(defvar *lisp-unit-file* "graphic-forms/src/external-libraries/practicals-1.0.3/lisp-unit.lisp") +(defvar *lisp-unit-file* "src/external-libraries/lisp-unit/lisp-unit.lisp") (defun configure-asdf () - (loop for var in '(*binary-data-dir* *cffi-dir* *closer-mop-dir* *lw-compat-dir* *macro-utilities-dir* *gf-dir*) - when (symbol-value var) - do (pushnew (symbol-value var) asdf:*central-registry* :test #'equal))) + (let ((dir-list (list (concatenate 'string *gf-dir* *binary-data-dir*) + (concatenate 'string *gf-dir* *macro-utilities-dir*) + *cffi-dir* *closer-mop-dir* *lw-compat-dir* *gf-dir*))) + (loop for var in dir-list + do (pushnew var asdf:*central-registry* :test #'equal)))) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Nov 1 17:56:18 2006 @@ -33,7 +33,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(load gfsys::*lisp-unit-file*) +(load (concatenate 'string gfsys::*gf-dir* gfsys::*lisp-unit-file*)) (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Wed Nov 1 17:56:18 2006 @@ -34,16 +34,14 @@ (in-package #:graphic-forms-system) (defun load-tests () - (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) - (asdf:operate 'asdf:load-op :graphic-forms-tests) - (load (merge-pathnames "test-utils.lisp" *gf-tests-dir*)) - (load (merge-pathnames "mock-objects" *gf-tests-dir*)) - (load (merge-pathnames "color-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "graphics-context-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "image-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "icon-bundle-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "layout-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "flow-layout-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "widget-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "item-manager-unit-tests" *gf-tests-dir*)) - (load (merge-pathnames "misc-unit-tests" *gf-tests-dir*))) + (let ((tests-dir (concatenate 'string gfsys::*gf-dir* "src/tests/uitoolkit/"))) + (setf *default-pathname-defaults* (parse-namestring tests-dir)) + (setf *textedit-dir* (concatenate 'string gfsys::*gf-dir* gfsys::*textedit-dir*)) + (setf *unblocked-dir* (concatenate 'string gfsys::*gf-dir* gfsys::*unblocked-dir*)) + (asdf:operate 'asdf:load-op :graphic-forms-tests) + (loop for file in '("test-utils.lisp" "mock-objects" "color-unit-tests" + "graphics-context-unit-tests" "image-unit-tests" + "icon-bundle-unit-tests" "layout-unit-tests" + "flow-layout-unit-tests" "widget-unit-tests" + "item-manager-unit-tests" "misc-unit-tests") + do (load (merge-pathnames file tests-dir))))) From junrue at common-lisp.net Sun Nov 5 21:06:36 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 5 Nov 2006 16:06:36 -0500 (EST) Subject: [graphic-forms-cvs] r390 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20061105210636.8E1BD5D004@common-lisp.net> Author: junrue Date: Sun Nov 5 16:06:36 2006 New Revision: 390 Modified: trunk/config.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/tests.lisp Log: more fixes for loading the system; minor cleanup in message-loop function; added a couple debug functions Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Sun Nov 5 16:06:36 2006 @@ -43,6 +43,7 @@ (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") (defvar *gf-dir* "graphic-forms/") +(defvar *gf-tests-dir* "graphic-forms/src/tests/uitoolkit/") (defvar *binary-data-dir* "src/external-libraries/practicals-1.0.3/Chapter08/") (defvar *macro-utilities-dir* "src/external-libraries/practicals-1.0.3/Chapter24/") (defvar *textedit-dir* "src/demos/textedit/") Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Sun Nov 5 16:06:36 2006 @@ -37,6 +37,14 @@ ;;; convenience functions ;;; +(defun debug-format (str &rest args) + (apply #'format *trace-output* str args) + (finish-output)) + +(defun debug-print (thing) + (print thing *trace-output*) + (finish-output)) + (defun recreate-array (array) (make-array (array-dimensions array) :element-type (array-element-type array) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Nov 5 16:06:36 2006 @@ -71,13 +71,7 @@ (cffi:with-foreign-object (msg-ptr 'gfs::msg) (loop (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) - (cffi:with-foreign-slots ((gfs::hwnd - gfs::message - gfs::wparam - gfs::lparam - gfs::time - gfs::pnt) - msg-ptr gfs::msg) + (cffi:with-foreign-slots ((gfs::message gfs::wparam) msg-ptr gfs::msg) (when (funcall msg-filter gm msg-ptr) (return-from message-loop gfs::wparam))))))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Nov 5 16:06:36 2006 @@ -34,14 +34,14 @@ (in-package #:graphic-forms-system) (defun load-tests () - (let ((tests-dir (concatenate 'string gfsys::*gf-dir* "src/tests/uitoolkit/"))) - (setf *default-pathname-defaults* (parse-namestring tests-dir)) - (setf *textedit-dir* (concatenate 'string gfsys::*gf-dir* gfsys::*textedit-dir*)) - (setf *unblocked-dir* (concatenate 'string gfsys::*gf-dir* gfsys::*unblocked-dir*)) + (setf *gf-tests-dir* (concatenate 'string gfsys::*gf-dir* "src/tests/uitoolkit/")) + (setf *textedit-dir* (concatenate 'string gfsys::*gf-dir* "src/demos/textedit/")) + (setf *unblocked-dir* (concatenate 'string gfsys::*gf-dir* "src/demos/unblocked/")) + (setf *default-pathname-defaults* (parse-namestring *gf-tests-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests) (loop for file in '("test-utils.lisp" "mock-objects" "color-unit-tests" "graphics-context-unit-tests" "image-unit-tests" "icon-bundle-unit-tests" "layout-unit-tests" "flow-layout-unit-tests" "widget-unit-tests" "item-manager-unit-tests" "misc-unit-tests") - do (load (merge-pathnames file tests-dir))))) + do (load (merge-pathnames file *gf-tests-dir*)))) From junrue at common-lisp.net Sun Nov 5 22:38:09 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 5 Nov 2006 17:38:09 -0500 (EST) Subject: [graphic-forms-cvs] r391 - trunk/docs/manual Message-ID: <20061105223809.0F63F3E053@common-lisp.net> Author: junrue Date: Sun Nov 5 17:38:08 2006 New Revision: 391 Modified: trunk/docs/manual/gfw-symbols.xml Log: documented the startup and shutdown functions Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Sun Nov 5 17:38:08 2006 @@ -2059,6 +2059,56 @@ + + + + + + A string identifying the application's name. + + + + + A function with initialization code for the + application. + + + + + undefined + + + + This is the main entry point for applications. + + + gfw:shutdown + + + + + + + + + An integer exit code. + + + + + undefined + + + + Applications call this function to perform graceful cleanup and exit. + One of the side effects of this function is the posting of a WM_QUIT + message. + + + gfw:startup + + + From junrue at common-lisp.net Tue Nov 7 21:02:05 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 7 Nov 2006 16:02:05 -0500 (EST) Subject: [graphic-forms-cvs] r392 - in trunk: docs/manual src/uitoolkit/widgets Message-ID: <20061107210205.0E58C72088@common-lisp.net> Author: junrue Date: Tue Nov 7 16:02:04 2006 New Revision: 392 Modified: trunk/docs/manual/gfw-symbols.xml trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: text-baseline tweaked such that default is mid-point instead of height Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Tue Nov 7 16:02:04 2006 @@ -2789,7 +2789,7 @@ that correlates to the baseline of the text of the control, if any. For controls in which a text baseline is not meaningful, such as a gfw:label with a gfg:image, - this function returns the control's height. + this function returns half of the control's height. By default, Graphic-Forms does not implement this function for Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Nov 7 16:02:04 2006 @@ -210,7 +210,7 @@ (format stream "text baseline: ~a" (text-baseline self)))) (defmethod text-baseline ((self control)) - (gfs:size-height (size self))) + (floor (gfs:size-height (size self)) 2)) (defmethod update-native-style ((self control) flags) (let ((hwnd (gfs:handle self))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Nov 7 16:02:04 2006 @@ -195,5 +195,5 @@ (let ((image (image self))) (if image (+ (gfs:size-height (gfg:size image)) b-width) - b-width)) + (floor b-width 2))) (widget-text-baseline self 0)))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Nov 7 16:02:04 2006 @@ -412,7 +412,7 @@ (:documentation "Sets self's text.")) (defgeneric text-baseline (self) - (:documentation "Returns the y coordinate of the object's text component, if any.")) + (:documentation "Returns the y coordinate of the baseline of self's text component, if any.")) (defgeneric text-for-pasting-p (self) (:documentation "Returns T if the clipboard has data in text format; nil otherwise.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Nov 7 16:02:04 2006 @@ -209,17 +209,15 @@ (defun widget-text-baseline (widget top-margin) (let ((size (gfw:size widget)) (b-width (border-width widget)) - (font (gfg:font widget)) - (baseline 0)) + (font (gfg:font widget))) (with-graphics-context (gc widget) (let ((metrics (gfg:metrics gc font))) - (setf baseline (+ b-width - top-margin - (gfg:ascent metrics) - (floor (- (gfs:size-height size) - (+ (gfg:ascent metrics) (gfg:descent metrics))) - 2))))) - baseline)) + (+ b-width + top-margin + (gfg:ascent metrics) + (floor (- (gfs:size-height size) + (+ (gfg:ascent metrics) (gfg:descent metrics))) + 2)))))) (defun check-box-size () (if *check-box-size* From junrue at common-lisp.net Mon Nov 13 06:58:15 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 13 Nov 2006 01:58:15 -0500 (EST) Subject: [graphic-forms-cvs] r393 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20061113065815.7F43030009@common-lisp.net> Author: junrue Date: Mon Nov 13 01:58:13 2006 New Revision: 393 Added: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/uitoolkit/widgets/border-layout.lisp Modified: trunk/NEWS.txt trunk/docs/manual/Makefile trunk/docs/manual/gfs-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/tests.lisp Log: initial implementation of border-layout; added create-rectangle convenience function Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Nov 13 01:58:13 2006 @@ -1,5 +1,9 @@ +. Implemented a new layout manager called GFW:BORDER-LAYOUT which assigns + children to 5 possible regions identified by :top, :left, :right, + :bottom, or :center. + . GFW:APPEND-ITEM now accepts an optional classname argument so that applications can use custom item classes. Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Mon Nov 13 01:58:13 2006 @@ -1,4 +1,4 @@ -# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*- +# -*- Mode: Makefile; tab-width: 4; indent-tabs-mode: t -*- # # Makefile # Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Mon Nov 13 01:58:13 2006 @@ -264,6 +264,7 @@ gfs:copy-rectangle + gfs:create-rectangle gfs:location gfs:make-rectangle gfs:size @@ -410,7 +411,7 @@ - A gfs:size specifing the dimensions of the + A gfs:size specifying the dimensions of the rectangle. @@ -425,6 +426,52 @@ gfs:copy-rectangle + gfs:create-rectangle + + + + + + + + + An integer specifying the X coordinate of the + upper-left corner of the rectangle. + + + + + + An integer specifying the Y coordinate of the + upper-left corner of the rectangle. + + + + + + An integer specifying the width of the + rectangle. + + + + + + An integer specifying the height of the + rectangle. + + + + + + gfs:rectangle + + + + Returns a new gfs:rectangle. This function is a + wrapper around gfs:make-rectangle. + + + gfs:copy-rectangle Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Mon Nov 13 01:58:13 2006 @@ -17,6 +17,130 @@ + + + + + gfw:layout-manager + + + + This layout manager organizes the space within a container as 5 regions, + one region for each edge of the container and a center region. Applications + specify the region for each component via gfw:layout-attribute, + using one of the following keywords: + + + + Place the component in the central region of the container. + + + + + Place the component in the bottom region of the container; note that + the bottom region extends to the left and right sides of the container. + + + + + Place the component in the left-hand region of the container. This region + is bounded vertically by the top and bottom regions. + + + + + Place the component in the right-hand region of the container. This region + is bounded vertically by the top and bottom regions. + + + + + Place the component in the top region of the container; note that + the top region extends to the left and right sides of the container. + + + + Note that only one child may be assigned to each region at a time. + + + Spacing between adjacent regions can also be specified via + gfw:layout-attribute using one or more + of the following keywords (note that not all keywords apply + to all regions): + + + + An integer specifying the number of pixels between + the center region and a region on the perimeter. + + + + + An integer specifying the number of pixels between + neighboring regions on the leading edge of the specified region. + + + + + An integer specifying the number of pixels between + neighboring regions on the trailing edge of the specified region. + + + + + An integer specifying the number of pixels between + a region and its immediate neighbors. + + + + + + The :top and :bottom components may be stretched horizontally, while the + :left and :right components may be stretched vertically. The :center component + will be sized to fill the remaining space. Each component's extent on the + secondary axis is determined by gfw:preferred-size. + + + + + + See gfw:layout-manager. + + + + + See gfw:layout-manager. + + + + + See gfw:layout-manager. + + + + + See gfw:layout-manager. + + + + + See gfw:layout-manager. + + + + + See gfw:layout-manager. + + + + + See gfw:layout-manager. + + + + + + @@ -30,7 +154,7 @@ An integer value specifying the number of pixels - between succeeding child widgets. + between neighboring child widgets. @@ -171,6 +295,7 @@ + gfw:border-layout gfw:flow-layout gfw:heap-layout @@ -187,22 +312,29 @@ - An integer value specifying margin thickness in pixels. + An integer value specifying the thickness of the margin + between the layout area and the bottom edge of the container, in pixels. - An integer value specifying margin thickness in pixels. + An integer value specifying the thickness of the + margin between the layout area and the left edge of the container, + in pixels. - An integer value specifying margin thickness in pixels. + An integer value specifying the thickness of the + margin between the layout area and the right edge of the container, + in pixels. - An integer value specifying margin thickness in pixels. + An integer value specifying the thickness of the + margin between the layout area and the top edge of the container, + in pixels. @@ -2159,10 +2291,9 @@ positioning 's children. - + - A gfw:window or other type containing - children. + An object whose position and size are managed by . @@ -2178,9 +2309,9 @@ Each gfw:layout-manager subclass can support attributes - that apply to each child of , which this function allows to be set + that apply to each , which this function allows to be set or retrieved. After setting attribute values, call gfw:layout - on . + on the container managed by . @@ -2493,7 +2624,7 @@ - undefined + list @@ -2539,7 +2670,7 @@ - undefined + gfs:size Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Nov 13 01:58:13 2006 @@ -149,6 +149,7 @@ (:file "panel") (:file "dialog") (:file "layout") + (:file "border-layout") (:file "heap-layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Nov 13 01:58:13 2006 @@ -59,9 +59,11 @@ ;; constants ;; methods, functions, macros + #:copy-rectangle #:copy-point #:copy-size #:copy-span + #:create-rectangle #:detail #:dispose #:disposed-p @@ -346,6 +348,7 @@ #:auto-vscroll-p #:background-color #:background-pattern + #:border-layout #:border-width #:bottom-margin-of #:capture-mouse @@ -365,7 +368,9 @@ #:column-index #:column-order #:columns + #:compute-layout #:compute-outer-size + #:compute-size #:copy-area #:copy-text #:cut-text Added: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Mon Nov 13 01:58:13 2006 @@ -0,0 +1,81 @@ +;;;; +;;;; border-layout-unit-tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defvar *all-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-3*))) + +(define-test border-layout-test1 + ;; regions: all + ;; spacing: 0 + ;; margins: 0 + ;; + (let* ((layout (make-border-layout *all-border-kids*)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) + (expected-rects '((0 45 80 5) (60 5 20 40) (0 5 20 40) (0 0 80 5) (20 5 40 40)))) + (assert-equal 80 (gfs:size-width size)) + (assert-equal 50 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test border-layout-test2 + ;; regions: all but center + ;; spacing: 0 + ;; margins: 0 + ;; + (let* ((kids (append (butlast *all-border-kids*) '(nil))) + (layout (make-border-layout kids)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) + (expected-rects '((0 15 40 5) (20 5 20 10) (0 5 20 10) (0 0 40 5)))) + (assert-equal 40 (gfs:size-width size)) + (assert-equal 20 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test border-layout-test3 + ;; regions: center only + ;; spacing: 0 + ;; margins: 0 + ;; + (let* ((kids (append '(nil nil nil nil) (last *all-border-kids*))) + (layout (make-border-layout kids)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) + (expected-rects '((0 0 40 40)))) + (assert-equal 40 (gfs:size-width size)) + (assert-equal 40 (gfs:size-height size)) + (validate-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Mon Nov 13 01:58:13 2006 @@ -33,17 +33,12 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *large-size* (gfs:make-size :width 25 :height 5)) -(defvar *small-size* (gfs:make-size :width 20 :height 10)) - -(defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*))) -(defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *large-size*) - (make-instance 'mock-widget :min-size *small-size*))) - -(defvar *flow-container* (make-instance 'mock-container)) +(defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-2*))) +(defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*))) (define-test flow-layout-test1 ;; orient: horizontal @@ -55,12 +50,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal))) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) - (assert-equal 60 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 60 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test2 ;; orient: vertical @@ -72,12 +67,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical))) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test3 ;; orient: horizontal @@ -89,9 +84,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) - (data (gfw::compute-layout layout *flow-container* 45 -1)) + (data (gfw::compute-layout layout *mock-container* 45 -1)) (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test4 ;; orient: vertical @@ -103,9 +98,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) - (data (gfw::compute-layout layout *flow-container* -1 25)) + (data (gfw::compute-layout layout *mock-container* -1 25)) (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test5 ;; orient: horizontal @@ -117,9 +112,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) - (data (gfw::compute-layout layout *flow-container* 45 18)) + (data (gfw::compute-layout layout *mock-container* 45 18)) (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test6 ;; orient: vertical @@ -131,9 +126,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) - (data (gfw::compute-layout layout *flow-container* 30 25)) + (data (gfw::compute-layout layout *mock-container* 30 25)) (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test7 ;; orient: horizontal @@ -145,12 +140,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 4)) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) - (assert-equal 68 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 68 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test8 ;; orient: vertical @@ -162,12 +157,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 4)) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 38 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 38 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test9 ;; orient: horizontal @@ -179,9 +174,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)) - (data (gfw::compute-layout layout *flow-container* 45 18)) + (data (gfw::compute-layout layout *mock-container* 45 18)) (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test10 ;; orient: vertical @@ -193,9 +188,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)) - (data (gfw::compute-layout layout *flow-container* 30 25)) + (data (gfw::compute-layout layout *mock-container* 30 25)) (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test11 ;; orient: horizontal @@ -207,12 +202,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3)) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) - (assert-equal 63 (gfs:size-width size)) - (assert-equal 13 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 63 (gfs:size-width size)) + (assert-equal 13 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test12 ;; orient: vertical @@ -224,12 +219,12 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3)) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 23 (gfs:size-width size)) - (assert-equal 33 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 23 (gfs:size-width size)) + (assert-equal 33 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test13 ;; orient: horizontal @@ -241,12 +236,12 @@ ;; kids: mixed ;; (let* ((layout (make-flow-layout *flow-mixed-kids* '(:horizontal :normalize))) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) - (assert-equal 75 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 75 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) (define-test flow-layout-test14 ;; orient: vertical @@ -258,9 +253,9 @@ ;; kids: mixed ;; (let* ((layout (make-flow-layout *flow-mixed-kids* '(:vertical :normalize))) - (size (gfw::compute-size layout *flow-container* -1 -1)) - (data (gfw::compute-layout layout *flow-container* -1 -1)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) - (assert-equal 25 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-rects data expected-rects))) + (assert-equal 25 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Mon Nov 13 01:58:13 2006 @@ -36,14 +36,21 @@ (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle (cffi:make-pointer 1234))) (widget2 (make-instance 'mock-widget :handle (cffi:make-pointer 5678)))) - (let ((data1 `(,widget1 (a 1 b 2))) - (data2 `(,widget2 (a 10 c 30))) + (let ((data1 (list widget1 (list 'a 1 'b 2))) + (data2 (list widget2 (list 'a 10 'c 30))) (layout (make-instance 'gfw:layout-manager))) (setf (slot-value layout 'gfw::data) (list data1 data2)) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) (assert-equal 2 (gfw:layout-attribute layout widget1 'b)) + (let ((tmp (gfw::obtain-children-with-attribute layout 'b))) + (assert-equal 1 (length tmp)) + (assert-true (cffi:pointer-eq (gfs:handle (car (first tmp))) (gfs:handle widget1)))) (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (let ((tmp (gfw::obtain-children-with-attribute layout 'c))) + (assert-equal 1 (length tmp)) + (assert-true (cffi:pointer-eq (gfs:handle (car (first tmp))) (gfs:handle widget2)))) + (assert-true (null (gfw::obtain-children-with-attribute layout 'd))) (setf (gfw:layout-attribute layout widget1 'b) 66 (gfw:layout-attribute layout widget2 'd) 100) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Mon Nov 13 01:58:13 2006 @@ -57,6 +57,8 @@ :initarg :visibility :initform t))) +(defvar *mock-container* (make-instance 'mock-container)) + (defmethod gfw:visible-p ((self mock-container)) (visibility-of self)) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Mon Nov 13 01:58:13 2006 @@ -33,6 +33,10 @@ (in-package :graphic-forms.uitoolkit.tests) +(defvar *child-size-1* (gfs:make-size :width 25 :height 5)) +(defvar *child-size-2* (gfs:make-size :width 20 :height 10)) +(defvar *child-size-3* (gfs:make-size :width 40 :height 40)) + (defun make-flow-layout (kids style &optional spacing left-margin top-margin right-margin bottom-margin) (let ((layout (make-instance 'gfw:flow-layout :style style @@ -44,6 +48,34 @@ (loop for kid in kids do (gfw::append-layout-item layout kid)) layout)) +(defun make-border-layout (kids &optional spacing left-margin top-margin right-margin bottom-margin) + (let ((layout (make-instance 'gfw:border-layout + :left-margin (or left-margin 0) + :top-margin (or top-margin 0) + :right-margin (or right-margin 0) + :bottom-margin (or bottom-margin 0))) + (top-kid (first kids)) + (right-kid (second kids)) + (bottom-kid (third kids)) + (left-kid (fourth kids)) + (center-kid (fifth kids))) + (when top-kid + (gfw::append-layout-item layout top-kid) + (setf (gfw:layout-attribute layout top-kid :top) t)) + (when right-kid + (gfw::append-layout-item layout right-kid) + (setf (gfw:layout-attribute layout right-kid :right) t)) + (when bottom-kid + (gfw::append-layout-item layout bottom-kid) + (setf (gfw:layout-attribute layout bottom-kid :bottom) t)) + (when left-kid + (gfw::append-layout-item layout left-kid) + (setf (gfw:layout-attribute layout left-kid :left) t)) + (when center-kid + (gfw::append-layout-item layout center-kid) + (setf (gfw:layout-attribute layout center-kid :center) t)) + layout)) + (defun validate-image (image expected-size expected-depth) (declare (ignore expected-depth)) (assert-false (null image)) @@ -52,6 +84,7 @@ (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) (defun validate-rects (entries expected-rects) + (assert-equal (length expected-rects) (length entries)) (let ((actual-rects (loop for entry in entries collect (cdr entry)))) (mapc #'(lambda (expected actual) (let ((pnt-a (gfs:location actual)) Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Mon Nov 13 01:58:13 2006 @@ -41,6 +41,11 @@ (defstruct span (start 0) (end 0)) +(declaim (inline create-rectangle)) +(defun create-rectangle (&key (height 0) (width 0) (x 0) (y 0)) + (make-rectangle :location (make-point :x x :y y) + :size (make-size :width width :height height))) + (declaim (inline location)) (defun location (rect) (rectangle-location rect)) Added: trunk/src/uitoolkit/widgets/border-layout.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/border-layout.lisp Mon Nov 13 01:58:13 2006 @@ -0,0 +1,163 @@ +;;;; +;;;; border-layout.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; helpers +;;; + +(declaim (inline total-border-layout-width)) +(defun total-border-layout-width (cwidth twidth lwidth bwidth rwidth) + (max twidth bwidth (+ lwidth cwidth rwidth))) + +(declaim (inline inside-border-layout-width)) +(defun inside-border-layout-width (cwidth twidth lwidth bwidth rwidth) + (max cwidth (- twidth lwidth rwidth) (- bwidth lwidth rwidth))) + +(declaim (inline inside-border-layout-height)) +(defun inside-border-layout-height (cheight lheight rheight) + (max cheight lheight rheight)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-border-components ((layout center top left bottom right) &body body) + `(progn + (let ((,center (first (obtain-children-with-attribute ,layout :center))) + (,top (first (obtain-children-with-attribute ,layout :top))) + (,left (first (obtain-children-with-attribute ,layout :left))) + (,bottom (first (obtain-children-with-attribute ,layout :bottom))) + (,right (first (obtain-children-with-attribute ,layout :right)))) + , at body))) + + (defmacro with-border-sizes ((layout center top left bottom right + total-width inside-width inside-height) &body body) + (let ((nil-size (gensym)) + (c-size (gensym)) + (t-size (gensym)) + (l-size (gensym)) + (b-size (gensym)) + (r-size (gensym)) + (c-widget (gensym)) + (t-widget (gensym)) + (l-widget (gensym)) + (r-widget (gensym)) + (b-widget (gensym))) + `(with-border-components (,layout ,c-widget ,t-widget ,l-widget ,b-widget ,r-widget) + (let* ((,nil-size (gfs:make-size)) + (,c-size (if ,c-widget (preferred-size (first ,c-widget) -1 -1) ,nil-size)) + (,t-size (if ,t-widget (preferred-size (first ,t-widget) -1 -1) ,nil-size)) + (,l-size (if ,l-widget (preferred-size (first ,l-widget) -1 -1) ,nil-size)) + (,b-size (if ,b-widget (preferred-size (first ,b-widget) -1 -1) ,nil-size)) + (,r-size (if ,r-widget (preferred-size (first ,r-widget) -1 -1) ,nil-size)) + (,center (cons (first ,c-widget) ,c-size)) + (,top (cons (first ,t-widget) ,t-size)) + (,left (cons (first ,l-widget) ,l-size)) + (,bottom (cons (first ,b-widget) ,b-size)) + (,right (cons (first ,r-widget) ,r-size)) + (,total-width (total-border-layout-width (gfs:size-width ,c-size) + (gfs:size-width ,t-size) + (gfs:size-width ,l-size) + (gfs:size-width ,b-size) + (gfs:size-width ,r-size))) + (,inside-width (inside-border-layout-width (gfs:size-width ,c-size) + (gfs:size-width ,t-size) + (gfs:size-width ,l-size) + (gfs:size-width ,b-size) + (gfs:size-width ,r-size))) + (,inside-height (inside-border-layout-height (gfs:size-height ,c-size) + (gfs:size-height ,l-size) + (gfs:size-height ,r-size)))) + , at body))))) + +;;; +;;; methods +;;; + +(defmethod compute-size ((self border-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((layout-size (gfs:make-size))) + (with-border-sizes (self unused1 top unused2 bottom unused3 total-width unused4 inside-height) + (declare (ignore unused1 unused2 unused3 unused4)) + ;; + ;; remember that top and/or bottom might be nil + ;; + (setf (gfs:size-width layout-size) total-width + (gfs:size-height layout-size) (+ (gfs:size-height (cdr top)) + inside-height + (gfs:size-height (cdr bottom))))) + (if (>= width-hint 0) + (setf (gfs:size-width layout-size) width-hint)) + (if (>= height-hint 0) + (setf (gfs:size-height layout-size) height-hint)) + layout-size)) + +(defmethod compute-layout ((self border-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((results nil)) + (with-border-sizes (self center top left bottom right total-width inside-width inside-height) + (let ((left-width (gfs:size-width (cdr left))) + (right-width (gfs:size-width (cdr right))) + (top-height (gfs:size-height (cdr top))) + (bottom-height (gfs:size-height (cdr bottom)))) + (when (car center) + (setf (cdr center) + (gfs:create-rectangle :x left-width + :y top-height + :width inside-width + :height inside-height)) + (push center results)) + (when (car top) + (setf (cdr top) + (gfs:create-rectangle :width total-width + :height top-height)) + (push top results)) + (when (car left) + (setf (cdr left) + (gfs:create-rectangle :y top-height + :width left-width + :height inside-height)) + (push left results)) + (when (car right) + (setf (cdr right) + (gfs:create-rectangle :x (+ left-width inside-width) + :y top-height + :width right-width + :height inside-height)) + (push right results)) + (when (car bottom) + (setf (cdr bottom) + (gfs:create-rectangle :y (+ top-height inside-height) + :width total-width + :height bottom-height)) + (push bottom results)))) + results)) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Mon Nov 13 01:58:13 2006 @@ -67,16 +67,16 @@ (let* ((size (client-size container)) (horz-margin (+ (left-margin-of self) (right-margin-of self))) (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) - (new-size (gfs:make-size :width (- (if (> width-hint horz-margin) - width-hint - (gfs:size-width size)) - horz-margin) - :height (- (if (> height-hint vert-margin) - height-hint - (gfs:size-height size)) - vert-margin))) - (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) - (bounds (gfs:make-rectangle :size new-size :location new-pnt))) + (bounds (gfs:create-rectangle :x (left-margin-of self) + :y (top-margin-of self) + :width (- (if (> width-hint horz-margin) + width-hint + (gfs:size-width size)) + horz-margin) + :height (- (if (> height-hint vert-margin) + height-hint + (gfs:size-height size)) + vert-margin)))) (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Mon Nov 13 01:58:13 2006 @@ -59,6 +59,9 @@ :initform nil)) (:documentation "Subclasses implement layout strategies to manage space within windows.")) +(defclass border-layout (layout-manager) () + (:documentation "Window children are assigned a position on the edges or center of a container.")) + (defclass flow-layout (layout-manager) ((spacing :accessor spacing-of Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Mon Nov 13 01:58:13 2006 @@ -39,20 +39,26 @@ (defun layout-attribute (layout thing name) "Return the value associated with name for thing; or NIL if no value is set." - (let ((items (assoc thing (data-of layout)))) - (unless items + (let ((item-data (assoc thing (data-of layout)))) + (unless item-data (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) - (getf (first (rest items)) name))) + (getf (second item-data) name))) (defun set-layout-attribute (layout thing name value) "Sets a value associated with name for thing in the specified layout." - (let ((items (assoc thing (data-of layout)))) - (unless items + (let ((item-data (assoc thing (data-of layout)))) + (unless item-data (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) - (setf (getf (first (rest items)) name) value))) + (setf (getf (second item-data) name) value))) (defsetf layout-attribute set-layout-attribute) +(defun obtain-children-with-attribute (layout name) + "Returns a list of layout entries that have the named attribute." + (loop for pair in (data-of layout) + when (getf (second pair) name) + collect pair)) + (defun append-layout-item (layout thing) "Adds thing to layout. Duplicate entries are not prevented." (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) @@ -68,24 +74,25 @@ (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) (loop for k in kid-specs for rect = (cdr k) + for widget = (car k) for size = (gfs:size rect) for pnt = (gfs:location rect) do (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) + (gfs::set-window-pos (gfs:handle widget) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) (gfs:size-width size) (gfs:size-height size) - (funcall flags-func (car k))) + (funcall flags-func widget)) (gfs::defer-window-pos hdwp - (gfs:handle (car k)) + (gfs:handle widget) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) (gfs:size-width size) (gfs:size-height size) - (funcall flags-func (car k))))) + (funcall flags-func widget)))) (unless (gfs:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp)))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Mon Nov 13 01:58:13 2006 @@ -43,5 +43,6 @@ "graphics-context-unit-tests" "image-unit-tests" "icon-bundle-unit-tests" "layout-unit-tests" "flow-layout-unit-tests" "widget-unit-tests" - "item-manager-unit-tests" "misc-unit-tests") + "item-manager-unit-tests" "misc-unit-tests" + "border-layout-unit-tests") do (load (merge-pathnames file *gf-tests-dir*)))) From junrue at common-lisp.net Mon Nov 13 23:23:40 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 13 Nov 2006 18:23:40 -0500 (EST) Subject: [graphic-forms-cvs] r394 - trunk/src/tests/uitoolkit Message-ID: <20061113232340.46F0371035@common-lisp.net> Author: junrue Date: Mon Nov 13 18:23:39 2006 New Revision: 394 Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp Log: implemented define-layout-test convenience macro Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Mon Nov 13 18:23:39 2006 @@ -39,43 +39,26 @@ (make-instance 'mock-widget :min-size *child-size-2*) (make-instance 'mock-widget :min-size *child-size-3*))) -(define-test border-layout-test1 - ;; regions: all - ;; spacing: 0 - ;; margins: 0 - ;; - (let* ((layout (make-border-layout *all-border-kids*)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 45 80 5) (60 5 20 40) (0 5 20 40) (0 0 80 5) (20 5 40 40)))) - (assert-equal 80 (gfs:size-width size)) - (assert-equal 50 (gfs:size-height size)) - (validate-rects data expected-rects))) +(defvar *outer-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*) + nil)) -(define-test border-layout-test2 - ;; regions: all but center - ;; spacing: 0 - ;; margins: 0 - ;; - (let* ((kids (append (butlast *all-border-kids*) '(nil))) - (layout (make-border-layout kids)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 15 40 5) (20 5 20 10) (0 5 20 10) (0 0 40 5)))) - (assert-equal 40 (gfs:size-width size)) - (assert-equal 20 (gfs:size-height size)) - (validate-rects data expected-rects))) +(defvar *center-border-kid* (list nil nil nil nil + (make-instance 'mock-widget :min-size *child-size-3*))) -(define-test border-layout-test3 - ;; regions: center only - ;; spacing: 0 - ;; margins: 0 - ;; - (let* ((kids (append '(nil nil nil nil) (last *all-border-kids*))) - (layout (make-border-layout kids)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 40 40)))) - (assert-equal 40 (gfs:size-width size)) - (assert-equal 40 (gfs:size-height size)) - (validate-rects data expected-rects))) +(define-layout-test border-layout-test1 + -1 -1 80 50 + '((0 45 80 5) (60 5 20 40) (0 5 20 40) (0 0 80 5) (20 5 40 40)) + #'make-border-layout *all-border-kids*) + +(define-layout-test border-layout-test2 + -1 -1 40 20 + '((0 15 40 5) (20 5 20 10) (0 5 20 10) (0 0 40 5)) + #'make-border-layout *outer-border-kids*) + +(define-layout-test border-layout-test3 + -1 -1 40 40 + '((0 0 40 40)) + #'make-border-layout *center-border-kid*) Modified: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Mon Nov 13 18:23:39 2006 @@ -40,222 +40,72 @@ (make-instance 'mock-widget :min-size *child-size-1*) (make-instance 'mock-widget :min-size *child-size-2*))) -(define-test flow-layout-test1 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal))) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) - (assert-equal 60 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test2 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical))) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test3 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width, unrestricted height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) - (data (gfw::compute-layout layout *mock-container* 45 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test4 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width, restricted height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) - (data (gfw::compute-layout layout *mock-container* -1 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test5 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) - (data (gfw::compute-layout layout *mock-container* 45 18)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test6 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) - (data (gfw::compute-layout layout *mock-container* 30 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test7 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 4)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) - (assert-equal 68 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test8 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 4)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 38 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test9 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)) - (data (gfw::compute-layout layout *mock-container* 45 18)) - (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test10 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)) - (data (gfw::compute-layout layout *mock-container* 30 25)) - (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) - (validate-rects data expected-rects))) - -(define-test flow-layout-test11 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) - (assert-equal 63 (gfs:size-width size)) - (assert-equal 13 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test12 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3)) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 23 (gfs:size-width size)) - (assert-equal 33 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test13 - ;; orient: horizontal - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-flow-layout *flow-mixed-kids* '(:horizontal :normalize))) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) - (assert-equal 75 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-rects data expected-rects))) - -(define-test flow-layout-test14 - ;; orient: vertical - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-flow-layout *flow-mixed-kids* '(:vertical :normalize))) - (size (gfw::compute-size layout *mock-container* -1 -1)) - (data (gfw::compute-layout layout *mock-container* -1 -1)) - (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) - (assert-equal 25 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-rects data expected-rects))) +(define-layout-test flow-layout-test1 + -1 -1 60 10 + '((0 0 20 10) (20 0 20 10) (40 0 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal)) + +(define-layout-test flow-layout-test2 + -1 -1 20 30 + '((0 0 20 10) (0 10 20 10) (0 20 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical)) + +(define-layout-test flow-layout-test3 + 45 -1 40 20 + '((0 0 20 10) (20 0 20 10) (0 10 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap)) + +(define-layout-test flow-layout-test4 + -1 25 20 20 + '((0 0 20 10) (0 10 20 10) (20 0 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap)) + +(define-layout-test flow-layout-test5 + 45 18 40 20 + '((0 0 20 10) (20 0 20 10) (0 10 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap)) + +(define-layout-test flow-layout-test6 + 30 25 40 20 + '((0 0 20 10) (0 10 20 10) (20 0 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap)) + +(define-layout-test flow-layout-test7 + -1 -1 68 10 + '((0 0 20 10) (24 0 20 10) (48 0 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal) 4) + +(define-layout-test flow-layout-test8 + -1 -1 20 38 + '((0 0 20 10) (0 14 20 10) (0 28 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical) 4) + +(define-layout-test flow-layout-test9 + 45 18 0 0 + '((0 0 20 10) (24 0 20 10) (0 14 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4) + +(define-layout-test flow-layout-test10 + 30 25 0 0 + '((0 0 20 10) (0 14 20 10) (24 0 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4) + +(define-layout-test flow-layout-test11 + -1 -1 63 13 + '((3 3 20 10) (23 3 20 10) (43 3 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3) + +(define-layout-test flow-layout-test12 + -1 -1 23 33 + '((0 0 20 10) (0 10 20 10) (0 20 20 10)) + #'make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3) + +(define-layout-test flow-layout-test13 + -1 -1 75 10 + '((0 0 25 10) (25 0 25 10) (50 0 25 10)) + #'make-flow-layout *flow-mixed-kids* '(:horizontal :normalize)) + +(define-layout-test flow-layout-test14 + -1 -1 25 30 + '((0 0 25 10) (0 10 25 10) (0 20 25 10)) + #'make-flow-layout *flow-mixed-kids* '(:vertical :normalize)) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Mon Nov 13 18:23:39 2006 @@ -95,3 +95,17 @@ (assert-equal (fourth expected) (gfs:size-height sz-a)))) expected-rects actual-rects))) + +(defmacro define-layout-test (name width-hint height-hint + expected-width expected-height expected-rects + factory &rest factory-args) + (let ((layout (gensym)) + (size (gensym)) + (data (gensym))) + `(define-test ,name + (let* ((,layout (apply ,factory (list , at factory-args))) + (,size (gfw::compute-size ,layout *mock-container* ,width-hint ,height-hint)) + (,data (gfw::compute-layout ,layout *mock-container* ,width-hint ,height-hint))) + (assert-equal ,expected-width (gfs::size-width ,size)) + (assert-equal ,expected-height (gfs::size-height ,size)) + (validate-rects ,data ,expected-rects))))) From junrue at common-lisp.net Fri Nov 17 19:34:42 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 17 Nov 2006 14:34:42 -0500 (EST) Subject: [graphic-forms-cvs] r395 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20061117193442.432F04044@common-lisp.net> Author: junrue Date: Fri Nov 17 14:34:40 2006 New Revision: 395 Modified: trunk/docs/manual/gfw-symbols.xml trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/widgets/border-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp Log: rewrote border-layout; added unit-test cases Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Fri Nov 17 14:34:40 2006 @@ -98,7 +98,11 @@ The :top and :bottom components may be stretched horizontally, while the :left and :right components may be stretched vertically. The :center component will be sized to fill the remaining space. Each component's extent on the - secondary axis is determined by gfw:preferred-size. + secondary axis is determined by gfw:preferred-size. When + positive width-hint and/or height-hint + values are provided to gfw:layout, the available space + is parceled out in amounts proportional to the preferred sizes for each + component. Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Fri Nov 17 14:34:40 2006 @@ -33,32 +33,66 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *all-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) - (make-instance 'mock-widget :min-size *child-size-2*) - (make-instance 'mock-widget :min-size *child-size-1*) - (make-instance 'mock-widget :min-size *child-size-2*) - (make-instance 'mock-widget :min-size *child-size-3*))) - -(defvar *outer-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) - (make-instance 'mock-widget :min-size *child-size-2*) - (make-instance 'mock-widget :min-size *child-size-1*) - (make-instance 'mock-widget :min-size *child-size-2*) +(defvar *all-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top + (make-instance 'mock-widget :min-size *child-size-2*) ; right + (make-instance 'mock-widget :min-size *child-size-1*) ; bottom + (make-instance 'mock-widget :min-size *child-size-2*) ; left + (make-instance 'mock-widget :min-size *child-size-3*))) ; center + +(defvar *outer-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top + (make-instance 'mock-widget :min-size *child-size-2*) ; right + (make-instance 'mock-widget :min-size *child-size-1*) ; bottom + (make-instance 'mock-widget :min-size *child-size-2*) ; left nil)) +(defvar *top-right-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top + (make-instance 'mock-widget :min-size *child-size-2*) ; right + nil nil nil)) + +(defvar *top-bottom-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top + nil + (make-instance 'mock-widget :min-size *child-size-1*) ; bottom + nil nil)) + (defvar *center-border-kid* (list nil nil nil nil (make-instance 'mock-widget :min-size *child-size-3*))) +;;; +;;; NOTE: the rects to be validated in each test must be specified in the +;;; the following order: center, top, left, bottom, right +;;; + (define-layout-test border-layout-test1 -1 -1 80 50 - '((0 45 80 5) (60 5 20 40) (0 5 20 40) (0 0 80 5) (20 5 40 40)) + '((20 5 40 40) (0 0 80 5) (0 5 20 40) (0 45 80 5) (60 5 20 40)) #'make-border-layout *all-border-kids*) (define-layout-test border-layout-test2 -1 -1 40 20 - '((0 15 40 5) (20 5 20 10) (0 5 20 10) (0 0 40 5)) + '((0 0 40 5) (0 5 20 10) (0 15 40 5) (20 5 20 10)) #'make-border-layout *outer-border-kids*) (define-layout-test border-layout-test3 -1 -1 40 40 '((0 0 40 40)) #'make-border-layout *center-border-kid*) + +(define-layout-test border-layout-test4 + -1 -1 25 15 + '((0 0 25 5) (0 5 20 10)) + #'make-border-layout *top-right-border-kids*) + +(define-layout-test border-layout-test5 + -1 -1 25 10 + '((0 0 25 5) (0 5 25 5)) + #'make-border-layout *top-bottom-border-kids*) + +(define-layout-test border-layout-test6 + 26 -1 26 50 + '((6 5 13 40) (0 0 26 5) (0 5 6 40) (0 45 26 5) (19 5 6 40)) + #'make-border-layout *all-border-kids*) + +(define-layout-test border-layout-test7 + -1 25 80 25 + '((20 2 40 20) (0 0 80 2) (0 2 20 20) (0 22 80 2) (60 2 20 20)) + #'make-border-layout *all-border-kids*) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Fri Nov 17 14:34:40 2006 @@ -59,21 +59,12 @@ (bottom-kid (third kids)) (left-kid (fourth kids)) (center-kid (fifth kids))) - (when top-kid - (gfw::append-layout-item layout top-kid) - (setf (gfw:layout-attribute layout top-kid :top) t)) - (when right-kid - (gfw::append-layout-item layout right-kid) - (setf (gfw:layout-attribute layout right-kid :right) t)) - (when bottom-kid - (gfw::append-layout-item layout bottom-kid) - (setf (gfw:layout-attribute layout bottom-kid :bottom) t)) - (when left-kid - (gfw::append-layout-item layout left-kid) - (setf (gfw:layout-attribute layout left-kid :left) t)) - (when center-kid - (gfw::append-layout-item layout center-kid) - (setf (gfw:layout-attribute layout center-kid :center) t)) + (loop for kid in kids + for region in '(:top :left :bottom :right :center) + when kid + do (progn + (gfw::append-layout-item layout kid) + (setf (gfw:layout-attribute layout kid region) t))) layout)) (defun validate-image (image expected-size expected-depth) Modified: trunk/src/uitoolkit/widgets/border-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/border-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/border-layout.lisp Fri Nov 17 14:34:40 2006 @@ -37,67 +37,128 @@ ;;; helpers ;;; -(declaim (inline total-border-layout-width)) -(defun total-border-layout-width (cwidth twidth lwidth bwidth rwidth) - (max twidth bwidth (+ lwidth cwidth rwidth))) - -(declaim (inline inside-border-layout-width)) -(defun inside-border-layout-width (cwidth twidth lwidth bwidth rwidth) - (max cwidth (- twidth lwidth rwidth) (- bwidth lwidth rwidth))) - -(declaim (inline inside-border-layout-height)) -(defun inside-border-layout-height (cheight lheight rheight) - (max cheight lheight rheight)) - (eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro with-border-components ((layout center top left bottom right) &body body) - `(progn - (let ((,center (first (obtain-children-with-attribute ,layout :center))) - (,top (first (obtain-children-with-attribute ,layout :top))) - (,left (first (obtain-children-with-attribute ,layout :left))) - (,bottom (first (obtain-children-with-attribute ,layout :bottom))) - (,right (first (obtain-children-with-attribute ,layout :right)))) - , at body))) - - (defmacro with-border-sizes ((layout center top left bottom right - total-width inside-width inside-height) &body body) - (let ((nil-size (gensym)) - (c-size (gensym)) - (t-size (gensym)) - (l-size (gensym)) - (b-size (gensym)) - (r-size (gensym)) - (c-widget (gensym)) - (t-widget (gensym)) - (l-widget (gensym)) - (r-widget (gensym)) - (b-widget (gensym))) - `(with-border-components (,layout ,c-widget ,t-widget ,l-widget ,b-widget ,r-widget) - (let* ((,nil-size (gfs:make-size)) - (,c-size (if ,c-widget (preferred-size (first ,c-widget) -1 -1) ,nil-size)) - (,t-size (if ,t-widget (preferred-size (first ,t-widget) -1 -1) ,nil-size)) - (,l-size (if ,l-widget (preferred-size (first ,l-widget) -1 -1) ,nil-size)) - (,b-size (if ,b-widget (preferred-size (first ,b-widget) -1 -1) ,nil-size)) - (,r-size (if ,r-widget (preferred-size (first ,r-widget) -1 -1) ,nil-size)) - (,center (cons (first ,c-widget) ,c-size)) - (,top (cons (first ,t-widget) ,t-size)) - (,left (cons (first ,l-widget) ,l-size)) - (,bottom (cons (first ,b-widget) ,b-size)) - (,right (cons (first ,r-widget) ,r-size)) - (,total-width (total-border-layout-width (gfs:size-width ,c-size) - (gfs:size-width ,t-size) - (gfs:size-width ,l-size) - (gfs:size-width ,b-size) - (gfs:size-width ,r-size))) - (,inside-width (inside-border-layout-width (gfs:size-width ,c-size) - (gfs:size-width ,t-size) - (gfs:size-width ,l-size) - (gfs:size-width ,b-size) - (gfs:size-width ,r-size))) - (,inside-height (inside-border-layout-height (gfs:size-height ,c-size) - (gfs:size-height ,l-size) - (gfs:size-height ,r-size)))) - , at body))))) + (defstruct borders layout hint-size inside-size outer-size + pref-top-height pref-left-width pref-right-width pref-bottom-height + center-widget top-widget left-widget bottom-widget right-widget + center-rect top-rect left-rect bottom-rect right-rect)) + +(defun map-border-rects (data map-func) + (loop for region in '(center top left bottom right) + for sym = (symbol-name region) + for widget-acc = (find-symbol (concatenate 'string "BORDERS-" sym "-WIDGET") :gfw) + for rect-acc = (find-symbol (concatenate 'string "BORDERS-" sym "-RECT") :gfw) + for widget = (funcall widget-acc data) + when widget + collect (funcall map-func widget (funcall rect-acc data)))) + +(defun init-borders (layout width-hint height-hint) + (let* ((data (make-borders + :layout layout + :hint-size (gfs:make-size :width width-hint + :height height-hint) + :center-widget (first (first (obtain-children-with-attribute layout :center))) + :top-widget (first (first (obtain-children-with-attribute layout :top))) + :left-widget (first (first (obtain-children-with-attribute layout :left))) + :bottom-widget (first (first (obtain-children-with-attribute layout :bottom))) + :right-widget (first (first (obtain-children-with-attribute layout :right))))) + (c-size (if (borders-center-widget data) + (preferred-size (borders-center-widget data) -1 -1) + (gfs:size *empty-rect*))) + (t-size (if (borders-top-widget data) + (preferred-size (borders-top-widget data) -1 -1) + (gfs:size *empty-rect*))) + (l-size (if (borders-left-widget data) + (preferred-size (borders-left-widget data) -1 -1) + (gfs:size *empty-rect*))) + (b-size (if (borders-bottom-widget data) + (preferred-size (borders-bottom-widget data) -1 -1) + (gfs:size *empty-rect*))) + (r-size (if (borders-right-widget data) + (preferred-size (borders-right-widget data) -1 -1) + (gfs:size *empty-rect*)))) + (setf (borders-pref-top-height data) (gfs:size-height t-size) + (borders-pref-left-width data) (gfs:size-width l-size) + (borders-pref-right-width data) (gfs:size-width r-size) + (borders-pref-bottom-height data) (gfs:size-height b-size)) + (setf (borders-inside-size data) + (gfs:make-size :width (max (gfs:size-width c-size) + (- (gfs:size-width t-size) + (gfs:size-width l-size) + (gfs:size-width r-size)) + (- (gfs:size-width b-size) + (gfs:size-width l-size) + (gfs:size-width r-size))) + :height (max (gfs:size-height l-size) + (gfs:size-height c-size) + (gfs:size-height r-size)))) + (setf (borders-outer-size data) + (gfs:make-size :width (max (gfs:size-width t-size) + (gfs:size-width b-size) + (+ (gfs:size-width l-size) + (gfs:size-width c-size) + (gfs:size-width r-size))) + :height (+ (gfs:size-height t-size) + (gfs:size-height (borders-inside-size data)) + (gfs:size-height b-size)))) + data)) + +(defun top-border-rect (data) + (unless (borders-top-widget data) + (return-from top-border-rect *empty-rect*)) + (or (borders-top-rect data) + (setf (borders-top-rect data) + (gfs:create-rectangle :width (gfs:size-width (borders-outer-size data)) + :height (borders-pref-top-height data))))) + +(defun bottom-border-rect (data) + (unless (borders-bottom-widget data) + (return-from bottom-border-rect *empty-rect*)) + (or (borders-bottom-rect data) + (let ((ypos (- (gfs:size-height (borders-outer-size data)) + (borders-pref-bottom-height data)))) + (setf (borders-bottom-rect data) + (gfs:create-rectangle :y ypos + :width (gfs:size-width (borders-outer-size data)) + :height (borders-pref-bottom-height data)))))) + +(defun left-border-rect (data) + (unless (borders-left-widget data) + (return-from left-border-rect *empty-rect*)) + (or (borders-left-rect data) + (let ((ypos (gfs:size-height (gfs:size (top-border-rect data)))) + (inside-height (gfs:size-height (borders-inside-size data)))) + (setf (borders-left-rect data) + (gfs:create-rectangle :y ypos + :width (borders-pref-left-width data) + :height inside-height))))) + +(defun right-border-rect (data) + (unless (borders-right-widget data) + (return-from right-border-rect *empty-rect*)) + (or (borders-right-rect data) + (let ((xpos (+ (gfs:size-width (gfs:size (left-border-rect data))) + (gfs:size-width (gfs:size (center-border-rect data))))) + (ypos (gfs:size-height (gfs:size (top-border-rect data)))) + (inside-height (gfs:size-height (borders-inside-size data)))) + (setf (borders-right-rect data) + (gfs:create-rectangle :x xpos + :y ypos + :width (borders-pref-right-width data) + :height inside-height))))) + +(defun center-border-rect (data) + (unless (borders-center-widget data) + (return-from center-border-rect *empty-rect*)) + (or (borders-center-rect data) + (let ((xpos (gfs:size-width (gfs:size (left-border-rect data)))) + (ypos (gfs:size-height (gfs:size (top-border-rect data)))) + (size (borders-inside-size data))) + (setf (borders-center-rect data) + (gfs:create-rectangle :x xpos + :y ypos + :width (gfs:size-width size) + :height (gfs:size-height size)))))) ;;; ;;; methods @@ -105,59 +166,28 @@ (defmethod compute-size ((self border-layout) (container layout-managed) width-hint height-hint) (cleanup-disposed-items self) - (let ((layout-size (gfs:make-size))) - (with-border-sizes (self unused1 top unused2 bottom unused3 total-width unused4 inside-height) - (declare (ignore unused1 unused2 unused3 unused4)) - ;; - ;; remember that top and/or bottom might be nil - ;; - (setf (gfs:size-width layout-size) total-width - (gfs:size-height layout-size) (+ (gfs:size-height (cdr top)) - inside-height - (gfs:size-height (cdr bottom))))) + (let ((size (borders-outer-size (init-borders self width-hint height-hint)))) (if (>= width-hint 0) - (setf (gfs:size-width layout-size) width-hint)) + (setf (gfs:size-width size) width-hint)) (if (>= height-hint 0) - (setf (gfs:size-height layout-size) height-hint)) - layout-size)) + (setf (gfs:size-height size) height-hint)) + size)) (defmethod compute-layout ((self border-layout) (container layout-managed) width-hint height-hint) (cleanup-disposed-items self) - (let ((results nil)) - (with-border-sizes (self center top left bottom right total-width inside-width inside-height) - (let ((left-width (gfs:size-width (cdr left))) - (right-width (gfs:size-width (cdr right))) - (top-height (gfs:size-height (cdr top))) - (bottom-height (gfs:size-height (cdr bottom)))) - (when (car center) - (setf (cdr center) - (gfs:create-rectangle :x left-width - :y top-height - :width inside-width - :height inside-height)) - (push center results)) - (when (car top) - (setf (cdr top) - (gfs:create-rectangle :width total-width - :height top-height)) - (push top results)) - (when (car left) - (setf (cdr left) - (gfs:create-rectangle :y top-height - :width left-width - :height inside-height)) - (push left results)) - (when (car right) - (setf (cdr right) - (gfs:create-rectangle :x (+ left-width inside-width) - :y top-height - :width right-width - :height inside-height)) - (push right results)) - (when (car bottom) - (setf (cdr bottom) - (gfs:create-rectangle :y (+ top-height inside-height) - :width total-width - :height bottom-height)) - (push bottom results)))) - results)) + (let ((data (init-borders self width-hint height-hint))) + (loop for func in (list #'top-border-rect #'bottom-border-rect + #'left-border-rect #'right-border-rect + #'center-border-rect) + do (funcall func data)) + (if (or (>= width-hint 0) (>= height-hint 0)) + (let ((total-size (borders-outer-size data)) + (hint-size (gfs:make-size :width width-hint :height height-hint))) + (map-border-rects data + (lambda (widget rect) + (declare (ignore widget)) + (let ((pnt (gfs:location rect)) + (size (gfs:size rect))) + (setf (gfs:location rect) (scale-point total-size hint-size pnt) + (gfs:size rect) (scale-size total-size hint-size size))))))) + (map-border-rects data #'cons))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Nov 17 14:34:40 2006 @@ -70,6 +70,37 @@ (defun cleanup-disposed-items (layout) (setf (data-of layout) (remove-if #'gfs:disposed-p (data-of layout) :key #'first))) +(declaim (inline scale-coord)) +(defun scale-coord (total hint orig-value) + (if (and (> total 0) (>= hint 0)) + (floor (* (/ hint total) orig-value)) + orig-value)) + +(declaim (inline scale-point)) +(defun scale-point (total-size hint-size orig-pnt) + (gfs:make-point :x (scale-coord (gfs:size-width total-size) + (gfs:size-width hint-size) + (gfs:point-x orig-pnt)) + :y (scale-coord (gfs:size-height total-size) + (gfs:size-height hint-size) + (gfs:point-y orig-pnt)))) + +(declaim (inline scale-size)) +(defun scale-size (total-size hint-size orig-size) + (gfs:make-size :width (scale-coord (gfs:size-width total-size) + (gfs:size-width hint-size) + (gfs:size-width orig-size)) + :height (scale-coord (gfs:size-height total-size) + (gfs:size-height hint-size) + (gfs:size-height orig-size)))) + +(declaim (inline scale-rectangle)) +(defun scale-rectangle (total-size hint-size orig-rect) + (let ((pnt (gfs:location orig-rect)) + (size (gfs:size orig-rect))) + (gfs:make-rectangle :location (scale-point total-size hint-size pnt) + :size (scale-size total-size hint-size size)))) + (defun arrange-hwnds (kid-specs flags-func) (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) (loop for k in kid-specs Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Fri Nov 17 14:34:40 2006 @@ -105,3 +105,5 @@ gfs::+swp-noownerzorder+ gfs::+swp-noactivate+ gfs::+swp-nocopybits+))) + +(defvar *empty-rect* (gfs:make-rectangle)) From junrue at common-lisp.net Fri Nov 17 23:46:34 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 17 Nov 2006 18:46:34 -0500 (EST) Subject: [graphic-forms-cvs] r396 - in trunk/src: tests/uitoolkit uitoolkit/widgets Message-ID: <20061117234634.A65226B005@common-lisp.net> Author: junrue Date: Fri Nov 17 18:46:33 2006 New Revision: 396 Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/widgets/border-layout.lisp Log: implemented border-layout margins Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Fri Nov 17 18:46:33 2006 @@ -93,6 +93,6 @@ #'make-border-layout *all-border-kids*) (define-layout-test border-layout-test7 - -1 25 80 25 - '((20 2 40 20) (0 0 80 2) (0 2 20 20) (0 22 80 2) (60 2 20 20)) - #'make-border-layout *all-border-kids*) + -1 -1 90 58 + '((24 8 40 40) (4 3 80 5) (4 8 20 40) (4 48 80 5) (64 8 20 40)) + #'make-border-layout *all-border-kids* 4 3 6 5) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Fri Nov 17 18:46:33 2006 @@ -48,19 +48,14 @@ (loop for kid in kids do (gfw::append-layout-item layout kid)) layout)) -(defun make-border-layout (kids &optional spacing left-margin top-margin right-margin bottom-margin) +(defun make-border-layout (kids &optional left-margin top-margin right-margin bottom-margin) (let ((layout (make-instance 'gfw:border-layout - :left-margin (or left-margin 0) + :left-margin (or left-margin 0) :top-margin (or top-margin 0) :right-margin (or right-margin 0) - :bottom-margin (or bottom-margin 0))) - (top-kid (first kids)) - (right-kid (second kids)) - (bottom-kid (third kids)) - (left-kid (fourth kids)) - (center-kid (fifth kids))) + :bottom-margin (or bottom-margin 0)))) (loop for kid in kids - for region in '(:top :left :bottom :right :center) + for region in '(:top :right :bottom :left :center) when kid do (progn (gfw::append-layout-item layout kid) Modified: trunk/src/uitoolkit/widgets/border-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/border-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/border-layout.lisp Fri Nov 17 18:46:33 2006 @@ -93,14 +93,18 @@ (gfs:size-height c-size) (gfs:size-height r-size)))) (setf (borders-outer-size data) - (gfs:make-size :width (max (gfs:size-width t-size) - (gfs:size-width b-size) - (+ (gfs:size-width l-size) - (gfs:size-width c-size) - (gfs:size-width r-size))) + (gfs:make-size :width (+ (max (gfs:size-width t-size) + (gfs:size-width b-size) + (+ (gfs:size-width l-size) + (gfs:size-width c-size) + (gfs:size-width r-size))) + (left-margin-of layout) + (right-margin-of layout)) :height (+ (gfs:size-height t-size) (gfs:size-height (borders-inside-size data)) - (gfs:size-height b-size)))) + (gfs:size-height b-size) + (top-margin-of layout) + (bottom-margin-of layout)))) data)) (defun top-border-rect (data) @@ -108,55 +112,68 @@ (return-from top-border-rect *empty-rect*)) (or (borders-top-rect data) (setf (borders-top-rect data) - (gfs:create-rectangle :width (gfs:size-width (borders-outer-size data)) - :height (borders-pref-top-height data))))) + (let ((layout (borders-layout data)) + (size (borders-outer-size data))) + (gfs:create-rectangle :x (left-margin-of layout) + :y (top-margin-of layout) + :width (- (gfs:size-width size) + (+ (left-margin-of layout) + (right-margin-of layout))) + :height (borders-pref-top-height data)))))) (defun bottom-border-rect (data) (unless (borders-bottom-widget data) (return-from bottom-border-rect *empty-rect*)) (or (borders-bottom-rect data) - (let ((ypos (- (gfs:size-height (borders-outer-size data)) - (borders-pref-bottom-height data)))) - (setf (borders-bottom-rect data) - (gfs:create-rectangle :y ypos - :width (gfs:size-width (borders-outer-size data)) + (setf (borders-bottom-rect data) + (let ((layout (borders-layout data)) + (size (borders-outer-size data))) + (gfs:create-rectangle :x (left-margin-of layout) + :y (- (gfs:size-height size) + (borders-pref-bottom-height data) + (bottom-margin-of layout)) + :width (- (gfs:size-width size) + (+ (left-margin-of layout) + (right-margin-of layout))) :height (borders-pref-bottom-height data)))))) (defun left-border-rect (data) (unless (borders-left-widget data) (return-from left-border-rect *empty-rect*)) (or (borders-left-rect data) - (let ((ypos (gfs:size-height (gfs:size (top-border-rect data)))) - (inside-height (gfs:size-height (borders-inside-size data)))) + (let ((layout (borders-layout data))) (setf (borders-left-rect data) - (gfs:create-rectangle :y ypos + (gfs:create-rectangle :x (left-margin-of layout) + :y (+ (top-margin-of layout) + (gfs:size-height (gfs:size (top-border-rect data)))) :width (borders-pref-left-width data) - :height inside-height))))) + :height (gfs:size-height (borders-inside-size data))))))) (defun right-border-rect (data) (unless (borders-right-widget data) (return-from right-border-rect *empty-rect*)) (or (borders-right-rect data) - (let ((xpos (+ (gfs:size-width (gfs:size (left-border-rect data))) - (gfs:size-width (gfs:size (center-border-rect data))))) - (ypos (gfs:size-height (gfs:size (top-border-rect data)))) - (inside-height (gfs:size-height (borders-inside-size data)))) + (let ((layout (borders-layout data))) (setf (borders-right-rect data) - (gfs:create-rectangle :x xpos - :y ypos + (gfs:create-rectangle :x (+ (left-margin-of layout) + (gfs:size-width (gfs:size (left-border-rect data))) + (gfs:size-width (gfs:size (center-border-rect data)))) + :y (+ (top-margin-of layout) + (gfs:size-height (gfs:size (top-border-rect data)))) :width (borders-pref-right-width data) - :height inside-height))))) + :height (gfs:size-height (borders-inside-size data))))))) (defun center-border-rect (data) (unless (borders-center-widget data) (return-from center-border-rect *empty-rect*)) (or (borders-center-rect data) - (let ((xpos (gfs:size-width (gfs:size (left-border-rect data)))) - (ypos (gfs:size-height (gfs:size (top-border-rect data)))) + (let ((layout (borders-layout data)) (size (borders-inside-size data))) (setf (borders-center-rect data) - (gfs:create-rectangle :x xpos - :y ypos + (gfs:create-rectangle :x (+ (left-margin-of layout) + (gfs:size-width (gfs:size (left-border-rect data)))) + :y (+ (top-margin-of layout) + (gfs:size-height (gfs:size (top-border-rect data)))) :width (gfs:size-width size) :height (gfs:size-height size)))))) From junrue at common-lisp.net Sat Nov 18 01:01:48 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 17 Nov 2006 20:01:48 -0500 (EST) Subject: [graphic-forms-cvs] r397 - trunk/src/tests/uitoolkit Message-ID: <20061118010148.188772E1C4@common-lisp.net> Author: junrue Date: Fri Nov 17 20:01:47 2006 New Revision: 397 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp Log: visual test case for border-layout Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Fri Nov 17 20:01:47 2006 @@ -142,10 +142,10 @@ (select-lb-content lb1 (gfw:selected-p btn)) (manage-lb-button-states lb1 btn-right nil btn-all btn-none) (setf latch nil))) - + (outer-layout (make-instance 'gfw:border-layout :spacing 4 :margins 4)) (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* - :layout (make-instance 'gfw:flow-layout :spacing 4 :margins 4))) + :layout outer-layout)) (lb1-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent outer-panel :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) @@ -163,6 +163,7 @@ :style '(:multiple-select) :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) + (setf (gfw:layout-attribute outer-layout lb1-panel :left) t) (setf btn-right (make-instance 'gfw:button :parent btn-panel :text " ==> " @@ -187,6 +188,7 @@ :style '(:check-box) :callback btn-select-callback)) (gfw:pack btn-panel) + (setf (gfw:layout-attribute outer-layout btn-panel :center) t) (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel @@ -194,6 +196,7 @@ :style '(:extend-select :scrollbar-always) :items (subseq *list-box-test-data* 4))) (gfw:pack lb2-panel) + (setf (gfw:layout-attribute outer-layout lb2-panel :right) t) (gfw:pack outer-panel) ;; FIXME: need to think of a more elegant solution for the following @@ -208,6 +211,7 @@ (setf (gfw:items-of lb1) *list-box-test-data*) (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) (gfw:delete-all lb2) + outer-panel)) (defun thumb->string (thing) From junrue at common-lisp.net Sat Nov 18 14:05:48 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 18 Nov 2006 09:05:48 -0500 (EST) Subject: [graphic-forms-cvs] r398 - trunk/docs/manual Message-ID: <20061118140548.937C4B@common-lisp.net> Author: junrue Date: Sat Nov 18 09:05:48 2006 New Revision: 398 Modified: trunk/docs/manual/gf-data.xsl Log: fixed multi-arg setf syntax Modified: trunk/docs/manual/gf-data.xsl ============================================================================== --- trunk/docs/manual/gf-data.xsl (original) +++ trunk/docs/manual/gf-data.xsl Sat Nov 18 09:05:48 2006 @@ -209,7 +209,7 @@ syntax - + normal ( @@ -223,26 +223,23 @@ , - + normal (setf ( - - - - - ) - - - - + + - + + ) + + + ) From junrue at common-lisp.net Sun Nov 19 22:27:52 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 19 Nov 2006 17:27:52 -0500 (EST) Subject: [graphic-forms-cvs] r399 - trunk/src/tests/uitoolkit Message-ID: <20061119222752.9598330018@common-lisp.net> Author: junrue Date: Sun Nov 19 17:27:49 2006 New Revision: 399 Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp Log: define-layout-test now accepts a function to use to customize the target layout Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Sun Nov 19 17:27:49 2006 @@ -64,35 +64,59 @@ (define-layout-test border-layout-test1 -1 -1 80 50 + nil '((20 5 40 40) (0 0 80 5) (0 5 20 40) (0 45 80 5) (60 5 20 40)) #'make-border-layout *all-border-kids*) (define-layout-test border-layout-test2 -1 -1 40 20 + nil '((0 0 40 5) (0 5 20 10) (0 15 40 5) (20 5 20 10)) #'make-border-layout *outer-border-kids*) (define-layout-test border-layout-test3 -1 -1 40 40 + nil '((0 0 40 40)) #'make-border-layout *center-border-kid*) (define-layout-test border-layout-test4 -1 -1 25 15 + nil '((0 0 25 5) (0 5 20 10)) #'make-border-layout *top-right-border-kids*) (define-layout-test border-layout-test5 -1 -1 25 10 + nil '((0 0 25 5) (0 5 25 5)) #'make-border-layout *top-bottom-border-kids*) (define-layout-test border-layout-test6 26 -1 26 50 + nil '((6 5 13 40) (0 0 26 5) (0 5 6 40) (0 45 26 5) (19 5 6 40)) #'make-border-layout *all-border-kids*) (define-layout-test border-layout-test7 -1 -1 90 58 + nil '((24 8 40 40) (4 3 80 5) (4 8 20 40) (4 48 80 5) (64 8 20 40)) #'make-border-layout *all-border-kids* 4 3 6 5) + +(defun border-layout-spacing (layout) + (loop for pair in (gfw::data-of layout) + for widget = (first pair) + for key = (first (second pair)) + do (case key + ;; note - we leave :center region with default spacing + (:top (setf (gfw:layout-attribute layout widget :leading-spacing) 2)) + (:left (setf (gfw:layout-attribute layout widget :trailing-spacing) 3)) + (:right (setf (gfw:layout-attribute layout widget :spacing) 4)) + (:bottom (setf (gfw:layout-attribute layout widget :center-spacing) 5))))) + +(define-layout-test border-layout-test8 + -1 -1 80 50 + #'border-layout-spacing + '((20 5 40 40) (0 0 80 5) (0 5 20 40) (0 45 80 5) (60 5 20 40)) + #'make-border-layout *all-border-kids*) Modified: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Sun Nov 19 17:27:49 2006 @@ -42,70 +42,84 @@ (define-layout-test flow-layout-test1 -1 -1 60 10 + nil '((0 0 20 10) (20 0 20 10) (40 0 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal)) (define-layout-test flow-layout-test2 -1 -1 20 30 + nil '((0 0 20 10) (0 10 20 10) (0 20 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical)) (define-layout-test flow-layout-test3 45 -1 40 20 + nil '((0 0 20 10) (20 0 20 10) (0 10 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap)) (define-layout-test flow-layout-test4 -1 25 20 20 + nil '((0 0 20 10) (0 10 20 10) (20 0 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap)) (define-layout-test flow-layout-test5 45 18 40 20 + nil '((0 0 20 10) (20 0 20 10) (0 10 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap)) (define-layout-test flow-layout-test6 30 25 40 20 + nil '((0 0 20 10) (0 10 20 10) (20 0 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap)) (define-layout-test flow-layout-test7 -1 -1 68 10 + nil '((0 0 20 10) (24 0 20 10) (48 0 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal) 4) (define-layout-test flow-layout-test8 -1 -1 20 38 + nil '((0 0 20 10) (0 14 20 10) (0 28 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical) 4) (define-layout-test flow-layout-test9 45 18 0 0 + nil '((0 0 20 10) (24 0 20 10) (0 14 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4) (define-layout-test flow-layout-test10 30 25 0 0 + nil '((0 0 20 10) (0 14 20 10) (24 0 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4) (define-layout-test flow-layout-test11 -1 -1 63 13 + nil '((3 3 20 10) (23 3 20 10) (43 3 20 10)) #'make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3) (define-layout-test flow-layout-test12 -1 -1 23 33 + nil '((0 0 20 10) (0 10 20 10) (0 20 20 10)) #'make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3) (define-layout-test flow-layout-test13 -1 -1 75 10 + nil '((0 0 25 10) (25 0 25 10) (50 0 25 10)) #'make-flow-layout *flow-mixed-kids* '(:horizontal :normalize)) (define-layout-test flow-layout-test14 -1 -1 25 30 + nil '((0 0 25 10) (0 10 25 10) (0 20 25 10)) #'make-flow-layout *flow-mixed-kids* '(:vertical :normalize)) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Nov 19 17:27:49 2006 @@ -83,13 +83,16 @@ actual-rects))) (defmacro define-layout-test (name width-hint height-hint - expected-width expected-height expected-rects + expected-width expected-height + customizer expected-rects factory &rest factory-args) (let ((layout (gensym)) (size (gensym)) + (dummy (gensym)) (data (gensym))) `(define-test ,name (let* ((,layout (apply ,factory (list , at factory-args))) + (,dummy (if ,customizer (funcall ,customizer ,layout))) (,size (gfw::compute-size ,layout *mock-container* ,width-hint ,height-hint)) (,data (gfw::compute-layout ,layout *mock-container* ,width-hint ,height-hint))) (assert-equal ,expected-width (gfs::size-width ,size)) From junrue at common-lisp.net Fri Nov 24 07:01:24 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 24 Nov 2006 02:01:24 -0500 (EST) Subject: [graphic-forms-cvs] r400 - in trunk: docs/manual src/tests/mcclim src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20061124070124.42C313301E@common-lisp.net> Author: junrue Date: Fri Nov 24 02:01:22 2006 New Revision: 400 Modified: trunk/docs/manual/gfw-symbols.xml trunk/src/tests/mcclim/hello-tester.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: initial work on cursor support Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Fri Nov 24 02:01:22 2006 @@ -2195,6 +2195,66 @@ + + + + + + The gfw:window whose cursor is to be + returned (modified). + + + + + gfw:cursor + + + + This function returns (sets) the cursor associated with a window. Such + an association remains in effect until either the next call to the + SETF function or the assigned cursor is disposed. + + + gfw:show-cursor + gfw:with-cursor + gfw:with-wait-cursor + + + + + + + + + The gfw:window whose cursor visibility + is to be modified. + + + + + A boolean; pass NIL to hide the cursor, or + non-NIL to make the cursor visible. + + + + + undefined + + + + Use this function to control the visibility of the mouse cursor within + . The system maintains a display counter whose value must be + greater than 0 for the cursor to actually be visible. When is + NIL, then the system counter is decremented by one; when is + non-NIL, the system counter is incremented. + + + gfw:cursor + gfw:with-cursor + gfw:with-wait-cursor + + + @@ -5912,6 +5972,80 @@ + + + + + + + The gfw:window object for which the cursor + will be set as determined by . + + + + + Identifies the cursor to be displayed. See gfw:cursor + for details on what values may be specified for this argument. + + + + + + + Application code. + + + + + results + + + + This macro temporarily sets the cursor specified by in + for the duration of . The previous cursor set in + is restored afterwards. + + + gfw:with-wait-cursor + gfw:set-cursor + gfw:show-cursor + + + + + + + + + + The gfw:window object for which the cursor + will be set as determined by . + + + + + + + Application code. + + + + + results + + + + This macro temporarily sets the wait cursor in + for the duration of . The previous cursor set in + is restored afterwards. + + + gfw:with-cursor + gfw:set-cursor + gfw:show-cursor + + + Modified: trunk/src/tests/mcclim/hello-tester.lisp ============================================================================== --- trunk/src/tests/mcclim/hello-tester.lisp (original) +++ trunk/src/tests/mcclim/hello-tester.lisp Fri Nov 24 02:01:22 2006 @@ -13,11 +13,11 @@ (:fill some-pane))))) (define-command com-hello () - (clim-graphic-forms::debug-print "com-hello called ") + #+graphic-forms (gfs::debug-print "com-hello called ") (setf (message *application-frame*) "Hello there!")) (define-command com-hi () - (clim-graphic-forms::debug-print "com-hi called ") + #+graphic-forms (gfs::debug-print "com-hi called ") (setf (message *application-frame*) "Hi there!")) (define-command-table menu-command-table @@ -33,5 +33,5 @@ (frame-exit *application-frame*)) (defmethod display-some-pane ((frame hello-frame) stream) - (clim-graphic-forms::debug-print "display-some-pane called ") + #+graphic-forms (gfs::debug-print "display-some-pane called ") (format stream (message frame))) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Fri Nov 24 02:01:22 2006 @@ -129,6 +129,11 @@ (lp LPARAM)) (defcfun + ("DestroyCursor" destroy-cursor) + BOOL + (hcursor HANDLE)) + +(defcfun ("DestroyIcon" destroy-icon) BOOL (hicon HANDLE)) @@ -670,6 +675,11 @@ (hwnd HANDLE)) (defcfun + ("SetCursor" set-cursor) + HANDLE + (hcursor HANDLE)) + +(defcfun ("SetFocus" set-focus) HANDLE (hwnd HANDLE)) @@ -741,6 +751,11 @@ (str :string)) (defcfun + ("ShowCursor" show-cursor) + INT + (flag BOOL)) + +(defcfun ("ShowWindow" show-window) BOOL (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Nov 24 02:01:22 2006 @@ -33,6 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defclass cursor (gfs:native-object) () + (:documentation "The cursor class represents the sprite controlled by the pointing device.")) + (defclass display (gfs:native-object) () (:documentation "Instances of this class describe characteristics of monitors attached to the system.")) @@ -129,9 +132,6 @@ :initform nil)) (:documentation "The widget class is the base class for all windowed user interface objects.")) -(defclass caret (widget) () - (:documentation "The caret class provides an i-beam typically representing an insertion point.")) - (defclass item-manager () ((sort-predicate :accessor sort-predicate-of From junrue at common-lisp.net Fri Nov 24 22:44:50 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 24 Nov 2006 17:44:50 -0500 (EST) Subject: [graphic-forms-cvs] r401 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/graphics/plugins/default src/uitoolkit/widgets Message-ID: <20061124224450.418A4309E@common-lisp.net> Author: junrue Date: Fri Nov 24 17:44:47 2006 New Revision: 401 Modified: trunk/docs/manual/constants.xml trunk/docs/manual/gfg-symbols.xml trunk/docs/manual/gfs-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/uitoolkit/graphics/graphics-constants.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: cursor documentation Modified: trunk/docs/manual/constants.xml ============================================================================== --- trunk/docs/manual/constants.xml (original) +++ trunk/docs/manual/constants.xml Fri Nov 24 17:44:47 2006 @@ -8,15 +8,21 @@ constants - This section lists the symbols for constants and variables exported from - each package. + This section lists the symbols for the constants and variables that help + comprise the public API. - Character Sets [GFG] - - + + Character Sets [GFG] character sets + + + + Character set constants to be used when requesting fonts. + + + +ansi-charset+ @@ -43,11 +49,17 @@ - Standard Colors [GFG] - - + + Standard Colors [GFG] colors + + + + Predefined color constants. + + + *color-black* @@ -59,11 +71,48 @@ - System Icons [GFG] + + System Cursors [GFG] + system cursors + + + + + Constants identifying predefined cursors. + + + + +app-starting-cursor+ + +crosshair-cursor+ + +default-cursor+ + +hand-cursor+ + +help-cursor+ + +ibeam-cursor+ + +no-cursor+ + +size-all-cursor+ + +size-nesw-cursor+ + +size-ns-cursor+ + +size-nwse-cursor+ + +size-we-cursor+ + +up-arrow-cursor+ + +wait-cursor+ + + + + + + System Icons [GFG] system icons + + + + Constants identifying predefined icons. + + + +application-icon+ @@ -75,11 +124,17 @@ - Virtual Key Codes [GFW] - - + + Virtual Key Codes [GFW] virtual key codes + + + + Device-independent keyboard codes. + + + +vk-break+ @@ -146,6 +201,25 @@ + + Widget Defaults [GFW] + + widget defaults + + + + Constants providing defaults for various widget attributes such as size. + + + + + + +default-widget-height+ + +default-widget-width+ + + + + Modified: trunk/docs/manual/gfg-symbols.xml ============================================================================== --- trunk/docs/manual/gfg-symbols.xml (original) +++ trunk/docs/manual/gfg-symbols.xml Fri Nov 24 17:44:47 2006 @@ -17,6 +17,51 @@ + + + + + gfs:native-object + + + This class encapsulates a native cursor handle. A cursor is an image whose + screen location is determined by a pointing device; when the user moves the + pointing device, the system changes the location of the cursor image to + match. + + + + + See gfs:native-object. + + + + + Specifies a pathname for a file containing cursor image + data. + + + + + Specifies a gfg:image whose data will be copied and + transformed into a cursor. + + + + + Identifies the cursor to be displayed. See system cursors + for a list of cursor identifiers. + + + + + gfw:with-wait-cursor + gfw:set-cursor + gfw:show-cursor + gfw:cursor-of + + + @@ -778,6 +823,7 @@ If and are the same, a complete ellipse is drawn. + colors gfg:draw-pie-wedge gfg:draw-filled-pie-wedge gfg:foreground-color @@ -1696,6 +1742,7 @@ interior of closed shapes. + colors gfg:foreground-color gfg:graphics-context Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Fri Nov 24 17:44:47 2006 @@ -433,6 +433,7 @@ + An integer specifying the X coordinate of the Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Fri Nov 24 17:44:47 2006 @@ -2195,7 +2195,7 @@ - + @@ -2206,18 +2206,19 @@ - gfw:cursor + gfg:cursor - This function returns (sets) the cursor associated with a window. Such - an association remains in effect until either the next call to the - SETF function or the assigned cursor is disposed. + This function returns (sets) the cursor image associated with a window. The + association remains in effect until either the next call to (setf cursor) + or the assigned cursor is disposed. gfw:show-cursor gfw:with-cursor gfw:with-wait-cursor + gfg:cursor @@ -2249,9 +2250,10 @@ non-NIL, the system counter is incremented. - gfw:cursor + gfw:cursor-of gfw:with-cursor gfw:with-wait-cursor + gfg:cursor @@ -5982,12 +5984,25 @@ will be set as determined by . - + + + + See gfg:cursor. + + + + + + See gfg:cursor. + + + + - Identifies the cursor to be displayed. See gfw:cursor - for details on what values may be specified for this argument. + See gfg:cursor. + @@ -6001,14 +6016,16 @@ - This macro temporarily sets the cursor specified by in + This macro temporarily sets a cursor in for the duration of . The previous cursor set in is restored afterwards. + system cursors gfw:with-wait-cursor - gfw:set-cursor gfw:show-cursor + gfw:cursor-of + gfg:cursor @@ -6035,14 +6052,22 @@ - This macro temporarily sets the wait cursor in - for the duration of . The previous cursor set in - is restored afterwards. + + This macro temporarily sets the wait cursor in + for the duration of . The previous cursor set in + is restored afterwards. Use of this macro is equivalent + to: + + + (gfw:with-cursor (window :system gfg:+wait-cursor+) body...) + + system cursors gfw:with-cursor - gfw:set-cursor gfw:show-cursor + gfw:cursor-of + gfg:cursor Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Nov 24 17:44:47 2006 @@ -126,10 +126,24 @@ #:*color-red* #:*color-white* #:*image-file-types* + #:+app-starting-cursor+ #:+application-icon+ + #:+crosshair-cursor+ + #:+default-cursor+ #:+error-icon+ + #:+hand-cursor+ + #:+help-cursor+ + #:+ibeam-cursor+ #:+information-icon+ + #:+no-cursor+ #:+question-icon+ + #:+size-all-cursor+ + #:+size-nesw-cursor+ + #:+size-ns-cursor+ + #:+size-nwse-cursor+ + #:+size-we-cursor+ + #:+up-arrow-cursor+ + #:+wait-cursor+ #:+warning-icon+ ;; methods, functions, macros @@ -275,6 +289,8 @@ #:window ;; constants + #:+default-widget-height+ + #:+default-widget-width+ #:+vk-break+ #:+vk-backspace+ #:+vk-tab+ Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Fri Nov 24 17:44:47 2006 @@ -33,12 +33,12 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defvar *image-win* nil) -(defvar *happy-image* nil) -(defvar *bw-image* nil) -(defvar *comp-image* nil) -(defvar *folder-image* nil) -(defvar *true-image* nil) +(defvar *image-win* nil) +(defvar *happy-image* nil) +(defvar *bw-image* nil) +(defvar *comp-image* nil) +(defvar *folder-image* nil) +(defvar *true-image* nil) (defclass image-events (gfw:event-dispatcher) ()) @@ -95,18 +95,14 @@ (defun load-images () (let ((*default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))) - (setf *happy-image* (make-instance 'gfg:image)) - (gfg::load *happy-image* "happy.bmp") - (setf *bw-image* (make-instance 'gfg:image)) - (gfg::load *bw-image* "blackwhite20x16.bmp") - (setf *true-image* (make-instance 'gfg:image)) - (gfg::load *true-image* "truecolor16x16.bmp") + (setf *happy-image* (make-instance 'gfg:image :file "happy.bmp") + *bw-image* (make-instance 'gfg:image :file "blackwhite20x16.bmp") + *true-image* (make-instance 'gfg:image :file "truecolor16x16.bmp")) + #+load-imagemagick-plugin (progn - (setf *folder-image* (make-instance 'gfg:image)) - (gfg::load *folder-image* "open-folder.gif") - (setf *comp-image* (make-instance 'gfg:image)) - (gfg::load *comp-image* "computer.png")))) + (setf *folder-image* (make-instance 'gfg:image :file "open-folder.gif") + *comp-image* (make-instance 'gfg:image :file "computer.png"))))) (defun image-tester-internal () (load-images) @@ -118,7 +114,8 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) - (setf (gfw:image *image-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) + (setf (gfw:image *image-win*) + (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *image-win* t))) (defun image-tester () Modified: trunk/src/uitoolkit/graphics/graphics-constants.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-constants.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-constants.lisp Fri Nov 24 17:44:47 2006 @@ -67,3 +67,23 @@ (defconstant +information-icon+ 32516) (defconstant +question-icon+ 32514) (defconstant +warning-icon+ 32515) + + +;;; The following are from WinUser.h; specify one of +;;; them as the value of the :system keyword arg when +;;; creating an image. +;;; +(defconstant +app-starting-cursor+ gfs::+ocr-appstarting+) +(defconstant +crosshair-cursor+ gfs::+ocr-cross+) +(defconstant +default-cursor+ gfs::+ocr-normal+) +(defconstant +hand-cursor+ gfs::+ocr-hand+) +(defconstant +help-cursor+ 32651) +(defconstant +ibeam-cursor+ gfs::+ocr-ibeam+) +(defconstant +no-cursor+ gfs::+ocr-no+) +(defconstant +size-all-cursor+ gfs::+ocr-sizeall+) +(defconstant +size-nesw-cursor+ gfs::+ocr-sizenesw+) +(defconstant +size-ns-cursor+ gfs::+ocr-sizens+) +(defconstant +size-nwse-cursor+ gfs::+ocr-sizenwse+) +(defconstant +size-we-cursor+ gfs::+ocr-sizewe+) +(defconstant +up-arrow-cursor+ gfs::+ocr-up+) +(defconstant +wait-cursor+ gfs::+ocr-wait+) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Fri Nov 24 17:44:47 2006 @@ -158,8 +158,7 @@ (#.+error-icon+ (cffi:make-pointer system)) (#.+information-icon+ (cffi:make-pointer system)) (#.+question-icon+ (cffi:make-pointer system)) - (#.+warning-icon+ (cffi:make-pointer system)) - (otherwise nil)))) + (#.+warning-icon+ (cffi:make-pointer system))))) (cond (resource-id (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Fri Nov 24 17:44:47 2006 @@ -44,7 +44,8 @@ ;; this extant in the world, so add more as needed) ;; (defvar *image-file-types* (let ((table (make-hash-table :test #'equal))) - (loop for (key value) in '(("bmp" "Microsoft Windows bitmap") + (loop for (key value) in '(("ani" "Microsoft Windows animated cursor") + ("bmp" "Microsoft Windows bitmap") ("cur" "Microsoft Windows cursor") ("dib" "Microsoft Windows device-independent bitmap") ("emf" "Microsoft Windows Enhanced Metafile") Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Fri Nov 24 17:44:47 2006 @@ -108,6 +108,7 @@ (helper (cond ((string-equal file-type "bmp") #'load-bmp-data) ((string-equal file-type "ico") #'load-icon-data) + ((string-equal file-type "cur") #'load-icon-data) (t (return-from loader nil))))) (with-open-file (stream path :element-type '(unsigned-byte 8)) (funcall helper stream)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Nov 24 17:44:47 2006 @@ -33,9 +33,6 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defclass cursor (gfs:native-object) () - (:documentation "The cursor class represents the sprite controlled by the pointing device.")) - (defclass display (gfs:native-object) () (:documentation "Instances of this class describe characteristics of monitors attached to the system.")) From junrue at common-lisp.net Sun Nov 26 07:12:07 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 26 Nov 2006 02:12:07 -0500 (EST) Subject: [graphic-forms-cvs] r402 - in trunk: . docs/manual src src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20061126071207.0385C2B14B@common-lisp.net> Author: junrue Date: Sun Nov 26 02:12:03 2006 New Revision: 402 Modified: trunk/docs/manual/gfg-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented cursor functionality; implemented screen/window coordinate translation Modified: trunk/docs/manual/gfg-symbols.xml ============================================================================== --- trunk/docs/manual/gfg-symbols.xml (original) +++ trunk/docs/manual/gfg-symbols.xml Sun Nov 26 02:12:03 2006 @@ -41,6 +41,15 @@ data. + + + A gfs:point identifying the pixel location within the + cursor image that determines which screen location is affected by mouse + events. By default, the location (0, 0) is used. For cursors loaded + via the :system initarg and cursors loaded from *.cur files, the hotspot + is predefined. + + Specifies a gfg:image whose data will be copied and @@ -55,6 +64,7 @@ + gfw:with-cursor gfw:with-wait-cursor gfw:set-cursor gfw:show-cursor Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Sun Nov 26 02:12:03 2006 @@ -2195,12 +2195,58 @@ + + + + gfs:point + + + + This function returns the current location of the pointing device in + screen coordinates. + + + gfw:translate-point + + + + + + + + + The gfw:widget representing the source or + target coordinate system, depending on the value of . + + + + + One of the symbols :display or :client to + indicate the target coordinate system. + + + + + The gfs:point to be converted. + + + + + gfs:point + + + + This function converts the coordinates specified by from + (or the display's) coordinate system to the display (or ). + + + - + - The gfw:window whose cursor is to be + The gfw:widget whose cursor is to be returned (modified). @@ -2210,9 +2256,12 @@ - This function returns (sets) the cursor image associated with a window. The - association remains in effect until either the next call to (setf cursor) - or the assigned cursor is disposed. + This function returns (sets) the cursor image associated with a widget. For + subclasses of gfw:window, this function will always return + a cursor, although this may be the window class cursor. For non-window + objects, this function may return NIL. The SETF function will dispose the + previously-assigned cursor, if any, and then assume ownership of the new cursor. + The association remains in effect until the next call to the SETF function. gfw:show-cursor @@ -2225,12 +2274,6 @@ - - - The gfw:window whose cursor visibility - is to be modified. - - A boolean; pass NIL to hide the cursor, or @@ -2243,11 +2286,11 @@ - Use this function to control the visibility of the mouse cursor within - . The system maintains a display counter whose value must be + Use this function to control the visibility of the mouse cursor. + The system maintains a display counter whose value must be greater than 0 for the cursor to actually be visible. When is - NIL, then the system counter is decremented by one; when is - non-NIL, the system counter is incremented. + NIL, then the system counter is decremented; when is non-NIL, + the counter is incremented. gfw:cursor-of @@ -5978,9 +6021,9 @@ - + - The gfw:window object for which the cursor + The gfw:widget object for which the cursor will be set as determined by . @@ -5991,6 +6034,12 @@ + + + See gfg:cursor. + + + See gfg:cursor. @@ -6033,9 +6082,9 @@ - + - The gfw:window object for which the cursor + The gfw:widget object for which the cursor will be set as determined by . @@ -6059,7 +6108,7 @@ to: - (gfw:with-cursor (window :system gfg:+wait-cursor+) body...) + (gfw:with-cursor (widget :system gfg:+wait-cursor+) body...) Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Nov 26 02:12:03 2006 @@ -82,6 +82,8 @@ (:file "graphics-generics") (:file "color" :depends-on ("graphics-classes")) + (:file "cursor" + :depends-on ("graphics-classes")) (:file "palette" :depends-on ("graphics-classes")) (:file "image-data" Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Nov 26 02:12:03 2006 @@ -107,6 +107,7 @@ ;; classes and structs #:color + #:cursor #:font #:font-data #:font-metrics @@ -391,7 +392,7 @@ #:copy-text #:cut-text #:current-font - #:cursor + #:cursor-of #:data-of #:default-message-filter #:default-widget @@ -496,6 +497,7 @@ #:obtain-displays #:obtain-event-time #:obtain-horizontal-scrollbar + #:obtain-pointer-location #:obtain-primary-display #:obtain-vertical-scrollbar #:outer-limit @@ -523,6 +525,7 @@ #:selected-p #:selected-span #:show + #:show-cursor #:show-column #:show-header #:show-item @@ -547,6 +550,7 @@ #:top-child-of #:top-index #:top-margin-of + #:translate-point #:traverse #:traverse-order #:trim-sizes Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Nov 26 02:12:03 2006 @@ -86,6 +86,13 @@ (defmacro color-table (data) `(gfg::palette-table ,data))) +(defclass cursor (gfs:native-object) + ((shared + :reader sharedp + :initarg :shared + :initform nil)) + (:documentation "This class wraps a native cursor handle.")) + (defclass image-data-plugin (gfs:native-object) () (:documentation "Base class for image data plugin implementations.")) @@ -97,7 +104,7 @@ (:documentation "This class maintains image attributes, color, and pixel data.")) (defclass font (gfs:native-object) () - (:documentation "This class encapsulates a realized native font.")) + (:documentation "This class wraps a native font handle.")) (defclass graphics-context (gfs:native-object) ((dc-destructor Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Nov 26 02:12:03 2006 @@ -153,12 +153,7 @@ (defmethod initialize-instance :after ((self icon-bundle) &key file images system transparency-pixel) (let ((image-list nil) - (resource-id (case system - (#.+application-icon+ (cffi:make-pointer system)) - (#.+error-icon+ (cffi:make-pointer system)) - (#.+information-icon+ (cffi:make-pointer system)) - (#.+question-icon+ (cffi:make-pointer system)) - (#.+warning-icon+ (cffi:make-pointer system))))) + (resource-id (if system (cffi:make-pointer system)))) (cond (resource-id (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Nov 26 02:12:03 2006 @@ -72,6 +72,20 @@ (ch UINT)) (defcfun + ("ChildWindowFromPointEx" child-window-from-point) + HANDLE + (hwnd HANDLE) + (pntx LONG) + (pnty LONG) + (flags UINT)) + +(defcfun + ("ClientToScreen" client-to-screen) + BOOL + (hwnd HANDLE) + (pnt point-pointer)) + +(defcfun ("CreateIconIndirect" create-icon-indirect) HANDLE (iconinfo iconinfo-pointer)) @@ -336,6 +350,10 @@ (virtkey INT)) (defcfun + ("GetCapture" get-capture) + HANDLE) + +(defcfun ("GetClassInfoExA" get-class-info) BOOL (instance HANDLE) @@ -368,6 +386,11 @@ (rct LPTR)) (defcfun + ("GetCursorPos" get-cursor-pos) + BOOL + (pnt point-pointer)) + +(defcfun ("GetDC" get-dc) HANDLE (hwnd HANDLE)) @@ -642,7 +665,7 @@ ("ScreenToClient" screen-to-client) BOOL (hwnd HANDLE) - (pnt :pointer)) + (pnt point-pointer)) (defcfun ("ScrollWindowEx" scroll-window) @@ -786,3 +809,8 @@ BOOL (hwnd HANDLE) (rct LPTR)) + +(defcfun + ("WindowFromPoint" window-from-point) + HANDLE + (pnt point-pointer)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Nov 26 02:12:03 2006 @@ -118,7 +118,7 @@ (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget))))) (defun process-ctlcolor-message (wparam lparam) - (let* ((widget (get-widget (thread-context) (cffi:make-pointer lparam))) + (let* ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) (hdc (cffi:make-pointer wparam)) (bkgdcolor (brush-color-of widget)) (textcolor (text-color-of widget)) @@ -206,7 +206,7 @@ (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) (unless (null (dispatcher item)) (event-select (dispatcher item) item)))) - (let ((widget (get-widget tc (cffi:make-pointer lparam)))) + (let ((widget (get-widget tc (cffi:make-pointer (logand #xFFFFFFFF lparam))))) (when (and widget (dispatcher widget)) (dispatch-control-notification widget wparam-hi)))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) @@ -412,6 +412,16 @@ (declare (ignore hwnd)) (process-ctlcolor-message wparam lparam)) +(defmethod process-message (hwnd (msg (eql gfs::+wm-setcursor+)) wparam lparam) + (declare (ignore hwnd lparam)) + (let* ((widget (get-widget (thread-context) (cffi:make-pointer wparam))) + (cursor (slot-value widget 'cursor)) + (retval 0)) + (when cursor + (gfs::set-cursor (gfs:handle cursor)) + (setf retval 1)) + retval)) + (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-double hwnd lparam :right-button)) @@ -452,7 +462,7 @@ (declare (ignore wparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd)) - (info-ptr (cffi:make-pointer lparam))) + (info-ptr (cffi:make-pointer (logand #xFFFFFFFF lparam)))) (if (typep w 'top-level) (let ((max-size (maximum-size w)) (min-size (minimum-size w))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Nov 26 02:12:03 2006 @@ -123,7 +123,9 @@ (:documentation "This class encapsulates a scrollbar attached to a window.")) (defclass widget (event-source) - ((style + ((cursor + :initform nil) + (style :accessor style-of :initarg :style :initform nil)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Nov 26 02:12:03 2006 @@ -117,9 +117,6 @@ (defgeneric copy-text (self) (:documentation "Copies the current text selection to the clipboard.")) -(defgeneric cursor (self) - (:documentation "Returns the cursor object associated with this object.")) - (defgeneric cut-text (self) (:documentation "Copies the current text selection to the clipboard and removes it from self.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Nov 26 02:12:03 2006 @@ -104,20 +104,48 @@ (funcall start-fn) (message-loop #'default-message-filter)))) +(declaim (inline shutdown)) (defun shutdown (exit-code) (gfs::post-quit-message exit-code)) +(defun translate-point (widget system pnt) + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (multiple-value-bind (ptr params) + (cffi:convert-to-foreign pnt 'gfs:point) + (ecase system + (:client (if (zerop (gfs::screen-to-client (gfs:handle widget) ptr)) + (error 'gfs:win32-error :detail "screen-to-client failed"))) + (:display (if (zerop (gfs::client-to-screen (gfs:handle widget) ptr)) + (error 'gfs::win32-error :detail "client-to-screen failed")))) + (let ((pnt (cffi:convert-from-foreign ptr 'gfs:point))) + (cffi:free-converted-object ptr 'gfs:point params) + pnt))) + +(declaim (inline show-cursor)) +(defun show-cursor (flag) + (gfs::show-cursor (if flag 1 0))) + +(defun obtain-pointer-location () + (cffi:with-foreign-object (ptr 'gfs:point) + (cffi:with-foreign-slots ((gfs::x gfs::y) ptr gfs:point) + (when (zerop (gfs::get-cursor-pos ptr)) + (warn 'gfs:win32-warning :detail "get-cursor-pos failed") + (return-from obtain-pointer-location (gfs:make-point))) + (gfs:make-point :x gfs::x :y gfs::y)))) + (defun create-window (class-name title parent-hwnd std-style ex-style &optional child-id) (cffi:with-foreign-string (cname-ptr class-name) (cffi:with-foreign-string (title-ptr title) - (let ((hwnd (gfs::create-window ex-style + (let ((hwnd (gfs::create-window + ex-style cname-ptr title-ptr std-style gfs::+cw-usedefault+ gfs::+cw-usedefault+ gfs::+cw-usedefault+ - gfs::+cw-usedefault+ + gfs::+cw-usedefault+ parent-hwnd (if (zerop (logand gfs::+ws-child+ std-style)) (cffi:null-pointer) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Nov 26 02:12:03 2006 @@ -62,6 +62,31 @@ (setf new-y (centered-coord-outside (gfs:point-y ancest-pnt) ancest-height desc-height))) (setf (location descendant) (gfs:make-point :x new-x :y new-y)))) +(defun cursor-of (widget) + "Return the cursor assigned to widget." + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((cursor (slot-value widget 'cursor))) + (if cursor + (return-from cursor-of cursor))) + (get-window-class-cursor (gfs:handle widget))) + +(defun (setf cursor-of) (cursor widget) + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((old-cursor (slot-value widget 'cursor))) + (if (and old-cursor (not (gfs:disposed-p old-cursor))) + (gfs:dispose old-cursor))) + (setf (slot-value widget 'cursor) cursor) + (let ((capture-hwnd (gfs::get-capture)) + (size (size widget)) + (pnt (obtain-pointer-location))) + (if (and (or (gfs:null-handle-p capture-hwnd) + (cffi:pointer-eq capture-hwnd (gfs:handle widget))) + (and (>= (gfs:point-x pnt) 0) (<= (gfs:point-x pnt) (gfs:size-width size))) + (and (>= (gfs:point-y pnt) 0) (<= (gfs:point-y pnt) (gfs:size-height size)))) + (gfs::set-cursor (gfs:handle cursor))))) + ;;; ;;; widget methods ;;; @@ -171,6 +196,10 @@ (error 'gfs:disposed-error))) (defmethod gfs:dispose ((self widget)) + (if (gfs:disposed-p self) + (warn 'gfs:toolkit-warning :detail "widget already disposed")) + (unless (null (slot-value self 'cursor)) + (gfs:dispose (slot-value self 'cursor))) (unless (null (dispatcher self)) (event-dispose (dispatcher self) self)) (let ((hwnd (gfs:handle self))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Nov 26 02:12:03 2006 @@ -33,6 +33,8 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defconstant +max-classname-string-length+ 256) + (defparameter *dialog-classname* "GraphicFormsDialog") (defparameter *toplevel-erasebkgnd-window-classname* "GraphicFormsTopLevelEraseBkgnd") (defparameter *toplevel-noerasebkgnd-window-classname* "GraphicFormsTopLevelNoEraseBkgnd") @@ -92,7 +94,35 @@ #'child-window-visitor :stdcall)) +(defun window-class-registered-p (class-name) + (cffi:with-foreign-string (str-ptr class-name) + (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) + (cffi:with-foreign-slots ((gfs::cbsize) wc-ptr gfs::wndclassex) + (gfs::zero-mem wc-ptr gfs::wndclassex) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) + (/= (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr)))))) + +(defun get-window-class-name (hwnd) + (cffi:with-foreign-pointer-as-string (str-ptr +max-classname-string-length+) + (if (zerop (gfs::get-class-name hwnd str-ptr +max-classname-string-length+)) + (error 'gfs:win32-error :detail "get-class-name failed")) + (cffi:foreign-string-to-lisp str-ptr))) + +(defun get-window-class-cursor (hwnd) + (cffi:with-foreign-string (str-ptr (get-window-class-name hwnd)) + (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::hcursor) wc-ptr gfs::wndclassex) + (gfs::zero-mem wc-ptr gfs::wndclassex) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) + (when (zerop (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr)) + (warn 'gfs:win32-warning :detail (format nil "class ~a not registered")) + (return-from get-window-class-cursor nil)) + (if (not (gfs::null-handle-p gfs::hcursor)) + (make-instance 'gfg:cursor :handle gfs::hcursor :shared t)))))) + (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) + (if (window-class-registered-p class-name) + (return-from register-window-class 1)) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -101,32 +131,29 @@ gfs::hicon gfs::hcursor gfs::hbrush gfs::menuname gfs::classname gfs::smallicon) wc-ptr gfs::wndclassex) - (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) - (if (zerop (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) - str-ptr wc-ptr)) - (progn - (setf gfs::style style) - (setf gfs::wndproc proc-ptr) - (setf gfs::clsextra 0) - (setf gfs::wndextra (or wndextra 0)) - (setf gfs::hinst (gfs::get-module-handle (cffi:null-pointer))) - (setf gfs::hicon (cffi:null-pointer)) - (setf gfs::hcursor (gfs::load-image (cffi:null-pointer) - (cffi:make-pointer gfs::+ocr-normal+) - gfs::+image-cursor+ 0 0 - (logior gfs::+lr-defaultcolor+ - gfs::+lr-shared+))) - (setf gfs::hbrush (if (< bkgcolor 0) - (cffi:null-pointer) - (cffi:make-pointer (1+ bkgcolor)))) - (setf gfs::menuname (cffi:null-pointer)) - (setf gfs::classname str-ptr) - (setf gfs::smallicon (cffi:null-pointer)) - (setf retval (gfs::register-class wc-ptr))) - (setf retval 1)) - (if (/= retval 0) - retval - (error 'gfs::win32-error :detail "register-class failed"))))))) + (gfs::zero-mem wc-ptr gfs::wndclassex) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex) + gfs::style style + gfs::wndproc proc-ptr + gfs::clsextra 0 + gfs::wndextra (or wndextra 0) + gfs::hinst (gfs::get-module-handle (cffi:null-pointer)) + gfs::hicon (cffi:null-pointer) + gfs::hcursor (gfs::load-image (cffi:null-pointer) + (cffi:make-pointer gfs::+ocr-normal+) + gfs::+image-cursor+ 0 0 + (logior gfs::+lr-defaultcolor+ + gfs::+lr-shared+)) + gfs::hbrush (if (< bkgcolor 0) + (cffi:null-pointer) + (cffi:make-pointer (1+ bkgcolor))) + gfs::menuname (cffi:null-pointer) + gfs::classname str-ptr + gfs::smallicon (cffi:null-pointer)) + (setf retval (gfs::register-class wc-ptr))))) + (if (/= retval 0) + retval + (error 'gfs::win32-error :detail "register-class failed")))) (defun capture-mouse (self) (if (gfs:disposed-p self) @@ -161,14 +188,12 @@ ;;; methods ;;; -(defmethod gfg:background-color ((win window)) - (let ((hwnd (gfs:handle win)) +(defmethod gfg:background-color ((self window)) + (let ((hwnd (gfs:handle self)) (color nil)) - (cffi:with-foreign-pointer-as-string (str-ptr 64) - (gfs::get-class-name hwnd str-ptr 64) - (if (string= (cffi:foreign-string-to-lisp str-ptr) *toplevel-erasebkgnd-window-classname*) - (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) - (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) + (if (string= (get-window-class-name self) *toplevel-erasebkgnd-window-classname*) + (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) + (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+)))) color)) (defmethod compute-outer-size ((self window) desired-client-size) From junrue at common-lisp.net Sun Nov 26 22:51:44 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 26 Nov 2006 17:51:44 -0500 (EST) Subject: [graphic-forms-cvs] r403 - in trunk: . src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20061126225144.84A017E005@common-lisp.net> Author: junrue Date: Sun Nov 26 17:51:43 2006 New Revision: 403 Added: trunk/src/uitoolkit/graphics/cursor.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: (setf cursor-of) now works; added missing source file Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Nov 26 17:51:43 2006 @@ -82,8 +82,6 @@ (:file "graphics-generics") (:file "color" :depends-on ("graphics-classes")) - (:file "cursor" - :depends-on ("graphics-classes")) (:file "palette" :depends-on ("graphics-classes")) (:file "image-data" @@ -92,6 +90,8 @@ :depends-on ("graphics-classes" "graphics-generics")) (:file "icon-bundle" :depends-on ("graphics-constants" "image")) + (:file "cursor" + :depends-on ("graphics-classes" "image")) (:file "font-data") (:file "font") (:file "graphics-context") Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-grid-panel.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Sun Nov 26 17:51:43 2006 @@ -55,6 +55,7 @@ (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size))) (setf (gfs:size-width *grid-char-size*) (floor +grid-half-extent+ 2) (gfs:size-height *grid-char-size*) (floor +grid-half-extent+ 2)) + (setf (gfw:cursor-of panel) (make-instance 'gfg:cursor :system gfg:+hand-cursor+)) panel)) (defun set-grid-scroll-params (window) Added: trunk/src/uitoolkit/graphics/cursor.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/cursor.lisp Sun Nov 26 17:51:43 2006 @@ -0,0 +1,68 @@ +;;;; +;;;; cursor.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.graphics) + +;;; +;;; functions +;;; + + +;;; +;;; methods +;;; + +(defmethod gfs:dispose ((self cursor)) + (if (gfs:disposed-p self) + (warn 'gfs:toolkit-warning :detail "cursor already disposed")) + (unless (sharedp self) + (gfs::destroy-cursor (gfs:handle self))) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod initialize-instance :after ((self cursor) &key file hotspot image system + &allow-other-keys) + (let ((resource-id (if system (cffi:make-pointer system)))) + (cond + (resource-id + (setf (slot-value self 'gfs:handle) + (gfs::load-image (cffi:null-pointer) + resource-id + gfs::+image-cursor+ + 0 0 + (logior gfs::+lr-defaultsize+ gfs::+lr-shared+))) + (setf (slot-value self 'shared) t)) + (file + (let ((tmp (make-instance 'image :file file))) + (setf (slot-value self 'gfs:handle) (image->hicon tmp)))) + ((typep image 'image) + (setf (slot-value self 'gfs:handle) (image->hicon image hotspot)))))) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Nov 26 17:51:43 2006 @@ -470,6 +470,36 @@ (defconstant +hs-cross+ 4) (defconstant +hs-diagcross+ 5) +(defconstant +hterror+ -2) +(defconstant +httransparent+ -1) +(defconstant +htnowhere+ 0) +(defconstant +htclient+ 1) +(defconstant +htcaption+ 2) +(defconstant +htsysmenu+ 3) +(defconstant +htgrowbox+ 4) +(defconstant +htsize+ 4) +(defconstant +htmenu+ 5) +(defconstant +hthscroll+ 6) +(defconstant +htvscroll+ 7) +(defconstant +htminbutton+ 8) +(defconstant +htmaxbutton+ 9) +(defconstant +htleft+ 10) +(defconstant +htright+ 11) +(defconstant +httop+ 12) +(defconstant +httopleft+ 13) +(defconstant +httopright+ 14) +(defconstant +htbottom+ 15) +(defconstant +htbottomleft+ 16) +(defconstant +htbottomright+ 17) +(defconstant +htborder+ 18) +(defconstant +htreduce+ 8) +(defconstant +htzoom+ 9) +(defconstant +htsizefirst+ 10) +(defconstant +htsizelast+ 17) +(defconstant +htobject+ 19) +(defconstant +htclose+ 20) +(defconstant +hthelp+ 21) + (defconstant +icc-listview-classes+ #x00000001) (defconstant +icc-treeview-classes+ #x00000002) (defconstant +icc-bar-classes+ #x00000004) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Nov 26 17:51:43 2006 @@ -83,7 +83,7 @@ ("ClientToScreen" client-to-screen) BOOL (hwnd HANDLE) - (pnt point-pointer)) + (pnt :pointer)) (defcfun ("CreateIconIndirect" create-icon-indirect) @@ -388,7 +388,7 @@ (defcfun ("GetCursorPos" get-cursor-pos) BOOL - (pnt point-pointer)) + (pnt :pointer)) (defcfun ("GetDC" get-dc) @@ -665,7 +665,7 @@ ("ScreenToClient" screen-to-client) BOOL (hwnd HANDLE) - (pnt point-pointer)) + (pnt :pointer)) (defcfun ("ScrollWindowEx" scroll-window) @@ -813,4 +813,4 @@ (defcfun ("WindowFromPoint" window-from-point) HANDLE - (pnt point-pointer)) + (pnt :pointer)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun Nov 26 17:51:43 2006 @@ -413,14 +413,14 @@ (process-ctlcolor-message wparam lparam)) (defmethod process-message (hwnd (msg (eql gfs::+wm-setcursor+)) wparam lparam) - (declare (ignore hwnd lparam)) - (let* ((widget (get-widget (thread-context) (cffi:make-pointer wparam))) - (cursor (slot-value widget 'cursor)) - (retval 0)) - (when cursor - (gfs::set-cursor (gfs:handle cursor)) - (setf retval 1)) - retval)) + (let* ((widget (get-widget (thread-context) hwnd)) + (cursor (slot-value widget 'cursor))) + (cond + (cursor + (gfs::set-cursor (gfs:handle cursor)) + 1) + (t + (gfs::def-window-proc hwnd msg wparam lparam))))) (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam) (declare (ignore wparam)) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sun Nov 26 17:51:43 2006 @@ -68,7 +68,11 @@ (defun thread-context () (when (null *the-thread-context*) (setf *the-thread-context* (make-instance 'thread-context)) - (init-utility-hwnd *the-thread-context*)) + (handler-case + (init-utility-hwnd *the-thread-context*) + (win32-error (e) + (setf *the-thread-context* nil) + (format *error-output* "~a~%" e)))) *the-thread-context*) #+(or clisp sbcl) @@ -84,7 +88,11 @@ (when (null tc) (setf tc (make-instance 'thread-context)) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) - (init-utility-hwnd tc)) + (handler-case + (init-utility-hwnd tc) + (win32-error (e) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil) + (format *error-output* "~a~%" e)))) tc)) #+lispworks Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Nov 26 17:51:43 2006 @@ -78,13 +78,9 @@ (if (and old-cursor (not (gfs:disposed-p old-cursor))) (gfs:dispose old-cursor))) (setf (slot-value widget 'cursor) cursor) - (let ((capture-hwnd (gfs::get-capture)) - (size (size widget)) - (pnt (obtain-pointer-location))) - (if (and (or (gfs:null-handle-p capture-hwnd) - (cffi:pointer-eq capture-hwnd (gfs:handle widget))) - (and (>= (gfs:point-x pnt) 0) (<= (gfs:point-x pnt) (gfs:size-width size))) - (and (>= (gfs:point-y pnt) 0) (<= (gfs:point-y pnt) (gfs:size-height size)))) + (let ((capture-hwnd (gfs::get-capture))) + (if (or (gfs:null-handle-p capture-hwnd) + (cffi:pointer-eq capture-hwnd (gfs:handle widget))) (gfs::set-cursor (gfs:handle cursor))))) ;;; Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Nov 26 17:51:43 2006 @@ -100,7 +100,8 @@ (cffi:with-foreign-slots ((gfs::cbsize) wc-ptr gfs::wndclassex) (gfs::zero-mem wc-ptr gfs::wndclassex) (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) - (/= (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr)))))) + (/= (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr) + 0))))) (defun get-window-class-name (hwnd) (cffi:with-foreign-pointer-as-string (str-ptr +max-classname-string-length+) From junrue at common-lisp.net Mon Nov 27 07:18:18 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 27 Nov 2006 02:18:18 -0500 (EST) Subject: [graphic-forms-cvs] r404 - in trunk: . docs/manual src src/demos/textedit src/uitoolkit/widgets Message-ID: <20061127071818.E02312B139@common-lisp.net> Author: junrue Date: Mon Nov 27 02:18:14 2006 New Revision: 404 Modified: trunk/NEWS.txt trunk/docs/manual/gfw-symbols.xml trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented with-cursor/with-wait-cursor macros; implemented process-events function; textedit demo now uses wait cursor when loading or saving files Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Nov 27 02:18:14 2006 @@ -1,8 +1,14 @@ +. Implemented cursor support. Applications can choose from the system-defined + cursors or load them from external files. Also provided are convenience + macros GFW:WITH-CURSOR and GFW:WITH-WAIT-CURSOR. + +. Implemented a new layout manager called GFW:BORDER-LAYOUT which allows + applications to assign children to 5 possible regions, identified by + :top, :left, :right, :bottom, or :center. -. Implemented a new layout manager called GFW:BORDER-LAYOUT which assigns - children to 5 possible regions identified by :top, :left, :right, - :bottom, or :center. +. Implemented the function GFW:PROCESS-EVENTS to help applications flush + the event queue of pending events. . GFW:APPEND-ITEM now accepts an optional classname argument so that applications can use custom item classes. Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Mon Nov 27 02:18:14 2006 @@ -2195,6 +2195,22 @@ + + + + undefined + + + + Call this function to processing pending events until the event queue + is empty. + + + gfw:default-message-filter + gfw:message-loop + + + @@ -2462,6 +2478,9 @@ it is passed to gfw:message-loop. + + gfw:process-events + @@ -2487,6 +2506,7 @@ gfw:default-message-filter + gfw:process-events Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Mon Nov 27 02:18:14 2006 @@ -62,13 +62,15 @@ paths :filters *textedit-file-filters*) (when paths - (setf (gfw:text *textedit-control*) (load-textedit-doc (first paths))) + (gfw:with-wait-cursor (*textedit-win*) + (setf (gfw:text *textedit-control*) (load-textedit-doc (first paths)))) (setf (file-path-of *textedit-model*) (namestring (first paths))) (setf (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths)))))) (defun textedit-file-save (disp item) (if (file-path-of *textedit-model*) - (save-textedit-doc (file-path-of *textedit-model*) (gfw:text *textedit-control*)) + (gfw:with-wait-cursor (*textedit-win*) + (save-textedit-doc (file-path-of *textedit-model*) (gfw:text *textedit-control*))) (textedit-file-save-as disp item)) (if (file-path-of *textedit-model*) (setf (gfw:text-modified-p *textedit-control*) nil))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Nov 27 02:18:14 2006 @@ -561,11 +561,13 @@ #:visible-item-count #:visible-p #:with-color-dialog + #:with-cursor #:with-drawing-disabled #:with-file-dialog #:with-font-dialog #:with-graphics-context #:with-root-window + #:with-wait-cursor ;; conditions )) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Nov 27 02:18:14 2006 @@ -68,13 +68,23 @@ ;;; (defun message-loop (msg-filter) + (push msg-filter (message-filters (thread-context))) (cffi:with-foreign-object (msg-ptr 'gfs::msg) (loop (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) (cffi:with-foreign-slots ((gfs::message gfs::wparam) msg-ptr gfs::msg) (when (funcall msg-filter gm msg-ptr) + (pop (message-filters (thread-context))) (return-from message-loop gfs::wparam))))))) +(defun process-events () + (let ((filter (first (message-filters (thread-context))))) + (unless filter + (return-from process-events nil)) + (cffi:with-foreign-object (msg-ptr 'gfs::msg) + (loop until (zerop (gfs::peek-message msg-ptr (cffi:null-pointer) 0 0 gfs::+pm-remove+)) + do (funcall filter 1 msg-ptr))))) + (defun key-down-p (key-code) "Return T if the key corresponding to key-code is currently down." (= (logand (gfs::get-async-key-state key-code) #x8000) #x8000)) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Nov 27 02:18:14 2006 @@ -42,6 +42,7 @@ (job-table-lock :initform nil) (virtual-key :initform 0 :accessor virtual-key) (items-by-id :initform (make-hash-table :test #'equal)) + (message-filters :initform nil :accessor message-filters) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) (next-item-id :initform 10000 :reader next-item-id) @@ -70,7 +71,7 @@ (setf *the-thread-context* (make-instance 'thread-context)) (handler-case (init-utility-hwnd *the-thread-context*) - (win32-error (e) + (gfs:win32-error (e) (setf *the-thread-context* nil) (format *error-output* "~a~%" e)))) *the-thread-context*) @@ -90,7 +91,7 @@ (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) (handler-case (init-utility-hwnd tc) - (win32-error (e) + (gfs:win32-error (e) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil) (format *error-output* "~a~%" e)))) tc)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Nov 27 02:18:14 2006 @@ -104,7 +104,6 @@ (funcall start-fn) (message-loop #'default-message-filter)))) -(declaim (inline shutdown)) (defun shutdown (exit-code) (gfs::post-quit-message exit-code)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Nov 27 02:18:14 2006 @@ -83,6 +83,27 @@ (cffi:pointer-eq capture-hwnd (gfs:handle widget))) (gfs::set-cursor (gfs:handle cursor))))) +(defmacro with-cursor ((widget &key file hotspot image system) &body body) + (lispworks:with-unique-names (old new retval) + `(let ((,old (slot-value ,widget 'cursor)) + (,new (make-instance 'gfg:cursor + :file ,file + :hotspot ,hotspot + :image ,image + :system ,system)) + (,retval nil)) + (setf (slot-value ,widget 'cursor) nil) + (setf (cursor-of ,widget) ,new) + (process-events) + (unwind-protect + (setf ,retval (progn , at body)) + (setf (slot-value ,widget 'cursor) ,old) + (gfs:dispose ,new)) + ,retval))) + +(defmacro with-wait-cursor ((widget) &body body) + `(with-cursor (,widget :system gfg:+wait-cursor+) + , at body)) ;;; ;;; widget methods ;;; Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Nov 27 02:18:14 2006 @@ -116,7 +116,8 @@ (gfs::zero-mem wc-ptr gfs::wndclassex) (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) (when (zerop (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr)) - (warn 'gfs:win32-warning :detail (format nil "class ~a not registered")) + (warn 'gfs:win32-warning + :detail (format nil "class ~a not registered" (get-window-class-name hwnd))) (return-from get-window-class-cursor nil)) (if (not (gfs::null-handle-p gfs::hcursor)) (make-instance 'gfg:cursor :handle gfs::hcursor :shared t)))))) From junrue at common-lisp.net Wed Nov 29 18:23:16 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 29 Nov 2006 13:23:16 -0500 (EST) Subject: [graphic-forms-cvs] r405 - in trunk: . docs/manual src src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20061129182316.54AE049050@common-lisp.net> Author: junrue Date: Wed Nov 29 13:23:14 2006 New Revision: 405 Added: trunk/src/uitoolkit/system/metrics.lisp Modified: trunk/NEWS.txt trunk/docs/manual/clhs-table.xml trunk/docs/manual/gf-data.xsl trunk/docs/manual/gfs-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented obtain-system-metrics Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Wed Nov 29 13:23:14 2006 @@ -4,8 +4,13 @@ macros GFW:WITH-CURSOR and GFW:WITH-WAIT-CURSOR. . Implemented a new layout manager called GFW:BORDER-LAYOUT which allows - applications to assign children to 5 possible regions, identified by - :top, :left, :right, :bottom, or :center. + applications to assign children to regions around the perimeter of a + window or the center. + +. Implemented GFS:OBTAIN-SYSTEM-METRICS as a higher-level interface to the + Win32 GetSystemMetrics() API. It returns a hash table that applications + may cache if desired, and collapses certain related metrics values for + easier access. . Implemented the function GFW:PROCESS-EVENTS to help applications flush the event queue of pending events. Modified: trunk/docs/manual/clhs-table.xml ============================================================================== --- trunk/docs/manual/clhs-table.xml (original) +++ trunk/docs/manual/clhs-table.xml Wed Nov 29 13:23:14 2006 @@ -12,11 +12,13 @@ + + Modified: trunk/docs/manual/gf-data.xsl ============================================================================== --- trunk/docs/manual/gf-data.xsl (original) +++ trunk/docs/manual/gf-data.xsl Wed Nov 29 13:23:14 2006 @@ -17,11 +17,7 @@ - - - - - + Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Wed Nov 29 13:23:14 2006 @@ -9,9 +9,9 @@ The symbols in this package correspond to system-level functionality, - such as foreign function declarations for the Win32 API. The majority - of symbols in this package are not exported, except for the - fundamental types, conditions, and functions listed below. + including CFFI declarations for functions and data types. Additional + symbols represent key classes, functions, and conditions. + The majority of Graphic-Forms is built on top of this package. @@ -301,6 +301,275 @@ + + + + hash-table + + + + + This function returns a table of system metrics: + + + + + A list specifying how minimized windows + are arranged. The first element is a symbol indicating + the starting position: + + + + + + + + The second element indicates the direction: + + + + + + + + + A symbol describing how the system was started: + + + + + + + + + + A list of gfs:size objects + describing the thickness of a window border in pixels. The first + element corresponds to windows with the 3D look, whereas the second + element describes windows with non-3D borders. + + + + + An integer indicating the number of mouse + buttons, or zero if no mouse is installed. + + + + + T if the meaning of the left and right mouse buttons are swapped; + NIL otherwise. + + + + + A list whose first element is a + gfs:size describing the size of a + normal (default) caption button. The second element is a + gfs:size for the small caption + button type. + + + + + A gfs:size describing the dimensions of a cursor + image in pixels. + + + + + T if the installed user32.dll supports DBCS; NIL otherwise. + + + + + T if the debug version of user32.dll is installed; NIL otherwise. + + + + + An integer describing the number of display + monitors on the desktop. + + + + + A list whose first element is a + gfs:size describing the total dimensions of + the primary display including the taskbar area. The second element + is a gfs:size that excludes the taskbar area. + + + + + A gfs:size indicating the area surrounding the + initial click of a double-click gesture. + + + + + A gfs:size indicating the area surrounding the + initial click of a drag gesture. + + + + + A gfs:size indicating the thickness in pixels + of the edges of the focus rectangle. + + + + + A list whose first element is a + gfs:size describing the thickness of a + resizable window's border in pixels. The second element is + a gfs:size indicating the thickness of + a fixed frame. + + + + + A list whose first element is a + gfs:size describing the size of a + normal (default) icon. The second element is a + gfs:size for the small icon type. + + + + + A gfs:size describing the width and height of + a grid cell for items in a large icon view; these values will be + greater than or equal to the large icon size. + + + + + T if Input Method Manager / Input Method Editor features are + enabled; NIL otherwise. + + + + + T if the system has determined that the CPU meets criteria associated + with a low-end (slow) model. + + + + + T if the installed system is Media Center Edition; NIL otherwise. + + + + + A gfs:size describing the size of menubar buttons + in pixels. + + + + + A gfs:size describing the size of the default + menu checkmark in pixels. + + + + + The symbol :right if menus are right-aligned with + the corresponding menubar item, or :left if menus are left-aligned. + + + + + T if the system is configured to support Hebrew and Arabic languages; + NIL otherwise. + + + + + A gfs:size describing the dimensions of a minimized + window in pixels. + + + + + T if a mouse with a wheel is installed; NIL otherwise. + + + + + T if the user requires applications to provide visual notification + in situations where only an audible notification would normally occur. + + + + + T if the Windows for Pen extensions are installed; NIL otherwise. + + + + + T if the calling process is associated with a Terminal Services client + session; NIL otherwise. + + + + + T if the current session is remotely controlled (in a Terminal Services + environment); NIL otherwise. + + + + + T if all displays use the same color encoding; NIL otherwise. + + + + + A gfs:size indicating the width of a vertical + scrollbar and the height of a horizontal scrollbar. + + + + + A gfs:size describing the width of a vertical + scrollbar's arrow bitmap and the height of a horizontal scrollbar's + arrow bitmap. + + + + + T if the current session is shutting down; NIL otherwise. + + + + + T if the system is Windows XP Tablet PC edition; NIL otherwise. + + + + + A list containing gfs:size + objects for the minimum and maximum supported window border tracking + sizes. + + + + + A list containing gfs:size + objects for window extremums in the following order: + full screen, maximized, + minimized, and minimum allowed. + + + + + A gfs:size describing the width and height of + the bounding rectangle of all display monitors. + + + + + + Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Wed Nov 29 13:23:14 2006 @@ -6043,8 +6043,8 @@ - The gfw:widget object for which the cursor - will be set as determined by . + The gfw:widget object for which a cursor + will be set. @@ -6104,8 +6104,8 @@ - The gfw:widget object for which the cursor - will be set as determined by . + The gfw:widget object for which the wait + cursor will be set. @@ -6122,7 +6122,7 @@ - This macro temporarily sets the wait cursor in + This macro temporarily sets the standard wait cursor in for the duration of . The previous cursor set in is restored afterwards. Use of this macro is equivalent to: Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Nov 29 13:23:14 2006 @@ -72,6 +72,7 @@ (:file "gdi32") (:file "kernel32") (:file "user32") + (:file "metrics") (:file "native-object") (:file "system-utils"))) (:module "graphics" Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Nov 29 13:23:14 2006 @@ -77,6 +77,7 @@ #:make-size #:make-span #:null-handle-p + #:obtain-system-metrics #:point-x #:point-y #:point-z Added: trunk/src/uitoolkit/system/metrics.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/metrics.lisp Wed Nov 29 13:23:14 2006 @@ -0,0 +1,383 @@ +;;;; +;;;; metrics.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.system) + +(defun obtain-system-metrics () + "Query system metrics and return them via a hash table." + (let ((table (make-hash-table))) + ;; + ;; :arrangement + ;; + ;; A two-valued result describing the starting position and direction + ;; of minimized windows." + ;; + (setf (gethash :arrangement table) + (let ((metric (get-system-metrics +sm-arrange+)) + (topright-bits (logior +arw-startright+ +arw-starttop+))) + (list (cond + ((= (logand metric topright-bits) topright-bits) + :top-right) + ((= (logand metric +arw-starttop+) +arw-starttop+) + :top-left) + ((= (logand metric +arw-startright+) +arw-startright+) + :bottom-right) + ((= (logand metric +arw-hide+) +arw-hide+) + :hide) + (t + :bottom-left)) + (if (= (logand metric +arw-up+) +arw-up+) + :vertical + :horizontal)))) + ;; + ;; :boot-mode + ;; + ;; A keyword symbol describing how the system was started. + ;; + (setf (gethash :boot-mode table) + (case (get-system-metrics +sm-cleanboot+) + (0 :normal) + (1 :fail-safe) + (2 :fail-safe-no-network) + (otherwise :unknown))) + ;; + ;; :border-sizes + ;; + ;; The thickness of resizable and fixes window borders in pixels. + ;; + (setf (gethash :border-sizes table) + (list (make-size :width (get-system-metrics +sm-cxedge+) + :height (get-system-metrics +sm-cyedge+)) + (make-size :width (get-system-metrics +sm-cxborder+) + :height (get-system-metrics +sm-cyborder+)))) + ;; + ;; :button-count + ;; + ;; The number of mouse buttons, or zero if no mouse is installed. + ;; + (setf (gethash :button-count table) + (get-system-metrics +sm-cmousebuttons+)) + ;; + ;; :buttons-swapped + ;; + ;; T if the meaning of the left and right mouse buttons are swapped; + ;; NIL otherwise. + ;; + (setf (gethash :buttons-swapped table) + (/= (get-system-metrics +sm-swapbutton+) 0)) + ;; + ;; :caption-button-sizes + ;; + ;; A list of the sizes of a button in a window's caption or title bar in pixels. + ;; + (setf (gethash :caption-button-sizes table) + (list (make-size :width (get-system-metrics +sm-cxsize+) + :height (get-system-metrics +sm-cysize+)) + (make-size :width (get-system-metrics +sm-cxsmsize+) + :height (get-system-metrics +sm-cysmsize+)))) + ;; + ;; :cursor-size + ;; + ;; The size of the cursor image in pixels. + ;; + (setf (gethash :cursor-size table) + (make-size :width (get-system-metrics +sm-cxcursor+) + :height (get-system-metrics +sm-cycursor+))) + ;; + ;; :dbcs-enabled + ;; + ;; T if user32.dll supports DBCS; NIL otherwise. + ;; + (setf (gethash :dbcs-enabled table) + (/= (get-system-metrics +sm-dbcsenabled+) 0)) + ;; + ;; :debug-version + ;; + ;; T if the debug version of user32.dll is installed; NIL otherwise. + ;; + (setf (gethash :debug-version table) + (/= (get-system-metrics +sm-debug+) 0)) + ;; + ;; :display-count + ;; + ;; A count of the display monitors on the desktop. + ;; + (setf (gethash :display-count table) + (get-system-metrics +sm-cmonitors+)) + ;; + ;; :display-sizes + ;; + ;; A list containing two sizes of the display (with and without the taskbar). + ;; + (setf (gethash :display-sizes table) + (list (make-size :width (get-system-metrics +sm-cxscreen+) + :height (get-system-metrics +sm-cyscreen+)) + (cffi:with-foreign-object (rect-ptr 'rect) + (if (zerop (system-parameters-info +spi-getworkarea+ 0 rect-ptr 0)) + (error 'win32-error :detail "system-parameters-info failed")) + (let ((tmp (cffi:convert-from-foreign rect-ptr 'rect-pointer))) + (size tmp))))) + ;; + ;; :double-click-size + ;; + ;; The size in pixels of the area surrounding a first click in a double-click sequence. + ;; + (setf (gethash :double-click-size table) + (make-size :width (get-system-metrics +sm-cxdoubleclk+) + :height (get-system-metrics +sm-cydoubleclk+))) + ;; + ;; :drag-size + ;; + ;; The size in pixels of the area surrounding the start of a drag gesture. + ;; + (setf (gethash :drag-size table) + (make-size :width (get-system-metrics +sm-cxdrag+) + :height (get-system-metrics +sm-cydrag+))) + ;; + ;; :frame-sizes + ;; + ;; The thickness of a fixed border (or dialog border) in pixels. + ;; + (setf (gethash :frame-sizes table) + (list (make-size :width (get-system-metrics +sm-cxframe+) + :height (get-system-metrics +sm-cyframe+)) + (make-size :width (get-system-metrics +sm-cxdlgframe+) + :height (get-system-metrics +sm-cydlgframe+)))) + ;; + ;; :focus-size + ;; + ;; The thickness in pixels of the edges of the focus rectangle. + ;; + (setf (gethash :focus-size table) + (make-size :width (get-system-metrics +sm-cxfocusborder+) + :height (get-system-metrics +sm-cyfocusborder+))) + ;; + ;; :icon-sizes + ;; + ;; The default and small sizes of an icon in pixels. + ;; + (setf (gethash :icon-sizes table) + (list (make-size :width (get-system-metrics +sm-cxicon+) + :height (get-system-metrics +sm-cyicon+)) + (make-size :width (get-system-metrics +sm-cxsmicon+) + :height (get-system-metrics +sm-cysmicon+)))) + ;; + ;; :icon-spacing + ;; + ;; The width and height of a grid cell for items in a large icon view; + ;; these values will be greater than or equal to the large icon size. + ;; + (setf (gethash :icon-spacing table) + (make-size :width (get-system-metrics +sm-cxiconspacing+) + :height (get-system-metrics +sm-cyiconspacing+))) + ;; + ;; :ime-enabled + ;; + ;; T if Input Method Manager/Input Method Editor features are + ;; enabled; NIL otherwise. + ;; + (setf (gethash :ime-enabled table) + (/= (get-system-metrics +sm-immenabled+) 0)) + ;; + ;; :low-end-processor + ;; + ;; T if the system has determined that the CPU meets criteria associated + ;; with a low-end (slow) model. + ;; + (setf (gethash :low-end-processor table) + (/= (get-system-metrics +sm-slowmachine+) 0)) + ;; + ;; :media-center + ;; + ;; T if the installed system is Media Center Edition; NIL otherwise. + ;; + (setf (gethash :media-center table) + (/= (get-system-metrics +sm-mediacenter+) 0)) + ;; + ;; :menu-button-size + ;; + ;; The size of menubar buttons in pixels. + ;; + (setf (gethash :menu-button-size table) + (make-size :width (get-system-metrics +sm-cxmenusize+) + :height (get-system-metrics +sm-cymenusize+))) + ;; + ;; :menu-check-size + ;; + ;; The size of the default menu checkmark image in pixels. + ;; + (setf (gethash :menu-check-size table) + (make-size :width (get-system-metrics +sm-cxmenucheck+) + :height (get-system-metrics +sm-cymenucheck+))) + ;; + ;; :menu-drop-alignment + ;; + ;; Value is :right if menus are right-aligned with the corresponding menubar + ;; item, or :left if menus are left-aligned. + ;; + (setf (gethash :menu-drop-alignment table) + (if (zerop (get-system-metrics +sm-menudropalignment+)) :left :right)) + ;; + ;; :mideast-enabled + ;; + ;; T if the system is c0nfigured to support Hebrew and Arabic languages; NIL + ;; otherwise. + ;; + (setf (gethash :mideast-enabled table) + (/= (get-system-metrics +sm-mideastenabled+) 0)) + ;; + ;; :minimized-window-size + ;; + ;; The size of a minimized window in pixels. + ;; + (setf (gethash :minimized-window-size table) + (make-size :width (get-system-metrics +sm-cxminimized+) + :height (get-system-metrics +sm-cyminimized+))) + ;; + ;; :minimized-window-spacing + ;; + ;; The width and height of a grid cell for a minimized window in pixels. + ;; + (setf (gethash :minimized-window-spacing table) + (make-size :width (get-system-metrics +sm-cxminspacing+) + :height (get-system-metrics +sm-cyminspacing+))) + ;; + ;; :mouse-wheel + ;; + ;; T if a mouse with a wheel is installed; NIL otherwise. + ;; + (setf (gethash :mouse-wheel table) + (/= (get-system-metrics +sm-mousewheelpresent+) 0)) + ;; + ;; :notify-visually + ;; + ;; T if the user requires applications to provide visual notification + ;; in situations where only an audible notification would normally occur. + ;; + (setf (gethash :notify-visually table) + (/= (get-system-metrics +sm-showsounds+) 0)) + ;; + ;; :pen-extensions + ;; + ;; T if the Windows for Pen extensions are installed; NIL otherwise. + ;; + (setf (gethash :pen-extensions table) + (/= (get-system-metrics +sm-penwindows+) 0)) + ;; + ;; :remote-session + ;; + ;; T if the calling process is associated with a Terminal Services client + ;; session; NIL otherwise. + ;; + (setf (gethash :remote-session table) + (/= (get-system-metrics +sm-remotesession+) 0)) + ;; + ;; :remotely-controlled + ;; + ;; T if the current session is remotely controlled (in a Terminal Services + ;; environment); NIL otherwise. + ;; + (setf (gethash :remotely-controlled table) + (/= (get-system-metrics +sm-remotecontrol+) 0)) + ;; + ;; :same-display-format + ;; + ;; T if all displays use the same color encoding; NIL otherwise. + ;; + (setf (gethash :same-display-format table) + (/= (get-system-metrics +sm-samedisplayformat+) 0)) + ;; + ;; :scrollbar-dimensions + ;; + ;; The width of a vertical scrollbar and the height of a horizontal scrollbar. + ;; + (setf (gethash :scrollbar-dimensions table) + (make-size :width (get-system-metrics +sm-cxvscroll+) + :height (get-system-metrics +sm-cyhscroll+))) + ;; + ;; :scrollbar-arrow-dimensions + ;; + ;; The width of a vertical scrollbar's arrow bitmap and the height of a + ;; horizontal-scrollbar's arrow bitmap. + ;; + (setf (gethash :scrollbar-arrow-dimensions table) + (make-size :width (get-system-metrics +sm-cxhscroll+) + :height (get-system-metrics +sm-cyvscroll+))) + ;; + ;; :shutting-down + ;; + ;; T if the current session is shutting down; NIL otherwise. + ;; + (setf (gethash :shutting-down table) + (/= (get-system-metrics +sm-shuttingdown+) 0)) + ;; + ;; :tablet-pc + ;; + ;; T if the system is Windows XP Tablet PC edition; NIL otherwise. + ;; + (setf (gethash :tablet-pc table) + (/= (get-system-metrics +sm-tabletpc+) 0)) + ;; + ;; :tracking-sizes + ;; + ;; The minimum and maximum sizes to which a window can be dragged. + ;; + (setf (gethash :tracking-sizes table) + (list (make-size :width (get-system-metrics +sm-cxmintrack+) + :height (get-system-metrics +sm-cymintrack+)) + (make-size :width (get-system-metrics +sm-cxmaxtrack+) + :height (get-system-metrics +sm-cymaxtrack+)))) + ;; + ;; :virtual-display-size + ;; + ;; The size of the bounding rectangle for all displays. + ;; + (setf (gethash :virtual-display-size table) + (make-size :width (get-system-metrics +sm-cxvirtualscreen+) + :height (get-system-metrics +sm-cyvirtualscreen+))) + ;; + ;; :window-sizes + ;; + ;; A list of size objects representing various window extremums. + ;; + (setf (gethash :window-sizes table) + (list (make-size :width (get-system-metrics +sm-cxfullscreen+) + :height (get-system-metrics +sm-cyfullscreen+)) + (make-size :width (get-system-metrics +sm-cxmaximized+) + :height (get-system-metrics +sm-cymaximized+)) + (make-size :width (get-system-metrics +sm-cxminimized+) + :height (get-system-metrics +sm-cyminimized+)) + (make-size :width (get-system-metrics +sm-cxmin+) + :height (get-system-metrics +sm-cymin+)))) + + table)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Nov 29 13:23:14 2006 @@ -52,6 +52,20 @@ (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) +(defconstant +arw-bottomleft+ #x0000) +(defconstant +arw-bottomright+ #x0001) +(defconstant +arw-topleft+ #x0002) +(defconstant +arw-topright+ #x0003) +(defconstant +arw-startmask+ #x0003) +(defconstant +arw-startright+ #x0001) +(defconstant +arw-starttop+ #x0002) + +(defconstant +arw-left+ #x0000) +(defconstant +arw-right+ #x0000) +(defconstant +arw-up+ #x0004) +(defconstant +arw-down+ #x0004) +(defconstant +arw-hide+ #x0008) + (defconstant +bi-rgb+ 0) (defconstant +bi-rle8+ 1) (defconstant +bi-rle4+ 2) @@ -895,18 +909,18 @@ (defconstant +ps-insideframe+ 6) (defconstant +ps-userstyle+ 7) (defconstant +ps-alternate+ 8) -(defconstant +ps-style-mask+ #x0000000f) +(defconstant +ps-style-mask+ #x0000000F) (defconstant +ps-endcap-round+ #x00000000) (defconstant +ps-endcap-square+ #x00000100) (defconstant +ps-endcap-flat+ #x00000200) -(defconstant +ps-endcap-mask+ #x00000f00) +(defconstant +ps-endcap-mask+ #x00000F00) (defconstant +ps-join-round+ #x00000000) (defconstant +ps-join-bevel+ #x00001000) (defconstant +ps-join-miter+ #x00002000) -(defconstant +ps-join-mask+ #x0000f000) +(defconstant +ps-join-mask+ #x0000F000) (defconstant +ps-cosmetic+ #x00000000) (defconstant +ps-geometric+ #x00010000) -(defconstant +ps-type-mask+ #x000f0000) +(defconstant +ps-type-mask+ #x000F0000) (defconstant +sb-horz+ 0) (defconstant +sb-vert+ 1) @@ -1048,6 +1062,178 @@ (defconstant +sm-remotecontrol+ #x2001) (defconstant +sm-caretblinkingenabled+ #x2002) +(defconstant +spi-getbeep+ #x0001) +(defconstant +spi-setbeep+ #x0002) +(defconstant +spi-getmouse+ #x0003) +(defconstant +spi-setmouse+ #x0004) +(defconstant +spi-getborder+ #x0005) +(defconstant +spi-setborder+ #x0006) +(defconstant +spi-getkeyboardspeed+ #x000A) +(defconstant +spi-setkeyboardspeed+ #x000B) +(defconstant +spi-langdriver+ #x000C) +(defconstant +spi-iconhorizontalspacing+ #x000D) +(defconstant +spi-getscreensavetimeout+ #x000E) +(defconstant +spi-setscreensavetimeout+ #x000F) +(defconstant +spi-getscreensaveactive+ #x0010) +(defconstant +spi-setscreensaveactive+ #x0011) +(defconstant +spi-getgridgranularity+ #x0012) +(defconstant +spi-setgridgranularity+ #x0013) +(defconstant +spi-setdeskwallpaper+ #x0014) +(defconstant +spi-setdeskpattern+ #x0015) +(defconstant +spi-getkeyboarddelay+ #x0016) +(defconstant +spi-setkeyboarddelay+ #x0017) +(defconstant +spi-iconverticalspacing+ #x0018) +(defconstant +spi-geticontitlewrap+ #x0019) +(defconstant +spi-seticontitlewrap+ #x001A) +(defconstant +spi-getmenudropalignment+ #x001B) +(defconstant +spi-setmenudropalignment+ #x001C) +(defconstant +spi-setdoubleclkwidth+ #x001D) +(defconstant +spi-setdoubleclkheight+ #x001E) +(defconstant +spi-geticontitlelogfont+ #x001F) +(defconstant +spi-setdoubleclicktime+ #x0020) +(defconstant +spi-setmousebuttonswap+ #x0021) +(defconstant +spi-seticontitlelogfont+ #x0022) +(defconstant +spi-getfasttaskswitch+ #x0023) +(defconstant +spi-setfasttaskswitch+ #x0024) +(defconstant +spi-setdragfullwindows+ #x0025) +(defconstant +spi-getdragfullwindows+ #x0026) +(defconstant +spi-getnonclientmetrics+ #x0029) +(defconstant +spi-setnonclientmetrics+ #x002A) +(defconstant +spi-getminimizedmetrics+ #x002B) +(defconstant +spi-setminimizedmetrics+ #x002C) +(defconstant +spi-geticonmetrics+ #x002D) +(defconstant +spi-seticonmetrics+ #x002E) +(defconstant +spi-setworkarea+ #x002F) +(defconstant +spi-getworkarea+ #x0030) +(defconstant +spi-setpenwindows+ #x0031) +(defconstant +spi-gethighcontrast+ #x0042) +(defconstant +spi-sethighcontrast+ #x0043) +(defconstant +spi-getkeyboardpref+ #x0044) +(defconstant +spi-setkeyboardpref+ #x0045) +(defconstant +spi-getscreenreader+ #x0046) +(defconstant +spi-setscreenreader+ #x0047) +(defconstant +spi-getanimation+ #x0048) +(defconstant +spi-setanimation+ #x0049) +(defconstant +spi-getfontsmoothing+ #x004A) +(defconstant +spi-setfontsmoothing+ #x004B) +(defconstant +spi-setdragwidth+ #x004C) +(defconstant +spi-setdragheight+ #x004D) +(defconstant +spi-sethandheld+ #x004E) +(defconstant +spi-getlowpowertimeout+ #x004F) +(defconstant +spi-getpowerofftimeout+ #x0050) +(defconstant +spi-setlowpowertimeout+ #x0051) +(defconstant +spi-setpowerofftimeout+ #x0052) +(defconstant +spi-getlowpoweractive+ #x0053) +(defconstant +spi-getpoweroffactive+ #x0054) +(defconstant +spi-setlowpoweractive+ #x0055) +(defconstant +spi-setpoweroffactive+ #x0056) +(defconstant +spi-setcursors+ #x0057) +(defconstant +spi-seticons+ #x0058) +(defconstant +spi-getdefaultinputlang+ #x0059) +(defconstant +spi-setdefaultinputlang+ #x005A) +(defconstant +spi-setlangtoggle+ #x005B) +(defconstant +spi-getwindowsextension+ #x005C) +(defconstant +spi-setmousetrails+ #x005D) +(defconstant +spi-getmousetrails+ #x005E) +(defconstant +spi-setscreensaverrunning+ #x0061) +(defconstant +spi-screensaverrunning+ #x0061) +(defconstant +spi-getfilterkeys+ #x0032) +(defconstant +spi-setfilterkeys+ #x0033) +(defconstant +spi-gettogglekeys+ #x0034) +(defconstant +spi-settogglekeys+ #x0035) +(defconstant +spi-getmousekeys+ #x0036) +(defconstant +spi-setmousekeys+ #x0037) +(defconstant +spi-getshowsounds+ #x0038) +(defconstant +spi-setshowsounds+ #x0039) +(defconstant +spi-getstickykeys+ #x003A) +(defconstant +spi-setstickykeys+ #x003B) +(defconstant +spi-getaccesstimeout+ #x003C) +(defconstant +spi-setaccesstimeout+ #x003D) +(defconstant +spi-getserialkeys+ #x003E) +(defconstant +spi-setserialkeys+ #x003F) +(defconstant +spi-getsoundsentry+ #x0040) +(defconstant +spi-setsoundsentry+ #x0041) +(defconstant +spi-getsnaptodefbutton+ #x005F) +(defconstant +spi-setsnaptodefbutton+ #x0060) +(defconstant +spi-getmousehoverwidth+ #x0062) +(defconstant +spi-setmousehoverwidth+ #x0063) +(defconstant +spi-getmousehoverheight+ #x0064) +(defconstant +spi-setmousehoverheight+ #x0065) +(defconstant +spi-getmousehovertime+ #x0066) +(defconstant +spi-setmousehovertime+ #x0067) +(defconstant +spi-getwheelscrolllines+ #x0068) +(defconstant +spi-setwheelscrolllines+ #x0069) +(defconstant +spi-getmenushowdelay+ #x006A) +(defconstant +spi-setmenushowdelay+ #x006B) +(defconstant +spi-getshowimeui+ #x006E) +(defconstant +spi-setshowimeui+ #x006F) +(defconstant +spi-getmousespeed+ #x0070) +(defconstant +spi-setmousespeed+ #x0071) +(defconstant +spi-getscreensaverrunning+ #x0072) +(defconstant +spi-getdeskwallpaper+ #x0073) +(defconstant +spi-getactivewindowtracking+ #x1000) +(defconstant +spi-setactivewindowtracking+ #x1001) +(defconstant +spi-getmenuanimation+ #x1002) +(defconstant +spi-setmenuanimation+ #x1003) +(defconstant +spi-getcomboboxanimation+ #x1004) +(defconstant +spi-setcomboboxanimation+ #x1005) +(defconstant +spi-getlistboxsmoothscrolling+ #x1006) +(defconstant +spi-setlistboxsmoothscrolling+ #x1007) +(defconstant +spi-getgradientcaptions+ #x1008) +(defconstant +spi-setgradientcaptions+ #x1009) +(defconstant +spi-getkeyboardcues+ #x100A) +(defconstant +spi-setkeyboardcues+ #x100B) +(defconstant +spi-getmenuunderlines+ #x100A) +(defconstant +spi-setmenuunderlines+ #x100B) +(defconstant +spi-getactivewndtrkzorder+ #x100C) +(defconstant +spi-setactivewndtrkzorder+ #x100D) +(defconstant +spi-gethottracking+ #x100E) +(defconstant +spi-sethottracking+ #x100F) +(defconstant +spi-getmenufade+ #x1012) +(defconstant +spi-setmenufade+ #x1013) +(defconstant +spi-getselectionfade+ #x1014) +(defconstant +spi-setselectionfade+ #x1015) +(defconstant +spi-gettooltipanimation+ #x1016) +(defconstant +spi-settooltipanimation+ #x1017) +(defconstant +spi-gettooltipfade+ #x1018) +(defconstant +spi-settooltipfade+ #x1019) +(defconstant +spi-getcursorshadow+ #x101A) +(defconstant +spi-setcursorshadow+ #x101B) +(defconstant +spi-getmousesonar+ #x101C) +(defconstant +spi-setmousesonar+ #x101D) +(defconstant +spi-getmouseclicklock+ #x101E) +(defconstant +spi-setmouseclicklock+ #x101F) +(defconstant +spi-getmousevanish+ #x1020) +(defconstant +spi-setmousevanish+ #x1021) +(defconstant +spi-getflatmenu+ #x1022) +(defconstant +spi-setflatmenu+ #x1023) +(defconstant +spi-getdropshadow+ #x1024) +(defconstant +spi-setdropshadow+ #x1025) +(defconstant +spi-getblocksendinputresets+ #x1026) +(defconstant +spi-setblocksendinputresets+ #x1027) +(defconstant +spi-getuieffects+ #x103E) +(defconstant +spi-setuieffects+ #x103F) +(defconstant +spi-getforegroundlocktimeout+ #x2000) +(defconstant +spi-setforegroundlocktimeout+ #x2001) +(defconstant +spi-getactivewndtrktimeout+ #x2002) +(defconstant +spi-setactivewndtrktimeout+ #x2003) +(defconstant +spi-getforegroundflashcount+ #x2004) +(defconstant +spi-setforegroundflashcount+ #x2005) +(defconstant +spi-getcaretwidth+ #x2006) +(defconstant +spi-setcaretwidth+ #x2007) +(defconstant +spi-getmouseclicklocktime+ #x2008) +(defconstant +spi-setmouseclicklocktime+ #x2009) +(defconstant +spi-getfontsmoothingtype+ #x200A) +(defconstant +spi-setfontsmoothingtype+ #x200B) +(defconstant +spi-getfontsmoothingcontrast+ #x200C) +(defconstant +spi-setfontsmoothingcontrast+ #x200D) +(defconstant +spi-getfocusborderwidth+ #x200E) +(defconstant +spi-setfocusborderwidth+ #x200F) +(defconstant +spi-getfocusborderheight+ #x2010) +(defconstant +spi-setfocusborderheight+ #x2011) +(defconstant +spi-getfontsmoothingorientation+ #x2012) +(defconstant +spi-setfontsmoothingorientation+ #x2013) + (defconstant +ss-left+ #x00000000) (defconstant +ss-center+ #x00000001) (defconstant +ss-right+ #x00000002) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Wed Nov 29 13:23:14 2006 @@ -785,6 +785,14 @@ (cmd INT)) (defcfun + ("SystemParametersInfoA" system-parameters-info) + BOOL + (action UINT) + (iparam UINT) + (vparam LPTR) + (ini UINT)) + +(defcfun ("TrackPopupMenuEx" track-popup-menu) BOOL (hmenu HANDLE) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed Nov 29 13:23:14 2006 @@ -97,8 +97,7 @@ (process-events) (unwind-protect (setf ,retval (progn , at body)) - (setf (slot-value ,widget 'cursor) ,old) - (gfs:dispose ,new)) + (setf (cursor-of ,widget) ,old)) ,retval))) (defmacro with-wait-cursor ((widget) &body body) From junrue at common-lisp.net Wed Nov 29 18:51:07 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 29 Nov 2006 13:51:07 -0500 (EST) Subject: [graphic-forms-cvs] r406 - trunk/src/uitoolkit/widgets Message-ID: <20061129185107.A35ED4C013@common-lisp.net> Author: junrue Date: Wed Nov 29 13:51:06 2006 New Revision: 406 Modified: trunk/src/uitoolkit/widgets/widget.lisp Log: fixed a regression in (setf cursor-of) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed Nov 29 13:51:06 2006 @@ -81,7 +81,9 @@ (let ((capture-hwnd (gfs::get-capture))) (if (or (gfs:null-handle-p capture-hwnd) (cffi:pointer-eq capture-hwnd (gfs:handle widget))) - (gfs::set-cursor (gfs:handle cursor))))) + (if cursor + (gfs::set-cursor (gfs:handle cursor)) + (gfs::set-cursor (cffi:null-pointer)))))) (defmacro with-cursor ((widget &key file hotspot image system) &body body) (lispworks:with-unique-names (old new retval) From junrue at common-lisp.net Thu Nov 30 03:16:44 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 29 Nov 2006 22:16:44 -0500 (EST) Subject: [graphic-forms-cvs] r407 - trunk/src/tests/uitoolkit Message-ID: <20061130031644.7F2A14D001@common-lisp.net> Author: junrue Date: Wed Nov 29 22:16:44 2006 New Revision: 407 Added: trunk/src/tests/uitoolkit/custom.cur (contents, props changed) Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Log: added test for loading and using cursor from file Added: trunk/src/tests/uitoolkit/custom.cur ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-grid-panel.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Wed Nov 29 22:16:44 2006 @@ -46,6 +46,7 @@ (declare (ignore disp item))) (defun make-scroll-grid-panel (parent) + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((panel-size (gfs:make-size :width (1+ (* (gfs:size-width *grid-model-size*) +grid-cell-extent+)) :height (1+ (* (gfs:size-height *grid-model-size*) +grid-cell-extent+)))) (panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events) @@ -55,7 +56,9 @@ (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size))) (setf (gfs:size-width *grid-char-size*) (floor +grid-half-extent+ 2) (gfs:size-height *grid-char-size*) (floor +grid-half-extent+ 2)) - (setf (gfw:cursor-of panel) (make-instance 'gfg:cursor :system gfg:+hand-cursor+)) + (setf (gfw:cursor-of panel) + (make-instance 'gfg:cursor + :file (merge-pathnames "custom.cur"))) panel)) (defun set-grid-scroll-params (window)