From junrue at common-lisp.net Fri Sep 1 04:27:51 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 1 Sep 2006 00:27:51 -0400 (EDT) Subject: [graphic-forms-cvs] r245 - in trunk: docs/manual src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060901042751.16787390E5@common-lisp.net> Author: junrue Date: Fri Sep 1 00:27:49 2006 New Revision: 245 Modified: trunk/docs/manual/event-functions.texinfo trunk/docs/manual/glossary.texinfo trunk/docs/manual/reference.texinfo trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented wrappers for list box messages, implemented list-box preferred-size method, some light refactoring of other controls Modified: trunk/docs/manual/event-functions.texinfo ============================================================================== --- trunk/docs/manual/event-functions.texinfo (original) +++ trunk/docs/manual/event-functions.texinfo Fri Sep 1 00:27:49 2006 @@ -37,7 +37,7 @@ @end defun @anchor{event-activate} - at deffn GenericFunction event-activate dispatcher widget + at deffn GenericFunction event-activate @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being activated. For a @ref{top-level} @ref{window} or @ref{dialog}, this means that @var{widget} was brought to the foreground and its trim (titlebar and @@ -64,7 +64,7 @@ @end table @end deffn - at deffn GenericFunction event-close dispatcher widget + at deffn GenericFunction event-close @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being closed by the user. Only @ref{dialog}s and @ref{top-level} @ref{window}s receive close events. @@ -76,7 +76,7 @@ @end deffn @anchor{event-deactivate} - at deffn GenericFunction event-deactivate dispatcher widget + at deffn GenericFunction event-deactivate @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being deactivated, meaning that some other object has been made active. This event only applies to @ref{top-level} @ref{window}s or @@ -88,7 +88,21 @@ @end table @end deffn - at deffn GenericFunction event-dispose dispatcher widget + at anchor{event-default-action} + at deffn GenericFunction event-default-action @ref{event-dispatcher} @ref{widget} +Implement this method to respond to a @ref{default action}, for +example when the user double-clicks on a @ref{list-box} @ref{item}, or +presses @sc{enter} while the keyboard focus is in an @ref{edit} +control. + at table @var + at event-dispatcher-arg + at item widget +The @ref{widget} for which the default action was invoked. + at end table + at end deffn + + at anchor{event-dispose} + at deffn GenericFunction event-dispose @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} being disposed (explicitly via @ref{dispose}; this event is not associated with garbage collection). This event function is called while the contents of @var{widget} are still @@ -101,7 +115,7 @@ @end deffn @anchor{event-focus-gain} - at deffn GenericFunction event-focus-gain dispatcher widget + at deffn GenericFunction event-focus-gain @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} gaining keyboard focus. @table @var @event-dispatcher-arg @@ -111,7 +125,7 @@ @end deffn @anchor{event-focus-loss} - at deffn GenericFunction event-focus-loss dispatcher widget + at deffn GenericFunction event-focus-loss @ref{event-dispatcher} @ref{widget} Implement this method to respond to @var{widget} losing keyboard focus. @table @var @event-dispatcher-arg @@ -120,7 +134,7 @@ @end table @end deffn - at deffn GenericFunction event-key-down dispatcher widget keycode char + at deffn GenericFunction event-key-down @ref{event-dispatcher} @ref{widget} keycode char Implement this method to respond to a key being pressed within @var{widget}. @table @var @@ -135,7 +149,7 @@ @end table @end deffn - at deffn GenericFunction event-key-up dispatcher widget keycode char + at deffn GenericFunction event-key-up @ref{event-dispatcher} @ref{widget} keycode char Implement this method to respond to a key being released within @var{widget}. @table @var @event-dispatcher-arg @@ -150,7 +164,7 @@ @end deffn @anchor{event-modify} - at deffn GenericFunction event-modify dispatcher widget + at deffn GenericFunction event-modify @ref{event-dispatcher} @ref{widget} Implement this method to respond to changes due to user input within @ref{widget}, for example when the user types text inside an @ref{edit} @ref{control}. @@ -161,7 +175,7 @@ @end table @end deffn - at deffn GenericFunction event-mouse-double dispatcher widget point button + at deffn GenericFunction event-mouse-double @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button double-click within @var{widget}. @table @var @event-dispatcher-arg @@ -172,7 +186,7 @@ @end table @end deffn - at deffn GenericFunction event-mouse-down dispatcher widget point button + at deffn GenericFunction event-mouse-down @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button click within @var{widget}. @table @var @event-dispatcher-arg @@ -183,7 +197,7 @@ @end table @end deffn - at deffn GenericFunction event-mouse-move dispatcher widget point button + at deffn GenericFunction event-mouse-move @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse move event within @var{widget}. @table @var @event-dispatcher-arg @@ -194,7 +208,7 @@ @end table @end deffn - at deffn GenericFunction event-mouse-up dispatcher widget point button + at deffn GenericFunction event-mouse-up @ref{event-dispatcher} @ref{widget} @ref{point} button Implement this method to respond to a mouse button being released within @var{widget}. @table @var @@ -206,7 +220,7 @@ @end table @end deffn - at deffn GenericFunction event-move dispatcher widget point + at deffn GenericFunction event-move @ref{event-dispatcher} @ref{widget} @ref{point} Implement this method to respond to @var{widget} being moved within its @ref{parent}'s coordinate system. @table @var @@ -219,7 +233,7 @@ @end deffn @anchor{event-paint} - at deffn GenericFunction event-paint dispatcher widget gc rect + at deffn GenericFunction event-paint @ref{event-dispatcher} @ref{widget} @ref{graphics-context} @ref{rectangle} Implement this method to respond to system requests to repaint @var{widget}. @table @var @event-dispatcher-arg @@ -233,7 +247,7 @@ @end table @end deffn - at deffn GenericFunction event-resize dispatcher widget size type + at deffn GenericFunction event-resize @ref{event-dispatcher} @ref{widget} size type Implement this method to respond to @var{widget} being resized. @table @var @event-dispatcher-arg @@ -258,7 +272,7 @@ @end deffn @anchor{event-select} - at deffn GenericFunction event-select dispatcher widget + at deffn GenericFunction event-select @ref{event-dispatcher} @ref{widget} Implement this method to handle notification that @var{widget} (or some @ref{item} within @var{widget}) has been clicked on by the user in order to invoke some action. Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Fri Sep 1 00:27:49 2006 @@ -40,6 +40,17 @@ accept user input and possibly generate notification events based on such input.@* + at item default action + at anchor{default action} + at cindex default action +Conceptually, a default action is a secondary event initiated by user +input that is a logical follow-up to a previous event. Examples of +such user gestures include double-clicking an item in a list box +control, or pressing @sc{enter} when an edit control has the keyboard +focus. The response to a default action makes use of context +established by the preceding event (e.g., the selection set by an +initial click becomes the context for the double-click response).@* + @item dialog @cindex dialog A dialog is a mechanism for collecting user input or showing Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Fri Sep 1 00:27:49 2006 @@ -70,7 +70,7 @@ @end macro @macro event-dispatcher-arg - at item dispatcher + at item event-dispatcher The @ref{event-dispatcher} to process this event. @end macro Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Sep 1 00:27:49 2006 @@ -556,6 +556,13 @@ (defconstant +lb-multipleaddstring+ #x01B1) (defconstant +lb-getlistboxinfo+ #x01B2) +(defconstant +lbn-errspace+ -2) +(defconstant +lbn-selchange+ 1) +(defconstant +lbn-dblclk+ 2) +(defconstant +lbn-selcancel+ 3) +(defconstant +lbn-setfocus+ 4) +(defconstant +lbn-killfocus+ 5) + (defconstant +lbs-notify+ #x0001) (defconstant +lbs-sort+ #x0002) (defconstant +lbs-noredraw+ #x0004) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Sep 1 00:27:49 2006 @@ -97,7 +97,7 @@ (init-control self)) (defmethod preferred-size ((self button) width-hint height-hint) - (let ((text-size (widget-text-size self gfs::+dt-singleline+)) + (let ((text-size (widget-text-size self #'text gfs::+dt-singleline+)) (size (gfs:make-size)) (b-width (* (border-width self) 2)) (need-cb-size (intersection '(:check-box :radio-button :tri-state) (style-of self))) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Fri Sep 1 00:27:49 2006 @@ -115,7 +115,7 @@ (gfs::send-message (gfs:handle self) gfs::+wm-paste+ 0 0)) (defmethod preferred-size ((self edit) width-hint height-hint) - (let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) + (let ((text-size (widget-text-size self #'text (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) (size (gfs:make-size)) (b-width (* (border-width self) 2))) (if (>= width-hint 0) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Fri Sep 1 00:27:49 2006 @@ -58,6 +58,11 @@ (:method (dispatcher widget) (declare (ignorable dispatcher widget)))) +(defgeneric event-default-action (dispatcher widget) + (:documentation "Implement this to respond to the widget-specific default action.") + (:method (dispatcher widget) + (declare (ignorable dispatcher widget)))) + (defgeneric event-deiconify (dispatcher widget) (:documentation "Implement this to respond to an object being deiconified.") (:method (dispatcher widget) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Sep 1 00:27:49 2006 @@ -120,10 +120,13 @@ (defun dispatch-notification (widget wparam-hi) (let ((disp (dispatcher widget))) (case wparam-hi - (0 (event-select disp widget)) - (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) - (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) - (#.gfs::+en-update+ (event-modify disp widget))))) + (0 (event-select disp widget)) + (#.gfs::+en-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+en-setfocus+ (event-focus-gain disp widget)) + (#.gfs::+en-update+ (event-modify disp widget)) + (#.gfs::+lbn-dblclk+ (event-default-action disp widget)) + (#.gfs::+lbn-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget))))) (defun process-ctlcolor-message (wparam lparam) (let* ((widget (get-widget (thread-context) (cffi:make-pointer lparam))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Sep 1 00:27:49 2006 @@ -178,7 +178,7 @@ (size nil)) (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf size (widget-text-size self flags)) + (setf size (widget-text-size self #'text flags)) (if (>= width-hint 0) (setf (gfs:size-width size) width-hint) (incf (gfs:size-width size) b-width)) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 1 00:27:49 2006 @@ -34,17 +34,6 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; helper functions -;;; - -(defun insert-list-item (hwnd index label hbmp) - (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box - (let ((text (or label ""))) - (cffi:with-foreign-string (str-ptr text) - (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) - (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) - -;;; ;;; methods ;;; @@ -54,7 +43,7 @@ (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) (item (create-item-with-callback hcontrol 'list-item thing disp))) - (insert-list-item hcontrol -1 text (cffi:null-pointer)) + (lb-insert-item hcontrol -1 text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) item)) @@ -103,16 +92,41 @@ (setf (slot-value self 'gfs:handle) hwnd))) (init-control self) (if (and estimated-count (> estimated-count 0)) - (gfs::send-message (gfs:handle self) - gfs::+lb-initstorage+ - estimated-count - (* estimated-count +estimated-text-size+))) + (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) (update-from-items self)) (defmethod (setf items-of) :after (new-items (self list-box)) (declare (ignore new-items)) (update-from-items self)) +(defmethod preferred-size ((self list-box) width-hint height-hint) + (let ((hwnd (gfs:handle self)) + (size (gfs:make-size :width width-hint :height height-hint)) + (b-width (* (border-width self) 2))) + (flet ((item-text (index) + (lb-item-text hwnd index (1+ (lb-item-text-length hwnd index))))) + (when (< width-hint 0) + (setf (gfs:size-width size) + (loop for index to (1- (lb-item-count hwnd)) + with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) + maximizing (widget-text-size self + (lambda () (item-text index)) + dt-flags) + into max-width + finally (return max-width))))) + (if (zerop (gfs:size-width size)) + (setf (gfs:size-width size) +default-widget-width+) + (incf (gfs:size-width size) b-width)) + (when (< height-hint 0) + (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) + (if (zerop (gfs:size-height size)) + (setf (gfs:size-height size) +default-widget-height+) + (incf (gfs:size-height size) b-width)) + (if (= (logand (gfs::get-window-long hwnd gfs::+gwl-style+) gfs::+ws-vscroll+) + gfs::+ws-vscroll+) + (incf (gfs:size-width size) (vertical-scrollbar-width))) + size)) + (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (items (items-of self)) @@ -123,7 +137,7 @@ (enable-redraw self nil) (unwind-protect (progn - (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) + (lb-clear-content hwnd) (loop for item in items for index = 0 then (1+ index) do (progn Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Fri Sep 1 00:27:49 2006 @@ -34,6 +34,55 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(defun lb-init-storage (hwnd item-count total-bytes) + (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) + +(defun lb-clear-content (hwnd) + (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) + +(defun lb-insert-item (hwnd index label hbmp) + (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box + (let ((text (or label ""))) + (cffi:with-foreign-string (str-ptr text) + (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) + (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) + +(defun lb-width (hwnd) + (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) + (if (< width 0) + (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) + width)) + +(defun lb-item-count (hwnd) + (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (if (< count 0) + (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) + count)) + +(defun lb-item-height (hwnd) + (let ((height (gfs::send-message hwnd gfs::+lb-getitemheight+ 0 0))) + (if (< height 0) + (error 'gfs:win32-error :detail "LB_GETITEMHEIGHT failed")) + height)) + +(defun lb-item-text (hwnd index &optional buffer-size) + (if (or (null buffer-size) (<= buffer-size 0)) + (setf buffer-size (lb-item-text-length hwnd index))) + (cffi:with-foreign-pointer-as-string (str-ptr (1+ buffer-size)) + (if (< (gfs::send-message hwnd gfs::+lb-gettext+ index (cffi:pointer-address str-ptr)) 0) + (error 'gfs:win32-error :detail "LB_GETTEXT failed")) + (cffi:foreign-string-to-lisp str-ptr))) + +(defun lb-item-text-length (hwnd index) + (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0))) + (if (< length 0) + (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed")) + length)) + +;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Fri Sep 1 00:27:49 2006 @@ -95,5 +95,7 @@ (defconstant +vk-right-alt+ #xA5) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) - (defconstant +estimated-text-size+ 32)) ;; bytes + (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) + (defconstant +default-widget-width+ 64) + (defconstant +default-widget-height+ 64) + (defconstant +estimated-text-size+ 32)) ; bytes Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Sep 1 00:27:49 2006 @@ -190,18 +190,30 @@ (setf (gfs:size-width sz) (- gfs::windowright gfs::windowleft)) (setf (gfs:size-height sz) (- gfs::windowbottom gfs::windowtop))))) +(defun horizontal-scrollbar-height () + (gfs::get-system-metrics gfs::+sm-cyhscroll+)) + +(defun horizontal-scrollbar-arrow-width () + (gfs::get-system-metrics gfs::+sm-cxhscroll+)) + +(defun vertical-scrollbar-arrow-height () + (gfs::get-system-metrics gfs::+sm-cyvscroll+)) + +(defun vertical-scrollbar-width () + (gfs::get-system-metrics gfs::+sm-cxvscroll+)) + (defun set-widget-text (w str) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) (gfs::set-window-text (gfs:handle w) str)) -(defun widget-text-size (widget dt-flags) +(defun widget-text-size (widget text-func dt-flags) (let ((hwnd (gfs:handle widget)) (hfont nil)) (gfs::with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs::with-hfont-selected (hdc hfont) - (gfg::text-bounds hdc (text widget) dt-flags 0))))) + (gfg::text-bounds hdc (funcall text-func widget) dt-flags 0))))) ;;; ;;; This algorithm adapted from the calculate_best_bounds() @@ -233,8 +245,8 @@ ;; use scrollbar system metric values as a rough approximation ;; (return-from check-box-size - (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxvscroll+) - :height (gfs::get-system-metrics gfs::+sm-cyvscroll+)))) + (gfs:make-size :width (vertical-scrollbar-width) + :height (vertical-scrollbar-arrow-height)))) (unwind-protect (cffi:with-foreign-object (bm-ptr 'gfs::bitmap) From junrue at common-lisp.net Mon Sep 4 20:01:48 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 4 Sep 2006 16:01:48 -0400 (EDT) Subject: [graphic-forms-cvs] r246 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060904200148.1A0744900A@common-lisp.net> Author: junrue Date: Mon Sep 4 16:01:46 2006 New Revision: 246 Added: trunk/src/tests/uitoolkit/widget-tester.lisp Modified: trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-tests.asd trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: lots of list-box debugging, with new widget-tester test program Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Sep 4 16:01:46 2006 @@ -387,8 +387,8 @@ case the control will re-allocate storage as necessary). @end deffn @deffn Initarg :items -This initarg accepts a list of objects for populating the -contents of the list-box. The list-box will hold references to the +This initarg accepts a list of @ref{list-item} objects for populating +the contents of the list-box. The list-box will hold references to the supplied objects. See also @ref{append-item}. @end deffn @control-parent-initarg{list-box} @@ -693,7 +693,11 @@ @anchor{panel} @deftp Class panel Base class for @ref{window}s that are children of @ref{top-level} -windows, @ref{dialog}s, or other @code{panel}s. +windows, @ref{dialog}s, or other panels. + at deffn Initarg :parent +This initarg is used to specify the @ref{parent} window of the +panel. + at end deffn @end deftp @anchor{root-window} Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Sep 4 16:01:46 2006 @@ -42,6 +42,7 @@ #:hello-world #:image-tester #:layout-tester + #:widget-tester #:textedit #:unblocked #:windlg)) @@ -87,4 +88,5 @@ (:file "layout-tester") (:file "image-tester") (:file "drawing-tester") + (:file "widget-tester") (:file "windlg"))))))))) Added: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Mon Sep 4 16:01:46 2006 @@ -0,0 +1,91 @@ +;;;; +;;;; widget-tester.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) + + ;; drop cookies +(defvar *list-box-test-data* '("chocolate chip" "butterscotch crunch" "peanut butter" "oatmeal" + ;; molded cookies + "butterfinger chunkies" "jam thumbprints" "cappuccino flats" + ;; pressed cookies + "langues de chat" "macaroons" "shortbread" + ;; refrigerator cookies + "brysell" "caramel" "mosaic" "praline" "toffee")) + +(defvar *widget-tester-win* nil) + +(defun widget-tester-exit (disp item) + (declare (ignore disp item)) + (gfs:dispose *widget-tester-win*) + (setf *widget-tester-win* nil) + (gfw:shutdown 0)) + +(defclass widget-tester-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp widget-tester-events) window) + (declare (ignore window)) + (widget-tester-exit disp nil)) + +(defclass widget-tester-panel-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-paint ((disp widget-tester-panel-events) window gc rect) + (declare (ignore rect)) + (setf (gfg:background-color gc) gfg:*color-white* + (gfg:foreground-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) + +(defun populate-list-box-test-panel () + (let* ((disp (make-instance 'widget-tester-panel-events)) + (layout (make-instance 'gfw:flow-layout)) + (panel (make-instance 'gfw:panel :dispatcher disp + :parent *widget-tester-win* + :layout layout))) + (make-instance 'gfw:list-box :parent panel :items *list-box-test-data*) + (gfW:pack panel) + panel)) + +(defun widget-tester-internal () + (let ((disp (make-instance 'widget-tester-events)) + (layout (make-instance 'gfw:heap-layout)) + (menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'widget-tester-exit))))))) + (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher disp + :layout layout + :style '(:frame))) + (setf (gfw:menu-bar *widget-tester-win*) menubar) + (setf (gfw:top-child-of layout) (populate-list-box-test-panel)) + (gfw:pack *widget-tester-win*) + (gfw:show *widget-tester-win* t))) + +(defun widget-tester () + (gfw:startup "Widget Tester" #'widget-tester-internal)) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Sep 4 16:01:46 2006 @@ -48,6 +48,33 @@ (t (funcall func thing))))) +(defun copy-item-sequence (parent new-items item-class) + (let ((hwnd (gfs:handle parent)) + (tc (thread-context)) + (replacements (make-array 7 :fill-pointer 0 :adjustable t))) + (cond + ((null new-items) + replacements) + ((vectorp new-items) + (dotimes (i (length new-items)) + (let ((item (elt new-items i))) + (if (typep item item-class) + (vector-push-extend item replacements) + (let ((tmp (make-instance item-class :handle hwnd :data item))) + (put-item tc tmp) + (vector-push-extend tmp replacements))))) + replacements) + ((listp new-items) + (loop for item in new-items + do (if (typep item item-class) + (vector-push-extend item replacements) + (let ((tmp (make-instance item-class :handle hwnd :data item))) + (put-item tc tmp) + (vector-push-extend tmp replacements)))) + replacements) + (t + (error 'gfs:toolkit-error :detail (format nil "invalid data structure type: ~a" new-items)))))) + ;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Mon Sep 4 16:01:46 2006 @@ -90,3 +90,10 @@ (if (null widget) (error 'gfs:toolkit-error :detail "no owner widget")) widget))) + +(defmethod print-object ((self item) stream) + (print-unreadable-object (self stream :type t) + (format stream "id: ~d " (item-id self)) + (format stream "data: ~a " (data-of self)) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a" (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Mon Sep 4 16:01:46 2006 @@ -76,23 +76,22 @@ for rect = (cdr k) for size = (gfs:size rect) for pnt = (gfs:location rect) - do (progn - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width size) - (gfs:size-height size) - (funcall flags-func (car k))) - (gfs::defer-window-pos hdwp - (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width size) - (gfs:size-height size) - (funcall flags-func (car k)))))) + do (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))) + (gfs::defer-window-pos hdwp + (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))))) (unless (gfs:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp)))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Mon Sep 4 16:01:46 2006 @@ -43,7 +43,7 @@ (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) (item (create-item-with-callback hcontrol 'list-item thing disp))) - (lb-insert-item hcontrol -1 text (cffi:null-pointer)) + (lb-insert-item hcontrol #xFFFFFFFF text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) item)) @@ -79,7 +79,7 @@ (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) -(defmethod initialize-instance :after ((self list-box) &key estimated-count parent &allow-other-keys) +(defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) @@ -93,10 +93,17 @@ (init-control self) (if (and estimated-count (> estimated-count 0)) (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) + (if items + (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) (update-from-items self)) (defmethod (setf items-of) :after (new-items (self list-box)) - (declare (ignore new-items)) + (let ((old-items (items-of self))) + (dotimes (i (length old-items)) + (let ((victim (elt old-items i))) + (setf (slot-value victim 'gfs:handle) nil) + (gfs:dispose victim)))) + (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) (update-from-items self)) (defmethod preferred-size ((self list-box) width-hint height-hint) @@ -109,14 +116,16 @@ (setf (gfs:size-width size) (loop for index to (1- (lb-item-count hwnd)) with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) - maximizing (widget-text-size self - (lambda () (item-text index)) - dt-flags) + maximizing (gfs:size-width (widget-text-size self + (lambda (unused) + (declare (ignore unused)) + (item-text index)) + dt-flags)) into max-width - finally (return max-width))))) + finally (return (or max-width 0)))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) - (incf (gfs:size-width size) b-width)) + (incf (gfs:size-width size) (+ b-width 4))) (when (< height-hint 0) (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) (if (zerop (gfs:size-height size)) @@ -131,16 +140,18 @@ (let ((sort-func (sort-predicate-of self)) (items (items-of self)) (hwnd (gfs:handle self))) +#| (when sort-func (setf items (gfs::indexed-sort items sort-func (lambda (it) (data-of it))) (items-of self) items)) +|# (enable-redraw self nil) (unwind-protect (progn (lb-clear-content hwnd) - (loop for item in items - for index = 0 then (1+ index) - do (progn - (setf (index-of item) index) - (append-item self item (dispatcher self))))) + (dotimes (index (length items)) + (let* ((item (elt items index)) + (text (call-text-provider self (data-of item)))) + (setf (index-of item) index) + (lb-insert-item hwnd #xFFFFFFFF text (cffi:null-pointer))))) (enable-redraw self t)))) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Mon Sep 4 16:01:46 2006 @@ -47,8 +47,9 @@ (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box (let ((text (or label ""))) (cffi:with-foreign-string (str-ptr text) - (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) - (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) + (let ((retval (gfs::send-message hwnd gfs::+lb-insertstring+ index (cffi:pointer-address str-ptr)))) + (if (< retval 0) + (error 'gfs:toolkit-error :detail (format nil "LB_INSERTSTRING failed: ~d" retval))))))) (defun lb-width (hwnd) (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) @@ -88,8 +89,16 @@ (defmethod gfs:dispose ((self list-item)) (let ((index (index-of self)) - (owner (owner self))) - (if owner - (gfs::send-message (gfs:handle owner) gfs::+lb-deletestring+ index 0)) + (howner (gfs:handle self))) + (if howner + (gfs::send-message howner gfs::+lb-deletestring+ index 0)) (setf (index-of self) 0)) (call-next-method)) + +(defmethod print-object ((self list-item) stream) + (print-unreadable-object (self stream :type t) + (format stream "id: ~d " (item-id self)) + (format stream "index: ~d " (index-of self)) + (format stream "data: ~a " (data-of self)) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a" (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Sep 4 16:01:46 2006 @@ -183,7 +183,7 @@ :initform nil)) (:documentation "A mix-in for objects composed of sub-elements.")) -(defclass list-box (widget item-manager) +(defclass list-box (control item-manager) ((callback-event-name :accessor callback-event-name-of :initform 'event-select Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Sep 4 16:01:46 2006 @@ -310,7 +310,7 @@ (defmethod print-object ((self widget) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a~%" (dispatcher self)))) + (format stream "dispatcher: ~a" (dispatcher self)))) (defmethod redo-available-p :before ((self widget)) (if (gfs:disposed-p self) From junrue at common-lisp.net Tue Sep 5 04:26:39 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 5 Sep 2006 00:26:39 -0400 (EDT) Subject: [graphic-forms-cvs] r247 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets Message-ID: <20060905042639.B36767C006@common-lisp.net> Author: junrue Date: Tue Sep 5 00:26:37 2006 New Revision: 247 Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/list-box.lisp Log: fixed bugs in indexed-sort, got listbox selection notification working, revised list-box compute-style-flags Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Tue Sep 5 00:26:37 2006 @@ -45,7 +45,7 @@ (assert-true (> (gfs:size-height size)) 0)) (assert-true (> (length (gfw:text display)) 0)))) -(define-test indexed-sort-test +(define-test indexed-sort-list-test (let* ((orig1 '("zzz" "mmm" "aaa")) (result1 (gfs::indexed-sort orig1 #'string< #'identity)) (orig2 '((zzz 10) (mmm 5) (aaa 1))) @@ -59,3 +59,46 @@ (assert-true (= 5 (second (second result2)))) (assert-true (eql 'zzz (first (third result2)))) (assert-true (= 10 (second (third result2)))))) + +(defun validate-array-elements (arr1 arr2) + (assert-true (string= "aaa" (elt arr1 0))) + (assert-true (string= "mmm" (elt arr1 1))) + (assert-true (string= "zzz" (elt arr1 2))) + (assert-true (eql 'aaa (first (elt arr2 0)))) + (assert-true (= 1 (second (elt arr2 0)))) + (assert-true (eql 'mmm (first (elt arr2 1)))) + (assert-true (= 5 (second (elt arr2 1)))) + (assert-true (eql 'zzz (first (elt arr2 2)))) + (assert-true (= 10 (second (elt arr2 2))))) + +(define-test indexed-sort-non-adjustable-array-test + (let* ((orig1 (make-array 3 :initial-contents '("zzz" "mmm" "aaa"))) + (result1 (gfs::indexed-sort orig1 #'string< #'identity)) + (orig2 (make-array 3 :initial-contents '((zzz 10) (mmm 5) (aaa 1)))) + (result2 (gfs::indexed-sort orig2 #'string< #'first))) + (assert-false (array-has-fill-pointer-p result1)) + (assert-false (array-has-fill-pointer-p result2)) + (assert-false (adjustable-array-p result1)) + (assert-false (adjustable-array-p result2)) + (assert-equal 3 (first (array-dimensions result1))) + (assert-equal 3 (first (array-dimensions result2))) + (assert-equal 3 (length result1)) + (assert-equal 3 (length result2)) + (validate-array-elements result1 result2))) + +(define-test indexed-sort-adjustable-array-test + (let ((orig1 (make-array 3 :adjustable t :fill-pointer 0)) + (orig2 (make-array 3 :adjustable t :fill-pointer 0))) + (loop for item in '("zzz" "mmm" "aaa") do (vector-push item orig1)) + (loop for item in '((zzz 10) (mmm 5) (aaa 1)) do (vector-push item orig2)) + (let ((result1 (gfs::indexed-sort orig1 #'string< #'identity)) + (result2 (gfs::indexed-sort orig2 #'string< #'first))) + (assert-true (array-has-fill-pointer-p result1)) + (assert-true (array-has-fill-pointer-p result2)) + (assert-true (adjustable-array-p result1)) + (assert-true (adjustable-array-p result2)) + (assert-equal 3 (first (array-dimensions result1))) + (assert-equal 3 (first (array-dimensions result2))) + (assert-equal 3 (length result1)) + (assert-equal 3 (length result2)) + (validate-array-elements result1 result2)))) Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Tue Sep 5 00:26:37 2006 @@ -60,21 +60,61 @@ (defmethod gfw:event-paint ((disp widget-tester-panel-events) window gc rect) (declare (ignore rect)) - (setf (gfg:background-color gc) gfg:*color-white* - (gfg:foreground-color gc) gfg:*color-white*) + (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) +(defun lb-select (disp lb) + (declare (ignore disp)) + (print lb)) + (defun populate-list-box-test-panel () - (let* ((disp (make-instance 'widget-tester-panel-events)) - (layout (make-instance 'gfw:flow-layout)) - (panel (make-instance 'gfw:panel :dispatcher disp - :parent *widget-tester-win* - :layout layout))) - (make-instance 'gfw:list-box :parent panel :items *list-box-test-data*) - (gfW:pack panel) - panel)) + (setf (gfw:text *widget-tester-win*) "Widget Tester (List Boxes)") + (let* ((panel-disp (make-instance 'widget-tester-panel-events)) + (lb1 nil) + (lb2 nil) + (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent *widget-tester-win* + :layout (make-instance 'gfw:flow-layout :spacing 4 :margins 4))) + (lb1-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) + (btn-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) + (lb2-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4)))) + (make-instance 'gfw:label :text "Multiple Select:" :parent lb1-panel) + (setf lb1 (make-instance 'gfw:list-box :parent lb1-panel + :callback #'lb-select + :sort-predicate #'string< + :style '(:multiple-select) + :items (subseq *list-box-test-data* 4))) + (gfw:pack lb1-panel) + (make-instance 'gfw:button :parent btn-panel :text " ==> ") + (make-instance 'gfw:button :parent btn-panel :text " <== ") + (gfw:pack btn-panel) + (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) + (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel + :callback #'lb-select + :style '(:extend-select :want-scrollbar) + :items (subseq *list-box-test-data* 4))) + (gfw:pack lb2-panel) + (gfw:pack outer-panel) + (let ((size (gfw:size lb1))) + (setf (gfw:maximum-size lb1) size + (gfw:minimum-size lb1) size + (gfw:maximum-size lb2) size + (gfw:minimum-size lb2) size)) + (setf (gfw:items-of lb1) *list-box-test-data*) + (gfw:update-from-items lb1) + (gfw:delete-all lb2) + outer-panel)) (defun widget-tester-internal () + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((disp (make-instance 'widget-tester-events)) (layout (make-instance 'gfw:heap-layout)) (menubar (gfw:defmenu ((:item "&File" @@ -82,8 +122,9 @@ (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher disp :layout layout :style '(:frame))) - (setf (gfw:menu-bar *widget-tester-win*) menubar) - (setf (gfw:top-child-of layout) (populate-list-box-test-panel)) + (setf (gfw:menu-bar *widget-tester-win*) menubar + (gfw:top-child-of layout) (populate-list-box-test-panel) + (gfw:image *widget-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:pack *widget-tester-win*) (gfw:show *widget-tester-win* t))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Tue Sep 5 00:26:37 2006 @@ -37,12 +37,32 @@ ;;; convenience functions ;;; +(defun recreate-array (array) + (make-array (array-dimensions array) + :adjustable (adjustable-array-p array) + :fill-pointer (if (array-has-fill-pointer-p array) 0 nil))) + (defun indexed-sort (sequence predicate key) - (let* ((tmp1 (loop for item in sequence - collect (list (funcall key item) item))) - (tmp2 (sort tmp1 predicate :key #'first))) - (loop for item in tmp2 - collect (second item)))) + (let ((result (cond + ((listp sequence) + nil) + ((vectorp sequence) + (recreate-array sequence)) + (t + (error 'gfs:toolkit-error :detail (format nil "unsupported type: ~a" sequence))))) + (tmp nil)) + (dotimes (i (length sequence)) + (let ((item (elt sequence i))) + (pushnew (list (funcall key item) item) tmp))) + (setf tmp (sort (reverse tmp) predicate :key #'first)) + (cond + ((listp result) + (setf result (loop for item in tmp collect (second item)))) + ((adjustable-array-p result) + (dotimes (i (length tmp)) (vector-push (second (elt tmp i)) result))) + (t + (dotimes (i (length tmp)) (setf (elt result i) (second (elt tmp i)))))) + result)) (defun flatten (tree) (if (cl:atom tree) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Sep 5 00:26:37 2006 @@ -126,6 +126,7 @@ (#.gfs::+en-update+ (event-modify disp widget)) (#.gfs::+lbn-dblclk+ (event-default-action disp widget)) (#.gfs::+lbn-killfocus+ (event-focus-loss disp widget)) + (#.gfs::+lbn-selchange+ (event-select disp widget)) (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget))))) (defun process-ctlcolor-message (wparam lparam) @@ -180,21 +181,17 @@ (wparam-hi (hi-word wparam)) (wparam-lo (lo-word wparam)) (owner (get-widget tc hwnd))) + ; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) (if owner - (cond - ((zerop lparam) - (let ((item (get-item tc wparam-lo))) - (if (null item) - (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) - (unless (null (dispatcher item)) - (event-select (dispatcher item) item))))) - ((eq wparam-hi 1) - (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug - (t - (let ((widget (get-widget tc (cffi:make-pointer lparam)))) - (when (and widget (dispatcher widget)) - ; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) - (dispatch-notification widget wparam-hi))))) + (if (zerop lparam) + (let ((item (get-item tc wparam-lo))) + (if (null item) + (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)))) + (when (and widget (dispatcher widget)) + (dispatch-notification widget wparam-hi)))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Sep 5 00:26:37 2006 @@ -34,6 +34,25 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(defun lb-extend-select-flags (orig-flags) + (setf orig-flags (logand orig-flags + (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-multiplesel+)))) + (logior orig-flags gfs::+lbs-extendedsel+)) + +(defun lb-multi-select-flags (orig-flags) + (setf orig-flags (logand orig-flags + (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-extendedsel+)))) + (logior orig-flags gfs::+lbs-multiplesel+)) + +(defun lb-no-select-flags (orig-flags) + (setf orig-flags (logand orig-flags + (lognot (logior gfs::+lbs-multiplesel+ gfs::+lbs-extendedsel+)))) + (logior orig-flags gfs::+lbs-nosel+)) + +;;; ;;; methods ;;; @@ -57,26 +76,15 @@ do (ecase sym ;; primary list-box styles ;; - (:extend-select (setf std-flags (logand std-flags (lognot gfs::+lbs-nosel+))) - (setf std-flags (logior std-flags - gfs::+lbs-extendedsel+ - gfs::+lbs-multiplesel+))) - - (:multiple (setf std-flags (logand std-flags (lognot gfs::+lbs-nosel+))) - (setf std-flags (logior std-flags gfs::+lbs-multiplesel+))) - - (:no-select (setf std-flags (logand std-flags - (lognot (logior gfs::+lbs-extendedsel+ - gfs::+lbs-multiplesel+)))) - (setf std-flags (logior std-flags gfs::+lbs-nosel+))) + (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) + (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) + (:no-select (setf std-flags (lb-no-select-flags std-flags))) ;; styles that can be combined ;; - (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) - - (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) - - (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) + (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) + (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) + (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) @@ -97,37 +105,56 @@ (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) (update-from-items self)) -(defmethod (setf items-of) :after (new-items (self list-box)) +(defmethod (setf items-of) :before (new-items (self list-box)) + (declare (ignore new-items)) (let ((old-items (items-of self))) (dotimes (i (length old-items)) (let ((victim (elt old-items i))) (setf (slot-value victim 'gfs:handle) nil) - (gfs:dispose victim)))) + (gfs:dispose victim))))) + +(defmethod (setf items-of) :after (new-items (self list-box)) (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) (update-from-items self)) (defmethod preferred-size ((self list-box) width-hint height-hint) (let ((hwnd (gfs:handle self)) + (min-size (min-size-of self)) + (max-size (max-size-of self)) (size (gfs:make-size :width width-hint :height height-hint)) (b-width (* (border-width self) 2))) - (flet ((item-text (index) - (lb-item-text hwnd index (1+ (lb-item-text-length hwnd index))))) - (when (< width-hint 0) - (setf (gfs:size-width size) - (loop for index to (1- (lb-item-count hwnd)) - with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) - maximizing (gfs:size-width (widget-text-size self - (lambda (unused) - (declare (ignore unused)) - (item-text index)) - dt-flags)) - into max-width - finally (return (or max-width 0)))))) + (cond + ((and min-size (< width-hint (gfs:size-width min-size))) + (setf (gfs:size-width size) (gfs:size-width min-size))) + ((and max-size (> width-hint (gfs:size-width max-size))) + (setf (gfs:size-width size) (gfs:size-width max-size))) + ((>= width-hint 0) + (setf (gfs:size-width size) width-hint)) + (t + (flet ((item-text (index) + (lb-item-text hwnd index (1+ (lb-item-text-length hwnd index))))) + (setf (gfs:size-width size) + (loop for index to (1- (lb-item-count hwnd)) + with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) + maximizing (gfs:size-width (widget-text-size self + (lambda (unused) + (declare (ignore unused)) + (item-text index)) + dt-flags)) + into max-width + finally (return (or max-width 0))))))) + (cond + ((and min-size (< height-hint (gfs:size-height min-size))) + (setf (gfs:size-height size) (gfs:size-height min-size))) + ((and max-size (> height-hint (gfs:size-height max-size))) + (setf (gfs:size-height size) (gfs:size-height max-size))) + ((>= height-hint 0) + (setf (gfs:size-height size) height-hint)) + (t + (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) (incf (gfs:size-width size) (+ b-width 4))) - (when (< height-hint 0) - (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) (if (zerop (gfs:size-height size)) (setf (gfs:size-height size) +default-widget-height+) (incf (gfs:size-height size) b-width)) @@ -138,16 +165,12 @@ (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) - (items (items-of self)) (hwnd (gfs:handle self))) -#| (when sort-func - (setf items (gfs::indexed-sort items sort-func (lambda (it) (data-of it))) - (items-of self) items)) -|# + (setf (slot-value self 'items) (gfs::indexed-sort (items-of self) sort-func #'data-of))) (enable-redraw self nil) (unwind-protect - (progn + (let ((items (items-of self))) (lb-clear-content hwnd) (dotimes (index (length items)) (let* ((item (elt items index)) From junrue at common-lisp.net Tue Sep 5 15:39:38 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 5 Sep 2006 11:39:38 -0400 (EDT) Subject: [graphic-forms-cvs] r248 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060905153938.D980E70210@common-lisp.net> Author: junrue Date: Tue Sep 5 11:39:37 2006 New Revision: 248 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/top-level.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: converted update-native-style to a generic function, added other convenience functions for querying style flags Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Tue Sep 5 11:39:37 2006 @@ -546,9 +546,17 @@ @anchor{update-from-items} @deffn GenericFunction update-from-items self Synchronizes @var{self}'s internal model (i.e., a native control's -data structures) with the list from the @var{items} slot -after that list has been sorted. Application code typically does not -need to call this function. +data structures) with data derived from the @var{items} slot. +If @var{self} has been assigned a sorting predicate, the array +of items will be sorted prior to the internal model update. + at end deffn + + at anchor{update-native-style} + at deffn GenericFunction update-native-style self integer => integer +This function replaces the native style flags of @var{self} with + at var{integer} and calls any additional API needed to ensure that + at var{self}'s visual representation is refreshed. The supplied + at var{integer} is returned. @end deffn @anchor{vertical-scrollbar-p} Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Tue Sep 5 11:39:37 2006 @@ -93,8 +93,8 @@ :style '(:multiple-select) :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) - (make-instance 'gfw:button :parent btn-panel :text " ==> ") - (make-instance 'gfw:button :parent btn-panel :text " <== ") + (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " ==> ") nil) + (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " <== ") nil) (gfw:pack btn-panel) (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Sep 5 11:39:37 2006 @@ -140,3 +140,7 @@ (defmethod text-baseline ((self button)) (widget-text-baseline self +vertical-button-text-margin+)) + +(defmethod update-native-style ((self button) flags) + (gfs::send-message (gfs:handle self) gfs::+bm-setstyle+ flags 1) + flags) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Sep 5 11:39:37 2006 @@ -195,3 +195,12 @@ (defmethod text-baseline ((self control)) (gfs:size-height (size self))) + +(defmethod update-native-style ((self control) flags) + (let ((hwnd (gfs:handle self))) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+))) + flags) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Tue Sep 5 11:39:37 2006 @@ -106,16 +106,16 @@ (let ((old-widget (cancel-widget self))) (if old-widget (let* ((hwnd (gfs:handle old-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style old-widget))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (update-native-style old-widget style)))) (let* ((hwnd (gfs:handle cancel-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style cancel-widget))) (setf style (logior style gfs::+bs-pushbutton+)) (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idcancel+) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) + (update-native-style cancel-widget style))) (defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) @@ -144,18 +144,18 @@ (let ((old-widget (default-widget self))) (if old-widget (let* ((hwnd (gfs:handle old-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style old-widget))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (update-native-style old-widget style)))) (let* ((hdlg (gfs:handle self)) (hwnd (gfs:handle def-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style def-widget))) (setf style (logior style gfs::+bs-defpushbutton+)) (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idok+) (gfs::send-message hdlg gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) + (update-native-style def-widget style))) (defmethod gfs:dispose ((self dialog)) (reenable-top-levels) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Sep 5 11:39:37 2006 @@ -41,12 +41,10 @@ ;;; (defmethod auto-hscroll-p ((self edit)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+es-autohscroll+) gfs::+es-autohscroll+))) + (test-native-style self gfs::+es-autohscroll+)) (defmethod auto-vscroll-p ((self edit)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+))) + (test-native-style self gfs::+es-autovscroll+)) (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) @@ -84,7 +82,7 @@ (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0)) (defmethod enable-scrollbars ((self edit) horizontal vertical) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) + (let ((bits (get-native-style self))) (if horizontal (setf bits (logior bits gfs::+ws-hscroll+)) (setf bits (logand bits (lognot gfs::+ws-hscroll+)))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Sep 5 11:39:37 2006 @@ -117,8 +117,7 @@ (defmethod (setf image) ((image gfg:image) (label label)) (if (or (gfs:disposed-p label) (gfs:disposed-p image)) (error 'gfs:disposed-error)) - (let* ((hwnd (gfs:handle label)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (let* ((orig-flags (get-native-style label)) (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+))) (flags (logior etch-flags @@ -142,8 +141,8 @@ (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) (setf image tmp-image))) (if (/= orig-flags flags) - (gfs::set-window-long hwnd gfs::+gwl-style+ flags)) - (gfs::send-message hwnd + (update-native-style label flags)) + (gfs::send-message (gfs:handle label) gfs::+stm-setimage+ gfs::+image-bitmap+ (cffi:pointer-address (gfs:handle image))))) @@ -164,9 +163,8 @@ (init-control label)) (defmethod preferred-size ((self label) width-hint height-hint) - (let* ((hwnd (gfs:handle self)) - (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) - (b-width (* (border-width self) 2))) + (let ((bits (get-native-style self)) + (b-width (* (border-width self) 2))) (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) (let ((image (image self))) (if image @@ -191,23 +189,18 @@ (get-widget-text self)) (defmethod (setf text) (str (self label)) - (let* ((hwnd (gfs:handle self)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (let* ((orig-flags (get-native-style self)) (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+)))) (multiple-value-bind (std-flags ex-flags) (compute-style-flags self nil nil str) (declare (ignore ex-flags)) - (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags - std-flags - +default-child-style+)))) + (update-native-style self (logior etch-flags std-flags +default-child-style+)))) (set-widget-text self str)) (defmethod text-baseline ((self label)) (let ((b-width (border-width self))) - (if (= (logand (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+) - gfs::+ss-bitmap+) - gfs::+ss-bitmap+) + (if (test-native-style self gfs::+ss-bitmap+) (let ((image (image self))) (if image (+ (gfs:size-height (gfg:size image)) b-width) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Sep 5 11:39:37 2006 @@ -52,6 +52,24 @@ (lognot (logior gfs::+lbs-multiplesel+ gfs::+lbs-extendedsel+)))) (logior orig-flags gfs::+lbs-nosel+)) +(defun lb-init-storage (hwnd item-count total-bytes) + (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) + +(defun lb-clear-content (hwnd) + (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) + +(defun lb-width (hwnd) + (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) + (if (< width 0) + (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) + width)) + +(defun lb-item-count (hwnd) + (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (if (< count 0) + (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) + count)) + ;;; ;;; methods ;;; @@ -151,15 +169,14 @@ ((>= height-hint 0) (setf (gfs:size-height size) height-hint)) (t - (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd))))) + (setf (gfs:size-height size) (* (lb-item-count hwnd) (1+ (lb-item-height hwnd)))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) (incf (gfs:size-width size) (+ b-width 4))) (if (zerop (gfs:size-height size)) (setf (gfs:size-height size) +default-widget-height+) (incf (gfs:size-height size) b-width)) - (if (= (logand (gfs::get-window-long hwnd gfs::+gwl-style+) gfs::+ws-vscroll+) - gfs::+ws-vscroll+) + (if (test-native-style self gfs::+ws-vscroll+) (incf (gfs:size-width size) (vertical-scrollbar-width))) size)) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Tue Sep 5 11:39:37 2006 @@ -37,12 +37,6 @@ ;;; helper functions ;;; -(defun lb-init-storage (hwnd item-count total-bytes) - (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) - -(defun lb-clear-content (hwnd) - (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) - (defun lb-insert-item (hwnd index label hbmp) (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box (let ((text (or label ""))) @@ -51,18 +45,6 @@ (if (< retval 0) (error 'gfs:toolkit-error :detail (format nil "LB_INSERTSTRING failed: ~d" retval))))))) -(defun lb-width (hwnd) - (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) - (if (< width 0) - (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) - width)) - -(defun lb-item-count (hwnd) - (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) - (if (< count 0) - (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) - count)) - (defun lb-item-height (hwnd) (let ((height (gfs::send-message hwnd gfs::+lb-getitemheight+ 0 0))) (if (< height 0) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Sep 5 11:39:37 2006 @@ -52,9 +52,8 @@ -1)) (defun update-top-level-resizability (win same-size-flag) - (let* ((hwnd (gfs:handle win)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) - (new-flags 0)) + (let ((orig-flags (get-native-style win)) + (new-flags 0)) (cond (same-size-flag (setf new-flags (logand orig-flags (lognot gfs::+ws-maximizebox+))) @@ -192,8 +191,7 @@ (format stream "max size: ~a" (maximum-size self)))) (defmethod resizable-p ((self top-level)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+ws-thickframe+) gfs::+ws-thickframe+))) + (test-native-style self gfs::+ws-thickframe+)) (defmethod (setf resizable-p) (flag (self top-level)) (let ((style (style-of self))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Sep 5 11:39:37 2006 @@ -423,6 +423,9 @@ (defgeneric update-from-items (self) (:documentation "Rebuilds the native control's model of self from self's item list.")) +(defgeneric update-native-style (self flags) + (:documentation "Modifies self's native style flags and refreshes self's visual appearance.")) + (defgeneric vertical-scrollbar (self) (:documentation "Returns T if this object currently has a vertical scrollbar; 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 Sep 5 11:39:37 2006 @@ -141,14 +141,6 @@ (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) retval)) -(defun update-native-style (widget bits) - (let ((hwnd (gfs:handle widget))) - (gfs::set-window-long hwnd gfs::+gwl-style+ bits) - (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ - gfs::+swp-nomove+ - gfs::+swp-nosize+ - gfs::+swp-nozorder+)))) - (defun get-widget-text (w) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) @@ -282,3 +274,15 @@ (let ((new-width (funcall compare-fn (gfs:size-width new-size) (gfs:size-width current-size))) (new-height (funcall compare-fn (gfs:size-height new-size) (gfs:size-height current-size)))) (gfs:make-size :width new-width :height new-height))) + +(defun get-native-style (widget) + (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+)) + +(defun get-native-exstyle (widget) + (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+)) + +(defun test-native-style (widget bits) + (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) bits)) + +(defun test-native-exstyle (widget bits) + (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) bits)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Sep 5 11:39:37 2006 @@ -92,8 +92,7 @@ (error 'gfs:disposed-error))) (defmethod border-width ((self widget)) - (let* ((hwnd (gfs:handle self)) - (bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (let ((bits (get-native-exstyle self))) (cond ((/= (logand bits gfs::+ws-ex-clientedge+) 0) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxedge+))) @@ -103,8 +102,7 @@ (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) ((/= (logand bits gfs::+ws-ex-windowedge+) 0) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxdlgframe+)))) - (setf bits (gfs::get-window-long hwnd gfs::+gwl-style+)) - (when (logand bits gfs::+ws-border+) + (when (test-native-style self gfs::+ws-border+) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) 0)) @@ -434,6 +432,11 @@ (unless (gfs:null-handle-p hwnd) (gfs::update-window hwnd)))) +(defmethod update-native-style :before ((self widget) bits) + (declare (ignore bits)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod visible-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Sep 5 11:39:37 2006 @@ -152,16 +152,16 @@ (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) color)) -(defmethod compute-outer-size ((win window) desired-client-size) - (let ((hwnd (gfs:handle win)) +(defmethod compute-outer-size ((self window) desired-client-size) + (let ((hwnd (gfs:handle self)) (new-size (gfs:make-size))) (gfs::with-rect (setf gfs::right (gfs:size-width desired-client-size) gfs::bottom (gfs:size-height desired-client-size)) (if (zerop (gfs::adjust-window-rect gfs::rect-ptr - (gfs::get-window-long hwnd gfs::+gwl-style+) + (get-native-style self) (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) - (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (get-native-exstyle self))) (error 'gfs:win32-error :detail "adjust-window-rect failed")) (setf (gfs:size-width new-size) (- gfs::right gfs::left) (gfs:size-height new-size) (- gfs::bottom gfs::top))) @@ -314,6 +314,15 @@ (outer-size self sz) sz)) +(defmethod update-native-style ((self window) flags) + (let ((hwnd (gfs:handle self))) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+))) + flags) + (defmethod window->display :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) From junrue at common-lisp.net Wed Sep 6 05:08:07 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 6 Sep 2006 01:08:07 -0400 (EDT) Subject: [graphic-forms-cvs] r249 - in trunk: docs/manual src src/demos/textedit src/uitoolkit/widgets Message-ID: <20060906050807.07BA1722A8@common-lisp.net> Author: junrue Date: Wed Sep 6 01:08:05 2006 New Revision: 249 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: API cleanup: collapsed selection-span and select-span into selected-span and associated setf function Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Wed Sep 6 01:08:05 2006 @@ -449,37 +449,56 @@ or to the unselected state if @sc{nil}. @end deffn + at anchor{select-all} @deffn GenericFunction select-all self flag -Sets the entire content of @code{self} to the selected state if +Sets the entire content of @var{self} to the selected state if @var{flag} is not @sc{nil} or to the unselected state if @sc{nil}. @end deffn - at anchor{select-items} - at deffn GenericFunction select-items self indices flag -Sets the @ref{item}s of @var{self}, each identified by a zero-based -index from the @var{indices} @sc{list}, to the selected state if - at var{flag} is not @sc{nil} or to the unselected state if @sc{nil}. -This is the function to use when not all of the items in question -are contiguous. + at anchor{selected-count} + at deffn GenericFunction selected-count self => integer +Returns the number of @ref{item}s selected in @var{self}. @end deffn - at anchor{select-span} - at deffn GenericFunction select-span self span -Sets the @ref{item}s of @var{self} that lie within @var{span} to -the selected state. An existing selection's extent is modified -to match the new @var{span}. - at end deffn + at anchor{selected-items} + at deffn GenericFunction selected-items self => list +(setf (@strong{selected-items} @var{self}) @var{list}) + +Returns a @sc{list} containing subclasses of @ref{item} appropriate +for @var{self} that correspond to selections made by the user, or + at sc{nil} if there are no selections. This function is defined only +for @ref{widget}s whose notion of @emph{selection} is a set of +item objects. - at deffn GenericFunction selection-span self => @ref{span} -Returns a span object describing the @var{start} and @var{end} of the -selection within @var{self}. If there is no selection, this function -returns @sc{nil}. +The @sc{setf} function takes a @var{list} of item subclasses +appropriate for @var{self} which identify the items in + at var{self} that should be selected. Passing @sc{nil} will unselect all +items, which is equivalent to calling @ref{select-all} with @sc{nil}. @end deffn + at anchor{selected-p} @deffn GenericFunction selected-p self => boolean Returns T if @var{self} is in the selected state; @sc{nil} otherwise. @end deffn + at anchor{selected-span} + at deffn GenericFunction selected-span self => @var{object}, @var{span} +(setf (@strong{selected-span} @var{self}) @var{span}) + +Returns a @ref{span} describing a range of data within @var{self} +that is in the selected state, as well as an @var{object} comprising +the selected data. If there is no selection, this +function returns @sc{nil} for both values. This function is defined +only for @ref{widget}s whose notion of @emph{selection} is a +contiguous range of simple data (e.g., characters in a string). + +The corresponding @sc{setf} function sets the content of + at var{self} whose indices lie within @var{span} to the selected +state. An existing selection's extent is modified to match the +new @var{span}. Passing @sc{nil} for @var{span} will unselect +all content. + at end deffn + @anchor{show} @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Sep 6 01:08:05 2006 @@ -98,17 +98,19 @@ (unless *textedit-control* (return-from manage-textedit-edit-menu nil)) (let ((items (gfw:items-of menu)) - (text (gfw:text *textedit-control*)) - (text-sel (gfw:selection-span *textedit-control*))) - (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)) - (gfw:enable (elt items 2) text-sel) - (gfw:enable (elt items 3) text-sel) - (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*)) - (gfw:enable (elt items 5) text-sel) - (gfw:enable (elt items 12) (and (> (length text) 0) - (or (null text-sel) - (> (gfs:span-start text-sel) 0) - (< (gfs:span-end text-sel) (length text))))))) + (text (gfw:text *textedit-control*))) + (multiple-value-bind (sub-text text-sel) + (gfw:selected-span *textedit-control*) + (declare (ignore sub-text)) + (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)) + (gfw:enable (elt items 2) text-sel) + (gfw:enable (elt items 3) text-sel) + (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*)) + (gfw:enable (elt items 5) text-sel) + (gfw:enable (elt items 12) (and (> (length text) 0) + (or (null text-sel) + (> (gfs:span-start text-sel) 0) + (< (gfs:span-end text-sel) (length text)))))))) (defun textedit-edit-copy (disp item) (declare (ignore disp item)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Sep 6 01:08:05 2006 @@ -487,12 +487,10 @@ #:scroll #:select #:select-all - #:select-items + #:selected-count + #:selected-items #:selected-p - #:selection-count - #:selection-index - #:selection-indices - #:selection-span + #:selected-span #:show #:show-column #:show-header Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Wed Sep 6 01:08:05 2006 @@ -133,13 +133,7 @@ (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 (length (text self))) (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 0))) -(defmethod select-span ((self edit) (span gfs:span)) - (with-drawing-disabled (self) - (let ((hwnd (gfs:handle self))) - (gfs::send-message hwnd gfs::+em-setsel+ 1 1) - (gfs::send-message hwnd gfs::+em-setsel+ (gfs:span-start span) (gfs:span-end span))))) - -(defmethod selection-span ((self edit)) +(defmethod selected-span ((self edit)) (cffi:with-foreign-object (start-ptr :unsigned-long) (cffi:with-foreign-object (end-ptr :unsigned-long) (gfs::send-message (gfs:handle self) @@ -147,8 +141,17 @@ (cffi:pointer-address start-ptr) (cffi:pointer-address end-ptr)) (let ((start (cffi:mem-ref start-ptr :unsigned-long)) - (end (cffi:mem-ref end-ptr :unsigned-long))) - (if (= start end) nil (gfs:make-span :start start :end end)))))) + (end (cffi:mem-ref end-ptr :unsigned-long)) + (str (text self))) + (if (= start end) + (values nil nil) + (values (subseq str start end) (gfs:make-span :start start :end end))))))) + +(defmethod (setf selected-span) ((span gfs:span) (self edit)) + (with-drawing-disabled (self) + (let ((hwnd (gfs:handle self))) + (gfs::send-message hwnd gfs::+em-setsel+ 1 1) + (gfs::send-message hwnd gfs::+em-setsel+ (gfs:span-start span) (gfs:span-end span))))) (defmethod text ((self edit)) (get-widget-text self)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Sep 6 01:08:05 2006 @@ -327,26 +327,23 @@ (defgeneric select-all (self flag) (:documentation "Set all items of this object into (or out of) the selected state.")) -(defgeneric select-items (self indices flag) - (:documentation "Set items of self, each identified by a zero-based index, into (or out of) the selected state.")) +(defgeneric selected-count (self) + (:documentation "Returns the number of this object's items that are selected.")) + +(defgeneric selected-items (self) + (:documentation "Returns a list of item subclasses representing selected items in self, or nil if no items are selected.")) -(defgeneric select-span (self span) - (:documentation "Set items of self that lie within span into the selected state.")) +(defgeneric (setf selected-items) (items self) + (:documentation "Updates self's visual display such that the specified items are selected.")) (defgeneric selected-p (self) (:documentation "Returns T if the object is in the selected state; nil otherwise.")) -(defgeneric selection-count (self) - (:documentation "Returns the number of this object's items that are selected.")) - -(defgeneric selection-index (self) - (:documentation "Returns the zero-based index of the currently-selected item, or nil if no item is selected.")) - -(defgeneric selection-indices (self) - (:documentation "Returns a list of zero-based indices identifying the selected items within this object.")) +(defgeneric selected-span (self) + (:documentation "Returns a span describing the range of data selected in self, and the selected data.")) -(defgeneric selection-span (self) - (:documentation "Returns a span object describing the start and end indices of the selection within self.")) +(defgeneric (setf selected-span) (span self) + (:documentation "Updates self's visual display such that the data within span is selected.")) (defgeneric show (self flag) (:documentation "Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed Sep 6 01:08:05 2006 @@ -343,13 +343,16 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod select-items :before ((self widget) items flag) - (declare (ignore items flag)) +(defmethod selected-count :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod select-span :before ((self widget) span) - (declare (ignore span)) +(defmethod selected-items :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod (setf selected-items) :before (items (self widget)) + (declare (ignore items)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -360,7 +363,15 @@ (defmethod selected-p ((self widget)) nil) -(defmethod selection-span :before ((self widget)) +(defmethod selected-span :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod selected-span ((self widget)) + nil) + +(defmethod (setf selected-span) :before (span (self widget)) + (declare (ignore span)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) From junrue at common-lisp.net Thu Sep 7 05:46:42 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 7 Sep 2006 01:46:42 -0400 (EDT) Subject: [graphic-forms-cvs] r250 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060907054642.D098D1B002@common-lisp.net> Author: junrue Date: Thu Sep 7 01:46:41 2006 New Revision: 250 Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: revised item-manager protocol so that now we have selected-items and selected-span, implemented selected-items for list-box and fixed up menu implementation, more debugging/bugfixing via widget-tester Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Thu Sep 7 01:46:41 2006 @@ -69,6 +69,10 @@ @acronym{GFW} @end macro + at macro apps-shouldnt-call-function +This function should typically not be called from application code. + at end macro + @macro event-dispatcher-arg @item event-dispatcher The @ref{event-dispatcher} to process this event. Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Thu Sep 7 01:46:41 2006 @@ -568,6 +568,8 @@ data structures) with data derived from the @var{items} slot. If @var{self} has been assigned a sorting predicate, the array of items will be sorted prior to the internal model update. + + at apps-shouldnt-call-function @end deffn @anchor{update-native-style} @@ -576,6 +578,8 @@ @var{integer} and calls any additional API needed to ensure that @var{self}'s visual representation is refreshed. The supplied @var{integer} is returned. + + at apps-shouldnt-call-function @end deffn @anchor{vertical-scrollbar-p} Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Thu Sep 7 01:46:41 2006 @@ -375,7 +375,8 @@ @begin-control-subclass{list-box, This @ref{control} subclass represents a list of selectable items; it also inherits @ref{item-manager}. The list is always visible\, unlike -a combo-box., +a combo-box. Each of the @code{-select} style keywords mentioned below +are exclusive., event-select} @control-callback-initarg{list-box,event-select} @deffn Initarg :estimated-count @@ -400,11 +401,13 @@ keys. @item :multiple-select This style keyword enables individual toggling of multiple item -selections within the list-box. Without this style, the list-box will -only allow a single selection. +selections within the list-box. @item :no-select This style keyword means that the list-box will display items but not allow any selections. + at item :single-select +This style keyword means that the list-box only allows one item at a +time to be selected. This is the default selection style. @item :tab-stops This style keyword configures the list-box to to expand tab characters when rendering item strings. Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Sep 7 01:46:41 2006 @@ -520,7 +520,6 @@ #:trim-sizes #:undo-available-p #:update - #:update-from-items #:vertical-scrollbar #:visible-item-count #:visible-p Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Thu Sep 7 01:46:41 2006 @@ -65,15 +65,50 @@ (gfg:foreground-color gc) color)) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) -(defun lb-select (disp lb) - (declare (ignore disp)) - (print lb)) +(defun manage-lb-button-states (lb move-btn all-btn none-btn) + (let ((count (gfw:selected-count lb)) + (items (gfw:items-of lb))) + (gfw:enable move-btn (> count 0)) + (if all-btn + (gfw:enable all-btn (< count (length items)))) + (if none-btn + (gfw:enable none-btn (> count 0))))) + +(defun move-lb-content (orig-lb dest-lb) + (let ((sel-items (gfw:selected-items orig-lb))) + (if sel-items + (setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb)))))) (defun populate-list-box-test-panel () (setf (gfw:text *widget-tester-win*) "Widget Tester (List Boxes)") (let* ((panel-disp (make-instance 'widget-tester-panel-events)) - (lb1 nil) - (lb2 nil) + (lb1 nil) + (lb2 nil) + (btn-left nil) + (btn-right nil) + (btn-all nil) + (btn-none nil) + (lb1-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-right btn-all btn-none))) + (lb2-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-left nil nil))) + (btn-left-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb2 lb1) + (manage-lb-button-states lb1 btn-right btn-all btn-none) + (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (btn-right-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb1 lb2) + (manage-lb-button-states lb1 btn-right btn-all btn-none) + (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (btn-all-callback (lambda (disp btn) + (declare (ignore disp btn)))) + (btn-none-callback (lambda (disp btn) + (declare (ignore disp btn)))) + (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* :layout (make-instance 'gfw:flow-layout :spacing 4 :margins 4))) @@ -82,26 +117,43 @@ :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) (btn-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent outer-panel - :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))) + :layout (make-instance 'gfw:flow-layout :style '(:vertical :normalize) :spacing 4 :margins 4))) (lb2-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent outer-panel :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4)))) + (make-instance 'gfw:label :text "Multiple Select:" :parent lb1-panel) (setf lb1 (make-instance 'gfw:list-box :parent lb1-panel - :callback #'lb-select + :callback lb1-callback :sort-predicate #'string< :style '(:multiple-select) :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) - (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " ==> ") nil) - (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " <== ") nil) + + (setf btn-right (make-instance 'gfw:button :parent btn-panel + :text " ==> " + :callback btn-right-callback)) + (gfw:enable btn-right nil) + (setf btn-left (make-instance 'gfw:button :parent btn-panel + :text " <== " + :callback btn-left-callback)) + (gfw:enable btn-left nil) + (setf btn-all (make-instance 'gfw:button :parent btn-panel + :text "Select All" + :callback btn-all-callback)) + (setf btn-none (make-instance 'gfw:button :parent btn-panel + :text "Select None" + :callback btn-none-callback)) + (gfw:enable btn-none nil) (gfw:pack btn-panel) + (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel - :callback #'lb-select + :callback lb2-callback :style '(:extend-select :want-scrollbar) :items (subseq *list-box-test-data* 4))) (gfw:pack lb2-panel) + (gfw:pack outer-panel) (let ((size (gfw:size lb1))) (setf (gfw:maximum-size lb1) size @@ -109,7 +161,6 @@ (gfw:maximum-size lb2) size (gfw:minimum-size lb2) size)) (setf (gfw:items-of lb1) *list-box-test-data*) - (gfw:update-from-items lb1) (gfw:delete-all lb2) outer-panel)) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Thu Sep 7 01:46:41 2006 @@ -39,6 +39,7 @@ (defun recreate-array (array) (make-array (array-dimensions array) + :element-type (array-element-type array) :adjustable (adjustable-array-p array) :fill-pointer (if (array-has-fill-pointer-p array) 0 nil))) @@ -64,6 +65,15 @@ (dotimes (i (length tmp)) (setf (elt result i) (second (elt tmp i)))))) result)) +(defun pick-elements (lisp-seq indices &optional count) + (let ((picks nil)) + (if (cffi:pointerp indices) + (dotimes (i count) + (push (elt lisp-seq (mem-aref indices :unsigned-int i)) picks)) + (dotimes (i (length indices)) + (push (elt lisp-seq (elt indices i)) picks))) + (reverse picks))) + (defun flatten (tree) (if (cl:atom tree) (list tree) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Thu Sep 7 01:46:41 2006 @@ -37,6 +37,9 @@ ;;; helper functions ;;; +(defun make-items-array (&optional (count 7)) + (make-array count :fill-pointer 0 :adjustable t)) + (defun call-text-provider (manager thing) (let ((func (text-provider-of manager)) (*print-readably* nil)) @@ -51,7 +54,7 @@ (defun copy-item-sequence (parent new-items item-class) (let ((hwnd (gfs:handle parent)) (tc (thread-context)) - (replacements (make-array 7 :fill-pointer 0 :adjustable t))) + (replacements (make-items-array))) (cond ((null new-items) replacements) @@ -85,10 +88,10 @@ (error 'gfs:disposed-error))) (defmethod delete-all ((self item-manager)) - (let ((items (items-of self))) + (let ((items (slot-value self 'items))) (dotimes (i (length items)) (gfs:dispose (aref items i)))) - (setf (items-of self) (make-array 7 :fill-pointer 0 :adjustable t))) + (setf (slot-value self 'items) (make-items-array))) (defmethod delete-item :before ((self item-manager) index) (declare (ignore index)) @@ -96,9 +99,9 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) - (let* ((items (items-of self)) + (let* ((items (slot-value self 'items)) (it (elt items index))) - (setf (items-of self) (remove it items :test #'items-equal-p)) + (setf (slot-value self 'items) (remove it items :test #'items-equal-p)) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) @@ -113,7 +116,7 @@ (delete-item self (gfs:span-start sp)))) (defmethod gfs:dispose ((self item-manager)) - (let ((items (items-of self)) + (let ((items (slot-value self 'items)) (tc (thread-context))) (dotimes (i (length items)) (delete-tc-item tc (elt items i))))) @@ -124,11 +127,23 @@ (error 'gfs:disposed-error))) (defmethod item-index ((self item-manager) (it item)) - (let ((pos (position it (items-of self) :test #'items-equal-p))) + (let ((pos (position it (slot-value self 'items) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) 0)) +(defmethod items-of ((self item-manager)) + (coerce (slot-value self 'items) 'list)) + +(defmethod selected-items :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod (setf selected-items) :before (items (self item-manager)) + (declare (ignore items)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod update-from-items :before ((self item-manager)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Thu Sep 7 01:46:41 2006 @@ -38,15 +38,14 @@ ;;; (defun create-item-with-callback (howner class-symbol thing disp) - (let ((item nil) - (id (increment-item-id (thread-context)))) + (let ((item nil)) (cond ((null disp) - (setf item (make-instance class-symbol :item-id id :data thing :handle howner))) + (setf item (make-instance class-symbol :data thing :handle howner))) ((functionp disp) - (setf item (make-instance class-symbol :item-id id :data thing :handle howner :callback disp))) + (setf item (make-instance class-symbol :data thing :handle howner :callback disp))) ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance class-symbol :item-id id :data thing :handle howner :dispatcher disp))) + (setf item (make-instance class-symbol :data thing :handle howner :dispatcher disp))) (t (error 'gfs:toolkit-error :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) @@ -70,12 +69,19 @@ (defmethod gfs:dispose ((self item)) (setf (dispatcher self) nil) + (let ((hwnd (gfs:handle self))) + (unless (or (null hwnd) (cffi:null-pointer-p hwnd)) + (let ((owner (get-widget (thread-context) hwnd))) + (if owner + (setf (slot-value owner 'items) + (remove self (slot-value owner 'items) :test #'items-equal-p)))))) (delete-tc-item (thread-context) self) (setf (data-of self) nil) (setf (item-id self) 0) (setf (slot-value self 'gfs:handle) nil)) (defmethod initialize-instance :after ((self item) &key callback &allow-other-keys) + (setf (item-id self) (increment-item-id (thread-context))) (when callback (unless (typep callback 'function) (error 'gfs:toolkit-error :detail ":callback value must be a function")) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Thu Sep 7 01:46:41 2006 @@ -52,11 +52,9 @@ (lognot (logior gfs::+lbs-multiplesel+ gfs::+lbs-extendedsel+)))) (logior orig-flags gfs::+lbs-nosel+)) -(defun lb-init-storage (hwnd item-count total-bytes) - (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) - -(defun lb-clear-content (hwnd) - (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) +(defun lb-single-select-flags (orig-flags) + (logand orig-flags + (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+)))) (defun lb-width (hwnd) (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) @@ -70,6 +68,14 @@ (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) count)) +(defun lb-delete-all (lb) + (let ((old-items (slot-value lb 'items))) + (gfs::send-message (gfs:handle lb) gfs::+lb-resetcontent+ 0 0) + (dotimes (i (length old-items)) + (let ((victim (elt old-items i))) + (setf (slot-value victim 'gfs:handle) nil) + (gfs:dispose victim))))) + ;;; ;;; methods ;;; @@ -82,7 +88,7 @@ (item (create-item-with-callback hcontrol 'list-item thing disp))) (lb-insert-item hcontrol #xFFFFFFFF text (cffi:null-pointer)) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) item)) (defmethod compute-style-flags ((self list-box) &rest extra-data) @@ -97,6 +103,7 @@ (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) (:no-select (setf std-flags (lb-no-select-flags std-flags))) + (:single-select (setf std-flags (lb-single-select-flags std-flags))) ;; styles that can be combined ;; @@ -105,6 +112,10 @@ (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) +(defmethod delete-all ((self list-box)) + (lb-delete-all self) + (setf (slot-value self 'items) (make-items-array))) + (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) @@ -115,23 +126,19 @@ std-style ex-style (increment-widget-id (thread-context))))) - (setf (slot-value self 'gfs:handle) hwnd))) - (init-control self) - (if (and estimated-count (> estimated-count 0)) - (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) + (setf (slot-value self 'gfs:handle) hwnd) + (init-control self) + (if (and estimated-count (> estimated-count 0)) + (gfs::send-message hwnd + gfs::+lb-initstorage+ + estimated-count + (* estimated-count +estimated-text-size+))))) (if items (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) (update-from-items self)) -(defmethod (setf items-of) :before (new-items (self list-box)) - (declare (ignore new-items)) - (let ((old-items (items-of self))) - (dotimes (i (length old-items)) - (let ((victim (elt old-items i))) - (setf (slot-value victim 'gfs:handle) nil) - (gfs:dispose victim))))) - -(defmethod (setf items-of) :after (new-items (self list-box)) +(defmethod (setf items-of) (new-items (self list-box)) + (lb-delete-all self) (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) (update-from-items self)) @@ -180,15 +187,38 @@ (incf (gfs:size-width size) (vertical-scrollbar-width))) size)) +(defmethod selected-count ((self list-box)) + (let ((hwnd (gfs:handle self))) + (if (test-native-style self gfs::+lbs-nosel+) + (if (>= (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0) 0) 1 0) + (let ((count (gfs::send-message hwnd gfs::+lb-getselcount+ 0 0))) + (if (< count 0) 0 count))))) + +(defmethod selected-items ((self list-box)) + (let ((hwnd (gfs:handle self)) + (items (slot-value self 'items))) + (if (and (not (test-native-style self gfs::+lbs-extendedsel+)) + (not (test-native-style self gfs::+lbs-multiplesel+))) + (let ((index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) + (if (and (>= index 0) (< index (length items))) + (list (elt items index)) + nil)) + (let ((count (gfs::send-message hwnd gfs::+lb-getselcount+ 0 0))) + (if (<= count 0) + nil + (cffi:with-foreign-object (indices :unsigned-int count) + (if (/= (gfs::send-message hwnd gfs::+lb-getselitems+ count (cffi:pointer-address indices)) count) + nil + (gfs::pick-elements items indices count)))))))) + (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (hwnd (gfs:handle self))) (when sort-func - (setf (slot-value self 'items) (gfs::indexed-sort (items-of self) sort-func #'data-of))) + (setf (slot-value self 'items) (gfs::indexed-sort (slot-value self 'items) sort-func #'data-of))) (enable-redraw self nil) (unwind-protect - (let ((items (items-of self))) - (lb-clear-content hwnd) + (let ((items (slot-value self 'items))) (dotimes (index (length items)) (let* ((item (elt items index)) (text (call-text-provider self (data-of item)))) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Thu Sep 7 01:46:41 2006 @@ -70,6 +70,7 @@ ;;; (defmethod gfs:dispose ((self list-item)) +(print self) (let ((index (index-of self)) (howner (gfs:handle self))) (if howner Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Thu Sep 7 01:46:41 2006 @@ -79,8 +79,8 @@ nil))) (defun visit-menu-tree (menu fn) - (dotimes (index (length (items-of menu))) - (let ((it (elt (items-of menu) index)) + (dotimes (index (length (slot-value menu 'items))) + (let ((it (elt (slot-value menu 'items) index)) (child (sub-menu menu index))) (unless (null child) (visit-menu-tree child fn)) @@ -97,32 +97,30 @@ (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) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) item)) (defmethod append-separator ((self menu)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-item-id tc)) (hmenu (gfs:handle self)) - (item (make-instance 'menu-item :handle hmenu :item-id id))) - (append-menuitem hmenu id nil (cffi:null-pointer) (cffi:null-pointer) nil nil) + (item (make-instance 'menu-item :handle hmenu))) + (append-menuitem hmenu (item-id item) nil (cffi:null-pointer) (cffi:null-pointer) nil nil) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) item)) (defmethod append-submenu ((self menu) text (submenu menu) disp &optional disabled checked) (if (or (gfs:disposed-p self) (gfs:disposed-p submenu)) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-item-id tc)) (hparent (gfs:handle self)) (hmenu (gfs:handle submenu)) - (item (make-instance 'menu-item :handle hparent :item-id id))) - (append-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked) + (item (make-instance 'menu-item :handle hparent))) + (append-menuitem hparent (item-id item) text (cffi:null-pointer) hmenu disabled checked) (put-item tc item) - (vector-push-extend item (items-of self)) + (vector-push-extend item (slot-value self 'items)) (put-widget tc submenu) (cond ((null disp)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu Sep 7 01:46:41 2006 @@ -170,7 +170,6 @@ :initarg :sort-predicate :initform nil) (items - :accessor items-of ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t)) (text-provider Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu Sep 7 01:46:41 2006 @@ -347,15 +347,6 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod selected-items :before ((self widget)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - -(defmethod (setf selected-items) :before (items (self widget)) - (declare (ignore items)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - (defmethod selected-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) From junrue at common-lisp.net Fri Sep 8 15:32:27 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 8 Sep 2006 11:32:27 -0400 (EDT) Subject: [graphic-forms-cvs] r251 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060908153227.01C285B056@common-lisp.net> Author: junrue Date: Fri Sep 8 11:32:27 2006 New Revision: 251 Added: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-functions.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/tests.lisp Log: added unit-tests for item-manager, fixed more bugs Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Fri Sep 8 11:32:27 2006 @@ -70,7 +70,7 @@ @end macro @macro apps-shouldnt-call-function -This function should typically not be called from application code. +This function is not intended to be called from application code. @end macro @macro event-dispatcher-arg Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Fri Sep 8 11:32:27 2006 @@ -36,13 +36,13 @@ @anchor{auto-hscroll-p} @deffn GenericFunction auto-hscroll-p self => boolean -Returns T if @code{self} is configured for automatic horizontal scrolling; +Returns T if @var{self} is configured for automatic horizontal scrolling; @sc{nil} otherwise. See @ref{auto-vscroll-p} and @ref{enable-auto-scrolling}. @end deffn @anchor{auto-vscroll-p} @deffn GenericFunction auto-vscroll-p self => boolean -Returns T if @code{self} is configured for automatic vertical scrolling; +Returns T if @var{self} is configured for automatic vertical scrolling; @sc{nil} otherwise. See @ref{auto-hscroll-p} and @ref{enable-auto-scrolling}. @end deffn @@ -56,9 +56,9 @@ @anchor{capture-mouse} @defun capture-mouse self -Enables the @ref{window} identified by @code{self} to receive mouse +Enables the @ref{window} identified by @var{self} to receive mouse input events even when the mouse pointer is outside of the bounds -of @code{self}. Only one window at a time can capture the mouse. This +of @var{self}. Only one window at a time can capture the mouse. This function is primarily intended for use with a window in the foreground; background windows may still capture the mouse, but only mouse move events will be received and those only when the mouse hotspot is within @@ -67,15 +67,15 @@ @anchor{center-on-owner} @deffn GenericFunction center-on-owner self -Position @code{self} such that it is centrally located relative to its - at ref{owner}, based on @code{self}'s current outermost size. +Position @var{self} such that it is centrally located relative to its + at ref{owner}, based on @var{self}'s current outermost size. See also @ref{center-on-parent}. @end deffn @anchor{center-on-parent} @deffn GenericFunction center-on-parent self -Position @code{self} such that it is centrally located relative to its - at ref{parent}, based on @code{self}'s current outermost size. +Position @var{self} such that it is centrally located relative to its + at ref{parent}, based on @var{self}'s current outermost size. See also @ref{center-on-owner}. @end deffn @@ -93,7 +93,7 @@ @end deffn @deffn GenericFunction compute-style-flags self &rest extra-data -Convert a list of keyword symbols in the object's @code{style} slot to +Convert a list of keyword symbols in the object's @var{style} slot to a values pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports. @end deffn @@ -106,8 +106,8 @@ @anchor{copy-text} @deffn GenericFunction copy-text self This function is a shortcut for a common clipboard transfer operation, -namely the transfer of text from @code{self} to the system clipboard. -The existing content of @code{self} remains in place. Some @ref{control}s +namely the transfer of text from @var{self} to the system clipboard. +The existing content of @var{self} remains in place. Some @ref{control}s like the @ref{edit} control have built-in clipboard functionality, and in such cases, the implementation of this function delegates directly. See @ref{cut-text}, @ref{paste-text}, and @ref{text-for-pasting-p}.@*@* @@ -118,8 +118,8 @@ @anchor{cut-text} @deffn GenericFunction cut-text self This function is a shortcut for a common clipboard transfer operation, -namely the transfer of text from @code{self} to the system clipboard -and removal of content from @code{self}. Some @ref{control}s like the +namely the transfer of text from @var{self} to the system clipboard +and removal of content from @var{self}. Some @ref{control}s like the @ref{edit} control have built-in clipboard functionality, and in such cases, the implementation of this function delegates directly. For other @ref{widget}s, this operation is a wrapper around a copy/delete @@ -135,12 +135,12 @@ Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil} if none has been set. If @sc{nil} is passed to the corresponding @sc{setf} function, then no default widget is set. The default widget -is the one that is selected when @code{self} is active and the user +is the one that is selected when @var{self} is active and the user presses @sc{enter}. @end deffn @deffn GenericFunction delete-all self -Removes all content from @code{self}. +Removes all content from @var{self}. @end deffn @deffn GenericFunction delete-item self index @@ -204,7 +204,7 @@ Specifying T for @var{horizontal} (@var{vertical}) reveals a scrollbar to attached to the right-hand (bottom) of @var{self}. Specifying @sc{nil} hides the scrollbar. These flags do -not affect scrolling behavior in @code{self} -- they only control +not affect scrolling behavior in @var{self} -- they only control scrollbar visibility. See @ref{horizontal-scrollbar-p} and @ref{vertical-scrollbar-p}. @end deffn @@ -224,7 +224,7 @@ @end defun @deffn GenericFunction focus-p self -Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} +Returns @sc{t} if @var{self} currently has keyboard focus; @sc{nil} otherwise. @end deffn @@ -233,7 +233,7 @@ Interrogates the data structure associated with an instance of @ref{font-dialog} to obtain the @ref{font} and @ref{color} corresponding to selections made by the user, and returns -them via @sc{values}. The @code{gc} parameter should be the same +them via @sc{values}. The @var{gc} parameter should be the same @ref{graphics-context} object with which the dialog was created. If the user cancelled the dialog, the font value will be @sc{nil}. Also, the color value will be @sc{nil} if the dialog was created with @@ -242,12 +242,12 @@ @end defun @deffn GenericFunction give-focus self -Places keyboard focus on @code{self}. +Places keyboard focus on @var{self}. @end deffn @anchor{horizontal-scrollbar-p} @deffn GenericFunction horizontal-scrollbar-p self => boolean -Returns T if @code{self} has been configured to display a horizontal +Returns T if @var{self} has been configured to display a horizontal scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @@ -270,7 +270,7 @@ @anchor{line-count} @deffn GenericFunction line-count self => integer -Returns the total number of lines (e.g., of text) contained by @code{self}. +Returns the total number of lines (e.g., of text) contained by @var{self}. @end deffn @deffn GenericFunction location self => @ref{point} @@ -281,9 +281,9 @@ @end deffn @deffn GenericFunction mapchildren self func => result-list -Calls @code{func}, which is a function of two arguments, for each -child of @code{self} and places @code{func}'s return value in - at code{result-list}. @code{func}'s two arguments are @code{self} and +Calls @var{func}, which is a function of two arguments, for each +child of @var{self} and places @var{func}'s return value in + at var{result-list}. @var{func}'s two arguments are @var{self} and the current child. @end deffn @@ -343,8 +343,8 @@ @anchor{owner} @deffn GenericFunction owner self -Returns the @code{owner} of @code{self}, which may be different from - at code{self}'s @ref{parent} because the window ownership hierarchy +Returns the @var{owner} of @var{self}, which may be different from + at var{self}'s @ref{parent} because the window ownership hierarchy includes the relationships between physically separate @ref{top-level}s and dialogs. And it is possible for a window to be unowned but still have a @ref{parent}. Consequently, calling @@ -370,7 +370,7 @@ @anchor{parent} @deffn GenericFunction parent self => @ref{window} -Returns the @code{parent} of @code{self}. In the case of @ref{panel}s +Returns the @code{parent} of @var{self}. In the case of @ref{panel}s and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or @ref{top-level} window. In the case of a dialog or @ref{top-level}, then a @ref{root-window} is returned. In the case of a @code{submenu}, @@ -391,8 +391,8 @@ @anchor{paste-text} @deffn GenericFunction paste-text self This function is a shortcut for a common clipboard transfer operation, -namely the transfer of text from the system clipboard to @code{self}. -Depending on the current selection within @code{self}, the text either +namely the transfer of text from the system clipboard to @var{self}. +Depending on the current selection within @var{self}, the text either gets inserted or existing content is replaced. Some @ref{control}s like the @ref{edit} control have built-in clipboard functionality, and in such cases, the implementation of this function delegates directly. See @@ -403,12 +403,12 @@ @anchor{preferred-size} @deffn GenericFunction preferred-size self width-hint height-hint -Implement this function to return @code{self}'s preferred @ref{size}; -that is, the dimensions that @code{self} computes as being the best +Implement this function to return @var{self}'s preferred @ref{size}; +that is, the dimensions that @var{self} computes as being the best fit for itself and/or its children. If one or both of - at code{width-hint} and @code{height-hint} are positive, then each such + at var{width-hint} and @var{height-hint} are positive, then each such parameter is used as a constraint on the @ref{size} calculation -- if -for example @code{width-hint} is some positive value, then @code{self} +for example @var{width-hint} is some positive value, then @var{self} must determine how tall it would be given that width. @end deffn @@ -418,7 +418,7 @@ @end defun @deffn GenericFunction redo-available-p self => boolean -Returns T if @code{self} has @sc{redo} capability and has an +Returns T if @var{self} has @sc{redo} capability and has an operation that can be redone; @sc{nil} otherwise. @end deffn @@ -436,11 +436,11 @@ @deffn GenericFunction resizable-p self => boolean (setf (@strong{resizable-p} @var{self}) @var{boolean})@* -Returns T if @code{self} can be resized by the user; @sc{nil} +Returns T if @var{self} can be resized by the user; @sc{nil} otherwise. The corresponding @sc{setf} function is implemented for the @ref{top-level} class (but only has meaning when the @code{:frame} or @code{:workspace} styles are set), allowing the application to -modify the resizability of @code{self}, whereupon the frame +modify the resizability of @var{self}, whereupon the frame decorations are modified appropriately. @end deffn @@ -514,14 +514,14 @@ @deffn GenericFunction text self => string (setf (@strong{text} @var{self}) @var{string})@* -For a @ref{window} or @ref{dialog}, this function returns @code{self}'s +For a @ref{window} or @ref{dialog}, this function returns @var{self}'s titlebar text (which may be blank). For other @ref{widget}s that have a text component, this function returns that text component. For anything else, this function returns @sc{nil}. @end deffn @deffn GenericFunction text-baseline self => integer -Returns the y coordinate value (relative to the top of @code{self}'s +Returns the y coordinate value (relative to the top of @var{self}'s bounding box) that correlates to the baseline of the text of the @ref{control}, if any. For controls in which a text baseline is not meaningful, such as a @ref{label} with an @ref{image}, this function @@ -544,7 +544,7 @@ @anchor{text-modified-p} @deffn GenericFunction text-modified-p self => boolean (setf (@strong{text-modified-p} @var{self}) @var{boolean})@*@* -Returns T if the text component of @code{self} has been modified by +Returns T if the text component of @var{self} has been modified by the user; @sc{nil} otherwise. The corresponding @sc{setf} function updates the dirty state flag. This function is not implemented for all widgets, since in some cases there are multiple text components and in @@ -553,7 +553,7 @@ @anchor{undo-available-p} @deffn GenericFunction undo-available-p self => boolean -Returns T if @code{self} has @sc{undo} capability and has an +Returns T if @var{self} has @sc{undo} capability and has an operation that can be undone; @sc{nil} otherwise. @end deffn @@ -584,7 +584,7 @@ @anchor{vertical-scrollbar-p} @deffn GenericFunction vertical-scrollbar-p self => boolean -Returns T if @code{self} has been configured to display a vertical +Returns T if @var{self} has been configured to display a vertical scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @@ -595,7 +595,7 @@ @html @deffn GenericFunction window->display self Return the @ref{display} object representing the monitor that is nearest -to @code{self}. The @ref{rectangle} bounding @code{self} is not required +to @var{self}. The @ref{rectangle} bounding @var{self} is not required to intersect the returned @ref{display}. @end deffn @end html Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Sep 8 11:32:27 2006 @@ -368,6 +368,7 @@ #:cut-text #:current-font #:cursor + #:data-of #:default-message-filter #:default-widget #:defmenu Added: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Fri Sep 8 11:32:27 2006 @@ -0,0 +1,134 @@ +;;;; +;;;; item-manager-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 *test-hwnd* (cffi:make-pointer 1)) + +(defun validate-item (expected actual &optional expected-id (expected-hwnd *default-hwnd*)) + (assert-true (typep actual 'mock-item)) + (if expected-id + (assert-equal expected-id (gfw:item-id actual)) + (assert-false (zerop (gfw::item-id actual)))) + (if expected-hwnd + (assert-equality #'cffi:pointer-eq expected-hwnd (gfs:handle actual)) + (assert-equality #'eql expected-hwnd (gfs:handle actual))) + (assert-equality #'equal expected (gfw:data-of actual))) + +(defun validate-item-array (expected array &optional (expected-hwnd *default-hwnd*)) + (assert-true (vectorp array)) + (assert-true (array-has-fill-pointer-p array)) + (assert-true (adjustable-array-p array)) + (assert-equal (length expected) (length array)) + (dotimes (i (length array)) + (validate-item (elt expected i) (elt array i) nil expected-hwnd))) + +(define-test copy-item-sequence-test + (let ((values '(a b c))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* values 'mock-item) *test-hwnd*) + (let ((tmp (loop for datum in values + collect (make-instance 'mock-item :data datum + :handle *test-hwnd*)))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)) + (let ((tmp (make-array 3 :initial-contents (loop for datum in values + collect datum)))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)) + (let ((tmp (make-array 3 :initial-contents (loop for datum in values + collect (make-instance 'mock-item + :data datum + :handle *test-hwnd*))))) + (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)))) + +(define-test item-manager-modifications-test + (let ((values1 '(a b c)) + (values2 '(1 2 3)) + (disp (make-instance 'gfw:event-dispatcher))) + (let ((mgr1 (make-instance 'mock-item-manager :items values1)) + (mgr2 (make-instance 'mock-item-manager :items values2 :handle *test-hwnd*)) + (mgr3 (make-instance 'mock-item-manager))) + + (gfw::put-widget (gfw::thread-context) mgr3) + (unwind-protect + (progn + + ;; sanity check initial states + ;; + (validate-item-array values1 (slot-value mgr1 'gfw::items)) + (validate-item-array values2 (slot-value mgr2 'gfw::items) *test-hwnd*) + (assert-true (zerop (length (slot-value mgr3 'gfw::items)))) + + ;; append a new item to each and sanity check again + ;; + (gfw:append-item mgr1 'd disp) + (validate-item-array (append values1 '(d)) (slot-value mgr1 'gfw::items)) + (gfw:append-item mgr2 4 disp) + (validate-item-array (append values2 '(4)) (slot-value mgr2 'gfw::items) *test-hwnd*) + (gfw:append-item mgr3 t disp) + (validate-item-array (list t) (slot-value mgr3 'gfw::items)) + + ;; delete all from mgr1 + ;; + (let ((tmp (gfw:items-of mgr1))) + (assert-equal 4 (length tmp)) + (gfw:delete-all mgr1) + (assert-true (zerop (length (gfw:items-of mgr1)))) + (loop for actual in tmp + for expected in (append values1 '(d)) + do (validate-item expected actual nil nil))) + + ;; delete an item from mgr2 (using delete-item) + ;; + (let ((tmp (gfw:items-of mgr2))) + (gfw:delete-item mgr2 0) + (validate-item 1 (first tmp) nil nil) + (assert-equal 3 (length (gfw:items-of mgr2))) + (loop for actual in (gfw:items-of mgr2) + for expected in (subseq (append values2 '(4)) 1 4) + do (validate-item expected actual nil *test-hwnd*))) + + ;; delete last item from mgr3 (using dispose) + ;; + (let ((tmp (gfw:items-of mgr3))) + (gfs:dispose (first tmp)) + (assert-true (zerop (length (gfw:items-of mgr3)))) + (validate-item t (first tmp) nil nil)) + + ;; copy items from mgr2 to mgr1 + ;; + (setf (gfw:items-of mgr1) (gfw:items-of mgr2)) + (assert-equal 3 (length (gfw:items-of mgr1))) + (loop for actual in (gfw:items-of mgr1) + for expected in (subseq (append values2 '(4)) 1 4) + do (validate-item expected actual nil *test-hwnd*))) + + (gfw::delete-widget (gfw::thread-context) *default-hwnd*))))) 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 Fri Sep 8 11:32:27 2006 @@ -34,8 +34,8 @@ (in-package :graphic-forms.uitoolkit.tests) (define-test layout-attributes-test - (let ((widget1 (make-instance 'mock-widget :handle 1234)) - (widget2 (make-instance 'mock-widget :handle 5678))) + (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))) (layout (make-instance 'gfw:layout-manager))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Sep 8 11:32:27 2006 @@ -37,6 +37,8 @@ (defconstant +default-container-width+ 300) (defconstant +default-container-height+ 200) +(defvar *default-hwnd* (cffi:make-pointer #xFFFFFFFF)) + ;;; ;;; stand-in for a window, used as parent of mock-widget ;;; @@ -80,19 +82,19 @@ :initarg :min-size :initform (gfs:make-size)))) -(defmethod initialize-instance :after ((widget mock-widget) &key handle &allow-other-keys) - (setf (slot-value widget 'gfs:handle) (cffi:make-pointer (or handle #xFFFFFFFF)))) +(defmethod initialize-instance :after ((self mock-widget) &key handle &allow-other-keys) + (setf (slot-value self 'gfs:handle) (or handle *default-hwnd*))) -(defmethod gfw:location ((widget mock-widget)) +(defmethod gfw:location ((self mock-widget)) (gfs:make-point)) -(defmethod gfw:minimum-size ((widget mock-widget)) - (gfs:make-size :width (gfs:size-width (min-size-of widget)) - :height (gfs:size-height (min-size-of widget)))) +(defmethod gfw:minimum-size ((self mock-widget)) + (gfs:make-size :width (gfs:size-width (min-size-of self)) + :height (gfs:size-height (min-size-of self)))) -(defmethod gfw:preferred-size ((widget mock-widget) width-hint height-hint) +(defmethod gfw:preferred-size ((self mock-widget) width-hint height-hint) (let ((size (gfs:make-size)) - (min-size (min-size-of widget))) + (min-size (min-size-of self))) (if (< width-hint 0) (setf (gfs:size-width size) (gfs:size-width min-size)) (setf (gfs:size-width size) width-hint)) @@ -101,8 +103,30 @@ (setf (gfs:size-height size) height-hint)) size)) -(defmethod gfw:text-baseline ((widget mock-widget)) - (floor (* (gfs:size-height (min-size-of widget)) 3) 4)) +(defmethod gfw:text-baseline ((self mock-widget)) + (floor (* (gfs:size-height (min-size-of self)) 3) 4)) + +(defmethod gfw:visible-p ((self mock-widget)) + (visibility-of self)) + +;;; +;;; infrastructure for item-manager unit tests +;;; + +(defclass mock-item (gfw:item) ()) + +(defclass mock-item-manager (gfw:widget gfw:item-manager) ()) + +(defmethod initialize-instance :after ((self mock-item-manager) &key handle items &allow-other-keys) + (setf (slot-value self 'gfs:handle) (or handle *default-hwnd*)) + (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)) + (let ((item (gfw::create-item-with-callback (gfs:handle self) 'mock-item thing disp))) + (vector-push-extend item (slot-value self 'gfw::items)) + item)) -(defmethod gfw:visible-p ((widget mock-widget)) - (visibility-of widget)) +(defmethod (setf gfw:items-of) (new-items (self mock-item-manager)) + (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) new-items 'mock-item))) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Fri Sep 8 11:32:27 2006 @@ -51,9 +51,8 @@ (t (funcall func thing))))) -(defun copy-item-sequence (parent new-items item-class) - (let ((hwnd (gfs:handle parent)) - (tc (thread-context)) +(defun copy-item-sequence (handle new-items item-class) + (let ((tc (thread-context)) (replacements (make-items-array))) (cond ((null new-items) @@ -63,7 +62,7 @@ (let ((item (elt new-items i))) (if (typep item item-class) (vector-push-extend item replacements) - (let ((tmp (make-instance item-class :handle hwnd :data item))) + (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements))))) replacements) @@ -71,7 +70,7 @@ (loop for item in new-items do (if (typep item item-class) (vector-push-extend item replacements) - (let ((tmp (make-instance item-class :handle hwnd :data item))) + (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements)))) replacements) @@ -101,9 +100,7 @@ (defmethod delete-item ((self item-manager) index) (let* ((items (slot-value self 'items)) (it (elt items index))) - (setf (slot-value self 'items) (remove it items :test #'items-equal-p)) - (if (gfs:disposed-p it) - (error 'gfs:disposed-error)) + (setf (slot-value self 'items) (remove it items :test #'items-equal)) (gfs:dispose it))) (defmethod delete-item-span :before ((self item-manager) (sp gfs:span)) @@ -127,7 +124,7 @@ (error 'gfs:disposed-error))) (defmethod item-index ((self item-manager) (it item)) - (let ((pos (position it (slot-value self 'items) :test #'items-equal-p))) + (let ((pos (position it (slot-value self 'items) :test #'items-equal))) (if (null pos) (return-from item-index 0)) 0)) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Fri Sep 8 11:32:27 2006 @@ -51,7 +51,7 @@ :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) item)) -(defun items-equal-p (item1 item2) +(defun items-equal (item1 item2) (= (item-id item1) (item-id item2))) ;;; @@ -68,16 +68,13 @@ (error 'gfs:toolkit-error :detail "null owner handle"))) (defmethod gfs:dispose ((self item)) - (setf (dispatcher self) nil) (let ((hwnd (gfs:handle self))) (unless (or (null hwnd) (cffi:null-pointer-p hwnd)) (let ((owner (get-widget (thread-context) hwnd))) (if owner (setf (slot-value owner 'items) - (remove self (slot-value owner 'items) :test #'items-equal-p)))))) + (remove self (slot-value owner 'items) :test #'items-equal)))))) (delete-tc-item (thread-context) self) - (setf (data-of self) nil) - (setf (item-id self) 0) (setf (slot-value self 'gfs:handle) nil)) (defmethod initialize-instance :after ((self item) &key callback &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 8 11:32:27 2006 @@ -134,12 +134,12 @@ estimated-count (* estimated-count +estimated-text-size+))))) (if items - (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) + (setf (slot-value self 'items) (copy-item-sequence (gfs:handle self) items 'list-item))) (update-from-items self)) (defmethod (setf items-of) (new-items (self list-box)) (lb-delete-all self) - (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) + (setf (slot-value self 'items) (copy-item-sequence (gfs:handle self) new-items 'list-item)) (update-from-items self)) (defmethod preferred-size ((self list-box) width-hint height-hint) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Fri Sep 8 11:32:27 2006 @@ -70,7 +70,6 @@ ;;; (defmethod gfs:dispose ((self list-item)) -(print self) (let ((index (index-of self)) (howner (gfs:handle self))) (if howner Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Sep 8 11:32:27 2006 @@ -55,6 +55,10 @@ (gfs:dispose ,gc))))) (defmacro with-drawing-disabled ((widget) &body body) + ;; FIXME: should this macro use enable-redraw instead? + ;; One immediate problem is that only one window can be + ;; locked at a time by LockWindowUpdate. + ;; (let ((tmp-widget (gensym))) `(let ((,tmp-widget ,widget)) (unwind-protect Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Fri Sep 8 11:32:27 2006 @@ -45,4 +45,5 @@ (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) (load (concatenate 'string *gf-tests-dir* "flow-layout-unit-tests")) (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "item-manager-unit-tests")) (load (concatenate 'string *gf-tests-dir* "misc-unit-tests"))) From junrue at common-lisp.net Sat Sep 9 03:02:06 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 8 Sep 2006 23:02:06 -0400 (EDT) Subject: [graphic-forms-cvs] r252 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060909030206.770642E183@common-lisp.net> Author: junrue Date: Fri Sep 8 23:02:05 2006 New Revision: 252 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: rewrote item dispose / manager delete-item, implemented item-index to replace index-of accessor, added unit-tests Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Fri Sep 8 23:02:05 2006 @@ -147,11 +147,6 @@ Removes the @ref{item} at the zero-based @var{index}. @end deffn - at deffn GenericFunction delete-item-span self @ref{span} -Removes the items from @var{self} whose zero-based indices lie within -the specified @var{span}. - at end deffn - @deffn GenericFunction delete-selection self Removes the subset of items from @var{self} that are in the @samp{selected} state. For a @ref{control} with a text field @@ -159,6 +154,11 @@ selected text. @end deffn + at deffn GenericFunction delete-span self @ref{span} +Removes the content from @var{self} whose zero-based indices lie within +the specified @var{span}. + at end deffn + @deffn GenericFunction display-to-object self pnt Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system. Modified: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Fri Sep 8 23:02:05 2006 @@ -69,6 +69,14 @@ :handle *test-hwnd*))))) (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*)))) +(define-test item-manager-positions-test + (let* ((values '(a b c)) + (mgr (make-instance 'mock-item-manager :items values)) + (items (slot-value mgr 'gfw::items))) + (assert-equal 0 (gfw:item-index mgr (elt items 0))) + (assert-equal 1 (gfw:item-index mgr (elt items 1))) + (assert-equal 2 (gfw:item-index mgr (elt items 2))))) + (define-test item-manager-modifications-test (let ((values1 '(a b c)) (values2 '(1 2 3)) @@ -113,7 +121,7 @@ (validate-item 1 (first tmp) nil nil) (assert-equal 3 (length (gfw:items-of mgr2))) (loop for actual in (gfw:items-of mgr2) - for expected in (subseq (append values2 '(4)) 1 4) + for expected in (mapcar (lambda (x) (1+ x)) (subseq values2 0 3)) do (validate-item expected actual nil *test-hwnd*))) ;; delete last item from mgr3 (using dispose) @@ -129,6 +137,6 @@ (assert-equal 3 (length (gfw:items-of mgr1))) (loop for actual in (gfw:items-of mgr1) for expected in (subseq (append values2 '(4)) 1 4) - do (validate-item expected actual nil *test-hwnd*))) + do (validate-item expected actual nil *default-hwnd*))) (gfw::delete-widget (gfw::thread-context) *default-hwnd*))))) Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Fri Sep 8 23:02:05 2006 @@ -102,3 +102,88 @@ (assert-equal 3 (length result1)) (assert-equal 3 (length result2)) (validate-array-elements result1 result2)))) + +(define-test remove-element-list-test + (let ((orig '(a b c)) + (remainder nil)) + (multiple-value-bind (tmp victim) (gfs::remove-element orig 1 nil) + (setf remainder tmp) + (assert-equal 2 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'c (second tmp)) + (assert-eql 'b victim)) + (multiple-value-bind (tmp victim) (gfs::remove-element remainder 1 nil) + (setf remainder tmp) + (assert-equal 1 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'c victim)) + (multiple-value-bind (tmp victim) (gfs::remove-element remainder 0 nil) + (assert-false tmp) + (assert-eql 'a victim)))) + +(define-test remove-elements-list-test + (let ((orig '(a b c d e f)) + (remainder nil)) + (multiple-value-bind (tmp victims) + (gfs::remove-elements orig (gfs:make-span :start 2 :end 4) nil) + (setf remainder tmp) + (assert-equal 3 (length victims)) + (assert-eql 'c (first victims)) + (assert-eql 'd (second victims)) + (assert-eql 'e (third victims)) + (assert-equal 3 (length tmp)) + (assert-eql 'a (first tmp)) + (assert-eql 'b (second tmp)) + (assert-eql 'f (third tmp))) + (multiple-value-bind (tmp victims) + (gfs::remove-elements remainder (gfs:make-span :start 0 :end 1) nil) + (setf remainder tmp) + (assert-equal 2 (length victims)) + (assert-eql 'a (first victims)) + (assert-eql 'b (second victims)) + (assert-equal 1 (length tmp)) + (assert-eql 'f (first tmp))) + (multiple-value-bind (tmp victims) + (gfs::remove-elements remainder (gfs:make-span :start 0 :end 0) nil) + (assert-false tmp) + (assert-equal 1 (length victims)) + (assert-eql 'f (first victims))))) + +(define-test remove-element-non-adjustable-array-test + (let ((orig (make-array 3 :initial-contents '(a b c))) + (tmp nil)) + (setf tmp (gfs::remove-element orig 1 (lambda () (make-array 2)))) + (assert-false (array-has-fill-pointer-p tmp)) + (assert-false (adjustable-array-p tmp)) + (assert-equal 2 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-eql 'c (elt tmp 1)) + (setf tmp (gfs::remove-element tmp 1 (lambda () (make-array 1)))) + (assert-equal 1 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-false (gfs::remove-element tmp 0 (lambda () (make-array 0)))))) + +(defun reaam-test-make-array () + (make-array 10 :fill-pointer 0 :adjustable t)) + +(define-test remove-elements-adjustable-array-test + (let ((orig (reaam-test-make-array)) + (tmp nil)) + (loop for item in '(a b c d e f) do (vector-push-extend item orig)) + (setf tmp (gfs::remove-elements orig + (gfs:make-span :start 2 :end 4) + #'reaam-test-make-array)) + (assert-true (array-has-fill-pointer-p tmp)) + (assert-true (adjustable-array-p tmp)) + (assert-equal 3 (length tmp)) + (assert-eql 'a (elt tmp 0)) + (assert-eql 'b (elt tmp 1)) + (assert-eql 'f (elt tmp 2)) + (setf tmp (gfs::remove-elements tmp + (gfs:make-span :start 0 :end 1) + #'reaam-test-make-array)) + (assert-equal 1 (length tmp)) + (assert-eql 'f (elt tmp 0)) + (assert-false (gfs::remove-elements tmp + (gfs:make-span :start 0 :end 0) + #'reaam-test-make-array)))) Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Fri Sep 8 23:02:05 2006 @@ -76,6 +76,7 @@ (defun move-lb-content (orig-lb dest-lb) (let ((sel-items (gfw:selected-items orig-lb))) + (gfw:delete-selection orig-lb) (if sel-items (setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb)))))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Fri Sep 8 23:02:05 2006 @@ -65,15 +65,51 @@ (dotimes (i (length tmp)) (setf (elt result i) (second (elt tmp i)))))) result)) -(defun pick-elements (lisp-seq indices &optional count) +(defun pick-elements (sequence indices &optional count) (let ((picks nil)) (if (cffi:pointerp indices) (dotimes (i count) - (push (elt lisp-seq (mem-aref indices :unsigned-int i)) picks)) + (push (elt sequence (mem-aref indices :unsigned-int i)) picks)) (dotimes (i (length indices)) - (push (elt lisp-seq (elt indices i)) picks))) + (push (elt sequence (elt indices i)) picks))) (reverse picks))) +(defun add-element (element sequence index) + (cond + ((listp sequence) + (push element sequence)) + ((adjustable-array-p sequence) + (vector-push-extend element sequence)) + (t + (setf (elt sequence index) element))) + sequence) + +(defun remove-element (sequence index creator) + (let ((result nil) + (victim nil)) + (dotimes (i (length sequence)) + (if (= i index) + (setf victim (elt sequence i)) + (setf result (add-element (elt sequence i) + (or result (if creator (funcall creator) nil)) + (if victim (1- i) i))))) + (if (listp result) + (values (reverse result) victim) + (values result victim)))) + +(defun remove-elements (sequence span creator) + (let ((result nil) + (victims nil)) + (dotimes (i (length sequence)) + (if (and (>= i (gfs:span-start span)) (<= i (gfs:span-end span))) + (push (elt sequence i) victims) + (setf result (add-element (elt sequence i) + (or result (if creator (funcall creator) nil)) + (- i (length victims)))))) + (if (listp result) + (values (reverse result) (reverse victims)) + (values result (reverse victims))))) + (defun flatten (tree) (if (cl:atom tree) (list tree) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Fri Sep 8 23:02:05 2006 @@ -61,7 +61,9 @@ (dotimes (i (length new-items)) (let ((item (elt new-items i))) (if (typep item item-class) - (vector-push-extend item replacements) + (progn + (setf (slot-value item 'gfs:handle) handle) + (vector-push-extend item replacements)) (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements))))) @@ -69,7 +71,9 @@ ((listp new-items) (loop for item in new-items do (if (typep item item-class) - (vector-push-extend item replacements) + (progn + (setf (slot-value item 'gfs:handle) handle) + (vector-push-extend item replacements)) (let ((tmp (make-instance item-class :handle handle :data item))) (put-item tc tmp) (vector-push-extend tmp replacements)))) @@ -98,17 +102,21 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) - (let* ((items (slot-value self 'items)) - (it (elt items index))) - (setf (slot-value self 'items) (remove it items :test #'items-equal)) - (gfs:dispose it))) + (multiple-value-bind (new-items victim) + (gfs::remove-element (slot-value self 'items) index #'make-items-array) + (setf (slot-value self 'items) new-items) + (gfs:dispose victim))) -(defmethod delete-item-span :before ((self item-manager) (sp gfs:span)) +(defmethod delete-selection :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod delete-span :before ((self item-manager) (sp gfs:span)) (declare (ignore sp)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item-span ((self item-manager) (sp gfs:span)) +(defmethod delete-span ((self item-manager) (sp gfs:span)) (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (delete-item self (gfs:span-start sp)))) @@ -127,7 +135,7 @@ (let ((pos (position it (slot-value self 'items) :test #'items-equal))) (if (null pos) (return-from item-index 0)) - 0)) + pos)) (defmethod items-of ((self item-manager)) (coerce (slot-value self 'items) 'list)) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 8 23:02:05 2006 @@ -116,6 +116,13 @@ (lb-delete-all self) (setf (slot-value self 'items) (make-items-array))) +(defmethod delete-selection ((self list-box)) + (enable-redraw self nil) + (unwind-protect + (loop for item in (selected-items self) + do (gfs:dispose item)) + (enable-redraw self t))) + (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) @@ -214,6 +221,8 @@ (defmethod update-from-items ((self list-box)) (let ((sort-func (sort-predicate-of self)) (hwnd (gfs:handle self))) + (unless (zerop (lb-item-count hwnd)) + (error 'gfs:toolkit-error :detail "list-box has existing content")) (when sort-func (setf (slot-value self 'items) (gfs::indexed-sort (slot-value self 'items) sort-func #'data-of))) (enable-redraw self nil) @@ -222,6 +231,5 @@ (dotimes (index (length items)) (let* ((item (elt items index)) (text (call-text-provider self (data-of item)))) - (setf (index-of item) index) (lb-insert-item hwnd #xFFFFFFFF text (cffi:null-pointer))))) (enable-redraw self t)))) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Fri Sep 8 23:02:05 2006 @@ -70,17 +70,9 @@ ;;; (defmethod gfs:dispose ((self list-item)) - (let ((index (index-of self)) - (howner (gfs:handle self))) - (if howner - (gfs::send-message howner gfs::+lb-deletestring+ index 0)) - (setf (index-of self) 0)) + (let ((hwnd (gfs:handle self))) + (unless (or (null hwnd) (cffi:null-pointer-p hwnd)) + (let ((owner (get-widget (thread-context) hwnd))) + (if (and owner (cffi:pointer-eq hwnd (gfs:handle owner))) + (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0))))) (call-next-method)) - -(defmethod print-object ((self list-item) stream) - (print-unreadable-object (self stream :type t) - (format stream "id: ~d " (item-id self)) - (format stream "index: ~d " (index-of self)) - (format stream "data: ~a " (data-of self)) - (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a" (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Sep 8 23:02:05 2006 @@ -90,10 +90,7 @@ :allocation :class)) ; shadowing same slot from event-source (:documentation "The item class is the base class for all non-windowed user interface objects.")) -(defclass list-item (item) - ((index - :accessor index-of - :initform 0)) +(defclass list-item (item) () (:documentation "A subclass of item representing an element of a list-box.")) (defclass menu-item (item) () Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Sep 8 23:02:05 2006 @@ -135,12 +135,12 @@ (defgeneric delete-item (self index) (:documentation "Removes the item at the zero-based index from the object.")) -(defgeneric delete-item-span (self span) - (:documentation "Removes the sequence of items represented by the specified span object.")) - (defgeneric delete-selection (self) (:documentation "Removes items from self that are in the selected state.")) +(defgeneric delete-span (self span) + (:documentation "Removes the sequence of items represented by the specified span object.")) + (defgeneric disabled-image (self) (:documentation "Returns the image used to render this item with a disabled look.")) @@ -213,6 +213,12 @@ (defgeneric item-index (self item) (:documentation "Return the zero-based index of the location of the other object in this object.")) +(defgeneric items-of (self) + (:documentation "Returns a list of item subclasses representing the content of self.")) + +(defgeneric (setf items-of) (items self) + (:documentation "Accepts a list of application data (or list subclasses) to set the content of self.")) + (defgeneric layout (self) (:documentation "Set the size and location of this object's children.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Sep 8 23:02:05 2006 @@ -165,20 +165,11 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item :before ((self widget) index) - (declare (ignore index)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - -(defmethod delete-item-span :before ((self widget) span) +(defmethod delete-span :before ((self widget) span) (declare (ignore span)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-selection :before ((self widget)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error))) - (defmethod gfs:dispose ((self widget)) (unless (null (dispatcher self)) (event-dispose (dispatcher self) self)) From junrue at common-lisp.net Sat Sep 9 04:39:19 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 9 Sep 2006 00:39:19 -0400 (EDT) Subject: [graphic-forms-cvs] r253 - in trunk/src: tests/uitoolkit uitoolkit/widgets Message-ID: <20060909043919.A7B4B72120@common-lisp.net> Author: junrue Date: Sat Sep 9 00:39:19 2006 New Revision: 253 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp Log: implemented select-all for list-box Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sat Sep 9 00:39:19 2006 @@ -66,13 +66,13 @@ (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) (defun manage-lb-button-states (lb move-btn all-btn none-btn) - (let ((count (gfw:selected-count lb)) - (items (gfw:items-of lb))) - (gfw:enable move-btn (> count 0)) + (let ((sel-count (gfw:selected-count lb)) + (item-count (length (gfw:items-of lb)))) + (gfw:enable move-btn (> sel-count 0)) (if all-btn - (gfw:enable all-btn (< count (length items)))) + (gfw:enable all-btn (and (> item-count 0) (< sel-count item-count)))) (if none-btn - (gfw:enable none-btn (> count 0))))) + (gfw:enable none-btn (> sel-count 0))))) (defun move-lb-content (orig-lb dest-lb) (let ((sel-items (gfw:selected-items orig-lb))) @@ -99,16 +99,20 @@ (declare (ignore disp btn)) (move-lb-content lb2 lb1) (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (manage-lb-button-states lb2 btn-left nil nil))) (btn-right-callback (lambda (disp btn) (declare (ignore disp btn)) (move-lb-content lb1 lb2) (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left btn-all btn-none))) + (manage-lb-button-states lb2 btn-left nil nil))) (btn-all-callback (lambda (disp btn) - (declare (ignore disp btn)))) + (declare (ignore disp btn)) + (gfw:select-all lb1 t) + (manage-lb-button-states lb1 btn-right btn-all btn-none))) (btn-none-callback (lambda (disp btn) - (declare (ignore disp btn)))) + (declare (ignore disp btn)) + (gfw:select-all lb1 nil) + (manage-lb-button-states lb1 btn-right btn-all btn-none))) (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Sat Sep 9 00:39:19 2006 @@ -102,6 +102,8 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) + (if (or (< index 0) (>= index (length (slot-value self 'items)))) + (error 'gfs:toolkit-error :detail "invalid item index")) (multiple-value-bind (new-items victim) (gfs::remove-element (slot-value self 'items) index #'make-items-array) (setf (slot-value self 'items) new-items) @@ -116,10 +118,6 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-span ((self item-manager) (sp gfs:span)) - (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) - (delete-item self (gfs:span-start sp)))) - (defmethod gfs:dispose ((self item-manager)) (let ((items (slot-value self 'items)) (tc (thread-context))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Sat Sep 9 00:39:19 2006 @@ -123,6 +123,13 @@ do (gfs:dispose item)) (enable-redraw self t))) +(defmethod delete-span ((self list-box) (span gfs:span)) + (enable-redraw self nil) + (unwind-protect + (dotimes (i (1+ (- (gfs:span-end span) (gfs:span-start span)))) + (delete-item self (gfs:span-start span))) + (enable-redraw self t))) + (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) @@ -194,6 +201,11 @@ (incf (gfs:size-width size) (vertical-scrollbar-width))) size)) +(defmethod select-all ((self list-box) flag) + (when (or (test-native-style self gfs::+lbs-extendedsel+) + (test-native-style self gfs::+lbs-multiplesel+)) + (gfs::send-message (gfs:handle self) gfs::+lb-setsel+ (if flag 1 0) #xFFFFFFFF))) + (defmethod selected-count ((self list-box)) (let ((hwnd (gfs:handle self))) (if (test-native-style self gfs::+lbs-nosel+) From junrue at common-lisp.net Sun Sep 10 21:31:02 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 10 Sep 2006 17:31:02 -0400 (EDT) Subject: [graphic-forms-cvs] r254 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060910213102.EC54416033@common-lisp.net> Author: junrue Date: Sun Sep 10 17:31:01 2006 New Revision: 254 Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.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 Log: fixed a bug in checked-p for buttons; implemented low-level select and deselect functions for list-box; enhanced test-native-style to support more than one bit to test Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Sun Sep 10 17:31:01 2006 @@ -16,22 +16,35 @@ @anchor{append-item} @deffn GenericFunction append-item self thing dispatcher &optional disabled checked => @ref{item} -Adds a new item representing @var{thing} to @var{self}, where the -class of @var{self} must derive from @ref{item-manager}. The -newly-created item is returned. The @var{dispatcher} parameter must -be an instance of @ref{event-dispatcher} or a subclass thereof. The -optional @var{checked} and @var{disabled} arguments can be used to set -the item's initial state. +Adds a new item representing @var{thing} to @var{self}, where @var{thing} +can be any @sc{object}. The newly-created item is returned. +The @var{dispatcher} parameter must be one of the following: + at itemize @bullet + at item An instance of @ref{event-dispatcher} or a subclass thereof. + at item A function whose argument list matches the event method +identified by the @var{callback-event-name} slot in @var{self}'s +class. + +See also @ref{items-of}. + at end itemize + +The optional @var{checked} and @var{disabled} arguments will each be +interpreted as @sc{generalized boolean} values in order to set the +item's initial state. Note, however, that not all @ref{item-manager} +subclasses support enabled or checked states for individual items. @end deffn @deffn GenericFunction append-separator self => @ref{item} -Adds a separator item to @var{self}, and returns the newly-created item. +Adds a separator to @var{self}, and returns a newly-created item to +wrap the separator. A separator is a thin etched divider that serves +to visually separate groups of items and has no other behavior. @end deffn - at deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{item} + at deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{menu-item} Adds @var{submenu} anchored to @var{self} and returns the corresponding - at ref{menu-item}. The optional @var{checked} and @var{disabled} arguments can -be used to set the menu item's initial state. +menu-item. The optional @var{checked} and @var{disabled} arguments +will each be interpreted as @sc{generalized boolean} values +in order to set the menu item's initial state. @end deffn @anchor{auto-hscroll-p} @@ -139,6 +152,16 @@ presses @sc{enter}. @end deffn + at anchor{data-of} + at deffn Accessor data-of self +(setf (@strong{data-of} @var{self}) @var{object})@* + +Returns application-specific data associated with @var{self}. + +The corresponding @sc{set} function associates new data with + at var{self}. + at end deffn + @deffn GenericFunction delete-all self Removes all content from @var{self}. @end deffn @@ -259,8 +282,33 @@ an image or an icon-bundle. @end deffn + at anchor{item-count} + at deffn GenericFunction item-count self => integer +Returns the number of instances of @ref{item} subclasses contained within + at var{self}. + at end deffn + + at anchor{item-index} @deffn GenericFunction item-index self item -Return the zero-based index of the location of the other object in this object. +Return the zero-based index of the location of @var{item} within @var{self}. + at end deffn + + at anchor{items-of} + at deffn GenericFunction items-of self +(setf (@strong{items-of} @var{self}) @var{items})@* + +Returns a fresh @sc{list} of @ref{item} subclasses appropriate for + at var{self}'s type. + +The corresponding @sc{setf} function accepts a list whose contents +are any combination of: + at itemize @bullet + at item Instances of @ref{item} subclasses appropriate for @var{self}. + at item Instances of any @sc{object} type; these will be wrapped by item +objects, to be accessible later via the @ref{data-of} method. + at end itemize +Existing items contained by @var{self} are replaced, and then the +native control is refreshed. See also @ref{append-item}. @end deffn @anchor{layout} @@ -284,7 +332,10 @@ Calls @var{func}, which is a function of two arguments, for each child of @var{self} and places @var{func}'s return value in @var{result-list}. @var{func}'s two arguments are @var{self} and -the current child. +the current child. Note that @code{mapchildren} accesses @var{self}'s + at emph{actual} children as determined by the underlying window's +data structures, regardless of any @ref{layout-manager} assigned +to @var{self}. @end deffn @anchor{maximum-size} @@ -464,16 +515,18 @@ @deffn GenericFunction selected-items self => list (setf (@strong{selected-items} @var{self}) @var{list}) -Returns a @sc{list} containing subclasses of @ref{item} appropriate -for @var{self} that correspond to selections made by the user, or - at sc{nil} if there are no selections. This function is defined only -for @ref{widget}s whose notion of @emph{selection} is a set of -item objects. - -The @sc{setf} function takes a @var{list} of item subclasses -appropriate for @var{self} which identify the items in - at var{self} that should be selected. Passing @sc{nil} will unselect all -items, which is equivalent to calling @ref{select-all} with @sc{nil}. +Returns a fresh @sc{list} containing subclasses of @ref{item} +appropriate for @var{self} that correspond to selections made by the +user, or @sc{nil} if there are no selections. This function is defined +only for @ref{widget}s whose notion of @emph{selection} is a set of +instances of @ref{item} subclasses. + +The @sc{setf} function takes a @sc{list} of instances of item +subclasses appropriate for @var{self} which identify the items in + at var{self} that should be selected. at footnote{In this respect, + at ref{selected-items} is not symmetric with @ref{items-of}.} Passing + at sc{nil} will unselect all items, which is equivalent to calling + at ref{select-all} with @sc{nil}. @end deffn @anchor{selected-p} Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Sep 10 17:31:01 2006 @@ -436,6 +436,7 @@ #:initial-delay-of #:horizontal-scrollbar #:image + #:item-count #:item-height #:item-id #:item-index Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sun Sep 10 17:31:01 2006 @@ -65,10 +65,12 @@ (gfg:foreground-color gc) color)) (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) -(defun manage-lb-button-states (lb move-btn all-btn none-btn) +(defun manage-lb-button-states (lb move-btn selected-btn all-btn none-btn) (let ((sel-count (gfw:selected-count lb)) - (item-count (length (gfw:items-of lb)))) + (item-count (gfw:item-count lb))) (gfw:enable move-btn (> sel-count 0)) + (if selected-btn + (gfw:check selected-btn (> sel-count 0))) (if all-btn (gfw:enable all-btn (and (> item-count 0) (< sel-count item-count)))) (if none-btn @@ -80,39 +82,64 @@ (if sel-items (setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb)))))) +(defun select-lb-content (lb state) + (let ((count (gfw:item-count lb)) + (func (if state #'gfw::lb-select-item #'gfw::lb-deselect-item))) + (loop for index in '(0 2 4) + when (>= count (1+ index)) + do (funcall func lb index)))) +#| + (let ((items (gfw:items-of lb))) + (setf (gfw:selected-items lb) (subseq items 0 (min 4 (length items)))))) +|# + (defun populate-list-box-test-panel () (setf (gfw:text *widget-tester-win*) "Widget Tester (List Boxes)") (let* ((panel-disp (make-instance 'widget-tester-panel-events)) - (lb1 nil) - (lb2 nil) - (btn-left nil) - (btn-right nil) - (btn-all nil) - (btn-none nil) - (lb1-callback (lambda (disp lb) - (declare (ignore disp)) - (manage-lb-button-states lb btn-right btn-all btn-none))) - (lb2-callback (lambda (disp lb) - (declare (ignore disp)) - (manage-lb-button-states lb btn-left nil nil))) - (btn-left-callback (lambda (disp btn) - (declare (ignore disp btn)) - (move-lb-content lb2 lb1) - (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left nil nil))) - (btn-right-callback (lambda (disp btn) - (declare (ignore disp btn)) - (move-lb-content lb1 lb2) - (manage-lb-button-states lb1 btn-right btn-all btn-none) - (manage-lb-button-states lb2 btn-left nil nil))) - (btn-all-callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfw:select-all lb1 t) - (manage-lb-button-states lb1 btn-right btn-all btn-none))) - (btn-none-callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfw:select-all lb1 nil) - (manage-lb-button-states lb1 btn-right btn-all btn-none))) + (latch nil) + (lb1 nil) + (lb2 nil) + (btn-left nil) + (btn-right nil) + (btn-all nil) + (btn-none nil) + (btn-select nil) + (lb1-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-right (if latch nil btn-select) btn-all btn-none))) + (lb2-callback (lambda (disp lb) + (declare (ignore disp)) + (manage-lb-button-states lb btn-left nil nil nil))) + (btn-left-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb2 lb1) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) + (manage-lb-button-states lb2 btn-left nil nil nil))) + (btn-right-callback (lambda (disp btn) + (declare (ignore disp btn)) + (move-lb-content lb1 lb2) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) + (manage-lb-button-states lb2 btn-left nil nil nil))) + (btn-all-callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfw:select-all lb1 t) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none))) + (btn-none-callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfw:select-all lb1 nil) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none))) + (btn-reset-callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfw:delete-all lb2) + (setf (gfw:items-of lb1) *list-box-test-data*) + (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none) + (manage-lb-button-states lb2 btn-left nil nil nil))) + (btn-select-callback (lambda (disp btn) + (declare (ignore disp)) + (setf latch t) + (select-lb-content lb1 (gfw:selected-p btn)) + (manage-lb-button-states lb1 btn-right nil btn-all btn-none) + (setf latch nil))) (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* @@ -135,21 +162,28 @@ :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) - (setf btn-right (make-instance 'gfw:button :parent btn-panel - :text " ==> " - :callback btn-right-callback)) + (setf btn-right (make-instance 'gfw:button :parent btn-panel + :text " ==> " + :callback btn-right-callback)) (gfw:enable btn-right nil) - (setf btn-left (make-instance 'gfw:button :parent btn-panel - :text " <== " - :callback btn-left-callback)) + (setf btn-left (make-instance 'gfw:button :parent btn-panel + :text " <== " + :callback btn-left-callback)) (gfw:enable btn-left nil) - (setf btn-all (make-instance 'gfw:button :parent btn-panel - :text "Select All" - :callback btn-all-callback)) - (setf btn-none (make-instance 'gfw:button :parent btn-panel - :text "Select None" - :callback btn-none-callback)) + (setf btn-all (make-instance 'gfw:button :parent btn-panel + :text "Select All" + :callback btn-all-callback)) + (setf btn-none (make-instance 'gfw:button :parent btn-panel + :text "Select None" + :callback btn-none-callback)) (gfw:enable btn-none nil) + (make-instance 'gfw:button :parent btn-panel + :text "Reset" + :callback btn-reset-callback) + (setf btn-select (make-instance 'gfw:button :parent btn-panel + :text "Select 0,2,4" + :style '(:check-box) + :callback btn-select-callback)) (gfw:pack btn-panel) (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) @@ -160,12 +194,17 @@ (gfw:pack lb2-panel) (gfw:pack outer-panel) + ;; FIXME: need to think of a more elegant solution for the following + ;; use-case where we want synchronize the sizes of two or more + ;; layout children + ;; (let ((size (gfw:size lb1))) (setf (gfw:maximum-size lb1) size (gfw:minimum-size lb1) size (gfw:maximum-size lb2) size (gfw:minimum-size lb2) size)) (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)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Sep 10 17:31:01 2006 @@ -729,3 +729,9 @@ ("UpdateWindow" update-window) BOOL (hwnd HANDLE)) + +(defcfun + ("ValidateRect" validate-rect) + BOOL + (hwnd HANDLE) + (rct LPTR)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun Sep 10 17:31:01 2006 @@ -46,10 +46,7 @@ (defmethod checked-p ((self button)) (let ((bits (gfs::send-message (gfs:handle self) gfs::+bm-getcheck+ 0 0))) - (case bits - (gfs::+bst-checked+ t) - (gfs::+bst-unchecked+ nil) - (otherwise nil)))) + (= (logand bits gfs::+bst-checked+) gfs::+bst-checked+))) (defmethod compute-style-flags ((self button) &rest extra-data) (declare (ignore extra-data)) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Sun Sep 10 17:31:01 2006 @@ -124,6 +124,13 @@ (dotimes (i (length items)) (delete-tc-item tc (elt items i))))) +(defmethod item-count :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod item-count ((self item-manager)) + (length (slot-value self 'items))) + (defmethod item-index :before ((self item-manager) (it item)) (declare (ignore it)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Sun Sep 10 17:31:01 2006 @@ -56,6 +56,11 @@ (logand orig-flags (lognot (logior gfs::+lbs-nosel+ gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+)))) +(defun lb-is-single-select (lb) + (not (test-native-style lb (logior gfs::+lbs-extendedsel+ + gfs::+lbs-multiplesel+ + gfs::+lbs-nosel+)))) + (defun lb-width (hwnd) (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) (if (< width 0) @@ -76,6 +81,90 @@ (setf (slot-value victim 'gfs:handle) nil) (gfs:dispose victim))))) +;;; This function is based on the package private select( int, boolean ) +;;; method from SWT 3.2 located in List.java starting on line 998, without +;;; the additional scrolling logic. +;;; +(defun lb-select-item (lb index) + (let ((hwnd (gfs:handle lb))) + + ;; sanity-check the index + ;; + (if (or (< index 0) (>= index (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (return-from lb-select-item nil)) + + ;; save the index of the top-most item + ;; + (let ((top-index (gfs::send-message hwnd gfs::+lb-gettopindex+ 0 0))) + (cffi:with-foreign-object (top-item-rect-ptr 'gfs::rect) + (cffi:with-foreign-object (sel-item-rect-ptr 'gfs::rect) + + ;; get the rectangle for the top-most item which we + ;; will repaint at the end + ;; + (gfs::send-message hwnd gfs::+lb-getitemrect+ + top-index (cffi:pointer-address top-item-rect-ptr)) + (let ((redraw-needed (zerop (gfs::is-window-visible hwnd))) + (has-sel-item nil)) + + ;; if the list box is visible, disable repainting + ;; + (if redraw-needed + (enable-redraw lb nil)) + (unwind-protect + (progn + (if (lb-is-single-select lb) + + ;; single-select list boxes must be configured differently + ;; from multi-select + ;; + (let ((old-index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) + (setf has-sel-item (/= old-index -1)) + + ;; get the rectangle for the old selected item + ;; + (if has-sel-item + (gfs::send-message hwnd gfs::+lb-getitemrect+ + old-index (cffi:pointer-address sel-item-rect-ptr))) + + ;; set the new selection + ;; + (gfs::send-message hwnd gfs::+lb-setcursel+ index 0)) + + ;; configure new selection for multi-select list boxes + ;; + (let ((focus-index (gfs::send-message hwnd gfs::+lb-getcaretindex+ 0 0))) + + ;; set the new selection + ;; + (gfs::send-message hwnd gfs::+lb-setsel+ 1 index) + + ;; if there was an item with focus, restore it + ;; + (if (/= focus-index -1) + (gfs::send-message hwnd gfs::+lb-setcaretindex+ focus-index 0))))) + + ;; restore the original top-index, then update the + ;; list box and the top item and the selection item + ;; + (gfs::send-message hwnd gfs::+lb-settopindex+ top-index 0) + (when redraw-needed + (enable-redraw lb t) + (gfs::validate-rect hwnd (cffi:null-pointer)) + (gfs::invalidate-rect hwnd top-item-rect-ptr 1) + (if has-sel-item + (gfs::invalidate-rect hwnd sel-item-rect-ptr 1)))))))))) + +(defun lb-deselect-item (lb index) + (let ((hwnd (gfs:handle lb))) + (if (or (< index 0) (>= index (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (return-from lb-deselect-item nil)) + (if (lb-is-single-select lb) + (let ((curr-index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) + (if (= curr-index index) + (gfs::send-message hwnd gfs::+lb-setcursel+ -1 0))) + (gfs::send-message hwnd gfs::+lb-setsel+ 0 index)))) + ;;; ;;; methods ;;; @@ -202,8 +291,7 @@ size)) (defmethod select-all ((self list-box) flag) - (when (or (test-native-style self gfs::+lbs-extendedsel+) - (test-native-style self gfs::+lbs-multiplesel+)) + (when (test-native-style self (logior gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+)) (gfs::send-message (gfs:handle self) gfs::+lb-setsel+ (if flag 1 0) #xFFFFFFFF))) (defmethod selected-count ((self list-box)) @@ -216,8 +304,7 @@ (defmethod selected-items ((self list-box)) (let ((hwnd (gfs:handle self)) (items (slot-value self 'items))) - (if (and (not (test-native-style self gfs::+lbs-extendedsel+)) - (not (test-native-style self gfs::+lbs-multiplesel+))) + (if (lb-is-single-select self) (let ((index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0))) (if (and (>= index 0) (< index (length items))) (list (elt items index)) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Sun Sep 10 17:31:01 2006 @@ -51,6 +51,12 @@ (error 'gfs:win32-error :detail "LB_GETITEMHEIGHT failed")) height)) +(defun lb-item-text-length (hwnd index) + (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0))) + (if (< length 0) + (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed")) + length)) + (defun lb-item-text (hwnd index &optional buffer-size) (if (or (null buffer-size) (<= buffer-size 0)) (setf buffer-size (lb-item-text-length hwnd index))) @@ -59,12 +65,6 @@ (error 'gfs:win32-error :detail "LB_GETTEXT failed")) (cffi:foreign-string-to-lisp str-ptr))) -(defun lb-item-text-length (hwnd index) - (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0))) - (if (< length 0) - (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed")) - length)) - ;;; ;;; methods ;;; @@ -76,3 +76,9 @@ (if (and owner (cffi:pointer-eq hwnd (gfs:handle owner))) (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0))))) (call-next-method)) + +(defmethod text ((self list-item)) + (let ((hwnd (gfs:handle self))) + (if (or (null hwnd) (cffi:null-pointer-p hwnd)) + "" + (lb-item-text hwnd (item-index (get-widget (thread-context) hwnd) self))))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Sep 10 17:31:01 2006 @@ -39,6 +39,8 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) +(defvar *default-dispatcher* (make-instance 'event-dispatcher)) + (defclass layout-managed () ((layout-p :reader layout-p @@ -68,7 +70,7 @@ ((dispatcher :accessor dispatcher :initarg :dispatcher - :initform (make-instance 'event-dispatcher)) + :initform *default-dispatcher*) (callback-event-name :accessor callback-event-name-of :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 Sep 10 17:31:01 2006 @@ -207,6 +207,9 @@ (defgeneric (setf image) (image self) (:documentation "Sets self's image object.")) +(defgeneric item-count (self) + (:documentation "Returns the number of items contained within self.")) + (defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Sep 10 17:31:01 2006 @@ -141,7 +141,7 @@ (defun show-common-dialog (dlg dlg-func) (let* ((struct-ptr (gfs:handle dlg)) (retval (funcall dlg-func struct-ptr))) - (if (and (zerop retval) (not (zerop (gfs::comm-dlg-extended-error)))) + (if (and (zerop retval) (/= (gfs::comm-dlg-extended-error) 0)) (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) retval)) @@ -286,7 +286,7 @@ (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+)) (defun test-native-style (widget bits) - (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) bits)) + (/= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) 0)) (defun test-native-exstyle (widget bits) - (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) bits)) + (/= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) 0)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Sep 10 17:31:01 2006 @@ -207,7 +207,7 @@ (redraw self))) (defmethod enabled-p ((self widget)) - (not (zerop (gfs::is-window-enabled (gfs:handle self))))) + (/= (gfs::is-window-enabled (gfs:handle self)) 0)) (defmethod image :before ((self widget)) (if (gfs:disposed-p self) @@ -435,4 +435,4 @@ (error 'gfs:disposed-error))) (defmethod visible-p ((self widget)) - (not (zerop (gfs::is-window-visible (gfs:handle self))))) + (/= (gfs::is-window-visible (gfs:handle self)) 0)) From junrue at common-lisp.net Sun Sep 10 22:59:22 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 10 Sep 2006 18:59:22 -0400 (EDT) Subject: [graphic-forms-cvs] r255 - in trunk/src: tests/uitoolkit uitoolkit/widgets Message-ID: <20060910225922.7FB253106@common-lisp.net> Author: junrue Date: Sun Sep 10 18:59:22 2006 New Revision: 255 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/list-item.lisp Log: implemented select and selected-p for list-item Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sun Sep 10 18:59:22 2006 @@ -85,7 +85,9 @@ (defun select-lb-content (lb state) (let ((count (gfw:item-count lb)) (func (if state #'gfw::lb-select-item #'gfw::lb-deselect-item))) - (loop for index in '(0 2 4) + (if (> count 0) + (gfw:select (first (gfw:items-of lb)) state)) + (loop for index in '(2 4) when (>= count (1+ index)) do (funcall func lb index)))) #| Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Sun Sep 10 18:59:22 2006 @@ -77,6 +77,16 @@ (gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0))))) (call-next-method)) +(defmethod select ((self list-item) flag) + (let ((owner (owner self))) + (if flag + (lb-select-item owner (item-index owner self)) + (lb-deselect-item owner (item-index owner self))))) + +(defmethod selected-p ((self list-item)) + (let ((owner (owner self))) + (> (gfs::send-message (gfs:handle self) gfs::+lb-getsel+ (item-index owner self) 0) 0))) + (defmethod text ((self list-item)) (let ((hwnd (gfs:handle self))) (if (or (null hwnd) (cffi:null-pointer-p hwnd)) From junrue at common-lisp.net Mon Sep 11 04:41:24 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 11 Sep 2006 00:41:24 -0400 (EDT) Subject: [graphic-forms-cvs] r256 - trunk Message-ID: <20060911044124.B1769D002@common-lisp.net> Author: junrue Date: Mon Sep 11 00:41:24 2006 New Revision: 256 Modified: trunk/NEWS.txt trunk/README.txt Log: doc updates Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Sep 11 00:41:24 2006 @@ -1,8 +1,28 @@ +. Initial list box control functionality is now available: + + * three selection modes (none / multiple / extend) + + * list item data comprised by arbitrary application-defined data + + * application defined sorting predicates + + * querying and programmatic control of item selection states + + * customizability of vertical scrollbar mode and keyboard input + + Additional list box control features will be provided in a future release. + +. Did some housecleaning of the item-manager protocol and heavily refactored + the implementation of item-manager base functionality. + . Implemented GFW:ENABLE-REDRAW to enable applications to temporarily disable (and later re-enable) drawing of widget content. +. Fixed a silly bug in GFW:CHECKED-P (and GFW:SELECTED-P) for checkbox and + radio button -style buttons. + ============================================================================== Release 0.5.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Sep 11 00:41:24 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.6.0 (22 August 2006) +Graphic-Forms README for version 0.6.0 (xx xxxxxxx 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -73,11 +73,15 @@ compute height from that. The gfg:text-extent function does return the correct width. +5. If a Graphic-Forms application is launched from within SLIME on a + single-threaded Common Lisp implementation, further SLIME commands + will be 'pipelined' until the Graphic-Forms main message loop exits. + How To Configure and Build -------------------------- -NOTE: in a future release, this project will be packaged for delivery +NOTE: in a future release, this library will be packaged for delivery via asdf-install. 1. [OPTIONAL] Install ImageMagick 6.2.6.5-Q16 (note in particular that it @@ -169,10 +173,12 @@ (gft:event-tester) - (gft:image-tester) + (gft:image-tester) ; if ImageMagick loaded, shows PNG and GIF images (gft:layout-tester) + (gft:widget-tester) + (gft:windlg) ;; From junrue at common-lisp.net Mon Sep 11 20:30:59 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 11 Sep 2006 16:30:59 -0400 (EDT) Subject: [graphic-forms-cvs] r257 - in trunk: docs/manual src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060911203059.C2E286000E@common-lisp.net> Author: junrue Date: Mon Sep 11 16:30:56 2006 New Revision: 257 Modified: trunk/docs/manual/event-functions.texinfo trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: account for menu wrapping in window compute-outer-size Modified: trunk/docs/manual/event-functions.texinfo ============================================================================== --- trunk/docs/manual/event-functions.texinfo (original) +++ trunk/docs/manual/event-functions.texinfo Mon Sep 11 16:30:56 2006 @@ -239,10 +239,10 @@ @event-dispatcher-arg @item widget The @ref{widget} whose contents need to be repainted. - at item gc + at item graphics-context A @ref{graphics-context} initialized for use during this paint event and which will be @ref{dispose}d after this method returns. - at item rect + at item rectangle The specific @ref{rectangle} within @var{widget} needing to be repainted. @end table @end deffn Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Sep 11 16:30:56 2006 @@ -175,8 +175,8 @@ (setf gfs::tablength tab-width) (setf gfs::leftmargin 0) (setf gfs::rightmargin 0) - (gfs::with-rect - (gfs::draw-text-ex hdc str -1 gfs::rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) + (gfs::with-rect (rect-ptr) + (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) (setf (gfs:size-width sz) (- gfs::right gfs::left)) (setf (gfs:size-height sz) (- gfs::bottom gfs::top)))))) (when (or (zerop len) (zerop (gfs:size-height sz))) @@ -292,7 +292,7 @@ (let ((hdc (gfs:handle self)) (pnt (gfs:location rect)) (size (gfs:size rect))) - (gfs::with-rect + (gfs::with-rect (rect-ptr) (setf gfs::top (gfs:point-y pnt) gfs::left (gfs:point-x pnt) gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size)) @@ -441,19 +441,19 @@ (setf gfs::tablength tb-width) (setf gfs::leftmargin 0) (setf gfs::rightmargin 0) - (gfs::with-rect + (gfs::with-rect (rect-ptr) (setf gfs::left (gfs:point-x pnt)) (setf gfs::top (gfs:point-y pnt)) (gfs::draw-text-ex (gfs:handle self) text -1 - gfs::rect-ptr + rect-ptr (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+))) dt-ptr) (gfs::draw-text-ex (gfs:handle self) text (length text) - gfs::rect-ptr + rect-ptr flags dt-ptr) (gfs::set-bk-mode (gfs:handle self) old-bk-mode)))))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Sep 11 16:30:56 2006 @@ -132,11 +132,11 @@ ;;; convenience macros ;;; -(defmacro with-rect (&body body) - `(cffi:with-foreign-object (rect-ptr 'gfs::rect) +(defmacro with-rect ((rect-var) &body body) + `(cffi:with-foreign-object (,rect-var 'gfs::rect) (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) - rect-ptr gfs::rect) - (zero-mem rect-ptr gfs::rect) + ,rect-var gfs::rect) + (zero-mem ,rect-var gfs::rect) , at body))) (defmacro with-hfont-selected ((hdc hfont) &body body) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Sep 11 16:30:56 2006 @@ -153,18 +153,29 @@ color)) (defmethod compute-outer-size ((self window) desired-client-size) - (let ((hwnd (gfs:handle self)) - (new-size (gfs:make-size))) - (gfs::with-rect + (let* ((hwnd (gfs:handle self)) + (has-menu (not (cffi:null-pointer-p (gfs::get-menu hwnd)))) + (new-size (gfs:make-size))) + (gfs::with-rect (rect-ptr) (setf gfs::right (gfs:size-width desired-client-size) gfs::bottom (gfs:size-height desired-client-size)) - (if (zerop (gfs::adjust-window-rect gfs::rect-ptr + (if (zerop (gfs::adjust-window-rect rect-ptr (get-native-style self) - (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) + (if has-menu 1 0) (get-native-exstyle self))) (error 'gfs:win32-error :detail "adjust-window-rect failed")) (setf (gfs:size-width new-size) (- gfs::right gfs::left) - (gfs:size-height new-size) (- gfs::bottom gfs::top))) + (gfs:size-height new-size) (- gfs::bottom gfs::top)) + ;; check how much wrapping occurs if there is a menu and we + ;; size a window to the above-computed width and infinite + ;; height + (when has-menu + (setf gfs::bottom #x7FFFFFFF) ; ensures we handle all possible menu wrap + (gfs::send-message hwnd gfs::+wm-nccalcsize+ 0 (cffi:pointer-address rect-ptr)) + ;; gfs::top is now the bottom-most position of the top part of the window's + ;; non-client area, which is the area that the wrapped menu occupies and for + ;; which compensation is needed. + (incf (gfs:size-height new-size) gfs::top))) new-size)) (defmethod gfs:dispose ((self window)) From junrue at common-lisp.net Tue Sep 12 03:04:32 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 11 Sep 2006 23:04:32 -0400 (EDT) Subject: [graphic-forms-cvs] r258 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060912030432.9195658322@common-lisp.net> Author: junrue Date: Mon Sep 11 23:04:31 2006 New Revision: 258 Modified: trunk/docs/manual/event-functions.texinfo trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/list-box.lisp Log: implemented and documented event-scroll generic function as first stage of implementing general scrolling support; renamed list-box style :vertical-scrollbar to :scrollbar-always to reflect that this is a policy style Modified: trunk/docs/manual/event-functions.texinfo ============================================================================== --- trunk/docs/manual/event-functions.texinfo (original) +++ trunk/docs/manual/event-functions.texinfo Mon Sep 11 23:04:31 2006 @@ -271,6 +271,62 @@ @end table @end deffn + at anchor{event-scroll} + at deffn GenericFunction event-scroll @ref{event-dispatcher} @ref{widget} axis detail +Implement this method to handle scrolling notifications for @var{widget}. + at table @var + at event-dispatcher-arg + at item widget +The @ref{widget} that was scrolled. + at item axis +The scrolling orientation, identified by one of the following +keyword symbols:@*@* + at table @code + at item :horizontal +Indicates that scrolling is occurring in the horizontal axis. + at item :vertical +Indicates that scrolling is occurring in the vertical axis. + at end table + at item detail +The specific scrolling request, identified by one of the +following keyword symbols:@*@* + at table @code + at item :end +The bottom or right-most content is revealed. + at item :page-back +The viewport is moved backward towards content start by +an amount equal to the viewport's height or width, or +the amount remaining between the viewport's origin +and the start, whichever is smaller. + at item :page-forward +The viewport is moved forward towards content end by +an amount equal to the viewport's height or width, or +the amount remaining between the viewport's origin +and the end, whichever is smaller. + at item :start +The viewport is moved such that the top or left-most +content edge is revealed. + at item :step-back +The viewport is moved backward towards content start by +an application-defined increment, or the amount +remaining between the viewport's origin and the start, +whichever is smaller. + at item :step-forward +The viewport is moved forward towards content end by an +application-defined increment, or the amount +remaining between the viewport's origina and the end, +whichever is smaller. + at item :thumb-position +Indicates an absolute position to which the viewport origin +is moved, as when the user releases the mouse button from a +scrollbar thumb. + at item :thumb-track +Indicates that the user is adjusting the position of the +viewport continuously, as when dragging a scrollbar thumb. + at end table + at end table + at end deffn + @anchor{event-select} @deffn GenericFunction event-select @ref{event-dispatcher} @ref{widget} Implement this method to handle notification that @var{widget} (or some Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Mon Sep 11 23:04:31 2006 @@ -136,6 +136,27 @@ @end deftp @end macro + at macro begin-primary-style-choices{defaultdesc} +The @code{:style} initarg is a list of keywords that define the +look-and-feel of the widget being created. \defaultdesc\ +Applications may choose from one of the following primary styles: + at table @code + at end macro + + at macro end-primary-style-choices + at end table + at end macro + + at macro begin-optional-style-choices +One or more of the following optional style keyword(s) may be +specified in the style keyword list: + at table @code + at end macro + + at macro end-optional-style-choices + at end table + at end macro + @c ==========================End Macros ============================= @copying Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Sep 11 23:04:31 2006 @@ -185,7 +185,8 @@ @end deffn @control-parent-initarg{button} @deffn Initarg :style - at table @code + at begin-primary-style-choices{The @code{:push-button} style is the +default.} @item :cancel-button Placing a @code{:cancel-button} in a @ref{dialog} enables the @sc{escape} key @ref{accelerator} for dismissing the dialog. This @@ -218,7 +219,7 @@ This style specifies a control that looks similar to a @code{:check-box}, but the box can be grayed as well as checked or cleared. The grayed look is used to indicate an undetermined state. - at end table + at end-primary-style-choices @end deffn @deffn Initarg :text Supplies the text for the button label. @@ -279,7 +280,7 @@ @control-callback-initarg{edit,event-modify} @control-parent-initarg{edit} @deffn Initarg :style - at table @code + at begin-optional-style-choices @item :auto-hscroll Specifies that the edit control will scroll text content to the right by 10 characters when the user types a character at the end @@ -323,7 +324,7 @@ style is also specified. Without this style, within a dialog the act of typing @sc{enter} has the same effect as pressing the dialog's default button. - at end table + at end-optional-style-choices @end deffn @deffn Initarg :text Supplies the initial text for the edit control. @@ -394,7 +395,8 @@ @end deffn @control-parent-initarg{list-box} @deffn Initarg :style - at table @code + at begin-primary-style-choices{By default\, a single item may be +selected at a time.} @item :extend-select This style keyword causes the list-box to allow multiple items to be selected by use of the @sc{shift} key and the mouse or special @@ -405,20 +407,19 @@ @item :no-select This style keyword means that the list-box will display items but not allow any selections. - at item :single-select -This style keyword means that the list-box only allows one item at a -time to be selected. This is the default selection style. + at end-primary-style-choices + at begin-optional-style-choices + at item :scrollbar-always +This style keyword causes the list-box to show a disabled vertical +scrollbar when it does not contain enough items to scroll. Otherwise +in such a case, the scrollbar will be hidden until needed. @item :tab-stops This style keyword configures the list-box to to expand tab characters when rendering item strings. @item :want-keys This style keyword allows the application to perform special processing when the list-box has focus and the user presses a key. - at item :want-scrollbar -This style keyword causes the list-box to show a disabled vertical -scrollbar when it does not contain enough items to scroll. Otherwise -in such a case, the scrollbar will be hidden. - at end table + at end-optional-style-choices @end deffn @end-control-subclass @@ -453,8 +454,8 @@ @ref{window} or a dialog. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols: - at table @code + at begin-primary-style-choices{By default\, the dialog does not +show the custom colors interface.} @item :allow-custom-colors This configures the dialog to enable the Define Custom Color button, which when clicked reveals additional controls for @@ -462,7 +463,7 @@ @item :display-solid-only This configures the dialog to only display solid colors in the set of basic colors. - at end table + at end-primary-style-choices @end deffn @end deftp @@ -484,7 +485,7 @@ @sc{nil} for the owner. @end deffn @deffn Initarg :style - at table @code + at begin-primary-style-choices{} @item :application-modal Specifies that the dialog is @emph{modal} with respect to all @ref{top-level} windows and @ref{dialog}s created by the application @@ -498,7 +499,7 @@ Specifies that the dialog is @emph{modal} only in relation to its @ref{owner} (which could be a window or another dialog). This style is the default if no style keywords are specified. - at end table + at end-primary-style-choices @end deffn @deffn Initarg :text Specifies the dialog's title. @@ -566,31 +567,32 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols: - at table @code + at begin-primary-style-choices{} + at item :open +This configures the dialog to be used to select one or more files +for loading data. + at item :save +This configures the dialog to be used to specify a destination file +for data to be saved. + at end-primary-style-choices + at begin-optional-style-choices @item :add-to-recent This enables the system to add a link to the selected file in the directory that contains the user's most recently used documents. @item :multiple-select This configures the dialog to accept multiple selections. - at item :open -This configures the dialog to be used to select one or more files -for loading data. @item :path-must-exist This keyword enables a validation check that constrains the user's selection to file paths that actually exist. A warning dialog will be displayed if the user supplies a non-existent path. - at item :save -This configures the dialog to be used to specify a destination file -for data to be saved. @item :show-hidden This keyword enables the dialog to display files marked @sc{hidden} by the system. @strong{Note:} files marked both @sc{hidden} and @sc{system} will not be displayed in any case. Also, be aware that using this keyword effectively overrides the user's preference settings. - at end table + at end-optional-style-choices @end deffn @deffn Initarg :text This initarg accepts a string that will become the title of the file @@ -636,8 +638,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols: - at table @code + at begin-primary-style-choices{} @item :all-fonts This is a convenience style, used by default if no other font criteria are specified, that enables the dialog to offer all @@ -659,7 +660,7 @@ Enables the dialog to offer the intersection of the sets of fonts available on the screen and the printer associated with the graphics-context specified by the @code{:gc} initarg. - at end table + at end-primary-style-choices @end deffn @end deftp @@ -728,8 +729,9 @@ @anchor{top-level} @deftp Class top-level Base class for @ref{window}s that are self-contained and parented to -the @ref{root-window}. Except for the @code{:palette} style, they are -normally resizable and have title bars (also called 'captions'). +the @ref{root-window}. Except when created with the @code{:borderless} +or @code{:palette} styles, they are resizable and have title bars +(also called @samp{captions}). @deffn Initarg :maximum-size Sets the maximum @ref{size} to which the user may adjust the boundaries of the window. @@ -739,10 +741,7 @@ boundaries of the window. @end deffn @deffn Initarg :style -The @code{:style} initarg is a list of keywords that define the overall -look-and-feel of the window being created. Applications may choose -from one of the following primary styles: - at table @code + at begin-primary-style-choices{} @item :borderless Specifies a window with a one-pixel border (so not really @emph{borderless} in the strictest sense); no frame icon, system menu, minimize/maximize @@ -764,13 +763,12 @@ and minimize/maximize buttons; this window type is resizable; it differs from the @code{:frame} style in that the system paints the background using the @sc{color_appworkspace} Win32 color scheme. - at end table -The following style keyword(s) may also be included: - at table @code + at end-primary-style-choices + at begin-optional-style-choices @item :keyboard-navigation Enables keyboard traversal of controls within the @code{window} as if it were a @ref{dialog}. - at end table + at end-optional-style-choices @end deffn @end deftp Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Mon Sep 11 23:04:31 2006 @@ -191,7 +191,7 @@ (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel :callback lb2-callback - :style '(:extend-select :want-scrollbar) + :style '(:extend-select :scrollbar-always) :items (subseq *list-box-test-data* 4))) (gfw:pack lb2-panel) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Mon Sep 11 23:04:31 2006 @@ -834,6 +834,22 @@ (defconstant +ps-geometric+ #x00010000) (defconstant +ps-type-mask+ #x000f0000) +(defconstant +sb-lineup+ 0) +(defconstant +sb-lineleft+ 0) +(defconstant +sb-linedown+ 1) +(defconstant +sb-lineright+ 1) +(defconstant +sb-pageup+ 2) +(defconstant +sb-pageleft+ 2) +(defconstant +sb-pagedown+ 3) +(defconstant +sb-pageright+ 3) +(defconstant +sb-thumbposition+ 4) +(defconstant +sb-thumbtrack+ 5) +(defconstant +sb-top+ 6) +(defconstant +sb-left+ 6) +(defconstant +sb-bottom+ 7) +(defconstant +sb-right+ 7) +(defconstant +sb-endscroll+ 8) + (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1) (defconstant +size-maximized+ 2) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Mon Sep 11 23:04:31 2006 @@ -174,10 +174,15 @@ (declare (ignorable dispatcher widget)))) (defgeneric event-resize (dispatcher widget size type) - (:documentation "Implement this to respond to an object being resized.") + (:documentation "Implement this to respond to widget being resized.") (:method (dispatcher widget size type) (declare (ignorable dispatcher widget size type)))) +(defgeneric event-scroll (dispatcher widget axis detail) + (:documentation "Implement this to respond to scrolling within widget.") + (:method (dispatcher widget axis detail) + (declare (ignorable dispatcher widget axis detail)))) + (defgeneric event-select (dispatcher item) (:documentation "Implement this to respond to an object (or item within) being selected.") (:method (dispatcher item) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Sep 11 23:04:31 2006 @@ -117,7 +117,7 @@ (cffi:pointer-address (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed"))) -(defun dispatch-notification (widget wparam-hi) +(defun dispatch-control-notification (widget wparam-hi) (let ((disp (dispatcher widget))) (case wparam-hi (0 (event-select disp widget)) @@ -143,6 +143,24 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) +(defun dispatch-scroll-notification (widget axis wparam-hi) + (let ((disp (dispatcher widget))) + (case wparam-hi + (#.gfs::+sb-top+ (event-scroll disp widget axis :start)) +; (#.gfs::+sb-left+ (event-scroll disp widget axis :start)) + (#.gfs::+sb-bottom+ (event-scroll disp widget axis :end)) +; (#.gfs::+sb-right+ (event-scroll disp widget axis :end)) + (#.gfs::+sb-lineup+ (event-scroll disp widget axis :step-back)) +; (#.gfs::+sb-lineleft+ (event-scroll disp widget axis :step-back)) + (#.gfs::+sb-linedown+ (event-scroll disp widget axis :step-forward)) +; (#.gfs::+sb-lineright+ (event-scroll disp widget axis :step-forward)) + (#.gfs::+sb-pageup+ (event-scroll disp widget axis :page-back)) +; (#.gfs::+sb-pageleft+ (event-scroll disp widget axis :page-back)) + (#.gfs::+sb-pagedown+ (event-scroll disp widget axis :page-forward)) +; (#.gfs::+sb-pageright+ (event-scroll disp widget axis :page-forward)) + (#.gfs::+sb-thumbposition+ (event-scroll disp widget axis :thumb-position)) + (#.gfs::+sb-thumbtrack+ (event-scroll disp widget axis :thumb-track))))) + (defun obtain-event-time () (gfs::get-message-time)) @@ -191,7 +209,7 @@ (event-select (dispatcher item) item)))) (let ((widget (get-widget tc (cffi:make-pointer lparam)))) (when (and widget (dispatcher widget)) - (dispatch-notification widget wparam-hi)))) + (dispatch-control-notification widget wparam-hi)))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) @@ -329,10 +347,23 @@ 1 0))) +(defmethod process-message (hwnd (msg (eql gfs::+wm-hscroll+)) wparam lparam) + (declare (ignore lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (dispatch-scroll-notification widget :horizontal (hi-word wparam)))) + 0) + +(defmethod process-message (hwnd (msg (eql gfs::+wm-vscroll+)) wparam lparam) + (declare (ignore lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (dispatch-scroll-notification widget :vertical (hi-word wparam)))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) (declare (ignore wparam lparam)) - (let* ((tc (thread-context)) - (widget (get-widget tc hwnd))) + (let ((widget (get-widget (thread-context) hwnd))) (if widget (let ((rct (gfs:make-rectangle))) (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Mon Sep 11 23:04:31 2006 @@ -189,16 +189,16 @@ do (ecase sym ;; primary list-box styles ;; - (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) - (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) - (:no-select (setf std-flags (lb-no-select-flags std-flags))) - (:single-select (setf std-flags (lb-single-select-flags std-flags))) + (:extend-select (setf std-flags (lb-extend-select-flags std-flags))) + (:multiple-select (setf std-flags (lb-multi-select-flags std-flags))) + (:no-select (setf std-flags (lb-no-select-flags std-flags))) + (:single-select (setf std-flags (lb-single-select-flags std-flags))) ;; styles that can be combined ;; - (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) - (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) - (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) + (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) + (:scrollbar-always (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))) + (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))))) (values std-flags 0))) (defmethod delete-all ((self list-box)) From junrue at common-lisp.net Tue Sep 12 05:35:13 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 12 Sep 2006 01:35:13 -0400 (EDT) Subject: [graphic-forms-cvs] r259 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060912053513.9226552001@common-lisp.net> Author: junrue Date: Tue Sep 12 01:35:09 2006 New Revision: 259 Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: added scroll event testing to event-tester Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Tue Sep 12 01:35:09 2006 @@ -157,6 +157,14 @@ @end table @end macro + at macro window-scrollbar-style{orientation,location} + at item :\orientation\-scrollbar +This style keyword configures a window to have a \orientation\ +scrollbar attached on the \location\. This style is a prerequisite +for scrolling functionality. The visibility policy for the scrollbar +can be configured via FIXME FIXME + at end macro + @c ==========================End Macros ============================= @copying Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Tue Sep 12 01:35:09 2006 @@ -702,6 +702,14 @@ This initarg is used to specify the @ref{parent} window of the panel. @end deffn + at deffn Initarg :style + at begin-primary-style-choices{} + at item :border +This style keyword causes the panel to maintain a thin border. + at window-scrollbar-style{horizontal,bottom} + at window-scrollbar-style{vertical,right} + at end-primary-style-choices + at end deffn @end deftp @anchor{root-window} @@ -728,10 +736,12 @@ @anchor{top-level} @deftp Class top-level -Base class for @ref{window}s that are self-contained and parented to +This class represents @ref{window}s that are self-contained and parented to the @ref{root-window}. Except when created with the @code{:borderless} or @code{:palette} styles, they are resizable and have title bars -(also called @samp{captions}). +(also called @samp{captions}). They may have scrollbars if either of the + at code{:horizontal-scrollbar} or @code{:vertical-scrollbar} styles are +specified, with further control over scrollbar visibility being possible. @deffn Initarg :maximum-size Sets the maximum @ref{size} to which the user may adjust the boundaries of the window. @@ -765,9 +775,11 @@ using the @sc{color_appworkspace} Win32 color scheme. @end-primary-style-choices @begin-optional-style-choices + at window-scrollbar-style{horizontal,bottom} @item :keyboard-navigation Enables keyboard traversal of controls within the @code{window} as if it were a @ref{dialog}. + at window-scrollbar-style{vertical,right} @end-optional-style-choices @end deffn @end deftp Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Sep 12 01:35:09 2006 @@ -416,6 +416,7 @@ #:event-pre-move #:event-pre-resize #:event-resize + #:event-scroll #:event-select #:event-session #:event-timer Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Sep 12 01:35:09 2006 @@ -59,6 +59,45 @@ (declare (ignore widget)) (exit-event-tester)) +(defun initialize-scrollbars () + ;; yucky test code to set scrollbar parameters -- this + ;; is not how applications will be expected to do it. + ;; + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::maxpos gfs::pagesize) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask (logior gfs::+sif-page+ gfs::+sif-range+ gfs::+sif-disablenoscroll+) + gfs::maxpos 500 + gfs::pagesize 50)) + (gfs::set-scroll-info (gfs:handle *event-tester-window*) gfs::+sb-horz+ info-ptr 0) + (gfs::set-scroll-info (gfs:handle *event-tester-window*) gfs::+sb-vert+ info-ptr 0))) + +(defun update-scrollbars (axis detail) + ;; yucky test code to set scrollbar parameters -- this + ;; is not how applications will be expected to do it. + ;; + (let ((which-sb (if (eql axis :vertical) gfs::+sb-vert+ gfs::+sb-horz+)) + (hwnd (gfs:handle *event-tester-window*))) + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pos gfs::pagesize + gfs::minpos gfs::maxpos gfs::trackpos) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask gfs::+sif-all+) + (gfs::get-scroll-info hwnd which-sb info-ptr) + (case detail + (:start (setf gfs::pos gfs::minpos)) + (:end (setf gfs::pos gfs::maxpos)) + (:step-back (setf gfs::pos (- gfs::pos 5))) + (:step-forward (setf gfs::pos (+ gfs::pos 5))) + (:page-back (setf gfs::pos (- gfs::pos gfs::pagesize))) + (:page-forward (setf gfs::pos (+ gfs::pos gfs::pagesize))) + (:thumb-track (setf gfs::pos gfs::trackpos))) + (gfs::set-scroll-info hwnd which-sb info-ptr 1))))) + (defun text-for-modifiers () (format nil "~:[SHIFT~;~] ~:[CTRL~;~] ~:[ALT~;~] ~:[L-WIN~;~] ~:[R-WIN~;~] ~:[ESC~;~] ~:[CAPSLOCK~;~] ~:[NUMLOCK~;~] ~:[SCROLLOCK~;~]" @@ -137,6 +176,15 @@ (gfw:obtain-event-time) (text-for-modifiers))) +(defun text-for-scroll (axis detail) + (format nil + "~a scroll: ~s detail: ~s time: 0x~x ~s" + (incf *event-counter*) + axis + detail + (gfw:obtain-event-time) + (text-for-modifiers))) + (defmethod gfw:event-activate ((d event-tester-window-events) window) (setf *event-tester-text* (text-for-activation "window activated")) (gfw:redraw window)) @@ -174,13 +222,16 @@ (defmethod gfw:event-move ((d event-tester-window-events) window pnt) (setf *event-tester-text* (text-for-move pnt)) - (gfw:redraw window) - 0) + (gfw:redraw window)) (defmethod gfw:event-resize ((d event-tester-window-events) window size type) (setf *event-tester-text* (text-for-size type size)) - (gfw:redraw window) - 0) + (gfw:redraw window)) + +(defmethod gfw:event-scroll ((d event-tester-window-events) window axis detail) + (update-scrollbars axis detail) + (setf *event-tester-text* (text-for-scroll axis detail)) + (gfw:redraw window)) (defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ()) @@ -240,7 +291,8 @@ (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) - :style '(:workspace))) + :style '(:workspace :horizontal-scrollbar :vertical-scrollbar))) + (initialize-scrollbars) (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu :submenu ((:item "Timer" :callback #'manage-timer) (:item "" :separator) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Sep 12 01:35:09 2006 @@ -834,6 +834,11 @@ (defconstant +ps-geometric+ #x00010000) (defconstant +ps-type-mask+ #x000f0000) +(defconstant +sb-horz+ 0) +(defconstant +sb-vert+ 1) +(defconstant +sb-ctl+ 2) +(defconstant +sb-both+ 3) + (defconstant +sb-lineup+ 0) (defconstant +sb-lineleft+ 0) (defconstant +sb-linedown+ 1) @@ -850,6 +855,13 @@ (defconstant +sb-right+ 7) (defconstant +sb-endscroll+ 8) +(defconstant +sif-range+ #x0001) +(defconstant +sif-page+ #x0002) +(defconstant +sif-pos+ #x0004) +(defconstant +sif-disablenoscroll+ #x0008) +(defconstant +sif-trackpos+ #x0010) +(defconstant +sif-all+ #x0017) + (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1) (defconstant +size-maximized+ 2) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Sep 12 01:35:09 2006 @@ -329,6 +329,15 @@ (rgbred BYTE) (rgbreserved BYTE)) +(defcstruct scrollinfo + (cbsize UINT) + (fmask UINT) + (minpos INT) + (maxpos INT) + (pagesize UINT) + (pos INT) + (trackpos INT)) + (defcstruct size (cx LONG) (cy LONG)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Sep 12 01:35:09 2006 @@ -436,6 +436,13 @@ (hwnd HANDLE)) (defcfun + ("GetScrollInfo" get-scroll-info) + BOOL + (hwnd HANDLE) + (bar INT) + (info LPTR)) + +(defcfun ("GetSubMenu" get-submenu) HANDLE (hwnd HANDLE) @@ -667,6 +674,14 @@ (item-info LPTR)) (defcfun + ("SetScrollInfo" set-scroll-info) + INT + (hwnd HANDLE) + (bar INT) + (info LPTR) + (redraw BOOL)) + +(defcfun ("SetTimer" set-timer) UINT (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Sep 12 01:35:09 2006 @@ -143,9 +143,9 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) -(defun dispatch-scroll-notification (widget axis wparam-hi) +(defun dispatch-scroll-notification (widget axis wparam-lo) (let ((disp (dispatcher widget))) - (case wparam-hi + (case wparam-lo (#.gfs::+sb-top+ (event-scroll disp widget axis :start)) ; (#.gfs::+sb-left+ (event-scroll disp widget axis :start)) (#.gfs::+sb-bottom+ (event-scroll disp widget axis :end)) @@ -351,14 +351,14 @@ (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (dispatch-scroll-notification widget :horizontal (hi-word wparam)))) + (dispatch-scroll-notification widget :horizontal (lo-word wparam)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-vscroll+)) wparam lparam) (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (dispatch-scroll-notification widget :vertical (hi-word wparam)))) + (dispatch-scroll-notification widget :vertical (lo-word wparam)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Tue Sep 12 01:35:09 2006 @@ -56,13 +56,16 @@ (defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags +default-child-style+)) - (mapc #'(lambda (sym) - (cond + (loop for sym in (style-of self) + do (ecase sym ;; styles that can be combined ;; - ((eq sym :border) - (setf std-flags (logior std-flags gfs::+ws-border+))))) - (style-of self)) + (:border + (setf std-flags (logior std-flags gfs::+ws-border+))) + (:horizontal-scrollbar + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:vertical-scrollbar + (setf std-flags (logior std-flags gfs::+ws-vscroll+))))) (values std-flags gfs::+ws-ex-controlparent+))) (defmethod initialize-instance :after ((self panel) &key parent &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Sep 12 01:35:09 2006 @@ -68,47 +68,28 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) &rest extra-data) +(defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) (ex-flags 0)) - (mapc #'(lambda (sym) - (cond - ;; styles that can be combined - ;; -#| - ((eq sym :hscroll) - (setf std-flags (logior std-flags gfs::+ws-hscroll+))) - ((eq sym :max) - (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :min) - (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :sysmenu) - (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :title) - (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :top) - (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) - ((eq sym :vscroll) - (setf std-flags (logior std-flags gfs::+ws-vscroll+))) -|# - - ;; pre-packaged combinations of window styles - ;; - ((eq sym :borderless) + (loop for sym in (style-of self) + do (ecase sym + ;; pre-packaged combinations of window styles + ;; + (:borderless (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-border+ gfs::+ws-popup+)) (setf ex-flags gfs::+ws-ex-topmost+)) - ((eq sym :palette) + (:palette (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popupwindow+ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-toolwindow+ gfs::+ws-ex-windowedge+))) - ((eq sym :miniframe) + (:miniframe (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popup+ @@ -117,22 +98,40 @@ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-appwindow+ gfs::+ws-ex-toolwindow+))) - ((or (eq sym :workspace) (eq sym :frame)) + (:frame + (setf std-flags (logior gfs::+ws-overlappedwindow+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+)) + (setf ex-flags 0)) + (:workspace (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) - (setf ex-flags 0)))) - (style-of win)) + (setf ex-flags 0)) + + ;; styles that can be combined + ;; +#| + (:max (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) + (:min (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) + (:sysmenu (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) + (:title (setf std-flags (logior std-flags gfs::+ws-caption+))) + (:top (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) +|# + (:horizontal-scrollbar + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:vertical-scrollbar + (setf std-flags (logior std-flags gfs::+ws-vscroll+))))) (values std-flags ex-flags))) -(defmethod gfs:dispose ((win top-level)) - (let ((m (menu-bar win))) +(defmethod gfs:dispose ((self top-level)) + (let ((m (menu-bar self))) (unless (null m) (visit-menu-tree m #'menu-cleanup-callback) (delete-widget (thread-context) (gfs:handle m)))) (call-next-method)) -(defmethod initialize-instance :after ((win top-level) &key owner text &allow-other-keys) +(defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) @@ -140,21 +139,21 @@ (setf text *default-window-title*)) (let ((classname *toplevel-noerasebkgnd-window-classname*) (register-func #'register-toplevel-noerasebkgnd-window-class)) - (when (find :workspace (style-of win)) + (when (find :workspace (style-of self)) (setf classname *toplevel-erasebkgnd-window-classname*) (setf register-func #'register-toplevel-erasebkgnd-window-class)) - (init-window win classname register-func owner text))) + (init-window self classname register-func owner text))) (defmethod (setf maximum-size) :after (max-size (self top-level)) (when (and max-size (minimum-size self)) (update-top-level-resizability self (gfs:equal-size-p (minimum-size self) max-size)))) -(defmethod menu-bar :before ((win top-level)) - (if (gfs:disposed-p win) +(defmethod menu-bar :before ((self top-level)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod menu-bar ((win top-level)) - (let ((hmenu (gfs::get-menu (gfs:handle win)))) +(defmethod menu-bar ((self top-level)) + (let ((hmenu (gfs::get-menu (gfs:handle self)))) (if (gfs:null-handle-p hmenu) (return-from menu-bar nil)) (let ((m (get-widget (thread-context) hmenu))) @@ -162,13 +161,13 @@ (error 'gfs:toolkit-error :detail "no object for menu handle")) m))) -(defmethod (setf menu-bar) :before ((m menu) (win top-level)) +(defmethod (setf menu-bar) :before ((m menu) (self top-level)) (declare (ignore m)) - (if (gfs:disposed-p win) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf menu-bar) ((m menu) (win top-level)) - (let* ((hwnd (gfs:handle win)) +(defmethod (setf menu-bar) ((m menu) (self top-level)) + (let* ((hwnd (gfs:handle self)) (hmenu (gfs::get-menu hwnd)) (old-menu (get-widget (thread-context) hmenu))) (unless (gfs:null-handle-p hmenu) From junrue at common-lisp.net Thu Sep 14 03:44:06 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 13 Sep 2006 23:44:06 -0400 (EDT) Subject: [graphic-forms-cvs] r260 - trunk/src/uitoolkit/widgets Message-ID: <20060914034406.4661348144@common-lisp.net> Author: junrue Date: Wed Sep 13 23:44:06 2006 New Revision: 260 Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: added some missing scrollbar-related methods to window Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Sep 13 23:44:06 2006 @@ -192,7 +192,7 @@ (defgeneric header-visible-p (self) (:documentation "Returns T if the object's header is visible; nil otherwise.")) -(defgeneric horizontal-scrollbar (self) +(defgeneric horizontal-scrollbar-p (self) (:documentation "Returns T if this object currently has a horizontal scrollbar; nil otherwise.")) (defgeneric iconify (self flag) @@ -432,7 +432,7 @@ (defgeneric update-native-style (self flags) (:documentation "Modifies self's native style flags and refreshes self's visual appearance.")) -(defgeneric vertical-scrollbar (self) +(defgeneric vertical-scrollbar-p (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise.")) (defgeneric visible-item-count (self) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed Sep 13 23:44:06 2006 @@ -206,9 +206,21 @@ (if flag (redraw self))) +(defmethod enable-scrollbars :before ((self widget) horizontal vertical) + (declare (ignore horizontal vertical)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod enabled-p ((self widget)) (/= (gfs::is-window-enabled (gfs:handle self)) 0)) +(defmethod horizontal-scrollbar-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod horizontal-scrollbar-p ((self widget)) + nil) + (defmethod image :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -430,6 +442,13 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) +(defmethod vertical-scrollbar-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod vertical-scrollbar-p ((self widget)) + nil) + (defmethod visible-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed Sep 13 23:44:06 2006 @@ -193,12 +193,22 @@ (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod event-resize ((d event-dispatcher) (self window) size type) +(defmethod event-resize ((disp event-dispatcher) (self window) size type) (declare (ignore size type)) (unless (null (layout-of self)) (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) +(defmethod enable-scrollbars ((self window) horizontal vertical) + (let ((bits (get-native-style self))) + (if horizontal + (setf bits (logior bits gfs::+ws-hscroll+)) + (setf bits (logand bits (lognot gfs::+ws-hscroll+)))) + (if vertical + (setf bits (logior bits gfs::+ws-vscroll+)) + (setf bits (logand bits (lognot gfs::+ws-vscroll+)))) + (update-native-style self bits))) + (defmethod focus-p :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -214,6 +224,9 @@ (defmethod give-focus ((self window)) (gfs::set-focus (gfs:handle self))) +(defmethod horizontal-scrollbar-p ((self top-level)) + (test-native-style self gfs::+ws-hscroll+)) + (defmethod image ((self window)) (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0)) (large (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-big+ 0)) @@ -334,6 +347,9 @@ gfs::+swp-nozorder+))) flags) +(defmethod vertical-scrollbar-p ((self top-level)) + (test-native-style self gfs::+ws-vscroll+)) + (defmethod window->display :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) From junrue at common-lisp.net Thu Sep 14 04:46:04 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 14 Sep 2006 00:46:04 -0400 (EDT) Subject: [graphic-forms-cvs] r261 - trunk/docs/website Message-ID: <20060914044604.9D6F363028@common-lisp.net> Author: junrue Date: Thu Sep 14 00:46:04 2006 New Revision: 261 Modified: trunk/docs/website/download.html trunk/docs/website/index.html Log: website tweak Modified: trunk/docs/website/download.html ============================================================================== --- trunk/docs/website/download.html (original) +++ trunk/docs/website/download.html Thu Sep 14 00:46:04 2006 @@ -2,7 +2,7 @@ - Graphic-Forms Source Control + Graphic-Forms Downloads @@ -10,7 +10,7 @@
-

Graphic-Forms downloads

+

Graphic-Forms Downloads

Graphic-Forms is distributed in source code form. Please choose from @@ -19,8 +19,7 @@