;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Layouters
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/layouters.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 06/11/92 09:36:25
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 6/11/90 (Juergen)  layouted-window has composite as superclass
;;;                    and got an extra slot bbox
;;; 7/17/90 (Hubertus) added unwind-protects and gensyms to without-<foo> macros.
;;; 7/20/90 (Hubertus) fixed bug in (setf layouter) :after method when new-layouter
;;;                    is NIL.
;;; 7/20/90 (Hubertus) the scrolling methods for layouted-windows now call 
;;;                    scroll-layouted-window instead of change-layout. Thus
;;;                    layouted-windows without layouters are scrollable and
;;;                    the overhead of changing layout is eliminated.
;;; 7/22/90 (Hubertus) replaced bbox cache for layouted-windows with a bbox-size
;;;                    cache. Now scrolling doesn't invalidate this cache any longer.
;;; 7/23/90 (Hubertus) improved with-final-layout macro to handle nested calls.
;;;
;;; 9/07/90 (Juergen)  change-layout has been modified to layout the 
;;;                    "layouted-windows", which defaults to all children of the 
;;;                    window in question (cf. method layouted-windows)
;;;
;;; 9/11/90 (Juergen)  newly-managed children are no longer treated specially 
;;;                    in change-layout method (this was a bug)
;;;
;;; 01/25/1991 (Juergen) method layouted-parts has been changed to return all 
;;;                      children of a window, which are layouted-p
;;;
;;; 01/30/1991 (Hubertus) update-state has been removed from with-final-layout
;;;                       and without-layouting macros.
;;;
;;; 02/12/1991 (Matthias) basic-layouter has new slot constraint. If set to
;;;                       :x or :y the corresponding coordinate will not be
;;;                       changed during layout
;;;
;;; 05/15/1991 (Hubertus) an improved version of a
;;;                       multiline-distance-layouter called
;;;                       ALIGNING-MULTILINE-DISTANCE-LAYOUTER is available. 
;;; 05/31/1991 (Hubertus)  moved UPDATE method from layouted-window to 
;;;                        composite.
;;;
;;; 07/01/1991 (Juergen) (setf adjust-size?) now triggers adjust-window-size
;;;                      method.
;;; 12/19/1991 (Matthias) changed: do-adjust-window-size
;;;___________________________________________________________________________

(in-package :xit)

;_____________________________________________________________________________

;____________________________________________________________________________
;
;                              Adjustable  Window
;____________________________________________________________________________

(defcontact adjustable-window (basic-window)
  ((adjust-size? :type boolean :initform t
		 :accessor adjust-size?
		 :initarg :adjust-size?))
  (:documentation "Abstract class providing the basic property
                   of adjusting the size of interaction objects
                   according to their contents, e.g., a text or
                   subparts"))

(defmethod do-adjust-window-size ((self adjustable-window))
  (multiple-value-bind (w h)
      (adjusted-window-size self)
     (resize-window self w h)))		

(defmethod do-adjust-window-size :after ((self adjustable-window))
  (with-slots (parent layouted?) self 
    (when (typep parent 'layouted-window) ; is this really needed? ***
      ;(if layouted?                  ; should be changed!
	  (change-layout parent)
	;(adjust-window-size parent)) ; should be changed!
                                      ; adjust-window-size does not test slot
                                      ; layout-window?, whereas change-layout
                                      ; does
    )))
      
(defmethod adjust-window-size ((self adjustable-window))
  (with-slots (adjust-size?) self
    (when adjust-size? (do-adjust-window-size self))))

(defmethod (setf adjust-size?) :after (value (self adjustable-window))
  (adjust-window-size self))

(defmacro without-adjusting-size (window &body body)
  `(without-adjusting-size-internal ,window #'(lambda () . ,body)))

(defun without-adjusting-size-internal (window continuation)
  (if (typep window 'adjustable-window)
      (with-slots (adjust-size?) window
	(let ((saved-adjust-size? adjust-size?))
	  (unwind-protect
	      (progn (setf adjust-size? nil)
		     (funcall continuation))
	    (setf adjust-size? saved-adjust-size?))))
      (funcall continuation)))

;____________________________________________________________________________
;
;                              Layouted  Window
;____________________________________________________________________________

(defcontact layouted-window (adjustable-window composite)
  ((layouter :type (or null layouter) :initform nil :accessor layouter)
   (layout-window? :type boolean :initform t :accessor layout-window?)
   (bbox-size :type (or null point) :initform nil
	      :documentation
	      "caching size of bounding-box: bbox-width, bbox-height"))
  (:documentation "layouted-window is a composite window which
                   automatically lays out its parts according to
                   a layouter object"))

(defmethod initialize-instance :after ((self layouted-window) &rest init-list
				       &key layouter)
  (declare (ignore init-list))
  (with-slots ((window-layouter layouter)) self
    (let ((layouter-descr (if layouter
			      layouter
			      window-layouter)))
      (cond
       ((null layouter-descr))
       ((typep layouter-descr 'layouter)
	(with-slots (window) layouter-descr
	  (setf window-layouter layouter-descr)
	  (setf window self)))
       (t
	(let ((layouter-class
	       (if (listp layouter-descr)
		   (car layouter-descr)
		 layouter-descr))
	      (layouter-inits
	       (when (listp layouter-descr)
		     (cdr layouter-descr))))
	  (setf window-layouter
		(apply #'make-instance layouter-class :window self layouter-inits))))))))

(defmethod bounding-size ((self layouted-window))
  (with-slots (bbox-size) self
     (if (not (null bbox-size))
	 ;; return cached values
	 (values (point-x bbox-size) (point-y bbox-size))
	 ;; recompute and cache bbox-size
	 (multiple-value-bind (bbox-w bbox-h) (call-next-method)
	   (setf bbox-size (point bbox-w bbox-h))
	   (values bbox-w bbox-h)))))

(defmethod layouted-parts ((self layouted-window))
  ;; parts to be layouted by corresponding layouter 
  ;; (defaults to all children which are layouted-p).
  ;; May be redefined by subclasses, e.g. to filter or reorder the 
  ;; layouted parts 
  (remove-if-not #'layouted-p (composite-children self)))
  
(defmethod change-layout ((self layouted-window) &optional newly-managed)
  (with-slots (layouter layout-window?) self
    ;(format t "~%change layout of ~A (~A) with layout-window? = ~A"
	;    self newly-managed layout-window?)
    (when layout-window?
      (if layouter
	  (dolist (child (layouted-parts self))
	    (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)))
	  (call-next-method)) 
      (adjust-window-size self))))    ; adjust only if layout-window? is non-NIL!

(defmethod change-layout :before ((self layouted-window)
				  &optional newly-managed)
  (with-slots (bbox-size) self
      (setf bbox-size nil)))			     ; invalidate bbox cache

(defmethod (setf layouter) :after (new-layouter (self layouted-window))
  (with-slots (window) new-layouter
    (when (not (null new-layouter))
      (setf window self)))
  (change-layout self))

(defmacro without-layouting (window &body body)
  (let ((saved-layout-window? (gensym)))
    `(with-slots (layout-window? display) ,window
       (let ((,saved-layout-window? layout-window?))
	 (unwind-protect
	     (progn (setf layout-window? nil)
		    ,@body)			; return the values of BODY!
	   ;; (update-state display)     ; to ensure that all windows are realized
	   ;; may cause problems when invoked from initialize-instance :after 
	   (setf layout-window? ,saved-layout-window?))))))

(defmacro with-final-layout (window &body body)
  (let ((saved-layout-window? (gensym))
	(w (gensym)))
    `(let ((,w ,window))
       (with-slots (layout-window? display) ,w
	 (let ((,saved-layout-window? layout-window?))
	   (unwind-protect
	       (progn (setf layout-window? nil)
		      ,@body)			; return the values of BODY!
	     ;; (update-state display) ; to ensure that all windows are realized
	     ;; may cause problems when invoked from initialize-instance :after
	     (setf layout-window? ,saved-layout-window?)
	     (when ,saved-layout-window?	; skip change-layout for nested calls
	       (change-layout ,w))))))))


;;;
;;; internal scrolling methods for layouted-windows
;;;

(defmethod extent-size ((self layouted-window))
  "Returns current width and height of window's extent."
  (multiple-value-bind (bbox-width bbox-height) (bounding-size self)
    ;; return window's bbox incremented by x/y margins
    (values (+ bbox-width (x-margins self))
	    (+ bbox-height (y-margins self)))))

(defmethod scroll-to ((self layouted-window) &optional x y)
  (let* ((origin (extent-origin self))
	 (o-x (point-x origin))
	 (o-y (point-y origin)))
    (multiple-value-bind (new-x new-y) (new-scroll-position self x y)
      (when new-x
	(setf (point-x origin) new-x))
      (when new-y
	(setf (point-y origin) new-y))
      (when (or new-x new-y)
	(scroll-layouted-window self
				(if new-x (- new-x o-x) 0)
				(if new-y (- new-y o-y) 0))))))

(defmethod scroll-relative ((self layouted-window) dx dy)
  (let* ((origin (extent-origin self))
	 (o-x (point-x origin))
	 (o-y (point-y origin)))
    (multiple-value-bind (new-x new-y) (new-scroll-position self dx dy :relative)
      (when new-x
	(setf (point-x origin) new-x))
      (when new-y
	(setf (point-y origin) new-y))
      (when (or new-x new-y)
	(scroll-layouted-window self
				(if new-x (- new-x o-x) 0)
				(if new-y (- new-y o-y) 0))))))

(defmethod scroll-layouted-window ((self layouted-window) dx dy)
  (dolist (child (composite-children self))
    (with-slots (x y) child
      (change-geometry child :x (+ x dx) :y (+ y dy)))))

#||
(defmethod scroll-layouted-window ((self layouted-window) dx dy)
  (dolist (child (layouted-parts self))
    (when (managed-p child)		; necessary!
      (with-slots (x y) child
        (change-geometry child :x (+ x dx) :y (+ y dy))))))
||#

;_______________________________________________________________________________
;
;                                Layouters
;_______________________________________________________________________________

(defclass layouter ()
     ((window :type layouted-window :reader window :initarg :window)))

(defmethod layout ((self layouter) window)           ; to be filled by subclasses
  (with-slots (x y width height border-width) window
    (values x y width height border-width)))


;_______________________________________________________________________________
;
;                                 Basic Layouter
;_______________________________________________________________________________

(defclass basic-layouter (layouter)
  ((alignment :type (member :upper-left :upper-center :upper-right
			    :left-center :center :right-center
			    :lower-left :lower-center :lower-right)
	      :initform :upper-left
	      :accessor alignment :initarg :alignment)
   (constraint :type (member :none :x :y) :initform :none
	       :accessor constraint :initarg :constraint))
  
  (:documentation "layouter that positions its windows on top of each other
optionally leaving one coordinate untouched."))

(defmethod (setf alignment) :after (value (self basic-layouter))
  (declare (ignore value))
  (with-slots (window) self
    (change-layout window)))

(defmethod (setf constraint) :after (value (self basic-layouter))
  (declare (ignore value))
  (with-slots (window) self
    (change-layout window)))

(defmethod layout ((self basic-layouter) window)
  (with-slots ((parent window) alignment constraint) self
    (with-slots (x y width height border-width) window
      (let ((parts (layouted-parts parent))
	    (origin (extent-origin parent))
	    (new-x x)
	    (new-y y))
	(unless (eq constraint :x)
	  (let* ((max-width (reduce #'max (mapcar #'contact-total-width parts)))
		(total-width (contact-total-width window))
		(x-offset
	       (case alignment
		 ((:upper-left :left-center :lower-left) 0)
		 ((:upper-center :center :lower-center)
		  (floor (- max-width total-width) 2))
		 ((:upper-right :right-center :lower-right)
		  (- max-width total-width)))))
	    (setq new-x (+ (point-x origin) (x-margin parent) x-offset))))
	(unless (eq constraint :y)
	  (let* ((max-height (reduce #'max (mapcar #'contact-total-height parts)))
		 (total-height (contact-total-height window))
		 (y-offset
		  (case alignment
		    ((:upper-left :upper-center :upper-right) 0)
		    ((:left-center :center :right-center)
		     (floor (- max-height total-height) 2))
		    ((:lower-left :lower-center :lower-right)
		     (- max-height total-height)))))
	    (setq new-y (+ (point-y origin) (y-margin parent) y-offset))))
	(values new-x new-y width height border-width)))))

;_______________________________________________________________________________
;
;                                Distance Layouters
;_______________________________________________________________________________

(defclass distance-layouter (layouter)
  ((orientation :type (member :right :left :up :down) :initform :down
		:accessor orientation :initarg :orientation)
   (distance :initform 5 :accessor distance :initarg :distance))
  (:documentation "layouter that positions its windows with constant distance
                   according to orientation"))

(defmethod (setf orientation) :after (new-orientation (self distance-layouter))
  (declare (ignore new-orientation))
  (with-slots (window) self
    (change-layout window)))

(defmethod (setf distance) :after (new-distance (self distance-layouter))
  (declare (ignore new-distance))
  (with-slots (window) self
    (change-layout window)))

(defmethod layout ((self distance-layouter) window)
  (with-slots ((parent window) orientation distance) self
    (with-slots (x y width height border-width) window
      (let ((previous (previous-layouted-sibling window parent))
	    (total-width (contact-total-width window))
	    (total-height (contact-total-height window)))
	(let (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 (case orientation
				((:down :up) prev-x)
				(:right (+ prev-end-x distance))
				(:left  (- prev-x total-width distance)))
			new-y (case orientation
				(:down (+ prev-end-y distance))
				(:up   (- prev-y total-height distance))
				((:right :left) 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 width height border-width))))))


(defclass indent-distance-layouter (distance-layouter)
  ((indent :initform 20 :accessor indent :initarg :indent))
  (:documentation "distance-layouter that adds a constant indent for each window
                   relative to its predecessor"))

(defmethod (setf indent) :after (new-indent (self indent-distance-layouter))
  (declare (ignore new-indent))
  (with-slots (window) self
    (change-layout window)))

(defmethod layout ((self indent-distance-layouter) window)
  (with-slots ((parent window) orientation distance indent) self
    (with-slots (x y width height border-width) window
      (let ((previous (previous-layouted-sibling window parent))
	    (total-width (contact-total-width window))
	    (total-height (contact-total-height window)))
	(let (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 (case orientation
				((:down :up) (+ prev-x indent))
				(:right (+ prev-end-x distance))
				(:left  (- prev-x total-width distance)))
			new-y (case orientation
				(:down (+ prev-end-y distance))
				(:up   (- prev-y total-height distance))
				((:right :left) (+ prev-y indent))))))
	    (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 width height border-width))))))

(defclass single-indent-distance-layouter (indent-distance-layouter)
  ()
  (:documentation "distance-layouter that adds an indent for each window
                   other than the first one"))

(defmethod layout ((self single-indent-distance-layouter) window)
  (with-slots ((parent window) orientation distance indent) self
    (with-slots (x y width height border-width) window
      (let ((previous (previous-layouted-sibling window parent))
	    (total-width (contact-total-width window))
	    (total-height (contact-total-height window))
	    (x-margin (x-margin parent))
	    (y-margin (y-margin parent)))
	(let (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 (case orientation
				((:down :up) (+ x-margin indent))
				(:right (+ prev-end-x distance))
				(:left  (- prev-x total-width distance)))
			new-y (case orientation
				(:down (+ prev-end-y distance))
				(:up   (- prev-y total-height distance))
				((:right :left) (+ y-margin indent))))))
	      (let ((origin (extent-origin parent)))
		(setq new-x (+ (point-x origin) x-margin)
		      new-y (+ (point-y origin) y-margin))))
	  (values new-x new-y width height border-width))))))


(defclass selective-indent-distance-layouter (indent-distance-layouter)
  ((indent-table :initform nil :accessor indent-table :initarg :indent-table))
  (:documentation "distance-layouter that adds an individual indentation for each window"))

(defmethod (setf indent-table) :after (new-indent-table
					(self selective-indent-distance-layouter))
  (declare (ignore new-indent-table))
  (with-slots (window) self
    (change-layout window)))

(defmethod indentation ((self selective-indent-distance-layouter) window)
  (or (cdr (assoc window (indent-table self) :test #'eq))
      0))

(defmethod set-indentation ((self selective-indent-distance-layouter) window indent)
  (with-accessors ((indent-table indent-table)) self
    (setf indent-table (acons window indent indent-table))))

(defmethod layout ((self selective-indent-distance-layouter) window)
  (with-slots ((parent window) orientation distance indent) self
    (with-slots (x y width height border-width) window
      (let ((previous (previous-layouted-sibling window parent))
	    (total-width (contact-total-width window))
	    (total-height (contact-total-height window))
	    (depth (indentation self window)))
	(let (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 (case orientation
				((:down :up) (* indent depth))
				(:right (+ prev-end-x distance))
				(:left  (- prev-x total-width distance)))
			new-y (case orientation
				(:down (+ prev-end-y distance))
				(:up   (- prev-y total-height distance))
				((:right :left) (* indent depth))))))
	      (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 width height border-width))))))

;_______________________________________________________________________________
;
;                         Aligning Distance Layouter
;_______________________________________________________________________________


(defclass aligning-distance-layouter (distance-layouter)
     ((alignment :type (member :upper-left :center :lower-right)
		 :initform :upper-left
		 :initarg :alignment
		 :accessor alignment)
      (divide-equally? :initform nil
		       :type boolean
		       :initarg :divide-equally?
		       :accessor divide-equally?))
  (:documentation "A distance layouter that aligns its windows
                   and optionally divides windows evenly if the parent is not
                   self-adjusting."))

(defmethod (setf alignment) :after (new-value (self aligning-distance-layouter))
  (declare (ignore new-value))
  (with-slots (window) self
    (change-layout window)))

(defmethod (setf divide-equally?) :after (new-value (self aligning-distance-layouter))
  (declare (ignore new-value))
  (with-slots (window) self
    (change-layout window)))

(defmethod layout ((self aligning-distance-layouter) window)
  (with-slots ((parent window) orientation distance alignment divide-equally?) self
    (with-slots (x y width height border-width) window
      (with-slots (adjust-size? (pwidth width) (pheight height)) parent
	(flet ((reduce-parts-geometry (parts reduce-foo geometry-foo)
		 (let ((reduced-value 0))
		   (dolist (part parts)
		     (setq reduced-value
			   (funcall reduce-foo reduced-value (funcall geometry-foo part))))
		   reduced-value)))
	  (let* ((previous (previous-layouted-sibling window parent))
		 (total-width (contact-total-width window))
		 (total-height (contact-total-height window))
		 (parts (layouted-parts parent))
		 (max-extent
		   (reduce-parts-geometry
		     parts #'max
		     (case orientation
		       ((:down :up) #'contact-total-width)
		       ((:right :left) #'contact-total-height))))
		 (spacing
		   (if (or adjust-size?
			   (not divide-equally?))
		       0
		       (floor (max 0
				   (- (case orientation
					((:down :up)
					 (- (contact-height parent) (y-margins parent)))
					((:right :left)
					 (- (contact-width parent) (x-margins parent))))
				      (reduce-parts-geometry
					parts #'+
					(case orientation
					  ((:down :up) #'contact-total-height)
					  ((:right :left) #'contact-total-width)))))
			      (1+ (length parts)))))
		 (distance (if (or adjust-size?
				   (not divide-equally?))
			       distance spacing))
		 (origin (extent-origin parent))
		 (start-x (+ (point-x origin)
			     (x-margin parent)
			     (if adjust-size?
				 0
			         (case orientation
				   ((:down :up)
				    (case alignment
				      (:upper-left 0)
				      (:center
				       (floor (- pwidth (x-margins parent) max-extent) 2))
				      (:lower-right
				       (- pwidth (x-margins parent) max-extent))))
				   ((:right :left) 0)))))
		 (start-y (+ (point-y origin)
			     (y-margin parent)
			     (if adjust-size?
				 0
			         (case orientation
				   ((:right :left)
				    (case alignment
				      (:upper-left 0)
				      (:center
				       (floor (- pheight (y-margins parent) max-extent) 2))
				      (:lower-right
				       (- pheight (y-margins parent) max-extent))))
				   ((:down :up) 0)))))
		 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
			  (case orientation
			    ((:down :up)
			     (case alignment
			       (:upper-left prev-x)
			       (:center (+ start-x (floor (- max-extent total-width) 2)))
			       (:lower-right (+ start-x (- max-extent total-width)))))
			    (:right (+ prev-end-x distance))
			    (:left  (- prev-x total-width distance)))
			  new-y
			  (case orientation
			    (:down (+ prev-end-y distance))
			    (:up   (- prev-y total-height distance))
			    ((:right :left)
			     (case alignment
			       (:upper-left prev-y)
			       (:center (+ start-y (floor (- max-extent total-height) 2)))
			       (:lower-right (+ start-y (- max-extent total-height)))))))))
		(setq new-x
		      (case orientation
			((:down :up)
			 (case alignment
			   (:upper-left start-x)
			   (:center (+ start-x (floor (- max-extent total-width) 2)))
			   (:lower-right (+ start-x (- max-extent total-width)))))
			((:right :left) (+ start-x spacing)))
		      new-y
		      (case orientation
			((:right :left)
			 (case alignment
			   (:upper-left start-y)
			   (:center (+ start-y (floor (- max-extent total-height) 2)))
			   (:lower-right (+ start-y (- max-extent total-height)))))
			((:down :up) (+ start-y spacing)))))
	    (values new-x new-y width height border-width)))))))

;_______________________________________________________________________________
;
;                                Offset Layouters
;_______________________________________________________________________________

(defclass offset-layouter (layouter)
  ((offset :type point :initform (point 10 10) :accessor offset :initarg :offset))
  (:documentation "layouter that positions its windows with constant offset"))

(defmethod (setf offset) :after (new-offset (self offset-layouter))
  (declare (ignore new-offset))
  (with-slots (window) self
    (change-layout window)))

(defmethod layout ((self offset-layouter) window)
  (with-slots ((parent window) offset) self
    (with-slots (x y width height border-width) window
      (let ((previous (previous-layouted-sibling window parent)))
	(let (new-x new-y)
	  (if previous
	      (with-slots ((prev-x x) (prev-y y)) previous
		(setq new-x (+ prev-x (point-x offset))
		      new-y (+ prev-y (point-y offset))))
	      (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 width height border-width))))))

;_______________________________________________________________________________
;
;                                Multiline Distance Layouter
;_______________________________________________________________________________

(defclass multiline-distance-layouter (distance-layouter)
  ((items-per-line :initform 1
		   :accessor items-per-line :initarg :items-per-line)
   (line-offset :initform 10
		:accessor line-offset :initarg :line-offset))
  (:documentation "layouter that positions its windows with constant distance
                   according to orientation in multiple line/rows"))

(defmethod (setf items-per-line) :after (new-val (self multiline-distance-layouter))
  (declare (ignore new-val))
  (with-slots (window) self
    (change-layout window)))

(defmethod (setf line-offset) :after (new-val (self multiline-distance-layouter))
  (declare (ignore new-val))
  (with-slots (window) self
    (change-layout window)))

(defmethod layout ((self multiline-distance-layouter) window)
  (with-slots ((parent window) orientation distance items-per-line
	       line-offset) self
    (with-slots (x y width height border-width) window
      (let* ((previous (previous-layouted-sibling window parent))
	     (layouted-children (layouted-parts parent))
	     (pos (or (position window layouted-children)
		     (length layouted-children)))
	     (newline? (= 0 (mod pos items-per-line)))
	     (?th-line (floor (/ pos items-per-line)))
	     (total-width (contact-total-width window))
	     (total-height (contact-total-height window))
	     (origin (extent-origin parent))
	     new-x new-y)
	(if previous
	    (if newline?
		(case orientation
		  ((:down :up)
		    (setq new-x (+ (* ?th-line line-offset)
				   (point-x origin)
				   (x-margin parent))
			  new-y (y-margin parent)))
		  
		  ((:left :right)
		   (setq new-x (x-margin parent)
			 new-y (+ (* ?th-line line-offset)
				  (point-y origin)
				  (y-margin parent)))))
	      (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 (case orientation
				  ((:down :up) prev-x)
				  (:right (+ prev-end-x distance))
				  (:left  (- prev-x total-width distance)))
			  new-y (case orientation
				  (:down (+ prev-end-y distance))
				  (:up   (- prev-y total-height distance))
				  ((:right :left) prev-y))))))
	  (setq new-x (+ (point-x origin) (x-margin parent))
		new-y (+ (point-y origin) (y-margin parent))))
	(values new-x new-y width height border-width)))))


;;;_____________________________________________________
;;;
;;; An improved version of MULTILINE-DSITANCE-LAYOUTER
;;;_____________________________________________________

(defclass aligning-multiline-distance-layouter
    (aligning-distance-layouter multiline-distance-layouter)
  ((alignment :initform :center))
  (:documentation "A multiline distance layouter that aligns its windows
                   and optionally divides windows evenly if the parent is not
                   self-adjusting."))


;;; 05/14/1991 (Hubertus):
;;; 
;;; If you intend to collect examples for very ugly usage of Lisp/CLOS,
;;; the following method might be a promising candidate.
;;; Otherwise I strongly encourage you to CLOSE YOUR EYES NOW! 
;;;
(defmethod layout ((self aligning-multiline-distance-layouter) window)
  (with-slots ((parent window) orientation distance alignment divide-equally?
	       items-per-line line-offset) self
    (with-slots (x y width height border-width) window
      (with-slots (adjust-size?) parent
	(flet ((reduce-parts-geometry (parts reduce-foo geometry-foo)
		 (let ((reduced-value 0))
		   (dolist (part parts)
		     (setq reduced-value
			   (funcall reduce-foo reduced-value (funcall geometry-foo part))))
		   reduced-value))
	       (parts-in-line (window parts)
		 (if adjust-size?
		     (let* ((lines (floor (position window parts)
					  items-per-line))
			    (items (* lines items-per-line)))
		       (values (subseq parts
				       items
				       (min (+ items items-per-line)
					    (length parts)))
			       (subseq parts 0 items)))
		   (do* ((pextent
			 (case orientation
			   ((:left :right)
			    (- (contact-width parent) (x-margins parent)))
			   ((:down :up)
			    (- (contact-height parent) (y-margins parent)))))
			 (i 0 (1+ i))
			 (rest parts (cdr rest))
			 (p (first rest) (first rest))
			 (start 0)
			 (p-found? nil)
			 (extent 0)
			 (wextent))
		       ((null p)
			(values (subseq parts start i)
				(subseq parts 0 start)))		     
		     (setq wextent
			 (case orientation
			   ((:down :up) (contact-total-height p))
			   ((:left :right) (contact-total-width p))))
		     (incf extent wextent)
		     (cond ((> extent pextent)
			    (if p-found?
				(setq rest nil
				      i (1- i))
			      (setq start i
				    extent (+ wextent distance))))
			   (t (incf extent distance)))
		     (when (eq p window)
		       (setq p-found? t))))))
	  (let* ((previous (previous-layouted-sibling window parent))
		 (total-width (contact-total-width window))
		 (total-height (contact-total-height window))
		 (parts (layouted-parts parent)))
	    (multiple-value-bind (parts-in-line parts-before)
		(parts-in-line window parts)
	      (let* ((max-extent
		      (reduce-parts-geometry
		       parts-in-line #'max
		       (case orientation
			 ((:down :up) #'contact-total-width)
			 ((:right :left) #'contact-total-height))))
		     (spacing
		      (if (or adjust-size?
			      (not divide-equally?))
			  0
			(floor (max 0
				    (- (case orientation
					 ((:down :up)
					  (- (contact-height parent) (y-margins parent)))
					 ((:right :left)
					  (- (contact-width parent) (x-margins parent))))
				       (reduce-parts-geometry
					parts-in-line #'+
					(case orientation
					  ((:down :up) #'contact-total-height)
					  ((:right :left) #'contact-total-width)))))
			       (1+ (length parts-in-line)))))
		     (distance (if (or adjust-size?
				       (not divide-equally?))
				   distance spacing))
		     (origin (extent-origin parent))
		     (start-x (+ (if parts-before 0 (point-x origin))
				 (case orientation
				   ((:down :up)
				    (+ (if parts-before
					   line-offset
					 (x-margin parent))
				       (reduce-parts-geometry
					parts-before #'max #'contact-end-x)))
				   ((:left :right) (x-margin parent)))))
		     (start-y (+ (if parts-before 0  (point-y origin))
				 (case orientation
				   ((:down :up) (y-margin parent))
				   ((:left :right)
				    (+ (if parts-before
					   line-offset
					 (y-margin parent))
				       (reduce-parts-geometry
					parts-before #'max #'contact-end-y))))))
		     (newline? (eq (first parts-in-line) 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
			  (case orientation
			    ((:down :up)
			     (case alignment
			       (:upper-left start-x)
			       (:center (+ start-x (floor (- max-extent total-width) 2)))
			       (:lower-right (+ start-x (- max-extent total-width)))))
			    (:right (if newline?
					(+ start-x spacing)
				      (+ prev-end-x distance)))
			    (:left  (if newline?
					(+ start-x spacing)
				      (- prev-x total-width distance))))
			  new-y
			  (case orientation
			    (:down (if newline?
				       (+ start-y spacing)
				     (+ prev-end-y distance)))
			    (:up   (if newline?
				       (+ start-y spacing)
				     (- prev-y total-height distance)))
			    ((:right :left)
			     (case alignment
			       (:upper-left start-y)
			       (:center (+ start-y (floor (- max-extent total-height) 2)))
			       (:lower-right (+ start-y (- max-extent total-height)))))))))
		(setq new-x
		      (case orientation
			((:down :up)
			 (case alignment
			   (:upper-left start-x)
			   (:center (+ start-x (floor (- max-extent total-width) 2)))
			   (:lower-right (+ start-x (- max-extent total-width)))))
			((:right :left) (+ start-x spacing)))
		      new-y
		      (case orientation
			((:right :left)
			 (case alignment
			   (:upper-left start-y)
			   (:center (+ start-y (floor (- max-extent total-height) 2)))
			   (:lower-right (+ start-y (- max-extent total-height)))))
			((:down :up) (+ start-y spacing)))))
	    (values new-x new-y width height border-width)))))))))

;;; YOU CAN OPEN YOUR EYES AGAIN!
;;;


