Skip to content
Snippets Groups Projects
db-layout.lisp 23.7 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
cer's avatar
cer committed
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
cer's avatar
cer committed
;; applicable.
;;
;;;
;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
;;;
cer's avatar
cer committed
;; $fiHeader: db-layout.lisp,v 1.20 92/06/29 14:04:30 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-requirements-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
;;;

cer's avatar
cer committed
;;--- This seems dubious...
(defmethod allocate-space ((pane sheet) width height)
cer's avatar
cer committed
  (declare (ignore width height)))

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

cer's avatar
cer committed
(defmethod note-space-requirements-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-requirements ((pane layout-mixin) &key &allow-other-keys)
cer's avatar
cer committed
  nil)

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


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

cer's avatar
cer committed
(defmethod change-space-requirements-to ((pane layout-mixin) space-requirement)
cer's avatar
cer committed
  (multiple-value-bind (width min-width max-width
			height min-height max-height)
cer's avatar
cer committed
      (space-requirement-components space-requirement)
cer's avatar
cer committed
    (change-space-requirements 
      pane
      :width width :min-width min-width :max-width max-width 
      :height height :min-height min-height :max-height max-height)))

cer's avatar
cer committed

cer's avatar
cer committed
;;--- Do we need this?
cer's avatar
cer committed
(defmethod change-space-requirements-to-default ((pane pane))
cer's avatar
cer committed
  nil)

cer's avatar
cer committed
(defmethod change-space-requirements-to-default ((pane layout-mixin))
  nil)

cer's avatar
cer committed
(defvar *inside-changing-space-requirements* nil)

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

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

cer's avatar
cer committed
(defmethod change-space-requirements :around ((pane layout-mixin) 
					      &key resize-frame 
					      &allow-other-keys)
cer's avatar
cer committed
  (call-next-method)
  (if *inside-changing-space-requirements*
      (push (if resize-frame (pane-frame pane) (sheet-parent pane))
	    (cdr *inside-changing-space-requirements*))
cer's avatar
cer committed
      (if resize-frame
	  (layout-frame (pane-frame pane))
	  (note-space-requirement-changed (sheet-parent pane) pane))))
cer's avatar
cer committed

cer's avatar
cer committed

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-requirements)
cer's avatar
cer committed
     (space-requirement :reader pane-space-requirements)))
cer's avatar
cer committed

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

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

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
  (declare (ignore 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-requirements ((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 slot that defaults to NIL"))
cer's avatar
cer committed

cer's avatar
cer committed
;;--- BUG: what do we do if the value is NIL?
(defmethod change-space-requirements ((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
;;--- This duplicates the method on SPACE-REQUIREMENT-MIXIN.  Can we share?
cer's avatar
cer committed
(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
cer's avatar
cer committed
	  height min-height max-height))
cer's avatar
cer committed

cer's avatar
cer committed
;;;;

cer's avatar
cer committed
;;--- The only subclass of BASIC-CLIENT-SPACE-REQUIREMENT-MIXIN.  Merge them?
cer's avatar
cer committed
(defclass client-space-requirement-mixin (basic-client-space-requirement-mixin)
cer's avatar
cer committed
    ()
cer's avatar
cer committed
  (:documentation "If the user specifies some space requirements then 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
  (declare (ignore 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-mixin (layout-mixin)
cer's avatar
cer committed
;    ((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-mixin) &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
;;;

cer's avatar
cer committed
(defclass client-overridability-mixin (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-mixin) &key width height)
  (declare (ignore 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)))
cer's avatar
cer committed
      (when width   (setf (space-requirement-width value)  width))
cer's avatar
cer committed
      (when height  (setf (space-requirement-height value) height))
cer's avatar
cer committed
      (when max-width  (setf (space-requirement-max-width value)  max-width))
cer's avatar
cer committed
      (when max-height (setf (space-requirement-max-height value) max-height))
cer's avatar
cer committed
      (when min-width  (setf (space-requirement-min-width value)  min-width))
cer's avatar
cer committed
      (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-mixin (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-mixin) &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
  (declare (ignore width height))
cer's avatar
cer committed
  (with-slots (space-requirement) pane
cer's avatar
cer committed
    (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 change-space-requirements :before ((pane space-requirement-cache-mixin) &key)
  (clear-space-requirement-cache pane))

cer's avatar
cer committed
(defmethod note-space-requirements-changed :before
cer's avatar
cer committed
	   (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-requirements-changed to propagate up.
cer's avatar
cer committed

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

cer's avatar
cer committed
(defmethod note-space-requirements-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

cer's avatar
cer committed
;;--- I think that since coordinates are ultimately integers we loose
cer's avatar
cer committed
;;--- along the way, calling FIX-COORDINATE on alloc helps a little but we
;;--- still end up with a gap along the bottom-right edges.
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)
cer's avatar
cer committed
  (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)))
cer's avatar
cer committed
    (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+))
cer's avatar
cer committed
		 (setq alloc 0)))
cer's avatar
cer committed
	    (t
cer's avatar
cer committed
	      (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)))))))
cer's avatar
cer committed
	  (push alloc sizes)))
      (nreverse sizes))))
cer's avatar
cer committed
	
;; 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
cer's avatar
cer committed
(defun allocate-space-to-items (given wanted items min-size
				desired-size max-size item-size)
cer's avatar
cer committed
  (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)))
cer's avatar
cer committed
    (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))
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)
	(let (alloc)
	  (typecase item
	    ((member :fill)
	     (setq alloc :fill))
	    (t
cer's avatar
cer committed
	      (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)))))))
cer's avatar
cer committed
	  (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)) 
cer's avatar
cer committed
		       0)))
cer's avatar
cer committed
	    (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

cer's avatar
cer committed
(defclass layout-pane (sheet-mute-input-mixin
cer's avatar
cer committed
		       pane-background-mixin
cer's avatar
cer committed
		       space-requirement-cache-mixin
cer's avatar
cer committed
		       sheet-permanently-enabled-mixin
		       composite-pane)
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)))))