[graphic-forms-cvs] r15 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Feb 20 06:58:34 UTC 2006
Author: junrue
Date: Mon Feb 20 00:58:33 2006
New Revision: 15
Modified:
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/layouts.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
implemented widget visibility interaction with flow layout
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Feb 20 00:58:33 2006
@@ -52,6 +52,12 @@
(declare (ignore widget time))
(exit-layout-tester))
+(defclass pack-layout-dispatcher (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-select ((d pack-layout-dispatcher) item time rect)
+ (declare (ignorable item time rect))
+ (gfw:pack *layout-tester-win*))
+
(defclass layout-tester-widget-events (gfw:event-dispatcher)
((toggle-fn
:accessor toggle-fn
@@ -61,11 +67,11 @@
:initarg :id
:initform 0)))
-(defun add-layout-tester-widget (primary-type sub-type)
+(defun add-layout-tester-widget (widget-class subtype)
(let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*))
- (w (make-instance primary-type :dispatcher be)))
+ (w (make-instance widget-class :dispatcher be)))
(cond
- ((eql sub-type :push-button)
+ ((eql subtype :push-button)
(setf (toggle-fn be) (let ((flag nil))
#'(lambda ()
(if (null flag)
@@ -76,25 +82,88 @@
(setf flag nil)
(format nil "~d ~a" (id be) +btn-text-after+))))))
(incf *button-counter*)))
- (gfw:realize w *layout-tester-win* sub-type)
+ (gfw:realize w *layout-tester-win* subtype)
(setf (gfw:text w) (funcall (toggle-fn be)))))
(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect)
(declare (ignorable time rect))
(setf (gfw:text btn) (funcall (toggle-fn d)))
+ (gfw:layout *layout-tester-win*))
+
+(defclass add-child-dispatcher (gfw:event-dispatcher)
+ ((widget-class
+ :accessor widget-class
+ :initarg :widget-class
+ :initform 'gfw:button)
+ (subtype
+ :accessor subtype
+ :initarg :subtype
+ :initform :push-button)))
+
+(defmethod gfw:event-select ((d add-child-dispatcher) item time rect)
+ (declare (ignorable item time rect))
+ (add-layout-tester-widget (widget-class d) (subtype d))
(gfw:pack *layout-tester-win*))
-(defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ())
+(defclass child-menu-dispatcher (gfw:event-dispatcher)
+ ((item-disp-class
+ :accessor item-disp-class
+ :initarg :item-disp-class
+ :initform nil)))
-(defmethod gfw:event-activate ((d layout-tester-child-menu-dispatcher) menu time)
+(defmethod gfw:event-activate ((d child-menu-dispatcher) menu time)
(declare (ignore time))
(gfw:clear-all menu)
(gfw:with-children (*layout-tester-win* kids)
(loop for k in kids
do (let ((it (make-instance 'gfw:menu-item)))
(gfw:item-append menu it)
+ (unless (null (item-disp-class d))
+ (setf (gfw:dispatcher it) (make-instance (item-disp-class d))))
(setf (gfw:text it) (gfw:text k))))))
+(defclass remove-child-dispatcher (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-select ((d remove-child-dispatcher) item time rect)
+ (declare (ignorable time rect))
+ (let ((text (gfw:text item))
+ (victim nil))
+ (gfw:with-children (*layout-tester-win* kids)
+ (loop for k in kids
+ do (if (string= (gfw:text k) text)
+ (setf victim k))))
+ (unless (null victim)
+ (gfi:dispose victim)
+ (gfw:layout *layout-tester-win*))))
+
+(defclass hide-child-dispatcher (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-select ((d hide-child-dispatcher) item time rect)
+ (declare (ignorable time rect))
+ (let ((text (gfw:text item))
+ (victim nil))
+ (gfw:with-children (*layout-tester-win* kids)
+ (loop for k in kids
+ do (if (string= (gfw:text k) text)
+ (setf victim k))))
+ (unless (null victim)
+ (gfw:hide victim)
+ (gfw:layout *layout-tester-win*))))
+
+(defclass show-child-dispatcher (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-select ((d show-child-dispatcher) item time rect)
+ (declare (ignorable time rect))
+ (let ((text (gfw:text item))
+ (victim nil))
+ (gfw:with-children (*layout-tester-win* kids)
+ (loop for k in kids
+ do (if (string= (gfw:text k) text)
+ (setf victim k))))
+ (unless (null victim)
+ (gfw:show victim)
+ (gfw:pack *layout-tester-win*))))
+
(defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect)
@@ -103,21 +172,36 @@
(defun run-layout-tester-internal ()
(setf *button-counter* 0)
- (let* ((menubar nil)
- (fed (make-instance 'layout-tester-exit-dispatcher))
- (cmd (make-instance 'layout-tester-child-menu-dispatcher)))
+ (let ((menubar nil)
+ (exit-disp (make-instance 'layout-tester-exit-dispatcher))
+ (pack-disp (make-instance 'pack-layout-dispatcher))
+ (add-btn-disp (make-instance 'add-child-dispatcher))
+ (rem-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'remove-child-dispatcher))
+ (hide-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'hide-child-dispatcher))
+ (show-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'show-child-dispatcher)))
(setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)
:layout-manager (make-instance 'gfw:flow-layout)))
(gfw:realize *layout-tester-win* nil :style-workspace)
- (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 250 :height 150))
(setf menubar (gfw:defmenusystem `(((:menu "&File")
- (:menuitem "E&xit" :dispatcher ,fed))
- ((:menu "&Children" :dispatcher ,cmd)
- (:menuitem :separator)))))
+ (:menuitem "E&xit" :dispatcher ,exit-disp))
+ ((:menu "&Children")
+ (:menuitem :submenu ((:menu "Add")
+ (:menuitem "Button" :dispatcher ,add-btn-disp)))
+ (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp)
+ (:menuitem :separator)))
+ (:menuitem :submenu ((:menu "Hide" :dispatcher ,hide-menu-disp)
+ (:menuitem :separator)))
+ (:menuitem :submenu ((:menu "Show" :dispatcher ,show-menu-disp)
+ (:menuitem :separator))))
+ ((:menu "&Window")
+ (:menuitem "Pack" :dispatcher ,pack-disp)
+ (:menuitem :submenu ((:menu "Select Layout")
+ (:menuitem "Flow")))
+ (:menuitem :submenu ((:menu "Modify Layout")
+ (:menuitem :separator)))))))
(setf (gfw:menu-bar *layout-tester-win*) menubar)
- (add-layout-tester-widget 'gfw:button :push-button)
- (add-layout-tester-widget 'gfw:button :push-button)
- (add-layout-tester-widget 'gfw:button :push-button)
+ (dotimes (i 3)
+ (add-layout-tester-widget 'gfw:button :push-button))
(gfw:pack *layout-tester-win*)
(gfw:show *layout-tester-win*)))
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Mon Feb 20 00:58:33 2006
@@ -303,6 +303,11 @@
(erase BOOL))
(defcfun
+ ("IsWindowVisible" is-window-visible)
+ BOOL
+ (hwnd HANDLE))
+
+(defcfun
("LoadImageA" load-image)
HANDLE
(instance HANDLE)
Modified: trunk/src/uitoolkit/widgets/layouts.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layouts.lisp (original)
+++ trunk/src/uitoolkit/widgets/layouts.lisp Mon Feb 20 00:58:33 2006
@@ -77,42 +77,44 @@
(with-children (win kids)
(loop for k in kids
do (let ((kid-size (preferred-size k width-hint height-hint)))
- (if (not vert-orient)
- (progn
- (incf total (gfi:size-width kid-size))
- (if (< max (gfi:size-height kid-size))
- (setf max (gfi:size-height kid-size))))
- (progn
- (incf total (gfi:size-height kid-size))
- (if (< max (gfi:size-width kid-size))
- (setf max (gfi:size-width kid-size))))))))
+ (when (or (visible-p k) (not (visible-p win)))
+ (if (not vert-orient)
+ (progn
+ (incf total (gfi:size-width kid-size))
+ (if (< max (gfi:size-height kid-size))
+ (setf max (gfi:size-height kid-size))))
+ (progn
+ (incf total (gfi:size-height kid-size))
+ (if (< max (gfi:size-width kid-size))
+ (setf max (gfi:size-width kid-size)))))))))
(if vert-orient
(gfi:make-size :width max :height total)
(gfi:make-size :width total :height max))))
(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint)
- (let ((layout-style (gfw:style layout))
- (entries nil)
+ (let ((entries nil)
(last-coord 0)
- (last-dim 0))
+ (last-dim 0)
+ (vert-orient (find :vertical (gfw:style layout))))
(with-children (win kids)
(loop for k in kids
do (let ((kid-size (preferred-size k width-hint height-hint))
(pnt (gfi:make-point)))
- (if (not (find :vertical layout-style))
- (progn
- (setf (gfi:point-x pnt) (+ last-coord last-dim))
- (if (>= height-hint 0)
- (setf (gfi:size-height kid-size) height-hint))
- (setf last-coord (gfi:point-x pnt))
- (setf last-dim (gfi:size-width kid-size)))
- (progn
- (setf (gfi:point-y pnt) (+ last-coord last-dim))
- (if (>= width-hint 0)
- (setf (gfi:size-width kid-size) width-hint))
- (setf last-coord (gfi:point-y pnt))
- (setf last-dim (gfi:size-height kid-size))))
- (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries))))
+ (when (or (visible-p k) (not (visible-p win)))
+ (if (not vert-orient)
+ (progn
+ (setf (gfi:point-x pnt) (+ last-coord last-dim))
+ (if (>= height-hint 0)
+ (setf (gfi:size-height kid-size) height-hint))
+ (setf last-coord (gfi:point-x pnt))
+ (setf last-dim (gfi:size-width kid-size)))
+ (progn
+ (setf (gfi:point-y pnt) (+ last-coord last-dim))
+ (if (>= width-hint 0)
+ (setf (gfi:size-width kid-size) width-hint))
+ (setf last-coord (gfi:point-y pnt))
+ (setf last-dim (gfi:size-height kid-size))))
+ (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries)))))
(reverse entries)))
(defmethod initialize-instance :after ((layout flow-layout) &key style)
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Mon Feb 20 00:58:33 2006
@@ -77,6 +77,9 @@
(if (gfi:disposed-p w)
(error 'gfi:disposed-error)))
+(defmethod hide ((w widget))
+ (gfs::show-window (gfi:handle w) gfs::+sw-hide+))
+
(defmethod location ((w widget))
(cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
(cffi:with-foreign-slots ((gfs::cbsize
@@ -131,7 +134,17 @@
(if (gfi:disposed-p w)
(error 'gfi:disposed-error)))
+(defmethod show ((w widget))
+ (gfs::show-window (gfi:handle w) gfs::+sw-showna+))
+
(defmethod update ((w widget))
(let ((hwnd (gfi:handle w)))
(unless (gfi:null-handle-p hwnd)
(gfs::update-window hwnd))))
+
+(defmethod visible-p :before ((w widget))
+ (if (gfi:disposed-p w)
+ (error 'gfi:disposed-error)))
+
+(defmethod visible-p ((w widget))
+ (not (zerop (gfs::is-window-visible (gfi:handle w)))))
More information about the Graphic-forms-cvs
mailing list