
(in-package "INSPECT")

(defclass special-view-title-item (object-from-pane-item)
  ())

(defmethod compute-item-text ((item special-view-title-item))
  (item-documentation item))

(declare-next-view inspecter inspecter)

(defmethod make-title-item ((object inspecter) (object-view inspecter) pane parent)
  (make-instance 'special-view-title-item
		 ':parent parent ':pane pane
		 ':documentation "Inspecter and Pane Operations"))

(defmethod fixed-item-list ((object inspecter) (object-view inspecter) parent)
  (let ((bvp (inspecter-visible-panes-item object)))
    `(,(make-instance 'pv-operation-item
		      ':parent parent ':pane (item-pane parent)
		      ':operation 'inspecter-add-pane)
       ,@(when (< 1 (length (item-list bvp)))
	   `(,(make-instance 'pv-operation-item
		            ':parent parent ':pane (item-pane parent)
		            ':operation 'inspecter-remove-pane)))
       ,(make-instance 'pv-operation-item
		       ':parent parent ':pane (item-pane parent)
		       ':operation (case (item-direction-of-children bvp)
				     (:horizontal 'inspecter-vertical-panes)
				     (:vertical 'inspecter-horizontal-panes)))
       ,(make-instance 'pv-operation-item
		       ':parent parent ':pane (item-pane parent)
		       ':operation 'revert-inspecter)
       ,(make-instance 'pv-operation-item
		       ':parent parent ':pane (item-pane parent)
		       ':operation 'show-fonts)
       ,(make-instance 'pv-operation-item
		       ':parent parent ':pane (item-pane parent)
		       ':operation 'choose-colors)
       ,(make-instance 'pv-operation-item
		       ':parent parent ':pane (item-pane parent)
		       ':operation 'save-inspecter-parameters))))

(defmethod revert-fixed-item-list ((object inspecter) (object-view inspecter) parent)
  (fixed-item-list object object-view parent))

(defmethod variable-items-count-function ((object inspecter) (object-view inspecter))
  #'(lambda ()
      (length (bvp-all-panes-vector
	       (inspecter-visible-panes-item object)))))

(defmethod variable-item-creator-function ((object inspecter) (object-view inspecter)
					   parent)
  #'(lambda (index)
      (let ((so (format nil "Pane ~D" index)))
	(make-instance 'property-value-item
		       ':parent parent ':pane (item-pane parent)
		       ':slot-object so
		       ':reader 
		       #'(lambda (object)
			   (aref (bvp-all-panes-vector
				  (inspecter-visible-panes-item object))
				 index))
		       ':description so))))

(declare-next-view pane pane)

(defclass fonts-view (standard-object)
  ())

(defmethod make-title-item ((object inspecter) (object-view fonts-view) pane parent)
  (make-instance 'special-view-title-item
		 ':parent parent
		 ':pane pane
		 ':documentation "The fonts available from the server"))

(defmethod fixed-item-list ((object inspecter) (object-view fonts-view) parent)
  nil)

(defmethod variable-items-count-function ((object inspecter) (object-view fonts-view))
  #'(lambda ()
      (length (inspecter-all-font-names object))))

(defmethod variable-item-creator-function ((object inspecter) (object-view fonts-view)
					   parent)
  #'(lambda (index)
      (let ((name (nth index (inspecter-all-font-names object))))
	(make-instance 'font-item
		       ':parent parent ':pane (item-pane parent)
		       ':text name
		       ':documentation name))))

(defclass font-item (text-item)
  ())

(defmethod operation-entry ((item font-item) item-or-nil)
  (build-entry 'set-inspecter-font-op 'set-inspecter-documentation-font-op))

(defgeneric set-inspecter-font-op (font-item)
  (:generic-function-class operation)
  (:documentation "Set the inspecter's font"))

(defgeneric set-inspecter-documentation-font-op (font-item)
  (:generic-function-class operation)
  (:documentation "Set the inspecter's documentation font"))

(defmethod set-inspecter-font-op ((item font-item))
  (with-slots (text)
    item
    (set-inspecter-font item text)))

(defmethod set-inspecter-documentation-font-op ((item font-item))
  (with-slots (text)
    item
    (set-inspecter-documentation-font item text)))

(defgeneric show-fonts (item)
  (:generic-function-class operation)
  (:documentation "Show the fonts available from the server"))

(defmethod show-fonts ((item item))
  (with-slots (inspecter)
    item
    (show-object-in-inspecter inspecter inspecter ':object-view-class 'fonts-view)))

(defgeneric choose-colors (item)
  (:generic-function-class operation)
  (:documentation "Choose colors for the inspecter"))

(defmethod choose-colors ((item item))
  (with-slots (inspecter)
    item
    (show-object-in-inspecter inspecter inspecter ':object-view-class 'colors-view)))

(defclass colors-view (standard-object)
  ())

(defmethod make-title-item ((object inspecter) (object-view colors-view) pane parent)
  (make-instance 'special-view-title-item
		 ':parent parent
		 ':pane pane
		 ':documentation "The named colors available"))

(defmethod fixed-item-list ((object inspecter) (object-view colors-view) parent)
  (let ((class (class-of object)))
    (nconc (list (make-instance 'pv-operation-item
				':parent parent ':pane (item-pane parent)
				':operation 'set-colors)
		 (make-instance 'property-value-item
				':parent parent ':pane (item-pane parent)))
	   (mapcar #'(lambda (slot-name)
		        (let ((slotd (pcl::find-slot-definition class slot-name)))
			  (make-instance 'object-slot-item
					 ':parent parent ':pane (item-pane parent)
					 ':slot-definition slotd)))
		   '(foreground-color-name
		     background-color-name
		     border-color-name)))))

(defmethod variable-items-count-function ((object inspecter) (object-view colors-view))
  #'(lambda ()
      (length (all-color-names))))

(defmethod variable-item-creator-function ((object inspecter) (object-view colors-view)
					   parent)
  #'(lambda (index)
      (let ((name (nth index (all-color-names))))
	(make-instance 'color-item
		       ':parent parent ':pane (item-pane parent)
		       ':text name
		       ':documentation
		       (let ((lcolor (gethash name *color-table*)))
			 (format nil "~A   (red: ~5,3F) (green: ~5,3F) (blue: ~5,3F)"
				 name 
				 (first lcolor) (second lcolor) (third lcolor)))))))

(defclass color-item (text-item)
  ())

(defmethod operation-entry ((item color-item) item-or-nil)
  (build-entry 'set-inspecter-foreground-color-name-op
	       'set-inspecter-background-color-name-op
	       'set-inspecter-border-color-name-op))

(defgeneric set-inspecter-foreground-color-name-op (color-item)
  (:generic-function-class operation)
  (:documentation "Set the inspecter's foreground color name"))

(defgeneric set-inspecter-background-color-name-op (color-item)
  (:generic-function-class operation)
  (:documentation "Set the inspecter's background color name"))

(defgeneric set-inspecter-border-color-name-op (color-item)
  (:generic-function-class operation)
  (:documentation "Set the inspecter's border color name"))

(defmethod set-inspecter-foreground-color-name-op ((item color-item))
  (with-slots (text inspecter pane)
    item
    (setf (inspecter-foreground-color-name inspecter) text)
    (revert-item pane)
    (refresh-all-windows pane)))

(defmethod set-inspecter-background-color-name-op ((item color-item))
  (with-slots (text inspecter pane)
    item
    (setf (inspecter-background-color-name inspecter) text)
    (revert-item pane)
    (refresh-all-windows pane)))

(defmethod set-inspecter-border-color-name-op ((item color-item))
  (with-slots (text inspecter pane)
    item
    (setf (inspecter-border-color-name inspecter) text)
    (revert-item pane)
    (refresh-all-windows pane)))

(defparameter *inspecter-parameters*
  '(*inspecter-margin*
    *scroll-bar-size*
    *slot-item-width*
    (*default-inspecter-font* inspecter-font-name)
    (*default-inspecter-documentation-font* inspecter-documentation-font-name)
    (*inspecter-initial-width* item-width)
    (*inspecter-initial-height* item-height)
    (*foreground-color* inspecter-foreground-color-name)
    (*background-color* inspecter-background-color-name)
    (*border-color* inspecter-border-color-name)
    (*direction-of-panes* inspecter-direction-of-panes)
    (*number-of-panes* inspecter-number-of-panes)))

(defvar *inspecter-parameters-restored-p*)

(defun inspecter-parameters-pathname ()
  (make-pathname :name "inspecter-init"
		 :type "lisp"
		 :defaults (let ((home (getenv :home)))
			     (if home
				 (dsys:pathname-as-directory home)
				 (user-homedir-pathname)))))

(defun restore-inspecter-parameters ()
  (unless *inspecter-parameters-restored-p*
    (let ((file (inspecter-parameters-pathname)))
      (when (probe-file file)
	(load file)))
    (setq *inspecter-parameters-restored-p* t)))

(defun reset-inspecter-parameters ()
  ;; Default values for parameters
  (setq *inspecter-margin* '1)
  (setq *scroll-bar-size* '10)
  (setq *slot-item-width* '(17 #\o))
  (setq *default-inspecter-font* 
	'"-adobe-helvetica-bold-r-normal--14-140-75-75-p-82-iso8859-1")
  (setq *default-inspecter-documentation-font*
	'"-adobe-helvetica-bold-r-normal--12-120-75-75-p-70-iso8859-1")
  (setq *inspecter-initial-width* '825)
  (setq *inspecter-initial-height* '734)
  (setq *foreground-color* '"Dark Slate Gray")
  (setq *background-color* '"Medium Goldenrod")
  (setq *border-color* '"Red")
  (setq *direction-of-panes* ':vertical)
  (setq *number-of-panes* '3)
  (setq *inspecter-parameters-restored-p* nil))

(unless (boundp '*inspecter-parameters-restored-p*)
  (reset-inspecter-parameters))

#+cmu
(progn
  (restore-inspecter-parameters)
  (pushnew 'reset-inspecter-parameters ext:*before-save-initializations*))

(defgeneric save-inspecter-parameters (item)
  (:generic-function-class operation)
  (:documentation "Save the current inspecter parameters"))

(defmethod save-inspecter-parameters ((item item))
  (with-slots (inspecter)
    item
    (let ((file (inspecter-parameters-pathname)))
      (with-open-file (out file :direction :output :if-exists :supersede)
	(format out "~%")
	(let ((*print-case* ':downcase)
	      (*print-base* 10)
	      (*package* (find-package "INSPECT")))
	  (format out "(in-package \"INSPECT\" :use '(\"LISP\" \"PCL\"))~2%")
	  (flet ((write-setq-form (var value)
		   (format out "(setq ~S '~S)~%" var value)
		   (set var value)))
	    (dolist (p *inspecter-parameters*)
	      (write-setq-form
	       (if (consp p) (car p) p)
	       (if (consp p) (funcall (cadr p) inspecter) (symbol-value p))))))))))
