Author: junrue Date: Tue Feb 7 22:50:33 2006 New Revision: 3 Added: trunk/src/tests/uitoolkit/layout-tester.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/system/system-conditions.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/menu.lisp Log: first implementation of menu activation and arming Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Tue Feb 7 22:50:33 2006 @@ -49,5 +49,6 @@ :components ((:module "uitoolkit" :components - ((:file "hello-world") - (:file "event-tester"))))))))) + ((:file "event-tester") + (:file "hello-world") + (:file "layout-tester"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Feb 7 22:50:33 2006 @@ -338,6 +338,7 @@ #:disable-layout #:disable-redraw #:disabled-image + #:dispatcher #:display-to-object #:echo-char #:enable Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Feb 7 22:50:33 2006 @@ -34,7 +34,7 @@ (in-package #:graphic-forms.uitoolkit.tests) (defparameter *event-tester-window* nil) -(defparameter *text* "Hello!") +(defparameter *event-tester-text* "Hello!") (defvar *event-counter* 0) (defvar *mouse-down-flag* nil) @@ -46,11 +46,13 @@ (defclass event-tester-window-events (gfuw:event-dispatcher) ()) -(defmethod gfuw:event-paint ((d event-tester-window-events) time (gc gfug:graphics-context) rect) - (declare (ignore time) (ignore rect)) +(defmethod gfuw:event-paint ((d event-tester-window-events) time gc rect) + (declare (ignorable time rect)) (setf (gfug:background-color gc) gfug:+color-white+) (setf (gfug:foreground-color gc) gfug:+color-blue+) - (gfug:draw-text gc *text* (gfid:make-point))) + (let* ((sz (gfuw:client-size *event-tester-window*)) + (pnt (gfid:make-point :x 0 :y (floor (/ (gfid:size-height sz) 2))))) + (gfug:draw-text gc *event-tester-text* pnt))) (defmethod gfuw:event-close ((d event-tester-window-events) time) (declare (ignore time)) @@ -90,10 +92,11 @@ time (text-for-modifiers))) -(defun text-for-menu (text time) +(defun text-for-item (text time desc) (format nil - "~a menu: ~s time: 0x~x ~s" + "~a ~s: ~s time: 0x~x ~s" (incf *event-counter*) + desc text time (text-for-modifiers))) @@ -118,39 +121,39 @@ (text-for-modifiers))) (defmethod gfuw:event-key-down ((d event-tester-window-events) time key-code char) - (setf *text* (text-for-key "down" time key-code char)) + (setf *event-tester-text* (text-for-key "down" time key-code char)) (gfuw:redraw *event-tester-window*)) (defmethod gfuw:event-key-up ((d event-tester-window-events) time key-code char) - (setf *text* (text-for-key "up" time key-code char)) + (setf *event-tester-text* (text-for-key "up" time key-code char)) (gfuw:redraw *event-tester-window*)) (defmethod gfuw:event-mouse-double ((d event-tester-window-events) time pnt button) - (setf *text* (text-for-mouse "double" time button pnt)) + (setf *event-tester-text* (text-for-mouse "double" time button pnt)) (gfuw:redraw *event-tester-window*)) (defmethod gfuw:event-mouse-down ((d event-tester-window-events) time pnt button) - (setf *text* (text-for-mouse "down" time button pnt)) + (setf *event-tester-text* (text-for-mouse "down" time button pnt)) (setf *mouse-down-flag* t) (gfuw:redraw *event-tester-window*)) (defmethod gfuw:event-mouse-move ((d event-tester-window-events) time pnt button) (when *mouse-down-flag* - (setf *text* (text-for-mouse "move" time button pnt)) + (setf *event-tester-text* (text-for-mouse "move" time button pnt)) (gfuw:redraw *event-tester-window*))) (defmethod gfuw:event-mouse-up ((d event-tester-window-events) time pnt button) - (setf *text* (text-for-mouse "up" time button pnt)) + (setf *event-tester-text* (text-for-mouse "up" time button pnt)) (setf *mouse-down-flag* nil) (gfuw:redraw *event-tester-window*)) (defmethod gfuw:event-move ((d event-tester-window-events) time pnt) - (setf *text* (text-for-move time pnt)) + (setf *event-tester-text* (text-for-move time pnt)) (gfuw:redraw *event-tester-window*) 0) (defmethod gfuw:event-resize ((d event-tester-window-events) time size type) - (setf *text* (text-for-size type time size)) + (setf *event-tester-text* (text-for-size type time size)) (gfuw:redraw *event-tester-window*) 0) @@ -160,32 +163,46 @@ (declare (ignorable time item rect)) (exit-event-tester)) -(defclass echo-menu-dispatcher (gfuw:event-dispatcher) ()) +(defmethod gfuw:event-arm ((d event-tester-exit-dispatcher) time item) + (declare (ignore rect)) + (setf *event-tester-text* (text-for-item (gfuw:text item) time "item armed")) + (gfuw:redraw *event-tester-window*)) + +(defclass event-tester-echo-dispatcher (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-select ((d event-tester-echo-dispatcher) time item rect) + (declare (ignore rect)) + (setf *event-tester-text* (text-for-item (gfuw:text item) time "item selected")) + (gfuw:redraw *event-tester-window*)) -(defmethod gfuw:event-select ((d echo-menu-dispatcher) time item rect) +(defmethod gfuw:event-arm ((d event-tester-echo-dispatcher) time item) (declare (ignore rect)) - (setf *text* (text-for-menu (gfuw:text item) time)) + (setf *event-tester-text* (text-for-item (gfuw:text item) time "item armed")) + (gfuw:redraw *event-tester-window*)) + +(defmethod gfuw:event-activate ((d event-tester-echo-dispatcher) time) + (setf *event-tester-text* (text-for-item "" time "menu activated")) (gfuw:redraw *event-tester-window*)) (defun run-event-tester-internal () - (setf *text* "Hello!") + (setf *event-tester-text* "Hello!") (setf *event-counter* 0) - (let ((echo-md (make-instance 'echo-menu-dispatcher)) + (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) (setf *event-tester-window* (make-instance 'gfuw:window :dispatcher (make-instance 'event-tester-window-events))) (gfuw:realize *event-tester-window* nil :style-workspace) - (setf menubar (gfuw:defmenusystem `(((:menu "&File") + (setf menubar (gfuw:defmenusystem `(((:menu "&File" :dispatcher ,echo-md) (:menuitem "&Open..." :dispatcher ,echo-md) (:menuitem "&Save..." :disabled :dispatcher ,echo-md) (:menuitem :separator) (:menuitem "E&xit" :dispatcher ,exit-md)) - ((:menu "&Options") + ((:menu "&Options" :dispatcher ,echo-md) (:menuitem "&Enabled" :checked :dispatcher ,echo-md) (:menuitem :submenu ((:menu "&Tools" :dispatcher ,echo-md) (:menuitem "&Fonts" :dispatcher ,echo-md :disabled) (:menuitem "&Colors" :dispatcher ,echo-md)))) - ((:menu "&Help") + ((:menu "&Help" :dispatcher ,echo-md) (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp"))))) (setf (gfuw:menu-bar *event-tester-window*) menubar) (gfuw:show *event-tester-window*) Added: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Feb 7 22:50:33 2006 @@ -0,0 +1,103 @@ +;;;; +;;;; layout-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) + +(defconstant +btn-text-1+ "Push Me") +(defconstant +btn-text-2+ "Again!") + +(defparameter *layout-win* nil) + +(defun exit-layout-tester () + (let ((w *layout-win*)) + (setf *layout-win* nil) + (gfis:dispose w)) + (gfuw:shutdown 0)) + +(defclass fill-events (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-close ((d fill-events) time) + (declare (ignore time)) + (exit-layout-tester)) + +(defclass fill-btn-events (gfuw:event-dispatcher) + ((button + :accessor button + :initarg :button + :initform nil) + (toggle-fn + :accessor toggle-fn + :initform nil))) + +(defmethod gfuw:event-select ((d fill-btn-events) time item rect) + (declare (ignorable time rect)) + (let ((btn (button d))) + (setf (gfuw:text btn) (funcall (toggle-fn d))))) + +(defclass fill-exit-dispatcher (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-select ((d fill-exit-dispatcher) time item rect) + (declare (ignorable time item rect)) + (exit-layout-tester)) + +(defun run-layout-tester-internal () + (let* ((menubar nil) + (md (make-instance 'fill-exit-dispatcher)) + (bd (make-instance 'fill-btn-events)) + (btn (make-instance 'gfuw:button :dispatcher bd))) + (setf (button bd) btn) + (setf (toggle-fn bd) (let ((flag nil)) + #'(lambda () + (if (null flag) + (progn + (setf flag t) + +btn-text-1+) + (progn + (setf flag nil) + +btn-text-2+))))) + (setf *layout-win* (make-instance 'gfuw:window :dispatcher (make-instance 'fill-events))) + (gfuw:realize *layout-win* nil :style-workspace) + (setf (gfuw:size *layout-win*) (gfid:make-size :width 200 :height 150)) + (setf menubar (gfuw:defmenusystem `(((:menu "&File") + (:menuitem "E&xit" :dispatcher ,md)) + ((:menu "&Children"))))) + (setf (gfuw:menu-bar *layout-win*) menubar) + (gfuw:realize btn *layout-win* :push-button) + (setf (gfuw:text btn) (funcall (toggle-fn bd))) + (setf (gfuw:location btn) (gfid:make-point)) + (setf (gfuw:size btn) (gfuw:preferred-size btn -1 -1)) + (gfuw:show *layout-win*) + (gfuw:run-default-message-loop))) + +(defun run-layout-tester () + (gfuw:startup "Layout Tester" #'run-layout-tester-internal)) Modified: trunk/src/uitoolkit/system/system-conditions.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-conditions.lisp (original) +++ trunk/src/uitoolkit/system/system-conditions.lisp Tue Feb 7 22:50:33 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; conditions.lisp +;;;; system-conditions.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Feb 7 22:50:33 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; constants.lisp +;;;; system-constants.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -545,6 +545,10 @@ (defconstant +wm-sysdeadchar+ #x0107) (defconstant +wm-keylast+ #x0109) ; for use with peek-message (defconstant +wm-command+ #x0111) +(defconstant +wm-initmenu+ #x0116) +(defconstant +wm-initmenupopup+ #x0117) +(defconstant +wm-menuselect+ #x011F) +(defconstant +wm-menuchar+ #x0120) (defconstant +wm-mousefirst+ #x0200) ; for use with peek-message (defconstant +wm-mousemove+ #x0200) (defconstant +wm-lbuttondown+ #x0201) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Feb 7 22:50:33 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; types.lisp +;;;; system-types.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Tue Feb 7 22:50:33 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; utils.lisp +;;;; system-utils.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Tue Feb 7 22:50:33 2006 @@ -38,10 +38,10 @@ (:method (dispatcher time) (declare (ignorable dispatcher time)))) -(defgeneric event-arm (dispatcher time) +(defgeneric event-arm (dispatcher time item) (:documentation "Implement this to respond to an object about to be selected.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher time item) + (declare (ignorable dispatcher time item)))) (defgeneric event-close (dispatcher time) (:documentation "Implement this to respond to an object being closed.") Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Feb 7 22:50:33 2006 @@ -131,7 +131,7 @@ (gfus::def-window-proc hwnd msg wparam lparam)) (defmethod process-message (hwnd (msg (eql gfus::+wm-close+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (if w (event-close (dispatcher w) *last-event-time*) @@ -166,8 +166,26 @@ (error 'gfus:toolkit-error :detail "no object for hwnd"))) 0) +(defmethod process-message (hwnd (msg (eql gfus::+wm-initmenupopup+)) wparam lparam) + (declare (ignorable hwnd lparam)) + (let ((menu (get-widget (cffi:make-pointer wparam)))) + (unless (null menu) + (let ((d (dispatcher menu))) + (unless (null d) + (event-activate d *last-event-time*))))) + 0) + +(defmethod process-message (hwnd (msg (eql gfus::+wm-menuselect+)) wparam lparam) + (declare (ignorable hwnd lparam)) ; FIXME: handle system menus + (let ((item (get-menuitem (lo-word wparam)))) + (unless (null item) + (let ((d (dispatcher item))) + (unless (null d) + (event-arm d *last-event-time* item))))) + 0) + (defmethod process-message (hwnd (msg (eql gfus::+wm-create+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (get-widget hwnd) ; has side-effect of setting handle slot 0) @@ -240,7 +258,7 @@ (process-mouse-message #'event-mouse-move hwnd lparam btn-sym))) (defmethod process-message (hwnd (msg (eql gfus::+wm-move+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (when w (outer-location w *move-event-pnt*) @@ -248,14 +266,14 @@ 0) (defmethod process-message (hwnd (msg (eql gfus::+wm-moving+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (if (and w (event-pre-move (dispatcher w) *last-event-time*)) 1 0))) (defmethod process-message (hwnd (msg (eql gfus::+wm-paint+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd)) (gc (make-instance 'gfug:graphics-context))) (if w @@ -303,7 +321,7 @@ 0) (defmethod process-message (hwnd (msg (eql gfus::+wm-sizing+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (if (and w (event-pre-resize (dispatcher w) *last-event-time*)) 1 Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Tue Feb 7 22:50:33 2006 @@ -398,7 +398,7 @@ (insert-separator (gfis:handle parent)))) (defmethod define-menu ((gen menu-generator) label dispatcher) - (let* ((m (make-instance 'menu :handle (gfus::create-popup-menu))) + (let* ((m (make-instance 'menu :handle (gfus::create-popup-menu) :dispatcher dispatcher)) (parent (first (menu-stack gen))) (it (make-instance 'menu-item :handle (gfis:handle m) :dispatcher dispatcher)) (id *next-menuitem-id*))