(FILECREATED " 7-Nov-84 16:25:34" {ERIS}<LISPNEW>FONTSAVAILPATCH.;2 7396
changes to: (VARS FONTSAVAILPATCHCOMS)
previous date: " 7-Nov-84 16:22:39" {ERIS}<LISPNEW>FONTSAVAILPATCH.;1)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FONTSAVAILPATCHCOMS)
(RPAQQ FONTSAVAILPATCHCOMS ((FNS \SEARCHINTERPRESSFONTS FONTSAVAILABLE \FONTINFOFROMFILENAME)))
(DEFINEQ
(\SEARCHINTERPRESSFONTS
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* rrb " 7-Nov-84 15:56")
(* * returns a list of the form (family size face rotation INTERPRESS) for any font matching the specs.
* is used as wildcard.)
(DECLARE (GLOBALVARS INTERPRESSFONTDIRECTORIES))
(bind FONTSFOUND THISFONT (FILENAMEPATTERN ←(\FONTFILENAME FAMILY PSIZE FACE (QUOTE WD)))
for DIR inside INTERPRESSFONTDIRECTORIES
do [for FONTFILE in (DIRECTORY (PACKFILENAME (QUOTE DIRECTORY)
DIR
(QUOTE BODY)
FILENAMEPATTERN))
when [PROGN (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE (QUOTE INTERPRESS)))
(AND (OR (EQ FAMILY (QUOTE *))
(EQ FAMILY (CAR THISFONT)))
(OR (EQ PSIZE (QUOTE *))
(EQ PSIZE (CADR THISFONT)))
(OR (EQ FACE (QUOTE *))
(EQUAL FACE (CADDR THISFONT]
do (* make sure the file is appropriate e.g. the directory
pattern for CLASSIC if SIZE is * will match
CLASSICTHIN10 as well.)
(OR (MEMBER THISFONT FONTSFOUND)
(SETQ FONTSFOUND (CONS THISFONT FONTSFOUND]
finally (RETURN FONTSFOUND])
(FONTSAVAILABLE
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?)
(* rrb " 7-Nov-84 15:41")
(* * returns a list of the fonts fitting a description that are available. FAMILY SIZE FACE or ROTATION can be *
which means get them all. if LOADEDONLYFLG is non-NIL, only fonts in core will be considered.)
(DECLARE (GLOBALVARS IMAGESTREAMTYPES))
(PROG (FONTX DEV)
[SETQ DEV (COND
((type? STREAM DEVICE)
(COND
((LISTP (SETQ DEV (IMAGESTREAMTYPE DEVICE)))
(CAR DEV))
(T DEV)))
(DEVICE)
(T (QUOTE DISPLAY]
(RETURN
(COND
((LISTP FAMILY)
(COND
((EQ (CAR FAMILY)
(QUOTE FONT))
(SETQ FONTX (CDR FAMILY)))
(T (SETQ FONTX FAMILY)))
(FONTSAVAILABLE (CAR FONTX)
(OR (CADR FONTX)
SIZE)
(OR (CADDR FONTX)
FACE)
(OR (CADDDR FONTX)
ROTATION)
DEV CHECKFILESTOO?))
([SETQ FONTX (COND
((type? FONTDESCRIPTOR FAMILY)
FAMILY)
((NULL FAMILY)
(DEFAULTFONT DEV))
((type? FONTCLASS FAMILY)
(* We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.
Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.)
(* I don't know what to do in this case- rrb.)
(\COERCEFONTDESC FAMILY DEV T))
((OR (IMAGESTREAMP FAMILY)
(type? WINDOW FAMILY))
(DSPFONT NIL FAMILY] (* FAMILY was a spec for a font descriptor, use it and
extend it by the other args.)
(FONTSAVAILABLE (FONTPROP FONTX (QUOTE FAMILY))
(OR SIZE (FONTPROP FONTX (QUOTE SIZE)))
(OR FACE (FONTPROP FONTX (QUOTE FACE)))
(OR ROTATION (FONTPROP FONTX (QUOTE ROTATION)))
(OR DEVICE (FONTPROP FONTX (QUOTE DEVICE)))
CHECKFILESTOO?))
(T (PROG ((FONTFACE FACE))
RETRY
(OR (LITATOM FAMILY)
(LISPERROR "ARG NOT LITATOM" FAMILY T))
(OR (AND (FIXP SIZE)
(IGREATERP SIZE 0))
(EQ SIZE (QUOTE *))
(\ILLEGAL.ARG SIZE))
[OR (EQ FONTFACE (QUOTE *))
(SETQ FONTFACE (OR (\FONTFACE FACE T)
(RETURN NIL]
(OR (U-CASEP FAMILY)
(SETQ FAMILY (U-CASE FAMILY)))
(COND
((NULL ROTATION)
(SETQ ROTATION 0))
((AND (FIXP ROTATION)
(IGEQ ROTATION 0)))
((EQ ROTATION (QUOTE *)))
(T (\ILLEGAL.ARG ROTATION)))
(RETURN (UNION (\LOOKUPFONTSINCORE FAMILY SIZE FONTFACE ROTATION DEV)
(COND
((NOT CHECKFILESTOO?)
NIL)
[(EQ DEV (QUOTE *))
(* map thru all the devices.)
(for EXTANTDEV in IMAGESTREAMTYPES
join (APPLY* (OR (CADR (ASSOC (QUOTE FONTSAVAILABLE)
(CDR EXTANTDEV)))
(FUNCTION NILL))
FAMILY SIZE FONTFACE ROTATION (CAR
EXTANTDEV]
(T (* apply the device font lookup function.)
(APPLY* (OR [CADR (ASSOC (QUOTE FONTSAVAILABLE)
(CDR (ASSOC DEV IMAGESTREAMTYPES]
(FUNCTION NILL))
FAMILY SIZE FONTFACE ROTATION DEV])
(\FONTINFOFROMFILENAME
[LAMBDA (FONTFILE DEVICE) (* rrb " 7-Nov-84 15:56")
(* returns a list of the family size face rotation
device of the font stored in the file name FONTFILE.)
(PROG ((FILENAMELIST (UNPACKFILENAME FONTFILE))
SIZEBEG SIZEND NAME FAMILY SIZE)
(SETQ NAME (LISTGET FILENAMELIST (QUOTE NAME))) (* find where the name and size are.)
(SETQ SIZEBEG (for CH# from 1 when (NUMBERP (NTHCHAR NAME CH#)) do (RETURN CH#)))
[SETQ FAMILY (MKATOM (SUBSTRING NAME 1 (SUB1 SIZEBEG]
(SETQ SIZEND (for CH# from SIZEBEG when (NOT (NUMBERP (NTHCHAR NAME CH#)))
do (RETURN CH#)))
[SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND]
(RETURN (LIST FAMILY SIZE (SELECTQ (LISTGET FILENAMELIST (QUOTE EXTENSION))
((DISPLAYFONT AC WD)
(LIST (COND
((STRPOS "-B" NAME SIZEND NIL T)
(QUOTE BOLD))
(T (QUOTE MEDIUM)))
(COND
((STRPOS "-I" NAME SIZEND NIL)
(QUOTE ITALIC))
(T (QUOTE REGULAR)))
(QUOTE REGULAR)))
(LIST (COND
((STRPOS "B" NAME SIZEND NIL T)
(QUOTE BOLD))
(T (QUOTE MEDIUM)))
(COND
((STRPOS "I" NAME SIZEND NIL)
(QUOTE ITALIC))
(T (QUOTE REGULAR)))
(QUOTE REGULAR)))
0 DEVICE])
)
(PUTPROPS FONTSAVAILPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (414 7310 (\SEARCHINTERPRESSFONTS 424 . 1819) (FONTSAVAILABLE 1821 . 5588) (
\FONTINFOFROMFILENAME 5590 . 7308)))))
STOP