;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: XIT; Base: 10; -*-
;;;_________________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: MARGINS
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Hohl, Hubertus
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/margins.lisp
;;; File Creation Date: 5/07/90 13:53:20
;;; Last Modification Time: 07/24/92 11:28:31
;;; Last Modification By: Juergen Herczeg
;;;
;;; All flames ---> Hubertus
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 6/13/90  [Hubertus]   enhanced scroll-lifts to continuously update percentages
;;;                       for the mouse-documentation.
;;; 6/20/90  [Hubertus]   exchanged scroll-direction semantics for scroll-arrows.
;;; 6/21/90  [Hubertus]   added interaction-window and popup-part-connection to 
;;;                       MARGINED-WINDOWs.
;;; 7/17/90  [Hubertus]   inhibit margin update in change-layout :after method for
;;;                       layouted-windows, if layout-window? is NIL.
;;; 7/18/90  [Hubertus]   changed change-layout :after to adjust-window-size :after
;;;
;;; 7/23/90  [Kalle]      delayed reparenting of children of unrealized
;;;                       margined-windows
;;;
;;; 1/23/91  [Hubertus]   redesigned contact-class MARGINED-WINDOW:
;;;                         - removed popup-part-connection
;;;                         - removed default reactivity 
;;;                         - changed superclass to INTEL
;;;                         - renamed generic function DISPLAY-WINDOW to 
;;;                           CLIENT-WINDOW (and corresponding :init-arg)
;;;                          
;;;                       redesigned contact-class MARGIN-LABEL:
;;;                         - removed reactivity and popup-part-connection
;;;                         - MARGIN-LABEL now is a subclass of text-dispel, i.e.
;;;                           use TEXT and FONT instead of MARGIN-LABEL-STRING and
;;;                           MARGIN-LABEL-FONT accessors 
;;;                           (and initarg :text instead of :string).
;;;
;;;                       The pattern in contact-class SCROLL-LIFT now is of type
;;;                       (or (member :solid) image). In both cases the lift is
;;;                       drawn by using contact's foreground color.
;;;
;;;                       Note that for "black-on-white" margin-labels you have to 
;;;                       specify both background and foreground attributes
;;;                       (i.e. :background "white", :foreground "black").
;;;                       
;;;                       Note that from now on margins can be accessed by
;;;                       their part-name, which defaults to the margin-class-name 
;;;                       symbol in the keyword package.
;;;
;;; 07/01/1991 (Juergen)  the identification of a margined-window is now the 
;;;                       identification of its client-window;
;;;                       a setf-method has been defined accordingly.
;;; 12/19/1991 (Matthias) margined-window: replaced do-adjust-window-size by 
;;;                       adjusted-window-size
;;;________________________________________________________________________________ 


(in-package :xit)

;;;_____________________________________________________________________________
;;; 
;;;		       Margined Window Framework
;;;
;;; The contact-class MARGINED-WINDOW provides a framework for wrapping various
;;; types of margins around a contact (the client-window).
;;; 
;;; Margins are specified by the :margins init-option for MARGINED-WINDOWs.
;;; This is an ordered list of margin-specs. A margin-spec may be either   
;;;   - a margin-class-name,  
;;;   - a list of margin-class-name and margin init-options, 
;;;   - an instance of class MARGIN or
;;;   - a compound-margin-spec. Compound margins expand into a series of margins 
;;;     that make up a standard margin-configuration. A compound-margin-spec
;;;     may be either a compound-margin-name or a list of compound-margin-name 
;;;     and compound-margin init-options. Compound margins are (un)defined by 
;;;     the (UN)DEFINE-COMPOUND-MARGIN macro.
;;;     
;;; The order of the margin-specs determines how the components are added to the
;;; margined-window. The first component is outermost and the last component is
;;; innermost.
;;;
;;; Different types of margin components are supported that are contact-
;;; subclasses of MARGIN. Besides inherited init-options MARGIN provides 
;;; :location and :thickness. Below is a list of currently implemented 
;;; margin types with their own init-options:
;;;
;;;   - MARGIN-LABEL (a text-dispel: :font :text :display-position)
;;;   - MARGIN-SPACE 
;;;   - MARGIN-SCROLL-BAR (:corner :lift-class)
;;;
;;; Besides these basic margin types the following compound-margins are defined:
;;;
;;;   - MARGIN-QUAD-SPACE   (:thickness :left :top :right :bottom) 
;;;   - STANDARD-MARGINS    (:label-options :quad-space-options)
;;;   - MARGIN-SCROLL-BARS  (:locations :space-options)
;;;   - STANDARD-MARGINS-WITH-SCROLL-BARS
;;;                         (:label-options :scroll-bar-options :quad-space-options)
;;;   - STANDARD-MARGINS-WITH-SCROLL-BARS-WITHOUT-LABEL
;;;                         (:scroll-bar-options :quad-space-options)
;;;   - SYMBOLICS-LOOKALIKE-MARGINS-WITH-SCROLL-BARS 
;;;                         (:label-options :space-options :scroll-bar-options)
;;;
;;; Use SEND-PARTS or BROADCAST to lookup or change individual 
;;; margin properties of a margined-window. For that reason, margins have a 
;;; part-name, which defaults to the class-name in the keyword package.
;;;
;;; The ACCESSING-MARGINS macro may be used to lookup or change individual 
;;; margin properties of a margined-window by mapping on margin types.
;;;
;;; The client-window is specified by the :client-window init-option for 
;;; MARGINED-WINDOWs. This is either 
;;;   - a class-name,
;;;   - a list of class-name and init-options or
;;;   - an instance of class BASIC-WINDOW. (Note that client-windows 
;;;     must be of type BASIC-WINDOW).
;;; The client-window can be accessed through the CLIENT-WINDOW 
;;; method of MARGINED-WINDOWs.
;;;  
;;; The adjustability of the client-window is controlled (and maybe overridden)
;;; by the margined-window's :adjust-size? option, i.e. the client-window is
;;; adjustable only, if BOTH client-window's and margined-window's adjust-size? 
;;; is T.
;;;_____________________________________________________________________________
;;;
;;; Application-examples for MARGINED-WINDOWs may be found in the 
;;; xit/examples directory.
;;;_____________________________________________________________________________
;;;
;;; To be done:   
;;;
;;;    - implement a "hold and move" scroll-lift
;;;    - add an :if-needed option to scroll-bars (toggle contact-state)
;;;    - add different types of margins (margin-choice-mixin, ...)
;;;_____________________________________________________________________________


;;;_____________________________________
;;;
;;; The basic contact class for Margins
;;;_____________________________________

(defcontact margin (adjustable-window)
  ((location :type (member :left :top :right :bottom)
	     :initarg :location
	     :accessor margin-location)
   (thickness :initarg :thickness
	      :accessor margin-thickness
	      :documentation "width/height of margin without inside-borders"))
  (:resources
    thickness)
  )

(defmethod (setf margin-location) :after (new-location (self margin))
  (declare (ignore new-location))
  (with-slots (parent) self
    (change-layout parent)))


;;;____________________
;;;
;;;   Margined Window
;;;____________________

(defcontact margined-window (intel)
  ((name :initform :margined-window)
   (layouter :initform 'margin-layouter)
   (left-margin-size :initform 0
		     :accessor left-margin-size)
   (top-margin-size :initform 0
		    :accessor top-margin-size)
   (right-margin-size :initform 0
		      :accessor right-margin-size)
   (bottom-margin-size :initform 0
		       :accessor bottom-margin-size))
  (:resources
   (border-width :initform 1)
   (inside-border :initform 0)			; superceeded by real margins
   )
  (:documentation "a window that wraps margin-components like 
                   scroll-bars, labels, space, etc. around a client-window
                   (specified by the init-option :client-window).
                   The order of the components (specified by the init-option :margins)
                   determines how they are added to the margined-window. The first component
                   is outermost and the last component is innermost."))

(defmethod children-to-be-reparented ((self margined-window))
  (getf (window-plist self) :children-to-be-reparented))

(defmethod (setf children-to-be-reparented) (new-children (self margined-window))
  (setf (getf (window-plist self) :children-to-be-reparented)
        new-children))

(defmethod x-margin ((self margined-window))
  (left-margin-size self))			; a crock!

(defmethod y-margin ((self margined-window))
  (top-margin-size self))			; a crock!

(defmethod x-margins ((self margined-window))
  (with-slots (left-margin-size right-margin-size) self
    (+ left-margin-size right-margin-size)))

(defmethod y-margins ((self margined-window))
  (with-slots (top-margin-size bottom-margin-size) self
    (+ top-margin-size bottom-margin-size)))

(defmethod inside-width ((self margined-window))
  (contact-total-width (client-window self)))

(defmethod inside-height ((self margined-window))
  (contact-total-height (client-window self)))

(defmethod client-window ((self margined-window))
  (or (find-part self #'(lambda (child) (not (typep child 'margin))))
      (error "A client-window is missing.")))

(defmethod identification ((self margined-window))
  (value (client-window self)))

(defmethod (setf identification) (value (self margined-window))
  (setf (value (client-window self)) value))

(defmacro accessing-margins ((margin-variable margined-window
			      &optional (margin-type ''margin))
			     &body body)
  "Execute body with margin-variable successively bound to margined-window's margins,
   that are of type margin-type."
  `(accessing-margins-internal ,margin-type
			       ,margined-window
			       #'(lambda (,margin-variable) .,body)))

(defun accessing-margins-internal (margin-type margined-window continuation)
  (with-slots (children) margined-window
    (dolist (child children)
      (when (typep child margin-type)
	(funcall continuation child)))))

(defmethod initialize-instance :after ((self margined-window) &rest initargs &key
				        margins client-window)
  (assert (not (null client-window)) nil
    "A client-window must be specified for margined-windows!")
  (setup-margins self margins)
  (setup-client self client-window))

(defmethod add-child-to-margined-window ((self margined-window) child)
  (cond ((and (realized-p self)
              (realized-p child))
	 (setf (contact-parent child) self))
        ((realized-p child)
	 (with-slots (parent) child
           (delete-child parent child)
           (setf parent self)
           (add-child self child))
	 (push child (children-to-be-reparented self)))
        ((realized-p self)
	 (error "Cannot add an unrealized child to a margined-window already~
                 realized!"))
        (t (with-slots (parent) child
             (when parent
	       (delete-child parent child)
	       (setf parent self)
	       (add-child self child))))))

(defmethod realize :after ((self margined-window))
  (dolist (child (children-to-be-reparented self))
    (setf (contact-parent child) self))
  (setf (children-to-be-reparented self) nil))

(defmethod setup-margins ((self margined-window) margin-specs)
  (dolist (margin-spec margin-specs)
    (setup-margin self margin-spec))
  (compute-margin-sizes self))

(defmethod setup-margin ((self margined-window) (margin-spec symbol))
  (if (compound-margin-p margin-spec)
      (dolist (spec (expand-compound-margin margin-spec))
	(setup-margin self spec))
      (add-part self :class margin-spec :adjust-size? T)))

(defmethod setup-margin ((self margined-window) (margin-spec cons))
  (if (compound-margin-p (car margin-spec))
      (dolist (spec (apply #'expand-compound-margin
			   (car margin-spec)
			   (cdr margin-spec)))
	(setup-margin self spec))
      (apply #'add-part self
	     :class (car margin-spec)
	     :adjust-size? T
	     (cdr margin-spec))))

(defmethod setup-margin ((self margined-window) (margin-spec margin))
  (with-slots (adjust-size?) margin-spec
    (add-child-to-margined-window self margin-spec)
    (setf adjust-size? T)))
	     
(defmethod client-value ((client-spec symbol) slotname &optional initarg)
  nil)

(defmethod client-value ((client-spec cons) slotname &optional initarg)
  (getf (cdr client-spec)
	(or initarg (intern (symbol-name slotname) 'keyword))))

(defmethod client-value ((client-spec adjustable-window) slotname &optional initarg)
  (slot-value client-spec slotname))

(defmethod setup-client ((self margined-window) client-specs)
  (with-slots (adjust-size? width height) self      
    (let* ((client-border-width
	    (or (client-value client-specs 'border-width) 0))
	   (client-adjust-size?
	    (client-value client-specs 'adjust-size?))
	   (frame-width-supplied (and (> width 0) width))
	   (frame-height-supplied (and (> height 0) height))
	   (client-width-supplied (client-value client-specs 'width))
	   (client-height-supplied (client-value client-specs 'height))
	   (client-width
	    (if (or adjust-size? (not frame-width-supplied))
		client-width-supplied
	      (max 1 (- frame-width-supplied
			(x-margins self)
			client-border-width
			client-border-width))))
	   (client-height
	    (if (or adjust-size? (not frame-height-supplied))
		client-height-supplied
	      (max 1 (- frame-height-supplied
			(y-margins self)
			client-border-width
			client-border-width)))))
      (apply #'add-client self client-specs
	     :adjust-size? (and adjust-size? client-adjust-size?)
	     :border-width client-border-width
	     (append (and client-width `(:width ,client-width))
		     (and client-height `(:height ,client-height))))
      (unless (or adjust-size? frame-width-supplied)
	    (setf width (+ (x-margins self)
			   (inside-width self))))
      (unless (or adjust-size? frame-height-supplied)
	(setf height (+ (y-margins self)
			(inside-height self)))))))

(defmethod add-client ((self margined-window) (client-specs symbol)
		       &rest override-initargs)
  (apply #'add-part self :class client-specs override-initargs))

(defmethod add-client ((self margined-window) (client-specs cons)
		       &rest override-initargs)
  (apply #'add-part self
	 :class (car client-specs)
	 (append override-initargs (cdr client-specs))))

(defmethod add-client  ((self margined-window) (client-specs adjustable-window)
		       &rest override-initargs
		       &key width height border-width adjust-size?)
  (with-slots ((c-w width) (c-h height) (c-b border-width) (c-a adjust-size?))
      client-specs
    (setf c-b border-width
	  c-a adjust-size?)
    (when width
      (setf c-w width))
    (when height
      (setf c-h height))
    (add-child-to-margined-window self client-specs)))


(defmethod compute-margin-sizes ((self margined-window))
  (with-slots (children
	       left-margin-size top-margin-size
               right-margin-size bottom-margin-size) self
    (let ((left 0) (top 0) (right 0) (bottom 0))
      (accessing-margins (margin self)
	  (with-slots (location) margin
	    (when (managed-p margin)	; managed margins only!
	      (case location
		(:left (incf left (contact-total-width margin)))
		(:top  (incf top (contact-total-height margin)))
		(:right (incf right (contact-total-width margin)))
		(:bottom (incf bottom (contact-total-height margin)))))))
      (setf left-margin-size left
	    top-margin-size top
	    right-margin-size right
	    bottom-margin-size bottom)
      (values left top right bottom))))

(defmethod adjusted-window-size ((self margined-window))
  (values (+ (x-margins self)
		    (inside-width self))
	  (+ (y-margins self)
		    (inside-height self))))

;;; change layout takes care to recompute margin sizes and update margins.
;;; Additionally geometry changes are propagated downwards to children 
;;; whose geometry may depend on their parent's geometry (e.g. margin-scroll-bars). 
;;; Note: there is no reason to send the client window a change-layout iff its 
;;; adjust-size? attribute is T!
;;;
(defmethod change-layout ((self margined-window) &optional newly-managed)
  (compute-margin-sizes self)
  (with-slots (layouter layout-window?) self
    (when layout-window?
      (if layouter
	  (let ((client-window (client-window self)))
	    (dolist (child (layouted-parts self))
	      (when (managed-p child)	; necessary!
		(multiple-value-bind (x y w h b) (layout layouter child)
		  (change-geometry child :x x :y y :width w :height h
				   :border-width b)
		  (when (typep child 'layouted-window)
		    (unless (and (eq child client-window)
				 (adjust-size? child))
		      (without-adjusting-size child
					      (change-layout child))))))))
	  (call-next-method))) 
    (adjust-window-size self))
  (update-margins self))

;;; this layouts margined-windows after size changes by the user
;;;
(defmethod resize-window-with-mouse :after ((self margined-window))
  (change-layout self))

(defmethod update-margins ((self margined-window) &optional (type 'margin))
  (accessing-margins (m self type)
    (update m)))

;;; 
;;; update-margins methods
;;;
;;; 06/22/1992 (Hubertus) Note that we have to put a demon
;;; on adjust-window-size and not on do-adjust-window-size because
;;; the window's extent may have changed (due to change-layout) although 
;;; adjust-window-size? is nil!

(defmethod adjust-window-size :after ((self layouted-window))
  (with-slots (parent layout-window?) self
    (when (and (typep parent 'margined-window)
	       layout-window?)
      (update-margins parent 'margin-scroll-bar))))

(defmethod scroll-layouted-window :after ((self layouted-window) dx dy)
  (with-slots (parent) self
    (when (typep parent 'margined-window)
      (update-margins parent 'margin-scroll-bar))))

;;;
;;; internal scrolling method for margined-windows
;;;

(defmethod extent-size ((self margined-window))
  "Returns current width and height of window's extent."
  ;; just return window's bounding-box size
  (bounding-size self))

;;;
;;;  a layouter for components of margined-windows
;;;

(defclass margin-layouter (layouter)
  ()
  (:documentation "a layouter for margined-windows."))

;;; the layouter for margined-windows assumes a specific ordering of children:
;;; the client-window is always preceeded by the margin components, which
;;; are in an 'outermost first' order.
;;;
(defmethod layout ((self margin-layouter) component)
  (flet ((previous-margin (margin location)
	   ;; return the first layouted margin-component 
	   ;; before margin that is located in location
	   (let ((previous nil))
	     (dolist (sibling (layouted-parts (contact-parent margin)))
	       (when (eq sibling margin) (return previous))
	       (when (and (layouted-p sibling)
			  (typep sibling 'margin)
			  (eq (margin-location sibling) location))
		 (setq previous sibling))))))
    (with-slots ((frame window)) self
      (let ((origin (extent-origin frame)))
        (with-slots ((frame-adjust-size? adjust-size?)
		     (frame-width width) (frame-height height)) frame
	  (with-slots (width height border-width) component
	    (let ((previous-left (previous-margin component :left))
		  (previous-top (previous-margin component :top))
		  (previous-right (previous-margin component :right))
		  (previous-bottom (previous-margin component :bottom))
		  (location (and (typep component 'margin)
		    	         (margin-location component)))
		  (frame-acceptable-width (if frame-adjust-size?
					      (+ (x-margins frame)
					         (inside-width frame))
					      frame-width))
		  (frame-acceptable-height (if frame-adjust-size?
					       (+ (y-margins frame)
						  (inside-height frame))
					       frame-height))
		  new-x new-y new-width new-height)
	     (case location
	        ((:left :right)
	         (setq new-x (if (eq location :left)
			         (if previous-left
				     (contact-end-x previous-left)
				     (point-x origin))
			         (- (if previous-right
				        (contact-x previous-right)
				        (+ (point-x origin) frame-acceptable-width))
				    width
				    border-width
				    border-width))
		       new-y (if previous-top
			         (contact-end-y previous-top)
			         (point-y origin))
		       new-width width
		       new-height (max 1 (- (if previous-bottom
					        (contact-y previous-bottom)
					        (+ (point-y origin) frame-acceptable-height))
					    (if previous-top
					        (contact-end-y previous-top)
					        (point-y origin))
					    border-width
					    border-width))))
	        ((:top :bottom)
	         (setq new-x (if previous-left
			         (contact-end-x previous-left)
			         (point-x origin))
		       new-y (if (eq location :top)
			         (if previous-top
				     (contact-end-y previous-top)
				     (point-y origin))
			         (- (if previous-bottom
				        (contact-y previous-bottom)
				        (+ (point-y origin) frame-acceptable-height))
				    height
				    border-width
				    border-width))
		       new-width (max 1 (- (if previous-right
					       (contact-x previous-right)
					       (+ (point-x origin) frame-acceptable-width))
					   (if previous-left
					       (contact-end-x previous-left)
					       (point-x origin))
					   border-width
					   border-width))
		       new-height height))
	        (otherwise			; client-window
		  (setq new-x (if previous-left
				  (contact-end-x previous-left)
				  (point-x origin))
		        new-y (if previous-top
				  (contact-end-y previous-top)
				  (point-y origin))
		        new-width (max 1 (- (if previous-right
					        (contact-x previous-right)
					        frame-acceptable-width)
					    new-x
					    border-width
					    border-width))
		        new-height (max 1 (- (if previous-bottom
					         (contact-y previous-bottom)
					         frame-acceptable-height)
					     new-y
					     border-width
					     border-width)))))
	      (values new-x new-y new-width new-height border-width))))))))



;;;__________________________________________________
;;;
;;;         Various kinds of Margin Components
;;;__________________________________________________


;;;_______________________
;;; 
;;;  Margin Scroll Bar
;;;_______________________

(defcontact margin-scroll-bar (margin intel)
  ((name :initform :margin-scroll-bar)
   (layouter :initform 'margin-scroll-bar-layouter))
  (:resources
   (thickness :initform 10)
   (border-width :initform 1)
   (inside-border :initform 0)
   (background :initform "white"))
  (:documentation "Provides a scroll bar to margined-windows. 
                   Scroll bars consist of decorations: 
                   usually a lift, arrows and/or corners at both ends 
                   that provide additional scrolling functionality.")
  )


(defmethod view-of ((self margin-scroll-bar))
  (with-slots (parent) self
    (client-window parent)))

(defmethod (setf margin-thickness) :after (new-value (self margin-scroll-bar))
  (declare (ignore new-value))
  (change-layout self))

(defmethod initialize-instance :after ((self margin-scroll-bar)
					&rest init-args &key corner lift-class)
  (check-type corner (or null (member :start :end :both)))
  (with-slots (width height thickness location) self
    (multiple-value-bind (start end slope)
	(case location
	  ((:left :right) (values :north :south :vertical))
	  ((:top :bottom)  (values :west :east :horizontal)))
      (with-slots (orientation) (layouter self)
	(setf orientation slope))
      (if (eq slope :vertical)
	  (setf width (+ thickness (x-margins self)))
	  (setf height (+ thickness (y-margins self))))
      (when (or (eq corner :start)
		(eq corner :both))
	(add-part self :class 'scroll-corner :direction start))
      (add-part self :class 'scroll-arrow :direction start)
      (add-part self :class (or lift-class 'scroll-lift) :direction slope)
      (add-part self :class 'scroll-arrow :direction end)
      (when (or (eq corner :end)
		(eq corner :both))
	(add-part self :class 'scroll-corner :direction end))
      )))


(defclass margin-scroll-bar-layouter (layouter)
  ((orientation :type (member :horizontal :vertical)
		:initarg :orientation)))

(defmethod layout ((self margin-scroll-bar-layouter) window)
  (with-slots ((parent window) orientation) self
    (with-slots (border-width) window
      (let ((previous (previous-layouted-sibling window))
	    new-x new-y)
	(if previous
	    (with-slots ((prev-x x) (prev-y y)) previous
	      (let ((prev-end-x (contact-end-x previous))
		    (prev-end-y (contact-end-y previous)))
		(setq new-x (if (eq orientation :vertical) prev-x prev-end-x)
		      new-y (if (eq orientation :vertical) prev-end-y prev-y))))
	    (let ((origin (extent-origin parent)))
	      (setq new-x (+ (point-x origin) (x-margin parent))
		    new-y (+ (point-y origin) (y-margin parent)))))
	(values new-x new-y
		(display-width window) (display-height window)
		border-width)))))

;;;________________________
;;; 
;;;  Scroll Bar Fixture
;;;________________________

(defcontact scroll-decoration (dispel)
  ((border-width :initform 0)
   (adjust-size? :initform nil)
   (direction :type (member :north :west :south :east)
	      :initarg :direction)
   )
  (:resources
   (inside-border :initform 0)))

(defmethod display-width ((self scroll-decoration))
  (margin-thickness (contact-parent self)))

(defmethod display-height ((self scroll-decoration))
  (margin-thickness (contact-parent self)))

;;;
;;; Scroll-Lift (modelled after Symbolics DynamicWindow scroll-bars)
;;;

(defcontact scroll-lift (scroll-decoration)
  ((name :initform :scroll-lift)
   (direction :type (member :horizontal :vertical) :initarg :direction)
   (pattern :type (or (member :solid) image))
   (compute-mouse-documentation? :initform :always)
   (mouse-docu-from-event? :type boolean :initform nil))
  (:resources
    (pattern :initform 33%gray)))

(defmethod convert (contact value (type (eql 'stipple-mask)))
  (if (typep value 'image)
      (find-simple-mask contact value)
      value))

(defmethod realize :after ((self scroll-lift))
  (with-slots (direction) self
    (change-window-cursor self
			  (if (eq direction :horizontal)
			      "sb_h_double_arrow"
			      "sb_v_double_arrow"))))

(defmethod initialize-instance :after ((self scroll-lift) &rest initargs)
  (with-slots (direction pattern) self
    (setf pattern (convert self pattern 'stipple-mask))
    (change-reactivity self :single-left-button
		       (if (eq direction :horizontal)
			   "Mark to left"
			   "Mark to top")
		       'mark-to-left-or-top)
    (change-reactivity self :shift-left-button
		       (if (eq direction :horizontal)
			   "Mark to right"
			   "Mark to bottom")
		       'mark-to-right-or-bottom)
    (change-reactivity self :single-middle-button
		       "Move percentage" 
		       'move-to-mark-percent)
    ;; recompute mouse-documentation on pointer-motion events
    ;; to allow continuous percentage-updates in the mouse-documentation.
    (change-reactivity self :motion-notify 'show-mouse-documentation)
    (change-reactivity self :single-right-button
		       (if (eq direction :horizontal)
			   "Left to mark"
			   "Top to mark")
		       'left-or-top-to-mark)))

(defmethod show-mouse-documentation ((self scroll-lift))
  (with-slots (mouse-docu-from-event?) self
    (setf mouse-docu-from-event? T)
    (call-next-method)
    (setf mouse-docu-from-event? nil)))

(defmethod reactivity-documentation-for ((self scroll-lift) event-spec)
  (with-slots (mouse-docu-from-event? direction) self
    (if (and (eq event-spec :single-middle-button)
	     mouse-docu-from-event?)
	(multiple-value-bind (percent-x percent-y) (x-y-percentage self)
	  (format nil "Move to ~D%"
		  (round (* 100 (if (eq direction :horizontal) percent-x percent-y)))))
	(call-next-method))))

(defmethod display-width ((self scroll-lift))
  (with-slots (direction parent) self
    (with-slots (children width thickness) parent
      (if (eq direction :vertical)
	  thickness
	  (max 1 (- width
		    (let ((w 0))
		      (dolist (child children)
			(unless (eq child self)
			  (incf w (contact-total-width child))))
		      w)
		    (x-margins parent)))))))

(defmethod display-height ((self scroll-lift))
  (with-slots (direction parent) self
    (with-slots (children height thickness) parent
      (if (eq direction :horizontal)
	  thickness
	  (max 1 (- height
		    (let ((h 0))
		      (dolist (child children)
			(unless (eq child self)
			  (incf h (contact-total-height child))))
		      h)
		    (y-margins parent)))))))

(defmethod mark-to-left-or-top ((self scroll-lift))
  (let ((view-of (view-of self)))
    (with-slots (direction) self
      (with-event (x y)
	(multiple-value-bind (new-x new-y)
	    (contact-translate self x y view-of)
	  (if (eq direction :horizontal)
	      (scroll-x-raster view-of nil (- new-x))
	      (scroll-y-raster view-of nil (- new-y))))))))

(defmethod mark-to-right-or-bottom ((self scroll-lift))
  (let ((view-of (view-of self)))
    (with-slots (direction) self
      (with-slots (width height) view-of
	(with-event (x y)
	  (multiple-value-bind (new-x new-y)
	      (contact-translate self x y view-of)
	    (if (eq direction :horizontal)
		(scroll-x-raster view-of nil (- width new-x))
		(scroll-y-raster view-of nil (- height new-y)))))))))

(defmethod left-or-top-to-mark ((self scroll-lift))
  (let ((view-of (view-of self)))
    (with-slots (direction) self
      (with-event (x y)
	(multiple-value-bind (new-x new-y)
	    (contact-translate self x y view-of)
	  (if (eq direction :horizontal)
	      (scroll-x-raster view-of nil new-x)
	      (scroll-y-raster view-of nil new-y)))))))

(defmethod move-to-mark-percent ((self scroll-lift))
  (with-slots (direction) self
    (multiple-value-bind (percent-x percent-y) (x-y-percentage self)
      (if (eq direction :horizontal)
	  (scroll-x-percent (view-of self) percent-x)
	  (scroll-y-percent (view-of self) percent-y)))))

(defmethod x-y-percentage ((self scroll-lift))
  (with-slots (width height) self
    (with-event (x y)
      (values (/ x width)
	      (/ y height)))))

(defvar *minimum-scroll-lift-size* 5)

(defmethod scroll-lift-geometry ((self scroll-lift))
  (declare (special *minimum-scroll-lift-size*))
  (let* ((client (view-of self))
	 (origin (extent-origin client)))
    (with-slots (direction width height) self
      (with-slots ((viewport-width width) (viewport-height height)) client
	(let ((el (point-x origin))
	      (et (point-y origin)))
	  (multiple-value-bind (ewidth eheight) (extent-size client)
	    (if (eq direction :vertical)
		(let* (scale
		       (start-y (if (> eheight 0)
				    (max 0
					 (min (- height *minimum-scroll-lift-size*)
					      (round (* (- et)
							(setq scale (/ height eheight))))))
				    0))
		       (end-y (if (> eheight 0)
				  (max *minimum-scroll-lift-size*
				       (min height
					    (round (* (- viewport-height et) scale))))
				  height)))
		  (values (x-margin self)
			  start-y
			  (- width (x-margins self))
			  (max *minimum-scroll-lift-size* (- end-y start-y))))
		(let* (scale
		       (start-x (if (> ewidth 0)
				    (max 0
					 (min (- width *minimum-scroll-lift-size*)
					      (round (* (- el)
							(setq scale (/ width ewidth))))))
				    0))
		       (end-x (if (> ewidth 0)
				  (max *minimum-scroll-lift-size*
				       (min width
					    (round (* (- viewport-width el) scale))))
				  width)))
		  (values start-x
			  (y-margin self)
			  (max *minimum-scroll-lift-size* (- end-x start-x))
			  (- height (y-margins self)))))))))))

(defmethod display ((self scroll-lift) &optional x y width height &key)
  (with-clip-mask (clip-mask self x y width height)
    (with-slots (pattern foreground) self
      (multiple-value-bind (p-x p-y p-width p-height) (scroll-lift-geometry self)
	(if (typep pattern 'pixmap)
	    (using-gcontext (gc :drawable self
				:clip-mask clip-mask
				:stipple pattern
				:fill-style :stippled
				:foreground foreground)
	      (draw-rectangle-inside self gc p-x p-y p-width p-height t))
	  (using-gcontext (gc :drawable self
			      :clip-mask clip-mask
			      :foreground foreground)
	    (draw-rectangle-inside self gc p-x p-y p-width p-height t)))))))


;;;
;;; Scroll-Corner (used as an adapter for vertical and 
;;;                horizontal scroll-bars that meet at an edge.)
;;;

(defcontact scroll-corner (scroll-decoration)
  ((name :initform :scroll-corner)
   (reactivity :initform
	       '((:single-left-button "Scroll home"
		  (call :view-of scroll-home)))))
  (:resources
    (cursor :initform "dot")))

(defmethod display-width ((self scroll-corner))
  (with-slots (direction parent) self
    (with-slots (border-width inside-border thickness) parent
      (if (or (eq direction :north)
	      (eq direction :south))
	  thickness
	  (+ border-width border-width inside-border thickness)))))

(defmethod display-height ((self scroll-corner))
  (with-slots (direction parent) self
    (with-slots (border-width inside-border thickness) parent
      (if (or (eq direction :east)
	      (eq direction :west))
	  thickness
	  (+ border-width border-width inside-border thickness)))))

(defmethod display ((self scroll-corner) &optional x y width height &key)
  (with-clip-mask (clip-mask self x y width height)
    (with-slots (direction width height parent foreground) self
      (with-slots (border-width) parent
	(let ((line-width (+ border-width border-width)))
	  (using-gcontext (gc :drawable self
			      :clip-mask clip-mask
			      :fill-style :solid
			      :foreground foreground)
	    (draw-rectangle-inside self gc
			    (case direction
			      ((:north :south :east) 0)
			      (:west (- width line-width)))
			    (case direction
			      ((:south :west :east) 0)
			      (:north (- height line-width)))
			    (case direction
			      ((:north :south) width)
			      ((:west :east) line-width))
			    (case direction
			      ((:north :south) line-width)
			      ((:west :east) height))
			    t)))))))


;;;
;;; Scroll-Arrow (modelled after Symbolics DynamicWindow scroll-bars)
;;;

(defcontact scroll-arrow (scroll-decoration)
  ((name :initform :scroll-arrow))
  )

(defmethod realize :after ((self scroll-arrow))
  (with-slots (direction) self
    (change-window-cursor self
			  (case direction
			    (:north "sb_up_arrow")
			    (:south "sb_down_arrow")
			    (:west "sb_left_arrow")
			    (:east "sb_right_arrow")))))

(defmethod initialize-instance :after ((self scroll-arrow) &rest initargs)
  (with-slots (direction) self
    (change-reactivity self :single-left-button
		       (case direction
			 (:north "Scroll upwards")
			 (:south "Scroll downwards")
			 (:west "Scroll leftwards")
			 (:east "Scroll rightwards"))
		       (case direction
			 (:north '(call :view-of scroll-y-raster 1))
			 (:south '(call :view-of scroll-y-raster -1))
			 (:west '(call :view-of scroll-x-raster 1))
			 (:east '(call :view-of scroll-x-raster -1))))
    (change-reactivity self :single-middle-button
		       (case direction
			 ((:north :west) "First screenful")
			 ((:south :east) "Last screenful"))
		       `(call :view-of scroll-to-border ,direction))
    (change-reactivity self :single-right-button
		       (case direction
			 (:north "Scroll screenful upwards")
			 (:south "Scroll screenful downwards")
			 (:west "Scroll screenful leftwards")
			 (:east "Scroll screenful rightwards"))
		       (case direction
			 (:north '(call :view-of scroll-y-screenful 1))
			 (:south '(call :view-of scroll-y-screenful -1))
			 (:west '(call :view-of scroll-x-screenful 1))
			 (:east '(call :view-of scroll-x-screenful -1))))))

(defmethod display ((self scroll-arrow) &optional x y width height &key)
  (with-clip-mask (clip-mask self x y width height)
    (with-slots (direction width height foreground) self
      (using-gcontext (gc :drawable self
			  :clip-mask clip-mask
			  :foreground foreground)
	(let ((center-x (floor width 2))
	      (center-y (floor height 2))
	      (width-1  (1- width))
	      (height-1 (1- height)))
	  (using-point-vector (v 8)
			      (case direction
				(:north (point-push center-x 0)
					(point-push width-1 height-1)
					(point-push 0 height-1)
					(point-push center-x 0))
				(:south (point-push 0 0)
					(point-push width-1 0)
					(point-push	center-x height-1)
					(point-push 0 0))
				(:west (point-push 0 center-y)
				       (point-push width-1 0)
				       (point-push width-1 height-1)
				       (point-push 0 center-y))
				(:east (point-push 0 0)
				       (point-push width-1 center-y)
				       (point-push 0 height-1)
				       (point-push 0 0)))
			      (draw-lines self gc v)))))))

  
;;;____________________________
;;;
;;;       Margin Space
;;;____________________________

(defcontact margin-space (margin dispel)
  ((name :initform :margin-space))
  (:resources
   (inside-border :initform 0)
   (thickness :initform 5)
   (border-width :initform 0)
   (background :initform "white")))

(defmethod display-width ((self margin-space))
  (with-slots (location thickness) self
    (when (member location '(:left :right))
      (+ thickness (x-margins self)))))

(defmethod display-height ((self margin-space))
  (with-slots (location thickness) self
    (when (member location '(:top :bottom))
      (+ thickness (y-margins self)))))

(defmethod (setf margin-thickness) :after (new-value (self margin-space))
  (declare (ignore new-value))
  (adjust-window-size self))
  
  
;;;____________________________
;;;
;;;       Margin Label
;;;____________________________

(defcontact margin-label (margin text-dispel)
  ((name :initform :margin-label)
   (location :type (member :top :bottom)
	     :initform :top)
   (font-defaults :allocation :class :initform '(:face :bold)))
  (:resources   
    (border-width :initform 1)
    (inside-border :initform 1)
    (thickness :initform 1)
    (background :initform "black")
    (foreground :initform "white"))
  )


(defmethod display-height ((self margin-label))
  (with-slots (font thickness) self
    (if font
	(+ (max (text-height font) thickness) (y-margins self))
	(+ thickness (y-margins self)))))

(defmethod display-x-offset ((self margin-label))
  (with-slots (display-position width) self
    (let ((x-margin (x-margin self))
	  (x-margins (x-margins self))
	  (display-width (display-width self)))
      (case display-position
	((:upper-left :left-center :lower-left)
	 x-margin)
	((:upper-center :center :lower-center)
	 (+ (floor (- width display-width x-margins) 2) x-margin))
	((:upper-right :right-center :lower-right)
	 (+ x-margin (- width display-width x-margins)))))))

(defmethod display-y-offset ((self margin-label))
  (with-slots (display-position height font) self
    (let ((y-margin (y-margin self))
	  (text-height (if font (text-height font) 0)))
      (case display-position
	((:upper-left :upper-center :upper-right)
	 y-margin)
	((:left-center :center :right-center)
	 (floor (- height text-height) 2))
	((:lower-left :lower-center :lower-right)
	 (+ y-margin (- height text-height)))))))

(defmethod adjusted-window-size ((self margin-label))
  (with-slots (width) self			      ; adjust height only
    (values width (max 1 (display-height self)))))  

(defmethod (setf display-position) :after (new-position (self margin-label))
  (declare (ignore new-position))
  (update self))

(defmethod (setf text) :around (string (self margin-label))
  (without-adjusting-size self
    (call-next-method)))

(defmethod (setf margin-thickness) :after (new-value (self margin-label))
  (declare (ignore new-value))
  (adjust-window-size self))


;;;___________________________________________________________
;;;
;;;		      Compound Margins
;;;
;;; By introducing compound-margins that expand into a series 
;;; of margins (either basic margins or compound-margins) 
;;; application programmers may build libraries of 
;;; standard margin-configurations. Compound-margins are 
;;; (un)defined by the (UN)DEFINE-COMPOUND-MARGIN macro.
;;;___________________________________________________________

(defmethod compound-margin-p (symbol) nil)

(defgeneric expand-compound-margin (margin-name &rest options
				    &key &allow-other-keys))

(defmacro define-compound-margin (name arglist &body body)
  `(progn
     (defmethod compound-margin-p ((name (eql ',name))) T)
     (defmethod expand-compound-margin ((name (eql ',name)) .,arglist)
       .,body)))

(defmacro undefine-compound-margin (name &rest ignored-args)
  (declare (ignore ignored-args))
  `(defmethod compound-margin-p ((name (eql ',name))) nil))


(define-compound-margin margin-quad-space (&rest options &key thickness left top right bottom)
  (remf options thickness)
  (remf options left)
  (remf options top)
  (remf options right)
  (remf options bottom)
  `((margin-space :location :left :thickness ,(or left thickness) .,(copy-list options))
    (margin-space :location :right :thickness ,(or right thickness) .,(copy-list options))
    (margin-space :location :top :thickness ,(or top thickness) .,(copy-list options))
    (margin-space :location :bottom :thickness ,(or bottom thickness) .,(copy-list options))
    ))

(define-compound-margin standard-margins (&rest options &key
					   label-options quad-space-options)
  `((margin-label ,@label-options)
    (margin-quad-space ,@quad-space-options)))

(defvar *default-scroll-bar-locations* '(:left :bottom))

(define-compound-margin margin-scroll-bars
			(&rest options &key
			 (locations nil loc-supplied-p) (space-options nil space-supplied-p))
  (declare (special *default-scroll-bar-locations*))
  (remf options locations)
  (remf options space-options)
  (let ((margin-specs nil)
	(locations (if loc-supplied-p
		       (remove-duplicates locations)
		       *default-scroll-bar-locations*)))
    (dolist (loc '(:left :right :top :bottom))
      (when (member loc locations)
	(push `(margin-scroll-bar
	        :location ,loc
		:corner ,(and (member loc '(:left :right))
			      (if (member :top locations)
				  (if (member :bottom locations)
				      :both
				      :start)
				  (if (member :bottom locations)
				      :end
				      nil)))
		.,(copy-list options))
	      margin-specs)
	;; maybe supply space in between scroll-bars
	(when space-supplied-p
	  (push `(margin-space :location ,loc .,(copy-list space-options))
		margin-specs))))
    (nreverse margin-specs)))

(define-compound-margin standard-margins-with-scroll-bars-without-label
			(&rest options &key
			 scroll-bar-options quad-space-options)
  (declare (special *default-scroll-bar-locations*))
  `((margin-scroll-bars ,@scroll-bar-options)
    ;; place a single line in borders without scroll-bar
    ,@(let ((sb-locs (getf scroll-bar-options :locations
			   *default-scroll-bar-locations*))
	    (sb-border (getf scroll-bar-options :border-width 1))
	    (space-locs nil))
	(when (> sb-border 0)
	  (dolist (loc '(:left :top :right :bottom) space-locs)
	    (unless (member loc sb-locs)
	      (push `(margin-space :location ,loc :thickness ,sb-border :background "black")
		    space-locs)))))
    (margin-quad-space ,@quad-space-options)))

(define-compound-margin standard-margins-with-scroll-bars
			(&rest options &key
			 label-options scroll-bar-options quad-space-options)
  `((margin-label ,@label-options)
    (standard-margins-with-scroll-bars-without-label
      :scroll-bar-options ,scroll-bar-options
      :quad-space-options ,quad-space-options)))

(define-compound-margin symbolics-lookalike-margins-with-scroll-bars
  (&rest options &key label-options space-options scroll-bar-options)
  `((margin-space :location :left .,(copy-list space-options))
    (margin-space :location :right .,(copy-list space-options))
    (margin-space :location ,(if (eq (getf label-options :location) :bottom)
				 :top :bottom)
		  .,(copy-list space-options))
    (margin-label ,@label-options
		  :location :top :border-width 0
		  :background "white" :foreground "black")
    (margin-space :location ,(if (eq (getf label-options :location) :bottom)
				 :bottom :top)
		  .,(copy-list space-options))
    (margin-scroll-bars :space-options ,space-options ,@scroll-bar-options)))




