 ;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; PS-Multifont
;;;
;;; This file contains functions for the multifont-text object used to
;;; generate PostScript files with the PS module.
;;;
;;; Multifont-text functions written by Rich McDaniel

;;; Change Log:
;;;
;;; 06/23/92 Andrew Mickish - Only print cursor when :visible is T
;;; 04/21/92 Andrew Mickish - Sent :ps-object message to multifont's cursor
;;; 04/15/92 Andrew Mickish - Moved multifont-text stuff here from ps.lisp
;;;

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

(define-method :ps-register-fn OPAL:MULTIFONT-TEXT (obj)
  (pushnew *text-fn* *required-ps-fns*)
  (pushnew *rectangle-fn* *required-ps-fns*)
  (and *color-p*
       (or *file-uses-color-p* (check-ls-color obj) (check-fs-color obj))))

(defun ps-frag (frag line-x top base-y height line-halftone line-style fill-p)
   (let ((string (convert-parentheses (opal::frag-string frag))))
      (unless (or (null string) (string= string ""))
         (let* ((left line-x)
                (opal-width (opal::frag-width frag))
                (font (opal::frag-font frag))
                (font-name (ps-font-name (g-value font :family)
                                 (g-value font :face)))
                (font-size (ps-font-size (g-value font :size))))
            (add-font-to-list font-name)
            (format t "~S ~S ~S ~S ~S " left top base-y opal-width height)
            (format t (format-int-or-fp line-halftone))
            (if fill-p
               (format t " true ")
               (format t " false ")
            )
            (print-color-info line-style)
            (print-background-color-info line-style)
            (format t (concatenate 'string
                  "(" string ") "
                  (prin1-to-string font-size) " " font-name
                  " DrawText~%"))
         )
      )
   )
)

(defun ps-multifont-line (obj line-halftone line-style fill-p)
   (let* ((line-x (g-value obj :left))
          (top (convert-y (g-value obj :top)))
          (line-y (- top (g-value obj :ascent)))
          (height (g-value obj :height)))
      (do ((frag (g-value obj :first-frag) (opal::frag-next-frag frag)))
          ((null frag))
         (ps-frag frag line-x top line-y height
               line-halftone line-style fill-p)
         (incf line-x (opal::frag-width frag))
      )
   )
)

(define-method :ps-object OPAL:MULTIFONT-TEXT (obj)
   (let ((line-style (g-value obj :line-style)))
     (if line-style
	 (let ((line-halftone
		(let ((stipple (g-value line-style :stipple)))
		  (if stipple
		      (- 1 (float (/ (g-value stipple :percent) 100)))
		      0)))
	       (fill-p (g-value obj :fill-background-p))
	       (cursor (g-value obj :cursor)))
	   (do ((line (g-value obj :first-line) (g-value line :next-line)))
	       ((null line))
	     (ps-multifont-line line line-halftone line-style fill-p))
	   (if (g-value cursor :visible)
	       (kr-send cursor :ps-object cursor))))))


