(FILECREATED " 3-Dec-84 18:03:45" {ERIS}<LISPNEW>PATCHES>PRESSFONTPATCH.;1
 8393   )


(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT PRESSFONTPATCHCOMS)

(RPAQQ PRESSFONTPATCHCOMS
 ((FNS \CREATEPRESSFONT)))
(DEFINEQ

(\CREATEPRESSFONT

  [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE)                (* rmk: " 3-Dec-84 17:59")


          (* Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for 

	  fixed WidthsY. DEVICE is PRESS or INTERPRESS)



    (DECLARE
 (
GLOBALVARS
 PRESSFONTWIDTHSFILES))
    (
RESETLST
                                                (* RESETLST to make sure the fontfiles get closed)

	      (
PROG
 (WSTRM STRMCACHE XLATEDFAM FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY
			   (WIDTHS (
ARRAY
 (
ADD1
 \MAXCHAR)
					  (
QUOTE
 SMALLPOSP)
					  0 0))
			   (PRESSMICASIZE (
IQUOTIENT
 (
ITIMES
 PSIZE 2540)
						     72))
			   (NSMICASIZE (
FIXR
 (
FQUOTIENT
 (
ITIMES
 PSIZE 2540)
							72)))
			   (FD (create
 FONTDESCRIPTOR
				       FONTDEVICE _ DEVICE
				       FONTFAMILY _ FAMILY
				       FONTSIZE _ PSIZE
				       FONTFACE _ FACE
				       \SFFACECODE _(
\FACECODE
 FACE)
				       ROTATION _ ROTATION)))

          (* The PRESS world and the NS world disagree on whether to truncate or round when converting from points to micas.

	  Hence the different values PRESSMICASIZE and NSMICASIZE.)



		    (
OR
 [for
 F inside
 PRESSFONTWIDTHSFILES when
 (
INFILEP
 F)
			   do
                                (* Look thru the candidate PRESSFONTWIDTHSFILES for a 

							     file that has a description for this font.)

			      [
COND

				[(
SETQ
 WSTRM (
\GETSTREAM
 F (
QUOTE
 INPUT)
							 T))
				  (
COND

				    ((
RANDACCESSP
 WSTRM)
				      (
RESETSAVE
 NIL (
LIST
 (
QUOTE
 SETFILEPTR)
							   WSTRM
							   (
GETFILEPTR
 WSTRM)))
				      (
SETFILEPTR
 WSTRM 0]
				(T (
RESETSAVE
 (
SETQ
 WSTRM (
OPENSTREAM
 F (
QUOTE
 INPUT)
								      (
QUOTE
 OLD)
								      8))
					      (
QUOTE
 (
PROGN
 (
CLOSEF?
 OLDVALUE]
			      [
OR
 (
RANDACCESSP
 WSTRM)
				  (
COPYBYTES
 WSTRM (
SETQ
 WSTRM (
OPENSTREAM
 (
QUOTE
 {NODIRCORE})
									   (
QUOTE
 BOTH)
									   (
QUOTE
 NEW]
			      (push
 STRMCACHE WSTRM)         (* Save for coercions below)

			      (
COND

				((
SETQ
 RELFLAG (
\FINDFONT
 FD WSTRM PRESSMICASIZE NSMICASIZE))
                                                             (* OK, we found this font described in this file.)

				  (
RETURN
 T]
			[
AND
 (
SETQ
 XLATEDFAM (
SELECTQ
 FAMILY
						      (MODERN (
QUOTE
 HELVETICA))
						      (CLASSIC (
QUOTE
 TIMESROMAN))
						      (LOGOTYPE (
QUOTE
 LOGO))
						      (TERMINAL (
QUOTE
 GACHA))
						      NIL))
			     (for
 old
 WSTRM in
 (
SETQ
 STRMCACHE (
DREVERSE
 STRMCACHE))
				first
 (replace
 FONTFAMILY of
 FD with
 XLATEDFAM)
				do
                           (* Now try coercing the family name)


          (* We know the file was left open and is randaccessp from the previous loop, which must have run off the end of the 

	  file list)



				   (
SETFILEPTR
 WSTRM 0)
				   (
COND

				     ((
SETQ
 RELFLAG (
\FINDFONT
 FD WSTRM PRESSMICASIZE NSMICASIZE))
				       (replace
 FONTDEVICESPEC of
 FD
					  with
 (
LIST
 XLATEDFAM PSIZE FACE ROTATION DEVICE))
				       (replace
 FONTFAMILY of
 FD with
 FAMILY)
				       (
RETURN
 T]
			[
AND
 (
SETQ
 XLATEDFAM (
SELECTQ
 FAMILY
						      (MODERN (
QUOTE
 FRUTIGER))
						      (CLASSIC (
QUOTE
 CENTURY))
						      NIL))
			     (for
 old
 WSTRM in
 STRMCACHE first
 (replace
 FONTFAMILY of
 FD
								  with
 XLATEDFAM)
				do
 (
SETFILEPTR
 WSTRM 0)
				   (
COND

				     ((
SETQ
 RELFLAG (
\FINDFONT
 FD WSTRM PRESSMICASIZE NSMICASIZE))
				       (replace
 FONTDEVICESPEC of
 FD
					  with
 (
LIST
 XLATEDFAM PSIZE FACE ROTATION DEVICE))
				       (replace
 FONTFAMILY of
 FD with
 FAMILY)
				       (
RETURN
 T]
			(
RETURN
 NIL))
		    (
SETQ
 RELFLAG (
ZEROP
 RELFLAG))           (* Actually, \FINDFONT returns zero if the font metrics

							     are size-relative and must be scaled.)

		    (
SETFILEPTR
 WSTRM (UNFOLD (
\FIXPIN
 WSTRM)
					      BYTESPERWORD))
                                                             (* Locate the segment)

		    (replace
 FBBOX of
 FD with
 (SIGNED (\WIN WSTRM)
						      BITSPERWORD))
		    (replace
 \SFDescent of
 FD with
 (
IMINUS
 (SIGNED (\WIN WSTRM)
								   BITSPERWORD)))
                                                             (* Descent is -FBBOY)

		    (replace
 FBBDX of
 FD with
 (SIGNED (\WIN WSTRM)
						      BITSPERWORD))
		    (replace
 \SFHeight of
 FD with
 (SIGNED (\WIN WSTRM)
							  BITSPERWORD))
                                                             (* Height is FBBDY)

		    (replace
 \SFWidths of
 FD with
 WIDTHS)
		    (
SETQ
 FIRSTCHAR (fetch
 FIRSTCHAR of
 FD))
		    (
SETQ
 LASTCHAR (fetch
 LASTCHAR of
 FD))
		    [
COND

		      (RELFLAG                               (* Dimensions are relative, must be scaled)

			       (replace
 FBBOX of
 FD with
 (
IQUOTIENT
 (
ITIMES
 (fetch
 FBBOX
									       of
 FD)
									    PRESSMICASIZE)
								    1000))
			       (replace
 \SFDescent of
 FD with
 (
IQUOTIENT
 (
ITIMES
 (fetch
 \SFDescent
										    of
 FD)
										 PRESSMICASIZE)
									 1000))
			       (replace
 FBBDX of
 FD with
 (
IQUOTIENT
 (
ITIMES
 (fetch
 FBBDX
									       of
 FD)
									    PRESSMICASIZE)
								    1000))
			       (replace
 \SFHeight of
 FD with
 (
IQUOTIENT
 (
ITIMES
 (fetch
 \SFHeight
										   of
 FD)
										PRESSMICASIZE)
									1000]
		    (replace
 \SFAscent of
 FD with
 (
IDIFFERENCE
 (fetch
 \SFHeight of
 FD)
							       (fetch
 \SFDescent of
 FD)))
		    (
SETQ
 FIXEDFLAGS (
LRSH
 (
\BIN
 WSTRM)
					   6))               (* The fixed flags)

		    (
\BIN
 WSTRM)                             (* Skip the spares)

		    [
COND

		      ((
EQ
 2 (
LOGAND
 FIXEDFLAGS 2))
			(
SETQ
 TEM (\WIN WSTRM))              (* The fixed width for this font)

			[
COND

			  ((
AND
 RELFLAG (
NOT
 (
ZEROP
 TEM)))
			    (
SETQ
 TEM (
IQUOTIENT
 (
ITIMES
 TEM PRESSMICASIZE)
						 1000]
			(for
 I from
 FIRSTCHAR to
 LASTCHAR do
 (
SETA
 WIDTHS I TEM)))
		      (T (
AIN
 WIDTHS FIRSTCHAR (
ADD1
 (
IDIFFERENCE
 LASTCHAR FIRSTCHAR))
			      WSTRM)
			 (for
 I from
 FIRSTCHAR to
 LASTCHAR when
 (
EQ
 noInfoCode (
ELT
 WIDTHS I))
			    do
 (
SETA
 WIDTHS I 0))
			 (
COND

			   (RELFLAG (for
 I from
 FIRSTCHAR to
 LASTCHAR
				       do
 (
SETA
 WIDTHS I (
IQUOTIENT
 (
ITIMES
 (
ELT
 WIDTHS I)
									    PRESSMICASIZE)
								    1000]
		    [
COND

		      [(
EQ
 1 (
LOGAND
 FIXEDFLAGS 1))
			(
SETQ
 WIDTHSY (\WIN WSTRM))          (* The fixed width-Y for this font;

							     the width-Y field is a single integer in the FD)

			(replace
 \SFWidthsY of
 FD with
 (
COND

							 ((
AND
 RELFLAG (
NOT
 (
ZEROP
 WIDTHSY)))
							   (
IQUOTIENT
 (
ITIMES
 WIDTHSY PRESSMICASIZE)
								      1000))
							 (T WIDTHSY]
		      (T (replace
 \SFWidthsY of
 FD with
 (
SETQ
 WIDTHSY (
ARRAY
 (
ADD1
 \MAXCHAR)
									     (
QUOTE
 SMALLPOSP)
									     0 0)))
			 (
AIN
 WIDTHSY FIRSTCHAR (
ADD1
 (
IDIFFERENCE
 LASTCHAR FIRSTCHAR))
			      WSTRM)
			 (for
 I from
 FIRSTCHAR to
 LASTCHAR when
 (
EQ
 noInfoCode (
ELT
 WIDTHSY I))
			    do
 (
SETA
 WIDTHSY I 0))
			 (
COND

			   (RELFLAG (for
 I from
 FIRSTCHAR to
 LASTCHAR
				       do
 (
SETA
 WIDTHSY I (
IQUOTIENT
 (
ITIMES
 (
ELT
 WIDTHSY I)
									     PRESSMICASIZE)
								     1000]
		    (
RETURN
 FD])
)
(PUTPROPS PRESSFONTPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (252 8308 (\CREATEPRESSFONT 262 . 8306)))))
STOP