;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; CHANGE LOG:
;;;  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.
;;;

;;; This file contains the mouse and keyboard interactors to input
;;; multifont text.
;;; It should be loaded after Interactor
;;;

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

(export '(MULTIFONT-TEXT-INTERACTOR))


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


;; 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-STRINGS 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-STRINGS 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-STRINGS orig-obj-over
                  (g-value an-interactor :original-string))
            (opal:SET-CURSOR-VISIBLE orig-obj-over NIL)
         )
      )
   )
)


;; 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
      (if (and (event-mousep event) ; then see if want to move cursor
            (event-downp event) (g-value an-interactor :cursor-where-press))
         (progn
            (opal:set-cursor-to-x-y-position string-object
                  (event-x event) (event-y event))
            (opal:SET-CURSOR-VISIBLE string-object T)
         )
         ; else use the translation
         (let ((new-trans-char
                     (inter::Translate-key (event-char event) an-interactor)))
            (when new-trans-char
               (unless (eq (event-char event) :control-\k)
                  (s-value string-object :kill-mode nil)
               )
               (case new-trans-char
                  (:prev-char (opal:go-to-prev-char string-object))
                  (:next-char (opal:go-to-next-char string-object))
                  (:up-line   (opal:go-to-prev-line string-object))
                  (:down-line (opal:go-to-next-line string-object))
                  (:delete-prev-char (opal:delete-prev-char string-object))
                  (:delete-prev-word (opal:delete-prev-word string-object))
                  (:delete-next-char (opal:delete-char string-object))
                  (:delete-string    (opal:set-strings string-object nil))
                  (:beginning-of-string
                        (progn
                           (opal:go-to-beginning-of-text string-object)
                           (opal:set-cursor-visible string-object t)
                        ))
                  (:beginning-of-line
                        (opal:go-to-beginning-of-line string-object))
                  (:end-of-string
                        (progn
                           (opal:go-to-end-of-text string-object)
                           (opal:set-cursor-visible string-object t)
                        ))
                  (:end-of-line      (opal:go-to-end-of-line string-object))
                  (T ;; here might be a keyword, character, string, or function
                        (cond
                           ((event-mousep event) NIL) ; ignore these
                           ((and (characterp new-trans-char)
                                 (or (graphic-char-p new-trans-char)
                                 (eql new-trans-char #\NewLine)))
                              ; then is a regular character, so add to str
                              (opal:add-char string-object new-trans-char))
                           ;; check if a string
                           ((stringp new-trans-char) ; then insert into string
                              (opal:Insert-String string-object
                                    new-trans-char))
                           ; now check for functions
                           ((if (symbolp new-trans-char) ; check if a function,
                                             ; need all 3 tests to do it right!
                                  (fboundp new-trans-char)
                                  (functionp new-trans-char))
                              ; then call the function
                              (funcall new-trans-char an-interactor
                                    string-object event))
                           (T ; otherwise, must be a bad character
                              (Beep))
                        )
                  )
               )
            )
         )
      )
   )
)


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

;;; Here's the actual interactor.
(Create-Schema 'inter:MULTIFONT-TEXT-INTERACTOR
      (:is-a inter:text-interactor)
      (:start-action 'Multifont-Text-Int-Start-Action)
      (: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)
)


;;; Kill line (like in Emacs)
(Bind-Key :control-\k
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor))
        (let ((deleted-stuff (opal:kill-rest-of-line obj))
              (a-window (event-window event)))
           (when (string= "" deleted-stuff)
              (setq deleted-stuff (string (opal:delete-char obj)))
           )
           (opal:set-x-cut-buffer a-window
                 (if (g-value obj :kill-mode)
                    (concatenate 'string (opal:get-x-cut-buffer a-window)
                          deleted-stuff)
                    deleted-stuff
                 ))
           (s-value obj :kill-mode t)
        )
     )
   MultiFont-Text-Interactor
)


;;; Yank buffer (like Emacs)
(Bind-Key :control-\y
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor))
        (let ((yanked-stuff (opal:get-x-cut-buffer (event-window event))))
           (opal:insert-string obj yanked-stuff)
        )
     )
   MultiFont-Text-Interactor
)


;;; delete next word
(Bind-Key :control-D
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (opal:delete-word obj)
     )
   MultiFont-Text-Interactor
)


;;; delete previous word
(Bind-Key :control-H
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (opal:delete-prev-word obj)
     )
   MultiFont-Text-Interactor
)


;;;----------------------------------------------------------------
;;; The rest of this file binds function keys to certain commands
;;; to alter the font of the text.  First, we need something which,
;;; given an xlib font, extracts its family, face, and size.


;; Put the pertinent information about a font into a convenient format.
(defun extract-key-from-font (font)
   (list (g-value font :family) (g-value font :face) (g-value font :size))
)


;; Next text typed will be in regular face
(Bind-Key :F2
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (let ((key (extract-key-from-font (g-value obj :current-font))))
           (setf (second key) :roman)
           (s-value obj :current-font (opal:get-standard-font (first key)
                 (second key) (third key)))
        )
     )
   MultiFont-Text-Interactor
)


;; Next text typed will be in italic face
(Bind-Key :F3
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (let ((key (extract-key-from-font (g-value obj :current-font))))
           (setf (second key) :italic)
           (s-value obj :current-font (opal:get-standard-font (first key)
                 (second key) (third key)))
        )
     )
   MultiFont-Text-Interactor
)


;; Next text typed will be in bold face
(Bind-Key :F4
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (let ((key (extract-key-from-font (g-value obj :current-font))))
           (setf (second key) :bold)
           (s-value obj :current-font (opal:get-standard-font (first key)
                 (second key) (third key)))
        )
     )
   MultiFont-Text-Interactor
)


;; Next text typed will be in bold-italic face
(Bind-Key :F5
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (let ((key (extract-key-from-font (g-value obj :current-font))))
           (setf (second key) :bold-italic)
           (s-value obj :current-font (opal:get-standard-font (first key)
                 (second key) (third key)))
        )
     )
   MultiFont-Text-Interactor
)


;; Next text typed will be in next bigger size
(Bind-Key :F6
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (let ((key (extract-key-from-font (g-value obj :current-font))))
           (setf (third key)
                 (case (third key)
                    (:small :medium)
                    (:medium :large)
                    (:large :very-large)
                    (:very-large :very-large)
                 ))
           (s-value obj :current-font (opal:get-standard-font (first key)
                 (second key) (third key)))
        )
     )
   MultiFont-Text-Interactor
)


;; Next text typed will be in next smaller size
(Bind-Key :F7
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (let ((key (extract-key-from-font (g-value obj :current-font))))
           (setf (third key)
                 (case (third key)
                    (:small :small)
                    (:medium :small)
                    (:large :medium)
                    (:very-large :large)
                 ))
           (s-value obj :current-font (opal:get-standard-font (first key)
                 (second key) (third key)))
        )
     )
   MultiFont-Text-Interactor
)


;; Next text typed will be in serif family
(Bind-Key :F8
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (let ((key (extract-key-from-font (g-value obj :current-font))))
           (setf (first key) :serif)
           (s-value obj :current-font (opal:get-standard-font (first key)
                 (second key) (third key)))
        )
     )
   MultiFont-Text-Interactor
)


;; Next text typed will be in sans-serif family
(Bind-Key :F9
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (let ((key (extract-key-from-font (g-value obj :current-font))))
           (setf (first key) :sans-serif)
           (s-value obj :current-font (opal:get-standard-font (first key)
                 (second key) (third key)))
        )
     )
   MultiFont-Text-Interactor
)


;; Next text typed will be in fixed family
(Bind-Key :F10
   #'(lambda (an-interactor obj event)
        (declare (ignore an-interactor event))
        (let ((key (extract-key-from-font (g-value obj :current-font))))
           (setf (first key) :fixed)
           (s-value obj :current-font (opal:get-standard-font (first key)
                 (second key) (third key)))
        )
     )
   MultiFont-Text-Interactor
)
