Re: Fix for Fred window zooming

[alice@digitool.com (Alice Hartley)]

At 2:22 PM 4/3/95, Mike Byrne wrote:
>I have more than one monitor, and Fred windows, when I click the zoom box,
>always zoom to the full size of the "main" monitor, which is not at all
>what I want (and which not at all follows Apple's prescribed behavior for
>window zooming).  Is there code somewhere out there which fixes the way
>Fred windows zoom?
>
>Thanks,
>-Mike
>
>=========================================================================


Here are some excerpts from post MCL 2.0 sources that should be a
start. I dont have 2 monitors so I'm not sure it will actually
work in 2.0. BEWARE OF WORD WRAP.

; -*- Mode: LISP; Package: CCL -*-

(in-package :CCL)
(defconstant $window-zoom-border 2 "Leave this much border around the
zoomed window.")

(defmethod window-title-height ((window window))
  20)

(defmethod view-preferred-size ((w window))
  #@(3000 3000))

(defun menubar-height ()
  (%get-word (%int-to-ptr #$MBarHeight)))

;; Find the screen that overlaps most of the window (or the main screen, if the
;; window doesn't overlap any screens), and return the bounds of the part
of that
;; screen that is usable.  This is the entire screen bounds, unless the screen
;; is the main screen, in which case the top portion is consumed by the menubar.
(defun window-preferred-screen-bounds (window &aux (mbar-height
(menubar-height)))
  (if *color-available*
    (rlet ((rect :rect :topLeft #@(0 0) :bottomRight (view-size window)))
      (#_OffsetRect :pointer rect :longint (view-position window))
      (let* ((main (#_GetMainDevice))
             (best -1)
             st sl sb sr)
        (flet ((set-to-device-bounds (devicePtr main-device-p)
                 (setf sl (pref devicePtr GDevice.gdRect.left)
                       st (+ (pref devicePtr GDevice.gdRect.top)
                             (if main-device-p mbar-height 0))
                       sr (pref devicePtr GDevice.gdRect.right)
                       sb (pref devicePtr GDevice.gdRect.bottom))))
          (do ((device (#_GetDeviceList) (#_GetNextDevice device)))
              ((%null-ptr-p device))
            (with-dereferenced-handles ((devicePtr device))
              (rlet ((intersection :rect))
                (#_SectRect rect (pref devicePtr GDevice.gdRect) intersection)
                (let ((area (* (- (pref intersection rect.bottom) (pref
intersection rect.top))
                               (- (pref intersection rect.right) (pref
intersection rect.left)))))
                  (when (> area best)
                    (setf best area)
                    (set-to-device-bounds devicePtr (eql device main)))))))
          (unless sl
            (with-dereferenced-handles ((devicePtr main))
              (set-to-device-bounds devicePtr t))))
        (values sl st sr sb)))
    (values 0 mbar-height *screen-width* *screen-height*)))


;; The window's new position.  If its origin remains on the same screen, and its
;; old position and new size allow it to fit entirely on that screen, leave it
;; where it is, otherwise move it.
(defmethod window-default-zoom-position ((window window))
  (multiple-value-bind (sl st sr sb) (window-preferred-screen-bounds window)
    (let* ((pos (view-position window))
           (current-h (point-h pos))
           (current-v (point-v pos))
           (size (window-default-zoom-size window))
           (new-width (point-h size))
           (new-height (point-v size))
           (moved-h (+ sl $window-zoom-border))
           (moved-v (+ st $window-zoom-border (window-title-height window))))
      ;; If origin of the window is still on the same screen...
      (if (and (<= sl current-h (1- sr))
               (<= st current-v (1- sb)))
        ;; ...then keep the same coordinates where they allow the window to
remain
        ;; wholly on the screen, and use the new ones where the old ones
don't...
        (make-point (if (< (+ current-h new-width $window-zoom-border) sr)
current-h moved-h)
                    (if (< (+ current-v new-height $window-zoom-border) sb)
current-v moved-v))
        ;; otherwise go ahead and move the window.
        (make-point moved-h moved-v)))))


;; The minimum of the window's preferred size and the usable window area
;; of the window's preferred screen.
(defmethod window-default-zoom-size ((window window))
  (multiple-value-bind (sl st sr sb) (window-preferred-screen-bounds window)
    (let* ((psize (view-preferred-size window))
           (ph (min (point-h psize) (- sr sl
                                       $window-zoom-border
$window-zoom-border)))
           (pv (min (point-v psize) (- sb st (window-title-height window)
                                       $window-zoom-border
$window-zoom-border))))
      (make-point ph pv))))


Alice@digitool.com