(FILECREATED "29-Apr-87 22:41:24" {ERIS}<LISPUSERS>KOTO>FONTSAMPLER.;6 6756
changes to: (FNS FontTable FontSample)
previous date: "28-Apr-87 14:59:04" {ERIS}<LISPUSERS>KOTO>FONTSAMPLER.;4)
(* Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FONTSAMPLERCOMS)
(RPAQQ FONTSAMPLERCOMS ((FNS FontSample FontSampleFaked FontTable)
[VARS (*INTERESTING-CHARSETS* (QUOTE (0 33 34 38 39 238 239 240 241]
(DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
FONT))))
(DEFINEQ
(FontSample
[LAMBDA (Fonts CharacterSets Printer StreamType) (* edited: "29-Apr-87 22:03")
(LET* [[TitleFont (FONTCREATE NIL 12 (QUOTE MRR)
0
(OR StreamType (PRINTERTYPE Printer]
(FontList (if (LISTP Fonts)
else (CONS Fonts)))
[Stream (OPENIMAGESTREAM Printer StreamType (LIST (QUOTE FONTS)
(CONS TitleFont FontList]
(InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream)))
(LastFont (CAR (LAST FontList)))
[CharacterSets (if (LISTP CharacterSets)
then CharacterSets
else (LIST (OR CharacterSets 0]
(LastCharacterSet (CAR (LAST CharacterSets]
(DSPRIGHTMARGIN (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL Stream))
Stream)
(for Font in FontList do (for CharacterSet in CharacterSets
do (FontTable Font CharacterSet Stream
(OR (NEQ Font LastFont)
(NEQ CharacterSet
LastCharacterSet))
TitleFont InchesToPrinterUnits))
finally (CLOSEF Stream])
(FontSampleFaked
[LAMBDA (FontAsList Printer StreamType) (* N.H.Briggs "27-Apr-87 18:12")
(LET* [[TitleFont (FONTCREATE NIL 12 (QUOTE MRR)
0
(OR StreamType (PRINTERTYPE Printer]
(Font)
[Stream (OPENIMAGESTREAM Printer StreamType (LIST (QUOTE FONTS)
(LIST TitleFont]
(InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream]
[SETQ Font (NCREATE (QUOTE FONTDESCRIPTOR)
(DEFAULTFONT (OR StreamType (PRINTERTYPE Printer]
(replace FONTFAMILY of Font with (CAR FontAsList))
(replace FONTSIZE of Font with (CADR FontAsList))
(replace FONTFACE of Font with (\FONTFACE (CADDR FontAsList)))
(FontTable Font (QUOTE (0))
Stream NIL TitleFont InchesToPrinterUnits)
(CLOSEF Stream])
(FontTable
[LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits)
(* edited: "29-Apr-87 22:36")
(LET* ((Family (FONTPROP Font (QUOTE FAMILY)))
(Face (FONTPROP Font (QUOTE FACE)))
(Size (FONTPROP Font (QUOTE SIZE)))
(Title (CONCAT " " Size "pt " (L-CASE Family T)
" "
(L-CASE Face T)
" Character set ")))
(printout T Title .I0.8 CharacterSet "Q")
(RESETLST (RESETSAVE (RADIX 8))
(for XPosition from (TIMES .65 InchesToPrinterUnits)
by (TIMES .45 InchesToPrinterUnits) as Counter from 0 to 15
bind (YPosition ←(TIMES 9.5 InchesToPrinterUnits))
do (MOVETO XPosition YPosition Stream)
(PRIN1 Counter Stream))
(for YPosition from (TIMES 9 InchesToPrinterUnits)
by (TIMES -.5 InchesToPrinterUnits) as Counter from 0 to 240
by 16 bind (XPosition ←(TIMES .25 InchesToPrinterUnits))
do (MOVETO XPosition YPosition Stream)
(PRIN1 Counter Stream)))
(DRAWLINE (TIMES .25 InchesToPrinterUnits)
(TIMES 9.25 InchesToPrinterUnits)
(TIMES 8.0 InchesToPrinterUnits)
(TIMES 9.25 InchesToPrinterUnits)
(DSPSCALE NIL Stream)
(QUOTE PAINT)
Stream)
(DRAWLINE (TIMES .6 InchesToPrinterUnits)
(TIMES 9.7 InchesToPrinterUnits)
(TIMES .6 InchesToPrinterUnits)
(TIMES 1.25 InchesToPrinterUnits)
(DSPSCALE NIL Stream)
(QUOTE PAINT)
Stream)
(DSPFONT Font Stream)
(for YPosition from (TIMES 9 InchesToPrinterUnits) by (TIMES -.5
InchesToPrinterUnits)
as YCounter from 0 to 15 bind (CharacterCode ← 0)
do (for XPosition from (TIMES .75 InchesToPrinterUnits) by (TIMES .45
InchesToPrinterUnits)
as XCounter from 0 to 15
do (MOVETO XPosition YPosition Stream)
(if (AND (NEQ CharacterCode (CHARCODE FF))
(if (MEMB (IMAGESTREAMTYPE Stream)
(QUOTE (DISPLAY INTERPRESS)))
then (OR (AND (IGREATERP CharacterCode 31)
(ILESSP CharacterCode 127))
(AND (IGREATERP CharacterCode 160)
(ILESSP CharacterCode 255)))
else T))
then (PRINTCCODE (IPLUS (ITIMES CharacterSet 256)
CharacterCode)
Stream))
(SETQ CharacterCode (ADD1 CharacterCode)))
(printout T "."))
(MOVETO (FTIMES .75 InchesToPrinterUnits)
(FTIMES .75 InchesToPrinterUnits)
Stream)
(DSPFONT TitleFont Stream)
(printout Stream Title .I0.8 CharacterSet)
(DSPYPOSITION (PLUS (DSPYPOSITION NIL Stream)
(TIMES -.4 (FONTHEIGHT TitleFont)))
Stream)
(printout Stream "8")
[if (EQ (FILENAMEFIELD (FULLNAME Stream)
(QUOTE HOST))
(QUOTE LPT))
then (MOVETO (FTIMES .75 InchesToPrinterUnits)
(FTIMES .5 InchesToPrinterUnits)
Stream)
(printout Stream " on " (L-CASE (OR (FILENAMEFIELD (FULLNAME Stream)
(QUOTE DEVICE))
(FILENAMEFIELD (FULLNAME Stream)
(QUOTE NAME)))
T)
", "
(GDATE NIL (DATEFORMAT NO.TIME SPACES]
(if FormFeed
then (DSPNEWPAGE Stream))
(printout T " done." T])
)
(RPAQQ *INTERESTING-CHARSETS* (0 33 34 38 39 238 239 240 241))
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
FONT)
)
(PUTPROPS FONTSAMPLER COPYRIGHT ("Xerox Corporation" 1985 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (540 6534 (FontSample 550 . 1744) (FontSampleFaked 1746 . 2686) (FontTable 2688 . 6532))
)))
STOP