Skip to content
Snippets Groups Projects
db-layout.lisp 22.9 KiB
Newer Older
cer's avatar
cer committed
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-

cer's avatar
cer committed
;; 
;; 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. 
;;;
cer's avatar
cer committed
;; $fiHeader: db-layout.lisp,v 1.14 92/04/28 09:25:14 cer Exp Locker: cer $
cer's avatar
cer committed

(in-package :silica)

cer's avatar
cer committed

cer's avatar
cer committed
;;;
;;; Layout Protocol
;;;

cer's avatar
cer committed
(defgeneric compose-space (pane &key width height)
cer's avatar
cer committed
  (:documentation "<Pane> should calculate how much space it wants."))
cer's avatar
cer committed

(defgeneric allocate-space (pane width height)
cer's avatar
cer committed
  (:documentation "<Pane> should allocate given space amongst itself and children"))
cer's avatar
cer committed

cer's avatar
cer committed
(defgeneric note-space-requirement-changed (composite child)
cer's avatar
cer committed
  (:documentation "Tells the composite that the child's shape has changed"))
cer's avatar
cer committed

;;;
;;; Default Methods for Layout Protocol
;;;

(defmethod allocate-space ((pane leaf-mixin) width height)
  (declare (ignore width height)))

cer's avatar
cer committed
(warn "boug")

(defmethod allocate-space (pane width height)
  (declare (ignore width height)))

cer's avatar
cer committed
(defmethod note-space-requirement-changed ((composite composite-pane) child)
cer's avatar
cer committed
  (declare (ignore child))
cer's avatar
cer committed
  (note-space-requirement-changed (sheet-parent composite) composite))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod note-space-requirement-changed ((composite null) child)
cer's avatar
cer committed
  ;; ??? 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
;;;

cer's avatar
cer committed
(defclass layout-mixin () ())
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod change-space-requirement ((pane layout-mixin) &key &allow-other-keys)
cer's avatar
cer committed
  nil)

cer's avatar
cer committed

;;#|

(defmacro changing-space-requirements ((&rest options &key resize-frame) &body body)
  `(flet ((changing-space-requirements-body ()
	    ,@body))
     (declare (dynamic-extent #'changing-space-requirements-body))
     (invoke-with-changing-space-requirements 
      #'changing-space-requirements-body 
      ,@options)))

(defvar *inside-changing-space-requirements* nil)

(defun invoke-with-changing-space-requirements (continuation &key resize-frame)
  (let ((old-inside-changing-space-requirements 
	 *inside-changing-space-requirements*)
	(*inside-changing-space-requirements* 
	 (cons nil *inside-changing-space-requirements*)))
    (multiple-value-prog1
	(funcall continuation)
      (unless old-inside-changing-space-requirements
	;; Layout that frames that need to be laid out
	;; and relayout the minimal subtrees that need to be laid out
	(let* ((frames (remove-duplicates
			(remove-if-not 
			#'(lambda (x) (typep x 'application-frame))
			*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 
		pane (bounding-rectangle-size pane)))))))))

(defmethod note-space-requirement-changed (parent child)
  (multiple-value-call #'allocate-space 
    parent (bounding-rectangle-size parent)))

(defmethod change-space-requirement :before ((pane space-requirement-cache-mixin) &key)
  (clear-space-requirement-cache pane))

(defmethod change-space-requirement :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))))

;;|#



#+ignore
(defmethod change-space-requirement :after ((pane layout-mixin) &key resize-frame &allow-other-keys)
cer's avatar
cer committed
  (if resize-frame
cer's avatar
cer committed
      (layout-frame (pane-frame pane))
      (note-space-requirement-changed (sheet-parent pane) pane)))
cer's avatar
cer committed

cer's avatar
cer committed
#+ignore
cer's avatar
cer committed
(defmethod note-space-requirement-changed (parent child)
cer's avatar
cer committed
  nil)
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port-did-it)
cer's avatar
cer committed
  (note-layout-mixin-region-changed pane :port port-did-it))

(defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port)  
cer's avatar
cer committed
  (declare (ignore port))
  (multiple-value-bind (width height) (bounding-rectangle-size pane)
    (allocate-space pane width height)))

cer's avatar
cer committed
(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)))
cer's avatar
cer committed
  req)

cer's avatar
cer committed
(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)
cer's avatar
cer committed
						 (space-requirement-max-width sr2))
cer's avatar
cer committed
			  :min-width (funcall fn (space-requirement-min-width sr1)
cer's avatar
cer committed
						 (space-requirement-min-width sr2))
cer's avatar
cer committed
			  :max-height (funcall fn (space-requirement-max-height sr1)
cer's avatar
cer committed
						  (space-requirement-max-height sr2))
cer's avatar
cer committed
			  :min-height (funcall fn (space-requirement-min-height sr1)
cer's avatar
cer committed
						  (space-requirement-min-height sr2))))
cer's avatar
cer committed

(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))
cer's avatar
cer committed
  sr)


;;;
;;;
;;;


;;;
;;; Space Req Mixin
;;; 

cer's avatar
cer committed
(defclass space-requirement-mixin (layout-mixin)
cer's avatar
cer committed
    ((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))
cer's avatar
cer committed
  (declare (ignore width min-width max-width
		   height min-height max-height))
cer's avatar
cer committed
  (multiple-value-bind (width min-width max-width
			height min-height max-height)
      (apply #'default-space-requirements pane :allow-other-keys t args)
cer's avatar
cer committed
    (setf (slot-value pane 'space-requirement)
cer's avatar
cer committed
	  (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))))
cer's avatar
cer committed

(defmethod default-space-requirements ((pane space-requirement-mixin) 
cer's avatar
cer committed
				       &key (width 0)
					    (min-width width)
					    (max-width width)
					    (height 0)
					    (min-height height)
					    (max-height height))
cer's avatar
cer committed
  (values width
	  min-width
	  max-width
	  height
	  min-height
	  max-height))
	  
	  
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod compose-space ((pane space-requirement-mixin) &key width height)
cer's avatar
cer committed
  (or (slot-value pane 'space-requirement)
      (slot-value pane 'initial-space-requirement)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod change-space-requirement ((pane space-requirement-mixin) &rest keys)
cer's avatar
cer committed
  (declare (dynamic-extent keys))
cer's avatar
cer committed
  (with-slots (space-requirement) pane
    (apply #'%set-space-requirement space-requirement keys)))
cer's avatar
cer committed



;;;
;;;  Client Space-req Mixin (read Client Space-req)
;;;

cer's avatar
cer committed
(defclass basic-client-space-requirement-mixin (layout-mixin)
cer's avatar
cer committed
    ((client-space-requirement :initform nil))
cer's avatar
cer committed
  (:documentation "User can specify a value for the client-space-requirement
cer's avatar
cer committed
slot that defaults to NIL"))

;;; BUG: what do we do if the value is NIL!

cer's avatar
cer committed
(defmethod change-space-requirement ((pane basic-client-space-requirement-mixin) &rest keys)
cer's avatar
cer committed
  (declare (dynamic-extent keys))
cer's avatar
cer committed
  (with-slots (client-space-requirement) pane
    (apply #'%set-space-requirement client-space-requirement keys)))
cer's avatar
cer committed

cer's avatar
cer committed
(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))
cer's avatar
cer committed
  (when (or width max-width min-width height max-height min-height)
cer's avatar
cer committed
    (multiple-value-bind (width min-width max-width
			  height min-height max-height)
	(apply #'default-space-requirements pane :allow-other-keys t args)
cer's avatar
cer committed
      (setf (slot-value pane 'client-space-requirement)
cer's avatar
cer committed
	    (make-space-requirement :width width :height height 
				    :max-width max-width
				    :min-width min-width
				    :max-height max-height
				    :min-height min-height)))))
cer's avatar
cer committed

cer's avatar
cer committed
(warn "duplicate?")

(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))
cer's avatar
cer committed
  (values width min-width max-width
	  height min-height max-height))
cer's avatar
cer committed

cer's avatar
cer committed
;;;;

cer's avatar
cer committed
(defclass client-space-requirement-mixin (basic-client-space-requirement-mixin)
cer's avatar
cer committed
    ()
  (:documentation "If the user specifies some space requirements then
cer's avatar
cer committed
use it otherwise use other value"))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod compose-space :around ((pane client-space-requirement-mixin) &key width height)
cer's avatar
cer committed
  (or (slot-value pane 'client-space-requirement)
cer's avatar
cer committed
      (call-next-method)))

cer's avatar
cer committed

cer's avatar
cer committed

;;;
cer's avatar
cer committed
;;; Client space space-requirement  (read Client Space Space-requirement)
cer's avatar
cer committed
;;; Just like the above but used by panes that are using the client-specified
cer's avatar
cer committed
;;; space-requirement to determine how much free space is requested (spacer, filler).
cer's avatar
cer committed
;;;

cer's avatar
cer committed
;(defclass client-space-space-requirement-mixin (client-space-requirement-mixin)
cer's avatar
cer committed
;    ())
;
;(defmethod initialize-instance :around
cer's avatar
cer committed
;	   ((pane client-space-space-requirement-mixin) &rest rest 
cer's avatar
cer committed
;	    &key space)
;  (if space
;      (apply #'call-next-method pane :width space :height space rest)
;      (call-next-method)))
cer's avatar
cer committed
;;;
;;;  Client Stretchability
;;;

cer's avatar
cer committed
;(defclass client-stretchability (layout-mixin)
;    ((max-width :initform nil :initarg :max-width)
;     (max-height :initform nil :initarg :max-height)))
;
cer's avatar
cer committed
;(defmethod compose-space :around ((pane client-stretchability) &key width height)
cer's avatar
cer committed
;  (with-slots (max-width max-height) pane
;    (let ((value (call-next-method)))
cer's avatar
cer committed
;      (when max-width (setf (space-requirement-max-width value) max-width))
;      (when max-height (setf (space-requirement-max-height value) max-height))
cer's avatar
cer committed
;      value)))
cer's avatar
cer committed

;;;
;;; Client Overridability
;;;

(defclass client-overridability (layout-mixin)
cer's avatar
cer committed
    ((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))
cer's avatar
cer committed
  (:documentation "Client can specify values that override those
provided elsewhere"))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod compose-space :around ((pane client-overridability) &key width height)
cer's avatar
cer committed
  (with-slots (width height max-width max-height min-width min-height) pane
    (let ((value (call-next-method)))
cer's avatar
cer committed
      (when (or width height max-width max-height min-width
		min-height)
cer's avatar
cer committed
	(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))
cer's avatar
cer committed
      value)))


;;;
;;; Client Demandability
;;;
;;; Used by db-scroll
cer's avatar
cer committed
;(defclass client-demandability (client-space-requirement-mixin
;				space-requirement-cache-mixin)
cer's avatar
cer committed
;    ((space-demand-p :initform t :initarg :space-demand-p)))
;  
cer's avatar
cer committed
;(defmethod compose-space ((pane client-demandability) &key width height)
cer's avatar
cer committed
;  (with-slots (client-space-requirement space-demand-p) pane
cer's avatar
cer committed
;    (if space-demand-p 
cer's avatar
cer committed
;	(or client-space-requirement (compose-space (sheet-child pane)))
cer's avatar
cer committed
;      (let ((child-req (compose-space (sheet-child pane))))
cer's avatar
cer committed
;	(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)))
cer's avatar
cer committed
;	  child-req)))))
cer's avatar
cer committed

;;;
;;; Space Req Cache
;;;

cer's avatar
cer committed
(defclass space-requirement-cache-mixin (layout-mixin)
    ((space-requirement :initform nil)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod compose-space :around ((pane space-requirement-cache-mixin) &key width height)
cer's avatar
cer committed
  (with-slots (space-requirement) pane
    (or space-requirement (setf space-requirement (call-next-method)))))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod clear-space-requirement-cache ((pane layout-mixin))
cer's avatar
cer committed
  nil)

cer's avatar
cer committed
(defmethod clear-space-requirement-cache ((pane t))
cer's avatar
cer committed
  nil)

cer's avatar
cer committed
(defmethod clear-space-requirement-cache ((pane space-requirement-cache-mixin))
  (with-slots (space-requirement) pane
    (setf space-requirement nil)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod note-space-requirement-changed :before
	   (composite (pane space-requirement-cache-mixin))
cer's avatar
cer committed
  (declare (ignore composite))
cer's avatar
cer committed
  (clear-space-requirement-cache pane))
cer's avatar
cer committed

cer's avatar
cer committed
(defun clear-space-requirement-caches-in-tree (sheet)
cer's avatar
cer committed
  (map-over-sheets #'(lambda (sheet) 
		       (clear-space-requirement-cache sheet))
		   sheet))
cer's avatar
cer committed

cer's avatar
cer committed
(defun clear-space-requirement-caching-in-ancestors (menu)
cer's avatar
cer committed
  (do ((parent (sheet-parent menu) (sheet-parent parent)))
      ((null parent))
cer's avatar
cer committed
    (clear-space-requirement-cache parent)))
cer's avatar
cer committed

cer's avatar
cer committed
;;;
;;; Wrapping Space Mixin
;;;

cer's avatar
cer committed
(defclass wrapping-space-mixin (layout-mixin)
cer's avatar
cer committed
    ()
  (:documentation "Supports echoing allocations down and compositions up."))
	 
(defmethod allocate-space ((pane wrapping-space-mixin) width height)
  (resize-sheet* (sheet-child pane) width height))

cer's avatar
cer committed
(defmethod compose-space ((pane wrapping-space-mixin) &key width height)
cer's avatar
cer committed
  (let ((child (sheet-child pane)))
cer's avatar
cer committed
    (compose-space child :width width :height height)))
cer's avatar
cer committed


;;;
;;; Transforming Wrapping Space Mixin
;;;

cer's avatar
cer committed
;(defclass simple-transforming-wrapping-space-mixin (space-requirement-cache-mixin)
cer's avatar
cer committed
;    ()
;  (: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))))
;  
cer's avatar
cer committed
;(defmethod compose-space ((pane simple-transforming-wrapping-space-mixin) &key width height)
cer's avatar
cer committed
;  (let* ((child (sheet-child pane))
;	 (xform (sheet-transformation child))
;	 (req   (compose-space child))
cer's avatar
cer committed
;	 (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)))
cer's avatar
cer committed
;    
;    (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))
;    
cer's avatar
cer committed
;    (make-space-requirement :width width :max-width max-width :min-width min-width
;		             :height height :max-height max-height :min-height min-height)))
cer's avatar
cer committed


;;;
;;; Restrainer-pane
;;;
cer's avatar
cer committed
;;; Use this wrapping composite to not allow note-space-requirement-changeds to propagate up.
cer's avatar
cer committed

(defclass restrainer-pane (composite-pane 
cer's avatar
cer committed
			   simple-wrapper-mixin
			   wrapping-space-mixin
			   mute-input-mixin)
    ())
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod note-space-requirement-changed ((pane restrainer-pane) inner)
cer's avatar
cer committed
  (declare (ignore inner))
cer's avatar
cer committed
  (allocate-space pane 
		  (bounding-rectangle-width pane) (bounding-rectangle-height pane)))
cer's avatar
cer committed


cer's avatar
cer committed

;;; Generally useful layout function
;;; Used all over to satisfy constraints
cer's avatar
cer committed
;;--- I think that since coordinates are ultimately integers we loose
;;---- along the way, calling fix-coor on alloc helps a little but we
;;---- still end up with a gap along the bottom-right edges.
cer's avatar
cer committed

cer's avatar
cer committed
#+ignore
cer's avatar
cer committed
(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))
cer's avatar
cer committed
	(setq give (- (desired-size wanted) (min-size wanted))
	      extra (min (- (desired-size wanted) given) give)))
cer's avatar
cer committed
      (dolist (item items)
cer's avatar
cer committed
	(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+))
	       (setq alloc 0)))
	    (t
	     (let* ((item-size (item-size item)))
cer's avatar
cer committed
	       (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)))))))
	  (push alloc sizes)))
      (nreverse sizes))))

;;-- 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)
  (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)))
	  (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
	     (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)))))))
	  (when (numberp alloc)
	    (incf allocated alloc))
cer's avatar
cer committed
	  (push alloc sizes)))
cer's avatar
cer committed
      (let ((fills (count :fill sizes))
	    (leftover (- given allocated)))
	(when (> fills 0)
	  (let ((x (if (> leftover 0) 
		       (fix-coordinate (/ leftover fills)) 
		     0)))
	    (setf sizes (nsubstitute x :fill sizes)))))
cer's avatar
cer committed
      (nreverse sizes))))
cer's avatar
cer committed
	
cer's avatar
cer committed
;;; Most of the layout panes should inherit from this

(defclass layout-pane (mute-input-mixin
		       pane-background-mixin
		       composite-pane 
cer's avatar
cer committed
		       space-requirement-cache-mixin
cer's avatar
cer committed
		       sheet-permanently-enabled-mixin)
cer's avatar
cer committed
    ())
cer's avatar
cer committed

cer's avatar
cer committed

cer's avatar
cer committed
;;--- 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) ())
cer's avatar
cer committed

(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)))))
cer's avatar
cer committed