;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 06-Oct-93 Andrew Mickish -- Removed obsolete :text-extents slot; used
;;;               WIDTH returned by xlib:text-extents instead of difference
;;;               between LEFT-BEARING and RIGHT-BEARING
;;; 17-Sep-93 Andrew Mickish -- Removed left-bearing from :draw method;
;;;               fixed :width formula accordingly
;;;  9-Sep-93 Andrew Mickish -- Fixed :cursor-offset formula to put the cursor
;;;               more between characters
;;;  1-Sep-93 Andrew Mickish -- Used :cut-string-structs slot instead of
;;;               kr::self-old-value; Created :prev-len to replace :x-substr
;;; 30-Aug-93 Andrew Mickish -- Fixed Move-Cursor-Up/Down-One-Line
;;; 17-Aug-93 Andrew Mickish -- Removed reference to kr::*NO-VALUE*
;;; 30-Jul-93 Andrew Mickish -- New opal:text obviates all cursor- and multi-
;;;               text versions
;;; 10-Jun-93 Andrew Mickish -- Renamed black-xor-hack to HP-XOR-Hack
;;;  6-Apr-93 koz Converted with-*-styles macros to set-*-style fns
;;;               And omitted "clip-mask" as argument to draw function.
;;;               And changed hack to "black-xor-hack" (now a macro)
;;; 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"))

(defvar *cursor-width*          2)
(defvar *cursor-half-width*     (floor *cursor-width* 2))
(defvar *cursor+++half+++width* (ceiling *cursor-width* 2))
(defvar *cursor-draw-fn*        (get :xor :x-draw-function))

(create-instance 'opal:TEXT opal:graphical-object
  :declare ((:parameters :left :top :string :font :actual-heightp
			 :justification :fill-background-p :line-style
			 :cursor-index :draw-function :visible)
	    (:type (string :string)
                   ((or (is-a-p opal:font) (is-a-p opal:font-from-file)) :font)
		   ((member :left :center :right) :justification))
	    (:maybe-constant :left :top :string :font :actual-heightp
                             :line-style :visible)
	    (:local-only-slots (:cursor-index nil) (:window nil)
                               (:parent nil) (:cut-string-structs NIL))
            (:ignored-slots :depended-slots :update-slots :update-slots-values
                            :xfont :cut-string-structs
			    :cut-strings)
	    (:update-slots :visible :fast-redraw-p :top :left :width :height
			   :string :xfont :actual-heightp :fill-background-p
			   :line-style :draw-function :cursor-offset
			   :justification :cut-strings :line-number))
  (:string            "")
  (:font              opal:default-font)
  (:actual-heightp    nil)
  (:fill-background-p nil)
  (:cursor-index NIL)
  (:justification :left)
  (:xfont (o-formula (gvl :font :xfont)))
  (:cut-strings
   (o-formula
    (let* ((string (gvl :string))
	   (font (gvl :xfont))
	   ;; Structs will be NIL if formula has never been evaluated
	   (structs (g-value kr::*schema-self* :cut-string-structs)))
      (do* ((old-structs structs (cdr old-structs))
	    (struct (car old-structs) (car old-structs))
	    (i -1 j)
	    (j 0)
	    (substring nil))
	   ((null i) (progn
		       ;; Throw away old cut-strings that we didn't use
		       (when old-structs
			 (let ((last-cdr (nthcdr (- (length structs)
						    (length old-structs)
						    1)
						 structs)))
			   (setf (cdr last-cdr) NIL)))
		       structs))
	(setf j (position #\Newline string :start (1+ i))
	      substring (if (or j substring)
			    (subseq string (1+ i) j)
			    string))
	(multiple-value-bind (width dummy2 dummy3 left-bearing)
	    (xlib:text-extents font substring)
	  (declare (ignore dummy2 dummy3))
	  ;; Reuse and old struct, if possible
	  (cond
	    (struct
	     (setf (cut-string-string struct) substring)
	     (setf (cut-string-width struct) width)
	     (setf (cut-string-left-bearing struct) left-bearing))
	    (t (setf structs
		     ;; Note: only append when we're adding a new line, and
		     ;; the object has never had this many lines.
		     (append structs
			     (list (make-cut-string
				    :string substring
				    :width width
				    :left-bearing left-bearing))))))))
      (s-value kr::*schema-self* :cut-string-structs structs))))
  (:height (o-formula (* (gvl :font :font-height)
			 (length (gvl :cut-strings)))))
  (:width (o-formula (let ((width *cursor-width*))
		       (dolist (cstring (gvl :cut-strings))
			 (setq width (max width (cut-string-width cstring))))
		       width)))
  (:line-number (o-formula (cursor-index-to-line-number
			    (gvl :cut-strings) (gvl :cursor-index))))
  (:line-height (o-formula (let ((xfont (gvl :xfont)))
			     (+ (xlib:max-char-ascent xfont)
				(xlib:max-char-descent xfont)))))
  (:prev-len
   (o-formula
    (let ((cursor-index (gvl :cursor-index)))
      (when cursor-index
	(let* ((cut-strings (gvl :cut-strings))
	       (line-number (gvl :line-number))
	       (n 0)   (prev-len 0))
	  ;; Count up all the characters in the lines before the cursor's line
	  (dolist (a-cut-string cut-strings)
	    (if (eq n line-number)
		(return prev-len)
		(progn
		  (setf prev-len
			;; Add an extra 1 for the #\newline
			(+ 1 prev-len
			   (length (cut-string-string a-cut-string))))
		  (incf n)))))))))
  (:cursor-offset
   (o-formula
    (let ((cursor-index (gvl :cursor-index)))
      (when cursor-index
      (let* ((cut-string        (nth (gvl :line-number) (gvl :cut-strings)))
	     (justification     (gvl :justification))
	     (string            (cut-string-string cut-string))
	     (line-width        (cut-string-width cut-string))
	     (max-line-width    (gvl :width))	
	     (font              (gvl :font))
	     (char-width        (gv font :char-width))
	     (prev-len          (gvl :prev-len))
	     ;; Adj-index gives us the cursor-index on the particular line
	     (adj-index   (- cursor-index prev-len))
	     (fixed-index (cond ((<= cursor-index 0)                 0)
				((>= adj-index line-width)  line-width)
				(T                           adj-index)))
	     (base-width  (if char-width
			      (* char-width fixed-index)
			      (xlib:text-width (gv font :xfont) string
					       :end fixed-index)))
	     (max-cursor-offset (- max-line-width *cursor+++half+++width*)))
	;; Never let offset be less than zero
	(max *cursor-half-width*
	(min max-cursor-offset
	     (+ (max (min max-cursor-offset
			  base-width)
		     *cursor-half-width*)
		(case justification
		  (:right (- max-line-width (max line-width 2)))
		  (:center (floor (- max-line-width line-width) 2))
		  (t 0))))))))))
  )


(create-instance 'opal::CURSOR-TEXT opal::text)
(create-instance 'opal::MULTI-TEXT opal::text)
(create-instance 'opal::CURSOR-MULTI-TEXT opal::multi-text)


(define-method :draw opal:text (gob line-style-gc filling-style-gc
				    drawable root-window)
  (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*))
	 (lstyle         (aref update-vals *text-lstyle*))
	 (max-line-width (aref update-vals *text-width*))
	 (justification  (aref update-vals *text-justification*))
	 (line-number    (aref update-vals *text-line-number*))
	 (cursor-offset  (aref update-vals *text-cursor-offset*))
	 (cut-strings    (aref update-vals *text-cut-strings*))
	 (ascent         (xlib:max-char-ascent xfont))
	 (line-height    (+ ascent (xlib:max-char-descent xfont))))
    (when lstyle
      (set-line-style lstyle line-style-gc xlib-gc-line root-window x-draw-fn)
      (set-gc line-style-gc xlib-gc-line :font xfont)
      (do ((count 0 (1+ count))
	   (remaining cut-strings (cdr remaining)))
	  ((null remaining))
	(let* ((cut-string (car remaining))
	       (width (cut-string-width cut-string))
	       (string (cut-string-string cut-string)))
          (if (aref update-vals *text-fill-background-p*)
	      (xlib:draw-image-glyphs drawable
			    xlib-gc-line
			    (+ left
			       (case justification
				 (:right (- max-line-width width))
				 (:center (floor (- max-line-width width) 2))
				 (t 0)))
			    (+ top ascent (* count line-height))
			    string)
	      (xlib:draw-glyphs drawable
			    xlib-gc-line
			    (+ left
			       (case justification
				 (:right (- max-line-width width))
				 (:center (floor (- max-line-width width) 2))
				 (t 0)))
			    (+ top ascent (* count line-height))
			    string))))
      (when cursor-offset
	(let ((cursor-left (+ left cursor-offset))
	      (cursor-top (+ top (* line-number line-height))))
	  (xlib:with-gcontext
	      (xlib-gc-line :line-width *cursor-width*
			    :function *cursor-draw-fn*
			    :foreground (HP-XOR-Hack
					 *cursor-draw-fn*
					 (xlib:gcontext-foreground xlib-gc-line))
			    :fill-style :solid)
	    (xlib:draw-line drawable xlib-gc-line
			    cursor-left cursor-top
			    cursor-left (+ cursor-top line-height)))))
      )))


(defun cursor-index-to-line-number (cut-strings index)
  (when 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))))))))

(defun move-cursor-down-one-line (gob)
  (when (g-value gob :cursor-index)
    (let* ((cut-strings (g-value gob :cut-strings))
	   (line-height (g-value gob :line-height))
	   (line-number (g-value gob :line-number)))
      (when (< line-number (1- (length cut-strings)))
	(s-value gob :cursor-index
		 (opal::get-cursor-index
		  gob
		  (+ (g-value gob :left) (g-value gob :cursor-offset))
		  (+ (g-value gob :top)
		     (* line-height (1+ line-number)))))))))

(defun move-cursor-up-one-line (gob)
  (when (g-value gob :cursor-index)
    (let* ((line-height (g-value gob :line-height))
	   (line-number (g-value gob :line-number)))
      (when (> line-number 0)
	(s-value gob :cursor-index
		 (opal::get-cursor-index
		  gob
		  (+ (g-value gob :left) (g-value gob :cursor-offset))
		  (+ (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 index
        (s-value gob :cursor-index (g-value gob :prev-len))
        (s-value gob :cursor-index 0))))

(defun move-cursor-to-end-of-line (gob)
  (if (g-value gob :cursor-index)
      (let* ((cut-strings (g-value gob :cut-strings))
	     (line-number (g-value gob :line-number)))
	(s-value gob :cursor-index
		 (+ (g-value gob :prev-len)
		    (length (cut-string-string
			     (nth line-number cut-strings))))))
      (s-value gob :cursor-index (length (g-value gob :string)))))


(define-method :string-set-func OPAL::TEXT
    (gadget-obj str-obj final-event final-string)
  (declare (ignore final-event))
  (if (eq str-obj gadget-obj)
      ; then is me (otherwise, is probably an error)
      (s-value str-obj :string final-string)
      ; else return NIL
      NIL))
