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
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;;;
;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved.
;;;
;; $fiHeader: db-layout.lisp,v 1.7 92/02/05 21:45:12 cer Exp $
(: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"))
;;;
;;; Default Methods for Layout Protocol
;;;
(defmethod allocate-space ((pane leaf-mixin) width height)
(declare (ignore width height)))
(warn "boug")
(defmethod allocate-space (pane width height)
(declare (ignore width height)))
(defmethod note-space-requirement-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-requirement ((pane layout-mixin) &key &allow-other-keys)
((pane layout-mixin) &key resize-frame &allow-other-keys)
(if resize-frame
(layout-frame (pane-frame pane))
(note-space-requirement-changed (sheet-parent pane) pane)))
(defmethod note-sheet-region-changed :after ((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 ((pane &key resize-frame) &body body)
`(progn
,@body {translate "change-space-req" to %set-space-req}
(if resize-frame
(layout-frame frame)
(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
;;;
((initial-space-requirement :reader pane-initial-space-requirement)
(space-requirement :reader pane-space-requirement)))
(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 default-space-requirements ((pane space-requirement-mixin)
&key (width 0)
(min-width width)
(max-width width)
(height 0)
(min-height height)
(max-height height))
(values width
min-width
max-width
height
min-height
max-height))
(defmethod compose-space ((pane space-requirement-mixin) &key width height)
(defmethod change-space-requirement ((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-requirement ((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)))))
(defclass client-space-requirement-mixin (basic-client-space-requirement-mixin)
()
(:documentation "If the user specifies some space requirements then
(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)))
;(defclass client-stretchability (layout-mixin)
; ((max-width :initform nil :initarg :max-width)
; (max-height :initform nil :initarg :max-height)))
;
;(defmethod compose-space :around ((pane client-stretchability) &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))
;;;
;;; Client Overridability
;;;
(defclass client-overridability (layout-mixin)
((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) &key width height)
(with-slots (width height max-width max-height min-width min-height) pane
(let ((value (call-next-method)))
(setq value (copy-space-requirement value)))
(when width (setf (space-requirement-width value) width))
(when height (setf (space-requirement-height value) height))
(when max-width (setf (space-requirement-max-width value) max-width))
(when max-height (setf (space-requirement-max-height value) max-height))
(when min-width (setf (space-requirement-min-width value) min-width))
(when min-height (setf (space-requirement-min-height value) min-height))
value)))
;;;
;;; Client Demandability
;;;
;;; Used by db-scroll
;(defclass client-demandability (client-space-requirement-mixin
; space-requirement-cache-mixin)
;(defmethod compose-space ((pane client-demandability) &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)
(with-slots (space-requirement) pane
(or space-requirement (setf space-requirement (call-next-method)))))
(defmethod clear-space-requirement-cache ((pane space-requirement-cache-mixin))
(with-slots (space-requirement) pane
(setf space-requirement nil)))
(defmethod note-space-requirement-changed :before
(composite (pane space-requirement-cache-mixin))
#'(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-requirement-changeds to propagate up.
simple-wrapper-mixin
wrapping-space-mixin
mute-input-mixin)
())
(allocate-space pane
(bounding-rectangle-width pane) (bounding-rectangle-height pane)))
;;; Generally useful layout function
;;; Used all over to satisfy constraints
(defun allocate-space-to-items (given wanted items min-size
desired-size max-size item-size)
(flet ((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)))
(dolist (item items)
(let* ((item-size (item-size item))
(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)
(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)
(decf give (- (desired-size item-size)
(min-size item-size)))))
;;; Most of the layout panes should inherit from this
(defclass layout-pane (mute-input-mixin
pane-background-mixin
composite-pane