;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT; -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Dispels
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/dispels.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 10/06/92 10:03:59
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 6/11/90 (Juergen) class basic-dispel introduced 
;;;
;;; 6/11/90 (Juergen) class dispel is subclass of basic-dispel and contact
;;;
;;; [Matthias  Mon Oct  8 10:04:00 1990] method (display dispel) now uses
;;;   color
;;;
;;; [Matthias  Mon Nov  5 17:12:16 1990] included file color.lisp (color-
;;;   mixin)
;;;
;;; [Juergen  Tue Nov  6 11:18:31 1990] resources are mostly defined in 
;;;   initforms instead of in define-resources, so that they are inherited
;;;   much like defaults
;;;
;;; [Hubertus  Thu Jan  3 12:28:20 1991] fixed bug when specifying width or 
;;;   height by resources for non-adjustable dispels.
;;;
;;; 02/01/1991 (Juergen) method accept-text for text-dispels has been changed
;;;                      to send the new text as part-value.
;;;
;;; 02/05/1991 (Juergen) The methods parts, part, part-with-identification, 
;;;                      part-viewing, find-part, and find-parts for
;;;                      basic-dispels have been added for consistency reasons.
;;;                      They all return nil.
;;; 02/07/1991 (Matthias) New: change-window-foreground
;;; 02/22/1991 (Matthias) Minor bug in convert (t t 'image): 
;;;                       value may now be a symbol
;;; 02/26/1991 (Matthias) editable text dispel now accepts ctrl-u (clear-text)
;;;
;;; 02/28/1991 (Hubertus) *bitmap-directory* may be either a pathname-string 
;;;                       or a list of pathname strings.
;;;                       (search order: left to right)
;;; 05/07/1991 (Hubertus) Fixed bug in convert (t t pixmap).
;;;
;;; 06/25/1991 (Juergen)  edit-text and accept-text now also update the 
;;;                       mouse-documentation.  Therefore, they should only
;;;                       be called as reactions on text-dispel events.
;;;                       Otherwise, use new make-editable or make-ineditable
;;;                       methods.
;;;
;;; 07/18/1991 (Hubertus) class MASKED-BITMAP-DISPEL introduced:
;;;                       a bitmap-dispel whose bitmap is drawn 
;;;                       by using a clipmask. Additionally mouse feedback
;;;                       is performed by XOR-drawing a feedback-border-bitmap or 
;;;                       feedback-inverse-bitmap
;;;
;;; 07/18/1991 (Matthias) BITMAP-DISPEL: colored images can now be displayed
;;;                         modified display-width and -height 
;;;
;;; 07/01/1991 (Juergen)  A cursor for editing text-dispels has been added.
;;;                       It is displayed whenever the text-dispel is in
;;;                       edit-mode (cf. methods edit-text and make-editable) 
;;;                       and indicates the position where the text is edited,
;;;                       i.e. characters may be inserted or deleted anywhere.
;;;                       The cursor position may be controlled by the 
;;;                       following Emacs-like control keys:
;;;                         c-f     forward cursor
;;;                         c-b     backward cursor
;;;                         c-e     cursor to end
;;;                         c-a     cursor to beginning
;;;                       Additionally, the following commands have been 
;;;                       (re)defined:
;;;                         c-d     delete cursor forward
;;;                         c-y     insert string from cut buffer
;;;                         c-k     deletes all characters from the cursor
;;;                                 position to the end of the text
;;;                       The internal method delete-character has been renamed
;;;                       to delete-character-backward.
;;;
;;; 07/01/1991 (Juergen)  New init-option :edit? has been introduced for
;;;                       text-dispels.  Use edit? t for initializing
;;;                       text-dispels that should be in edit mode after
;;;                       instantiation, instead of adding the :keyboard
;;;                       event to the reactivity.  Otherwise, no cursor
;;;                       will be displayed.
;;;
;;; 11/05/1991 (Matthias) TEXT-DISPEL: draw-cursor bug fixed
;;;
;;; 11/22/1991 (Matthias) defimage-from-file etc. changed and went to 
;;;                       image.lisp
;;; 11/25/1991 (Matthias) new: read-dispel-bitmap and install-colormap hook
;;; 12/09/1991 (Matthias) new: setf background :after for masked-bitmap-dispel
;;; 12/19/1991 (Matthias) basic-dispel: replaced do-adjust-window-size by 
;;;                       adjusted-window-size
;;;                       added fixed-size-mixin to bitmap-dispel
;;; 01/13/1992 (Juergen)  delete-to-end (C-d) and clear-text (C-u) for
;;;                       text-dispels now save the deleted text in the
;;;                       cut-buffer.  Method add-string (C-y), which inserts 
;;;                       text from the cut buffer, now also updates the cursor
;;;                       position.
;;; 02/10/1992 (Matthias) Changed: make-(in)editable, now uses focus-mixin
;;;
;;; 04/09/1992 (Juergen)  New key argument :test for methods part,
;;;                       part-viewing, and part-with-identification.
;;;                       Appropriate defaults have been provided to let
;;;                       the methods behave as before.
;;;                       Method part additionally has the keyword :key,
;;;                       which defaults to #'contact-name.  So part with
;;;                       no :key specified works as before.
;;;                       Now, the following is possible:
;;;                        (part <text-menu> "refresh" 
;;;                              :key #'text :test #'string=)
;;;
;;; 04/09/1992 (Juergen)  New method part* which may be supplied with an
;;;                       arbitrary number of part names.  The method
;;;                       recursively descends the part hierarchy according
;;;                       to the specified part names and returns the 
;;;                       identified part.
;;;
;;; 07/16/1992 (Juergen)  display-width and display-height for (basic-)dispels
;;;                       now default to 1 instead of nil.  Thus, text-dispels
;;;                       with no text and bitmap-dispels with no bitmap can
;;;                       now be used properly, ie. their geometry will be
;;;                       valid and they may be displayed.
;;;
;;; 07/16/1992 (Juergen)  New logical event key :accept-event has been
;;;                       introduced for text-dispels, which is now sent
;;;                       by accept-text (triggered by pressing <Return>)
;;;                       instead of a part-event.  By default, :accept-text
;;;                       sends a part-event, so that there should be no
;;;                       incompatibilities.  :accept-event should be
;;;                       used instead of writing a new accept-text method.
;;;
;;; 09/29/1992 (Juergen)  The :edit? keyword for text-dispels may now be
;;;                       supplied with the following values:
;;;
;;;                         nil       not editable
;;;                         :local    editable, only dispel has keyboard focus,
;;;                                   i.e. mouse pointer must be within dispel
;;;                                   for editing
;;;                         :context  editable, keyboard focus is passed
;;;                                   upwards in the window hierarchy
;;;                         t         same as :local, for backward 
;;;                                   compatibility
;;;
;;;_________________________________________________________________________

(in-package :xit)

;___________________________________________________________________________

;___________________________________________________________________________
;
;                                Basic Dispel
;___________________________________________________________________________


(defcontact basic-dispel (interaction-window adjustable-window)
  ((display-position :type (member :upper-left :upper-center :upper-right
				   :left-center :center :right-center
				   :lower-left :lower-center :lower-right)
		     :initform :center
		     :accessor display-position
		     :initarg :display-position))
  (:documentation "Abstract class for all dispels.
                   Dispels are windows without subwindows presenting
                   a contents, e.g. text, bitmap, or graphics"))

(defmethod display-width ((self basic-dispel))
  1)                                   ; to be filled by subclasses

(defmethod display-height ((self basic-dispel))
  1)                                   ; to be filled by subclasses

(defmethod display-x-offset ((self basic-dispel))
  (with-slots (adjust-size? display-position width) self
    (let ((x-margin (x-margin self))
	  (display-width (display-width self)))
      (if adjust-size?
	  x-margin
	  (case display-position
	    ((:upper-left :left-center :lower-left)
	     x-margin)
	    ((:upper-center :center :lower-center)
	     (+ x-margin (floor (- width display-width) 2)))
	    ((:upper-right :right-center :lower-right)
	     (+ x-margin (- width display-width))))))))

(defmethod display-y-offset ((self basic-dispel))
  (with-slots (adjust-size? display-position height) self
    (let ((y-margin (y-margin self))
	  (display-height (display-height self)))
      (if adjust-size?
	  y-margin
	  (case display-position
	    ((:upper-left :upper-center :upper-right)
	     y-margin)
	    ((:left-center :center :right-center)
	     (+ y-margin (floor (- height display-height) 2)))
	    ((:lower-left :lower-center :lower-right)
	     (+ y-margin (- height display-height))))))))

;;; 11/22/1990 (Matthias) I have to do something just before
(defmethod initialize-instance :after ((self basic-dispel) &rest init-args)
  (apply #'set-size-after-initialization self init-args))

(defmethod set-size-after-initialization ((self basic-dispel) &rest init-args)
  (declare (ignore init-args))
  (with-slots (adjust-size? width height) self
    (let ((display-width (display-width self))
	  (display-height (display-height self)))
	(when (and display-width
		   (or adjust-size?
		       (zerop width)))
	  (setf width display-width))
	(when (and display-height
		   (or adjust-size?
		       (zerop height)))
	  (setf height display-height)))))

(defmethod adjusted-window-size ((self basic-dispel))
  (with-slots (width height) self
   (values (or (display-width self) width)
	  (or (display-height self) height))))

(defmethod (setf inside-border) :after (new-border (self basic-dispel))
  (declare (ignore new-border))
  (update self))

(defevent basic-dispel :exposure) ; display is sent by handle-event

;_______________________________________________________________________________
;
;                          PART ACCESS FOR DISPELS
;_______________________________________________________________________________

;; the following methods have been added for consistency reasons

(defmethod parts ((self basic-dispel) &optional part-name)
  (declare (ignore part-name))
  nil)

(defmethod part ((self basic-dispel) value &key key test)
   (declare (ignore value key test))
   nil)

(defmethod part* ((self basic-dispel) &rest name-list)
   (unless name-list self))
  
(defmethod find-part ((self basic-dispel) test)
  (declare (ignore test))
  nil)
    
(defmethod find-parts ((self basic-dispel) test)
  (declare (ignore test))
  nil)
     
;;;_________________________________________________________________________
;;;
;;;                              Color Mixin
;;;_________________________________________________________________________

(defcontact foreground-color-mixin ()
  ((foreground :type pixel
	       :accessor foreground
	       :initarg :foreground))
 (:resources
   (foreground :initform "black"))
 (:documentation "Mixin class providing a foreground color slot")) 

;;; [Matthias  Wed Nov  7 11:04:37 1990]
(defmethod (setf foreground) (color (self foreground-color-mixin))
  (let ((new-color nil))
     (assert (setf new-color (convert self color 'pixel))
	 (color) "~s is no color name." color)
    (with-slots (foreground) self
		(setf foreground new-color))
    (update self)
    color))

(defmethod background ((self foreground-color-mixin))
  ;; [Matthias  Thu Oct 25 13:46:51 1990] *white-pixel* 
  (with-slots (parent foreground background) self
    (let ((bg (if (eq background :parent-relative)
		  (background parent)
		background)))
      (cond ((or (eq bg :none)
		 (pixmap-p bg))
	     (let ((white (convert self "white" 'pixel)))
	       (if (eq foreground white)
		   (convert self "black" 'pixel)
		 white)))
	    (t bg)))))

(defmethod (setf background) (color (self foreground-color-mixin))
  (prog1 (setf (contact-background self) color)
         (update self)))


(defmethod background ((self contact))
  (with-slots (parent background) self
     (if (eq background :parent-relative)
	 (background parent)
       background)))

(defmethod change-window-foreground ((self foreground-color-mixin) value)
  (setf (foreground self) value))

;_______________________________________________________________________________
;
;                                Dispel
;_______________________________________________________________________________

(defcontact dispel (foreground-color-mixin basic-dispel contact)
    ()
    (:resources
     (backing-store :initform :always))
    (:documentation "Abstract class for all dispels, which are
                     represented as real windows, i.e. windows
                     in the x server (cf. class basic-dispel)"))

(defmethod show-mouse-feedback ((self dispel) &optional clip-mask)
  (with-slots (width height foreground mouse-feedback-border-width) self
    (let ((mask (logxor foreground (background self)) ))
      (using-gcontext (gc :drawable self
			  :clip-mask clip-mask
			  :line-width mouse-feedback-border-width
			  :function BOOLE-XOR
			  :foreground mask
			  :subwindow-mode :include-inferiors) 
	(case (mouse-feedback self)
	  (:border  (draw-rectangle-inside self gc 0 0 width height))
	  (:inverse (draw-rectangle-inside self gc 0 0 width height t)))))))

(defmethod after-display ((self dispel) &optional clip-mask)
   (declare (special *shading-mask*))
   (with-slots (inverse? shaded? width height foreground) self
     (when inverse?
        ;; [Matthias  Thu Oct 25 13:59:39 1990] just inverse and watch what happens
       (let ((mask  (logxor foreground (background self))))
	 (using-gcontext (gc :drawable self
			     :clip-mask clip-mask
			     :function BOOLE-XOR
			     :foreground mask ; :background *white-pixel*
			   :subwindow-mode :include-inferiors) 
	 (draw-rectangle-inside self gc 0 0 width height t))))
     (when shaded?
       (using-gcontext (gc :drawable self
			   :clip-mask clip-mask
			   :foreground (background self)
			   :subwindow-mode :include-inferiors
			   :fill-style :stippled
			   :stipple *shading-mask*
			   ) 
	 (draw-rectangle-inside self gc 0 0 width height t)))
     ))


;_______________________________________________________________________________
;
;                                Text Dispels
;_______________________________________________________________________________


(defcontact text-dispel (focus-mixin font-mixin fixed-size-mixin dispel)
  ((name :initform :text)
   (text :type stringable :accessor text :initarg :text)
   (keyboard-focus :initform :pass)
   (edit-value? :type boolean :initform nil :accessor edit-value?)
   (cursor-position :type integer :initform 0
		    :initarg :cursor-position :accessor cursor-position)
   (saved-text :type stringable :initform nil :accessor saved-text)
   (saved-reactivity-entry :initform nil)
   (x-offset :initform 0)
   )
  (:resources
   (inside-border :initform 1)
   (text :initform ""))
  (:documentation "Dispels for text elements which represent an editable
                   text in a specific font"))

(defmethod initialize-instance :after ((self text-dispel)
				       &rest init-list &key edit?)
   (declare (ignore init-list))
   (when edit?
     (unless (eq edit? :context)
       (setf (keyboard-focus self) nil))
     (make-editable self)))

(defmethod display-x-offset :around ((self text-dispel))
  ;; this is to ensure that the cursor will always be visible
  ;; even if the text is larger than its window
  (with-slots (text font cursor-position edit-value? x-offset) self
    (let* ((text-width (text-width font text))
	   (inside-width (- (contact-width self)
			    (x-margins self)))
	   (left-margin (x-margin self))
	   (right-margin (- (contact-width self) (x-margin self))))
      (setf x-offset
	  (cond ((and edit-value? (> text-width inside-width))
		 (let* ((header (subseq text 0 cursor-position))
			(cursor-offset (text-width font header)))
		   (cond ((> (+ cursor-offset x-offset) right-margin)
			  (+ (x-margin self)
			     (- inside-width cursor-offset)))
			 ((< (+ cursor-offset x-offset) left-margin)
			  (- (- left-margin cursor-offset) 0))
			 ((<= text-width cursor-offset)
			  (+ (x-margin self)
			     (- inside-width text-width)))
			 (t x-offset))))
		(t
		 (call-next-method)))))))

(defmethod display-width ((self text-dispel))
  (with-slots (text font) self
    (if (and text font)
      (+ (text-width font text) (x-margins self))
      (call-next-method))))

(defmethod display-height ((self text-dispel))
  (with-slots (font) self
    (if font
      (+ (text-height font) (y-margins self))
      (call-next-method))))

(defmethod (setf text) :after (string (self text-dispel))
  (adjust-window-size self)
  (cursor-to-end self)) ;; this also triggers an update

(defmethod (setf font) :after (font-spec (self text-dispel))
  (declare (ignore font-spec))
  (adjust-window-size self)
  (update self))

;(defmethod edit-event-type ((self text-dispel))
;  :select)

(defmethod edit-event-type ((self text-dispel))
  :edit)

#|| OLD:
(defmethod make-editable ((self text-dispel) &optional (cursor-position
							(length (text self))))
  (unless (edit-value? self)
    (save-text self)
    (let ((old-reactivity-entry
	   (reactivity-entry self (edit-event-type self))))
      (with-slots (saved-reactivity-entry) self
	(setf saved-reactivity-entry
	    (or old-reactivity-entry `(,(edit-event-type self) :none)))))
    (change-reactivity self (edit-event-type self) "Set cursor"
		       '(call :self set-cursor-position-with-mouse))
    (change-reactivity self :keyboard "Edit text")
    (setf (edit-value? self) t)
    (change-cursor-position self cursor-position)))

(defmethod make-ineditable ((self text-dispel))
  (with-slots (edit-value? saved-reactivity-entry) self
    (when edit-value?
      (setf edit-value? nil)
      (change-reactivity self :keyboard :none)
      (when saved-reactivity-entry
	(apply #'change-reactivity self saved-reactivity-entry))
      (update self))))
||#

(defmethod make-editable ((self text-dispel) &optional (cursor-position
							(length (text self))))
  (unless (edit-value? self)
    (save-text self)
    (let ((old-reactivity-entry
	   (reactivity-entry self (edit-event-type self))))
      (with-slots (saved-reactivity-entry) self
	(setf saved-reactivity-entry
	    (or old-reactivity-entry `(,(edit-event-type self) :none)))))
    (change-reactivity self (edit-event-type self) "Set cursor"
		       '(call :self set-cursor-position-with-mouse))
    (unless (reactivity-entry self :accept-event)
      (change-reactivity self :accept-event
			 '(call :part-event (text *self*))))
    (send-focus-event self :request self)
    ;(change-reactivity self :keyboard "Edit text")
    (setf (edit-value? self) t)
    (change-cursor-position self cursor-position)))

(defmethod make-ineditable ((self text-dispel))
  (with-slots (edit-value? saved-reactivity-entry) self
    (when edit-value?
      (setf edit-value? nil)
      (send-focus-event self :release self)
      ;(change-reactivity self :keyboard :none)
      (when saved-reactivity-entry
	(apply #'change-reactivity self saved-reactivity-entry))
      (update self))))

(defmethod take-focus ((self text-dispel))
  (unless (destroyed-p self)
    ;; MR 10/06/92 otherwise keyboard-focus is obsolete
    (accept-text self)))

;;;CCC Eventuell folgende 2 Methoden in eine.

(defmethod edit-text ((self text-dispel))
  ; should only be called as an action for a text-dispel event 
  ; (e.g. a button click)
  (make-editable self)
  (show-mouse-documentation self))

(defmethod edit-text-with-mouse ((self text-dispel))
  ;; call following function in this order
  (with-event (x y window)
    (multiple-value-bind (nx ny)
	(contact-translate window x y self)
      (make-editable self (convert-offset-to-cursor-position self nx))))
  (show-mouse-documentation self))
  

;;; [Matthias  Thu Oct 25 14:05:26 1990] CCC changed for color screen
  
(defmethod display ((self text-dispel) &optional x y w h &key)
  (with-slots (text font foreground edit-value?) self
    (with-clip-mask (clip-mask self x y w h)
      (using-gcontext (gc :drawable self
			  :font font
			  :clip-mask clip-mask
			  :foreground foreground
			 ;:background (background self)
			  )
	(draw-glyphs self gc
		     (display-x-offset self)
		     (+ (display-y-offset self) (max-char-ascent font))
		     text)
	(when edit-value? (draw-cursor self x y w h))))))
 
(defmethod draw-cursor ((self text-dispel) &optional x y w h)
  (with-slots (text font cursor-position foreground) self
    (with-clip-mask (clip-mask self x y w h)
     (let* ((header (subseq text 0 cursor-position))
	   (cursor-x (+ (text-width font header) (display-x-offset self)))
	   (cursor-y (display-y-offset self))
	   (cursor-width 1)
	   (cursor-height (text-height font)))
      (using-gcontext (gc :drawable self :function BOOLE-XOR
			  :clip-mask clip-mask
			  :foreground (logxor foreground (background self))
			  :background 0) 
	(draw-rectangle-inside self gc cursor-x cursor-y
			       cursor-width cursor-height t))))))

(defmethod key-press ((self text-dispel) char)
  (with-slots (display cursor-position) self
    (when
	(characterp char)
      (case char
	(#\Rubout
	 (delete-character-backward self cursor-position))
	((;#\Clear                         ;Symbolics only
	  #\Control-\u)
	  (clear-text self))
	 ((;#\Abort                         ;Symbolics only
	   #\Control-\g)
	  (reject-text self))
	 ((;#\Help                          ;Symbolics only
	   #\Control-\h)
	  (help self))
	 ((;\End                            ;Symbolics only
	   #\Return #\Linefeed)
	  (accept-text self))
	 (#\Control-\k
	  (delete-to-end self cursor-position))
	 (#\Control-\d
	  (delete-character-forward self cursor-position))
	 (#\Control-\f
	  (forward-cursor self))
	 (#\Control-\b
	  (backward-cursor self))
	 (#\Control-\a
	  (cursor-to-beginning self))
	 (#\Control-\e
	  (cursor-to-end self))
	 (#\Control-\y
	  (add-string self (cut-buffer display) cursor-position))
	 (t (if (graphic-char-p char)
		(progn
		  (add-character self char cursor-position))
	      (reject-character self char)))))))

(defmethod forward-cursor ((self text-dispel))
  (with-slots (text cursor-position) self
    (let ((text-length (length text)))
      (when (< cursor-position text-length)
	(incf cursor-position))))
  (update self))

(defmethod backward-cursor ((self text-dispel))
  (with-slots (text cursor-position) self
    (when (> cursor-position 0)
      (decf cursor-position)))
  (update self))

(defmethod cursor-to-end ((self text-dispel))
  (with-slots (text) self
    (change-cursor-position self (length text))))

(defmethod cursor-to-beginning ((self text-dispel))
  (change-cursor-position self 0))

(defmethod change-cursor-position ((self text-dispel) pos)
  (with-slots (cursor-position) self
    (setf cursor-position pos))
  (update self))

(defmethod add-string ((self text-dispel) string &optional position)
  (with-slots (text cursor-position) self
      (let* ((header (subseq text 0  position))
	     (tail (subseq text position)))
	(setf text (concatenate 'string header string tail))
	(setf cursor-position (+ position (length string)))
	(adjust-window-size self)
	(update self)))) 

(defmethod add-character ((self text-dispel) char &optional position)
  (with-slots (text) self
      (let* ((header (subseq text 0  position))
	     (tail (subseq text position)))
	(setf text (concatenate 'string header (string char) tail))
	(adjust-window-size self)
	(forward-cursor self)))) 

(defmethod delete-character-forward ((self text-dispel)
				     &optional position)
  (with-slots (text) self
    (when (< position  (length text))
      (let* ((header (subseq text 0 position))
	     (tail (subseq text (1+ position))))
	(setf text (concatenate 'string header tail))
	(adjust-window-size self)
	(update self)))))

(defmethod delete-character-backward ((self text-dispel)
				      &optional position)
  (when (> position 0)
    (with-slots (text) self
      (let* ((header (subseq text 0 (1- position)))
	     (tail (subseq text position)))
	(setf text (concatenate 'string header tail))
	(adjust-window-size self)
	(backward-cursor self)))))

(defmethod delete-to-end ((self text-dispel)
			  &optional position)
  (with-slots (display text) self
    (let ((length (length text)))
      (when (< position length)
	(let* ((header (subseq text 0 position))
	       (tail (subseq text position length)))
	  (setf (cut-buffer display) tail)
	  (setf text header)
	  (adjust-window-size self)
	  (update self))))))

		   

(defmethod reject-character ((self text-dispel) char)
  (declare (ignore char))
  (flash-window self))

(defmethod save-text ((self text-dispel))
  (setf (saved-text self) (text self)))

(defmethod clear-text ((self text-dispel))
  (with-accessors ((display contact-display) (text text)) self
     (setf (cut-buffer display) text)
     (setf (text self) "")))

(define-event-key :accept-event ())

(defmethod send-accept-event ((self text-dispel))
  (send-callback self :accept-event))

(defmethod accept-text ((self text-dispel))
  ; should only be called from key-press action
  (with-slots (text) self
    (make-ineditable self)
    (show-mouse-documentation self)
    (send-accept-event self)      ;; new event
    ;;(send-part-event self text) ;; default action of accept-event
    (cursor-to-end self)))

(defmethod reject-text ((self text-dispel))
  (with-accessors ((saved-text saved-text) (text text)) self
    (when saved-text
      (setf text saved-text)
      (cursor-to-end self))))

(defmethod help ((self text-dispel))
  )

;;; Set cursor

(defmethod set-cursor-position-with-mouse ((self text-dispel))
  "Sets the cursor according to a prevailing mouse button event."
  (with-event (x y window)
    (multiple-value-bind (nx ny)
	(contact-translate window x y self)
      (set-cursor-pixel-position self nx))))

(defmethod set-cursor-pixel-position ((self text-dispel) x) 
  (setf (cursor-position self)
      (convert-offset-to-cursor-position self x))
  (update self))

(defmethod convert-offset-to-cursor-position ((self text-dispel) x-offset)
  (with-slots (text font ) self
    (let ((cursor-offset (max 0 (- x-offset (display-x-offset self)))))
	  (search-cursor-position text font 0 0 (length text) (text-width font text)
				cursor-offset))))


(defparameter *cursor-position-threshold* .66
  "Determines the relative position within the width of a character where it
   has to be pointed at so as to specify the cursor position to the right of
   the character. E.g. a value of .5 means that clicking left of the center
   of the character leads to the left cursor position.")

(defun search-cursor-position (text font left left-offset right right-offset cursor-offset)
  "Searches for the cursor-positions immediately left and right of the pixel position
   given by cursor-offset and returns one of them as specified by the variable
   *cursor-position-threshold*." 
  (cond ((= left right) left)
	((= (- right left) 1)
	 (if (> (/ (- cursor-offset left-offset)
	       (- right-offset left-offset))
	    *cursor-position-threshold*)
	 right left))
	((<= right-offset cursor-offset)
	 right)
	((<= cursor-offset left-offset)
	 left)
	((<= left-offset cursor-offset right-offset)
	 (let ((new-pos
		(+ left (floor (* (- right left)
				  (- cursor-offset left-offset))
			       (- right-offset left-offset)))))
	   (if (= new-pos left)
	       (incf new-pos)
	     (if (= new-pos right)
		 (decf new-pos)))
	   (let ((new-offset (text-width font (subseq text 0 new-pos))))
	     (cond ((> new-offset cursor-offset)
		    (setq right new-pos)
		    (setq right-offset new-offset))
		   ((= new-offset cursor-offset)
		    (return-from search-cursor-position new-pos))
		   (t (setq left new-pos)
		    (setq left-offset new-offset)))
	     (search-cursor-position text font left left-offset right right-offset cursor-offset))))
	(t (warn "Unexpected offsets: ~d ~d ~d" left-offset cursor-offset right-offset))))

; hack for menu items
;(defmethod actions-to-string ((self text-dispel) actions)
;  (format nil "~A" (text self)))


;_______________________________________________________________________________
;
;                              Active Text Dispels
;_______________________________________________________________________________

(defcontact active-text-dispel (minimax-mixin text-dispel)
  ((name :initform :active-text)
   (min-width :initform 20)
   (mouse-feedback :initform :border)
   (reactivity :initform '((:edit))))
  (:documentation "A text-dispel representing an editable text"))

(defmethod identification ((self active-text-dispel))
  (text self))

(defmethod (setf identification) (value (self active-text-dispel))
  (setf (text self) value))

;_______________________________________________________________________________
;
;                                Bitmap Dispels
;_______________________________________________________________________________


(defcontact bitmap-dispel (fixed-size-mixin dispel)
  ((name :initform :bitmap)
   ;; 11/22/1990 (Matthias)  changed type to conform with new semantics:
   ;; bitmap is set by the user and holds the image, pixmap holds the
   ;; maybe colored pixmap
   (bitmap :type (or image pixmap) :reader bitmap :initarg :bitmap)
   ;; 11/22/1990 (Matthias) new: pixmap
   (pixmap :type (or null pixmap) :reader pixmap :initform nil))
   (:resources
     bitmap)
  (:documentation "Dispels for bitmap elements"))

;;; 07/18/1991 (Matthias) Back again
(defmethod initialize-instance :after ((self bitmap-dispel) &rest initargs)
  (declare (ignore initargs))
  (update-pixmap self))

;;; 07/18/1991 (Matthias) before-method set-size-after-initialization obsolete;
;;; display-height and width is now computed from the image

(defmethod update-pixmap ((self bitmap-dispel))
  (with-slots (foreground pixmap bitmap) self
    (let ((bitmap-value bitmap))
      (typecase bitmap-value
	(pixmap (if (eq (contact-depth self) (drawable-depth bitmap))
		    (setf pixmap bitmap)
		  (setq bitmap-value (get-image bitmap :x 0 :y 0
						:width (drawable-width bitmap)
						:height (drawable-height bitmap))))))
      (typecase bitmap-value
	(image (setf pixmap
		   ;; 07/18/1991 (Matthias)
		   ;; if real bitmap make it colored:
		   (if (= (image-depth bitmap-value) 1)
		       (find-mask self bitmap-value foreground (background self))
		     (find-pixmap self bitmap-value))))))))
      
(defmethod (setf foreground) :after (value (self bitmap-dispel))
  (declare (ignore value))
  (update-pixmap self)
  (update self))

(defmethod (setf contact-background) :after (value (self bitmap-dispel))
  (declare (ignore value))
  (update-pixmap self)
  (update self))

(defmethod get-bitmap-name ((self bitmap-dispel))
  (with-slots (bitmap) self
    (when (and bitmap 
               (not (stringp bitmap))
	       (typep bitmap 'image))
          (string-left-trim ":" 
                            (convert-to-readable-string 
                             ;; (car (last (slot-value bitmap 'xlib::plist)))
			     ;; better:
			     (getf (xlib::image-plist bitmap) :name)
			     )))))

(defmethod get-bitmap-file ((name string))
  "returns full path of the bitmap file as a string"
  (let ((file (find-file name 
			 *bitmap-directory*
			 *bitmap-extensions*)))
    (when file (namestring file))))

(defmethod get-bitmap-file ((self bitmap-dispel))
  "returns bitmap file name"
  (get-bitmap-file (get-bitmap-name self)))

(defmethod get-bitmap-symbol ((name string))
  "return symbol under which corresponding image is cached"
  (image-symbol name))

(defmethod get-bitmap-symbol ((self bitmap-dispel))
  (get-bitmap-symbol (get-bitmap-name self)))

(defmethod reload-bitmap ((self bitmap-dispel))
  (declare (special cluei::*bitmap-images*))
  (let ((bitmap-name (get-bitmap-name self))
	(bitmap-symbol (get-bitmap-symbol self)))
    (setf cluei::*bitmap-images* 
      (delete bitmap-symbol cluei::*bitmap-images*))
    (makunbound bitmap-symbol)
    (setf (bitmap self) bitmap-name)))

;;; 11/22/1990 (Matthias) find-pixmap defined in general.lisp
;;; typecase moved to convert2image (see below)

(defmethod convert (contact value (type (eql 'pixmap)))
  (typecase value    
      (pixmap    value)
      (otherwise
       (let ((image (convert contact value 'image)))
	 (when image
	   (find-pixmap contact image))))))


;;; 11/22/1990 (Matthias) get-gray-image, see general.lisp

(defmethod convert (contact value (type (eql 'image)))
  (declare (special *bitmap-prefix*))
  (typecase value
    (stringable
     ;; 02/22/1991 (Matthias) formerly error is signalled if value is symbol
     (when (symbolp value) (setq value (symbol-name value)))
     (or (cluei::stringable-value value 'image)
	 (cluei::stringable-value
	  (concatenate 'string *bitmap-prefix* value) 'image)
	 (defcolorimage-from-file contact value)	; read bitmap from file
	 ))
    (image value)
    ((or (rational 0 1) (float 0.0 1.0))
     (get-gray-image value))
    (otherwise nil)))

;; 07/18/1991 (Matthias) ask image
(defmethod display-width ((self bitmap-dispel))
  (with-slots (bitmap) self
   (typecase bitmap
     (image (+ (image-width bitmap) (x-margins self)))
     (pixmap (+ (drawable-width bitmap) (x-margins self)))
     (t (call-next-method)))))

;; 07/18/1991 (Matthias) ask image
(defmethod display-height ((self bitmap-dispel))
  (with-slots (bitmap) self
    (typecase bitmap
     (image (+ (image-height bitmap) (y-margins self)))
     (pixmap (+ (drawable-height bitmap) (y-margins self)))
     (t (call-next-method)))))


;;;11/22/1990 (Matthias) convert to image,
;;; new: update-pixmap incl. adjust & update
(defmethod (setf bitmap) (new-bitmap (self bitmap-dispel))
  (let ((bm (typecase new-bitmap
	      (pixmap new-bitmap)
	      (string (let* ((image (convert self new-bitmap 'image))
			     (cm (get (image-symbol new-bitmap) 'colormap)))
			(when cm (setf (window-colormap self) cm))
			image))
	      (t (convert self new-bitmap 'image)))))
    (setf (slot-value self 'bitmap) bm)
    (update-pixmap self)
    (adjust-window-size self)
    (update self)
    new-bitmap))

(defmethod display ((self bitmap-dispel) &optional x y w h &key)
  (with-clip-mask (clip-mask self x y w h)
    (with-slots (pixmap) self
      (when pixmap
	(using-gcontext (gc :drawable self
			    :clip-mask clip-mask)
	  (copy-area pixmap gc
		     0 0
		     (drawable-width pixmap) (drawable-height pixmap)
		     self
		     (display-x-offset self) (display-y-offset self)))))))

(defmethod read-dispel-bitmap ((self bitmap-dispel) pathname
			       &key verbose)
  "Reads an image file into the bitmap of a bitmap-dispel and changes its colormap."
  (multiple-value-bind (type width height)
      (type-of-image-file pathname)
    (declare (ignore width))
    (when type
      (let ((window (if (realized-p self) self
		      (contact-root self))))
	(with-progress-indicator (:ticks height)
	  (multiple-value-bind (image colormap)
	      (read-pixmap-file pathname window
				:verbose verbose)
	    (setf (bitmap self) image)
	    (when colormap
	      (setf (window-colormap self) colormap))
	    self))))))

(defun install-automatic-colormap-installation (display)
  (when (= (display-default-depth display) 8) 
    (defmethod mouse-enters-action :around ((self bitmap-dispel))
      (install-colormap (window-colormap self))
      (call-next-method))))

(add-open-display-hook 'install-automatic-colormap-installation)

;;;_______________________
;;;
;;; Masked Bitmap Dispels
;;;_______________________
;;;
;;; Masked bitmap dispels are bitmap-dispels whose bitmap is drawn 
;;; by using a clipmask. Additionally mouse feedback is performed
;;; by XOR-drawing a feedback-border-bitmap or feedback-inverse-bitmap

(deftype pixmap-mask () 'pixmap)

(defcontact masked-bitmap-dispel (bitmap-dispel)
  ((pseudobackground :type pixel
		     :reader pseudobackground
		     :initarg :pseudobackground)
   (clipmask :type (or (member :none) pixmap-mask)
	     :reader clipmask
	     :initarg :clipmask)
   (display-position :initform :upper-left)
   ;; feedback bitmaps are set by the user and hold the image, 
   ;; the corresponding pixmaps are stored on the contact's plist.
   ;;
   (feedback-border-bitmap :type (or (member :none) image pixmap)  
			   :reader feedback-border-bitmap
			   :initarg :feedback-border-bitmap)
   (feedback-inverse-bitmap :type (or (member :none) image pixmap)  
			    :reader feedback-inverse-bitmap
			    :initarg :feedback-inverse-bitmap))
  (:resources
   (pseudobackground :initform "white")     
   (clipmask :initform :none)              
   (feedback-border-bitmap :initform :none)
   (feedback-inverse-bitmap :initform :none)
   ))


(defmethod (setf clipmask) (new-mask (self masked-bitmap-dispel))
  (with-slots (clipmask) self
    (setf clipmask (convert self new-mask 'pixmap-mask))
    (update self)
    new-mask))

(defmethod (setf feedback-border-bitmap) (new-bitmap (self masked-bitmap-dispel))
  (let ((bm (typecase new-bitmap
	      ((or pixmap (member :none)) new-bitmap)
	      (otherwise (convert self new-bitmap 'image)))))
    (with-slots (feedback-border-bitmap) self
      (setf feedback-border-bitmap bm))
    (update-feedback-pixmap self bm :border)
    (update self)
    new-bitmap))

(defmethod (setf feedback-inverse-bitmap) (new-bitmap (self masked-bitmap-dispel))
  (let ((bm (typecase new-bitmap
	      ((or pixmap (member :none)) new-bitmap)
	      (otherwise (convert self new-bitmap 'image)))))
    (with-slots (feedback-inverse-bitmap) self
      (setf feedback-inverse-bitmap bm))  ; 11/25/1991 (Matthias) Bug fixed
    (update-feedback-pixmap self bm :inverse)
    (update self)
    new-bitmap))

(defmethod update-pixmap :after ((self masked-bitmap-dispel))
  (with-slots (feedback-inverse-bitmap feedback-border-bitmap) self
    (update-feedback-pixmap self feedback-inverse-bitmap :inverse)
    (update-feedback-pixmap self feedback-border-bitmap :border)))

(defmethod update-feedback-pixmap ((self masked-bitmap-dispel) bitmap feedback-type)
  (with-slots (foreground) self
    (typecase bitmap
      (pixmap (setf (getf (window-plist self) feedback-type)
		    bitmap))
      ((member :none) #|| do nothing ||# )
      (otherwise
        (setf (getf (window-plist self) feedback-type)
	  (let ((image (convert self bitmap 'image)))
	    (when image
	      ;; 10/31/1991 (Hubertus) if real bitmap make it colored:
	      (with-slots (foreground) self
	        (if (= (image-depth image) 1)
		    (find-mask self image
			       (logxor foreground (background self))
			       0)
		  (find-pixmap self image))))))))))
    
(defmethod convert (contact value (type (eql 'pixmap-mask)))
  (cond ((or (eq value :none)
	     (and (typep value 'pixmap)
		  (= (drawable-depth value) 1)))
	 value)
        (t (find-simple-mask contact (convert contact value 'image)))))

(defmethod after-display ((self masked-bitmap-dispel) &optional
			  display-clip-mask)
  (with-slots (clipmask) self
    (call-next-method self
		      (if (eq clipmask :none)
			  display-clip-mask
			clipmask))))

(defmethod show-mouse-feedback ((self masked-bitmap-dispel) &optional clip-mask)
  (with-slots (feedback-border-bitmap feedback-inverse-bitmap
	       mouse-feedback clipmask width height
	       mouse-feedback-border-width) self
    (if (or (and (eq mouse-feedback :border)
		 (eq feedback-border-bitmap :none))
	    (and (eq mouse-feedback :inverse)
		 (eq feedback-inverse-bitmap :none)))
	(call-next-method self
			  (if (eq mouse-feedback :border)
			      clip-mask
			    (if (eq clipmask :none)
				clip-mask
			      clipmask)))
      (using-gcontext (gc :drawable self
			  :clip-mask clip-mask 
			  :function BOOLE-XOR)
        (let ((pixmap (getf (window-plist self) mouse-feedback)))
	  (when pixmap
	    (copy-area pixmap gc
		       0 0
		       (drawable-width pixmap)
		       (drawable-height pixmap)
		       self
		       (display-x-offset self)
		       (display-y-offset self))))))))

(defmethod display ((self masked-bitmap-dispel) &optional x y w h &key)
  (with-clip-mask (display-clip-mask self x y w h)
      (with-slots (pixmap clipmask) self
	(when pixmap
	  (using-gcontext (gc :drawable self
			      :clip-mask
			      (if (eq clipmask :none)
				  display-clip-mask
				clipmask))
	    (copy-area pixmap gc
		       0 0
		       (drawable-width pixmap) (drawable-height pixmap)
		       self
		       (display-x-offset self)
		       (display-y-offset self)))))))

(defmethod contact-clipmask ((self masked-bitmap-dispel))
  (case (clipmask self)
    ((:none nil) nil)
    (t (clipmask self))))


(defmethod background ((self masked-bitmap-dispel))
  (pseudobackground self))

(defmethod (setf background) (new-color (self  masked-bitmap-dispel))
  (with-slots (pseudobackground) self
    (setf pseudobackground (convert self new-color 'pixel))
    ;(update self)
    new-color))

(defmethod (setf background) :after (value (self masked-bitmap-dispel))
  (declare (ignore value))
  (update-pixmap self)
  (update self))
