Newer
Older
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
;; $fiHeader: db-layout.lisp,v 1.34 1993/06/04 20:46:27 cer Exp $
"Copyright (c) 1991, 1992 Franz, Inc. All rights reserved.
Portions copyright (c) 1992 Symbolics, Inc. All rights reserved.
Portions copyright (c) 1989, 1990 Xerox Corp. All rights reserved."
(:documentation "<Pane> should calculate how much space it wants."))
(:documentation "<Pane> should allocate given space amongst itself and children"))
(:documentation "Tells the composite that the child's shape has changed"))
(defmethod note-space-requirements-changed ((composite composite-pane) child)
(note-space-requirements-changed (sheet-parent composite)
composite))
(defmethod note-space-requirements-changed ((composite top-level-sheet) child)
(declare (ignore child))
(layout-frame (pane-frame composite)))
;; ??? Why is this method necessary -- RR
;; I'm sure it is, I just don't like the looks of it, which probably means
;; that there's a deeper problem somewhere.
(declare (ignore child)))
;;;
;;; Layout Mixin
;;;
(defmethod change-space-requirements ((pane layout-mixin) &key &allow-other-keys)
(defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port-did-it)
(note-layout-mixin-region-changed pane :port port-did-it))
(defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port)
(declare (ignore port))
(multiple-value-bind (width height) (bounding-rectangle-size pane)
(allocate-space pane width height)))
(defmacro changing-space-requirements ((&rest options &key resize-frame layout)
&body body)
(declare (ignore resize-frame layout))
`(flet ((changing-space-requirements-body () ,@body))
(declare (dynamic-extent #'changing-space-requirements-body))
(invoke-with-changing-space-requirements
(defmethod change-space-requirements-to ((pane layout-mixin) space-requirement)
(multiple-value-bind (width min-width max-width
height min-height max-height)
:width width :min-width min-width :max-width max-width
:height height :min-height min-height :max-height max-height)))
(defmethod change-space-requirements-to-default ((pane layout-mixin))
nil)
(defun invoke-with-changing-space-requirements (continuation &key resize-frame (layout t))
;; Layout that frames that need to be laid out and
;; re-layout the minimal subtrees that need to be laid out
(remove-if-not
#'(lambda (x) (application-frame-p x))
*inside-changing-space-requirements*)))
(panes (remove-if #'(lambda (x)
(or (not (panep x))
(member (pane-frame x) frames)))
*inside-changing-space-requirements*)))
(mapc #'layout-frame frames)
(dolist (pane panes)
(unless (some #'(lambda (p)
(and (not (eq p pane))
(sheet-ancestor-p pane p)))
panes)
;; do this because the change has occurred somewhere in
;; the tree
(clear-space-requirement-caches-in-tree pane)
(multiple-value-call #'allocate-space
(let ((frame (pane-frame pane)))
(if *inside-changing-space-requirements*
(push (if (and frame resize-frame) frame (sheet-parent pane))
(cdr *inside-changing-space-requirements*))
(if (and frame resize-frame)
(layout-frame frame)
(defun space-requirement-combine (function sr1 sr2)
(multiple-value-bind (width1 min-width1 max-width1 height1 min-height1 max-height1)
(space-requirement-components sr1)
(multiple-value-bind (width2 min-width2 max-width2 height2 min-height2 max-height2)
(space-requirement-components sr2)
(make-space-requirement
:width (funcall function width1 width2)
:min-width (funcall function min-width1 min-width2)
:max-width (funcall function max-width1 max-width2)
:height (funcall function height1 height2)
:min-height (funcall function min-height1 min-height2)
:max-height (funcall function max-height1 max-height2)))))
;; Add two space requirements
(defun-inline space-requirement+ (sr1 sr2)
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
;; The "spread" version of the above...
(defun space-requirement+* (sr &key (width 0) (max-width width) (min-width width)
(height 0) (max-height height) (min-height height))
(multiple-value-bind (srwidth srmin-width srmax-width
srheight srmin-height srmax-height)
(space-requirement-components sr)
(make-space-requirement
:width (+ srwidth width)
:min-width (+ srmin-width min-width)
:max-width (+ srmax-width max-width)
:height (+ srheight height)
:min-height (+ srmin-height min-height)
:max-height (+ srmax-height max-height))))
(define-compiler-macro space-requirement+ (&whole form sr1 sr2)
(cond ((and (listp sr1)
(eq (first sr1) 'make-space-requirement))
(destructuring-bind (f &key (width 0) (max-width width) (min-width width)
(height 0) (max-height height) (min-height height))
sr1
(declare (ignore f))
`(space-requirement+* ,sr2
:width ,width :max-width ,max-width :min-width ,min-width
:height ,height :max-height ,max-height :min-height ,min-height)))
((and (listp sr2)
(eq (first sr2) 'make-space-requirement))
(destructuring-bind (f &key (width 0) (max-width width) (min-width width)
(height 0) (max-height height) (min-height height))
sr2
(declare (ignore f))
`(space-requirement+* ,sr1
:width ,width :max-width ,max-width :min-width ,min-width
:height ,height :max-height ,max-height :min-height ,min-height)))
(t form)))
&rest args
&key width max-width min-width
height max-height min-height)
(declare (dynamic-extent args))
(declare (ignore width min-width max-width
height min-height max-height))
(with-slots (space-requirement initial-space-requirement) pane
(multiple-value-bind (width min-width max-width
height min-height max-height)
(apply #'default-space-requirements pane :allow-other-keys t args)
(let ((sr (make-space-requirement
:width width :min-width min-width :max-width max-width
:height height :min-height min-height :max-height max-height)))
;; Space requirements are immutable...
(setf space-requirement sr
initial-space-requirement sr)))))
(defmethod change-space-requirements-to-default ((pane basic-space-requirement-mixin))
(when (pane-initial-space-requirements pane)
(change-space-requirements-to pane (pane-initial-space-requirements pane))))
&key (width 0)
(min-width width)
(max-width width)
(height 0)
(min-height height)
(max-height height))
&key width min-width max-width
height min-height max-height
resize-frame)
(declare (ignore resize-frame))
(multiple-value-bind (srwidth srmin-width srmax-width
srheight srmin-height srmax-height)
(space-requirement-components space-requirement)
(setq space-requirement (make-space-requirement
:width (or width srwidth)
:min-width (or min-width srmin-width)
:max-width (or max-width srmax-width)
:height (or height srheight)
:min-height (or min-height srmin-height)
:max-height (or max-height srmax-height))))))
(or (slot-value pane 'space-requirement)
(slot-value pane 'initial-space-requirement)))
(defclass client-overridability-mixin (basic-space-requirement-mixin)
())
(defmethod default-space-requirements ((pane client-overridability-mixin)
&key width min-width max-width height min-height max-height)
(values width min-width max-width
height min-height max-height))
(defmethod normalize-space-requirement ((pane client-overridability-mixin) sr)
sr)
(defmethod compose-space :around ((pane client-overridability-mixin) &key width height)
(declare (ignore width height))
(multiple-value-bind (width1 min-width1 max-width1 height1 min-height1 max-height1)
(space-requirement-components (normalize-space-requirement pane space-requirement))
(multiple-value-bind (width2 min-width2 max-width2 height2 min-height2 max-height2)
(space-requirement-components (call-next-method))
(flet ((mmin (x y z)
(or x (and y z (min y z)) y z))
(mmax (x y z)
(or x (and y z (max y z)) y z)))
(let ((height (or height1 height2))
(width (or width1 width2)))
(make-space-requirement
:width width
:min-width (or (mmin min-width1 width1 min-width2) width)
:max-width (or (mmax max-width1 width1 max-width2) width)
:height height
:min-height (or (mmin min-height1 height1 min-height2) height)
:max-height (or (mmax max-height1 height1 max-height2) height))))))))
(defmethod compose-space :around ((pane space-requirement-cache-mixin) &key width height)
(with-slots (space-requirement-cache) pane
(or space-requirement-cache
(setf space-requirement-cache (call-next-method)))))
(defmethod clear-space-requirement-cache ((pane space-requirement-cache-mixin))
(with-slots (space-requirement-cache) pane
(setf space-requirement-cache nil)))
(defmethod change-space-requirements :before ((pane space-requirement-cache-mixin) &key)
(clear-space-requirement-cache pane))
(map-over-sheets #'(lambda (sheet)
(clear-space-requirement-cache sheet))
sheet))
(do ((parent (sheet-parent menu) (sheet-parent parent)))
((null parent))
(defmethod compose-space ((pane wrapping-space-mixin) &key width height)
;; This new supa dupa version saves up all the fills to the end and
;; then divides up any leftover space equally amongst them and it
;; seems to work!
(defun allocate-space-to-items (given wanted items min-size
desired-size max-size item-size)
(macrolet ((desired-size (x) `(funcall desired-size ,x))
(min-size (x) `(funcall min-size ,x))
(max-size (x) `(funcall max-size ,x))
(item-size (x) `(funcall item-size ,x)))
(let ((stretch-p (>= given (desired-size wanted)))
(allocated 0)
extra give used sizes)
(if stretch-p
(setq give (- (max-size wanted) (desired-size wanted))
extra (min (- given (desired-size wanted)) give))
(setq give (- (desired-size wanted) (min-size wanted))
extra (min (- (desired-size wanted) given) give)))
(dolist (item items)
(let (alloc)
(typecase item
((member :fill)
(setq alloc :fill))
(t
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
(cond ((eq item-size :fill)
(setq alloc :fill))
((numberp item-size)
(setq alloc (fix-coordinate (* item-size given))))
(t
(setq alloc (desired-size item-size))
(when (> give 0)
(if stretch-p
(progn
(setq used (/ (* (- (max-size item-size)
(desired-size item-size))
extra)
give))
(incf alloc used)
(fix-coordinates alloc)
(decf give (- (max-size item-size)
(desired-size item-size))))
(progn
(setq used (/ (* (- (desired-size item-size)
(min-size item-size))
extra)
give))
(decf alloc used)
(fix-coordinates alloc)
(decf give (- (desired-size item-size)
(min-size item-size)))))
(decf extra used)))))))
(let ((fills (count :fill sizes))
(leftover (- given allocated)))
(when (> fills 0)
(let ((x (if (> leftover 0)
(fix-coordinate (/ leftover fills))
;;--- It would be nice if this and COMPOSITE-PANE had single- and multiple-child
;;--- versions so that users could get better error diagnostics
sheet-with-resources-mixin