;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Changes:
;;; 9/28/92 AMICKISH  Added Point-Size variables so that make-xfont-name
;;;              selects fonts based on point size, not pixel size
;;;  8/6/91 AMICKISH  Added ps-font-name (used by postscript module)
;;;  3/4/91 d'souza Removed nickname "MO" of package Opal.
;;; 3/18/90 ECP  Oops, I had "times" and "helvetica" switched.
;;;		 Actually, Times has the serifs, not Helvetica.
;;; 1/25/90 ECP  Total rewrite to take advantage of standard font files.
;;;              using X font naming conventions.
;;;

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

(defvar *Fixed-Font-Family*      "courier")
(defvar *Serif-Font-Family*      "times")
(defvar *Sans-Serif-Font-Family* "helvetica")

(defvar *Small-Font-Size*      10)
(defvar *Medium-Font-Size*     12)
(defvar *Large-Font-Size*      18)
(defvar *Very-Large-Font-Size* 24)

(defvar *Small-Font-Point-Size*      100)
(defvar *Medium-Font-Point-Size*     120)
(defvar *Large-Font-Point-Size*      180)
(defvar *Very-Large-Font-Point-Size* 240)

;; Returns either a string which describes the font using X conventions,
;; or a cons of the bad value and slot.
(defun make-xfont-name (key)
  (let ((family-part
          (case (first key)
            (:fixed      *Fixed-Font-Family*)
            (:serif      *Serif-Font-Family*)
            (:sans-serif *Sans-Serif-Font-Family*)
	    (otherwise   nil)))
        (face-part 
          (case (second key)
            (:roman "medium-r")
            (:bold "bold-r")
            (:italic (if (eq (first key) :serif) "medium-i" "medium-o"))
            (:bold-italic (if (eq (first key) :serif) "bold-i" "bold-o"))
            (otherwise nil)))
        (size-part
	  (case (third key)
            (:small      (princ-to-string *Small-Font-Point-Size*))
            (:medium     (princ-to-string *Medium-Font-Point-Size*))
            (:large      (princ-to-string *Large-Font-Point-Size*))
            (:very-large (princ-to-string *Very-Large-Font-Point-Size*))
            (otherwise   nil))))
    (cond ((null family-part)
           (cons (first key) :family)) ;; for reporting error
          ((null face-part)
           (cons (second key) :face))
          ((null size-part)
           (cons (third key) :size))
          (t
           (concatenate 'string
           "*-*-"
           family-part
           "-"
           face-part
           "-*-*-*-" 
           size-part
           "-*-*-*-*-iso8859-1")))))

;; "/Courier", etc. are names of postscript fonts used by the printer.
;;
(defun ps-font-name (family face)
  (let* ((serif-p (eq family :serif))
	 (ps-font1 (case family
		     (:fixed "/Courier")
		     (:serif "/Times")
		     (:sans-serif "/Helvetica")))
	 (ps-font2 (case face
		     (:roman (if serif-p "-Roman" ""))
		     (:bold "-Bold")
		     (:italic (if serif-p "-Italic" "-Oblique"))
		     (:bold-italic (if serif-p
				       "-BoldItalic"
				       "-BoldOblique")))))
    (concatenate 'string ps-font1 ps-font2)))

(defun ps-font-size (size)
  (case size
    (:small *Small-Font-Size*)
    (:medium *Medium-Font-Size*)
    (:large *Large-Font-Size*)
    (:very-large *Very-Large-Font-Size*)))

