
(in-package "INSPECT")

(defclass input-item (item)
  ((input-text-item :reader input-text-item))
  (:default-initargs :direction-of-children :vertical
                     :border-width nil
		     :size-within-parent :ask))

(defmethod initialize-instance :after ((item input-item) &key
				       documentation initial-text 
				       finish-function accept-function)
  (with-slots (item-list input-text-item)
    item
    (setq input-text-item (make-instance 'input-text-item
					 ':parent item
					 ':initial-text initial-text
					 ':documentation documentation))
    (setq item-list (list (make-instance 'input-command-item
					 ':parent item
					 ':input-text-item input-text-item
					 ':documentation documentation
					 ':finish-function finish-function
					 ':accept-function accept-function)
			  input-text-item))))

(defmethod (setf inspecter-input-text-item) (new-input-text-item (item inspecter))
  (with-slots (input-text-item)
    item
    (let ((old-input-text-item input-text-item))
      (setq input-text-item new-input-text-item)
      (when old-input-text-item (draw-text-cursor old-input-text-item))
      (when new-input-text-item (draw-text-cursor new-input-text-item))
      new-input-text-item)))

(defmethod insert-input-window ((item inspecter) iw &optional (display-p t))
  (with-slots (item-list input-text-item visible-panes-item)
    item
    (when iw
      (let ((bvpp (position visible-panes-item item-list)))
	(setq item-list (nconc (subseq item-list 0 (1+ bvpp))
			       (list iw)
			       (subseq item-list (1+ bvpp))))
	(when display-p
	  (display-item item))))
    (setf (inspecter-input-text-item item) (and iw (input-text-item iw)))
    iw))

(defmethod remove-input-window ((item inspecter) &optional iw)
  (with-slots (item-list)
    item
    (setf (inspecter-input-text-item item) nil)
    (unless iw
      (setq iw (find 'input-item (item-list item) 
		     ':key #'(lambda (o) (class-name (class-of o))))))
    (when iw
      (setq item-list (delete iw item-list))
      (unmap-window iw))
    iw))

(defmethod get-input ((item inspecter) &key
		      (documentation "Type a string")
		      (initial-text "")
		      (accept-function #'(lambda (string) 
					   (declare (ignore string))
					   t)))
  (with-slots (item-list)
    item
    (let ((current-input-window (remove-input-window item)))
      (let* ((ff #'(lambda (iw)
		     (insert-input-window item current-input-window nil)
		     (remove-input-window item iw)
		     (destroy-window-and-all-subwindows iw)
		     (display-item item)))
	     (ii (make-instance 'input-item
				':parent item
				':documentation documentation
				':initial-text initial-text
				':finish-function ff
				':accept-function accept-function)))
	(insert-input-window item ii)))))

(defclass input-command-item (item)
  ()
  (:default-initargs :direction-of-children :horizontal
                     :border-width 0
		     :size-within-parent :ask))

(defclass input-operation-item (operation-item)
  ((text :initarg :text :reader item-text :reader compute-item-text)
   (documentation :initarg :documentation :reader item-documentation))
  (:default-initargs :border-width 1))

(defclass input-filler-operation-item (documentation-font-mixin filler-operation-item)
  ()
  (:default-initargs :border-width 0))

(defclass input-command-text-item (documentation-font-mixin text-item)
  ()
  (:default-initargs :size-within-parent :ask))

(defmethod item-desired-size ((item input-command-text-item) direction)
  (case direction
    (:horizontal
     0.6)
    (:vertical 
     (font-height item))))

(defmethod initialize-instance :after ((item input-command-item) &key
				       input-text-item finish-function accept-function)
  (with-slots (parent documentation inspecter item-list)
    item
    (flet ((accept ()
	     (when (funcall accept-function (input-text input-text-item))
	       (funcall finish-function parent)))
	   (give-up ()
	     (funcall finish-function parent)))
    (setq item-list (list (make-instance 'input-command-text-item
					 ':parent item
					 ':text documentation
					 ':documentation documentation)
			  (make-instance 'input-filler-operation-item
					 ':parent item)
			  (make-instance 'input-operation-item
					 ':parent item
					 ':operation #'accept
					 ':text "Accept this value"
					 ':documentation documentation)
			  (make-instance 'input-filler-operation-item
					 ':parent item)
			  (make-instance 'input-operation-item
					 ':parent item
					 ':operation #'give-up
					 ':text "Give up"
					 ':documentation documentation)
			  (make-instance 'input-filler-operation-item
					 ':parent item))))))

(defclass input-text-item (documentation-font-mixin item)
  ((text :initarg :initial-text :initform "" :reader input-text)
   (cursor-position :initform 0))
  (:default-initargs :border-width 0
                     :size-within-parent :ask))

(defmethod initialize-instance :after ((item input-text-item) &key)
  (with-slots (text cursor-position)
    item
    (setq cursor-position (length text))))

(defmethod item-desired-size ((item input-text-item) direction)
  (case direction
    (:horizontal
     :even)
    (:vertical 
     (font-height item))))

(defmethod refresh-window ((item input-text-item))
  (with-slots (state text cursor-position inspecter cursor-state)
    item
    (when (eq state 'mapped)
      (let* ((font (item-font item))
	     (gc (item-draw-gc item))
	     (x (max *inspecter-margin* 4))
	     (y (+ *inspecter-margin* (xlib:font-ascent font))))
	(xlib:clear-area item)
	(xlib:draw-glyphs item gc x y text)
	(draw-text-cursor item)))))

(defvar *sfc-table* (make-hash-table ':test 'eql))

(defun string-from-character (char)
  (or (gethash char *sfc-table*)
      (setf (gethash char *sfc-table*)
	    (make-string 1 ':initial-element char))))

(defmethod char-width ((item item) char)
  (xlib:text-width (item-font item) (string-from-character char)))

(defmethod string-width ((item item) string)
  (xlib:text-width (item-font item) (string-from-character string)))

(defmethod draw-text-cursor ((item input-text-item))
  (with-slots (state text cursor-position inspecter)
    item
    (when (eq state 'mapped)
      (let* ((font (item-font item))
	     (draw-gc (item-draw-gc inspecter))
	     (inverse-draw-gc (item-inverse-draw-gc inspecter))
	     (x (max *inspecter-margin* 4))
	     (y (+ *inspecter-margin* (xlib:font-ascent font)))
	     (box-min-x (+ x (xlib:text-width font text :end cursor-position)))
	     (box-min-y *inspecter-margin*)
	     (char (if (<= (length text) cursor-position) 
		       #\space
		       (aref text cursor-position)))
	     (string (string-from-character char))
	     (box-width (max 2 (xlib:text-width font string)))
	     (box-height (+ (xlib:font-ascent font) (xlib:font-descent font)))
	     (new-focus-p (and (eq item (inspecter-input-text-item inspecter))
			       (inspecter-focus-p inspecter))))
	(xlib:draw-rectangle item (if new-focus-p draw-gc inverse-draw-gc)
			     box-min-x box-min-y box-width box-height t)
	(unless new-focus-p
	  (xlib:draw-rectangle item draw-gc
			       box-min-x box-min-y box-width box-height nil))
	(xlib:draw-glyphs item (if new-focus-p inverse-draw-gc draw-gc)
			  box-min-x y string)
	new-focus-p))))

(defmethod process-key-press ((item input-text-item) code state)
  (with-slots (inspecter xlib:display text cursor-position)
    item
    (let* ((control-p (logbitp 2 state))
	   (meta-p (logbitp 3 state))
	   (char (xlib:keycode->character xlib:display code (logand state 3))))
      (when char
	(multiple-value-bind (new-text new-cursor-position)
	    (edit-string text cursor-position char control-p meta-p)
	  (setq text new-text)
	  (setq cursor-position new-cursor-position)
	  (refresh-window item))))))

(defun edit-string (text cursor-position char control-p meta-p)
  (unless (array-has-fill-pointer-p text)
    (let* ((len (length text))
	   (a (make-array (max 60 len) ':element-type 'string-char 
			  ':fill-pointer len)))
      (dotimes (i len (setq text a))
	(setf (aref a i) (aref text i)))))
  (cond ((not (characterp char))
	 (values text cursor-position))
	((and (not control-p) (not meta-p))
	 (cond ((graphic-char-p char)
		(ec-insert-char text cursor-position char))
	       ((eql char #\rubout)
		(ec-delete-backwards text cursor-position))
	       (t
		(values text cursor-position))))
	((and control-p (not meta-p))
	 (cond ((eql char #\a)
		(values text 0))
	       ((eql char #\b)
		(values text (max 0 (1- cursor-position))))
	       ((eql char #\d)
		(ec-delete-forwards text cursor-position))
	       ((eql char #\e)
		(values text (length text)))
	       ((eql char #\f)
		(values text (min (length text) (1+ cursor-position))))
	       ((eql char #\k)
		(setf (fill-pointer text) cursor-position)
		(values text cursor-position))
	       (t
		(values text cursor-position))))
	((and (not control-p) meta-p)
	 (cond ((eql char #\<)
		(values text 0))
	       ((eql char #\>)
		(values text (length text)))
	       ((eql char #\b)
		(values text (- cursor-position
				(ec-backward-word-size text cursor-position))))
	       ((eql char #\d)
		(ec-delete-forwards text cursor-position
				    (ec-forward-word-size text cursor-position)))
	       ((eql char #\f)
		(values text (+ cursor-position
				(ec-forward-word-size text cursor-position))))
	       ((eql char #\rubout)
		(ec-delete-backwards text cursor-position
				     (ec-backward-word-size text cursor-position)))
	       (t
		(values text cursor-position))))
	(t
	 (values text cursor-position))))

(defun ec-insert-char (text cursor-position char)
  (declare (fixnum cursor-position))
  (vector-push-extend #\space text)
  (let ((len (length text)))
    (declare (fixnum len))
    (dotimes (i (- len cursor-position))
      (setf (aref text (- len i))
	    (aref text (- len i 1)))))
  (setf (aref text cursor-position) char)
  (incf cursor-position)
  (values text cursor-position))

(defun ec-forward-word-size (text cursor-position)
  (declare (fixnum cursor-position))
  (let* ((alpha-char-seen-p nil)
	 (len (length text))
	 (position (min len (1+ cursor-position))))
    (declare (fixnum len position))
    (loop (when (= len position)
	    (return (- position cursor-position)))
	  (if (alpha-char-p (aref text position))
	      (setq alpha-char-seen-p t)
	      (when alpha-char-seen-p
		(return (- position cursor-position))))
	  (incf position))))

(defun ec-backward-word-size (text cursor-position)
  (declare (fixnum cursor-position))
  (let ((alpha-char-seen-p nil)
	(position (max 0 (1- cursor-position))))
    (declare (fixnum position))
    (loop (when (= 0 position)
	    (return (- cursor-position position)))
	  (if (alpha-char-p (aref text position))
	      (setq alpha-char-seen-p t)
	      (when alpha-char-seen-p
		(return (- cursor-position (1+ position)))))
	  (decf position))))

(defun ec-delete-backwards (text cursor-position &optional (size 1))
  (declare (fixnum cursor-position size))
  (ec-delete-forwards text (- cursor-position size) size))		      

(defun ec-delete-forwards (text cursor-position &optional (size 1))
  (declare (fixnum cursor-position size))
  (let ((len (length text)))
    (declare (fixnum len))
    (if (>= cursor-position len)
	(values text len)
	(let* ((desired-end (+ cursor-position size))
	       (actual-end (max 0 (min desired-end len)))
	       (actual-start (max 0 (min cursor-position len)))
	       (count (- actual-end actual-start)))
	  (declare (fixnum desired-end actual-end actual-start count))
	  (dotimes (i (- len actual-end))
	    (setf (aref text (+ i actual-start))
		  (aref text (+ i actual-start size))))
	  (decf (fill-pointer text) count)
	  (values text actual-start)))))

(defgeneric inspect-read (item)
  (:generic-function-class operation)
  (:documentation "Read a value"))

(defmethod inspect-read ((item item))
  (with-slots (inspecter xlib:display)
    item
    (get-input inspecter
	       ':documentation "Type an object to inspect"
	       ':accept-function 
	       #'(lambda (string)
		   (let ((state "") value error)
		     (handler-case (progn
				     (setq state "reading value")
				     (setq value (with-input-from-string (in string)
						   (read in))))
			(error (condition)
			  (setq error (remove #\newline
					      (format nil "Error while ~A: ~A"
						      state condition)))))
		     (if error
			 (let ((di (inspecter-documentation-item inspecter)))
			   (setf (item-text di) error)
			   (refresh-window di)
			   (xlib:bell xlib:display)
			   nil)
			 (progn
			   (show-object-in-inspecter inspecter value)
			   t)))))))
