Skip to content
Snippets Groups Projects
db-layout.lisp 17.2 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.7 92/02/05 21:45:12 cer Exp $
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
(defmethod change-space-requirement :after
cer's avatar
cer committed
	   ((pane layout-mixin) &key resize-frame &allow-other-keys)
  (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
(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)
  (declare (ignore port))
  (multiple-value-bind (width height) (bounding-rectangle-size pane)
    (allocate-space pane width height)))


cer's avatar
cer committed
#||

cer's avatar
cer committed
(defmacro changing-space-requirements ((pane &key resize-frame) &body body)
cer's avatar
cer committed
 `(progn
    ,@body {translate "change-space-req" to %set-space-req}
    (if resize-frame
        (layout-frame frame)
cer's avatar
cer committed
        (note-space-requirement-changed (sheet-parent pane) pane))))
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-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
  (slot-value pane '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
(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
  (clim-internals::map-over-sheets
cer's avatar
cer committed
    #'(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

(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)
	(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))))
cer's avatar
cer committed
		(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)))))
cer's avatar
cer committed
	    (decf extra used))
cer's avatar
cer committed
	  (push alloc 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