;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  4/15/92 ecp -- Fixed bug where cursor was not appearing on color screen
;;;		    with black = 0 when draw-function = :xor.
;;;  4/01/92 Andrew Mickish - Removed redundant :initialize method
;;; 10/23/91 ecp -- Fix for when drawing cursor on color screen with black = 0.
;;;  3/04/91 D'Souza - Removed nickname "MO" of package Opal.
;;;  2/04/91 ecp -- Cursor of cursor-text now has draw function :xor.
;;;  2/28/90 ecp -- Cursor of cursor text now has same draw function
;;;		    as the text.
;;;  3/11/89 lkb -- bug fixes, cursor now shows wven when string is empty
;;;                 height of cursor reflects value of :actual-heightp slot
;;;                 calls to X are more limited than before (more speed!!!)

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

(define-method :draw opal:cursor-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))
	   (xfont (aref update-vals *text-xfont*))
	   (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)))
	   (left (aref update-vals *text-left*))
	   (top (aref update-vals *text-top*))
	   (height (aref update-vals *text-height*))
	   (width (aref update-vals *text-width*))
	   (substring (aref update-vals *cursor-text-x-substr*))
	   (text-extents (aref update-vals *text-text-extents*))
	   cursor-offset)
      (when xfont
	(setq cursor-offset (- (xlib:text-width xfont substring)
			       (the-left-bearing text-extents)
			       1))
	(setq cursor-offset (min cursor-offset
				 (- 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
			      (+ left cursor-offset)
			      (+ top height)))))))
