;;; -*- Mode:LISP; Package:TV; Fonts:(CPTFONT); Base:10; Patch-File:T -*-

(defvar ddd 0)

(defconst *handling-weird-characters-p* nil
   "If non-NIL, :TYO operations print any character in font; 
else, only char values < #o200 are printed, others are lozenged.
See WITH-WEIRD-CHARACTER-HANDLING for a better way; you should be
cautious about setting this globally, which affects other programs.")

(defmacro with-weird-character-handling(&body body)
  `(let ((*handling-weird-characters-p* t))
     . ,body))

(defun char-in-font-p(char font)
;;;Absolutely must re-re-re-optimize this to max.
  (let ((exist-table  (font-chars-exist-table font)))
    (and (arrayp exist-table)
	(array-in-bounds-p exist-table char)
	(not(zerop (aref exist-table char))))
    ))

(defun sheet-font-from-spec(sheet fontspec)
  (typecase fontspec
    (null (sheet-current-font sheet))
    (font fontspec)
    (fixnum (let ((fontmap (sheet-font-map sheet)))
	      (if (lessp fontspec (array-length fontmap))
		  (aref fontmap fontspec)
		(sheet-current-font sheet))))
    (t (sheet-current-font sheet))))

(defun sheet-tyo2 (sheet char &optional newfont)
  "Output printing or formatting character CHAR on SHEET in FONT.
FONT defaults to the current font of SHEET.
Character not present in font is not output.
If *handling-weird-characters-p* is NIL, characters with value >= #o200 are always lozenged.
If T, character range is not significant."
  (etypecase char
    (character (setq char (char-int char)))
    (fixnum t))
  (let* ((font (sheet-font-from-spec sheet newfont))
	 (lozenge-it (if *handling-weird-characters-p*
			 (not(char-in-font-p char font))
		       (>= char #o200))))
    (cond
      ((null lozenge-it)
       (let (X Y WIDTH ALU CWT FIT LKT)
	 (PREPARE-SHEET (SHEET)
	   (SHEET-HANDLE-EXCEPTIONS-IF-NECESSARY SHEET)
	   (cond ((null newfont)
		  (SETQ Y (+ (SHEET-CURSOR-Y SHEET) (SHEET-BASELINE-ADJ SHEET))))
		 (t
		  (COERCE-FONT FONT SHEET)
		  (SETQ Y (+ (SHEET-CURSOR-Y SHEET)
			     (- (SHEET-BASELINE SHEET) (FONT-BASELINE FONT))))))
	   (SETQ CWT (FONT-CHAR-WIDTH-TABLE FONT))
	   (SETQ FIT (FONT-INDEXING-TABLE FONT))
	   (SETQ ALU (SHEET-CHAR-ALUF SHEET))
	   (SETQ WIDTH (IF CWT (AREF CWT CHAR) (FONT-CHAR-WIDTH FONT)))
	   (COND (( (+ (SETQ X (SHEET-CURSOR-X SHEET)) WIDTH)
		     (IF (ZEROP (SHEET-RIGHT-MARGIN-CHARACTER-FLAG SHEET))
			 (SHEET-INSIDE-RIGHT SHEET)
		       (- (SHEET-INSIDE-RIGHT SHEET) (SHEET-CHAR-WIDTH SHEET))))
		  (COND ((NULL (SETQ LKT (FONT-LEFT-KERN-TABLE FONT)))
			 (IF (NULL FIT)
			     (%DRAW-CHAR FONT CHAR X Y ALU SHEET)
			   (DRAW-CHAR FONT CHAR X Y ALU SHEET)))
			(T
			 (IF (NULL FIT)
			     (%DRAW-CHAR FONT CHAR (- X (AREF LKT CHAR)) Y ALU SHEET)
			   (DRAW-CHAR FONT CHAR (- X (AREF LKT CHAR)) Y ALU SHEET))))
		  (SETF (SHEET-CURSOR-X SHEET) (+ X WIDTH)))
		 (T
		  (SEND SHEET :END-OF-LINE-EXCEPTION)
		  (sheet-tyo2 sheet char font))))))
      ('ELSE
       ;;; Handling a special character
       (COND ((AND (= CHAR #/NEWLINE) (ZEROP (SHEET-CR-NOT-NEWLINE-FLAG SHEET)))
	      (SHEET-CRLF SHEET))
	     ((= CHAR #/TAB)
	      (SHEET-TAB-1 SHEET))
	     ((AND (= CHAR #/BACKSPACE) (ZEROP (SHEET-BACKSPACE-NOT-OVERPRINTING-FLAG SHEET)))
	      (SHEET-BACKSPACE-1 SHEET))
	     (T
	      (SHEET-DISPLAY-LOZENGED-STRING
		SHEET
		(STRING (OR (CAR (RASSQ CHAR SI::XR-SPECIAL-CHARACTER-NAMES))
			    (FORMAT NIL "~3O" CHAR)))))))))
  char)


;;; Danger, danger! redefining the actual %DRAW-STRING routine can lose big time

(defun %draw-string-2 (sheet alu xpos ypos string font start stop xlim)
  "Draw STRING on SHEET starting with the character at index START and stopping after
drawing the character at index STOP, presuming it all fits.  Output starts at XPOS,
YPOS on the sheet and continues until all appropriate characters are drawn, or until
the next character to be drawn would extend past XLIM.  The index of the next character
to be drawn, and the xpos where it would go are returned.  If a NEWLINE is encountered,
returns its index and xpos immediately.  The sheet's cursor position is ignored and
left unchanged."
  (declare (values index xpos))
  ;; Warning!  This function has been extensively tweaked by someone who knows what's
  ;; actually going on in the machine.  There are a lot of weird efficiency hacks,
  ;; particularly in the use of local variables and the stack, but also some weird
  ;; branching.  If you must modify this function, keep in mind that the Zmacs redisplay
  ;; spends more than 90% of its time here.  This function, in turn, should spend at
  ;; least 90% of its time in %draw-char (it currently does).
  (prog (c (i start) width (tab-width (sheet-tab-width sheet)) (base-ypos ypos) (npos xpos)
	 font-index font-next (font-map (sheet-font-map sheet))
	 font-index-table font-width-table font-kern-table lozenge-string
	 (inside-left (sheet-inside-left sheet))
	 (weird-handling *handling-weird-characters-p*)
	 exist-table
	 (graphic-char-limit #o200))		;In local variable for speed.

	(when ( i stop) (return (values (1+ stop) xpos)))
	(unless (eq (%p-mask-field-offset #.%%array-type-field string 0) #.art-string)
	  (go multiple-font))

   single-font
	(when (fixnump font) (setq font (aref font-map font)))
	(setq ypos (+ ypos (- (sheet-baseline sheet) (font-baseline font))))
	(cond ((setq font-index-table (font-indexing-table font))
	       (setf (sheet-cursor-x sheet) xpos)
	       (go single-hairy-font-loop))
	      ((or (setq font-width-table (font-char-width-table font))
		   (setq font-kern-table (font-left-kern-table font)))
	       (setq width (font-char-width font))
	       (go single-variable-width-font-loop))
	      (t
	       (setq width (font-char-width font))
	       (go single-fixed-width-font-loop)))

   ;; I considered setting up a little pipeline for this case, but currently the bottleneck
   ;; is %draw-char.  We need a font format that's a little easier to draw.  A faster
   ;; video board wouldn't hurt either.  Currently the inner loop is 20. trivial instructions,
   ;; one cached aref of a simple string, and one %draw-char.

   single-fixed-width-font-loop
	(when ( (setq c (zl:aref string i)) graphic-char-limit)
	  (case c
	    (#/tab     (go single-fixed-width-font-tab))
	    (#/return  (return (values i npos)))
	    (otherwise (if (and weird-handling
				(arrayp (setq exist-table (font-chars-exist-table font)))
				(array-in-bounds-p exist-table c)
				(not(zerop(aref exist-table c))))
			   (go single-fixed-width-font-char)
			 (go single-fixed-width-font-hard)))))
   single-fixed-width-font-char
	(when (> (setq npos (+ (setq xpos npos) width)) xlim)
	  (go exceeded-x-limit))
	(%draw-char font c xpos ypos alu sheet)
	(when (eq (incf i) stop)
	  (go finished))
	(if (< (setq c (zl:aref string i)) graphic-char-limit)
	    (go single-fixed-width-font-char)
	  (case c
	    (#/tab     (go single-fixed-width-font-tab))
	    (#/return  (return (values i npos)))
	    (otherwise (if (and weird-handling
				(arrayp (setq exist-table (font-chars-exist-table font)))
				(array-in-bounds-p exist-table c)
				(not(zerop(aref exist-table c))))
			   (go single-fixed-width-font-char)
			 (go single-fixed-width-font-hard)))))
   single-fixed-width-font-tab
	(setq npos (+ (* (truncate (+ (setq xpos npos) tab-width) tab-width)
			 tab-width) inside-left))
	(when (> npos xlim) (return (values i xpos)))
	(when (eq (incf i) stop) (return (values (1+ stop) npos)))
	(go single-fixed-width-font-loop)
   single-fixed-width-font-hard
	(setq lozenge-string (or (car (rassq c si:xr-special-character-names))
				 (format nil "~O" c)))
	(setq npos (+ (setq xpos npos) (lozenged-string-width lozenge-string)))
	(when (> npos xlim) (return (values i xpos)))
	(setf (sheet-cursor-x sheet) xpos)
	(sheet-display-lozenged-string sheet lozenge-string)
	(when (eq (incf i) stop) (return (values (1+ stop) npos)))
	(go single-fixed-width-font-loop)

   exceeded-x-limit
        (return (values i xpos))
   finished
        (return (values (1+ stop) npos))

   single-variable-width-font-loop
	(when ( (setq c (zl:aref string i)) graphic-char-limit)
	  (case c
	    (#/tab     (go single-variable-width-font-tab))
	    (#/return  (return (values i npos)))
	    (otherwise (if (and weird-handling
				(arrayp (setq exist-table (font-chars-exist-table font)))
				(array-in-bounds-p exist-table c)
				(not(zerop(aref exist-table c))))
			   (go single-variable-width-font-char)
			 (go single-variable-width-font-hard)))))
   single-variable-width-font-char
        (when (> (setq npos (+ (setq xpos npos)
			       (if font-width-table (aref font-width-table c) width))) xlim)
	  (go exceeded-x-limit))
	(if font-kern-table
	    (%draw-char font c (- xpos (aref font-kern-table c)) ypos alu sheet)
	  (%draw-char font c xpos ypos alu sheet))
	(when (eq (incf i) stop)
	  (go finished))
	(go single-variable-width-font-loop)
   single-variable-width-font-tab
	(setq npos (+ (* (truncate (+ (setq xpos npos) tab-width) tab-width)
			 tab-width) inside-left))
	(when (> npos xlim) (return (values i xpos)))
	(when (eq (incf i) stop) (return (values (1+ stop) npos)))
	(go single-variable-width-font-loop)
   single-variable-width-font-hard
	(setq lozenge-string (or (car (rassq c si:xr-special-character-names))
				 (format nil "~O" c)))
	(setq npos (+ (setq xpos npos) (lozenged-string-width lozenge-string)))
	(when (> npos xlim) (return (values i xpos)))
	(setf (sheet-cursor-x sheet) xpos)
	(sheet-display-lozenged-string sheet lozenge-string)
	(when (eq (incf i) stop) (return (values (1+ stop) npos)))
	(go single-variable-width-font-loop)

   single-hairy-font-loop
	(setq width (sheet-character-width sheet (setq c (zl:aref string i)) font))
	(when (> (+ (sheet-cursor-x sheet) width) xlim)
	  (return (values i (sheet-cursor-x sheet))))
	(sheet-tyo sheet c font)
	(when (eq (incf i) stop)
	  (return (values (1+ stop) (sheet-cursor-x sheet))))
	(go single-hairy-font-loop)

   multiple-font
	(setq font-next (%logldb #.%%ch-font (setq c (zl:aref string i))))
   multiple-font-main-loop-font-changed
	(setq font (aref font-map (setq font-index font-next)))
	(setq font-index-table (font-indexing-table font))
	(setq font-width-table (font-char-width-table font))
	(setq font-kern-table (font-left-kern-table font))
	(setq width (font-char-width font))
	(setq ypos (+ base-ypos (- (sheet-baseline sheet) (font-baseline font))))
   multiple-font-main-loop-font-unchanged
	(when ( (setq c (%logldb #.%%ch-char c)) #o200) (go multiple-font-special-character))
	
   multiple-font-graphic-character
	(when (> (setq npos (+ (setq xpos npos)
			       (if font-width-table (aref font-width-table c) width)))
		 xlim)
	  (return (values i xpos)))
	(when (null font-index-table)
	  (if font-width-table
	      (if font-kern-table
		  (go multiple-font-variable-width-with-kerning-loop-short-cut)
		(go multiple-font-variable-width-loop-short-cut))
	    (go multiple-font-fixed-width-loop-short-cut)))
	(setf (sheet-cursor-x sheet) xpos)	;Must transmit latest position.
	(sheet-tyo sheet c font)		;Indexed character (wider than 32 bits).
	(go multiple-font-loop-tail)

   multiple-font-special-character
	(case c
	  (#/tab
	   (when (> (setq npos (+ (setq xpos npos)
				  (- tab-width
				     (\ (- xpos inside-left)
					tab-width))))
		    xlim)
	     (return (values i xpos))))
	  (#/return
	   (return (values i (setq xpos npos))))
	  (otherwise
	   (setq lozenge-string (or (car (rassq c si:xr-special-character-names))
				    (format nil "~O" c)))
	   (when (> (setq npos (+ (setq xpos npos)
				  (lozenged-string-width lozenge-string)))
		    xlim)
	     (return (values i xpos)))
	   (setf (sheet-cursor-x sheet) xpos)
	   (sheet-display-lozenged-string sheet lozenge-string)))

   multiple-font-loop-tail
	(when (eq (incf i) stop) (return (values (1+ stop) npos)))
	(if (eq (setq font-next (%logldb #.%%ch-font (setq c (zl:aref string i)))) font-index)
	    (go multiple-font-main-loop-font-unchanged)
	  (go multiple-font-main-loop-font-changed))
	
   multiple-font-fixed-width-loop
	(when ( (setq c (%logldb #.%%ch-char c)) #o200)
	  (go multiple-font-special-character))
	(when (> (setq npos (+ (setq xpos npos) width))
		 xlim)
	  (return (values i xpos)))
   multiple-font-fixed-width-loop-short-cut
	(%draw-char font c xpos ypos alu sheet)
	(when (eq (incf i) stop) (return (values (1+ stop) npos)))
	(if (eq (setq font-next (%logldb #.%%ch-font (setq c (zl:aref string i)))) font-index)
	    (go multiple-font-fixed-width-loop)
	  (go multiple-font-main-loop-font-changed))

   multiple-font-variable-width-loop
	(when ( (setq c (%logldb #.%%ch-char c)) #o200)
	  (go multiple-font-special-character))
	(when (> (setq npos (+ (setq xpos npos)
			       (if font-width-table (aref font-width-table c) width)))
		 xlim)
	  (return (values i xpos)))
   multiple-font-variable-width-loop-short-cut
	(%draw-char font c xpos ypos alu sheet)
	(when (eq (incf i) stop) (return (values (1+ stop) npos)))
	(if (eq (setq font-next (%logldb #.%%ch-font (setq c (zl:aref string i)))) font-index)
	    (go multiple-font-variable-width-loop)
	  (go multiple-font-main-loop-font-changed))

   multiple-font-variable-width-with-kerning-loop
	(when ( (setq c (%logldb #.%%ch-char c)) #o200)
	  (go multiple-font-special-character))
	(when (> (setq npos (+ (setq xpos npos)
			       (if font-width-table (aref font-width-table c) width)))
		 xlim)
	  (return (values i xpos)))
   multiple-font-variable-width-with-kerning-loop-short-cut
	(%draw-char font c (- xpos (aref font-kern-table c)) ypos alu sheet)
	(when (eq (incf i) stop) (return (values (1+ stop) npos)))
	(if (eq (setq font-next (%logldb #.%%ch-font (setq c (zl:aref string i)))) font-index)
	    (go multiple-font-variable-width-with-kerning-loop)
	  (go multiple-font-main-loop-font-changed))

	))