From 4d2f43a9965f29cd7cfd99e1c44b043fde86cd6f Mon Sep 17 00:00:00 2001 From: Andreas Fuchs <asf@boinkor.net> Date: Wed, 16 Sep 2009 13:23:30 +0200 Subject: [PATCH] spr36199: Restrict window sizes to max available space on screen. * Adjust the graft size to compute the available screen height/width sans task bar. * Make sure that resize-frame works only on the window's client area (which is reduced by menu bars and window decorations). --- ChangeLog.n | 5 +++ aclpc/acl-mirror.lisp | 83 +++++++++++++++++++++++++++---------------- 2 files changed, 58 insertions(+), 30 deletions(-) diff --git a/ChangeLog.n b/ChangeLog.n index 773d2566..57deb2af 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -3,6 +3,11 @@ don't forget to change the version in utils/packages.lisp if you do anything user visible. ******************************************************************************* +2009-09-15 Andreas Fuchs <afuchs@franz.com> + + * aclpc/acl-mirror.lisp: Restrict window sizes to the maximum available client + rect size for each window. (spr36199). + 2009-09-10 Andreas Fuchs <afuchs@franz.com> * tk/font.lisp: Fix (obvious, in retrospect) printer error in warning about missing diff --git a/aclpc/acl-mirror.lisp b/aclpc/acl-mirror.lisp index d41798c7..f225ceb7 100644 --- a/aclpc/acl-mirror.lisp +++ b/aclpc/acl-mirror.lisp @@ -36,38 +36,61 @@ ;;--- This isn't really right, all ports only have kludges for this (defmethod sheet-shell (sheet) sheet) +(defun win-full-screen-area () + "Get the area of the screen that can be occupied by windows (screen - task/tool bars)." + (let ((rect (ct:ccallocate win:rect))) + (win:SystemParametersInfo win:SPI_GETWORKAREA 0 rect 0) + (values (coordinate (ct:cref win:rect rect win::left)) + (coordinate (ct:cref win:rect rect win::top)) + (coordinate (ct:cref win:rect rect win::right)) + (coordinate (ct:cref win:rect rect win::bottom))))) + (defmethod realize-graft ((port acl-port) graft) (let ((screen (slot-value (screen-device *acl-port*) 'device-handle1))) - (setf (port-screen port) screen) - (init-cursors) - (with-slots (silica::pixels-per-point - silica::pixel-width - silica::pixel-height - silica::mm-width - silica::mm-height - silica::units) graft - (with-dc (screen dc) - (let ((screen-width (win:GetSystemMetrics win:SM_CXSCREEN)) - (screen-height (win:GetSystemMetrics win:SM_CYSCREEN)) - (logpixelsx (win:GetDeviceCaps dc win:LOGPIXELSX)) - (logpixelsy (win:GetDeviceCaps dc win:LOGPIXELSY))) - (setf silica::pixel-width screen-width - silica::pixel-height screen-height - silica::mm-width (round (* screen-width 25.4s0) logpixelsx) - silica::mm-height (round (* screen-height 25.4s0) logpixelsy)) - (let* ((ppp (/ logpixelsy 72s0)) - (rounded-ppp (round ppp))) - (setf silica::pixels-per-point - (if (< (abs (- ppp rounded-ppp)) .1s0) rounded-ppp ppp))) - (setf (sheet-region graft) - (ecase silica::units - ((:device :pixel) - (make-bounding-rectangle - 0 0 - silica::pixel-width silica::pixel-height)))) - (setf (sheet-native-transformation graft) +identity-transformation+) - (setf (sheet-direct-mirror graft) screen) - (update-mirror-transformation port graft)))))) + (setf (port-screen port) screen) + (init-cursors) + (with-slots (silica::pixels-per-point + silica::pixel-width + silica::pixel-height + silica::mm-width + silica::mm-height + silica::units) graft + (with-dc (screen dc) + (multiple-value-bind (screen-left screen-top screen-right screen-bottom) + (win-full-screen-area) + (let ((screen-width (- screen-left screen-right)) + (screen-height (- screen-bottom screen-top)) + (logpixelsx (win:GetDeviceCaps dc win:LOGPIXELSX)) + (logpixelsy (win:GetDeviceCaps dc win:LOGPIXELSY))) + (setf silica::pixel-width (- screen-left screen-right) + silica::pixel-height (- screen-bottom screen-top) + silica::mm-width (round (* screen-width 25.4s0) logpixelsx) + silica::mm-height (round (* screen-height 25.4s0) logpixelsy)) + (let* ((ppp (/ logpixelsy 72s0)) + (rounded-ppp (round ppp))) + (setf silica::pixels-per-point + (if (< (abs (- ppp rounded-ppp)) .1s0) rounded-ppp ppp))) + + (setf (sheet-region graft) + (ecase silica::units + ((:device :pixel) + (make-bounding-rectangle + screen-left screen-top screen-right screen-bottom)))) + (format *trace-output* "~&height: ~A vs. real height: ~A~%" + screen-height (- screen-bottom screen-top)) + (setf (sheet-native-transformation graft) +identity-transformation+) + (setf (sheet-direct-mirror graft) screen) + (update-mirror-transformation port graft))))))) + +(defmethod resize-sheet :around ((sheet acl-top-level-sheet) width height) + "Restrict sheet sizes to the actual available client area." + (multiple-value-bind (-left -top dw dh) + (get-nonclient-deltas sheet) + (declare (ignore -left -top)) + (let* ((graft-br (sheet-region (graft sheet))) + (gw (bounding-rectangle-width graft-br)) + (gh (bounding-rectangle-height graft-br))) + (call-next-method sheet (min (- gw dw) width) (min (- gh dh) height))))) (defmethod modal-frame-p ((frame t)) nil) (defmethod modal-frame-p ((frame clim-internals::accept-values-own-window)) t) -- GitLab