Newer
Older
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved.
;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; applicable.
;;
;;;
;;; Copyright (c) 1989, 1990 by Xerox Corporation. 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"))
;;--- This seems dubious...
(defmethod allocate-space ((pane sheet) width height)
(defmethod note-space-requirements-changed ((composite composite-pane) child)
;; ??? 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)
(change-space-requirements
pane
: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)
;; 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
(defmethod note-space-requirement-changed (parent child)
(multiple-value-call #'allocate-space
parent (bounding-rectangle-size parent)))
(defmethod change-space-requirements :around ((pane layout-mixin)
&key resize-frame
&allow-other-keys)
(call-next-method)
(if *inside-changing-space-requirements*
(push (if resize-frame (pane-frame pane) (sheet-parent pane))
(cdr *inside-changing-space-requirements*))
(if resize-frame
(layout-frame (pane-frame pane))
(note-space-requirement-changed (sheet-parent pane) pane))))
(defun map-space-requirement (fn req)
(setf (space-requirement-width req) (funcall fn (space-requirement-width req))
(space-requirement-height req) (funcall fn (space-requirement-height req))
(space-requirement-max-width req) (funcall fn (space-requirement-max-width req))
(space-requirement-min-width req) (funcall fn (space-requirement-min-width req))
(space-requirement-max-height req) (funcall fn (space-requirement-max-height req))
(space-requirement-min-height req) (funcall fn (space-requirement-min-height req)))
(defun space-requirement+* (req &key (width 0)
(max-width width)
(min-width width)
(height 0)
(max-height height)
(min-height height))
(make-space-requirement :width (+ (space-requirement-width req) width)
:height (+ (space-requirement-height req) height)
:max-width (+ (space-requirement-max-width req) max-width)
:min-width (+ (space-requirement-min-width req) min-width)
:max-height (+ (space-requirement-max-height req) max-height)
:min-height (+ (space-requirement-min-height req) min-height)))
(defun space-requirement-combine (fn sr1 sr2)
(make-space-requirement :width (funcall fn (space-requirement-width sr1)
(space-requirement-width sr2))
:height (funcall fn (space-requirement-height sr1)
(space-requirement-height sr2))
:max-width (funcall fn (space-requirement-max-width sr1)
(defun space-requirement+ (sr1 sr2)
(space-requirement-combine #'+ sr1 sr2))
(defun %set-space-requirement (sr &key width height max-width
max-height min-width min-height &allow-other-keys)
(when width (setf (space-requirement-width sr) width))
(when max-width (setf (space-requirement-max-width sr) max-width))
(when min-width (setf (space-requirement-min-width sr) min-width))
(when height (setf (space-requirement-height sr) height))
(when max-height (setf (space-requirement-max-height sr) max-height))
(when min-height (setf (space-requirement-min-height sr) min-height))
sr)
;;;
;;;
;;;
;;;
;;; Space Req Mixin
;;;
(defmethod initialize-instance :after ((pane space-requirement-mixin)
&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))
(multiple-value-bind (width min-width max-width
height min-height max-height)
(apply #'default-space-requirements pane :allow-other-keys t args)
(make-space-requirement :width width
:height height
:max-width max-width
:min-width min-width
:max-height max-height
:min-height min-height)
(slot-value pane 'initial-space-requirement)
(make-space-requirement :width width
:height height
:max-width max-width
:min-width min-width
:max-height max-height
:min-height min-height))))
(defmethod change-space-requirements-to-default ((pane 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))
(defmethod compose-space ((pane space-requirement-mixin) &key width height)
(or (slot-value pane 'space-requirement)
(slot-value pane 'initial-space-requirement)))
(defmethod change-space-requirements ((pane space-requirement-mixin) &rest keys)
(with-slots (space-requirement) pane
(apply #'%set-space-requirement space-requirement keys)))
;;;
;;; Client Space-req Mixin (read Client Space-req)
;;;
(:documentation "User can specify a value for the client-space-requirement slot that defaults to NIL"))
;;--- BUG: what do we do if the value is NIL?
(defmethod change-space-requirements ((pane basic-client-space-requirement-mixin) &rest keys)
(with-slots (client-space-requirement) pane
(apply #'%set-space-requirement client-space-requirement keys)))
(defmethod initialize-instance :after ((pane basic-client-space-requirement-mixin)
&rest args
&key width max-width min-width
height max-height min-height)
(declare (dynamic-extent args))
(multiple-value-bind (width min-width max-width
height min-height max-height)
(apply #'default-space-requirements pane :allow-other-keys t args)
(make-space-requirement :width width :height height
:max-width max-width
:min-width min-width
:max-height max-height
:min-height min-height)))))
;;--- This duplicates the method on SPACE-REQUIREMENT-MIXIN. Can we share?
(defmethod default-space-requirements ((pane basic-client-space-requirement-mixin)
&key (width 0)
(min-width width)
(max-width width)
(height 0)
(min-height height)
(max-height height))
;;--- The only subclass of BASIC-CLIENT-SPACE-REQUIREMENT-MIXIN. Merge them?
(defclass client-space-requirement-mixin (basic-client-space-requirement-mixin)
(:documentation "If the user specifies some space requirements then use it otherwise use other value"))
(defmethod compose-space :around ((pane client-space-requirement-mixin) &key width height)
;;; Just like the above but used by panes that are using the client-specified
;;; space-requirement to determine how much free space is requested (spacer, filler).
;(defclass client-space-space-requirement-mixin (client-space-requirement-mixin)
; &key space)
; (if space
; (apply #'call-next-method pane :width space :height space rest)
; (call-next-method)))
; ((max-width :initform nil :initarg :max-width)
; (max-height :initform nil :initarg :max-height)))
;
;(defmethod compose-space :around ((pane client-stretchability-mixin) &key width height)
; (with-slots (max-width max-height) pane
; (let ((value (call-next-method)))
; (when max-width (setf (space-requirement-max-width value) max-width))
; (when max-height (setf (space-requirement-max-height value) max-height))
((width :initform nil :initarg :width)
(height :initform nil :initarg :height)
(max-width :initform nil :initarg :max-width)
(max-height :initform nil :initarg :max-height)
(min-width :initform nil :initarg :min-width)
(min-height :initform nil :initarg :min-height))
(:documentation "Client can specify values that override those provided elsewhere"))
(defmethod compose-space :around ((pane client-overridability-mixin) &key width height)
(declare (ignore width height))
(with-slots (width height max-width max-height min-width min-height) pane
(let ((value (call-next-method)))
value)))
;;;
;;; Client Demandability
;;;
;;; Used by db-scroll
;(defclass client-demandability-mixin (client-space-requirement-mixin
; space-requirement-cache-mixin)
;(defmethod compose-space ((pane client-demandability-mixin) &key width height)
; (if client-space-requirement
; (make-space-requirement :width (min (space-requirement-width client-space-req)
; (space-requirement-width child-req))
; :max-width (max (space-requirement-max-width client-space-req)
; (space-requirement-max-width child-req))
; :height (min (space-requirement-height client-space-req)
; (space-requirement-height child-req))
; :max-height (max (space-requirement-max-height client-space-req)
; (space-requirement-max-height child-req)))
(defclass space-requirement-cache-mixin (layout-mixin)
((space-requirement :initform nil)))
(defmethod compose-space :around ((pane space-requirement-cache-mixin) &key width height)
(defmethod clear-space-requirement-cache ((pane space-requirement-cache-mixin))
(with-slots (space-requirement) pane
(setf space-requirement 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))
()
(:documentation "Supports echoing allocations down and compositions up."))
(defmethod allocate-space ((pane wrapping-space-mixin) width height)
(resize-sheet* (sheet-child pane) width height))
(defmethod compose-space ((pane wrapping-space-mixin) &key width height)
;(defclass simple-transforming-wrapping-space-mixin (space-requirement-cache-mixin)
; ()
; (:documentation "Supports echoing allocations down and compositions up.~%~
; Transforming the echos for translations and reflection."))
;
;(defmethod allocate-space ((pane simple-transforming-wrapping-space-mixin)
; width height)
; (let ((child (sheet-child pane)))
; (multiple-value-bind (width height)
; (untransform-dimensions (sheet-transformation child) width height)
; (resize-sheet* child width height))))
;
;(defmethod compose-space ((pane simple-transforming-wrapping-space-mixin) &key width height)
; (let* ((child (sheet-child pane))
; (xform (sheet-transformation child))
; (req (compose-space child))
; (width (space-requirement-width req))
; (height (space-requirement-height req))
; (max-width (space-requirement-max-width req))
; (max-height (space-requirement-max-height req))
; (min-width (space-requirement-min-width req))
; (min-height (space-requirement-min-height req)))
;
; (multiple-value-setq (width height) (untransform-dimensions xform width height))
; (multiple-value-setq (max-width max-height) (untransform-dimensions xform max-width max-height))
; (multiple-value-setq (min-width min-height) (untransform-dimensions xform min-width min-height))
;
; (make-space-requirement :width width :max-width max-width :min-width min-width
; :height height :max-height max-height :min-height min-height)))
;;; Use this wrapping composite to not allow note-space-requirements-changed to propagate up.
(defmethod note-space-requirements-changed ((pane restrainer-pane) inner)
(allocate-space pane
(bounding-rectangle-width pane) (bounding-rectangle-height pane)))
;;; Generally useful layout function
;;; Used all over to satisfy constraints
;;--- along the way, calling FIX-COORDINATE on alloc helps a little but we
;;--- still end up with a gap along the bottom-right edges.
(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)))
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)))
(let (alloc)
(typecase item
((member :fill)
(if stretch-p
(progn
(setq alloc (/ (* +fill+ extra) give))
(setq alloc (ceiling alloc))
(fix-coordinates alloc)
(decf give +fill+))
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
(let* ((item-size (item-size item)))
(if (eq item-size :fill)
(if stretch-p
(progn
(setq alloc (/ (* +fill+ extra) give))
(setq alloc (ceiling alloc))
(fix-coordinates alloc)
(decf give +fill+))
(setq alloc 0))
(progn
(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)))))))
;; 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!
#---ignore
(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
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
(let ((item-size (item-size item)))
(if (eq item-size :fill)
(setq alloc :fill)
(progn
(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))
;;--- Does this need to be more complicated?
;;--- What is the correct behavior. Should it take a space requirement?
;;--- and just call ALLOCATE-SPACE?
(defclass bboard-pane (space-requirement-mixin layout-pane) ())
(defmethod allocate-space ((pane bboard-pane) width height)
(declare (ignore width height))
(dolist (child (sheet-children pane))
(let ((space-req (compose-space child)))
(resize-sheet* child
(space-requirement-width space-req)
(space-requirement-height space-req)))))