[graphic-forms-cvs] r170 - in trunk: docs/manual src src/demos/unblocked src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Jul 3 03:54:06 UTC 2006
Author: junrue
Date: Sun Jul 2 23:54:05 2006
New Revision: 170
Modified:
trunk/docs/manual/api.texinfo
trunk/src/demos/unblocked/unblocked-window.lisp
trunk/src/packages.lisp
trunk/src/uitoolkit/system/datastructs.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
implemented resizable-p, refactored minimum-size/maximum-size methods for top-level windows
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Sun Jul 2 23:54:05 2006
@@ -1221,6 +1221,16 @@
@xref{capture-mouse}.
@end deffn
+ at anchor{resizable-p}
+ at deffn GenericFunction resizable-p self => boolean
+Returns T if @code{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
+decorations are modified appropriately.
+ 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/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jul 2 23:54:05 2006
@@ -201,9 +201,12 @@
:dispatcher (make-instance 'tiles-panel-events
:buffer-size tile-buffer-size)))
(setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked")
+
+ (setf (gfw:resizable-p *unblocked-win*) nil)
(let ((size (gfw:preferred-size *unblocked-win* -1 -1)))
(setf (gfw:minimum-size *unblocked-win*) size)
(setf (gfw:maximum-size *unblocked-win*) size))
+
(new-unblocked nil nil nil nil)
(gfw:show *unblocked-win* t)))
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Sun Jul 2 23:54:05 2006
@@ -65,6 +65,7 @@
#:detail
#:dispose
#:disposed-p
+ #:equal-size-p
#:flatten
#:handle
#:location
Modified: trunk/src/uitoolkit/system/datastructs.lisp
==============================================================================
--- trunk/src/uitoolkit/system/datastructs.lisp (original)
+++ trunk/src/uitoolkit/system/datastructs.lisp Sun Jul 2 23:54:05 2006
@@ -46,3 +46,7 @@
(defmacro size (rect)
`(rectangle-size ,rect))
+
+(defun equal-size-p (size1 size2)
+ (and (= (size-width size1) (size-width size2))
+ (= (size-height size1) (size-height size2))))
Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp (original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Jul 2 23:54:05 2006
@@ -51,6 +51,24 @@
gfs::+cs-dblclks+
-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))
+ (cond
+ (same-size-flag
+ (setf new-flags (logand orig-flags (lognot gfs::+ws-maximizebox+)))
+ (setf new-flags (logand new-flags (lognot gfs::+ws-thickframe+))))
+ (t
+ (setf new-flags (logior orig-flags gfs::+ws-maximizebox+))
+ (setf new-flags (logior new-flags gfs::+ws-thickframe+))))
+ (when (/= orig-flags new-flags)
+ (gfs::set-window-long hwnd gfs::+gwl-style+ new-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+)))))
+
;;;
;;; methods
;;;
@@ -132,6 +150,10 @@
(setf register-func #'register-toplevel-erasebkgnd-window-class))
(init-window win 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)
(error 'gfs:disposed-error)))
@@ -161,6 +183,10 @@
(gfs::set-menu hwnd (gfs:handle m))
(gfs::draw-menu-bar hwnd)))
+(defmethod (setf minimum-size) :after (min-size (self top-level))
+ (when (and (maximum-size self) min-size)
+ (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self)))))
+
(defmethod print-object ((self top-level) stream)
(print-unreadable-object (self stream :type t)
(format stream "handle: ~x " (gfs:handle self))
@@ -169,17 +195,26 @@
(format stream "min size: ~a " (minimum-size self))
(format stream "max size: ~a" (maximum-size self))))
-(defmethod text :before ((win top-level))
- (if (gfs:disposed-p win)
+(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+)))
+
+(defmethod (setf resizable-p) (flag (self top-level))
+ (let ((style (style-of self)))
+ (if (or (find :frame style) (find :workspace style))
+ (update-top-level-resizability self (not flag)))))
+
+(defmethod text :before ((self top-level))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod text ((win top-level))
- (get-widget-text win))
+(defmethod text ((self top-level))
+ (get-widget-text self))
-(defmethod (setf text) :before (str (win top-level))
+(defmethod (setf text) :before (str (self top-level))
(declare (ignore str))
- (if (gfs:disposed-p win)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod (setf text) (str (win top-level))
- (set-widget-text win str))
+(defmethod (setf text) (str (self top-level))
+ (set-widget-text self str))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Sun Jul 2 23:54:05 2006
@@ -246,39 +246,46 @@
(format stream "handle: ~x " (gfs:handle self))
(format stream "dispatcher: ~a " (dispatcher self))))
-(defmethod redraw :before ((w widget))
- (if (gfs:disposed-p w)
+(defmethod redraw :before ((self widget))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod redraw ((w widget))
- (let ((hwnd (gfs:handle w)))
+(defmethod redraw ((self widget))
+ (let ((hwnd (gfs:handle self)))
(unless (gfs:null-handle-p hwnd)
(gfs::invalidate-rect hwnd nil 1))))
-(defmethod selected-p :before ((w widget))
- (if (gfs:disposed-p w)
+(defmethod resizable-p :before ((self widget))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod selected-p ((w widget))
- (declare (ignore w))
+(defmethod resizable-p ((self widget))
nil)
-(defmethod size :before ((w widget))
- (if (gfs:disposed-p w)
+(defmethod selected-p :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod selected-p ((self widget))
+ (declare (ignore self))
+ nil)
+
+(defmethod size :before ((self widget))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod size ((w widget))
- (client-size w))
+(defmethod size ((self widget))
+ (client-size self))
-(defmethod (setf size) :before ((size gfs:size) (w widget))
+(defmethod (setf size) :before ((size gfs:size) (self widget))
(declare (ignore size))
- (if (gfs:disposed-p w)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod (setf size) ((size gfs:size) (w widget))
- (if (gfs:disposed-p w)
+(defmethod (setf size) ((size gfs:size) (self widget))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (if (zerop (gfs::set-window-pos (gfs:handle w)
+ (if (zerop (gfs::set-window-pos (gfs:handle self)
(cffi:null-pointer)
0 0
(gfs:size-width size)
@@ -287,13 +294,13 @@
(error 'gfs:win32-error :detail "set-window-pos failed"))
size)
-(defmethod show :before ((w widget) flag)
+(defmethod show :before ((self widget) flag)
(declare (ignore flag))
- (if (gfs:disposed-p w)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod show ((w widget) flag)
- (gfs::show-window (gfs:handle w) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)))
+(defmethod show ((self widget) flag)
+ (gfs::show-window (gfs:handle self) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)))
(defmethod text-baseline :before ((self widget))
(if (gfs:disposed-p self)
More information about the Graphic-forms-cvs
mailing list