;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 15-Apr-92 ecp Fixed bug where cursor was not appearing on color screen
;;;                 with black = 0 when draw-function = :xor.
;;; 23-Oct-91 ecp Fix for when drawing cursor on color screen with black = 0.
;;;  4-Feb-91 ecp Cursor of cursor-multi-text now has draw function :xor.
;;; 23-Mar-90 ecp  New slot :fill-background-p for text objects.
;;; 14-Mar-90 ecp Move-cursor-* functions added.
;;; 28-Feb-90 ecp Cursor of cursor-multi-text now has same draw
;;;		  function as the text itself.
;;;
(in-package "OPAL" :use '("KR" "LISP"))


(define-method :draw opal:multi-text (gob line-style-gc filling-style-gc
					  drawable root-window clip-mask)
  (declare (ignore filling-style-gc))
  (let* ((update-vals (g-local-value gob :update-slots-values))
	 (xfont (aref update-vals *text-xfont*))
	 (x-draw-fn (get (aref update-vals *text-draw-function*)
			 :x-draw-function))
	 (xlib-gc-line (opal-gc-gcontext line-style-gc))
	 (left (aref update-vals *text-left*))
	 (top (aref update-vals *text-top*))
	 (max-line-width (aref update-vals *text-width*))
	 (justification (aref update-vals *multi-text-justification*))
	 (ascent (xlib:max-char-ascent xfont))
	 (height (+ ascent (xlib:max-char-descent xfont))))
    (with-line-styles ( (aref update-vals *text-lstyle*) line-style-gc
			xlib-gc-line root-window x-draw-fn clip-mask)
      (set-gc line-style-gc xlib-gc-line :font xfont)
      (do ((count 0 (1+ count))
	   (remaining (aref update-vals *multi-text-cut-strings*)
		      (cdr remaining)))
	  ((null remaining))
	(let* ((cut-string (car remaining))
	       (width (cut-string-width cut-string))
	       (string (cut-string-string cut-string))
	       (left-bearing (cut-string-left-bearing cut-string)))
          (if (aref update-vals *text-fill-background-p*)
	      (xlib:draw-image-glyphs drawable
			    xlib-gc-line
			    (+ (- left left-bearing)
			       (case justification
				 (:right (- max-line-width width))
				 (:center (floor (- max-line-width width) 2))
				 (t 0)))
			    (+ top ascent (* count height))
			    string)
	      (xlib:draw-glyphs drawable
			    xlib-gc-line
			    (+ (- left left-bearing)
			       (case justification
				 (:right (- max-line-width width))
				 (:center (floor (- max-line-width width) 2))
				 (t 0)))
			    (+ top ascent (* count height))
			    string)))))))


(defun cursor-index-to-line-number (cut-strings index)
  (let (length-of-this-line)
    (dotimes (line-num (length cut-strings))
      (setq length-of-this-line (length (cut-string-string (car cut-strings))))
      (if (<= index length-of-this-line)
	  (return line-num)
	  (progn
	    (setq index (- index 1 length-of-this-line))
	    (setq cut-strings (cdr cut-strings)))))))

(define-method :draw opal:cursor-multi-text (gob line-style-gc filling-style-gc
						 drawable root-window clip-mask)
  (call-prototype-method gob line-style-gc filling-style-gc
			 drawable root-window clip-mask)
  (when (g-value gob :cursor-index)
   (let* ((update-vals (g-local-value gob :update-slots-values))
	 (xlib-gc-line (opal-gc-gcontext line-style-gc))
	 (cursor-draw-fn (get :xor :x-draw-function))
	 (gc-foreground (xlib:gcontext-foreground xlib-gc-line))
         ;; When determining foreground color of cursor, only call
         ;; hack-etc if draw function is not boole-xor, because then
         ;; hack-etc will have already been called inside prototype method.
	 (cursor-foreground (if (eq (get (aref update-vals *text-draw-function*)
					 :x-draw-function)
				    boole-xor)
				gc-foreground
				(opal::hack-for-black-xor-on-color-screen
                                  cursor-draw-fn
                                  gc-foreground)))
	 (xfont (aref update-vals *text-xfont*))
	 (left (aref update-vals *text-left*))
	 (top (aref update-vals *text-top*))
	 (max-line-width (aref update-vals *text-width*))
	 (justification (aref update-vals *multi-text-justification*))
	 (cut-strings (aref update-vals *multi-text-cut-strings*))
	 (cursor-index
	  (max 0 (min (aref update-vals *cursor-multi-text-cursor-index*)
		      (length (aref update-vals *text-string*)))))
	 (line-number (cursor-index-to-line-number cut-strings cursor-index))
	 (cut-string (nth line-number cut-strings))
	 (line-height (+ (xlib:max-char-ascent xfont)
			 (xlib:max-char-descent xfont)))
	 (line-left-bearing (cut-string-left-bearing cut-string))
	 (line-width (cut-string-width cut-string))
	 (substring (aref update-vals *cursor-multi-text-x-substr*))
	 (cursor-offset (+ (case justification
			     (:right (- max-line-width line-width))
			     (:center (floor (- max-line-width line-width) 2))
			     (t 0))
			   (xlib:text-width xfont substring)
			   (- line-left-bearing)
			   -1)))
    (setq cursor-offset (min cursor-offset
			     (- max-line-width (ceiling *cursor-width* 2))))
    (setq cursor-offset (max cursor-offset (floor *cursor-width* 2)))
    (xlib:with-gcontext (xlib-gc-line
			    :line-width *cursor-width*
			    :function cursor-draw-fn
                            :foreground cursor-foreground
			    :fill-style :solid
			    :clip-mask clip-mask)
      (xlib:draw-line drawable xlib-gc-line
		      (+ left cursor-offset)
		      (+ top (* line-number line-height))
		      (+ left cursor-offset)
		      (+ top (* (1+ line-number) line-height))
		      )))))


(defun move-cursor-down-one-line (gob)
  (when (and (is-a-p gob opal:cursor-multi-text)
             (g-value gob :cursor-index))
    (let* ((cut-strings (g-value gob :cut-strings))
	   (x-substr (g-value gob :x-substr))
	   (xfont (g-value gob :xfont))
	   (line-height (+ (xlib:max-char-ascent xfont)
			   (xlib:max-char-descent xfont)))
	   (index (g-value gob :cursor-index))
	   (line-number (cursor-index-to-line-number cut-strings index)))
      (when (< line-number (1- (length cut-strings)))
	(let ((cut-string (nth line-number cut-strings)))
	  (s-value gob :cursor-index
		   (opal::get-cursor-index
		    gob
		    (+ (g-value gob :left)
		       (case (g-value gob :justification)
			 (:right (- (g-value gob :width)
				    (cut-string-width cut-string)))
			 (:center (floor (- (g-value gob :width)
					    (cut-string-width cut-string))
					 2))
			 (t 0))
		       (xlib:text-width xfont x-substr))
		    (+ (g-value gob :top)
		       (* line-height (1+ line-number))))))))))

(defun move-cursor-up-one-line (gob)
  (when (and (is-a-p gob opal:cursor-multi-text)
             (g-value gob :cursor-index))
    (let* ((cut-strings (g-value gob :cut-strings))
	   (x-substr (g-value gob :x-substr))
	   (xfont (g-value gob :xfont))
	   (line-height (+ (xlib:max-char-ascent xfont)
			   (xlib:max-char-descent xfont)))
	   (index (g-value gob :cursor-index))
	   (line-number (cursor-index-to-line-number cut-strings index)))
      (when (> line-number 0)
	(let ((cut-string (nth line-number cut-strings)))
	  (s-value gob :cursor-index
		   (opal::get-cursor-index
		    gob
		    (+ (g-value gob :left)
		       (case (g-value gob :justification)
			 (:right (- (g-value gob :width)
				    (cut-string-width cut-string)))
			 (:center (floor (- (g-value gob :width)
					    (cut-string-width cut-string))
					 2))
			 (t 0))
		       (xlib:text-width xfont x-substr))
		    (+ (g-value gob :top)
		       (* line-height (1- line-number))))))))))

(defun move-cursor-to-beginning-of-line (gob)
  (let ((index (g-value gob :cursor-index)))
    (if (and index (is-a-p gob opal:cursor-multi-text))
        (s-value gob :cursor-index
	       (- index (length (g-value gob :x-substr))))
        (s-value gob :cursor-index 0))))

(defun move-cursor-to-end-of-line (gob)
  (let ((index (g-value gob :cursor-index)))
    (if (and index (is-a-p gob opal:cursor-multi-text))
        (let* ((cut-strings (g-value gob :cut-strings))
	       (line-number (cursor-index-to-line-number cut-strings index)))
	  (s-value gob :cursor-index
		   (+ (- index (length (g-value gob :x-substr)))
		      (length (cut-string-string (nth line-number cut-strings))))))
       (s-value gob :cursor-index (length (g-value gob :string))))))
