Skip to content
Snippets Groups Projects
db-layout.lisp 14.8 KiB
Newer Older
cer's avatar
cer committed
;;; -*- 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 $
cer's avatar
cer committed

(in-package :silica)

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

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...
cer's avatar
cer committed
(defmethod allocate-space ((pane basic-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))

(defmethod note-space-requirements-changed ((composite top-level-sheet) child)
  (declare (ignore child))
  (layout-frame (pane-frame 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
cer's avatar
cer committed
      :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 basic-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)

(defun invoke-with-changing-space-requirements (continuation &key resize-frame (layout t))
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
      (when (and layout (not 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

cer's avatar
cer committed
(defmethod change-space-requirements :around ((pane layout-mixin) 
cer's avatar
cer committed
					      &key resize-frame &allow-other-keys)
cer's avatar
cer committed
  (call-next-method)
cer's avatar
cer committed
  (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)
cer's avatar
 
cer committed
	    (note-space-requirements-changed (sheet-parent pane) pane)))))
cer's avatar
cer committed

cer's avatar
cer committed

cer's avatar
cer committed
(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)
cer's avatar
cer committed
  (space-requirement-combine #'+ sr1 sr2))

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


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

cer's avatar
 
cer committed
(defclass basic-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 basic-space-requirement-mixin) 
cer's avatar
cer committed
				       &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
  (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)))))
cer's avatar
cer committed

cer's avatar
 
cer committed
(defmethod change-space-requirements-to-default ((pane basic-space-requirement-mixin))
cer's avatar
cer committed
  (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 basic-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 change-space-requirements ((pane basic-space-requirement-mixin) 
cer's avatar
cer committed
				      &key width min-width max-width
					   height min-height max-height
					   resize-frame)
  (declare (ignore resize-frame))
cer's avatar
cer committed
  (with-slots (space-requirement) pane
cer's avatar
cer committed
    (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))))))
cer's avatar
cer committed

cer's avatar
 
cer committed

cer's avatar
cer committed
;;;
cer's avatar
 
cer committed
(defclass space-requirement-mixin (basic-space-requirement-mixin) ())
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

cer's avatar
cer committed
;;;
;;; Client Overridability
;;;

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

cer's avatar
 
cer committed
(defmethod normalize-space-requirement ((pane client-overridability-mixin) sr)
  sr)

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 (space-requirement) pane
cer's avatar
 
cer committed
    (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))))))))
cer's avatar
cer committed
;;;
;;; Space Req Cache
;;;

cer's avatar
cer committed
(defclass space-requirement-cache-mixin (layout-mixin)
cer's avatar
cer committed
    ((space-requirement-cache :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-cache) pane
    (or space-requirement-cache
	(setf space-requirement-cache (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))
cer's avatar
cer committed
  (with-slots (space-requirement-cache) pane
    (setf space-requirement-cache 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
    ())
cer's avatar
cer committed
	 
(defmethod allocate-space ((pane wrapping-space-mixin) width height)
cer's avatar
cer committed
  (resize-sheet (sheet-child pane) width height))
cer's avatar
cer committed

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


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

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)))
cer's avatar
 
cer committed
		(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)))))))
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
;;--- It would be nice if this and COMPOSITE-PANE had single- and multiple-child
;;--- versions so that users could get better error diagnostics
cer's avatar
 
cer committed

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