(FILECREATED " 5-Sep-85 19:29:50" {ERIS}<LISPCORE>LIBRARY>FONTSAMPLE.;5 12927
changes to: (FNS FNT.FINDALL FNT.DISPLOOK FNT.NARRDSCR FNT.FACEMAP)
(VARS FNT.INFOFONT)
previous date: " 5-Sep-85 16:57:58" {ERIS}<LISPCORE>LIBRARY>FONTSAMPLE.;3)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FONTSAMPLECOMS)
(RPAQQ FONTSAMPLECOMS ((VARS FNT.PANEL FNT.FNAME FNT.INFOFONT FNT.OUTFTEXT)
(FNS FNT.MAKEBOOK FNT.LESSP FNT.DISPLOOK FNT.DISPTBLE FNT.DISPDSCR
FNT.NARRDSCR FNT.DISPINIT FNT.FACEMAP FNT.SIZEMAP FNT.MAKENAME
FNT.MAKEWIND FNT.FILEMAP FNT.FINDALL)))
(RPAQQ FNT.PANEL ([PROG (SETQ FNT.WIND (FNT.MAKEWIND))
(SETQ FNT.FONTLIST (QUOTE (GACHA 10 (MEDIUM REGULAR REGULAR)
0 INTERPRESS]
(PROG (CLEARW FNT.WIND)
(FNT.DISPTBLE FNT.WIND FNT.FONTLIST))
(PROG (SETQ FNT.FILENAME (FNT.MAKENAME FNT.FONTLIST))
(SETQ FNT.STRM (OPENIMAGESTREAM FNT.FILENAME (QUOTE INTERPRESS)))
(TOTOPW FNT.WIND)
(BITBLT FNT.WIND 0 0 FNT.STRM 0 0 612 792 (QUOTE INPUT)
(QUOTE REPLACE))
(CLOSEF FNT.STRM))))
(RPAQQ FNT.FNAME {DSK}FONTBOOK.IP)
(RPAQQ FNT.INFOFONT (TERMINAL 8 (MEDIUM REGULAR REGULAR)
0))
(RPAQQ FNT.OUTFTEXT "abcdefghijkl ABCDEFGHIJKL")
(DEFINEQ
(FNT.MAKEBOOK
[LAMBDA (OUTFROOTNAME ListOfFonts PRNTFN PERPAGE) (* FS " 5-Sep-85 15:44")
(* * takes a file name and font specification and iteratively invokes a given print function
(fnt.dispfont by default) on each font in the sorted list)
(PROG (CURRFONT FONTLIST OUTFTYPE OUTFDSCR TYPE SIZE FACE ANGL ITER BREAKFILE PAGENO OUTFNAME)
(* * Handle input parm defaults * *)
(if (EQ PRNTFN NIL)
then (SETQQ PRNTFN FNT.DISPLOOK))
(if (EQ PERPAGE NIL)
then (SETQ PERPAGE 18))
(SETQQ OUTFTYPE INTERPRESS)
(SETQ PAGENO 1)
(if (EQ OUTFROOTNAME NIL)
then (SETQ OUTFDSCR NIL)
else (SETQ OUTFNAME (FNT.FILEMAP OUTFROOTNAME PAGENO))
(SETQ OUTFDSCR (OPENIMAGESTREAM OUTFNAME OUTFTYPE)))
(if (EQUAL ListOfFonts (QUOTE ALL))
then (SETQ FONTLIST (FNT.FINDALL OUTFTYPE))
else (SETQ FONTLIST ListOfFonts))
(* * Iterate over fonts, increment file name * *)
(SETQ ITER 0)
(SETQ BREAKFILE T)
[for I in FONTLIST
do (APPLY* PRNTFN OUTFDSCR I)
(SETQ ITER (ADD1 ITER))
(if (AND (GEQ ITER PERPAGE)
BREAKFILE)
then (SETQ ITER 0)
(SETQ PAGENO (ADD1 PAGENO))
(CLOSEF OUTFNAME)
(SETQ OUTFNAME (FNT.FILEMAP OUTFROOTNAME PAGENO))
(SETQ OUTFDSCR (OPENIMAGESTREAM OUTFNAME OUTFTYPE]
(if (AND (NEQ OUTFNAME T)
(NEQ OUTFNAME NIL))
then (CLOSEF OUTFNAME))
(RETURN NIL])
(FNT.LESSP
[LAMBDA (DSC1 DSC2) (* FS " 5-Sep-85 16:39")
(* * Impose alpha order on font descriptions)
(PROG (KEY1 KEY2)
(if (NOT (LISTP DSC1))
then (RETURN (ALPHORDER DSC1 DSC2)))
(SETQ KEY1 (CAR DSC1))
(SETQ KEY2 (CAR DSC2))
(if (LISTP KEY1)
then (RETURN (FNT.LESSP KEY1 KEY2)))
(if (NEQ KEY1 KEY2)
then (RETURN (ALPHORDER KEY1 KEY2)))
(RETURN (FNT.LESSP (CDR DSC1)
(CDR DSC2])
(FNT.DISPLOOK
[LAMBDA (FILEDSC FONTDSC) (* FS " 5-Sep-85 18:54")
(* * uses "private" global vars fnt.infofont and fnt.outftext to generate sample string)
(PROG NIL
(DSPFONT FNT.INFOFONT FILEDSC)
(TERPRI FILEDSC)
(TERPRI FILEDSC)
(TERPRI FILEDSC)
(TERPRI FILEDSC)
(FNT.NARRDSCR FILEDSC (LIST FONTDSC))
(DSPFONT FONTDSC FILEDSC)
(printout FILEDSC FNT.OUTFTEXT)
(RETURN NIL])
(FNT.DISPTBLE
[LAMBDA (Stream FONTDSC) (* FS " 2-Jul-85 15:23")
(* * generates a font table using prin1)
(LET* ((TitleFont (FONTCREATE FNT.INFOFONT))
(FontList (LIST FONTDSC))
(InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream)))
(DDev (IMAGESTREAMTYPE Stream)))
(for Font in FontList
do (MOVETO (FTIMES .75 InchesToPrinterUnits)
(FTIMES 10.0 InchesToPrinterUnits)
Stream)
(DSPFONT TitleFont Stream)
(FNT.NARRDSCR Stream FontList)
(DSPFONT FONTDSC Stream)
(printout Stream FNT.OUTFTEXT)
(DSPFONT Font Stream)
(for YPosition from (TIMES 9 InchesToPrinterUnits) to (TIMES 1.5 InchesToPrinterUnits)
by (TIMES -.5 InchesToPrinterUnits) bind (CharacterCode ← 0)
do (for XPosition from (TIMES .75 InchesToPrinterUnits) to (TIMES 7.5
InchesToPrinterUnits)
by (TIMES .45 InchesToPrinterUnits)
do (MOVETO XPosition YPosition Stream)
(if (NEQ CharacterCode (CHARCODE FF))
then (if (EQ DDev (QUOTE DISPLAY))
then (BLTCHAR CharacterCode Stream)
else (PRIN1 (CHARACTER CharacterCode)
Stream)))
(SETQ CharacterCode (ADD1 CharacterCode)))
(printout T "."))
(printout T " done." T])
(FNT.DISPDSCR
[LAMBDA (OUTF FONTLIST) (* FS " 2-Jul-85 13:00")
(* * Prints a list of fontlists with facelist formatting appropriate for 8 pt. terminal)
(PROG (NAME SIZE JUNK NUMB STRM TEMP OFFX UNITS T0 T1 T2 T3 T4 T5 T6 T7)
(if (EQ FONTLIST NIL)
then (RETURN NIL))
(SETQ TEMP (DSPSCALE NIL OUTF))
(SETQ UNITS (TIMES 4.25 TEMP))
(SETQ OFFX (TIMES 42.5 TEMP))
(SETQ T0 (PLUS OFFX (TIMES 0 UNITS)))
(SETQ T1 (PLUS OFFX (TIMES 14 UNITS)))
(SETQ T2 (PLUS OFFX (TIMES 20 UNITS)))
(SETQ T3 (PLUS OFFX (TIMES 30 UNITS)))
(SETQ T4 (PLUS OFFX (TIMES 40 UNITS)))
(SETQ T5 (PLUS OFFX (TIMES 50 UNITS)))
(SETQ T6 (PLUS OFFX (TIMES 55 UNITS)))
(SETQ T7 (PLUS OFFX (TIMES 70 UNITS)))
[MAPC FONTLIST (QUOTE (LAMBDA (DESCR)
(SETQ NAME (CAR DESCR))
(SETQ SIZE (CADR DESCR))
(SETQ JUNK (CADDR DESCR))
(SETQ TEMP (CDDDR DESCR))
(SETQ NUMB (CAR TEMP))
(SETQ STRM (CADR TEMP))
(DSPXPOSITION T0 OUTF)
(printout OUTF NAME)
(DSPXPOSITION T1 OUTF)
(printout OUTF .I3 SIZE)
(DSPXPOSITION T2 OUTF)
(printout OUTF "(" (CAR JUNK))
(DSPXPOSITION T3 OUTF)
(printout OUTF (CADR JUNK))
(DSPXPOSITION T4 OUTF)
(printout OUTF (CADDR JUNK)
")")
(DSPXPOSITION T5 OUTF)
(printout OUTF NUMB)
(DSPXPOSITION T6 OUTF)
(printout OUTF STRM)
(DSPXPOSITION T7 OUTF]
(RETURN NIL])
(FNT.NARRDSCR
[LAMBDA (OUTF FONTLIST) (* FS " 5-Sep-85 18:52")
(* * Prints a list of fontlists with narrow formatting appropriate for 8 pt. terminal)
(PROG (NAME SIZE FACE NUMB STRM TEMP OFFX UNITS T0 T1 T2 T3 T4 T5)
(if (EQ FONTLIST NIL)
then (RETURN NIL))
(SETQ TEMP (DSPSCALE NIL OUTF))
(SETQ UNITS (TIMES 4.25 TEMP))
(SETQ OFFX (TIMES 42.5 TEMP))
(SETQ T0 (PLUS OFFX (TIMES 0 UNITS)))
(SETQ T1 (PLUS OFFX (TIMES 14 UNITS)))
(SETQ T2 (PLUS OFFX (TIMES 20 UNITS)))
(SETQ T3 (PLUS OFFX (TIMES 28 UNITS)))
(SETQ T4 (PLUS OFFX (TIMES 33 UNITS)))
(SETQ T5 (PLUS OFFX (TIMES 48 UNITS)))
(* * (MAPC FONTLIST (QUOTE (LAMBDA (DESCR) (SETQ NAME (CAR DESCR)) (SETQ SIZE (CADR DESCR))
(SETQ FACE (FNT.FACEMAP (CADDR DESCR))) (SETQ TEMP (CDDDR DESCR)) (SETQ NUMB (CAR TEMP)) (SETQ STRM
(CADR TEMP)) (DSPXPOSITION T0 OUTF) (printout OUTF NAME) (DSPXPOSITION T1 OUTF) (printout OUTF .I3 SIZE)
(DSPXPOSITION T2 OUTF) (printout OUTF FACE) (DSPXPOSITION T3 OUTF) (printout OUTF NUMB) (DSPXPOSITION T4 OUTF)
(printout OUTF STRM) (DSPXPOSITION T5 OUTF)))))
(for DESCR in FONTLIST
do (SETQ NAME (CAR DESCR))
(SETQ SIZE (CADR DESCR))
(SETQ FACE (FNT.FACEMAP (CADDR DESCR)))
(SETQ TEMP (CDDDR DESCR))
(SETQ NUMB (CAR TEMP))
(SETQ STRM (CADR TEMP))
(DSPXPOSITION T0 OUTF)
(printout OUTF NAME)
(DSPXPOSITION T1 OUTF)
(printout OUTF .I3 SIZE)
(DSPXPOSITION T2 OUTF)
(printout OUTF FACE)
(DSPXPOSITION T3 OUTF)
(printout OUTF NUMB)
(DSPXPOSITION T4 OUTF)
(printout OUTF STRM)
(DSPXPOSITION T5 OUTF))
(RETURN NIL])
(FNT.DISPINIT
[LAMBDA (FILEDSC) (* FS " 2-Jul-85 14:14")
(* * initialization or optimization for fnt.dispfont)
(PROG (vars...)
(SETQ FNT.OUTFTEXT "abcdefghijkl ABCDEFGHIJKL")
(SETQQ FNT.INFOFONT (TERMINAL 8 (MEDIUM REGULAR REGULAR)
0 INTERPRESS))
(RETURN NIL])
(FNT.FACEMAP
[LAMBDA (OLDFACE) (* FS " 5-Sep-85 19:04")
(* * make short face from facelist)
(SETQ OLDFACE (\FONTFACE OLDFACE)) (* make list form *)
(CONCAT (GNC (MKSTRING (CAR OLDFACE)))
(GNC (MKSTRING (CADR OLDFACE)))
(GNC (MKSTRING (CADDR OLDFACE])
(FNT.SIZEMAP
[LAMBDA (SIZE) (* FS " 2-Jul-85 14:13")
(* * make size into two character string)
(PROG (STR)
(if (ILESSP SIZE 10)
then (RETURN (CONCAT "0" (MKSTRING SIZE)))
else (RETURN (MKSTRING SIZE])
(FNT.MAKENAME
[LAMBDA (FONTLIST) (* FS " 3-Sep-85 16:07")
(* * make a unique interpress file name given a fontlist)
(PROG (STR TYPE SIZE FACE DDEV)
(SETQ TYPE (MKSTRING (CAR FONTLIST)))
(SETQ SIZE (FNT.SIZEMAP (CADR FONTLIST)))
[SETQ FACE (MKSTRING (FNT.FACEMAP (CADDR FONTLIST]
(SETQ DDEV (CAR (CDDDDR FONTLIST)))
(SETQ STR (CONCAT (MKSTRING TYPE)
(MKSTRING SIZE)
(MKSTRING FACE)
(GNC (MKSTRING DDEV))
".IP"))
(RETURN STR])
(FNT.MAKEWIND
[LAMBDA NIL (* FS " 2-Jul-85 13:59")
(* * MAKE A WINDOW)
(PROG (PPI)
(SETQ PPI (TIMES 72 (DSPSCALE NIL T)))
[SETQ FNT.WINDOW (CREATEW (create REGION
LEFT ← 0
BOTTOM ← 0
WIDTH ←(TIMES 8.5 PPI)
HEIGHT ←(TIMES 11 PPI]
(RETURN FNT.WINDOW])
(FNT.FILEMAP
[LAMBDA (OUTFNAME NUMBER) (* FS " 5-Sep-85 16:56")
(* * Takes a file name and returns an Interpress file name with number at end * *)
(PROG (FNAME ROOTNAME DESTNAME)
(if (OR (EQ OUTFNAME T)
(EQ OUTFNAME NIL))
then (RETURN OUTFNAME))
(SETQ FNAME OUTFNAME)
(SETQ ROOTNAME (FILENAMEFIELD FNAME (QUOTE NAME)))
(SETQ ROOTNAME (MKATOM (CONCAT ROOTNAME NUMBER)))
(SETQ DESTNAME (PACKFILENAME (QUOTE NAME)
ROOTNAME
(QUOTE BODY)
FNAME))
(RETURN DESTNAME])
(FNT.FINDALL
[LAMBDA (DEVICE) (* FS " 5-Sep-85 19:18")
(* * Returns list of all fonts for device * *)
(LET (RESULT)
(SETQ RESULT (FONTSAVAILABLE (QUOTE *)
(QUOTE *)
(QUOTE (* * *))
(QUOTE *)
DEVICE T))
(SETQ RESULT (SORT RESULT (QUOTE FNT.LESSP])
)
(PUTPROPS FONTSAMPLE COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1282 12846 (FNT.MAKEBOOK 1292 . 3026) (FNT.LESSP 3028 . 3665) (FNT.DISPLOOK 3667 . 4233
) (FNT.DISPTBLE 4235 . 5692) (FNT.DISPDSCR 5694 . 7497) (FNT.NARRDSCR 7499 . 9476) (FNT.DISPINIT 9478
. 9861) (FNT.FACEMAP 9863 . 10273) (FNT.SIZEMAP 10275 . 10612) (FNT.MAKENAME 10614 . 11285) (
FNT.MAKEWIND 11287 . 11720) (FNT.FILEMAP 11722 . 12425) (FNT.FINDALL 12427 . 12844)))))
STOP