
(in-package "INSPECT")

#+pcl
(eval-when (compile load eval)
  (setq pcl::*defclass-times* '(compile load eval))
)

(defvar *operation-list* nil)

(defclass operation (standard-generic-function)
  ()
  (:metaclass pcl::funcallable-standard-class))

(defmethod initialize-instance :after ((gf operation) &key)
  (pushnew gf *operation-list*))

(defclass item (xlib:window)
  ((xlib:display :initarg :display)
   (inspecter :reader item-inspecter)
   (pane :initform nil :initarg :pane :reader item-pane)
   (parent :initform nil :initarg :parent :reader item-parent)
   (item-list :initform nil :accessor item-list :initarg item-list)
   ;; For initialization of x,y,width,height
   (size-within-parent :initform :even :initarg :size-within-parent 
		       :reader item-size-within-parent)
   ;; for initialization of children   
   (direction-of-children :initform nil :initarg :direction-of-children
			  :accessor item-direction-of-children)
   ;;
   (documentation :initform "" :initarg :documentation :reader item-documentation)
   (highlight-p :initform nil :reader highlight-window-p)
   (state :initform nil :accessor window-state) ; nil, created, mapped, unmapped
   (x :initarg :x :accessor item-x)
   (y :initarg :y :accessor item-y)
   (width :initarg :width :accessor item-width)
   (height :initarg :height :accessor item-height)
   (border-width :initform nil :initarg :border-width :accessor item-border-width)))

(defmethod initialize-instance :after ((item item) &key)
  (with-slots (xlib:display parent inspecter pane border-width)
    item
    (when (and pane (null parent))
      (setq parent pane))
    (unless (slot-boundp item 'inspecter)
      (unless parent
	(error "This window does not have a parent"))
      (setq xlib:display (xlib:window-display parent))
      (setq inspecter (item-inspecter parent))
      (unless border-width (setq border-width (item-border-width inspecter))))))

(defmethod print-object ((instance item) stream)
  (pcl::printing-random-thing (instance stream)
     (format stream "~A ~S"
	     (class-name (class-of instance))
	     (if (slot-boundp instance 'xlib:display)
		 (item-documentation instance)
		 '***UNBOUND***))))

;direction-of-children:
;           nil :horizontal :vertical
;size-within-parent:
;                    integer  ; non-negative size in pixels
;                    real     ; between 0.0 and 1.0 inclusive, fraction of total
;                    :even    ; each :even gets an equal share of remaining space
;                    :ask     ; for text

(defmacro define-idoc-functions (name hfun vfun)
  (let ((set (intern (format nil "SET-~A" name))))
    `(progn
       (defun ,name (item direction-of-children)
	 (case direction-of-children
	   (:horizontal (,hfun item))
	   (:vertical   (,vfun item))))
       (defun ,set (item direction-of-children value)
	 (case direction-of-children
	   (:horizontal (setf (,hfun item) value))
	   (:vertical   (setf (,vfun item) value))))
       (defsetf ,name ,set))))

(define-idoc-functions item-start item-x item-y)
(define-idoc-functions item-other-start item-y item-x)
(define-idoc-functions item-size item-width item-height)
(define-idoc-functions item-other-size item-height item-width)

(defvar *asapoc-throw-on-error-p* nil)

(defmethod adjust-sizes-and-positions-of-children ((item item))
  (with-slots (item-list direction-of-children)
    item
    (when (and item-list direction-of-children)
      (multiple-value-bind (requested even-count border fraction)
	  (ask-children-about-sizes item)
	(adjust-sizes-and-positions-of-children-internal
	 item requested even-count border fraction)))))

(defmethod ask-children-about-sizes ((item item))
  (with-slots (item-list (doc direction-of-children))
    item
    (let ((requested 0) (even-count 0) (border 0) (fraction 0.0))
      (declare (fixnum requested even-count border) (float fraction))
      (dolist (child item-list)
	(incf border (* 2 (item-border-width child)))
	(let ((swp (item-size-within-parent child)))
	  (when (eql swp ':ask) (setq swp (item-desired-size child doc)))
	  (when (eq swp ':even) (setq swp nil))
	  (typecase swp
	    (null (incf even-count))
	    (integer (incf requested swp))
	    (float (incf fraction swp)))))
      (values requested even-count border fraction))))

(defmethod adjust-sizes-and-positions-of-children-internal
    ((item item) requested even-count border fraction)
  (declare (fixnum requested even-count border) (float fraction))
  (with-slots (item-list (doc direction-of-children))
    item
    (let* ((start 0)
	   (item-size (item-size item doc))
	   (avail (- item-size border))
	   (frequested (ceiling (* avail fraction)))
	   (total-requested (+ requested frequested))
	   (avail-for-even (- avail total-requested))
	   (even-portion 0) (even-last-portion 0))
      (declare (fixnum start avail frequested total-requested avail-for-even))
      (declare (fixnum even-portion even-last-portion))
      (when (minusp avail-for-even)
	(if *asapoc-throw-on-error-p*
	    (throw 'asapoc-error nil)
	    (error "Can't satisfy size requests (info: ~D ~D ~D ~D,~D -> ~D)"
		   requested even-count border fraction item-size avail-for-even)))
      (when (plusp even-count)
	(setq even-portion (floor avail-for-even even-count))
	(setq even-last-portion (- avail-for-even
				   (* (1- even-count) even-portion))))
      (dolist (child item-list)
	(let* ((bw (item-border-width child))
	       (other-inside-size (- (item-other-size item doc) (* 2 bw)))
	       (swp (item-size-within-parent child)))
	  (declare (fixnum bw other-inside-size))
	  (when (eql swp ':ask) (setq swp (item-desired-size child doc)))
	  (when (eq swp ':even) (setq swp nil))
	  (let* ((inside-size (typecase swp
				(null (decf even-count)
				      (if (plusp even-count)
					  even-portion
					  even-last-portion))
				(integer swp)
				(float (floor (* swp avail)))))
		 (outsize-size (+ inside-size (* 2 bw))))
	    (multiple-value-bind (x y width height)
		(case doc 
		  (:horizontal (values start 0 inside-size other-inside-size))
		  (:vertical   (values 0 start other-inside-size inside-size)))
	      (set-and-adjust-item child x y width height)
	      (setq start (+ start outsize-size)))))))))

(defmethod set-and-adjust-item ((item item) new-x new-y new-width new-height)
  (with-slots (x y width height)
    item
    (setq x new-x y new-y width new-width height new-height)
    (when (window-state item)
      (xlib:with-state (item)
	(setf (xlib:drawable-x item) x)
	(setf (xlib:drawable-y item) y)
	(setf (xlib:drawable-width item) width)
	(setf (xlib:drawable-height item) height)))
    (adjust-sizes-and-positions-of-children item)))

(defmethod item-desired-size ((item item) direction)
  (with-slots (item-list direction-of-children)
    item
    (let ((size 0))
      (declare (fixnum size))
      (dolist (child item-list size)
	(let ((child-size (item-desired-size child direction)))
	  (when (eq ':even child-size)
	    (return-from item-desired-size ':even))
	  (if (eq direction-of-children direction)
	      (incf size child-size)
	      (setq size (max size child-size))))))))

(defmethod item-font ((item item))
  (inspecter-font (item-inspecter item)))

(defmethod item-draw-gc ((item item))
  (inspecter-draw-gc (item-inspecter item)))

(defmethod item-inverse-draw-gc ((item item))
  (inspecter-inverse-draw-gc (item-inspecter item)))

(defvar *inspecter-margin* 1)

(defmethod font-height ((item item))
  (let ((font (item-font item)))
    (+ (xlib:font-ascent font) (xlib:font-descent font) 
       (* (the fixnum *inspecter-margin*) 2))))

(defmethod refresh-all-windows ((item item))
  (with-slots (item-list state)
    item
    (when (eq state 'mapped)
      (refresh-window item)
      (mapc #'refresh-all-windows item-list))))

(defmethod refresh-window ((item item))
  (with-slots (state)
    item
    (when (eq state 'mapped)
      (xlib:clear-area item))))

(defmethod refresh-window :after ((item item))
  (with-slots (highlight-p)
    item
    (when highlight-p
      (draw-highlight-window item))))

(defmethod highlight-window ((item item))
  (with-slots (highlight-p)
    item
    (setq highlight-p t)
    (draw-highlight-window item)))

(defmethod unhighlight-window ((item item))
  (with-slots (highlight-p)
    item
    (setq highlight-p nil)
    (draw-unhighlight-window item)))

(defmethod draw-highlight-window ((item item))
  (with-slots (width height state)
    item
    (when (eq state 'mapped)
      (xlib:draw-rectangle item (item-draw-gc item)
			   0 0 (- width 1) (- height 1)))))

(defmethod draw-unhighlight-window ((item item))
  (with-slots (width height state)
    item
    (when (eq state 'mapped)
      (xlib:draw-rectangle item (item-inverse-draw-gc item)
			   0 0 (- width 1) (- height 1)))))

(defmethod item-cursor ((item item))
  (inspecter-cursor (item-inspecter item)))

(defparameter *item-event-mask*
  (xlib:make-event-mask 
   :button-press :key-press :exposure :enter-window :leave-window))

(defparameter *inspecter-event-mask*
  (xlib:make-event-mask 
   :button-press :key-press :exposure :enter-window :leave-window
   :structure-notify :focus-change))

(defmethod item-event-mask ((item item))
  *item-event-mask*)

(defmethod create-window ((item item))
  (with-slots (inspecter state parent x y width height border-width)
    item
    (unless state
      (xlib:create-window :window item
			  :parent parent
			  :x x :y y :width width :height height
			  :border-width border-width
			  :border (inspecter-border-pixel inspecter)
			  :backing-store nil
			  :background (inspecter-background-pixel inspecter)
			  :event-mask (item-event-mask item)
			  :do-not-propagate-mask nil
			  :cursor (item-cursor item))
      (setq state 'created))
    state))

(defmethod revert-properties-of-window ((item item))
  (with-slots (inspecter)
    item
    (when (xlib:window-id item)
      (xlib:with-state (item)
	(setf (xlib:window-border item) (inspecter-border-pixel inspecter))
	(setf (xlib:window-background item) (inspecter-background-pixel inspecter))
	(setf (xlib:window-cursor item) (item-cursor item)))
      (mapc #'revert-properties-of-window (xlib:query-tree item)))
    item))

(defmethod create-all-subwindows ((item item))
  (with-slots (item-list)
    item
    (mapc #'create-window-and-all-subwindows item-list)))

(defmethod create-window-and-all-subwindows ((item item))
  (with-slots (item-list)
    item
    (create-window item)
    (mapc #'create-window-and-all-subwindows item-list)))

(defmethod map-window ((item item))
  (with-slots (state)
    item
    (when (null state) (create-window item))
    (unless (eq state 'mapped)
      (xlib:map-window item)
      (setq state 'mapped))
    state))

(defmethod map-all-subwindows ((item item))
  (with-slots (item-list state)
    item
    (mapc #'map-window-and-all-subwindows item-list)))

(defmethod map-window-and-all-subwindows ((item item))
  (map-window item)
  (map-all-subwindows item))

(defmethod unmap-window ((item item))
  (with-slots (state)
    item
    (when (eq state 'mapped)
      (xlib:unmap-window item)
      (setq state 'unmapped))
    state))

(defmethod destroy-window-and-all-subwindows ((item item))
  (with-slots (state)
    item
    (when state
      (destroy-window-and-all-subwindows-internal item)
      (xlib:destroy-window item))))

(defmethod destroy-window-and-all-subwindows-internal ((item item))
  (with-slots (state item-list)
    item
    (when state
      (setq state nil)
      (mapc #'destroy-window-and-all-subwindows-internal item-list))))

(defmethod display-item ((item item))
  (with-slots (state)
    item
    (adjust-sizes-and-positions-of-children item)
    (map-window-and-all-subwindows item)
    (refresh-all-windows item)))

(defmethod revert-item ((item item))
  (with-slots (item-list)
    item
    (mapc #'revert-item item-list)))

(defmethod selected-item ((item item))
  (inspecter-selected-item (item-inspecter item)))

#+pcl (pcl::do-standard-defsetf inspecter-selected-item)

(defmethod (setf selected-item) (new-value (item item))
  (setq *** **    ** *    * new-value)
  (setf (inspecter-selected-item (item-inspecter item)) new-value))

(defgeneric select-item (item)
  (:generic-function-class operation)
  (:documentation "Select this item"))

(defmethod select-item ((item item))
  (setf (selected-item item) item))

(defgeneric unselect-item (item)
  (:generic-function-class operation)
  (:documentation "Unselect"))

(defmethod unselect-item ((item item))
  (setf (selected-item item) nil))

(defclass text-item (item)
  ((text :initarg :text :accessor item-text))
  (:default-initargs :size-within-parent :ask
                     :border-width 0))

(defmethod item-desired-size ((item text-item) direction)
  (case direction
    (:horizontal 
       (+ (xlib:text-width (item-font item) (item-text item))
	  (* (the fixnum *inspecter-margin*) 2) 5))
    (:vertical 
     (font-height item))))

(defmethod refresh-window ((item text-item))
  (with-slots (state)
    item
    (when (eq state 'mapped)
      (xlib:clear-area item)
      (xlib:draw-glyphs item (item-draw-gc item)
			(max *inspecter-margin* 4)
			(+ (the fixnum *inspecter-margin*)
			   (xlib:font-ascent (item-font item)))
			(item-text item)))))

(defmethod draw-highlight-window ((item text-item))
  (with-slots (width height state)
    item
    (when (eq state 'mapped)
      (let ((hwidth (max 4 (min width 
				(+ (xlib:text-width (item-font item) (item-text item))
				   (* (the fixnum *inspecter-margin*) 2) 5)))))
	(xlib:draw-rectangle item (item-draw-gc item)
			     0 0 (- hwidth 1) (- height 1))))))

(defmethod draw-unhighlight-window ((item text-item))
  (with-slots (width height state)
    item
    (when (eq state 'mapped)
      (let ((hwidth (max 4 (min width 
				(+ (xlib:text-width (item-font item) (item-text item))
				   (* (the fixnum *inspecter-margin*) 2) 5)))))
	(xlib:draw-rectangle item (item-inverse-draw-gc item)
			     0 0 (- hwidth 1) (- height 1))))))

(defmethod item-text ((item text-item))
  (with-slots (text)
    item
    (unless (slot-boundp item 'text)
      (setq text (compute-item-text item)))
    (when (> (length text) 400)
      (setq text (subseq text 0 400)))
    text))

(defmethod revert-item :before ((item text-item))
  (with-slots (text)
    item
    (setq text (compute-item-text item))))

(defmethod compute-item-text ((item text-item))
  (with-slots (text)
    item
    (if (slot-boundp item 'text) text "")))

(defmethod compute-item-text :around ((item text-item))
  (let ((string (call-next-method)))
    (if (find #\newline string)
	(remove #\newline string)
	string)))

(defmethod print-object ((instance text-item) stream)
  (with-slots (object)
    instance
    (let ((*print-pretty* nil))
      (pcl::printing-random-thing (instance stream)
        (format stream "~A ~S"
		(class-name (class-of instance))
		(if (slot-boundp instance 'xlib:display)
		    (item-documentation instance)
		    '***UNBOUND***))))))
