;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-


;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
;;;                                  P.O. BOX 149149                                 |
;;;                             AUSTIN, TEXAS 78714-9149                             |
;;;                                                                                  |
;;;             Copyright (C) 1990, 1990 Texas Instruments Incorporated.             |
;;;                                                                                  |
;;; Permission is granted to any individual or institution to use, copy, modify, and |
;;; distribute this software, provided that  this complete copyright and  permission |
;;; notice is maintained, intact, in all copies and supporting documentation.        |
;;;                                                                                  |
;;; Texas Instruments Incorporated provides this software "as is" without express or |
;;; implied warranty.                                                                |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+

(in-package "CLIO-OPEN")

(export '(
	  edit-text
	  edit-text-clear
	  edit-text-cut
	  edit-text-field
	  edit-text-grow
	  edit-text-field-length
	  edit-text-paste

	  make-edit-text
	  make-edit-text-field
	  )
	'clio-open)


(defmacro char-or-keysym (keysym)
  ;; Expands to the character corresponding to the KEYSYM in the
  ;; default global (display-independent) keysym mapping, if any.
  ;; Otherwise, expands to the KEYSYM.
  (let ((mapping (find-if #'(lambda (mapping)
			      ;; Better to use keysym-mapping accessors directly, but in R3 CLX these
			      ;; macros are defined only at compile time. 
			      (and (characterp (first mapping))		       ; xlib::keysym-mapping-object 
				   (not (second mapping))		       ; xlib::keysym-mapping-mask 
				   (not (third mapping))		       ; xlib::keysym-mapping-modifiers 
				   (not (fourth mapping))		       ; xlib::keysym-mapping-lowercase 
				   (not (fifth mapping))		       ; xlib::keysym-mapping-translate 
				   ))
			  
			  (gethash keysym xlib::*keysym->character-map*))))
    `,(if mapping
	(first mapping)							       ; xlib::keysym-mapping-object 
	keysym)))



(defconstant
  *default-edit-text-field-command-table*
  (make-text-command-table
    :default                                 'text-insert
    #\rubout                                 'text-rubout
    #\newline                                'text-complete
    #\linefeed                               'text-complete
    (char-or-keysym #.(xlib::keysym 255 83)) '(text-move-point :chars 1)       ; Right Arrow
    (char-or-keysym #.(xlib::keysym 255 81)) '(text-move-point :chars -1)      ; Left Arrow 
    (char-or-keysym #.(xlib::keysym 255 82)) 'ignore			       ; Up Arrow
    (char-or-keysym #.(xlib::keysym 255 84)) 'ignore			       ; Down Arrow

    ;; KCL doesn't support char-bits!
    #-kcl #\Control-\y                       #-kcl 'edit-text-paste
    #-kcl #\Control-\w                       #-kcl 'edit-text-cut
    #-kcl #\Meta-\w                          #-kcl 'display-text-copy
    #-kcl #\Control-\a                       #-kcl '(text-move-sol)
    #-kcl #\Control-\e                       #-kcl '(text-move-eol)
    #-kcl #\Control-\k                       #-kcl '(text-delete-eol)
    ))
	      

;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                                text-editor                                 |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(defconstant *i-bar-cursor-index* 152)

(defcontact text-editor ()
  ((commands         :type	     list
		     :initform       (list *default-edit-text-field-command-table*)
		     :initarg	     :commands
		     :accessor	     edit-text-commands)   

   (focus-p          :type           boolean
		     :initform       nil
		     :accessor       edit-text-focus-p))
  
  (:resources
    (cursor :initform *i-bar-cursor-index* :type cursor))
  
  (:documentation  "Basic behaviors for editing text."))



;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                              Event Handling                                |
;;;                                                                            |
;;;----------------------------------------------------------------------------+
 
(defevent text-editor (:button-press :button-1 :control) edit-text-cut)
(defevent text-editor :enter-notify  (change-focus t))
(defevent text-editor :leave-notify  (change-focus nil))
(defevent text-editor :focus-out     (change-focus nil t))
(defevent text-editor :focus-in      (change-focus t t))
(defevent text-editor :key-press     perform-command)

(defun change-focus (text new-value &optional explicit-p)
  (with-event (focus-p kind)
    (when
      (and
	;; Text window actually the one gaining/losing focus?
	(if explicit-p
	    (member kind '(:ancestor :inferior :nonlinear))     
	    focus-p)

	;; Actually losing when leaving?
	(or new-value explicit-p (not (eq (input-focus (contact-display text)) text))))
      
      (setf (edit-text-focus-p text) new-value))))



;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                                  Display                                   |
;;;                                                                            |
;;;----------------------------------------------------------------------------+



(defmethod (setf text-caret-displayed-p) (boolean (text text-editor)
					  &optional exposed-x exposed-y exposed-width exposed-height)
  (unless (or (not (realized-p text)) (text-selection-range text))
    (with-slots (focus-p point foreground) text
      (let*
	((scale  (contact-scale text))
	 (caret  (getf *text-caret-dimensions* scale))
	 (offset (text-caret-baseline-offset caret)))
	
	;; Get image and dimensions for active/inactive caret.
	(multiple-value-bind (width height image)
	    (if focus-p
		(values
		  (text-caret-width caret)
		  (text-caret-height caret)		
		  (getf (getf *text-caret-images* :active) scale))
		
		(values
		  nil
		  (or (text-caret-inactive-height caret) (text-caret-height caret))		
		  (getf (getf *text-caret-images* :inactive) scale)))
	  
	  ;; Adjust amount of image to copy.
	  (setf width  (or width height)
		height (min height (+ (text-caret-descent text scale) offset)))
	  
	  ;; Copy image pixmap.
	  (multiple-value-bind (x y) (text-base-position text point)
	    (using-gcontext (gc :drawable text :function boole-xor :exposures :off)
	      (with-gcontext (gc :clip-mask (when exposed-x (list exposed-x exposed-y exposed-width exposed-height)))
		(copy-area
		  (contact-image-mask
		    text image
		    :foreground (logxor foreground (contact-current-background-pixel text)))
		  gc
		  0 0 width height
		  text
		  (1+ (- x (pixel-round width 2))) (- y offset)))))))))
  boolean)


(defgeneric text-caret-descent (text scale)
  (:documentation "Return the descent of the displayed caret for TEXT."))


(defmethod text-caret-descent ((text text-editor) scale)
  (let ((dimensions (getf *text-caret-dimensions* scale)))
    (- (or (text-caret-inactive-height dimensions)
	   (text-caret-height dimensions))
       (text-caret-baseline-offset dimensions))))


(defmethod compute-text-geometry :around ((text text-editor))
  (with-slots (gravity) text
    (multiple-value-bind (left top width height ascent descent)
	(call-next-method)
      (values
	;; Leave room for caret at end.
	(case gravity
	  ((:north-west :west :south-west)
	   (+ left (pixel-round (text-caret-width (getf *text-caret-dimensions* (contact-scale text))) 2)))
	  ((:north-east :east :south-east)
	   (- left (pixel-round (text-caret-width (getf *text-caret-dimensions* (contact-scale text))) 2)))
	  (otherwise
	   left))
	top width height ascent descent))))



;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                                 Selection                                  |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(defgeneric edit-text-clear (text)
  (:documentation "Sets the source of the TEXT to the empty string."))

(defmethod edit-text-clear ((text text-editor))
  (setf (display-text-source text) ""))

(defgeneric edit-text-cut (text)
  (:documentation "Causes the TEXT selection to be deleted into the :CLIPBOARD.
Returns the deleted text."))

(defmethod edit-text-cut ((text text-editor))
  (let ((clip (clipboard-copy text)))
    (when clip (text-rubout text))
    clip))

(defgeneric edit-text-paste (text)
  (:documentation "Inserts the :CLIPBOARD into the TEXT and returns the inserted string."))

(defmethod edit-text-paste ((text text-editor))
  (let*
    ((display     (contact-display text))
     (client-clip (display-clipboard-text display))
     (paste       
       ;; Does this client own the :CLIPBOARD selection?
       (if (plusp (length client-clip))
	   
	   ;; Yes, get it the easy way.
	   client-clip
	   
	   ;; No, use interclient communication.
	   (flet
	     ((throw-convert (text) 
			     (declare (ignore text))
			     (with-event (property) (throw :convert property))))
	     
	     (let ((time (when (processing-event-p) (with-event (time) time))))
	       (with-event-mode (text `(:selection-notify ,#'throw-convert)) 
		 (convert-selection :clipboard :string text :paste time)
		 
		 ;; Wait for :selection-notify to report result of conversion.
		 (when (catch :convert (loop (process-next-event display)))
		   
		   ;; Conversion successful --- get stored value.
		   (get-property
		     text :paste :result-type 'string

		     ;; The :string target specifies Latin-1 encoding. This happens to correspond
		     ;; to the keysym encoding, hence the following transform function.
		     ;; Note that #'code-char might work on many systems, but this is not guaranteed
		     ;; since Common Lisp does not specify a standard character encoding.
		     
		     :transform #'(lambda (code) (keysym->character display code))))))))))
    
    (if paste
	(text-insert text paste)
	(bell display))
    paste))


;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                                 Accessors                                  |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(defmethod (setf edit-text-focus-p) :around (new-value (text text-editor))
  (with-slots (focus-p) text
    (let* ((changed-p (if new-value (not focus-p) focus-p))
	   (caret-p   (and changed-p (not (text-selection-range text)))))
      (when caret-p
	(setf (text-caret-displayed-p text) nil))      
      (call-next-method)      
      (when changed-p
	(when caret-p
	  (setf (text-caret-displayed-p text) t))
	(apply-callback text (if new-value :resume :suspend)))))  
  new-value)




;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                              edit-text-field                               |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(defcontact edit-text-field (text-editor select-text display-text-field)
  ((length           :type	     (or null (integer 0 *))
		     :initform       nil
		     :initarg	     :length
		     :accessor	     edit-text-field-length))
  
  (:resources
    (font :initform *default-display-text-font*)
    (display-gravity :initform :west)
    length)
  
  (:documentation  "A single line of editable text."))

(defun make-edit-text-field (&rest initargs)
  (apply #'make-contact 'edit-text-field initargs))


;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                                 Accessors                                  |
;;;                                                                            |
;;;----------------------------------------------------------------------------+


(defmethod (setf edit-text-point) :before (new-point (text edit-text-field) &key clear-p)
  (declare (ignore clear-p))
  (check-type new-point (or null (integer 0 *))))

(defmethod (setf edit-text-mark) :before (new-mark (text edit-text-field))
  (check-type new-mark (or null (integer 0 *))))


;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                                  Display                                   |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(defmethod display :around ((text edit-text-field) &optional x y width height &key) 
  
  ;; Display underline
  (multiple-value-bind (base-x base-y) (call-next-method)    
    (let ((scale (contact-scale text)))
      (with-slots (foreground font length width clip-rectangle) text      
	(let*
	  ((underline-y (+ base-y (text-caret-descent text scale)))
	   ;; Length of line reflects max string length
	   (start-x     (if length
			    base-x
			    0))
	   (end-x       (if length
			    (+ base-x
			       (* length
				  ;; Use average char width and hope for the best.
				  (pixel-round (+ (min-char-width font) (max-char-width font)) 2)))
			    width)))
	  
	  (using-gcontext (gc :drawable   text
			      :foreground foreground
			      :clip-mask  clip-rectangle)
	    (draw-line text gc start-x underline-y end-x underline-y))))))
  
  ;; Display caret, current selection
  (setf (text-selection-displayed-p text x y width height) t)
  (setf (text-caret-displayed-p text) t))

(defmethod text-clear-line ((text edit-text-field) base-x base-y)
  (with-slots (font) text
    (clear-area
      text
      :x      base-x
      :y      (- base-y (font-ascent font))
      :height (+ (font-ascent font) (text-caret-descent text (contact-scale text))))))



(defmethod text-change-highlight ((text edit-text-field) from to
				  &optional exposed-x exposed-y exposed-width exposed-height)
  (when (realized-p text)
    (with-slots (font foreground clip-rectangle) text
    (let ((ascent  (font-ascent font))
	  (descent (font-descent font)))
      
      (multiple-value-bind (from-x from-y)
	  (text-mark-point text from)
	(let ((to-x (text-mark-point text to)))
	  
	  (using-gcontext
	    (gc :drawable   text
		:function   boole-xor
		:clip-mask  clip-rectangle
		:foreground (logxor
			      foreground
			      (contact-current-background-pixel text)))	    	    
	    
	    (if exposed-x
		
		;; Clip highlight to intersection of clip rectangle and exposed region.
		(let
		  ((old-clip-x      (display-clip-x text))
		   (old-clip-y      (display-clip-y text))
		   (old-clip-width  (display-clip-width text))
		   (old-clip-height (display-clip-height text)))
		  
		  (setf
		    (display-clip-x text)     (max old-clip-x exposed-x)
		    (display-clip-y text)     (max old-clip-y exposed-y)
		    (display-clip-width text) (- (min (+ exposed-x exposed-width)
						      (+ old-clip-x old-clip-width))
						 (display-clip-x text))
		    (display-clip-height text) (- (min (+ exposed-y exposed-height)
						       (+ old-clip-y old-clip-height))
						  (display-clip-y text)))
		  ;; Does intersection exist?
		  (when (and (plusp (display-clip-width text)) (plusp (display-clip-height text)))
		    (with-gcontext (gc :clip-mask clip-rectangle)
		      (draw-rectangle
			text gc
			(min from-x to-x) (- from-y ascent)
			(abs (- from-x to-x))
			(+ ascent descent)
			t)))
		  
		  ;; Restore clip rectangle
		  (setf (display-clip-x text)      old-clip-x
			(display-clip-y text)      old-clip-y
			(display-clip-width text)  old-clip-width
			(display-clip-height text) old-clip-height))
		
		;; Else draw highlight without additional clipping
		(draw-rectangle
		  text gc
		  (min from-x to-x) (- from-y ascent)
		  (abs (- from-x to-x))
		  (+ ascent descent)
		  t)))))))))




;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                                   Geometry                                 |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(defmethod preferred-size ((text edit-text-field) &key width height border-width)
  (with-slots
    (length font (contact-width width) (contact-height height) (contact-border-width border-width))
    text
    (multiple-value-bind (text-width text-height) 
	(if length
	    ;; Prefer to be big enough for length chars (use average char width and hope for the best).
	    (values (* length (pixel-round (+ (min-char-width font) (max-char-width font)) 2))
		    (+ (font-ascent font) (font-descent font)))

	    ;; Else use current source extent.
	    (display-text-extent text))

      (let ((scale (contact-scale text)))	
	(values
	  ;; Ensure wide enough to display caret at end.
	  (max (+ text-width (text-caret-width (getf *text-caret-dimensions* scale))) (or width contact-width))

	  ;; Ensure tall enough to display caret and underline.
	  (max (+ text-height (text-caret-descent text scale) 1) (or height contact-height))
	  (or border-width contact-border-width))))))


(defmethod text-caret-descent :around ((text edit-text-field) scale)
  ;; Decrement normal caret height to avoid underline.
  (1- (call-next-method)))


(defmethod display-text-extent :around ((text edit-text-field))
  (multiple-value-bind (width height ascent) (call-next-method)
    (declare (ignore height))
    (let ((descent (1+ (text-caret-descent text (contact-scale text)))))
      (values width (+ ascent descent) ascent descent))))	  



;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                             Command Functions                              |
;;;                                                                            |
;;;----------------------------------------------------------------------------+


(defun perform-command (edit-text)
  (with-slots (commands) edit-text
    (with-event (character keysym)
      (let ((input (or character keysym)))
	
	;; Look up command in command table list.
	(multiple-value-bind (command default)
	    (dolist (table commands)
	      (let* ((command (text-command table input))
		     (default (unless command (text-command table :default))))
		(when (or command default)
		  (return (values command default)))))
	  
	  (cond
	    ;; Command found --- call with edit-text and other args.
	    (command
	     (if (listp command)
		 (apply (first command) edit-text (rest command))
		 (funcall command edit-text)))
	    
	    ;; Default command found --- call with edit-text, input, and other args.
	    (default
	     (if (listp default)
		 (apply (first default) edit-text input (rest default))
		 (funcall default edit-text input)))))))))


  
(defgeneric text-insert (edit-text chars)
  (:documentation "Insert the CHARS into the EDIT-TEXT at the current point
and increment the point."))


(defmethod text-insert ((text text-editor) input)
  ;; If input not character or string, then ignore.
  ;; This case may occur for non-character keysyms like arrow keys.
  (declare (ignore input)))

(defmethod text-insert :around ((text text-editor) (input character))
  ;; Ignore non-graphic characters (e.g. #\Hyper-Q).
  (if (graphic-char-p input)
      (call-next-method)
      (text-insert-nongraphic text input)))


(defgeneric text-insert-nongraphic (text input)
  (:documentation "Insert non-graphic INPUT into the EDIT-TEXT at the current point."))

(defmethod text-insert-nongraphic ((text text-editor) input)
  (declare (ignore input))
  (bell (contact-display text)))



(defmethod edit-text-field-insert ((text edit-text-field) char) 
  (declare (type edit-text-field text)
	   (type (or character string) char))
  (with-slots (buffer mark point gravity length) 
    text 
    (multiple-value-bind (select-start select-end) (text-selection-range text)
	 
      ;; Invoke :insert callback
      (let ((initial-insert-point (or select-start point)))
	(multiple-value-bind (insert-point char)
	    (apply-callback-else (text :insert text initial-insert-point char)
				 (values initial-insert-point char))
	     
	  (when
	      (or
	       ;; Insertion refused?
	       (not insert-point)
		 
	       ;; Too many chars?
	       (and length (>= (buffer-length buffer) length)
		    (bell (contact-display text)) t))
	       
	    ;; Insertion not allowed. 
	    (return-from edit-text-field-insert))
	     
	  ;; If insert point altered, then clear selection and do not delete it.
	  (unless (or (not select-start) (= insert-point initial-insert-point))
	    (setf (edit-text-mark text) point
		  select-start          nil))
	     
	  (while-changing-marks (text) 
	    (let* ((clear-all-p
		    (case gravity
		      ((:north-west :west :south-west) select-start)
		      (otherwise                       t)))
		   (clear-position
		    (if clear-all-p 0 insert-point)))
		 
	      ;; Clear before changing source.
	      (multiple-value-bind (base-x base-y)
		  (text-base-position text clear-position)
		(text-clear-line text base-x base-y)
		   
		;; Delete current selection.
		(when select-start
		  (buffer-delete buffer select-start select-end))
		   
		   
		;; Insert new character and move point
		(let ((new-point (buffer-line-insert buffer char insert-point)))
		     
		  ;; Refresh new line
		  (text-refresh-line
		   text clear-position
		   :clear-p nil
		   :base-x  (unless clear-all-p base-x)
		   :base-y  base-y)	       
		     
		  ;; Update point, mark.
		  (setf mark (setf point new-point)))))))))))

(defmethod text-insert ((text edit-text-field) (char character))
  (edit-text-field-insert text char))

(defmethod text-insert ((text edit-text-field) (char string))
  (edit-text-field-insert text char))

 
(defgeneric text-move-point (edit-text &key lines chars)
  (:documentation "Increment the point of the EDIT-TEXT by the 
given number of LINES and CHARS."))

(defmethod text-move-point ((text text-editor) &key (lines 0) (chars 0))
  (with-slots (point mark  buffer) text
    (while-changing-marks (text)
      (let ((new-point (buffer-move-mark buffer point :chars chars :lines lines)))
	(if (text-selection-range text)
	    (text-change-highlight text point new-point)
	    (setf mark (move-mark mark new-point)))
	(setf point (move-mark point new-point))))
    
    (apply-callback text :point text (buffer-mark-position buffer point))))



(defgeneric text-move-sol (edit-text)
  (:documentation "Move to the start of the current line of EDIT-TEXT."))

(defmethod text-move-sol ((text text-editor))
  (with-slots (point buffer) text
    (setf (edit-text-point text :clear-p (not (text-selection-range text)))
	  (buffer-sol buffer point))))

(defgeneric text-move-eol (edit-text)
  (:documentation "Move to the end of the current line of EDIT-TEXT."))

(defmethod text-move-eol ((text text-editor))
  (with-slots (point buffer) text
    (setf (edit-text-point text :clear-p (not (text-selection-range text)))
	  (buffer-eol buffer point))))


(defgeneric text-delete-eol (edit-text)
  (:documentation "Delete to the end of the current line of EDIT-TEXT."))

(defmethod text-delete-eol ((text text-editor))
  (with-slots (point buffer) text
    ;; Select to end of line...
    (setf (edit-text-mark text) (buffer-eol buffer point))

    ;; ...and delete it.
    (text-rubout text)))

(defgeneric text-rubout (edit-text)
  (:documentation "Decrement the current point and delete the character in the EDIT-TEXT 
at the new point."))


(defmethod text-rubout ((text edit-text-field))
  (with-slots (point mark gravity buffer) text
    (multiple-value-bind (select-start select-end) (text-selection-range text)
      
      ;; Attempt to delete non-existent character?
      (if (and (not select-start) point (zerop point))
	  
	  ;; Yes, beep a warning.
	  (bell (contact-display text))
	  
	  ;; No, perform delete.	  
	  (let ((initial-start (or select-start (buffer-move-mark buffer point :chars -1)))
		(initial-end  (or select-end point)))
	    
	    ;; Invoke :delete callback.
	    (multiple-value-bind (start end)
		(apply-callback-else (text :delete text initial-start initial-end)
		  (values initial-start initial-end))
	      
	      ;; Deletion allowed?
	      (unless start (return-from text-rubout))
	      
	      ;; If delete range altered, then clear selection and do not delete it.
	      (unless (and (= start initial-start) (= end initial-end))
		(setf (edit-text-mark text) point
		      select-start          nil))
	      
	      (let*
		((clear-all-p
		   (case gravity
		     ((:north-west :west :south-west) select-start)
		     (otherwise                       t)))
		 (clear-position
		   (if clear-all-p 0 start)))
		
		(while-changing-marks (text)
		  ;; Clear before changing source.
		  (multiple-value-bind (base-x base-y) (text-base-position text clear-position)
		    (text-clear-line text base-x base-y)
		    
		    ;; Delete chars and reset point, mark.
		    (buffer-line-delete buffer (setf point (setf mark start)) end)      
		    
		    ;; Redisplay chars	
		    (text-refresh-line
		      text clear-position
		      :clear-p nil
		      :base-x  (unless clear-all-p base-x)
		      :base-y  base-y))))))))))


(defgeneric text-complete (edit-text)
  (:documentation "Invoke the :complete callback."))

(defmethod text-complete ((text text-editor))
  (multiple-value-bind (verified-p message)
      (apply-callback-else (text :verify text)
	t)

    (if verified-p
	(apply-callback text :complete)
	
	(confirm-p
	  :near          text
	  :message       (or message "Text changes not accepted.")
	  :accept-only   :on))))



;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                                 edit-text                                  |
;;;                                                                            |
;;;----------------------------------------------------------------------------+

(defconstant
  *default-edit-text-command-table*
  (make-text-command-table
    :default                                 'text-insert
    #\rubout                                 'text-rubout
    (char-or-keysym #.(xlib::keysym 255 83)) '(text-move-point :chars 1)   ; Right Arrow
    (char-or-keysym #.(xlib::keysym 255 81)) '(text-move-point :chars -1)  ; Left Arrow
    (char-or-keysym #.(xlib::keysym 255 82)) '(text-move-point :lines -1)  ; Up Arrow
    (char-or-keysym #.(xlib::keysym 255 84)) '(text-move-point :lines 1)  ; Down Arrow

    ;; KCL doesn't support char-bits!
    #-kcl #\Control-\y                       #-kcl 'edit-text-paste
    #-kcl #\Control-\w                       #-kcl 'edit-text-cut
    #-kcl #\Meta-\w                          #-kcl 'display-text-copy
    #-kcl #\Control-\a                       #-kcl '(text-move-sol)
    #-kcl #\Control-\e                       #-kcl '(text-move-eol)
    #-kcl #\Control-\k                       #-kcl '(text-delete-eol)
    ))
 
(defcontact edit-text (text-editor display-text)
  ((commands :initform (list *default-edit-text-command-table*)))
  
  (:resources
    (display-gravity :initform :north-west))

  
  (:documentation  "Multiple lines of editable text."))

(defun make-edit-text (&rest initargs)
  (apply #'make-contact 'edit-text initargs))





;;;----------------------------------------------------------------------------+
;;;                                                                            |
;;;                             Command Functions                              |
;;;                                                                            |
;;;----------------------------------------------------------------------------+


(let ((insert-start (make-mark)) 
      (insert-mark  (make-mark)))  
  (flet
    ((edit-text-insert (text string)
       (declare (type edit-text text)
		(type (or character string) string))
    
       (with-slots (buffer mark point font gravity alignment extent-left extent-width) text
	 (multiple-value-bind (select-start select-end) (text-selection-range text)
	   
	   ;; Initialize insert mark.
	   (move-mark insert-start (or select-start point)) 
	   
	   ;; Invoke :insert callback, if necessary
	   (multiple-value-bind (insert-pos string)
	       (apply-callback-else
		 (text :insert text (buffer-mark-position buffer insert-start) string)
		 (values t string))
	     
	     ;; Insert allowed?
	     (unless insert-pos (return-from edit-text-insert))
	     
	     ;; New insert position returned?
	     (unless (eq insert-pos t)
	       ;; Yes, convert to insert mark.
	       (buffer-position-mark buffer insert-pos insert-start))
	     
	     ;; If insert point altered, then clear selection and do not delete it.
	     (unless (or (not select-start) (mark-equal insert-start select-start))
	       (setf (edit-text-mark text) point
		     select-start          nil))
	     
	     (while-changing-marks (text)
	       (let ((small-delete-p 
		       (cond
			 (select-start
			  ;; Delete current selection, if any. 
			  (buffer-delete buffer select-start select-end)
			  
			  ;; Return true if delete limited to one line.
			  (= (mark-line-index select-end) (mark-line-index select-start)))
			 
			 (:else
			  t))))
		 
		 ;; Insert new string and move insert mark
		 (move-mark insert-mark insert-start)
		 (buffer-insert buffer string insert-mark)
		 (move-mark mark (move-mark point insert-mark))
		 
		 ;; Redisplay is simple and efficient for most common case ---
		 ;; :north-west gravity, :left alignment, and insert/delete affecting only one line.
		 ;; Otherwise, redisplay is simple and inefficient! Replace with more
		 ;; sophisticated algorithm when possible.

		 (multiple-value-bind (refresh-start refresh-end clear-p)
		     (if
		       (or (and (eq gravity :north-west) (eq alignment :left))
			   (and (eq gravity :north-east) (eq alignment :right)))
		    
		       ;; Optimize this case... 
		       (let*
			 ((one-line-p  (and small-delete-p
					    (= (mark-line-index insert-mark)
					       (mark-line-index insert-start))))
			  (ascent      (font-ascent font))
			  (descent     (font-descent font)) 
			  (clear-start (mark-line-index insert-start))
			  (line-height (+ ascent descent)))
			 
			 ;; Clear damaged areas. If multiple lines damaged, just clear to bottom of window.
			 (when (eq alignment :left)    
			   ;; This case can be optimized: clear first line only from insert point.
			   (text-clear-line
			     text 
			     (text-base-x text clear-start (mark-index insert-start))
			     (text-base-y text clear-start)))
			 
			 (unless (and (eq alignment :left) one-line-p)
			   (when (eq alignment :left)
			     ;; First line already cleared above.
			     (incf clear-start))
			   
			   ;; Clear one or more lines. 
			   (clear-area
			     text
			     :x extent-left
			     :y (- (text-base-y text clear-start) ascent)
			     :width extent-width
			     :height (when one-line-p line-height)))
			 
			 ;; If multiple lines damaged, just redisplay to end of buffer.
			 (values insert-start (if one-line-p insert-mark nil) t))
		   
		       ;; Else punt and redisplay everything!  Replace with more efficient
		       ;; algorithm when possible.
		       (progn
			 (clear-area text)
			 (values 0 nil nil)))
		   
		   (setf (text-extent-defined-p text) nil)
		   (text-refresh text refresh-start refresh-end clear-p)))))))))

    (defmethod text-insert ((text edit-text) (input character))
      (edit-text-insert text input))

    (defmethod text-insert ((text edit-text) (input string))
      (edit-text-insert text input))

    (defmethod text-insert-nongraphic ((text edit-text) (char (eql #\newline)))
      (edit-text-insert text char))

    (defmethod text-insert-nongraphic ((text edit-text) (char (eql #\linefeed)))
      (edit-text-insert text #\newline)))) 


(let ((prev-point (make-mark)))
  
  (defmethod text-rubout ((text edit-text))
    (with-slots (point mark gravity alignment buffer font extent-left extent-width) text
      
      (multiple-value-bind (initial-start initial-end) (text-selection-range text)
	;; Attempt to delete non-existent character?
	(if
	  (and (not initial-start) (mark-equal point 0))

	  ;; Yes, beep a warning.
	  (bell (contact-display text))
	  
	  ;; No, perform delete. 
	  (while-changing-marks (text)
	    (move-mark prev-point point)
	    
	    ;; Determine initial delete range.
	    (setf initial-start (or initial-start (buffer-move-mark buffer point :chars -1))
		  initial-end   (or initial-end prev-point))
	    
	    ;; Invoke :delete callback to determine actual delete range.
	    (multiple-value-bind (start end)
		(apply-callback-else (text :delete text initial-start initial-end)
		  (values initial-start initial-end))
	      
	      ;; Deletion allowed?
	      (unless start (return-from text-rubout)) 
	      
	      ;; If delete range altered, then clear selection and do not delete it.
	      (unless (and (mark-equal start initial-start) (mark-equal end initial-end))
		(setf (edit-text-mark text) point)) 
	      
	      ;; Clear damaged area, delete chars, then redisplay.
	      ;;
	      ;; Redisplay is simple and efficient for most common case ---
	      ;; :north-west gravity, :left alignment, and delete affecting only one line.
	      ;; Otherwise, redisplay is simple and inefficient! Replace with more
	      ;; sophisticated algorithm when possible.
	      
	      (let ((start (move-mark initial-start start))
		    (end   (move-mark initial-end end)))
		
		;; Clear efficiently, if possible.
		(multiple-value-bind (refresh-start refresh-end clear-p) 
		    (if
		      (or (and (eq gravity :north-west) (eq alignment :left))
			  (and (eq gravity :north-east) (eq alignment :right)))
		      
		      ;; Optimize this case... 
		      (let*
			((one-line-p  (= (mark-line-index start) (mark-line-index end)))
			 (ascent      (font-ascent font))
			 (descent     (font-descent font)) 
			 (clear-start (mark-line-index start))
			 (line-height (+ ascent descent)))
			
			;; Clear damaged areas. If multiple lines damaged, just clear to bottom of window.
			(when (eq alignment :left)    
			  ;; This case can be optimized: clear first line only from delete point.
			  (text-clear-line
			    text 
			    (text-base-x text clear-start (mark-index start))
			    (text-base-y text clear-start)))
			
			(unless (and (eq alignment :left) one-line-p)
			  (when (eq alignment :left)
			    ;; First line already cleared above.
			    (incf clear-start))
			  
			  ;; Clear one or more lines. 
			  (clear-area
			    text
			    :x extent-left
			    :y (- (text-base-y text clear-start) ascent)
			    :width extent-width
			    :height (when one-line-p line-height)))
			
			(values start (when one-line-p end) t))
		      
		      ;; Else punt and redisplay everything!  Replace with more efficient
		      ;; algorithm when possible.
		      (progn
			(clear-area text)
			(values 0 nil nil)))
		  
		  ;; Delete chars.
		  (buffer-delete buffer start end)
		  
		  ;; Redisplay buffer.
		  (setf (text-extent-defined-p text) nil)
		  (text-refresh text refresh-start refresh-end clear-p)) 
		
		;; Update point and mark.
		(move-mark point (move-mark mark start))))))))))








