;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; 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:
;;; 22-Oct-92 RGM Fixed format bug in INSERT-TEXT procedure.
;;; 23-Sep-92 Mickish/koz Pushed some :update-slots slots from MULTIFONT-TEXT
;;;           down into MULTIFONT-LINE instances (partial fix -- remaining
;;;           slots must be dealt with).
;;; 27-Aug-92 Mickish G-value --> gv in :width formula of multifont-text
;;; 26-Jun-92 Mickish Replaced calls to opal::*-method-aggregate with kr-sends
;;;                   of the corresponding methods.
;;; 18-May-92 ECP Added hack to update-text-width to make cursor valid.
;;; 12-May-92 RGM Fixed initialization so that last-line's next-line is NIL.
;;;  7-Apr-92 ECP Moved declaration of frag-height to after defstruct of frag.
;;;  6-Apr-92 Mickish Fixed a typo and missing parameter in a call to
;;;                   calculate-size-of-line in ADD-CHAR
;;;  6-Apr-92 ECP Renamed copy-selection to copy-selected-text so as not
;;;		  to collide with the name of inter:copy-selection.
;;;  2-Apr-92 RGM Released new version.  Made major changes.  Added word wrap
;;;           and the ability to select text.
;;; 21-Oct-91 ECP Implemented :fill-background-p for multifont-text.
;;; 11-Jun-91 ECP Released to test version
;;;

;;; Notes to maintainers:
;;; A) The multifont-text is an aggregate.  The components of the aggregate
;;;    are multifont-lines which draw the strings of the text and one
;;;    multifont-cursor which is a line showing the position of the cursor.
;;; B) Multifont-line are kept as a linked list within the multifont-text:
;;;    the slot, :prev-line, points to the line above and :next-line to the
;;;    line below.  Each line contains a single linked list of "fragments."
;;; C) A fragment is a structure (frag) that holds the actual strings.  There
;;;    is exactly the number of fragments in a line as there are different
;;;    fonts.  If two lines are merges and the first and last fragments of
;;;    corresponding lines contain the same font (which they must), the
;;;    fragments must be merged to form one.  Also, there is not allowed to be
;;;    a fragment of zero length with one exception.  If the first character
;;;    of a line has a different font than the last character of the line
;;;    above, there must be a zero length fragment on that line with the font
;;;    from the line above.  The reason for the extra fragment is to make new
;;;    characters at the beginning of the line the same font as the character
;;;    at the end of the last line.  The procedure calculate-size-of-line is
;;;    able to make a line follow the above conventions.
;;; D) The state of the cursor has five parts: line, character position,
;;;    fragment, fragment position, and x offset.  The cursor is not allowed
;;;    to point to the very beginning of a fragment (frag-pos = 0) unless
;;;    the cursor is at the very beginning of the line.  If the fragment
;;;    position is zero and there exists a previous fragment, the cursor must
;;;    be set to point to the last character in the previous fragment. 
;;; E) The state of the selection pointer consists of four parts: line,
;;;    position, fragment, and fragment position.  A selection area is
;;;    highlighted by setting the multifont-text's :selection-p to true,
;;;    and having the highlight-start and highlight-end components of the
;;;    fragments to be nonequal.

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

(export '(MULTIFONT-TEXT

          SET-CURSOR-VISIBLE
          SET-CURSOR-TO-X-Y-POSITION
          SET-CURSOR-TO-LINE-CHAR-POSITION
          GET-CURSOR-LINE-CHAR-POSITION
          GO-TO-NEXT-CHAR
          GO-TO-PREV-CHAR
          GO-TO-NEXT-WORD
          GO-TO-PREV-WORD
          GO-TO-NEXT-LINE
          GO-TO-PREV-LINE
	  GO-TO-BEGINNING-OF-TEXT
          GO-TO-END-OF-TEXT
	  GO-TO-BEGINNING-OF-LINE
          GO-TO-END-OF-LINE

          FETCH-NEXT-CHAR
          FETCH-PREV-CHAR

          TOGGLE-SELECTION
          SET-SELECTION-TO-X-Y-POSITION
          SET-SELECTION-TO-LINE-CHAR-POSITION
          GET-SELECTION-LINE-CHAR-POSITION
          CHANGE-FONT-OF-SELECTION

          ADD-CHAR
          DELETE-CHAR
          DELETE-PREV-CHAR
          INSERT-STRING
          INSERT-TEXT
          DELETE-SUBSTRING
          DELETE-WORD
          DELETE-PREV-WORD
          KILL-REST-OF-LINE

          COPY-SELECTED-TEXT
          DELETE-SELECTION

          SET-STRINGS
          GET-STRING
          GET-TEXT

          TEXT-TO-PURE-LIST
          PURE-LIST-TO-TEXT
          TEXT-TO-STRING
          CONCATENATE-TEXT))

;;; Global Variables

(defvar *default-xfont*
      (opal::font-to-xfont opal:default-font opal::*default-x-display*))
(defvar *default-ascent* (xlib:max-char-ascent *default-xfont*))
(defvar *default-descent* (xlib:max-char-descent *default-xfont*))
(defvar *mf-cursor-width* 2)
(defvar *delim-chars* '(#\space #\newline #\tab))
(defvar *Free-Line-List* nil) (setf *Free-Line-List* nil)

;;; TYPE w/ print function

;; FRAG : A fragment of text, with just one font
(defstruct (frag (:print-function print-the-frag))
   (width 0)            ; in pixels
   (ascent *default-ascent*)
   (descent *default-descent*)
   (string "")
   (length 0)           ; in characters
   (font opal:default-font)
   (xfont *default-xfont*)
   (start-highlight 0)  ; character position to begin selection highlight
   (end-highlight 0)    ; position to end highlight
   prev-frag
   next-frag
   (break-p nil) ; T if end-of-line is a break, not a true \newline
)

;;; Helper Function used in definitions

(defun frag-height (frag)
  (+ (frag-ascent frag) (frag-descent frag))
)


(defun print-the-frag (f stream depth)
   (declare (ignore depth))
   (format stream "#FRAG<\"~A\" :LENGTH ~A :WIDTH ~A :START-H ~A :END-H ~A"
         (frag-string f) (frag-length f) (frag-width f)
         (frag-start-highlight f) (frag-end-highlight f))
   (if (frag-next-frag f)
      (format stream ">")
      (if (frag-break-p f)
         (format stream " (BREAK)>")
         (format stream " (EOLN)>")
      )
   )
)


(defun update-text-width (gob)
   (if (g-value gob :word-wrap-p)
      (let ((text-width (g-value gob :text-width)))
         (do ((my-line (g-value gob :first-line) (g-value my-line :next-line)))
             ((null my-line))
            (if (> (g-value my-line :width) text-width)
               (wrap-line gob my-line)
               (do ()
                   ((null (undo-wrap-line gob my-line)))
               )
            )
         )
      )
      (do ((my-line (g-value gob :first-line) (g-value my-line :next-line)))
          ((null my-line))
         (when (frag-break-p (g-value my-line :last-frag))
            (merge-lines gob my-line (g-value my-line :next-line))
         )
      )
   )
   ;;; This is a hack -- for some reason, the first time this is called,
   ;;; the update-info-invalid-p bit of the cursor gets stuck with the value T,
   ;;; and from then on, update-slot-invalidated never calls make-object-invalid
   ;;; on the cursor, so the cursor never gets put on its window's invalid
   ;;; object list, so you never see the cursor move again.
   (setf (update-info-invalid-p (g-value gob :cursor :update-info)) NIL)
)


;; INSTANCES

;; MULTIFONT-LINE : A single line of text
(create-instance 'opal::MULTIFONT-LINE opal:graphical-object
   (:update-slots '(:visible :fast-redraw-p :top :left :width :height
                    :line-style :draw-function :fill-background-p))
   (:left (o-formula (gvl :parent :left)))
   (:top (o-formula (if (gvl :prev-line)
                       (+ (gvl :prev-line :top) (gvl :prev-line :height))
                       (gvl :parent :top))))
   (:fast-redraw-p (o-formula (gvl :parent :fast-redraw-p)))
   (:fast-redraw-line-style (o-formula (gvl :parent :fast-redraw-line-style)))
   (:fast-redraw-filling-style
                         (o-formula (gvl :parent :fast-redraw-filling-style)))
   (:length 0)
   (:ascent 0)
   (:descent 0)
   (:width 0)
   (:height (o-formula (+ (gvl :ascent) (gvl :descent))))
   (:line-style (o-formula (gvl :parent :line-style)))
   (:draw-function (o-formula (gvl :parent :draw-function)))
   (:fill-background-p (o-formula (gvl :parent :fill-background-p)))
   (:first-frag nil)  ; points to beginning of doubly linked list of frags
   (:last-frag nil)
   (:prev-line nil)
   (:next-line nil)
)


;; MULTIFONT-TEXT : An aggregate of multifont-lines plus a cursor
(create-instance 'opal:MULTIFONT-TEXT opal:aggregate
   (:update-slots '(:word-wrap-p :text-toggle :text-width))
   (:draw-function :copy)
   (:first-line nil)
   (:last-line nil)
   (:line-style opal:default-line-style)
   (:cursor-line)      ; pointer to line that cursor is in
   (:cursor-frag)      ; pointer to frag containing the cursor
   (:cursor-position 0)  ; character position of cursor within line
   (:cursor-frag-pos 0)  ; character position of cursor within frag
   (:cursor-x-offset 0)  ; x position of cursor
   (:selection-p nil)  ; selection highlight is on or not
   (:select-line)      ; line that selection box is on
   (:select-position)  ; character position of cursor within line
   (:select-frag)      ; frag that selection box is on
   (:select-frag-pos)  ; character position of cursor within frag
   (:text-toggle (o-formula (progn
                               (gvl :text-width)
                               (gvl :word-wrap-p)
                               (update-text-width (gv :self)))))
   (:CURRENT-FONT (o-formula (frag-font (gvl :cursor-frag))))
   (:CURRENT-XFONT (o-formula (opal::font-to-xfont (gvl :current-font)
                                    opal::*default-x-display*)))
   (:LEFT 0)
   (:TOP 0)
   (:HEIGHT (o-formula (+ (- (gvl :last-line :top) (gvl :top))
                             (gvl :last-line :height))))
   (:WIDTH (o-formula (if (gvl :word-wrap-p)
                         (gvl :text-width)
                         (let ((w 0))
                            (do ((line (gvl :first-line)
                                       (g-value line :next-line)))
                                ((null line))
                               (setq w (max w (gv line :width)))
                            )
                            w
                         )
                      )))
   (:STRINGS (list ""))
   (:FILL-BACKGROUND-P nil)
   (:WORD-WRAP-P nil)
   (:TEXT-WIDTH 300)
)


;; MULTIFONT-TEXT-CURSOR : Cursor for multifont-text
(create-instance 'MULTIFONT-TEXT-CURSOR opal:rectangle
   (:draw-function :xor)
   (:filling-style opal:black-fill)
   (:line-style nil)
   (:fast-redraw-p t)
   (:visible nil)
   (:top (o-formula (- (+ (gvl :parent :cursor-line :top)
                          (gvl :parent :cursor-line :ascent))
                       (min (xlib:max-char-ascent (gvl :parent :current-xfont))
                            (gvl :parent :cursor-line :ascent)))))
   (:left (o-formula (+ (gvl :parent :left) (gvl :parent :cursor-x-offset))))
   (:width 2)
   (:height (o-formula
               (min (+ (xlib:max-char-ascent (gvl :parent :current-xfont))
                       (xlib:max-char-descent (gvl :parent :current-xfont)))
                    (gvl :parent :cursor-line :height))))
)


;;; Helper Functions for Methods

;; If the *Free-Line-List* is non-nil, a line is fetched from it to be used
;; as a new line.  Otherwise create-instance is used to generate a new line.
(defun get-new-line ()
   (if *Free-Line-List*
      (pop *Free-Line-List*)
      (create-instance nil MULTIFONT-LINE)
   )
)


;; Removes the line from its containing aggregate.  Puts it into the
;; *Free-Line-List* for potential later use.
(defun destroy-line (my-line)
   (opal:remove-component (g-value my-line :parent) my-line)
   (push my-line *Free-Line-List*)
)


;; Turns string str into a list of strings, split up at #\newlines.
(defun break-at-newlines (str)
   (let ((ans nil))
      (do ((pos (position #\newline str :from-end t)
                (position #\newline str :from-end t)))
          ((null pos) (push (concatenate 'string str " ") ans))
         (push (concatenate 'string (subseq str (1+ pos)) " ") ans)
         (setq str (subseq str 0 pos))
      )
   )
)


;; Returns the font as an X-windows compatible font
(defun conditional-font-to-xfont (my-font)
   (cond
      ((xlib:font-p my-font)
         my-font)
      ((is-a-p my-font opal:font)
         (opal::font-to-xfont my-font opal::*default-x-display*))
      (t
         *default-xfont*)
   )
)


;; Locates all spaces in the line that can be used to word wrap.  Returns a
;; list of pairs (position width) indicating the character position and pixel
;; position of each space.  Returned list is in "reversed" order ie. the
;; higher widths are returned first.
(defun find-spaces (my-line)
   (let ((output nil)
         (width 0)
         (my-position 0)
         (spc nil)
         (spc-spc nil)
         char)
      (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
          ((null frag) output)
         (do ((i 0 (1+ i)))
             ((>= i (frag-length frag)))
            (setq char (aref (frag-string frag) i))
            (if (char= #\space char)
               (if spc
                  (if spc-spc
                     (push (list my-position width) output)
                     (setq spc-spc t))
                  (setq spc t))
               (when spc
                  (push (list my-position width) output)
                  (setq spc nil spc-spc nil)))
            (incf my-position)
            (incf width (xlib:char-width (frag-xfont frag) (char-code char)))
         )
      )
   )
)


;; Return the character position to break the line.  The break must occur such
;; that the width of the left part must be less than or equal to parameter,
;; width.
(defun width-break (width my-line)
   (let ((my-position 0)
         (accum 0)
         cut-frag)
      (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
          ((or (null frag)
               (> (+ accum (frag-width frag)) width)) (setq cut-frag frag))
         (incf my-position (frag-length frag))
         (incf accum (frag-width frag)))
      (max 2
         (if cut-frag
            (do ((i 0 (1+ i)))
                ((> accum width) (1- my-position))
               (incf accum (xlib:char-width (frag-xfont cut-frag)
                     (char-code (aref (frag-string cut-frag) i))))
               (incf my-position))
            my-position
         ))
   )
)


;; Return the character position to break the line.  The break could be
;; contained in the spec which is a list of (position width) pairs
;; (see function find-spaces).
(defun find-wrap (width my-line spec)
   (do ((pair (pop spec) (pop spec)))
       ((or (null pair) (< (cadr pair) width))
            (if pair
               (car pair)
               (width-break width my-line)))
   )
)


;; Append first-frag into second-frag if fonts are equal.  Return second frag
;; if successful; otherwise, return first-frag.
(defun merge-frags (my-line first-frag second-frag)
   (if (eq (frag-xfont first-frag) (frag-xfont second-frag))
      (progn
         (setf (frag-prev-frag second-frag) (frag-prev-frag first-frag))
         (if (frag-prev-frag second-frag)
            (setf (frag-next-frag (frag-prev-frag second-frag)) second-frag)
            (s-value my-line :first-frag second-frag)
         )
         (setf (frag-string second-frag)
               (concatenate 'string (frag-string first-frag)
               (frag-string second-frag)))
         (incf (frag-length second-frag) (frag-length first-frag))
         (incf (frag-width second-frag) (frag-width first-frag))
         (setf (frag-prev-frag first-frag) nil)
         (setf (frag-next-frag first-frag) nil)
         (if (= (frag-start-highlight second-frag)
               (frag-end-highlight second-frag))
            (progn
               (setf (frag-start-highlight second-frag)
                     (frag-start-highlight first-frag))
               (setf (frag-end-highlight second-frag)
                     (frag-end-highlight first-frag))
            )
            (if (= (frag-start-highlight first-frag)
                  (frag-end-highlight first-frag))
               (progn
                  (incf (frag-start-highlight second-frag)
                        (frag-length first-frag))
                  (incf (frag-end-highlight second-frag)
                        (frag-length first-frag))
               )
               (progn
                  (setf (frag-start-highlight second-frag)
                        (frag-start-highlight first-frag))
                  (incf (frag-end-highlight second-frag)
                        (frag-length first-frag))
               )
            )
         )
         second-frag
      )
      (progn
         (setf (frag-next-frag first-frag) second-frag)
         (setf (frag-prev-frag second-frag) first-frag)
         first-frag
      )
   )
)


;; Splits a frag into two pieces, the first (old) being left-frag
;; and the second (new) being right-frag.  Returns right-frag.
(defun split-frag (left-frag cursor-sub-index)
   (let ((right-frag (copy-frag left-frag)))
      (setf (frag-string right-frag)
            (subseq (frag-string left-frag) cursor-sub-index))
      (setf (frag-string left-frag)
            (subseq (frag-string left-frag) 0 cursor-sub-index))
      (setf (frag-next-frag left-frag) nil)
      (setf (frag-prev-frag right-frag) nil)
      (setf (frag-length left-frag) cursor-sub-index)
      (decf (frag-length right-frag) cursor-sub-index)
      (setf (frag-width left-frag)
	    (xlib:text-width (frag-xfont left-frag) (frag-string left-frag)))
      (setf (frag-width right-frag)
	    (xlib:text-width (frag-xfont right-frag) (frag-string right-frag)))
      (unless (= (frag-start-highlight left-frag)
            (frag-end-highlight left-frag))
         (if (< (frag-start-highlight left-frag) cursor-sub-index)
            (progn
               (setf (frag-start-highlight right-frag) 0)
               (if (< (frag-end-highlight left-frag) cursor-sub-index)
                  (setf (frag-end-highlight right-frag) 0)
                  (progn
                     (setf (frag-end-highlight left-frag) cursor-sub-index)
                     (decf (frag-end-highlight right-frag) cursor-sub-index)
                  )
               )
            )
            (progn
               (setf (frag-start-highlight left-frag) 0)
               (setf (frag-end-highlight left-frag) 0)
               (decf (frag-start-highlight right-frag) cursor-sub-index)
               (decf (frag-end-highlight right-frag) cursor-sub-index)
            )
         )
      )
      right-frag
   )
)


;; Determine all attributes (other than fragments) of the given line by
;; running through all of its constituent fragments.  Remove zero length
;; fragments from line (except for the first fragment which is a special case).
(defun calculate-size-of-line (gob my-line)
   (let ((length 0)
         (width 0)
         (ascent 0)
         (descent 0)
         (cursor-frag (g-value gob :cursor-frag)))
      (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
          ((null frag))
         (if (zerop (frag-length frag))
            (let ((prev-frag (frag-prev-frag frag))
                  (next-frag (frag-next-frag frag)))
               (if (or prev-frag next-frag)
                  (progn
                     (if prev-frag
                        (progn
                           (setf (frag-break-p prev-frag) (frag-break-p frag))
                           (setf (frag-next-frag prev-frag) next-frag)
                           (when (eq frag cursor-frag)
                              (s-value gob :cursor-frag prev-frag)
                              (s-value gob :cursor-frag-pos
                                   (frag-length prev-frag))
                           )
                        )
                        (progn
                           (s-value my-line :first-frag next-frag)
                           (when (eq frag cursor-frag)
                              (s-value gob :cursor-frag next-frag)
                           )
                        )
                     )
                     (if next-frag
                       (setf (frag-prev-frag next-frag) prev-frag)
                        (s-value my-line :last-frag prev-frag)
                     )
                  )
                  (progn
                     (setq ascent (frag-ascent frag))
                     (setq descent (frag-descent frag))
                  )
               )
            )
            (let ((prev-frag (frag-prev-frag frag)))
               (incf length (frag-length frag))
               (incf width (frag-width frag))
               (when (and prev-frag
                     (eq (frag-xfont prev-frag) (frag-xfont frag)))
                  (if (eq cursor-frag prev-frag)
                     (s-value gob :cursor-frag frag)
                     (if (eq cursor-frag frag)
                        (incf (g-value gob :cursor-frag-pos)
                              (frag-length prev-frag))
                     )
                  )
                  (merge-frags my-line (frag-prev-frag frag) frag)
               )
               (setq ascent (max (frag-ascent frag) ascent))
               (setq descent (max (frag-descent frag) descent))
            )
         )
      )
      (s-value my-line :length length)
      (s-value my-line :width width)
      (s-value my-line :ascent ascent)
      (s-value my-line :descent descent)
   )
)


;; This returns neccessary computations to update the position of the cursor.
;; Given the line and character offset of the cursor, this will return the
;; fragment, fragment offset, and pixel offset.
(defun calculate-cursor-pos (my-line my-position)
   (let ((frag-offset my-position)
         (x-offset 0)
         cursor-frag)
      (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
          ((or (null frag) (>= (frag-length frag) frag-offset))
                (setq cursor-frag frag))
         (decf frag-offset (frag-length frag))
         (incf x-offset (frag-width frag))
      )
      (incf x-offset (xlib:text-width (frag-xfont cursor-frag)
            (subseq (frag-string cursor-frag) 0 frag-offset)))
      (values cursor-frag frag-offset x-offset)
   )
)


;; Break the line at the given character position.  The cursor position is
;; changed correctly if it is on the line.  The parameter break-p is used to
;; fill the break-p slot in the broken frag.
(defun break-line (gob my-line my-position break-p)
   (let ((length my-position)
         cut-frag new-frag new-line
         (last-frag (g-value my-line :last-frag)))
      (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
          ((or (null frag) (>= (frag-length frag) length))
                (setq cut-frag frag))
         (decf length (frag-length frag))
      )
      (if (frag-break-p last-frag)
         (let* ((next-line (g-value my-line :next-line))
                (result-frag (merge-frags my-line last-frag
                                   (g-value next-line :first-frag))))
            (setq new-line next-line)
            (when (eq new-line (g-value gob :cursor-line))
               (s-value gob :cursor-line my-line)
               (incf (g-value gob :cursor-position) (g-value my-line :length))
            )
            (when (eq new-line (g-value gob :select-line))
               (s-value gob :select-line my-line)
               (incf (g-value gob :select-position) (g-value my-line :length))
            )
            (when (eq cut-frag last-frag)
               (setq cut-frag result-frag)
            )
         )
         (progn
            (setq new-line (get-new-line))
            (s-value new-line :prev-line my-line)
            (s-value new-line :next-line (g-value my-line :next-line))
            (if (g-value new-line :next-line)
               (s-value (g-value new-line :next-line) :prev-line new-line)
               (s-value gob :last-line new-line)
            )
            (s-value my-line :next-line new-line)
            (opal:add-component gob new-line :after my-line)
            (s-value new-line :last-frag last-frag)
         )
      )
      (setq new-frag (split-frag cut-frag length))
      (s-value new-line :first-frag new-frag)
      (setf (frag-break-p cut-frag) break-p)
      (s-value my-line :last-frag cut-frag)
      (if (frag-next-frag new-frag)
         (setf (frag-prev-frag (frag-next-frag new-frag)) new-frag)
         (s-value new-line :last-frag new-frag)
      )
      (calculate-size-of-line gob my-line)
      (calculate-size-of-line gob new-line)
      (when (eq my-line (g-value gob :cursor-line))
         (when (<= my-position (g-value gob :cursor-position))
            (decf (g-value gob :cursor-position) my-position)
            (s-value gob :cursor-line new-line)
         )
         (multiple-value-bind (frag frag-pos x-offset)
                (calculate-cursor-pos (g-value gob :cursor-line)
                      (g-value gob :cursor-position))
            (s-value gob :cursor-frag frag)
            (s-value gob :cursor-frag-pos frag-pos)
            (s-value gob :cursor-x-offset x-offset)
         )
      )
      (when (and (g-value gob :selection-p)
            (eq my-line (g-value gob :select-line)))
         (when (<= my-position (g-value gob :select-position))
            (decf (g-value gob :select-position) my-position)
            (s-value gob :select-line new-line)
         )
         (multiple-value-bind (frag frag-pos)
                (calculate-cursor-pos (g-value gob :select-line)
                      (g-value gob :select-position))
            (s-value gob :select-frag frag)
            (s-value gob :select-frag-pos frag-pos)
         )
      )
   )
)


;; If line is too long, wrap excess onto next line.
(defun wrap-line (gob my-line)
  (when my-line
    (let ((width (g-value gob :text-width)))
      (when (>= (g-value my-line :width) width)
         (break-line gob my-line
               (find-wrap width my-line (find-spaces my-line)) t)
         (wrap-line gob (g-value my-line :next-line))
      )
    )
  )
)


;; Add a space to end of frag.
(defun add-space-to-frag (frag)
   (if (stringp frag)
      (concatenate 'string frag " ")
      (cons (concatenate 'string (car frag) " ") (cdr frag))
   )
)


;; Put a space at the end of the line.
(defun add-space-to-line (my-line)
   (if (stringp my-line)
      (concatenate 'string my-line " ")
      (progn
         (setf (car (last my-line)) (add-space-to-frag (car (last my-line))))
         my-line
      )
   )
)


;; Put a space at the end of every line.  The space represents a newline.
(defun add-spaces (text)
   (let ((ans nil))
      (dolist (my-line text)
         (push (add-space-to-line my-line) ans)
      )
      (reverse ans)
   )
)



;;; METHODS

;; Method :UPDATE used to update the value of :text-toggle so that text width
;; will be updated.
(define-method :update opal:MULTIFONT-TEXT (&rest args)
   (g-value (car args) :text-toggle)
   (apply (g-value opal:aggregate :update) args)
)


;; Method :INITIALIZE : create initial data for text box.
(define-method :initialize opal:MULTIFONT-TEXT (gob &optional (first-time t))
   (when first-time
     (kr-send opal:aggregate :initialize gob)
   )
   (let ((cursor (create-instance nil multifont-text-cursor))
         (strings (g-value gob :strings))
         (prev-line nil) new-line
         prev-frag new-frag
         substring xfont)
      (s-value gob :cursor cursor)
      (opal:add-component gob cursor)
      (if (stringp strings)
         (setq strings (break-at-newlines strings))
         (if (atom strings)
            (setq strings (list " "))
            (setq strings (add-spaces strings))
         )
      )
      (dolist (my-line strings)
         (setq new-line (get-new-line))
         (opal:add-component gob new-line :before cursor)
         (if prev-line
            (s-value prev-line :next-line new-line)
            (s-value gob :first-line new-line)
         )
         (s-value new-line :prev-line prev-line)
         (setq prev-line new-line)
         (setq prev-frag nil)
         (dolist (frag (if (listp my-line) my-line (list my-line)))
            (setq new-frag (make-frag))
            (if prev-frag
               (setf (frag-next-frag prev-frag) new-frag)
               (s-value new-line :first-frag new-frag)
            )
            (setf (frag-prev-frag new-frag) prev-frag)
            (setq prev-frag new-frag)
            (if (stringp frag)
               (setf substring frag)
               (setf substring (car frag) (frag-xfont new-frag)
                     (conditional-font-to-xfont (cdr frag))
                     (frag-font new-frag) (cdr frag))
            )
            (setq xfont (frag-xfont new-frag))
            (setf (frag-string new-frag) substring)
            (setf (frag-width new-frag) (xlib:text-width xfont substring))
            (setf (frag-ascent new-frag) (xlib:max-char-ascent xfont))
            (setf (frag-descent new-frag) (xlib:max-char-descent xfont))
            (setf (frag-length new-frag) (length substring))
         )
         (s-value new-line :last-frag new-frag)
         (calculate-size-of-line gob new-line)
      )
      (s-value new-line :next-line nil)
      (s-value gob :last-line new-line)
      (s-value gob :cursor-line (g-value gob :first-line))
      (s-value gob :cursor-frag (g-value gob :first-line :first-frag))
      (s-value gob :cursor-position 0)
      (s-value gob :cursor-frag-pos 0)
   ) ; end of let
   (when (g-value gob :word-wrap-p)
      (do ((my-line (g-value gob :first-line) (g-value my-line :next-line)))
          ((null my-line))
         (wrap-line gob my-line)))
)


;; Method :DRAW : draws a single line.
(define-method :draw opal::MULTIFONT-LINE (gob line-style-gc filling-style-gc
                                           drawable root-window clip-mask)
   (declare (ignore filling-style-gc))
   (let ((xlib-gc-line (opal::opal-gc-gcontext line-style-gc))
         (left (g-value gob :left))
         (top (+ (g-value gob :top) (g-value gob :ascent)))
         (foreground-color (g-value gob :line-style
               :foreground-color :colormap-index))
         (background-color (g-value gob :line-style
               :background-color :colormap-index)))
      (with-line-styles ((g-value gob :line-style) line-style-gc
                         xlib-gc-line root-window
                         (get (g-value gob :draw-function) :x-draw-function)
                         clip-mask)
         (do ((frag (g-value gob :first-frag) (frag-next-frag frag)))
             ((null frag))
            (opal::set-gc line-style-gc xlib-gc-line :font (frag-xfont frag))
            (if (= (frag-start-highlight frag) (frag-end-highlight frag))
               (progn
                  (if (g-value gob :fill-background-p)
                     (xlib:draw-image-glyphs drawable xlib-gc-line left top
                           (frag-string frag))
                     (xlib:draw-glyphs drawable xlib-gc-line left top
                           (frag-string frag))
                  )
                  (incf left (frag-width frag))
               )
               (if (and (= (frag-start-highlight frag) 0)
                        (= (frag-end-highlight frag) (frag-length frag)))
                  (progn
                     (opal::set-gc line-style-gc xlib-gc-line
                           :foreground background-color)
                     (opal::set-gc line-style-gc xlib-gc-line
                           :background foreground-color)
                     (xlib:draw-image-glyphs drawable xlib-gc-line
                           left top (frag-string frag))
                     (opal::set-gc line-style-gc xlib-gc-line
                           :foreground foreground-color)
                     (opal::set-gc line-style-gc xlib-gc-line
                           :background background-color)
                     (incf left (frag-width frag))
                  )
                  (let ((left-str (subseq (frag-string frag)
                                        0 (frag-start-highlight frag)))
                         (mid-str (subseq (frag-string frag)
                                        (frag-start-highlight frag)
                                        (frag-end-highlight frag)))
                          (right-str (subseq (frag-string frag)
                                        (frag-end-highlight frag))))
                     (if (g-value gob :fill-background-p)
                        (xlib:draw-image-glyphs drawable xlib-gc-line
                              left top left-str)
                        (xlib:draw-glyphs drawable xlib-gc-line
                              left top left-str)
                     )
                     (incf left (xlib:text-width (frag-xfont frag) left-str))
                     (opal::set-gc line-style-gc xlib-gc-line
                           :foreground background-color)
                     (opal::set-gc line-style-gc xlib-gc-line
                           :background foreground-color)
                     (xlib:draw-image-glyphs drawable xlib-gc-line
                           left top mid-str)
                     (incf left (xlib:text-width (frag-xfont frag) mid-str))
                     (opal::set-gc line-style-gc xlib-gc-line
                           :foreground foreground-color)
                     (opal::set-gc line-style-gc xlib-gc-line
                           :background background-color)
                     (if (g-value gob :fill-background-p)
                        (xlib:draw-image-glyphs drawable xlib-gc-line
                              left top right-str)
                        (xlib:draw-glyphs drawable xlib-gc-line
                              left top right-str)
                     )
                     (incf left (xlib:text-width (frag-xfont frag) right-str))
                  )
               )
            )
         )
      )
   )
)



;; Method :DESTROY-ME : Destroys links between the fragments so that they
;; can be cleaned up at next garbage-collection time.
;;; Commented out because it is no longer used
;(define-method :destroy-me opal::MULTIFONT-LINE (gob &optional
;                                                     (top-level-p T))
;   (let (next-frag)
;      (do ((frag (g-value gob :first-frag) next-frag))
;          ((null frag))
;         (setq next-frag (frag-next-frag frag))
;         (setf (frag-prev-frag frag) nil)
;         (setf (frag-next-frag frag) nil)
;      )
;   )
;   (call-prototype-method gob top-level-p)
;)


;;; Helper functions for Operations

;; This returns neccessary computations to update the position of the cursor.
;; Given the line and pixel offset of the cursor, this will return the
;; fragment, fragment offset, pixel offset, and character offset.
(defun calculate-cursor-x (my-line x-offset)
   (let ((my-position (g-value my-line :length))
         (dec-offset (g-value my-line :width)))
      (do ((frag (g-value my-line :last-frag) (frag-prev-frag frag)))
          ((<= (- dec-offset (frag-width frag)) x-offset)
                (decf my-position (frag-length frag))
                (do ((i (frag-length frag) (1- i)))
                    ((<= dec-offset x-offset)
                          (when (and (null (frag-next-frag frag))
                                (= i (frag-length frag)))
                             (decf i)
                             (decf dec-offset
                                   (xlib:char-width (frag-xfont frag)
                                   (char-code (aref (frag-string frag) i))))
                          )
                          (if (and (zerop i) (frag-prev-frag frag))
                             (values (frag-prev-frag frag)
                                   (frag-length (frag-prev-frag frag))
                                   dec-offset my-position)
                             (values frag i dec-offset (+ my-position i))
                          )
                    )
                   (decf dec-offset (xlib:char-width (frag-xfont frag)
                         (char-code (aref (frag-string frag) (1- i)))))
                )
          )
         (decf dec-offset (frag-width frag))
         (decf my-position (frag-length frag))
      )
   )
)


;; Makes certain that line gets redrawn even though no slot in the line schema
;; has changed.
(defmacro invalidate-line (line)
   `(invalidate-object-bbox ,line)
)


;; Reset font.  This is neccessary since it is possible for the user to set
;; the font with a s-value to :current-font.  This must be reset whenever any
;; operation other than adding characters is performed.
(defmacro reset-font (gob)
   `(s-value ,gob :current-font (frag-font (g-value ,gob :cursor-frag)))
)


;; Returns t if cursor position 1 is higher (or equal) to cursor position 2,
;; nil otherwise.
(defun higher-cursor (line1 pos1 line2 pos2)
   (if (< (g-value line1 :top) (g-value line2 :top))
      t
      (if (eq line1 line2)
         (<= pos1 pos2)
         nil
      )
   )
)


;; Switch highlight on for the single line between positions pos1 and pos2.
(defun turn-on-segment-mid (my-line pos1 pos2)
   (unless (= pos1 pos2)
      (invalidate-line my-line)
      (let ((dec-pos1 pos1)
            (dec-pos2 pos2))
         (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
             ((>= (frag-length frag) dec-pos1)
                (if (>= (frag-length frag) dec-pos2)
                   (if (= (frag-start-highlight frag)
                         (frag-end-highlight frag))
                      (progn
                         (setf (frag-start-highlight frag) dec-pos1)
                         (setf (frag-end-highlight frag) dec-pos2)
                      )
                      (if (> (frag-start-highlight frag) dec-pos1)
                         (setf (frag-start-highlight frag) dec-pos1)
                         (setf (frag-end-highlight frag) dec-pos2)
                      )
                   )
                   (progn
                      (if (= (frag-start-highlight frag)
                            (frag-end-highlight frag))
                         (setf (frag-start-highlight frag) dec-pos1)
                         (when (> (frag-start-highlight frag) dec-pos1)
                            (setf (frag-start-highlight frag) dec-pos1))
                      )
                      (setf (frag-end-highlight frag) (frag-length frag))
                      (decf dec-pos2 (frag-length frag))
                      (do ((nfrag (frag-next-frag frag)
                                 (frag-next-frag nfrag)))
                          ((>= (frag-length nfrag) dec-pos2)
                             (if (= (frag-start-highlight nfrag)
                                   (frag-end-highlight nfrag))
                                (setf (frag-end-highlight nfrag) dec-pos2)
                                (when (< (frag-end-highlight nfrag) dec-pos2)
                                   (setf (frag-end-highlight nfrag) dec-pos2))
                             )
                             (setf (frag-start-highlight nfrag) 0)
                          )
                         (setf (frag-start-highlight nfrag) 0)
                         (setf (frag-end-highlight nfrag) (frag-length nfrag))
                         (decf dec-pos2 (frag-length nfrag))
                      )
                   )
                )
             )
            (decf dec-pos1 (frag-length frag))
            (decf dec-pos2 (frag-length frag))
         )
      )
   )
)


;; Switch highlight on for the single line between start of line and pos.
(defun turn-on-segment-left (my-line pos)
   (unless (= pos 0)
      (invalidate-line my-line)
      (let ((dec-pos pos))
         (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
             ((>= (frag-length frag) dec-pos)
                (if (= (frag-start-highlight frag) (frag-end-highlight frag))
                   (setf (frag-end-highlight frag) dec-pos)
                   (when (< (frag-end-highlight frag) dec-pos)
                      (setf (frag-end-highlight frag) dec-pos))
                )
                (setf (frag-start-highlight frag) 0)
             )
            (decf dec-pos (frag-length frag))
            (setf (frag-start-highlight frag) 0)
            (setf (frag-end-highlight frag) (frag-length frag))
         )
      )
   )
)


;; Switch highlight on for the single line between pos and end of line.
(defun turn-on-segment-right (my-line pos)
   (unless (= pos (g-value my-line :length))
      (invalidate-line my-line)
      (let ((dec-pos (g-value my-line :length)))
         (do ((frag (g-value my-line :last-frag) (frag-prev-frag frag)))
             ((<= (- dec-pos (frag-length frag)) pos)
                (let ((frag-pos (- (+ pos (frag-length frag)) dec-pos)))
                   (if (= (frag-start-highlight frag)
                         (frag-end-highlight frag))
                      (setf (frag-start-highlight frag) frag-pos)
                      (when (> (frag-start-highlight frag) frag-pos)
                         (setf (frag-start-highlight frag) frag-pos))
                   )
                )
                (setf (frag-end-highlight frag) (frag-length frag))
             )
            (decf dec-pos (frag-length frag))
            (setf (frag-start-highlight frag) 0)
            (setf (frag-end-highlight frag) (frag-length frag))
         )
      )
   )
)


;; Switch highlight on for the single line.
(defun turn-on-line (my-line)
   (invalidate-line my-line)
   (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
       ((null frag))
      (setf (frag-start-highlight frag) 0)
      (setf (frag-end-highlight frag) (frag-length frag))
   )
)


;; Makes selection box visible between the two points given.
(defun turn-on-select (line1 pos1 line2 pos2)
   (if (eq line1 line2)
      (turn-on-segment-mid line1 pos1 pos2)
      (progn
         (turn-on-segment-right line1 pos1)
         (do ((my-line (g-value line1 :next-line)
                       (g-value my-line :next-line)))
             ((eq my-line line2))
            (turn-on-line my-line))
         (turn-on-segment-left line2 pos2)
      )
   )
)


;; Switch highlight off for the single line between pos1 and pos2.
(defun turn-off-segment-mid (my-line pos1 pos2)
   (unless (= pos1 pos2)
      (invalidate-line my-line)
      (let ((dec-pos1 pos1)
            (dec-pos2 pos2))
         (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
             ((>= (frag-length frag) dec-pos1)
                (if (>= (frag-length frag) dec-pos2)
                   (unless (= (frag-start-highlight frag)
                         (frag-end-highlight frag))
                      (if (= (frag-start-highlight frag) dec-pos1)
                         (setf (frag-start-highlight frag) dec-pos2)
                         (setf (frag-end-highlight frag) dec-pos1)
                      )
                   )
                   (progn
                      (unless (= (frag-start-highlight frag)
                            (frag-end-highlight frag))
                         (setf (frag-end-highlight frag) dec-pos1)
                      )
                      (decf dec-pos2 (frag-length frag))
                      (do ((nfrag (frag-next-frag frag)
                                 (frag-next-frag nfrag)))
                          ((>= (frag-length nfrag) dec-pos2)
                             (unless (= (frag-start-highlight nfrag)
                                   (frag-end-highlight nfrag))
                                (setf (frag-start-highlight nfrag) dec-pos2)
                             )
                          )
                         (setf (frag-start-highlight nfrag) 0)
                         (setf (frag-end-highlight nfrag) 0)
                         (decf dec-pos2 (frag-length nfrag))
                      )
                   )
                )
             )
            (decf dec-pos1 (frag-length frag))
            (decf dec-pos2 (frag-length frag))
         )
      )
   )
)


;; Switch highlight off for the single line between start of line and pos.
(defun turn-off-segment-left (my-line pos)
   (unless (= pos 0)
      (invalidate-line my-line)
      (let ((dec-pos pos))
         (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
             ((>= (frag-length frag) dec-pos)
                (setf (frag-start-highlight frag) dec-pos)
             )
            (decf dec-pos (frag-length frag))
            (setf (frag-start-highlight frag) 0)
            (setf (frag-end-highlight frag) 0)
         )
      )
   )
)


;; Switch highlight off for the single line between pos and end of line.
(defun turn-off-segment-right (my-line pos)
   (unless (= pos (g-value my-line :length))
      (invalidate-line my-line)
      (let ((dec-pos (g-value my-line :length)))
         (do ((frag (g-value my-line :last-frag) (frag-prev-frag frag)))
             ((<= (- dec-pos (frag-length frag)) pos)
                (setf (frag-end-highlight frag)
                      (- (+ pos (frag-length frag)) dec-pos))
             )
            (decf dec-pos (frag-length frag))
            (setf (frag-start-highlight frag) 0)
            (setf (frag-end-highlight frag) 0)
         )
      )
   )
)


;; Switch highlight off for the single line.
(defun turn-off-line (my-line)
   (invalidate-line my-line)
   (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
       ((null frag))
      (setf (frag-start-highlight frag) 0)
      (setf (frag-end-highlight frag) 0)
   )
)


;; Makes selection box invisible between the two points given.
(defun turn-off-select (line1 pos1 line2 pos2)
   (if (eq line1 line2)
      (turn-off-segment-mid line1 pos1 pos2)
      (progn
         (turn-off-segment-right line1 pos1)
         (do ((my-line (g-value line1 :next-line)
                       (g-value my-line :next-line)))
             ((eq my-line line2))
            (turn-off-line my-line))
         (turn-off-segment-left line2 pos2)
      )
   )
)


;; When the cursor gets moved to a random position.  The selection box may
;; need to be updated aggressively.  This function performs an aggressive
;; change to the selection box.  change-line, change-pos is the end-point of
;; the selection that was moved.  stable-line, stable-pos is the other
;; end-point of the selection.  new-line, new-pos is the new end-point.
(defun reset-selection (change-line change-pos stable-line stable-pos
                        new-line new-pos)
   (if (higher-cursor stable-line stable-pos change-line change-pos)
      (if (higher-cursor new-line new-pos stable-line stable-pos)
         (progn
            (turn-on-select new-line new-pos stable-line stable-pos)
            (turn-off-select stable-line stable-pos change-line change-pos)
         )
         (if (higher-cursor new-line new-pos change-line change-pos)
            (turn-off-select new-line new-pos change-line change-pos)
            (turn-on-select change-line change-pos new-line new-pos)
         )
      )
      (if (higher-cursor stable-line stable-pos new-line new-pos)
         (progn
            (turn-on-select stable-line stable-pos new-line new-pos)
            (turn-off-select change-line change-pos stable-line stable-pos)
         )
         (if (higher-cursor change-line change-pos new-line new-pos)
            (turn-off-select change-line change-pos new-line new-pos)
            (turn-on-select new-line new-pos change-line change-pos)
         )
      )
   )
)


;; Merges first-line and second-line.
(defun merge-lines (gob first-line second-line)
   (let ((last-frag-of-first-line (g-value first-line :last-frag))
         (first-frag-of-second-line (g-value second-line :first-frag))
         (third-line (g-value second-line :next-line)))
      (s-value first-line :next-line third-line)
      (if third-line
         (s-value third-line :prev-line first-line)
         (s-value gob :last-line first-line)
      )
      (when (= (frag-length first-frag-of-second-line) 0)
         (let ((hold first-frag-of-second-line))
            (setq first-frag-of-second-line
                  (frag-next-frag first-frag-of-second-line))
            (setf (frag-next-frag hold) nil)
            (setf (frag-prev-frag hold) nil)
         )
      )
      (merge-frags first-line last-frag-of-first-line
            first-frag-of-second-line)
      (s-value first-line :last-frag (g-value second-line :last-frag))
      (let ((cursor-line (g-value gob :cursor-line))
            (cursor-position (g-value gob :cursor-position)))
         (if (eq first-line cursor-line)
            (multiple-value-bind (frag frag-pos x-offset)
                  (calculate-cursor-pos first-line cursor-position)
               (s-value gob :cursor-frag frag)
               (s-value gob :cursor-frag-pos frag-pos)
               (s-value gob :cursor-x-offset x-offset)
            )
            (when (eq second-line cursor-line)
               (let* ((length (+ cursor-position
                                    (g-value first-line :length))))
                  (s-value gob :cursor-line first-line)
                  (s-value gob :cursor-position length)
                  (multiple-value-bind (frag frag-pos x-offset)
                         (calculate-cursor-pos first-line length)
                     (s-value gob :cursor-frag frag)
                     (s-value gob :cursor-frag-pos frag-pos)
                     (s-value gob :cursor-x-offset x-offset)
                  )
               )
            )
         )
      )
      (when (g-value gob :selection-p)
         (let ((select-line (g-value gob :select-line))
               (select-position (g-value gob :select-position)))
            (if (eq first-line select-line)
               (multiple-value-bind (frag frag-pos)
                     (calculate-cursor-pos first-line select-position)
                  (s-value gob :select-frag frag)
                  (s-value gob :select-frag-pos frag-pos)
               )
               (when (eq second-line select-line)
                  (let* ((length (+ select-position
                                       (g-value first-line :length))))
                     (s-value gob :select-line first-line)
                     (s-value gob :select-position length)
                     (multiple-value-bind (frag frag-pos)
                            (calculate-cursor-pos select-line length)
                        (s-value gob :select-frag frag)
                        (s-value gob :select-frag-pos frag-pos)
                     )
                  )
               )
            )
         )
      )
      (incf (g-value first-line :length) (g-value second-line :length))
      (incf (g-value first-line :width) (g-value second-line :width))
      (s-value first-line :ascent
            (max (g-value first-line :ascent) (g-value second-line :ascent)))
      (s-value first-line :descent
            (max (g-value first-line :descent) (g-value second-line :descent)))
      (s-value first-line :last-frag (g-value second-line :last-frag))
      (s-value second-line :first-frag nil)
      (s-value second-line :last-frag nil)
      (destroy-line second-line)
      (when (g-value gob :word-wrap-p)
         (wrap-line gob first-line)
      )
   )
)
   

;; Returns non-nil if there exists enough space for part of the second line
;; to be merged into the first.  Returns nil otherwise.
(defun unwrap-space-check (gob first-line second-line)
   (let ((text-width (g-value gob :text-width))
         (first-width (g-value first-line :width))
         (second-width (g-value second-line :width)))
      (if (<= (+ first-width second-width) text-width)
         T
         (let ((spaces (find-spaces second-line))
               (size (- text-width first-width)))
            (do ((item (pop spaces) (pop spaces)))
                ((or (null item) (<= (second item) size))
                   item
                )
            )
         )
      )
   )
)


;; Merges line with its next line if the line has enough space to accomodate
;; a word of the next line.  Returns non-nil if merge occurs, nil otherwise.
(defun undo-wrap-line (gob my-line)
   (let ((next-line (g-value my-line :next-line)))
      (when next-line
         (let ((last-frag (g-value my-line :last-frag))
               (first-frag (g-value next-line :first-frag))
               (prev-length (g-value my-line :length)))
            (when (zerop (frag-length first-frag))
               (setq first-frag (frag-next-frag first-frag))
            )
            (when (and (frag-break-p last-frag)
                  (or (zerop (frag-length last-frag))
                  (not (char= #\space (aref (frag-string last-frag)
                          (1- (frag-length last-frag)))))
                  (char= #\space (aref (frag-string first-frag) 0))
                  (unwrap-space-check gob my-line next-line)))
               (merge-lines gob my-line next-line)
               (not (= prev-length (g-value my-line :length)))
            )
         )
      )
   )
)


(defun update-font (old-font my-font family size italic bold)
   (if my-font
      my-font
      (let ((key (inter::extract-key-from-font old-font)))
         (when family
            (setf (first key) family)
         )
         (unless (eq italic :not-supplied)
            (setf (second key)
                  (if italic
                     (case italic
                        (:toggle-first (case (second key)
                                          (:roman :italic)
                                          (:bold :bold-italic)
                                          (:italic :roman)
                                          (:bold-italic :bold)
                                       ))
                        (:toggle (case (second key)
                                    (:roman :italic)
                                    (:bold :bold-italic)
                                    (:italic :roman)
                                    (:bold-italic :bold)
                                 ))
                        (t (case (second key)
                              (:roman :italic)
                              (:bold :bold-italic)
                              (:italic :italic)
                              (:bold-italic :bold-italic)
                           ))
                     )
                     (case (second key)
                        (:roman :roman)
                        (:bold :bold)
                        (:italic :roman)
                        (:bold-italic :bold)
                     )
                  ))
         )
         (unless (eq bold :not-supplied)
            (setf (second key)
                  (if bold
                     (case bold
                        (:toggle-first (case (second key)
                                          (:roman :bold)
                                          (:bold :roman)
                                          (:italic :bold-italic)
                                          (:bold-italic :italic)
                                       ))
                        (:toggle (case (second key)
                                    (:roman :bold)
                                    (:bold :roman)
                                    (:italic :bold-italic)
                                    (:bold-italic :italic)
                                 ))
                        (t (case (second key)
                              (:roman :bold)
                              (:bold :bold)
                              (:italic :bold-italic)
                              (:bold-italic :bold-italic)
                           ))
                     )
                     (case (second key)
                        (:roman :roman)
                        (:bold :roman)
                        (:italic :italic)
                        (:bold-italic :italic)
                     )
                  ))
         )
         (when size
            (if (eq size :bigger)
               (setf (third key)
                     (case (third key)
                        (:small :medium)
                        (:medium :large)
                        (:large :very-large)
                        (:very-large :very-large)
                     ))
               (if (eq size :smaller)
                  (setf (third key)
                        (case (third key)
                           (:small :small)
                           (:medium :small)
                           (:large :medium)
                           (:very-large :large)
                        ))
                  (setf (third key) size)
               )
            )
         )
         (opal:get-standard-font (first key) (second key) (third key))
      )
   )
)


(defun change-font-frag (frag my-font family size italic bold first-face)
   (unless my-font
      (let ((key (inter::extract-key-from-font (frag-font frag))))
         (when family
            (setf (first key) family)
         )
         (unless (eq italic :not-supplied)
            (if italic
               (case italic
                  (:toggle-first
                     (if (or (eq first-face :roman) (eq first-face :bold))
                        (setf (second key)
                              (case (second key)
                                 (:roman :italic)
                                 (:bold :bold-italic)
                                 (:italic :italic)
                                 (:bold-italic :bold-italic)
                              ))
                        (setf (second key)
                              (case (second key)
                                 (:roman :roman)
                                 (:bold :bold)
                                 (:italic :roman)
                                 (:bold-italic :bold)
                              ))
                     ))
                  (:toggle (setf (second key)
                                 (case (second key)
                                    (:roman :italic)
                                    (:bold :bold-italic)
                                    (:italic :roman)
                                    (:bold-italic :bold)
                                 )))
                  (t (setf (second key)
                           (case (second key)
                              (:roman :italic)
                              (:bold :bold-italic)
                              (:italic :italic)
                              (:bold-italic :bold-italic)
                           )))
               )
               (setf (second key)
                     (case (second key)
                        (:roman :roman)
                        (:bold :bold)
                        (:italic :roman)
                        (:bold-italic :bold)
                     ))
            )
         )
         (unless (eq bold :not-supplied)
            (if bold
               (case bold
                  (:toggle-first
                     (if (or (eq first-face :roman) (eq first-face :italic))
                        (setf (second key)
                              (case (second key)
                                 (:roman :bold)
                                 (:bold :bold)
                                 (:italic :bold-italic)
                                 (:bold-italic :bold-italic)
                              ))
                        (setf (second key)
                              (case (second key)
                                 (:roman :roman)
                                 (:bold :roman)
                                 (:italic :italic)
                                 (:bold-italic :italic)
                              ))
                     ))
                  (:toggle (setf (second key)
                                 (case (second key)
                                    (:roman :bold)
                                    (:bold :roman)
                                    (:italic :bold-italic)
                                    (:bold-italic :italic)
                                 )))
                  (t (setf (second key)
                           (case (second key)
                              (:roman :bold)
                              (:bold :bold)
                              (:italic :bold-italic)
                              (:bold-italic :bold-italic)
                           )))
               )
               (setf (second key)
                     (case (second key)
                        (:roman :roman)
                        (:bold :roman)
                        (:italic :italic)
                        (:bold-italic :italic)
                     ))
            )
         )
         (when size
            (if (eq size :bigger)
               (setf (third key)
                     (case (third key)
                        (:small :medium)
                        (:medium :large)
                        (:large :very-large)
                        (:very-large :very-large)
                     ))
               (if (eq size :smaller)
                  (setf (third key)
                        (case (third key)
                           (:small :small)
                           (:medium :small)
                           (:large :medium)
                           (:very-large :large)
                        ))
                  (setf (third key) size)
               )
            )
         )
         (setq my-font (opal:get-standard-font (first key) (second key)
               (third key)))
      )
   )
   (let ((xfont (conditional-font-to-xfont my-font)))
      (unless (eq (frag-xfont frag) xfont)
         (setf (frag-font frag) my-font)
         (setf (frag-xfont frag) xfont)
         (setf (frag-ascent frag) (xlib:max-char-ascent xfont))
         (setf (frag-descent frag) (xlib:max-char-descent xfont))
         (setf (frag-width frag)
               (xlib:text-width xfont (frag-string frag)))
      )
   )
)


(defun change-font-mid (gob my-line start-pos end-pos
                        my-font family size italic bold key)
   (unless (= start-pos end-pos)
      (invalidate-line my-line)
      (let ((dec-pos1 start-pos)
            (dec-pos2 end-pos)
            new-frag)
         (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
             ((>= (frag-length frag) dec-pos1)
                (setq new-frag (split-frag frag dec-pos1))
                (setf (frag-prev-frag new-frag) frag)
                (setf (frag-next-frag frag) new-frag)
                (if (frag-next-frag new-frag)
                   (setf (frag-prev-frag (frag-next-frag new-frag)) new-frag)
                   (s-value my-line :last-frag new-frag)
                )
                (decf dec-pos2 (frag-length frag))
             )
            (decf dec-pos1 (frag-length frag))
            (decf dec-pos2 (frag-length frag))
         )
         (do ((frag new-frag (frag-next-frag frag)))
             ((<= dec-pos2 (frag-length frag))
                (setq new-frag (split-frag frag dec-pos2))
                (setf (frag-prev-frag new-frag) frag)
                (setf (frag-next-frag frag) new-frag)
                (if (frag-next-frag new-frag)
                   (setf (frag-prev-frag (frag-next-frag new-frag)) new-frag)
                   (s-value my-line :last-frag new-frag)
                )
                (change-font-frag frag my-font family size italic bold key)
             )
            (decf dec-pos2 (frag-length frag))
            (change-font-frag frag my-font family size italic bold key)
         )
      )
      (calculate-size-of-line gob my-line)
   )
)


(defun change-font-right (gob my-line pos my-font family size italic bold key)
   (unless (= pos (g-value my-line :length))
      (invalidate-line my-line)
      (let ((dec-pos (- (g-value my-line :length) pos))
            new-frag)
         (do ((frag (g-value my-line :last-frag) (frag-prev-frag frag)))
             ((<= dec-pos (frag-length frag))
                (setq dec-pos (- (frag-length frag) dec-pos))
                (setq new-frag (split-frag frag dec-pos))
                (setf (frag-prev-frag new-frag) frag)
                (setf (frag-next-frag frag) new-frag)
                (if (frag-next-frag new-frag)
                   (setf (frag-prev-frag (frag-next-frag new-frag)) new-frag)
                   (s-value my-line :last-frag new-frag)
                )
                (change-font-frag new-frag
                      my-font family size italic bold key)
             )
            (decf dec-pos (frag-length frag))
            (change-font-frag frag my-font family size italic bold key)
         )
      )
      (calculate-size-of-line gob my-line)
   )
)


(defun change-font-left (gob my-line pos my-font family size italic bold key)
   (unless (= pos 0)
      (invalidate-line my-line)
      (let ((dec-pos pos)
            new-frag)
         (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
             ((<= dec-pos (frag-length frag))
                (setq new-frag (split-frag frag dec-pos))
                (setf (frag-prev-frag new-frag) frag)
                (setf (frag-next-frag frag) new-frag)
                (if (frag-next-frag new-frag)
                   (setf (frag-prev-frag (frag-next-frag new-frag)) new-frag)
                   (s-value my-line :last-frag new-frag)
                )
                (change-font-frag frag my-font family size italic bold key)
             )
            (decf dec-pos (frag-length frag))
            (change-font-frag frag my-font family size italic bold key)
         )
      )
      (calculate-size-of-line gob my-line)
   )
)


(defun change-font-line (gob my-line my-font family size italic bold key)
   (invalidate-line my-line)
   (do ((frag (g-value my-line :first-frag) (frag-next-frag frag)))
       ((null frag))
      (change-font-frag frag my-font family size italic bold key)
   )
   (calculate-size-of-line gob my-line)
)


;; Change the font of all character between the given positions.
(defun change-font (gob start-line start-pos end-line end-pos my-font
                    family size italic bold first-font)
   (let ((key (second (inter::extract-key-from-font first-font))))
      (if (eq start-line end-line)
         (change-font-mid gob start-line start-pos end-pos
               my-font family size italic bold key)
         (progn
            (change-font-right gob start-line start-pos
                  my-font family size italic bold key)
            (do ((my-line (g-value start-line :next-line)
                          (g-value my-line :next-line)))
                ((eq my-line end-line))
               (change-font-line gob my-line my-font
                     family size italic bold key)
            )
            (change-font-left gob end-line end-pos my-font family size
                  italic bold key)
         )
      )
   )
)


;;; OPERATIONS

(defun SET-CURSOR-VISIBLE (gob vis)
   (s-value (g-value gob :cursor) :visible vis)
)


(defun SET-CURSOR-TO-X-Y-POSITION (gob x y)
   (let (new-line)
      (do ((my-line (g-value gob :first-line) (g-value my-line :next-line)))
          ((or (null my-line) (> (g-value my-line :top) y))
                (setq new-line
                      (if my-line
                         (or (g-value my-line :prev-line) my-line)
                         (g-value gob :last-line)
                      ))
          )
      )
      (multiple-value-bind (frag frag-pos x-offset my-position)
            (calculate-cursor-x new-line (max 0 (- x (g-value gob :left))))
         (when (g-value gob :selection-p)
            (reset-selection (g-value gob :cursor-line)
                  (g-value gob :cursor-position) (g-value gob :select-line)
                  (g-value gob :select-position) new-line my-position)
         )
         (s-value gob :cursor-line new-line)
         (s-value gob :cursor-frag frag)
         (s-value gob :cursor-frag-pos frag-pos)
         (s-value gob :cursor-x-offset x-offset)
         (s-value gob :cursor-position my-position)
      )
   )
   (reset-font gob)
   t
)


(defun SET-CURSOR-TO-LINE-CHAR-POSITION (gob my-line char)
   (let ((new-line (g-value gob :first-line)))
      (dotimes (i my-line)
         (when new-line
            (setq new-line (g-value new-line :next-line))))
      (unless new-line
         (setq new-line (g-value gob :last-line)))
      (setq char (min char (1- (g-value new-line :length))))
      (when (g-value gob :selection-p)
         (reset-selection (g-value gob :cursor-line)
               (g-value gob :cursor-position) (g-value gob :select-line)
               (g-value gob :select-position) new-line char)
      )
      (s-value gob :cursor-line new-line)
      (s-value gob :cursor-position char)
      (multiple-value-bind (frag frag-pos x-offset)
            (calculate-cursor-pos new-line char)
         (s-value gob :cursor-frag frag)
         (s-value gob :cursor-frag-pos frag-pos)
         (s-value gob :cursor-x-offset x-offset)
      )
   )
   (reset-font gob)
   t
)


;; Returns multiple values.  First line then char position.
(defun GET-CURSOR-LINE-CHAR-POSITION (gob)
   (let ((target (g-value gob :cursor-line)))
      (do ((my-line (g-value gob :first-line) (g-value my-line :next-line))
           (i 0 (1+ i)))
          ((eq my-line target)
             (values i (g-value gob :cursor-position)))
      )
   )
)


;; Returns character cursor passed over, or #\newline if we went to a 
;; new line, or nil if at end of text.
(defun GO-TO-NEXT-CHAR (gob)
   (let* ((my-line (g-value gob :cursor-line))
          (next-line (g-value my-line :next-line))
          (frag (g-value gob :cursor-frag))
          (frag-pos (g-value gob :cursor-frag-pos)))
      (when (= frag-pos (frag-length frag))
         (setq frag (frag-next-frag frag))
         (setq frag-pos 0)
      )
      (s-value gob :current-font (frag-font frag))
      (if (and (null next-line) (>= frag-pos (1- (frag-length frag)))
            (null (frag-next-frag frag)))
         nil
         (let ((char (aref (frag-string frag) frag-pos)))
            (when (g-value gob :selection-p)
               (invalidate-line my-line)
               (if (= (frag-start-highlight frag) (frag-end-highlight frag))
                  (progn
                     (setf (frag-start-highlight frag) frag-pos)
                     (setf (frag-end-highlight frag) (1+ frag-pos))
                  )
                  (if (= (frag-end-highlight frag) frag-pos)
                     (incf (frag-end-highlight frag))
                     (incf (frag-start-highlight frag))
                  )
               )
            )
            (incf frag-pos)
            (if (and (= frag-pos (frag-length frag))
                  (null (frag-next-frag frag)))
               (progn
                  (unless (frag-break-p frag)
                     (setq char #\newline))
                  (s-value gob :cursor-line next-line)
                  (s-value gob :cursor-frag (g-value next-line :first-frag))
                  (s-value gob :cursor-position 0)
                  (s-value gob :cursor-frag-pos 0)
                  (s-value gob :cursor-x-offset 0)
               )
               (progn
                  (s-value gob :cursor-frag frag)
                  (s-value gob :cursor-frag-pos frag-pos)
                  (incf (g-value gob :cursor-position))
                  (incf (g-value gob :cursor-x-offset)
                        (xlib:char-width (frag-xfont frag) (char-code char)))
               )
            )
            char
         )
      )
   )
)


;; Returns character cursor passed over, or #\newline if cursor went to a 
;; new line, or nil if at beginning of text.
(defun GO-TO-PREV-CHAR (gob)
   (reset-font gob)
   (block zero
      (let ((my-line (g-value gob :cursor-line))
            (frag (g-value gob :cursor-frag))
            (frag-pos (1- (g-value gob :cursor-frag-pos)))
            char char-size)
         (if (< frag-pos 0)
            (progn
               (unless (setq my-line (g-value my-line :prev-line))
                  (return-from zero nil)
               )
               (s-value gob :cursor-line my-line)
               (setq frag
                     (s-value gob :cursor-frag (g-value my-line :last-frag)))
               (s-value gob :cursor-position (g-value my-line :length))
               (setq frag-pos
                     (s-value gob :cursor-frag-pos (1- (frag-length frag))))
               (s-value gob :cursor-x-offset (g-value my-line :width))
               (if (frag-break-p frag)
                  (progn
                     (setq char (aref (frag-string frag) frag-pos))
                     (setq char-size (xlib:char-width (frag-xfont frag)
                           (char-code char)))
                  )
                  (progn
                     (setq char #\newline)
                     (setq char-size (xlib:char-width (frag-xfont frag)
                           (char-code #\space)))
                  )
               )
            )
            (progn
               (setq char (aref (frag-string frag) frag-pos))
               (setq char-size
                     (xlib:char-width (frag-xfont frag) (char-code char)))
            )
         )
         (when (g-value gob :selection-p)
            (invalidate-line my-line)
            (if (= (frag-start-highlight frag) (frag-end-highlight frag))
               (progn
                  (setf (frag-start-highlight frag) frag-pos)
                  (setf (frag-end-highlight frag) (1+ frag-pos))
               )
               (if (> (frag-start-highlight frag) frag-pos)
                  (decf (frag-start-highlight frag))
                  (decf (frag-end-highlight frag))
               )
            )
         )
         (when (and (= frag-pos 0) (frag-prev-frag frag))
            (setq frag (frag-prev-frag frag))
            (setq frag-pos (frag-length frag))
         )
         (s-value gob :cursor-line my-line)
         (s-value gob :cursor-frag frag)
         (s-value gob :cursor-frag-pos frag-pos)
         (decf (g-value gob :cursor-position))
         (decf (g-value gob :cursor-x-offset) char-size)
         char
      )
   )
)


(defun GO-TO-NEXT-WORD (gob)
   (let ((str ""))
      (do ((char (GO-TO-NEXT-CHAR gob) (GO-TO-NEXT-CHAR gob)))
          ((or (null char) (member char *delim-chars*))
             (do ((space char (GO-TO-NEXT-CHAR gob)))
                 ((or (null space)
                        (not (member (FETCH-NEXT-CHAR gob) *delim-chars*)))
                    str
                 )
                (setq str (concatenate 'string str (string space)))
             )
          )
         (setq str (concatenate 'string str (string char)))
      )
   )
)


(defun GO-TO-PREV-WORD (gob)
   (let ((str ""))
      (do ((char (GO-TO-PREV-CHAR gob) (GO-TO-PREV-CHAR gob)))
          ((or (null char) (member char *delim-chars*))
             (do ((space char (GO-TO-PREV-CHAR gob)))
                 ((or (null space)
                        (not (member (FETCH-PREV-CHAR gob) *delim-chars*)))
                    str
                 )
                (setq str (concatenate 'string str (string space)))
             )
          )
         (setq str (concatenate 'string str (string char)))
      )
   )
)


(defun GO-TO-NEXT-LINE (gob)
   (let ((next-line (g-value gob :cursor-line :next-line)))
      (when next-line
         (multiple-value-bind (frag frag-pos x-offset my-position)
               (calculate-cursor-x next-line (g-value gob :cursor-x-offset))
            (when (g-value gob :selection-p)
               (reset-selection (g-value gob :cursor-line)
                     (g-value gob :cursor-position) (g-value gob :select-line)
                     (g-value gob :select-position) next-line my-position)
            )
            (s-value gob :cursor-line next-line)
            (s-value gob :cursor-frag frag)
            (s-value gob :cursor-frag-pos frag-pos)
            (s-value gob :cursor-x-offset x-offset)
            (s-value gob :cursor-position my-position)
         )
      )
   )
   (reset-font gob)
)


(defun GO-TO-PREV-LINE (gob)
   (let ((prev-line (g-value gob :cursor-line :prev-line)))
      (when prev-line
         (multiple-value-bind (frag frag-pos x-offset my-position)
               (calculate-cursor-x prev-line (g-value gob :cursor-x-offset))
            (when (g-value gob :selection-p)
               (reset-selection (g-value gob :cursor-line)
                     (g-value gob :cursor-position) (g-value gob :select-line)
                     (g-value gob :select-position) prev-line my-position)
            )
            (s-value gob :cursor-line prev-line)
            (s-value gob :cursor-frag frag)
            (s-value gob :cursor-frag-pos frag-pos)
            (s-value gob :cursor-x-offset x-offset)
            (s-value gob :cursor-position my-position)
         )
      )
   )
   (reset-font gob)
)


(defun GO-TO-BEGINNING-OF-TEXT (gob)
   (let ((my-line (g-value gob :first-line)))
      (when (g-value gob :selection-p)
         (reset-selection (g-value gob :cursor-line)
               (g-value gob :cursor-position) (g-value gob :select-line)
               (g-value gob :select-position) my-line 0)
      )
      (s-value gob :cursor-line my-line)
      (s-value gob :cursor-frag (g-value my-line :first-frag))
      (s-value gob :cursor-frag-pos 0)
      (s-value gob :cursor-x-offset 0)
      (s-value gob :cursor-position 0)
   )
   (reset-font gob)
)


(defun GO-TO-END-OF-TEXT (gob)
   (let* ((my-line (g-value gob :last-line))
          (length (1- (g-value my-line :length))))
      (when (g-value gob :selection-p)
         (reset-selection (g-value gob :cursor-line)
               (g-value gob :cursor-position) (g-value gob :select-line)
               (g-value gob :select-position) my-line length)
      )
      (s-value gob :cursor-line my-line)
      (s-value gob :cursor-position length)
      (multiple-value-bind (frag frag-pos x-offset)
            (calculate-cursor-pos my-line length)
         (s-value gob :cursor-frag frag)
         (s-value gob :cursor-frag-pos frag-pos)
         (s-value gob :cursor-x-offset x-offset)
      )
   )
   (reset-font gob)
)


(defun GO-TO-BEGINNING-OF-LINE (gob)
   (let ((my-line (g-value gob :cursor-line)))
      (when (g-value gob :selection-p)
         (reset-selection (g-value gob :cursor-line)
               (g-value gob :cursor-position) (g-value gob :select-line)
               (g-value gob :select-position) my-line 0)
      )
      (s-value gob :cursor-line my-line)
      (s-value gob :cursor-frag (g-value my-line :first-frag))
      (s-value gob :cursor-frag-pos 0)
      (s-value gob :cursor-x-offset 0)
      (s-value gob :cursor-position 0)
   )
   (reset-font gob)
)


(defun GO-TO-END-OF-LINE (gob)
   (let* ((my-line (g-value gob :cursor-line))
          (length (1- (g-value my-line :length))))
      (when (g-value gob :selection-p)
         (reset-selection (g-value gob :cursor-line)
               (g-value gob :cursor-position) (g-value gob :select-line)
               (g-value gob :select-position) my-line length)
      )
      (s-value gob :cursor-line my-line)
      (s-value gob :cursor-position length)
      (multiple-value-bind (frag frag-pos x-offset)
            (calculate-cursor-pos my-line length)
         (s-value gob :cursor-frag frag)
         (s-value gob :cursor-frag-pos frag-pos)
         (s-value gob :cursor-x-offset x-offset)
      )
   )
   (reset-font gob)
)


(defun FETCH-NEXT-CHAR (gob)
   (let ((frag (g-value gob :cursor-frag))
         (frag-pos (g-value gob :cursor-frag-pos)))
      (when (= frag-pos (frag-length frag))
         (setq frag (frag-next-frag frag))
         (setq frag-pos 0)
      )
      (let ((char (aref (frag-string frag) frag-pos)))
         (when (and (= (1+ frag-pos) (frag-length frag))
               (null (frag-next-frag frag)))
            (unless (frag-break-p frag)
               (if (g-value gob :cursor-line :next-line)
                  (setq char #\newline)
                  (setq char nil)
               )
            )
         )
         char
      )
   )
)


(defun FETCH-PREV-CHAR (gob)
   (let ((frag (g-value gob :cursor-frag))
         (frag-pos (1- (g-value gob :cursor-frag-pos)))
         char)
      (if (< frag-pos 0)
         (let ((prev-line (g-value gob :cursor-line :prev-line)))
            (unless prev-line
               (return-from fetch-prev-char nil)
            )
            (setq frag (g-value prev-line :last-frag))
            (if (frag-break-p frag)
               (setq char (aref (frag-string frag) (1- (frag-length frag))))
               (setq char #\newline)
            )
         )
         (setq char (aref (frag-string frag) frag-pos))
      )
      char
   )
)


(defun TOGGLE-SELECTION (gob value)
   (unless (eq (null value) (null (g-value gob :selection-p)))
      (s-value gob :selection-p value)
      (if value
         (progn
            (s-value gob :select-line (g-value gob :cursor-line))
            (s-value gob :select-frag (g-value gob :cursor-frag))
            (s-value gob :select-position (g-value gob :cursor-position))
            (s-value gob :select-frag-pos (g-value gob :cursor-frag-pos))
         )
         (let ((cursor-line (g-value gob :cursor-line))
               (cursor-pos (g-value gob :cursor-position))
               (select-line (g-value gob :select-line))
               (select-pos (g-value gob :select-position)))
            (if (higher-cursor cursor-line cursor-pos select-line select-pos)
               (do ((my-line cursor-line (g-value my-line :next-line)))
                   ((eq my-line select-line) (turn-off-line my-line))
                  (turn-off-line my-line))
               (do ((my-line select-line (g-value my-line :next-line)))
                   ((eq my-line cursor-line) (turn-off-line my-line))
                  (turn-off-line my-line))
            )
         )
      )
   )
)


(defun SET-SELECTION-TO-X-Y-POSITION (gob x y)
   (unless (g-value gob :selection-p)
      (TOGGLE-SELECTION gob t))
   (let (new-line)
      (do ((my-line (g-value gob :first-line) (g-value my-line :next-line)))
          ((or (null my-line) (> (g-value my-line :top) y))
                (setq new-line
                      (if my-line
                         (or (g-value my-line :prev-line) my-line)
                         (g-value gob :last-line)
                      ))
          )
      )
      (multiple-value-bind (frag frag-pos x-offset my-position)
            (calculate-cursor-x new-line (max 0 (- x (g-value gob :left))))
         (declare (ignore x-offset))
         (reset-selection (g-value gob :select-line)
               (g-value gob :select-position) (g-value gob :cursor-line)
               (g-value gob :cursor-position) new-line my-position)
         (s-value gob :select-line new-line)
         (s-value gob :select-frag frag)
         (s-value gob :select-frag-pos frag-pos)
         (s-value gob :select-position my-position)
      )
   )
)


(defun SET-SELECTION-TO-LINE-CHAR-POSITION (gob my-line char)
   (unless (g-value gob :selection-p)
      (TOGGLE-SELECTION gob t))
   (let ((new-line (g-value gob :first-line)))
      (dotimes (i my-line)
         (when new-line
            (setq new-line (g-value new-line :next-line))))
      (unless new-line
         (setq new-line (g-value gob :last-line)))
      (setq char (min char (1- (g-value new-line :length))))
      (reset-selection (g-value gob :select-line)
            (g-value gob :select-position) (g-value gob :cursor-line)
            (g-value gob :cursor-position) new-line char)
      (s-value gob :select-line new-line)
      (s-value gob :select-position char)
      (multiple-value-bind (frag frag-pos)
            (calculate-cursor-pos new-line char)
         (s-value gob :select-frag frag)
         (s-value gob :select-frag-pos frag-pos)
      )
   )
)


(defun GET-SELECTION-LINE-CHAR-POSITION (gob)
   (if (g-value gob :selection-p)
      (let ((target (g-value gob :select-line)))
         (do ((my-line (g-value gob :first-line) (g-value my-line :next-line))
              (i 0 (1+ i)))
             ((eq my-line target)
                (values i (g-value gob :select-position)))
         )
      )
      (values nil nil)
   )
)


(defun CHANGE-FONT-OF-SELECTION (gob my-font &key family size
                                 (italic :not-supplied) (bold :not-supplied))
   (if (g-value gob :selection-p)
      (let* ((cursor-line (g-value gob :cursor-line))
             (cursor-pos (g-value gob :cursor-position))
             (select-line (g-value gob :select-line))
             (select-pos (g-value gob :select-position))
             (cursor-high (higher-cursor cursor-line cursor-pos
                                select-line select-pos)))
         (if cursor-high
            (let ((frag (g-value gob :cursor-frag))
                  (frag-pos (g-value gob :cursor-frag-pos)))
               (when (= frag-pos (frag-length frag))
                  (setq frag (frag-next-frag frag))
               )
               (change-font gob cursor-line cursor-pos select-line select-pos
                     my-font family size italic bold
                     (frag-font frag))
               (s-value gob :current-font (frag-font frag))
            )
            (let ((frag (g-value gob :select-frag))
                  (frag-pos (g-value gob :select-frag-pos)))
               (when (= frag-pos (frag-length frag))
                  (setq frag (frag-next-frag frag))
               )
               (change-font gob select-line select-pos cursor-line cursor-pos
                     my-font family size italic bold
                     (frag-font frag))
               (s-value gob :current-font
                     (frag-font (g-value gob :cursor-frag)))
            )
         )
         (multiple-value-bind (frag frag-pos x-offset)
               (calculate-cursor-pos cursor-line cursor-pos)
            (s-value gob :cursor-frag frag)
            (s-value gob :cursor-frag-pos frag-pos)
            (s-value gob :cursor-x-offset x-offset)
         )
         (multiple-value-bind (frag frag-pos)
               (calculate-cursor-pos select-line select-pos)
            (s-value gob :select-frag frag)
            (s-value gob :select-frag-pos frag-pos)
         )
         (if (g-value gob :word-wrap-p)
            (let ((text-width (g-value gob :text-width)))
               (if cursor-high
                  (do ((my-line (or (g-value cursor-line :prev-line)
                             cursor-line) (g-value my-line :next-line)))
                      ((eq my-line (g-value gob :select-line :next-line)))
                     (if (> (g-value my-line :width) text-width)
                        (wrap-line gob my-line)
                        (do ()
                           ((null (undo-wrap-line gob my-line)))
                        )
                     )
                  )
                  (do ((my-line (or (g-value select-line :prev-line)
                            select-line) (g-value my-line :next-line)))
                      ((eq my-line (g-value gob :cursor-line :next-line)))
                     (if (> (g-value my-line :width) text-width)
                        (wrap-line gob my-line)
                        (do ()
                           ((null (undo-wrap-line gob my-line)))
                        )
                     )
                  )
               )
            )
         )
      )
      (progn
         (s-value gob :current-font (update-font (g-value gob :current-font)
               my-font family size italic bold))
      )
   )
)


(defun ADD-CHAR (gob char &optional new-font)
   (when (and (characterp char) (or (graphic-char-p char) (eq char #\newline)))
      (TOGGLE-SELECTION gob nil)
      (let ((my-line (g-value gob :cursor-line)))
         (invalidate-line my-line)
         (if (eq char #\newline)
            (progn
               (break-line gob my-line (g-value gob :cursor-position) nil)
               (let* ((frag (g-value my-line :last-frag))
                      (width (xlib:char-width (frag-xfont frag)
                                   (char-code #\space))))
                  (setf (frag-string frag)
                        (concatenate 'string (frag-string frag) " "))
                  (incf (g-value my-line :length))
                  (incf (frag-length frag))
                  (incf (frag-width frag) width)
                  (incf (g-value my-line :width) width)
               )
               (when (g-value gob :word-wrap-p)
                  (wrap-line gob (g-value my-line :next-line))
                  (when (g-value my-line :prev-line)
                     (undo-wrap-line gob (g-value my-line :prev-line))
                  )
               )
            )
            (let* ((frag (g-value gob :cursor-frag))
                   (frag-pos (g-value gob :cursor-frag-pos))
                   (my-font (or new-font (g-value gob :current-font)))
                   (xfont (conditional-font-to-xfont my-font)))
               (unless (eq xfont (frag-xfont frag))
                  (if (and (= frag-pos (frag-length frag))
                        (frag-next-frag frag)
                        (eq xfont (frag-xfont (frag-next-frag frag))))
                     (progn
                        (s-value gob :cursor-frag
                              (setq frag (frag-next-frag frag)))
                        (setq frag-pos 0)
                     )
                     (let ((new-frag (make-frag
                              :font my-font
                              :xfont xfont
                              :ascent (xlib:max-char-ascent xfont)
                              :descent (xlib:max-char-descent xfont)
                              :break-p (frag-break-p frag)
                          )))
                        (if (= frag-pos (frag-length frag))
                           (progn
                              (setf (frag-next-frag new-frag)
                                    (frag-next-frag frag))
                              (if (frag-next-frag new-frag)
                                 (setf (frag-prev-frag
                                       (frag-next-frag new-frag)) new-frag)
                                 (progn
                                    (s-value my-line :last-frag new-frag)
                                    (when (g-value my-line :next-line)
                                       (calulate-size-of-line
                                             (g-value my-line :next-line))
                                    )
                                 )
                              )
                           )
                           (let ((right-frag (split-frag frag frag-pos)))
                              (setf (frag-next-frag new-frag) right-frag)
                              (setf (frag-prev-frag right-frag) new-frag)
                              (if (frag-next-frag right-frag)
                                 (setf (frag-prev-frag
                                       (frag-next-frag right-frag)) right-frag)
                                 (s-value my-line :last-frag right-frag)
                              )
                           )
                        )
                        (setf (frag-prev-frag new-frag) frag)
                        (setf (frag-next-frag frag) new-frag)
                        (setq frag-pos 0)
                        (s-value gob :cursor-frag (setq frag new-frag))
                        (s-value my-line :ascent
                              (max (g-value my-line :ascent)
                              (frag-ascent frag)))
                        (s-value my-line :descent
                              (max (g-value my-line :descent)
                              (frag-descent frag)))
                     )
                  )
               )
               (setf (frag-string frag)
                     (concatenate 'string
                           (subseq (frag-string frag) 0 frag-pos) (string char)
                     (subseq (frag-string frag) frag-pos)))
               (incf (frag-length frag))
               (incf (g-value my-line :length))
               (incf (g-value gob :cursor-position))
               (let ((char-size (xlib:char-width (frag-xfont frag)
                                      (char-code char))))
                  (incf (frag-width frag) char-size)
                  (incf (g-value my-line :width) char-size)
                  (incf (g-value gob :cursor-x-offset) char-size)
               )
               (s-value gob :cursor-frag-pos (1+ frag-pos))
               (when (g-value gob :word-wrap-p)
                  (wrap-line gob my-line)
                  (when (g-value my-line :prev-line)
                     (undo-wrap-line gob (g-value my-line :prev-line))
                  )
               )
            )
         )
      )
   )
)


;; Deletes a character from text at the position of its cursor.
;; returns that character, or nil if cursor was at end of text.
(defun DELETE-CHAR (gob)
   (TOGGLE-SELECTION gob nil)
   (let* ((my-line (g-value gob :cursor-line))
          (next-line (g-value my-line :next-line))
          (frag (g-value gob :cursor-frag))
          (frag-pos (g-value gob :cursor-frag-pos)))
      (invalidate-line my-line)
      (when (= frag-pos (frag-length frag))
         (setq frag (frag-next-frag frag))
         (setq frag-pos 0)
      )
      (if (and (null next-line) (>= frag-pos (1- (frag-length frag)))
            (null (frag-next-frag frag)))
         nil
         (let* ((char (aref (frag-string frag) frag-pos))
                (char-size (xlib:char-width (frag-xfont frag)
                                 (char-code char))))
            (setf (frag-string frag) (concatenate 'string
                  (subseq (frag-string frag) 0 frag-pos)
                  (subseq (frag-string frag) (1+ frag-pos))))
            (decf (frag-length frag))
            (decf (g-value my-line :length))
            (decf (frag-width frag) char-size)
            (decf (g-value my-line :width) char-size)
            (when (and (= (frag-length frag) 0) (frag-prev-frag frag))
               (setq frag-pos (frag-length frag))
               (calculate-size-of-line gob my-line)
               (setq frag (g-value gob :cursor-frag))
            )
            (when (and (= frag-pos (frag-length frag))
                  (null (frag-next-frag frag)))
               (unless (frag-break-p frag)
                  (setq char #\newline))
               (merge-lines gob my-line next-line)
               (setq next-line (g-value my-line :next-line))
            )
            (when (g-value gob :word-wrap-p)
               (undo-wrap-line gob my-line)
               (when (g-value my-line :prev-line)
                  (undo-wrap-line gob (g-value my-line :prev-line))
               )
            )
            (reset-font gob)
            char
         )
      )
   )
)


(defun DELETE-PREV-CHAR (gob)
   (TOGGLE-SELECTION gob nil)
   (let ((my-line (g-value gob :cursor-line))
         (frag (g-value gob :cursor-frag))
         (frag-pos (1- (g-value gob :cursor-frag-pos)))
         char char-size)
      (invalidate-line my-line)
      (when (< frag-pos 0)
         (unless (setq my-line (g-value my-line :prev-line))
            (return-from delete-prev-char nil)
         )
         (s-value gob :cursor-line my-line)
         (s-value gob :cursor-frag (setq frag (g-value my-line :last-frag)))
         (s-value gob :cursor-position (g-value my-line :length))
         (setq frag-pos (1- (frag-length frag)))
         (s-value gob :cursor-x-offset (g-value my-line :width))
      )
      (setq char (aref (frag-string frag) frag-pos))
      (setq char-size (xlib:char-width (frag-xfont frag) (char-code char)))
      (setf (frag-string frag)
            (concatenate 'string (subseq (frag-string frag) 0 frag-pos)
            (subseq (frag-string frag) (1+ frag-pos))))
      (decf (frag-length frag))
      (decf (g-value my-line :length))
      (decf (frag-width frag) char-size)
      (decf (g-value my-line :width) char-size)
      (when (and (= frag-pos 0) (frag-prev-frag frag))
         (let ((hold frag))
            (s-value gob :cursor-frag (setq frag (frag-prev-frag frag)))
            (setq frag-pos (frag-length frag))
            (when (= (frag-length hold) 0)
               (calculate-size-of-line gob my-line)
               (setq frag (g-value gob :cursor-frag))
            )
         )
      )
      (if (and (= frag-pos (frag-length frag)) (null (frag-next-frag frag)))
         (progn
            (s-value gob :cursor-line (g-value my-line :next-line))
            (s-value gob :cursor-frag
                  (g-value my-line :next-line :first-frag))
            (s-value gob :cursor-frag-pos 0)
            (s-value gob :cursor-position 0)
            (s-value gob :cursor-x-offset 0)
            (unless (frag-break-p frag)
               (setq char #\newline)
               (merge-lines gob my-line (g-value my-line :next-line))
            )
         )
         (progn
            (s-value gob :cursor-frag-pos frag-pos)
            (decf (g-value gob :cursor-position))
            (decf (g-value gob :cursor-x-offset) char-size)
         )
      )
      (when (g-value gob :word-wrap-p)
         (undo-wrap-line gob my-line)
         (when (g-value my-line :prev-line)
           (undo-wrap-line gob (g-value my-line :prev-line))
         )
      )
      (reset-font gob)
      char
   )
)


(defun INSERT-STRING (gob str &optional new-font)
   (let ((pos (position #\newline str)))
      (if pos
         (progn
            (INSERT-STRING gob (subseq str 0 pos) new-font)
            (ADD-CHAR gob #\newline new-font)
            (INSERT-STRING gob (subseq str (1+ pos)) new-font)
         )
         (when (> (length str) 0)
            (TOGGLE-SELECTION gob nil)
            (let* ((my-line (g-value gob :cursor-line))
                   (frag (g-value gob :cursor-frag))
                   (frag-pos (g-value gob :cursor-frag-pos))
                   (my-font (or new-font (g-value gob :current-font)))
                   (xfont (conditional-font-to-xfont my-font))
                   (str-length (length str)))
               (invalidate-line my-line)
               (unless (eq xfont (frag-xfont frag))
                  (if (and (= frag-pos (frag-length frag))
                        (frag-next-frag frag)
                        (eq xfont (frag-xfont (frag-next-frag frag))))
                     (progn
                        (s-value gob :cursor-frag
                              (setq frag (frag-next-frag frag)))
                        (setq frag-pos 0)
                     )
                     (let ((new-frag (make-frag
                              :font my-font
                              :xfont xfont
                              :ascent (xlib:max-char-ascent xfont)
                              :descent (xlib:max-char-descent xfont)
                              :break-p (frag-break-p frag)
                          )))
                        (if (= frag-pos (frag-length frag))
                           (progn
                              (setf (frag-next-frag new-frag)
                                    (frag-next-frag frag))
                              (if (frag-next-frag new-frag)
				  (setf (frag-prev-frag
					 (frag-next-frag new-frag)) new-frag)
				(let ((next-line (g-value my-line :next-line)))
				  (s-value my-line :last-frag new-frag)
				  (if next-line 
				      (calculate-size-of-line gob next-line)
				    )
                                 )
                              )
                           )
                           (let ((right-frag (split-frag frag frag-pos)))
                              (setf (frag-next-frag new-frag) right-frag)
                              (setf (frag-prev-frag right-frag) new-frag)
                              (if (frag-next-frag right-frag)
                                 (setf (frag-prev-frag
                                       (frag-next-frag right-frag)) right-frag)
                                 (s-value my-line :last-frag right-frag)
                              )
                           )
                        )
                        (setf (frag-prev-frag new-frag) frag)
                        (setf (frag-next-frag frag) new-frag)
                        (setq frag-pos 0)
                        (s-value gob :cursor-frag (setq frag new-frag))
                        (s-value my-line :ascent
                              (max (g-value my-line :ascent)
                              (frag-ascent frag)))
                        (s-value my-line :descent
                              (max (g-value my-line :descent)
                              (frag-descent frag)))
                     )
                  )
               )
               (setf (frag-string frag)
                     (concatenate 'string
                     (subseq (frag-string frag) 0 frag-pos) str
                     (subseq (frag-string frag) frag-pos)))
               (incf (frag-length frag) str-length)
               (incf (g-value my-line :length) str-length)
               (incf (g-value gob :cursor-position) str-length)
               (let ((text-size (xlib:text-width xfont str)))
                  (incf (frag-width frag) text-size)
                  (incf (g-value my-line :width) text-size)
                  (incf (g-value gob :cursor-x-offset) text-size)
               )
               (s-value gob :cursor-frag-pos (+ frag-pos str-length))
               (when (g-value gob :word-wrap-p)
                  (wrap-line gob my-line)
                  (when (g-value my-line :prev-line)
                     (undo-wrap-line gob (g-value my-line :prev-line))
                  )
               )
            )
         )
      )
   )
)


(defun INSERT-TEXT (gob text)
   (if (stringp text)
      (INSERT-STRING gob text)
      (do ((my-line (pop text) (pop text)))
          ((null text)
             (when my-line
                (if (stringp my-line)
                   (INSERT-STRING gob my-line)
                   (dolist (frag my-line)
                      (if (stringp frag)
                         (INSERT-STRING gob frag)
                         (INSERT-STRING gob (car frag) (cdr frag))
		      )
                   )
                )
             )
          )
         (if (stringp my-line)
            (INSERT-STRING gob my-line)
            (dolist (frag my-line)
               (if (stringp frag)
                  (INSERT-STRING gob frag)
                  (INSERT-STRING gob (car frag) (cdr frag))
	       )
            )
         )
         (ADD-CHAR gob #\newline)
      )
   )
)


(defun DELETE-SUBSTRING (gob start-line start-char end-line end-char)
   (SET-CURSOR-TO-LINE-CHAR-POSITION gob start-line start-char)
   (SET-SELECTION-TO-LINE-CHAR-POSITION gob end-line end-char)
   (TEXT-TO-STRING (DELETE-SELECTION gob))
)


;; Returns word deleted.
(defun DELETE-WORD (gob)
   (TOGGLE-SELECTION gob nil)
   (let ((str ""))
      (do ((space (DELETE-CHAR gob) (DELETE-CHAR gob)))
          ((or (null space) (not (member space *delim-chars*)))
             (do ((char space (DELETE-CHAR gob)))
                 ((or (null char) (member (FETCH-NEXT-CHAR gob) *delim-chars*))
                    str
                 )
                (setq str (concatenate 'string str (string char)))
             )
          )
         (setq str (concatenate 'string str (string space)))
      )
   )
)
	       

;; Returns word deleted.
(defun DELETE-PREV-WORD (gob)
   (TOGGLE-SELECTION gob nil)
   (let ((str ""))
      (do ((space (DELETE-PREV-CHAR gob) (DELETE-PREV-CHAR gob)))
           ((or (null space) (not (member space *delim-chars*)))
              (do ((char space (DELETE-PREV-CHAR gob)))
                  ((or (null char)
                         (member (FETCH-PREV-CHAR gob) *delim-chars*))
                     str
                  )
                 (setq str (concatenate 'string str (string char)))
              )
           )
         (setq str (concatenate 'string str (string space)))
      )
   )
)


;; Deletes remainder of line.  Returns text deleted as a string.
(defun KILL-REST-OF-LINE (gob)
   (TOGGLE-SELECTION gob nil)
   (let* ((my-line (g-value gob :cursor-line))
          (next-line (g-value my-line :next-line))
          (frag (g-value gob :cursor-frag))
          (frag-pos (g-value gob :cursor-frag-pos))
          (str ""))
      (invalidate-line my-line)
      (when (or (frag-next-frag frag) (< frag-pos (1- (frag-length frag)))
            next-line)
         (setq str (subseq (frag-string frag) frag-pos))
         (setf (frag-string frag) (subseq (frag-string frag) 0 frag-pos))
         (setf (frag-break-p frag) (frag-break-p (g-value my-line :last-frag)))
         (setf (frag-length frag) (length (frag-string frag)))
         (setf (frag-width frag) (xlib:text-width (frag-xfont frag)
               (frag-string frag)))
         (s-value my-line :last-frag frag)
         (do ((hold (frag-next-frag frag) (frag-next-frag hold)))
             ((null hold))
            (setq str (concatenate 'string str (frag-string hold)))
         )
         (setf (frag-next-frag frag) nil)
         (unless (frag-break-p frag)
            (if (= 1 (length str))
               (progn
                  (setq str (string #\newline))
                  (merge-lines gob my-line next-line)
               )
               (progn
                  (setq str (subseq str 0 (1- (length str))))
                  (setf (frag-string frag)
                        (concatenate 'string (frag-string frag) " "))
                  (incf (frag-length frag))
                  (incf (frag-width frag) (xlib:char-width (frag-xfont frag)
                        (char-code #\space)))
                  (when (g-value gob :word-wrap-p)
                     (wrap-line gob my-line)
                  )
               )
            )
         )
         (calculate-size-of-line gob my-line)
         (when (g-value my-line :next-line)
            (calculate-size-of-line gob (g-value my-line :next-line))
         )
         (when (g-value gob :word-wrap-p)
            (undo-wrap-line gob my-line)
            (when (g-value my-line :prev-line)
               (undo-wrap-line gob (g-value my-line :prev-line))
            )
         )
      )
      (reset-font gob)
      str
   )
)


;; Returns copied portion in text format.
(defun COPY-SELECTED-TEXT (gob)
   (unless (g-value gob :selection-p)
      (return-from copy-selected-text nil)
   )
   (let ((start-line (g-value gob :cursor-line))
         (start-pos (g-value gob :cursor-position))
         (start-frag (g-value gob :cursor-frag))
         (start-frag-pos (g-value gob :cursor-frag-pos))
         (end-line (g-value gob :select-line))
         (end-pos (g-value gob :select-position))
         (end-frag (g-value gob :select-frag))
         (end-frag-pos (g-value gob :select-frag-pos)))
      (when (higher-cursor end-line end-pos start-line start-pos)
         (let ((hold-line start-line)
               (hold-pos start-pos)
               (hold-frag start-frag)
               (hold-frag-pos start-frag-pos))
	   (setq start-line end-line)
	   (setq end-line hold-line)
	   (setq start-pos end-pos)
	   (setq end-pos hold-pos)
	   (setq start-frag end-frag)
	   (setq end-frag hold-frag)
	   (setq start-frag-pos end-frag-pos)
	   (setq end-frag-pos hold-frag-pos)
         )
      )
      (if (eq start-line end-line)
         (if (eq start-frag end-frag)
            (list (list (cons (subseq (frag-string start-frag)
                  start-frag-pos end-frag-pos) (frag-font start-frag))))
            (let ((my-line nil))
               (push (cons (subseq (frag-string end-frag) 0 end-frag-pos)
                     (frag-font end-frag)) my-line)
               (do ((frag (frag-prev-frag end-frag) (frag-prev-frag frag)))
                   ((eq frag start-frag))
                  (push (cons (frag-string frag) (frag-font frag)) my-line)
               )
               (push (cons (subseq (frag-string start-frag) start-frag-pos)
                     (frag-font start-frag)) my-line)
               (list my-line)
            )
         )
         (let ((text (list nil)))
            (push (cons (subseq (frag-string end-frag) 0 end-frag-pos)
                  (frag-font end-frag)) (car text))
            (do ((frag (frag-prev-frag end-frag) (frag-prev-frag frag)))
                ((null frag))
               (push (cons (frag-string frag) (frag-font frag)) (car text))
            )
            (do ((my-line (g-value end-line :prev-line)
                       (g-value my-line :prev-line)))
                ((eq my-line start-line))
               (let ((last-frag (g-value my-line :last-frag)))
                  (if (frag-break-p last-frag)
                     (push (cons (frag-string last-frag)
                           (frag-font last-frag)) (car text))
                     (push (list (cons (subseq (frag-string last-frag)
                           0 (1- (frag-length last-frag)))
                           (frag-font last-frag))) text)
                  )
                  (do ((frag (frag-prev-frag last-frag) (frag-prev-frag frag)))
                      ((null frag))
                     (push (cons (frag-string frag) (frag-font frag))
                           (car text))
                  )
               )
            )
            (let ((last-frag (g-value start-line :last-frag)))
               (if (frag-break-p last-frag)
                  (progn
                     (do ((frag last-frag (frag-prev-frag frag)))
                         ((eq frag start-frag))
                        (push (cons (frag-string frag) (frag-font frag))
                              (car text))
                     )
                     (push (cons (subseq (frag-string start-frag)
                           start-frag-pos) (frag-font start-frag)) (car text))
                  )
                  (if (eq last-frag start-frag)
                     (push (list (cons (subseq (frag-string start-frag)
                           start-frag-pos (1- (frag-length start-frag)))
                           (frag-font start-frag))) text)
                     (progn
                        (push (list (cons (subseq (frag-string last-frag)
                              0 (1- (frag-length last-frag)))
                              (frag-font last-frag))) text)
                        (do ((frag (frag-prev-frag last-frag)
                                   (frag-prev-frag frag)))
                            ((eq frag start-frag))
                           (push (cons (frag-string frag) (frag-font frag))
                                 (car text))
                        )
                        (push (cons (subseq (frag-string start-frag)
                              start-frag-pos) (frag-font start-frag))
                              (car text))
                     )
                  )
               )
            )
            text
         )
      )
   )
)


;; Returns deleted portion in text format.  Turns off selection highlight.
(defun DELETE-SELECTION (gob)
   (unless (g-value gob :selection-p)
      (return-from delete-selection nil)
   )
   (TOGGLE-SELECTION gob nil)
   (let ((start-line (g-value gob :cursor-line))
         (start-pos (g-value gob :cursor-position))
         (start-frag (g-value gob :cursor-frag))
         (start-frag-pos (g-value gob :cursor-frag-pos))
         (end-line (g-value gob :select-line))
         (end-pos (g-value gob :select-position))
         (end-frag (g-value gob :select-frag))
         (end-frag-pos (g-value gob :select-frag-pos))
         (text nil))
      (when (higher-cursor end-line end-pos start-line start-pos)
         (let ((hold-line start-line)
               (hold-pos start-pos)
               (hold-frag start-frag)
               (hold-frag-pos start-frag-pos))
            (setq start-line end-line)
            (setq end-line hold-line)
            (setq start-pos end-pos)
            (setq end-pos hold-pos)
            (setq start-frag end-frag)
            (setq end-frag hold-frag)
            (setq start-frag-pos end-frag-pos)
            (setq end-frag-pos hold-frag-pos)
            (s-value gob :cursor-line start-line)
            (s-value gob :cursor-position start-pos)
            (multiple-value-bind (frag frag-pos x-offset)
                  (calculate-cursor-pos start-line start-pos)
               (s-value gob :cursor-frag frag)
               (s-value gob :cursor-frag-pos frag-pos)
               (s-value gob :cursor-x-offset x-offset)
            )
         )
      )
      (if (eq start-line end-line)
         (if (eq start-frag end-frag)
            (let ((str (subseq (frag-string start-frag)
                             start-frag-pos end-frag-pos))
                  (my-font (frag-font start-frag)))
               (setf (frag-string start-frag)
                     (concatenate 'string (subseq (frag-string start-frag) 0
                     start-frag-pos) (subseq (frag-string start-frag)
                     end-frag-pos)))
               (setf (frag-length start-frag)
                     (length (frag-string start-frag)))
               (setf (frag-width start-frag)
                     (xlib:text-width (frag-xfont start-frag)
                     (frag-string start-frag)))
               (setq text (list (list (cons str my-font))))
            )
            (let ((my-line nil))
               (push (cons (subseq (frag-string end-frag) 0 end-frag-pos)
                     (frag-font end-frag)) my-line)
               (setf (frag-string end-frag)
                     (subseq (frag-string end-frag) end-frag-pos))
               (setf (frag-length end-frag) (length (frag-string end-frag)))
               (setf (frag-width end-frag)
                     (xlib:text-width (frag-xfont end-frag)
                     (frag-string end-frag)))
               (do ((frag (frag-prev-frag end-frag) (frag-prev-frag frag)))
                   ((eq frag start-frag))
                  (push (cons (frag-string frag) (frag-font frag)) my-line)
               )
               (push (cons (subseq (frag-string start-frag) start-frag-pos)
                     (frag-font start-frag)) my-line)
               (setf (frag-string start-frag) (subseq (frag-string start-frag)
                     0 start-frag-pos))
               (setf (frag-length start-frag)
                     (length (frag-string start-frag)))
               (setf (frag-width start-frag)
                     (xlib:text-width (frag-xfont start-frag)
                     (frag-string start-frag)))
               (if (eq (frag-xfont start-frag) (frag-xfont end-frag))
                  (progn
                     (setf (frag-string end-frag)
                           (concatenate 'string (frag-string start-frag)
                           (frag-string end-frag)))
                     (incf (frag-length end-frag) (frag-length start-frag))
                     (incf (frag-width end-frag) (frag-width start-frag))
                     (setf (frag-prev-frag end-frag)
                           (frag-prev-frag start-frag))
                     (if (frag-prev-frag start-frag)
                        (setf (frag-next-frag (frag-prev-frag start-frag))
                              end-frag)
                        (s-value start-line :first-frag end-frag)
                     )
                  )
                  (progn
                     (setf (frag-next-frag start-frag) end-frag)
                     (setf (frag-prev-frag end-frag) start-frag)
                  )
               )
               (setq text (list my-line))
            )
         )
         (progn
            (setq text (list nil))
            (push (cons (subseq (frag-string end-frag) 0 end-frag-pos)
                  (frag-font end-frag)) (car text))
            (do ((frag (frag-prev-frag end-frag) (frag-prev-frag frag)))
                ((null frag))
               (push (cons (frag-string frag) (frag-font frag)) (car text))
            )
            (setf (frag-string end-frag)
                  (subseq (frag-string end-frag) end-frag-pos))
            (setf (frag-length end-frag) (length (frag-string end-frag)))
            (setf (frag-width end-frag) (xlib:text-width (frag-xfont end-frag)
                  (frag-string end-frag)))
            (do ((my-line (g-value end-line :prev-line)
                       (g-value my-line :prev-line)))
                ((eq my-line start-line))
               (let ((last-frag (g-value my-line :last-frag)))
                  (if (frag-break-p last-frag)
                     (push (cons (frag-string last-frag)
                           (frag-font last-frag)) (car text))
                     (push (list (cons (subseq (frag-string last-frag)
                           0 (1- (frag-length last-frag)))
                           (frag-font last-frag))) text)
                  )
                  (do ((frag (frag-prev-frag last-frag) (frag-prev-frag frag)))
                      ((null frag))
                     (push (cons (frag-string frag) (frag-font frag))
                           (car text))
                  )
               )
               (destroy-line my-line)
            )
            (let ((last-frag (g-value start-line :last-frag)))
               (if (frag-break-p last-frag)
                  (progn
                     (do ((frag last-frag (frag-prev-frag frag)))
                         ((eq frag start-frag))
                        (push (cons (frag-string frag) (frag-font frag))
                              (car text))
                     )
                     (push (cons (subseq (frag-string start-frag)
                           start-frag-pos)
                           (frag-font start-frag)) (car text))
                  )
                  (if (eq last-frag start-frag)
                     (push (list (cons (subseq (frag-string start-frag)
                           start-frag-pos (1- (frag-length start-frag)))
                           (frag-font start-frag))) text)
                     (progn
                        (push (list (cons (subseq (frag-string last-frag)
                              0 (1- (frag-length last-frag)))
                              (frag-font last-frag))) text)
                        (do ((frag (frag-prev-frag last-frag)
                                   (frag-prev-frag frag)))
                            ((eq frag start-frag))
                           (push (cons (frag-string frag) (frag-font frag))
                                 (car text))
                        )
                        (push (cons (subseq (frag-string start-frag)
                              start-frag-pos) (frag-font start-frag))
                              (car text))
                     )
                  )
               )
            )
            (setf (frag-string start-frag)
                  (subseq (frag-string start-frag) 0 start-frag-pos))
            (setf (frag-length start-frag) (length (frag-string start-frag)))
            (setf (frag-width start-frag)
                  (xlib:text-width (frag-xfont start-frag)
                  (frag-string start-frag)))
            (if (eq (frag-xfont start-frag) (frag-xfont end-frag))
               (progn
                  (setf (frag-string end-frag)
                        (concatenate 'string (frag-string start-frag)
                        (frag-string end-frag)))
                  (incf (frag-length end-frag) (frag-length start-frag))
                  (incf (frag-width end-frag) (frag-width start-frag))
                  (setf (frag-prev-frag end-frag) (frag-prev-frag start-frag))
                  (if (frag-prev-frag start-frag)
                     (setf (frag-next-frag (frag-prev-frag start-frag))
                           end-frag)
                     (s-value start-line :first-frag end-frag)
                  )
               )
               (progn
                  (setf (frag-next-frag start-frag) end-frag)
                  (setf (frag-prev-frag end-frag) start-frag)
               )
            )
            (s-value start-line :last-frag (g-value end-line :last-frag))
            (s-value start-line :next-line (g-value end-line :next-line))
            (if (g-value end-line :next-line)
               (s-value (g-value end-line :next-line) :prev-line start-line)
               (s-value gob :last-line start-line)
            )
            (s-value end-line :first-frag nil)
            (s-value end-line :last-frag nil)
            (destroy-line end-line)
            (calculate-size-of-line gob start-line)
            (when (g-value gob :word-wrap-p)
               (wrap-line gob start-line))
         )
      )
      (calculate-size-of-line gob start-line)
      (invalidate-line start-line)
      (when (g-value gob :word-wrap-p)
         (undo-wrap-line gob start-line)
         (when (g-value start-line :prev-line)
            (undo-wrap-line gob (g-value start-line :prev-line))
         )
      )
      (reset-font gob)
      text
   )
)


(defun SET-STRINGS (gob strings)
   (TOGGLE-SELECTION gob nil)
   (let* ((cursor-was-visible (g-value gob :cursor :visible))
          (gob-was-visible (g-value gob :visible))
          (first-line (g-value gob :first-line))
          (first-frag (g-value first-line :first-frag))
          (next-line (g-value first-line :next-line)))
      (s-value gob :visible nil)
      (do ((my-line next-line next-line))
          ((null my-line))
         (setq next-line (g-value my-line :next-line))
         (destroy-line my-line)
      )
      (s-value gob :last-line first-line)
      (s-value first-line :last-frag first-frag)
      (s-value first-line :next-line nil)
      (setf (frag-string first-frag) " ")
      (setf (frag-length first-frag) 1)
      (setf (frag-width first-frag)
            (xlib:char-width *default-xfont* (char-code #\space)))
      (setf (frag-font first-frag) opal:default-font)
      (setf (frag-xfont first-frag) *default-xfont*)
      (setf (frag-ascent first-frag) *default-ascent*)
      (setf (frag-descent first-frag) *default-descent*)
      (setf (frag-next-frag first-frag) nil)
      (setf (frag-break-p first-frag) nil)
      (calculate-size-of-line gob first-line)
      (GO-TO-BEGINNING-OF-TEXT gob)
      (INSERT-TEXT gob strings)
      (GO-TO-BEGINNING-OF-TEXT gob)
      (s-value gob :visible gob-was-visible)
      (s-value (g-value gob :cursor) :visible cursor-was-visible)
   )
)


(defun GET-STRING (gob)
   (TEXT-TO-STRING (GET-TEXT gob))
)


(defun GET-TEXT (gob)
   (let ((text nil))
      (do ((my-line (g-value gob :last-line) (g-value my-line :prev-line)))
          ((null my-line))
         (let ((last-frag (g-value my-line :last-frag)))
            (if (frag-break-p last-frag)
               (push (cons (frag-string last-frag) (frag-font last-frag))
                     (car text))
               (push (list (cons (subseq (frag-string last-frag)
                     0 (1- (frag-length last-frag)))
                     (frag-font last-frag))) text)
            )
            (do ((frag (frag-prev-frag last-frag) (frag-prev-frag frag)))
                ((null frag))
               (push (cons (frag-string frag) (frag-font frag)) (car text))
            )
         )
      )
      text
   )
)


;;; The following are conversion functions, useful for turning text lists into
;;; other things.  Note there is no STRING-TO-TEXT function since by
;;; definition a string is a valid form of text.


(defun font-to-list (my-font)
   (cond
      ((xlib:font-p my-font)
         (cons :XFONT (xlib:font-name my-font))
      )
      ((is-a-p my-font opal:font)
         (list :FONT (g-value my-font :family) (g-value my-font :face)
               (g-value my-font :size))
      )
      ((is-a-p my-font opal:font-from-file)
         (list :FONT-FROM-FILE (g-value my-font :font-path)
               (g-value my-font :font-name))
      )
      (t
         (font-to-list opal:default-font))
   )
)


(defun list-to-font (my-font)
   (case (car my-font)
     (:XFONT
        (xlib:open-font opal::*default-x-display* (cdr my-font)))
     (:FONT
        (GET-STANDARD-FONT (second my-font) (third my-font) (fourth my-font)))
     (:FONT-FROM-FILE
        (create-instance nil opal:font-from-file
           (:font-path (second my-font))
           (:font-name (third my-font))
        ))
   )
)


(defun frag-to-list (frag)
   (if (stringp frag)
      frag
      (cons (car frag) (font-to-list (cdr frag)))
   )
)


(defun list-to-frag (frag)
   (if (stringp frag)
      frag
      (cons (car frag) (list-to-font (cdr frag)))
   )
)


(defun line-to-list (my-line)
   (if (or (stringp my-line) (null my-line))
      my-line
      (cons (frag-to-list (car my-line)) (line-to-list (cdr my-line)))
   )
)


(defun list-to-line (my-line)
   (if (or (stringp my-line) (null my-line))
      my-line
      (cons (list-to-frag (car my-line)) (list-to-line (cdr my-line)))
   )
)


(defun TEXT-TO-PURE-LIST (text)
   (if (or (stringp text) (null text))
      text
      (cons (line-to-list (car text)) (text-to-pure-list (cdr text)))
   )
)


(defun PURE-LIST-TO-TEXT (pure-list)
   (if (or (stringp pure-list) (null pure-list))
      pure-list
      (cons (list-to-line (car pure-list)) (pure-list-to-text (cdr pure-list)))
   )
)


(defun TEXT-TO-STRING (text)
   (if text
      (if (stringp text)
         text
         (let ((str ""))
            (dolist (my-line text)
               (if (stringp my-line)
                  (setq str (concatenate 'string str my-line
                        (string #\newline)))
                  (progn
                     (dolist (frag my-line)
                        (if (stringp frag)
                           (setq str (concatenate 'string str frag))
                           (setq str (concatenate 'string str (car frag)))
                        )
                     )
                     (setq str (concatenate 'string str (string #\newline)))
                  )
               )
            )
            (setq str (subseq str 0 (1- (length str))))
         )
      )
      ""
   )
)


(defun listify-frag (frag)
   (if (stringp frag)
      (cons frag opal:default-font)
      frag
   )
)


(defun listify-line (my-line)
   (if (stringp my-line)
      (list (listify-frag my-line))
      (when my-line
         (cons (listify-frag (car my-line)) (listify-line (cdr my-line)))
      )
   )
)


(defun listify-text (text)
   (if (stringp text)
      (let ((pos (position #\newline text)))
         (if pos
            (cons (listify-line (subseq text 0 pos))
                  (listify-text (subseq text (1+ pos))))
            (list (listify-line text))
         )
      )
      (when text
         (cons (listify-line (car text)) (listify-text (cdr text)))
      )
   )
)


(defun concat-lists (text1 text2)
   (if (null (cdr text1))
      (cons (append (car text1) (car text2)) (cdr text2))
      (cons (car text1) (concat-lists (cdr text1) text2))
   )
)


(defun CONCATENATE-TEXT (text1 text2)
   (setq text1 (listify-text text1))
   (setq text2 (listify-text text2))
   (if (null text1)
      text2
      (if (null text2)
         text1
         (concat-lists text1 text2)
      )
   )
)
