;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XAM
;;;                       Module: pane layout
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/pane-layout.lisp
;;; File Creation Date: 02/07/92 15:43:40
;;; Last Modification Time: 10/09/92 10:10:07
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

(defmethod select-layout-meta-sheet-for ((self paned-window))
  (update-pane-meta-menu-for self)
  (let ((layout-sheet (make-meta-pane-layout-sheet self)))
    (hide-unable layout-sheet)
    (popup layout-sheet)))

(defmethod new-layouter ((self paned-window) config)
  (let ((pane-layouter (make-instance 'pane-layouter
                                      :window self
                                      :configuration (car config)
                                      :configurations (list config))))
    (initialize-configurations pane-layouter)
    (setf (layouter self) pane-layouter)))

(defmethod make-meta-pane-layout-sheet ((self paned-window))
  (while-busy nil
    (make-window
     'shadow-popup-margined-window
     :name :meta-pane-layout-sheet
     :parent (toplevel-window self)
     :popup-for-window self
     :reactivity-entries 
     `((:double-right-button "Generate Layout" 
			     (call :self generate-layouter)))
     :adjust-size? t
     :destroy-after? t
     :hide-on-mouse-exit? nil
     :margins 
     `((standard-margins
	:label-options
	(:name :label
	       :display-position :center
	       :text "Pane Layout")
	:quad-space-options
	(:name :space
	       :thickness 1)))
     :client-window 
     `(pane-layout-part
       :width ,(contact-width self)
       :height ,(contact-height self)
       :adjust-size? nil
       :border-width 1
       :background 0))))
     
(defmethod generate-layouter ((self shadow-popup-margined-window))
  (while-busy nil
    (let* ((layouter-window (client-window self))
	   (tree-of-nodes (car (tree layouter-window)))
	   (layouter (convert-tree-to-layouter tree-of-nodes))
	   (new-layouter (if (eq (nth 2 layouter) :h)
			     `(,(read-from-string (genstring "configuration"))
			       ((area :rest :h ,@(subseq layouter 3))))
			   `(,(read-from-string (genstring "configuration"))
			     (,@(subseq layouter 3))))))
      (do-hide self)
      (new-layouter (paned-window layouter-window) new-layouter))))

;___________________________________________________________________________
;
;                      pane layout part 
;___________________________________________________________________________

(defcontact pane-layout-part (intel)
  ((kind-of-width :type (member nil :ask :realtive :absolute :rest :even)
                  :accessor kind-of-width
                  :initarg :kind-of-width
                  :initform :absolute)
   (kind-of-height :type (member nil :ask :realtive :absolute :rest :even)
                   :accessor kind-of-height
                   :initarg :kind-of-height
                   :initform :absolute)
   (ask-whoom-for-width :accessor ask-whoom-for-width
                        :initarg :ask-whoom-for-width
                        :initform nil)
   (ask-whoom-for-height :accessor ask-whoom-for-height
                         :initarg :ask-whoom-for-height
                         :initform nil)
   (pane-width :accessor pane-width :initform 1)
   (pane-height :accessor pane-height :initform 1)
   (relative-pane-width :accessor relative-pane-width :initform 0.01)
   (relative-pane-height :accessor relative-pane-height :initform 0.01)
   (name-of-pane :accessor name-of-pane :initform nil)
   (direction :type (member nil :vertical :horizontal)
              :accessor direction
              :initarg :direction
              :initform nil)
   (reactivity :initform 
               `((:metasystem "Specify pane properties"
		  (call :self select-pane-meta-menu))
		 (:menu "Menu"
                  (call :self select-meta-pane-layout-menu))))))

(defmethod select-meta-pane-layout-menu ((self pane-layout-part))
  (declare (special *meta-pane-layout-menu*))
  (unless (and (boundp '*meta-pane-layout-menu*) *meta-pane-layout-menu*)
    (setf *meta-pane-layout-menu* (make-meta-pane-layout-menu)))
  (setf (view-of *meta-pane-layout-menu*) self)
  (popup *meta-pane-layout-menu*))

(defun destroy-meta-pane-layout-menu ()
  (declare (special *meta-pane-layout-menu*))
  (destroy-and-make-unbound *meta-pane-layout-menu*))

(defun make-meta-pane-layout-menu ()
  (while-busy nil
    (make-window 
     'shadow-popup-text-menu    
     :name :main-menu
     :destroy-after? nil
     :reactivity-entries
     `((:part-event 
        (call :eval (funcall *part-value* (view-of *self*)))))
     :parts 
     `((:view-of new-part-horizontal
        :text "Horizontal Cut"
	:action-docu "Divide pane horizontally")
       (:view-of new-part-vertical
        :text "Vertical Cut"
	:action-docu "Divide pane vertically")
       (:view-of select-pane-meta-menu
        :text "Specify"
        :action-docu "Specify pane properties")))))

(defun get-pane-meta-menu ()
  (declare (special *pane-meta-menu*))
  (unless (and (boundp '*pane-meta-menu*) *pane-meta-menu*)
    (setq *pane-meta-menu* (make-pane-meta-menu)))
  *pane-meta-menu*)

(defmethod select-pane-meta-menu ((self pane-layout-part))
  (let ((pane-meta-menu (get-pane-meta-menu)))
    (change-kind-of-width self :absolute) ;?
    (change-kind-of-height self :absolute) ;?
    (setf (view-of pane-meta-menu) self)
    (popup pane-meta-menu)))

(defun destroy-pane-meta-menu ()
  (declare (special *pane-meta-menu*))
  (destroy-and-make-unbound *pane-meta-menu*))

(defmethod update-pane-meta-menu-for ((self paned-window))
  (let ((menu
	 (part (part (client-window (get-pane-meta-menu)) :pane-name) :value)))
	   (setf (parts menu)
	       (cons '(:view-of empty
		       :action-docu "empty"
		       :text "empty")
		     (mapcar #'(lambda (name)  
				 `(:view-of ,name 
				   :action-docu ,(string name) 
				   :text ,(string name)))
			     (mapcar #'contact-name 
				     (parts self)))))))

(defmethod make-pane-meta-menu ()
  (while-busy nil
    (make-window 
     'shadow-popup-margined-window
     :name :property-sheet
     :destroy-after? nil
     :margins 
     `((standard-margins
        :label-options
        (:name :label
               :inside-border 3
	       :text "Pane Properties")
        :quad-space-options
        (:name :space
               :thickness 1)))
     :client-window
     `(property-sheet
       :border-width 1
       :adjust-size? t
       :reactivity-entries
       ((:shift-left-button
         "Read attribute values of Menu"
         (call :read)))
       :parts 
       ((:label "name"
	 :name :pane-name
	 :read-function name-of-pane
	 :write-function (lambda (view-of value)
			   (setf (name-of-pane view-of) value)
			   (get-shaded view-of))
	 :read-initially? nil
	 :value-part
	 (:class single-choice-text-menu
	  :layouter (distance-layouter :orientation :right)))
        (:label "width"
         :read-function kind-of-width
         :write-function (lambda (view-of value)
                               (change-kind-of-width view-of value))
	 :read-initially? nil
	 :reactivity-entries
	 ((:write-event
	   (call :self write-value)
	   (call :part-of read-from-application)))
         :value-part
         (:class single-choice-text-menu
          :layouter (distance-layouter :orientation :right)
          :parts 
          ((:view-of :absolute :action-docu ":absolute" :text ":absolute")
           (:view-of :relative :action-docu ":relative" :text ":relative")
           (:view-of :rest :action-docu ":rest" :text ":rest")
           (:view-of :even :action-docu ":even" :text ":even")
           (:view-of :ask :action-docu ":ask" :text ":ask"))))
         (:class text-property-field
          :name :whoom-width
          :label "ask width of"
          :read-function ask-whoom-for-width
	  :read-initially? nil
	  :reactivity-entries
	  ((:read-event
	    (call :self read-value)
	    (call :eval (setf (contact-sensitive *self*)
			    (if (ask-whoom-for-width (view-of *self*))
				:on :off)))
	    (call :self update))))
         (:label "height"
          :read-function kind-of-height
          :write-function (lambda (view-of value)
                               (change-kind-of-height view-of value))
          :read-initially? nil
	  :reactivity-entries
	  ((:write-event
	    (call :self write-value)
	    (call :part-of read-from-application)))
         :value-part
          (:class single-choice-text-menu
           :layouter (distance-layouter :orientation :right)
           :parts 
           ((:view-of :absolute :action-docu ":absolute" :text ":absolute")
            (:view-of :relative :action-docu ":relative" :text ":relative")
            (:view-of :rest :action-docu ":rest" :text ":rest")
            (:view-of :even :action-docu ":even" :text ":even")
            (:view-of :ask :action-docu ":ask" :text ":ask"))))
          (:class text-property-field
           :name :whoom-height
           :label "ask height of"
           :read-function ask-whoom-for-height
	   :read-initially? nil
	   :reactivity-entries
	   ((:read-event
	     (call :self read-value)
	     (call :eval (setf (contact-sensitive *self*)
			     (if (ask-whoom-for-height (view-of *self*))
				 :on :off)))
	     (call :self update)))))))))
   
(defmethod change-kind-of-width ((self pane-layout-part) new-kind)
  (setf (kind-of-width self) new-kind)
  (case new-kind
    (:absolute (setf (pane-width self) (contact-width self))
	       (setf (ask-whoom-for-width self) nil))
    (:relative (setf (relative-pane-width self) 
                     (float (/ (contact-width self)
                               (contact-width (part-of self)))))
	       (setf (ask-whoom-for-width self) nil))
    (:ask (setf (ask-whoom-for-width self) (name-of-pane self)))
    (t (setf (ask-whoom-for-width self) nil)))
  (if (equal (direction (part-of self)) :horizontal)
      (propagate-width (get-root-of-horizontal-panes self) 
                       new-kind
                       (case new-kind
                             (:absolute (pane-width self))
                             (:relative (relative-pane-width self))
                             (:ask (name-of-pane self))))))

(defmethod change-kind-of-height ((self pane-layout-part) new-kind)
  (setf (kind-of-height self) new-kind)
  (case new-kind
    (:absolute (setf (pane-height self) (contact-height self))
	       (setf (ask-whoom-for-height self) nil))
    (:relative (setf (relative-pane-height self) 
                     (float (/ (contact-height self)
                               (contact-height (part-of self)))))
	       (setf (ask-whoom-for-height self) nil))
    (:ask (setf (ask-whoom-for-height self) (name-of-pane self)))
    (t (setf (ask-whoom-for-height self) nil)))
  (if (equal (direction (part-of self)) :vertical)
      (propagate-height (get-root-of-vertical-panes self) 
                       new-kind
                       (case new-kind
                         (:absolute (pane-height self))
                         (:relative (relative-pane-height self))
                         (:ask (name-of-pane self))))))

(defmethod new-part-horizontal ((self pane-layout-part))
  (multiple-value-bind (pointer-x pointer-y)
      (pointer-position self)
    (new-pane-layout-part self :horizontal
			  (contact-width self)
			  (max 1 (min pointer-y (contact-height self))))))

(defmethod new-part-vertical ((self pane-layout-part))
  (multiple-value-bind (pointer-x pointer-y)
      (pointer-position self)
    (new-pane-layout-part self :vertical
			  (max 1 (min pointer-x (contact-width self)))
			  (contact-height self))))

(defmethod new-pane-layout-part ((self pane-layout-part)
				 direction width height)
  (setf (direction self) direction)
  (multiple-value-bind (pointer-x pointer-y)
      (pointer-position self)
    (let ((new-part
	   (make-window
	    'pane-layout-part 
	    :parent self
	    :x -1 :y -1
	    :width width
	    :height height
	    :adjust-size? nil
	    :border-width 0)))
      (multiple-value-bind (width height)
	  (move-cut new-part direction)
	(make-rest-window self direction width height)))))
  
(defmethod move-cut ((self pane-layout-part) direction)
  (with-slots (display parent (contact-x x) (contact-y y)) self
    (using-gcontext (gc :drawable parent :subwindow-mode :include-inferiors
                        :function BOOLE-XOR :foreground 1 :line-width 2)
      (let* ((width (contact-total-width self))
             (height (contact-total-height self))
             (x-pos (contact-end-x self))
             (y-pos (contact-end-y self)))
        (warp-pointer parent x-pos y-pos)
        (process-all-events display)
        (grab-pointer parent
                      '(:button-press :pointer-motion) 
                      :owner-p t
                      :confine-to parent
                      :cursor (convert self "sizing" 'cursor)
                      :time nil)
        (draw-rectangle-inside parent gc contact-x contact-y width height)
        (unwind-protect
            (event-case (display :discard-p t :force-output-p t)
               (motion-notify 
                (x y event-window)
                (draw-rectangle-inside 
                 parent gc
                 contact-x contact-y width height)
                (multiple-value-bind (parent-x parent-y)
                                (contact-translate event-window x y parent)
                  (case direction
                        (:vertical
                         (setq width (max 1 (- parent-x contact-x))))
                        (:horizontal
                         (setq height (max 1 (- parent-y contact-y))))))
                (draw-rectangle-inside parent gc
                                     contact-x contact-y width height)
                nil)
               (button-press (x y event-window)
                 (draw-rectangle-inside parent gc
                                      contact-x contact-y width height)
                 (multiple-value-bind (parent-x parent-y)
                                 (contact-translate event-window x y parent)
                   (case direction
                         (:vertical (setq width (- parent-x contact-x)))
                         (:horizontal (setq height (- parent-y contact-y)))))
                 t))
          (ungrab-pointer display))
        (setq width
              (cond 
               ((< width 1) 1)
               ((> width (- (contact-width (part-of self)) 2))
                (- (contact-width (part-of self)) 1))
               (t width)))
        (setq height
              (cond 
               ((< height 1) 1)
               ((> height (- (contact-height (part-of self)) 2))
                (- (contact-height (part-of self)) 1))
               (t height)))
        (resize-window self width height)
	(change-window-border-width self 1)
        (values width height)))))

(defmethod make-rest-window 
  ((self pane-layout-part) direction planed-width planed-height)
  (let ((x (case direction (:vertical planed-width) (:horizontal -1)))
        (y (case direction (:vertical -1) (:horizontal planed-height)))
        (width (case direction
                 (:vertical (- (contact-width self) planed-width))
                 (:horizontal (contact-width self))))
        (height (case direction
                  (:vertical (contact-height self))
                  (:horizontal (- (contact-height self) planed-height)))))
    (make-window 
     'pane-layout-part 
     :parent self
     :x x
     :y y
     :width width
     :height height
     :adjust-size? nil
     :border-width 1
     :background 0)))
                        
(defmethod set-width ((self pane-layout-part) kind-of-width value)
  (setf (kind-of-width self) kind-of-width)
  (case kind-of-width
        (:absolute (setf (pane-width self) value))
        (:relative (setf (relative-pane-width self) value))
        (:ask (setf (ask-whoom-for-width self) value)))
  ;(update-property-sheet self) ;; to be removed
  )
      
(defmethod propagate-width ((self pane-layout-part) kind-of-width value)
  (case (direction self)
    (:horizontal (set-width self kind-of-width value)
                 (dolist (part (parts self))
                   (propagate-width part kind-of-width value)))
    (:vertical nil)
    (t (set-width self kind-of-width value))))
                
(defmethod set-height ((self pane-layout-part) kind-of-height value)
  (setf (kind-of-height self) kind-of-height)
  (case kind-of-height
        (:absolute (setf (pane-height self) value))
        (:relative (setf (relative-pane-height self) value))
        (:ask (setf (ask-whoom-for-height self) value)))
  ;(update-property-sheet self) ;;to be removed
  )
             
(defmethod propagate-height ((self pane-layout-part) kind-of-height value)
  (case (direction self)
        (:horizontal nil) 
        (:vertical (set-height self kind-of-height value)
                   (dolist (part (parts self))
                     (propagate-height part kind-of-height value)))
        (t (set-height self kind-of-height value))))

(defmethod get-root-of-horizontal-panes ((self pane-layout-part))
  (do ((window self (part-of window)))
    ((or (not  (slot-exists-p (part-of window) 'direction))
         (eq (direction (part-of window)) :vertical)) 
     window)))
     
(defmethod get-root-of-vertical-panes ((self pane-layout-part))
  (do ((window self (part-of window)))
    ((or (not  (slot-exists-p (part-of window) 'direction))
         (eq (direction (part-of window)) :horizontal)) 
     window)))
     
(defmethod paned-window ((self pane-layout-part))
  (do ((window self (part-of window)))
    ((typep window 'shadow-popup-margined-window)
     (popup-for-window window))))

(defmethod get-shaded ((self pane-layout-part))
  (setf (contact-background self) 0.5)
  (update self))

;-----------------------------------------------------------------------------
; structure layout-node for building a tree of nodes representing 
; the splitted paned-window
;-----------------------------------------------------------------------------

(defstruct layout-node 
  name
  kind-of-size
  size-value
  direction
  (subnodes nil))
  
(defmethod get-width ((self pane-layout-part))
  (case (kind-of-width self)
        (:absolute (pane-width self))
        (:relative (relative-pane-width self))
        (:ask (ask-whoom-for-width self))))

(defmethod get-height ((self pane-layout-part))
  (case (kind-of-height self)
        (:absolute (pane-height self))
        (:relative (relative-pane-height self))
        (:ask (ask-whoom-for-height self))))

(defmethod tree ((self pane-layout-part) &optional old-direction)
   (with-slots (children direction name) self
    (if (and children (equal old-direction direction))
        (append (tree (car children) direction)
                (tree (cadr children) direction))
      (list
       (cond 
        (children
         (make-layout-node
          :subnodes
          (append (tree (car children) direction)
                  (tree (cadr children) direction))
          :direction direction
          :kind-of-size
          (case direction
                (:horizontal (kind-of-width self))
                (:vertical (kind-of-height self)))
          :size-value
          (case direction
                (:horizontal (get-width self))
                (:vertical (get-height self)))))
        (t 
         (make-layout-node
          :name (name-of-pane self)
          :kind-of-size
          (case old-direction
                (:horizontal (kind-of-height self))
                (:vertical (kind-of-width self)))
          :size-value
          (case old-direction
                (:horizontal (get-height self))
                (:vertical (get-width self))))))))))

(defun convert-tree-to-layouter (node)
  (when node
    (cond
     ((layout-node-direction node)
      (do ((nodes  (layout-node-subnodes node) (cdr nodes))
           (result (list 
                    'area
                    (case (layout-node-kind-of-size node)
                      ((:absolute :relative) (layout-node-size-value node))
                      (:ask (list :ask (layout-node-size-value node)))
                      (:rest :rest)
                      (:even :even)) 
                    (case (layout-node-direction node)
                      (:horizontal :v)
                      (:vertical :h)))
                   (append result 
                           (list (convert-tree-to-layouter (car nodes))))))
          ((null nodes) result)))
     (t
      (list (layout-node-name node)
            (case (layout-node-kind-of-size node)
              ((:absolute :relative) (layout-node-size-value node))
              (:ask :ask)
              (:rest :rest)
              (:even :even)))))))

(defmethod destroy :before ((self pane-layout-part))
  (broadcast self #'destroy))


