[graphic-forms-cvs] r3 - in trunk: . src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Feb 8 04:50:34 UTC 2006
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*))
More information about the Graphic-forms-cvs
mailing list