;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: INTERACTORS; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  ^f ^b ^d ^h = forward, backwards, delete forwards, delete backwards char
;;;  left-arrow, right-arrow =  backwards, forwards
;;;  meta-f, meta-b, meta-d, meta-h  = same but by words
;;;  ^p = previous line, ^n = next line
;;;  uparrow, downarrow = previous line, next line
;;;  ^, or HOME = beginning of document
;;;  ^. or END = end of document
;;;  ^a = beginning of line
;;;  ^e = end of line
;;;
;;;  ^k = kill line, ^u = delete entire string, ^w, CUT = delete selection
;;;  META-w, COPY = copy selection to cut buffer
;;;  ^c = copy entire string to X cut buffer
;;;  ^y, PASTE = yank kill buffer or X cut buffer
;;;  ^Y, ^PASTE = yank X buffer
;;;  meta-y, meta-PASTE = yank kill buffer
;;;
;;; The following ones extend the selection while moving
;;;   ^leftarrow, ^rightarrow = prev, next char selecting
;;;   meta-leftarrow, meta-rightarrow = prev, next word selecting
;;;   ^uparrow, ^downarrow = up-line, down-line selecting
;;;   ^HOME ^END = beginning, end of string selecting
;;;   ^* = select all
;;;
;;;  CONTROL-META is Lisp stuff:
;;;     ^-META-b, ^-META-leftarrow = prev lisp expression
;;;     ^-META-f, ^-META-rightarrow =  next lisp expression
;;;     ^-META-h, ^-META-backspace, ^-META-delete = delete prev s-expr
;;;     ^-META-d  = delete next s-expr
;;;
;;;  ^-shift- = font stuff:
;;;     ^-shift-B = toggle bold
;;;     ^-shift-I = toggle italic
;;;     ^-shift-F = fixed font (courier)
;;;     ^-shift-T = times font (serif)
;;;     ^-shift-H = helvetica font (sans-serif)
;;;     ^-shift-< = smaller font
;;;     ^-shift-> = bigger font
;;;     ^1 ^2 ^3 ^4  = small, medium, large, and very-large fonts

#|
============================================================
CHANGE LOG:
 22-july-93 Brad Myers - Make sure that don't have selection visible
                         in more than one string (e.g. in demo-text)
 13-July-93 Goldberg - Added lisp-mode-p conditional calls to opal:add-char
                       or opal:add-lisp-char and to opal:delete-selection or
                       inter:delete-lisp-region.
 15-june-93 Brad Myers - safe-functionp
 26-May-93 Mickish/Goldberg - Added lisp mode
 21-May-93 Brad Myers - added more key bindings, allow drag-through
                       selection if :drag-through-selection?
 19-Mar-93 Brad Myers - :after-cursor-moves-func called whenever
                        anything to the left of the cursor changes
 24-Feb-93 Brad Myers - new (better) key bindings, and more keywords
 10-Feb-93 RGM Fixed bug in Control-\k key binding.
               (converted text to string.)
 01-Feb-93 Andrew Mickish  opal:Set-Strings ---> opal:Set-Text
 25-dec-92 Brad Myers  Allowed mapping of mouse events (double-click, etc.)
                       Added mappings for new functions (paste X, etc.)
  9-Apr-92 ECP Changed defvar to proclaim special.
  2-Apr-92 ECP Changed #\control-\k to :control-\k
 31-Jan-92 RGM Modified to be compatible with new mulifont-text.
============================================================
|#



(in-package "INTERACTORS" :use '("KR" "LISP"))

(export '(MULTIFONT-TEXT-INTERACTOR))


(proclaim '(special MULTIFONT-TEXT-INTERACTOR))



;;; Initializes the hash table of an-interactor with the standard
;;; translations.  If there is no table in an-interactor, creates one.
;;; Otherwise, removes any translations that are there before adding
;;; the new ones.
(defun Set-MultiFont-Default-Key-Translations (an-interactor)
  (let ((ht (get-local-value an-interactor :standard-translation-table)))
    (if (not (hash-table-p ht))
      (s-value an-interactor :standard-translation-table
	       (setq ht (make-hash-table)))
      ; else re-initialize ht
      (clrhash ht))

    ;; backwards
    (bind-key-internal :LEFTARROW   :prev-char ht)
    (bind-key-internal :control-\b  :prev-char ht)

    (bind-key-internal :meta-\b     :prev-word ht)
    (bind-key-internal :meta-B      :prev-word ht)

    (bind-key-internal :control-meta-\b         :lisp-prev-expr ht)
    (bind-key-internal :control-meta-B          :lisp-prev-expr ht)
    (bind-key-internal :control-meta-LEFTARROW  :lisp-prev-expr ht)
    
    (bind-key-internal :control-LEFTARROW   :prev-char-select ht)
    (bind-key-internal :meta-LEFTARROW      :prev-word-select ht)

    ;; forwards

    (bind-key-internal :RIGHTARROW  :next-char ht)
    (bind-key-internal :control-\f  :next-char ht)
    
    (bind-key-internal :meta-F      :next-word ht)
    (bind-key-internal :meta-\f     :next-word ht)

    (bind-key-internal :control-meta-\f :lisp-next-expr ht)
    (bind-key-internal :control-meta-F  :lisp-next-expr ht)
    (bind-key-internal :control-meta-RIGHTARROW  :lisp-next-expr ht)

    (bind-key-internal :control-RIGHTARROW   :next-char-select ht)
    (bind-key-internal :meta-RIGHTARROW      :next-word-select ht)
    
    ;; PREVIOUS LINE
    
    (bind-key-internal :UPARROW     :up-line ht)
    (bind-key-internal :control-P   :up-line ht)
    (bind-key-internal :control-\p  :up-line ht)

    (bind-key-internal :control-UPARROW   :up-line-select ht)
    
    ;; NEXT LINE

    (bind-key-internal :DOWNARROW   :down-line ht)
    (bind-key-internal :control-N   :down-line ht)
    (bind-key-internal :control-\n  :down-line ht)

    (bind-key-internal :control-DOWNARROW   :down-line-select ht)
    
    ;; BEGINNING/END  LINE/STRING

    (bind-key-internal :control-\a  :beginning-of-line ht)
    
    (bind-key-internal :control-\e  :end-of-line ht)

    (bind-key-internal :HOME      :beginning-of-string ht)
    (bind-key-internal :R7        :beginning-of-string ht) ; HOME key on Sun
    (bind-key-internal :control-\,  :beginning-of-string ht)

    (bind-key-internal :control-HOME :beginning-of-string-select ht)
    (bind-key-internal :control-R7   :beginning-of-string-select ht) ;HOME key
    
    (bind-key-internal :END         :end-of-string ht) 
    (bind-key-internal :R13         :end-of-string ht)   ; END key on Sun
    (bind-key-internal :control-\.  :end-of-string ht)

    (bind-key-internal :control-END :end-of-string-select ht)
    (bind-key-internal :control-R13 :end-of-string-select ht) ;END key
    
    (bind-key-internal :control-\*  :select-all ht)
    
    ;; delete previous

    #+kcl (bind-key-internal #\rubout     :delete-prev-char ht)
    #-kcl (bind-key-internal #\delete     :delete-prev-char ht)
    (bind-key-internal #\backspace        :delete-prev-char ht)
    (bind-key-internal :control-\h        :delete-prev-char ht)
    
    (bind-key-internal :meta-H         :delete-prev-word ht)
    (bind-key-internal :meta-\h        :delete-prev-word ht)
    #+kcl (bind-key-internal #\\377    :delete-prev-word ht)
    (bind-key-internal :meta-BACKSPACE :delete-prev-word ht)
    (bind-key-internal :meta-DELETE    :delete-prev-word ht)
    (bind-key-internal :meta-RUBOUT    :delete-prev-word ht)

    (bind-key-internal :control-meta-\h         :lisp-delete-prev-expr ht)
    (bind-key-internal :control-meta-H          :lisp-delete-prev-expr ht)
    (bind-key-internal :control-meta-BACKSPACE  :lisp-delete-prev-expr ht)
    (bind-key-internal :control-meta-DELETE     :lisp-delete-prev-expr ht)
    (bind-key-internal :control-meta-RUBOUT     :lisp-delete-prev-expr ht)

    ;; delete next

    (bind-key-internal :control-\d  :delete-next-char ht)

    (bind-key-internal :meta-D      :delete-next-word ht)
    (bind-key-internal :meta-\d     :delete-next-word ht)

    (bind-key-internal :control-meta-\d    :lisp-delete-next-expr ht)
    (bind-key-internal :control-meta-D     :lisp-delete-next-expr ht)

    ;; other deletes and copies

    (bind-key-internal :control-\u  :delete-string ht)
    
    (bind-key-internal :control-\k  :kill-line ht)

    (bind-key-internal :control-W  :delete-selection ht)
    (bind-key-internal :control-\w :delete-selection ht)
    (bind-key-internal :CUT        :delete-selection ht)
    (bind-key-internal :L10        :delete-selection ht)  ;; cut key on Sun
    
    (bind-key-internal :meta-W     :copy-selection ht)
    (bind-key-internal :meta-\w    :copy-selection ht)
    (bind-key-internal :COPY       :copy-selection ht)
    (bind-key-internal :L6         :copy-selection ht)  ;; copy key on Sun

    (bind-key-internal :control-c  :copy-to-X-cut-buffer ht)
    
    ;; PASTES
    
    (bind-key-internal :control-\y  :yank-buffer-or-X-cut-buffer ht)
    (bind-key-internal :insert  :yank-buffer-or-X-cut-buffer ht)
    (bind-key-internal :L8      :yank-buffer-or-X-cut-buffer ht) ;paste on Sun
    (bind-key-internal :insert-line :yank-buffer-or-X-cut-buffer ht)
    #+(or vax dec3100 dec5000)
        (bind-key-internal :insert-here :yank-buffer-or-X-cut-buffer ht)

    (bind-key-internal :control-insert  :copy-from-X-cut-buffer ht)
    (bind-key-internal :control-Y       :copy-from-X-cut-buffer ht)
    (bind-key-internal :control-L8      :copy-from-X-cut-buffer ht)

    (bind-key-internal :meta-insert     :yank-buffer ht)
    (bind-key-internal :meta-Y          :yank-buffer ht)
    (bind-key-internal :meta-L8         :yank-buffer ht)

    ;; NEWLINES

    (bind-key-internal #\return     #\Newline ht)
    (bind-key-internal :control-J   #\Newline ht)
    (bind-key-internal :control-\j  #\Newline ht)

    (bind-key-internal :control-\o :Insert-LF-after ht)
    (bind-key-internal :control-O  :Insert-LF-after ht)
    
    ;; FONT STUFF
    
    (bind-key-internal :control-B  :toggle-bold ht)
    (bind-key-internal :control-I  :toggle-italic ht)
    (bind-key-internal :control->  :bigger ht)
    (bind-key-internal :control-<  :smaller ht)

    (bind-key-internal :control-1  :small ht)
    (bind-key-internal :control-2  :medium ht)
    (bind-key-internal :control-3  :large ht)
    (bind-key-internal :control-4  :very-large ht)
    (bind-key-internal :control-!  :small ht)
    (bind-key-internal :control-@  :medium ht)
    (bind-key-internal :control-#  :large ht)
    (bind-key-internal :control-$  :very-large ht)

    (bind-key-internal :control-F  :fixed ht)
    (bind-key-internal :control-T  :serif ht)
    (bind-key-internal :control-H  :sans-serif ht)
      
    ;; translate the number pad into regular characters (if CMU)
    #+cmu (bind-key-internal :num-pad-1 #\1 ht)
    #+cmu (bind-key-internal :num-pad-2 #\2 ht)
    #+cmu (bind-key-internal :num-pad-3 #\3 ht)
    #+cmu (bind-key-internal :num-pad-4 #\4 ht)
    #+cmu (bind-key-internal :num-pad-5 #\5 ht)
    #+cmu (bind-key-internal :num-pad-6 #\6 ht)
    #+cmu (bind-key-internal :num-pad-7 #\7 ht)
    #+cmu (bind-key-internal :num-pad-8 #\8 ht)
    #+cmu (bind-key-internal :num-pad-9 #\9 ht)
    #+cmu (bind-key-internal :num-pad-0 #\0 ht)
    #+cmu (bind-key-internal :num-pad-/ #\/ ht)
    #+cmu (bind-key-internal :num-pad-* #\* ht)
    #+cmu (bind-key-internal :num-pad-- #\- ht)
    #+cmu (bind-key-internal :num-pad-+ #\+ ht)
    #+cmu (bind-key-internal :num-pad-. #\. ht)
    #+cmu (bind-key-internal :num-pad-enter #\NewLine ht) ; the enter key

    ))

;; In addition to the standard key bindings, the lisp translation table
;; also handles tabs, parens, semi-colons, etc. specially for lisp mode
;;
(defun Set-Lisp-Key-Translations (an-interactor)
   (let ((ht (copy-hash-table
	      (get-local-value an-interactor :standard-translation-table))))
     (s-value an-interactor :lisp-translation-table ht)
     (bind-key-internal #\tab #'tab ht)
     (bind-key-internal #\; #'semi-func ht)
     (bind-key-internal #\return #'return-func ht)
     (bind-key-internal #\\ #'bslash-func ht)
     (bind-key-internal #\- #'bslash-func ht)
     (bind-key-internal #\rubout #'rubout-func ht)
     (bind-key-internal :control-\d #'cd-func ht)
     (bind-key-internal :meta-\d #'md-func ht)
     (bind-key-internal :control-\k #'ck-func ht) 
     (bind-key-internal :control-\y #'cy-func ht) 
     (bind-key-internal :control-meta-\f #'cmf-func ht)
     (bind-key-internal :control-meta-f #'cmf-func ht)
     (bind-key-internal :control-meta-rightarrow #'cmf-func ht)
     (bind-key-internal :control-meta-\b #'cmb-func ht)
     (bind-key-internal :control-meta-b #'cmb-func ht)
     (bind-key-internal :control-meta-leftarrow #'cmb-func ht)
     (bind-key-internal :control-meta-\d #'cmd-func ht)
     (bind-key-internal :control-meta-d #'cmd-func ht)
     (bind-key-internal :control-meta-\h #'cmh-func ht)
     (bind-key-internal :control-meta-h #'cmh-func ht)
     (bind-key-internal :control-meta-rubout #'cmh-func ht)     
     (bind-key-internal #\# #'hash-func ht)
     (bind-key-internal #\( #'open-paren-func ht)
     (bind-key-internal #\) #'close-paren-func ht)
     (bind-key-internal #\space #'space-func ht)
     (bind-key-internal #\| #'bar-func ht)
     (bind-key-internal #\" #'quote-func ht)
    )
  )


;; Turn the cursor visibility on or off.
(defun mf-obj-or-feedback-cursor-on-off (obj-over feedback-obj turn-on-p)
   (when (or feedback-obj (schema-p obj-over)) ; otherwise, just exit because
                                               ; no object to set
      (let ((obj (or feedback-obj obj-over))
            line\# char\#)
         (if turn-on-p
            (progn
               (setq line\# (g-value obj :saved-line-index))
               (setq char\# (g-value obj :saved-char-index))
               (opal:SET-CURSOR-TO-LINE-CHAR-POSITION obj line\# char\#)
               (opal:SET-CURSOR-VISIBLE obj T)
            )
            ; else save current index and turn off cursor
            (progn
               (multiple-value-setq (line\# char\#)
                     (opal:GET-CURSOR-LINE-CHAR-POSITION obj))
               (s-value obj :saved-line-index line\#)
               (s-value obj :saved-char-index char\#)
               (opal:SET-CURSOR-VISIBLE obj nil)
            )
         )
      )
   )
)


(defun Multifont-Text-Interactor-Initialize (new-Text-schema)
   (if-debug new-Text-schema (format T "Text initialize ~s~%" new-Text-schema))
   (Check-Interactor-Type new-Text-schema inter:multifont-text-interactor)
   (Check-Required-Slots new-Text-schema)
   (Set-Up-Defaults new-Text-schema)
) ;end initialize procedure


;; Make a copy of the orignal string in case :abort happens.
(defun Multifont-Text-Int-Start-Action (an-interactor new-obj-over start-event)
   (if-debug an-interactor (format T "Text int-start over ~s~%" new-obj-over))
   (let ((feedback (g-value an-interactor :feedback-obj))
         (startx (event-x start-event))
         (starty (event-y start-event)))
      (s-value an-interactor :startx startx)
      (s-value an-interactor :starty starty)
      (if feedback
         (progn
            (if-debug an-interactor
               (format T
                     "  * Setting :box of ~s (feedback-obj) to (~s ~s ..)~%"
                     feedback startx starty))
            (set-obj-list2-slot feedback :box startx starty)
            (s-value feedback :obj-over new-obj-over)
            (s-value an-interactor :original-string
                  (opal:GET-TEXT feedback))
            (s-value feedback :visible T)
            (opal:SET-CURSOR-TO-X-Y-POSITION feedback startx starty)
            (opal:SET-CURSOR-VISIBLE feedback T)
         )
         ;; else modify new-obj-over
         (progn
            (s-value an-interactor :original-string
                  (opal:GET-TEXT new-obj-over))
            (when (schema-p new-obj-over)
               (opal:SET-CURSOR-TO-X-Y-POSITION new-obj-over startx starty)
               (opal:SET-CURSOR-VISIBLE new-obj-over T)
            )
         )
      )
      (obj-or-feedback-edit an-interactor new-obj-over feedback start-event)
   )
)


(defun Multifont-Text-Int-Outside-Action (an-interactor last-obj-over)
   (if-debug an-interactor (format T "Text int-outside object=~s~%"
         last-obj-over))
   (mf-obj-or-feedback-cursor-on-off last-obj-over
         (g-value an-interactor :feedback-obj) NIL)
)


(defun Multifont-Text-Int-Back-Inside-Action (an-interactor obj-over event)
   (if-debug an-interactor (format T "Text int-back-inside, obj-ever = ~S ~% "
         obj-over))
   (let ((feedback (g-value an-interactor :feedback-obj)))
      (mf-obj-or-feedback-cursor-on-off obj-over feedback T)
      (obj-or-feedback-edit an-interactor obj-over feedback event)
   )
)


(defun Multifont-Text-Int-Stop-Action (an-interactor obj-over event)
   (if-debug an-interactor (format T "Text int-stop over ~s~%" obj-over))
   (let ((feedback (g-value an-interactor :feedback-obj)))
      ;; ** NOTE final character is NOT edited into the string
      (mf-obj-or-feedback-cursor-on-off obj-over feedback NIL)
      (when (and feedback (schema-p obj-over))
         (opal:SET-TEXT obj-over (opal:GET-TEXT feedback))
      )
      (when feedback
         (s-value feedback :visible NIL)
      )
      (when (g-value an-interactor :final-function)
         (let ((str ; try to come up with a final string for final-function
                     (if (schema-p obj-over)
                        (opal:GET-TEXT obj-over)
                        (if feedback
                           (opal:GET-TEXT feedback)
                            NIL
                        )
                      ))
               startx starty)
            (if (g-value an-interactor :continuous)
               (progn
                  (setf startx (g-value an-interactor :startx))
                  (setf starty (g-value an-interactor :starty))
               )
               (progn
                  (setf startx (event-x event))
                  (setf starty (event-y event))
               )
            )
            (KR-Send an-interactor :final-function an-interactor obj-over event
                  str startx starty)
         )
      )
   )
)


(defun Multifont-Text-Int-Abort-Action (an-interactor orig-obj-over event)
   (declare (ignore event))
   (if-debug an-interactor (format T "Text int-abort over ~s~%" orig-obj-over))
   (let ((feedback (g-value an-interactor :feedback-obj)))
      (if feedback
         (progn
            (opal:SET-TEXT feedback
                  (g-value an-interactor :original-string))
            (opal:SET-CURSOR-VISIBLE feedback nil)
            (s-value feedback :visible NIL)
         )
         (when (schema-p orig-obj-over)
            (opal:SET-TEXT orig-obj-over
                  (g-value an-interactor :original-string))
            (opal:SET-CURSOR-VISIBLE orig-obj-over NIL)
         )
      )
   )
)

;; some additional commands

;;; Kill line (like in Emacs)
(defun do-kill-line (inter obj event)
  (let ((deleted-stuff (opal:kill-rest-of-line obj))
	(cut-buffer (g-value inter :cut-buffer))
	(a-window (event-window event)))
    (when deleted-stuff
      (if (g-value inter :kill-mode)
	  (setq deleted-stuff (opal:concatenate-text
				    cut-buffer deleted-stuff))
	  (s-value inter :kill-mode t))
      (s-value inter :cut-buffer deleted-stuff)
      (opal:set-x-cut-buffer a-window
			     (opal:text-to-string deleted-stuff)))))

;;; remove selection into cut buffer
(defun do-delete-selection (inter obj event set-cut-buf?)
  (let* ((deleted-stuff (if (g-value inter :lisp-mode-p)
			    (inter:delete-lisp-region obj)
			    (opal:delete-selection obj)))
	 (deleted-string (opal:text-to-string deleted-stuff))
	 (a-window (event-window event)))
    (unless (string= deleted-string "")
      (when set-cut-buf? (s-value inter :cut-buffer deleted-stuff))
      (opal:set-x-cut-buffer a-window deleted-string)
      (when set-cut-buf? (curs-move inter obj)))))

;;; copy the selection into cut buffer, but don't remove it
(defun do-copy-selection (inter obj event)
  (let* ((copied-stuff (opal:copy-selected-text obj))
	 (copied-string (opal:text-to-string copied-stuff))
	 (a-window (event-window event)))
    (unless (string= copied-string "")
      (s-value inter :cut-buffer copied-stuff)
      (opal:set-x-cut-buffer a-window copied-string))))

;;; Yank buffer (like Emacs)
(defun do-yank-buffer (inter obj event)
  (declare (ignore event))
  (let ((yanked-stuff (g-value inter :cut-buffer)))
    (opal:insert-text obj yanked-stuff)
    (curs-move inter obj)))

;;; if there is a cut-buffer, then insert it, else insert X cut buffer
(defun do-yank-buffer-or-X-cut-buffer (inter obj event)
  (let ((yanked-stuff (g-value inter :cut-buffer)))
    (if yanked-stuff
      (opal:insert-text obj yanked-stuff)
      (opal:insert-string obj
			  (Opal:Get-X-Cut-Buffer (inter:event-window event))))
    (curs-move inter obj)))


;;; sets the font of the current selection, if any.  If none, then sets the
;;; default font for the string-object.  Family, face and size can be NIL, a
;;; real value or a special value.
(defun Set-Font-Changing (string-object family face size)
  (if (g-value string-object :selection-p)
      (progn
	(when family 
	  (opal:change-font-of-selection string-object NIL :family family))
	(when size
	  (opal:change-font-of-selection string-object NIL :size size))
	(when face
	  (case face
	    ((NIL) NIL)
	    (:bold (opal:change-font-of-selection string-object NIL :bold T))
	    (:italic (opal:change-font-of-selection string-object NIL
						    :italic T))
	    (:bold-italic (opal:change-font-of-selection string-object NIL
							 :italic T :bold T))
	    (:toggle-bold (opal:change-font-of-selection string-object NIL
							  :bold :toggle-first))
	    (:toggle-italic (opal:change-font-of-selection string-object NIL
						   :italic :toggle-first)))))

      ;; otherwise set the default font
      (let* ((font (g-value string-object :current-font)))
	(unless family
	  (setf family (g-value font :family)))
	(ecase face
	  ((NIL) (setq face (g-value font :face)))
	  ((:bold :italic :bold-italic :roman)) ; face is fine
	  (:toggle-bold (setq face (ecase (g-value font :face)
				     (:bold NIL)
				     (:roman :bold)
				     (:italic :bold-italic)
				     (:bold-italic :italic))))
	  (:toggle-italic (setq face (ecase (g-value font :face)
				       (:italic NIL)
				       (:roman :italic)
				       (:bold :bold-italic)
				       (:bold-italic :bold)))))
	(ecase size
	  ((NIL) (setq size (g-value font :size)))
	  ((:small :medium :large :very-large)) ; size is fine
	  (:bigger (setq size (ecase (g-value font :size)
				(:small :medium)
				(:medium :large)
				(:large :very-large)
				(:very-large :very-large))))
	  (:smaller (setq size (ecase (g-value font :size)
				 (:small :small)
				 (:medium :small)
				 (:large :medium)
				 (:very-large :large)))))
	(s-value string-object :current-font
		 (opal:get-standard-font family face size)))))


(defun curs-move (inter string-object)
  (kr-send inter :after-cursor-moves-func inter string-object)) 

(defparameter Shift-Bit (xlib:make-state-mask :shift))

;;event is a mouse event, not a move, see if down or shift-down
(defun Handle-Move-Cursor (an-interactor string-object event)
  ;; then see if want to move cursor
  (let ((x (event-x event))
	(y (event-y event)))
    (cond ((and (event-downp event)
		(g-value an-interactor :cursor-where-press))
	   ;; see if shift down.
	   (if (zerop (logand (event-state event) Shift-Bit))
	       ;; not shift
	       (progn
		 (opal:toggle-selection string-object NIL)
		 (opal:set-cursor-to-x-y-position string-object x y)
		 (opal:SET-CURSOR-VISIBLE string-object T)
		 (curs-move an-interactor string-object)
		 (when (g-value an-interactor :drag-through-selection?)
		   (s-value an-interactor :dragging-now T)))
	       ;; else extend selection
	       (when (g-value an-interactor :drag-through-selection?)
		 (opal:toggle-selection string-object T)
		 (opal:set-selection-to-x-y-position string-object x y))
	       ))
	  ((and (event-code event)(null (event-downp event)))
	   (s-value an-interactor :dragging-now NIL)))))
    
(defun Handle-Drag-Through (string-object event)
  (opal:toggle-selection string-object T)
  (opal:set-selection-to-x-y-position string-object
				      (event-x event) (event-y event)))

;;; On a delete operation, if there is a selection, delete it and don't do the
;;; regular delete operation.
(defun check-delete-selection (string-object lisp-mode-p)
  (and (g-value string-object :selection-p)
       (if lisp-mode-p
	   (inter:delete-lisp-region string-object)
	   (opal:delete-selection string-object))))

;; Does the same stuff as inter:Edit-String (in textkeyhandling.lisp)
;; but string-object is of type opal:multifont-text.
(defun MultiFont-Edit-String (an-interactor string-object event)
   (if (or (null event) (not (schema-p string-object)))
      NIL ; ignore this event and keep editing
      ; else
      (let* ((char (event-char event))
	     (new-trans-char (inter::Translate-key char an-interactor))
	     (last-edited-string (g-value an-interactor :last-edited-string)))
	;; make sure there isn't a selection visible in another
	;; string, in case this interactor is operating over multiple
	;; string objects.
	(unless (eq last-edited-string string-object)
	  (s-value an-interactor :last-edited-string string-object)
	  (when (and last-edited-string
		     (is-a-p last-edited-string opal:multifont-text))
	    (opal:toggle-selection last-edited-string NIL)))
	(if (and (eq char :mouse-moved)
		 (g-value an-interactor :drag-through-selection?)
		 (g-value an-interactor :dragging-now))
	    (Handle-Drag-Through string-object event)
	    ;; else deal with the character
	    (when new-trans-char
	      (unless (eq new-trans-char :kill-line)
		(s-value an-interactor :kill-mode nil))
	      (if-debug an-interactor
			(format T "Key ~s translated to ~s~%" char
				new-trans-char))
	      (case new-trans-char
                  (:prev-char (opal:toggle-selection string-object nil)
			      (opal:go-to-prev-char string-object)
			      (curs-move an-interactor string-object))
		  (:prev-char-select (opal:toggle-selection string-object t)
				     (opal:go-to-prev-char string-object)
				     (curs-move an-interactor string-object))
                  (:next-char (opal:toggle-selection string-object nil)
			      (opal:go-to-next-char string-object)
			      (curs-move an-interactor string-object))
		  (:next-char-select (opal:toggle-selection string-object t)
				     (opal:go-to-next-char string-object)
				     (curs-move an-interactor string-object))
		  (:prev-word (opal:toggle-selection string-object nil)
			      (opal:go-to-prev-word string-object)
			      (curs-move an-interactor string-object))
		  (:prev-word-select (opal:toggle-selection string-object t)
				     (opal:go-to-prev-word string-object)
				     (curs-move an-interactor string-object))
		  (:next-word (opal:toggle-selection string-object nil)
			      (opal:go-to-next-word string-object)
			      (curs-move an-interactor string-object))
		  (:next-word-select (opal:toggle-selection string-object t)
				     (opal:go-to-next-word string-object)
				     (curs-move an-interactor string-object))
                  (:up-line (opal:toggle-selection string-object nil)
			    (opal:go-to-prev-line string-object)
			    (curs-move an-interactor string-object))
		  (:up-line-select (opal:toggle-selection string-object t)
				   (opal:go-to-prev-line string-object)
				   (curs-move an-interactor string-object))
                  (:down-line (opal:toggle-selection string-object nil)
			      (opal:go-to-next-line string-object)
			      (curs-move an-interactor string-object))
		  (:down-line-select (opal:toggle-selection string-object t)
				     (opal:go-to-next-line string-object)
				     (curs-move an-interactor string-object))
                  (:beginning-of-string
		   (opal:toggle-selection string-object nil)
		   (opal:go-to-beginning-of-text string-object)
		   (opal:set-cursor-visible string-object t)
		   (curs-move an-interactor string-object))
		  (:beginning-of-string-select
                     (opal:toggle-selection string-object t)
                     (opal:go-to-beginning-of-text string-object)
		     (curs-move an-interactor string-object))
		  (:beginning-of-line
		   (opal:toggle-selection string-object nil)
		   (opal:go-to-beginning-of-line string-object)
		   (curs-move an-interactor string-object))
		  (:beginning-of-line-select
                     (opal:toggle-selection string-object t)
                     (opal:go-to-beginning-of-line string-object)
		     (curs-move an-interactor string-object))
                  (:end-of-string
		   (opal:toggle-selection string-object nil)
		   (opal:go-to-end-of-text string-object)
		   (opal:set-cursor-visible string-object t)
		   (curs-move an-interactor string-object))
		  (:end-of-string-select
                     (opal:toggle-selection string-object t)
                     (opal:go-to-end-of-text string-object)
		     (curs-move an-interactor string-object))
		  (:end-of-line (opal:toggle-selection string-object nil)
				(opal:go-to-end-of-line string-object)
				(curs-move an-interactor string-object))
		  (:end-of-line-select (opal:toggle-selection string-object t)
				       (opal:go-to-end-of-line string-object)
				       (curs-move an-interactor string-object))
		  (:select-all 
		   (opal:toggle-selection string-object NIL)
		   (opal:go-to-beginning-of-text string-object)
		   (opal:toggle-selection string-object T)
		   (opal:go-to-end-of-text string-object)
		   (curs-move an-interactor string-object))
                  (:delete-prev-char
		   (unless (check-delete-selection
			    string-object (g-value an-interactor :lisp-mode-p))
		     (opal:delete-prev-char string-object))
		   (curs-move an-interactor string-object))
                  (:delete-prev-word
		   (unless (check-delete-selection
			    string-object (g-value an-interactor :lisp-mode-p))
		     (opal:delete-prev-word string-object))
		   (curs-move an-interactor string-object))
                  (:delete-next-char
		   (unless (check-delete-selection
			    string-object (g-value an-interactor :lisp-mode-p))
		     (opal:delete-char string-object)))
		  (:delete-next-word
		   (unless (check-delete-selection
			    string-object (g-value an-interactor :lisp-mode-p))
		     (opal:delete-word string-object)))
                  (:delete-string (opal:set-text string-object nil)
				  (curs-move an-interactor string-object))
		  (:kill-line (do-kill-line an-interactor string-object event))
		  (:delete-selection
		   (do-delete-selection an-interactor string-object event T))
		  (:copy-selection
		   (do-copy-selection an-interactor string-object event))
		  (:copy-to-X-cut-buffer
		   (Opal:Set-X-Cut-Buffer (inter:event-window event)
					  (opal:get-string string-object)))

		  (:yank-buffer
		   (do-yank-buffer an-interactor string-object event)
		   (curs-move an-interactor string-object))
		  (:yank-buffer-or-X-cut-buffer
		   (do-yank-buffer-or-X-cut-buffer an-interactor string-object
						   event))
		  (:copy-from-X-cut-buffer
		   (opal:insert-string string-object
			   (Opal:Get-X-Cut-Buffer (inter:event-window event)))
		   (curs-move an-interactor string-object))

		  (:Insert-LF-after
		     (if (g-value an-interactor :lisp-mode-p)
			 (inter:add-lisp-char string-object #\newline)
			 (opal:add-char string-object #\newline))
		     (opal:go-to-prev-char string-object))

		  (:toggle-bold
		   (Set-Font-Changing string-object NIL :toggle-bold NIL))
		  (:bold (Set-Font-Changing string-object NIL :bold NIL))
		  (:italic (Set-Font-Changing string-object NIL :italic NIL))
		  (:bold-italic (Set-Font-Changing string-object NIL
						   :bold-italic NIL))
		  (:roman (Set-Font-Changing string-object NIL :roman NIL))
		  (:toggle-italic
		   (Set-Font-Changing string-object NIL :toggle-italic NIL))
		  (:bigger (Set-Font-Changing string-object NIL NIL :bigger))
		  (:smaller (Set-Font-Changing string-object NIL NIL :smaller))
		  (:small (Set-Font-Changing string-object NIL NIL :small))
		  (:medium (Set-Font-Changing string-object NIL NIL :medium))
		  (:large (Set-Font-Changing string-object NIL NIL :large))
		  (:very-large (Set-Font-Changing string-object NIL NIL`
						  :very-large))
		  (:fixed (Set-Font-Changing string-object :fixed NIL NIL))
		  (:serif (Set-Font-Changing string-object :serif NIL NIL))
		  (:sans-serif (Set-Font-Changing string-object
						  :sans-serif NIL NIL))
                  (T ;; here might be a keyword, char, string, func, or mouse
		   (cond
		     ((and (characterp new-trans-char)
			   (or (graphic-char-p new-trans-char)
			       (eql new-trans-char #\NewLine)))
		      ;; then is a regular character
		      (when (g-value string-object :selection-p)
			(do-delete-selection an-interactor string-object event
					     NIL))
		      ;; add char to string
		      (if (g-value an-interactor :lisp-mode-p)
			 (inter:add-lisp-char string-object new-trans-char)
			 (opal:add-char string-object new-trans-char))
		      (curs-move an-interactor string-object))
		     ;; check if a string
		     ((stringp new-trans-char) ; then insert into string
		      (when (g-value string-object :selection-p)
			(do-delete-selection an-interactor string-object event
					     T))
		      (opal:Insert-String string-object new-trans-char)
		      (curs-move an-interactor string-object))
		     ;; now check for functions
		     ((garnet-utils:safe-functionp new-trans-char)
					; then call the function
		      (funcall new-trans-char an-interactor string-object
			       event)
		      (curs-move an-interactor string-object))
		     ((event-mousep event)  
		      (if (is-a-p an-interactor MULTIFONT-TEXT-INTERACTOR)
			 (Handle-Move-Cursor an-interactor string-object event)
			  ;; else is a focus-multifont so don't do anything
			  NIL))
		     (T ; otherwise, must be a bad character
		      (Beep))))))))))


(defun MultiFont-Text-do-start (an-interactor obj-over event)
  (if-debug an-interactor (format T "Multi-Font starting over ~s~%" obj-over))
        ;; if obj-to-change supplied, then use that, otherwise use whatever was
	;; under the mouse when started
  (let ((obj (or (g-value an-interactor :obj-to-change) obj-over))
	need-moved)
    (if (g-value an-interactor :continuous)  ;then will go to running state
	(progn
	  (setq need-moved (g-value an-interactor :drag-through-selection?))
	  (Fix-Running-Where an-interactor obj-over)
	  (s-value an-interactor :remembered-object obj) ; object to edit
	  (s-value an-interactor :dragging-now NIL)
	  (GoToRunningState an-interactor
			    (if (eq T (Get-Running-where an-interactor))
				need-moved
				T))  ; need mouse moved to see if outside
	  (kr-send an-interactor :start-action an-interactor obj event))
	;else call stop-action
	(progn
	  (GoToStartState an-interactor NIL)
	  (kr-send an-interactor :stop-action an-interactor obj event)))))

;;;============================================================
;;; Text schema
;;;============================================================

;;; Here's the actual interactor.
(Create-Schema 'inter:MULTIFONT-TEXT-INTERACTOR
      (:is-a inter:text-interactor)
      (:lisp-mode-p NIL)
      (:match-parens-p NIL)
      (:match-obj NIL)
      (:key-translation-table (o-formula (if (gvl :lisp-mode-p)
					     (gvl :lisp-translation-table)
					   (gvl :standard-translation-table))))
      (:standard-translation-table NIL) ;table of translations; set below
      (:lisp-translation-table NIL) ;table of translations for lisp; set below
      (:after-cursor-moves-func (o-formula (when (gvl :match-parens-p)
						 #'check-parens)))
      (:running-where T)
      (:drag-through-selection? T) 
      (:start-action 'Multifont-Text-Int-Start-Action)
      (:Do-Start 'MultiFont-Text-do-start) ; special start for drag-through
      (:edit-func 'Multifont-Edit-String)
      (:stop-action 'Multifont-Text-Int-Stop-Action)
      (:abort-action 'Multifont-Text-Int-Abort-Action)
      (:outside-action 'Multifont-Text-Int-Outside-Action)
      (:back-inside-action 'Multifont-Text-Int-Back-Inside-Action)
      (:initialize 'Multifont-Text-Interactor-Initialize))

(Set-MultiFont-Default-Key-Translations inter:MULTIFONT-TEXT-INTERACTOR)
(Set-Lisp-Key-Translations inter:MULTIFONT-TEXT-INTERACTOR)
