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
+@anchor{resizable-p} +@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. +@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)