
(in-package "INSPECT")

(defgeneric make-title-item (object object-view pane parent)
  (:argument-precedence-order object-view object pane parent))

(defgeneric fixed-item-list (object object-view parent)
  (:argument-precedence-order object-view object parent))

(defgeneric variable-items-count-function (object object-view)
  (:argument-precedence-order object-view object))

(defgeneric variable-item-creator-function (object object-view parent)
  (:argument-precedence-order object-view object parent))		    

(defclass property-value-list-item (item)
  ((object :initform nil :initarg :object)
   (object-view :initform nil :initarg :object-view)
   (total-items-count :initform 0 :reader scroll-total-size)
   (visible-items-count :initform 0 :reader scroll-visible-size)
   (top-item-index :initform 0 :reader scroll-top-position)
   (pvi-fixed-item-list :initform nil)
   (pvi-variable-item-vector :initform nil)
   (pvi-variable-items-count-function :initform nil)
   (pvi-variable-item-creator-function :initform nil))
  (:default-initargs :direction-of-children :vertical
                     :size-within-parent :even
		     :border-width 0))

#+pcl (pcl::do-standard-defsetf scroll-top-position)

(defmethod initialize-instance :after ((item property-value-list-item) &key)
  (with-slots (object object-view)
    item
    (set-object-and-object-view item
				#-pcl object
				#+pcl (if (slot-boundp item 'object)
					  object
					  pcl::*slot-unbound*)
				object-view)))

(defmethod set-object-and-object-view ((item property-value-list-item)
				       new-object new-object-view)
  (with-slots (object object-view total-items-count pvi-fixed-item-list 
		      pvi-variable-item-vector pvi-variable-items-count-function
		      pvi-variable-item-creator-function pane)
    item
    (setq object new-object) (setq object-view new-object-view)
    (let ((object new-object))
      (setq pvi-variable-items-count-function
	    (variable-items-count-function object object-view))
      (setq pvi-fixed-item-list 
	    (nconc (fixed-item-list object object-view item)
		   (when pvi-variable-items-count-function
		     (list (make-instance 'property-value-item
					  ':parent item ':pane pane)))))
      (when pvi-variable-items-count-function
	(setq pvi-variable-item-vector
	      (let ((size (funcall pvi-variable-items-count-function)))
		(make-array size ':fill-pointer size
			    ':adjustable t ':initial-element nil)))
	(setq pvi-variable-item-creator-function
	      (variable-item-creator-function object object-view item)))
      (setq total-items-count (+ (length pvi-fixed-item-list)
				 (if pvi-variable-item-vector
				     (fill-pointer pvi-variable-item-vector)
				     0)))
      (setf (scroll-top-position item) 0)
      item)))

(defmethod (setf scroll-top-position) (new-position (item property-value-list-item))
  (with-slots (height visible-items-count top-item-index total-items-count
		      pvi-fixed-item-list pvi-variable-item-vector
		      pvi-variable-item-creator-function item-list)
    item
    (setq visible-items-count (floor (if (slot-boundp item 'height) height 0)
				     (font-height item)))
    (setq top-item-index (if (<= total-items-count visible-items-count)
			     0
			     (min (- total-items-count visible-items-count)
				  (max new-position 0))))
    (let* ((bottom-item-limit (min total-items-count 
				   (+ top-item-index visible-items-count)))
	   (new-item-list-size (- bottom-item-limit top-item-index))
	   (new-item-list (make-list new-item-list-size))
	   (new-item-list-tail new-item-list)
	   (fixed-item-list-size (length pvi-fixed-item-list)))
      (dotimes (i new-item-list-size)
	(let ((index (+ i top-item-index)))
	  (setf (car new-item-list-tail)
		(if (< index fixed-item-list-size)
		    (nth index pvi-fixed-item-list)
		    (let ((vindex (- index fixed-item-list-size)))
		      (or (aref pvi-variable-item-vector vindex)
			  (setf (aref pvi-variable-item-vector vindex)
				(funcall pvi-variable-item-creator-function
					 vindex))))))
	  (setq new-item-list-tail (cdr new-item-list-tail))))
      (mapc #'unmap-window (set-difference item-list new-item-list))
      (setq item-list new-item-list)
      new-position)))

(defmethod revert-fixed-item-list (object object-view (item property-value-list-item))
  (with-slots (pvi-fixed-item-list)
    item
    (mapc #'revert-item pvi-fixed-item-list)))

(defmethod revert-item ((item property-value-list-item))
  (with-slots (object object-view
	       total-items-count top-item-index pvi-fixed-item-list 
				 pvi-variable-item-vector
				 pvi-variable-items-count-function
				 pvi-variable-item-creator-function)
    item
    (let ((last (car (last pvi-fixed-item-list)))
	  (new-fil (revert-fixed-item-list #-pcl object
					   #+pcl (if (slot-boundp item 'object)
						     object
						     pcl::*slot-unbound*)
					   object-view item)))
      (setq pvi-fixed-item-list 
	    (if pvi-variable-items-count-function
		(nconc (delete last new-fil) (list last))
		new-fil)))
    (when pvi-variable-items-count-function
      (let* ((current-size (length pvi-variable-item-vector))
	     (new-size (funcall pvi-variable-items-count-function))
	     (min-size (min current-size new-size)))
	(dotimes (index min-size)
	  (let ((si (aref pvi-variable-item-vector index)))
	    (when si (revert-item si))))
	(unless (= current-size new-size)
	  (let* ((number-to-remove (- current-size min-size))
		 (current-total-size (array-dimension pvi-variable-item-vector 0))
		 (new-total-size (if (<= new-size current-total-size)
				     current-total-size
				     (+ new-size 10))))
	    (dotimes (i number-to-remove)
	      (let* ((index (+ i min-size))
		     (si (aref pvi-variable-item-vector index)))
		(when si 
		  (destroy-window-and-all-subwindows si)
		  (setf (aref pvi-variable-item-vector index) nil))))
	    (if (= current-total-size new-total-size)
		(setf (fill-pointer pvi-variable-item-vector) new-size)
		(adjust-array pvi-variable-item-vector new-total-size
			      ':fill-pointer new-size ':initial-element nil))))))
    (setq total-items-count (+ (length pvi-fixed-item-list)
			       (if pvi-variable-item-vector
				   (fill-pointer pvi-variable-item-vector)
				   0)))
    (setf (scroll-top-position item) top-item-index)))

(defmethod adjust-sizes-and-positions-of-children :before
           ((item property-value-list-item))
  (with-slots (top-item-index)
    item
    (setf (scroll-top-position item) top-item-index)))  

(defmethod print-object ((instance property-value-list-item) stream)
  (with-slots (pane)
    instance
    (if (and (slot-boundp instance 'xlib:display) pane)
	(pcl::printing-random-thing (instance stream)
           (format stream "~A Properties of ~S"
		   (class-name (class-of instance))
		   (pane-object pane)))
	(call-next-method))))

(defmethod item-documentation ((item property-value-list-item))
  (with-slots (pane)
    item
    (item-documentation pane)))

(defvar *scroll-bar-size* 10)

;scroll-total-size scroll-visible-size scroll-top-position (setf scroll-top-position)
(defclass pane-scroll-bar (item)
  ((direction)
   (object :accessor scroll-object))
  (:default-initargs :size-within-parent :ask
                     :border-width 1))

(defmethod scroll-window-p ((item item))
  nil)

(defmethod scroll-window-p ((item pane-scroll-bar))
  t)

(defvar *scroll-mouse-documentation*
  (concatenate 'string
	       "L: show previous screen   "
	       "M: scroll to this place relative to everything   "
	       "R: show next screen"))

(defmethod mouse-documentation ((item pane-scroll-bar))
  *scroll-mouse-documentation*)

(defmethod item-documentation ((item pane-scroll-bar))
  (format nil "Scroll bar for ~A" (item-documentation (item-pane item))))

(defmethod item-desired-size ((item pane-scroll-bar) size-direction)
  (with-slots (direction)
    item
    (if (eq direction size-direction)
	':even
	*scroll-bar-size*)))

(defclass vertical-scroll-bar (pane-scroll-bar)
  ((direction :initform :vertical)))

(defmethod item-cursor ((item vertical-scroll-bar))
  (inspecter-vscroll-cursor (item-inspecter item)))

(defmethod refresh-window ((item vertical-scroll-bar))
  (with-slots (state object width height)
    item
    (when (eq state 'mapped)
      (xlib:clear-area item)
      (when object
	(let* ((total-size (scroll-total-size object))
	       (visible-size (scroll-visible-size object))
	       (top-position (scroll-top-position object))
	       (bottom-position (+ top-position (1- visible-size)))
	       (max-position (1- (max total-size visible-size)))
	       (pixels (- height 2))
	       (scroll-top (floor (* top-position pixels) max-position))
	       (scroll-bottom (floor (* bottom-position pixels) max-position)))
	  (xlib:draw-rectangle item (item-draw-gc item)
			       1 (1+ scroll-top)
			       (- width 2) (1+ (- scroll-bottom scroll-top))
			       t))))))

(defmethod do-scroll ((item vertical-scroll-bar) code x y)
  (with-slots (object height)
    item
    (when object
      (let* ((total-size (scroll-total-size object))
	     (visible-size (scroll-visible-size object))
	     (top-position (scroll-top-position object))
	     (max-top-position (max 0 (- total-size visible-size)))
	     (pixels (- height 2)))
	(unless (zerop max-top-position)
	  (setf (scroll-top-position object)
		(case code
		  (1 (- top-position visible-size))
		  (2 (floor (* (- y 1) (1+ max-top-position)) pixels))
		  (3 (+ top-position visible-size))))
	  (display-item object)
	  (refresh-window item))))))

(defclass horizontal-scroll-bar (pane-scroll-bar)
  ((direction :initform :horizontal)))

(defclass pane-contents-item (item)
  ((vertical-scroll-bar)
   (contents :initform nil))
  (:default-initargs :direction-of-children :horizontal
                     :border-width 0))

(defmethod initialize-instance :after ((pci pane-contents-item) &key
				       object object-view)
  (with-slots (parent pane vertical-scroll-bar contents item-list)
    pci    
    (setq vertical-scroll-bar (make-instance 'vertical-scroll-bar
					     ':pane pane ':parent pci))
    (setq contents (make-instance 'property-value-list-item
				  ':parent pci
				  ':pane pane
				  ':object object
				  ':object-view object-view))
    (setf (scroll-object vertical-scroll-bar) contents)
    (setq item-list (list vertical-scroll-bar contents))))

(defmethod set-object-and-object-view ((pci pane-contents-item) object object-view)
  (with-slots (contents)
    pci
    (set-object-and-object-view contents object object-view)))

(defclass pane (item)
  ((index :reader pane-index)
   (object :initform nil :initarg :object #-pcl :reader #-pcl pane-object)   
   (object-view :initform nil :initarg :object-view :reader pane-object-view)
   (pci)
   (contents-item :initform nil :initarg :contents-item :reader pane-contents-item)
   (title-item :initform nil :initarg :title-item :reader pane-title-item))
  (:default-initargs :border-width nil
                     :direction-of-children :vertical
		     :size-within-parent :even))

#+pcl
(defmethod pane-object ((pane pane))
  (if (slot-boundp pane 'object)
      (slot-value pane 'object)
      pcl::*slot-unbound*))

(defmethod initialize-instance :after ((pane pane) &key)
  (with-slots (parent index pci title-item item-list object-view)
    pane
    (let ((object (pane-object pane)))
      (setq pci (make-instance 'pane-contents-item
			       ':parent pane ':pane pane
			       ':object object ':object-view object-view))
      (setq index (index-for-new-pane parent pane))
      (unless object-view
	(setq item-list nil))
      (when object-view
	(setq title-item (make-title-item object object-view pane pane))
	(setq item-list (list title-item pci))))))

(defmethod item-documentation ((pane pane))
  (with-slots (index title-item)
    pane
    (if title-item
	(format nil "Pane ~D:  ~A" index (item-documentation title-item))
	(format nil "Pane ~D" index))))

(defmethod make-reference-to-pane ((pane pane) reference-item-parent)
  (with-slots (object-view)
    pane
    (let ((object (pane-object pane)))
      (make-title-item object object-view pane reference-item-parent))))

(defmethod set-object-and-object-view ((pane pane) new-object new-object-view)
  (with-slots (object-view pci title-item contents-item item-list state)
    pane
    (let ((object (pane-object pane)))
      (unless (and (eql object new-object)
		   (eql object-view new-object-view))
	(when title-item 
	  (destroy-window-and-all-subwindows title-item)
	  (setq title-item nil))
	(setq object (setf (slot-value pane 'object) new-object))
	(setq object-view new-object-view)
	(unless (or object object-view)
	  (unmap-window pci)
	  (setq item-list nil))
	(when (or object object-view)
	  (setq title-item (make-title-item object object-view pane pane))
	  (set-object-and-object-view pci object object-view)
	  (setq item-list (list title-item pci)))
	(when (eq state 'mapped)
	  (display-item pane))))))

(defmethod make-title-item (object object-view pane parent)
  (make-instance 'object-from-pane-item
		 ':parent parent
		 ':pane pane
		 ':documentation
		 (let ((*print-pretty* nil)
		       (*print-length* 4)
		       (*print-level* 3))
		   (format nil "~A view of ~S" 
			   (class-name (class-of object-view)) object))))

(defun find-pane-with-object (list object &optional object-view-class)
  (unless object-view-class
    (setq object-view-class (first (object-view-classes-for-object object))))
  (let ((pane-p (eq object-view-class (find-class 'pane))))
    (dolist (pane list nil)
      (when (or (and pane-p (eq pane object))
		(and (eql (pane-object pane) object)
		     (eql (class-of (pane-object-view pane)) object-view-class)))
	(return pane)))))

(defun find-pane-with-no-object (list)
  (dolist (pane list nil)
    (unless (or (pane-object pane) (pane-object-view pane))
      (return pane))))

(defclass inspecter-visible-panes (item)
  ((all-panes-vector :initform (make-array 20 :fill-pointer 0 :adjustable t)
		     :reader bvp-all-panes-vector)
   (invisible-pane-list :initform nil))
  (:default-initargs :size-within-parent :even
		     :border-width 0))

(defmethod initialize-instance :after ((bvp inspecter-visible-panes) 
				       &key number-of-panes)
  (with-slots (item-list parent)
    bvp
    (when number-of-panes
      (dotimes (i number-of-panes)
	(push (make-instance 'pane :parent bvp) item-list)))
    (setq item-list (nreverse item-list))))

(defmethod add-pane ((bvp inspecter-visible-panes))
  (with-slots (invisible-pane-list item-list parent inspecter)
    bvp
    (let ((new-pane (or (pop invisible-pane-list)
			(make-instance 'pane :parent bvp))))
      (setq item-list (nconc item-list (list new-pane)))
      (revert-item inspecter)
      (display-item inspecter))))

(defmethod remove-pane ((bvp inspecter-visible-panes))
  (with-slots (invisible-pane-list item-list parent inspecter)
    bvp
    (when (and item-list (cdr item-list))
      (let ((old-pane (or (find-pane-with-no-object item-list)
			  (car item-list))))
	(setq item-list (delete old-pane item-list))
	(push old-pane invisible-pane-list)
	(unmap-window old-pane)
	(revert-item inspecter)
	(display-item inspecter)))))

(defgeneric inspecter-add-pane (item)
  (:generic-function-class operation)
  (:documentation "Add a pane to the inspecter"))

(defgeneric inspecter-remove-pane (item)
  (:generic-function-class operation)
  (:documentation "Remove a pane from the inspecter"))

(defmethod inspecter-add-pane ((item item))
  (add-pane (inspecter-visible-panes-item (item-inspecter item))))

(defmethod inspecter-remove-pane ((item item))
  (remove-pane (inspecter-visible-panes-item (item-inspecter item))))

(defmethod index-for-new-pane ((bvp inspecter-visible-panes) new-pane)
  (with-slots (all-panes-vector)
    bvp
    (prog1 (fill-pointer all-panes-vector)
      (vector-push-extend new-pane all-panes-vector))))

(defgeneric inspecter-vertical-panes (item)
  (:generic-function-class operation)
  (:documentation "Show the inspecter's panes vertically"))

(defgeneric inspecter-horizontal-panes (item)
  (:generic-function-class operation)
  (:documentation "Show the inspecter's panes horizontally"))

(defmethod inspecter-vertical-panes ((item item))
  (with-slots (inspecter)
    item
    (setf (item-direction-of-children (inspecter-visible-panes-item inspecter))
	  ':vertical)
    (revert-item inspecter)
    (display-item inspecter)))

(defmethod inspecter-horizontal-panes ((item item))
  (with-slots (inspecter)
    item
    (setf (item-direction-of-children (inspecter-visible-panes-item inspecter))
	  ':horizontal)
    (revert-item inspecter)
    (display-item inspecter)))

(defmethod replace-pane-with-pane ((bvp inspecter-visible-panes)
				   visible-pane not-visible-pane)
  (with-slots (item-list invisible-pane-list)
    bvp
    (unmap-window visible-pane)
    (setq invisible-pane-list (cons visible-pane
				    (delete not-visible-pane invisible-pane-list)))
    (setq item-list (nconc (delete visible-pane item-list) (list not-visible-pane)))
    (display-item bvp)
    not-visible-pane))

(defmethod show-object-in-inspecter ((bvp inspecter-visible-panes) object 
				     &key object-view object-view-class)
  (with-slots (item-list invisible-pane-list)
    bvp
    (when object-view (setq object-view-class (class-of object-view)))
    (when object-view-class
      (when (symbolp object-view-class)
	(setq object-view-class (find-class object-view-class)))
      (when (eq '$RoseObject (class-name object-view-class))
	(setq object-view-class nil object-view nil)))
    (unless object-view-class
      (setq object-view-class (first (object-view-classes-for-object object))))
    (let ((pane (find-pane-with-object item-list object object-view-class)))
      (when pane
	(revert-item pane)
	(setq item-list (nconc (delete pane item-list) (list pane)))
	(display-item bvp)
	(return-from show-object-in-inspecter pane)))
    (unless object-view
      (setq object-view (object-view-for-view-class object-view-class)))
    (let ((visible-no-pane (find-pane-with-no-object (reverse item-list)))
	  (not-visible-pane 
	   (find-pane-with-object invisible-pane-list object object-view-class)))
      (when (and (eq object-view-class (find-class 'pane))
		 (null not-visible-pane))
	(return-from show-object-in-inspecter nil))
      (when (and visible-no-pane (null not-visible-pane))
	(set-object-and-object-view visible-no-pane object object-view)
	(unless (eq visible-no-pane (last item-list))
	  (setq item-list (nconc (delete visible-no-pane item-list)
				 (list visible-no-pane)))
	  (display-item bvp))
	(return-from show-object-in-inspecter visible-no-pane))
      (let ((visible-pane (or visible-no-pane (car item-list))))
	(if not-visible-pane
	    (revert-item not-visible-pane)
	    (let ((not-visible-no-pane (find-pane-with-no-object invisible-pane-list)))
	      (when not-visible-no-pane
		(set-object-and-object-view not-visible-no-pane object object-view)
		(setq not-visible-pane not-visible-no-pane))))
	(unless not-visible-pane
	  (setq not-visible-pane
		(make-instance 'pane
			       ':parent bvp
			       ':object object
			       ':object-view object-view)))
	(replace-pane-with-pane bvp visible-pane not-visible-pane)))))
