(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 5-Feb-2025 17:03:38" {DSK}matt>Interlisp>medley>lispusers>FONTSAMPLER.;11 9743 :EDIT-BY "mth" :CHANGES-TO (FNS FontSample FontTable) :PREVIOUS-DATE " 3-Feb-2025 20:08:40" {DSK}matt>Interlisp>medley>lispusers>FONTSAMPLER.;10 ) (PRETTYCOMPRINT FONTSAMPLERCOMS) (RPAQQ FONTSAMPLERCOMS ((FNS FontSample FontSampleFaked FontTable) [VARS (*INTERESTING-CHARSETS* '(0 33 34 38 39 238 239 240 241] (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) FONT)))) (DEFINEQ (FontSample [LAMBDA (Fonts CharacterSets Printer StreamType Hexadecimal) (* ; "Edited 5-Feb-2025 17:02 by mth") (* edited%: "29-Apr-87 22:03") (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer] (FontList (if (LISTP Fonts) else (CONS Fonts))) [Stream (OPENIMAGESTREAM Printer StreamType (LIST '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 Hexadecimal)) finally (CLOSEF Stream]) (FontSampleFaked [LAMBDA (FontAsList Printer StreamType) (* N.H.Briggs "27-Apr-87 18:12") (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer] (Font) [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (LIST TitleFont] (InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream] [SETQ Font (NCREATE '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 '(0) Stream NIL TitleFont InchesToPrinterUnits) (CLOSEF Stream]) (FontTable [LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits Hexadecimal) (* ; "Edited 5-Feb-2025 17:03 by mth") (* ; "Edited 3-Feb-2025 20:07 by mth") (* edited%: "29-Apr-87 22:36") (LET* ((Family (FONTPROP Font 'FAMILY)) (Face (FONTPROP Font 'FACE)) (Size (FONTPROP Font 'SIZE)) (Title (CONCAT " " Size "pt " (L-CASE Family T) " " (L-CASE Face T) " Character set ")) [UseDisplayFontBitmaps (AND (EQ (FONTPROP Font 'DEVICE) 'DISPLAY) (NOT (EQ (IMAGESTREAMTYPE Stream) 'DISPLAY] [RelativeDescent (FQUOTIENT (FONTPROP Font 'DESCENT) (FONTPROP Font 'HEIGHT] (XCellSpacing (TIMES 0.45 InchesToPrinterUnits)) (YCellSpacing (TIMES 0.5 InchesToPrinterUnits))) (printout T Title .I0.8 CharacterSet "Q" T) (RESETLST (RESETSAVE (RADIX (if Hexadecimal then 16 else 8))) (MOVETO (FTIMES 0.75 InchesToPrinterUnits) (FTIMES 10 InchesToPrinterUnits) Stream) (DSPFONT TitleFont Stream) (if Hexadecimal then (printout Stream Title .I0.16 CharacterSet) else (printout Stream Title .I0.8 CharacterSet)) (DSPYPOSITION (PLUS (DSPYPOSITION NIL Stream) (TIMES -0.4 (FONTHEIGHT TitleFont))) Stream) (printout Stream (if Hexadecimal then "16" else "8")) (for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing 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 (MINUS YCellSpacing) as Counter from 0 to 240 by 16 bind (XPosition _ (TIMES 0.25 InchesToPrinterUnits)) do (MOVETO XPosition YPosition Stream) (PRINTNUM (if Hexadecimal then '(FIX 2 16 T) else '(FIX 3 8)) Counter Stream))) (DRAWLINE (TIMES 0.25 InchesToPrinterUnits) (TIMES 9.3 InchesToPrinterUnits) (TIMES 8.0 InchesToPrinterUnits) (TIMES 9.3 InchesToPrinterUnits) (DSPSCALE NIL Stream) 'PAINT Stream) (DRAWLINE (TIMES 0.6 InchesToPrinterUnits) (TIMES 9.7 InchesToPrinterUnits) (TIMES 0.6 InchesToPrinterUnits) (TIMES 1.25 InchesToPrinterUnits) (DSPSCALE NIL Stream) 'PAINT Stream) (CL:UNLESS UseDisplayFontBitmaps (DSPFONT Font Stream)) (for YPosition from (TIMES 9 InchesToPrinterUnits) by (MINUS YCellSpacing) as YCounter from 0 to 15 bind (CharacterCode _ 0) do (for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as XCounter from 0 to 15 do [LET ((CCode (IPLUS (ITIMES CharacterSet 256) CharacterCode))) (MOVETO XPosition YPosition Stream) (if UseDisplayFontBitmaps then (LET* ((Glyph (GETCHARBITMAP CCode Font)) (ImSize (BITMAPIMAGESIZE Glyph NIL Stream)) (ImWidth (CAR ImSize)) (ImHeight (CDR ImSize))) (BITBLT Glyph 0 0 Stream XPosition (FDIFFERENCE YPosition (FTIMES ImHeight RelativeDescent)) ImWidth ImHeight 'INPUT 'REPLACE)) else (if (AND (NEQ CharacterCode (CHARCODE FF)) (if (MEMB (IMAGESTREAMTYPE Stream) '(DISPLAY INTERPRESS)) then (OR (AND (IGREATERP CharacterCode 31) (ILESSP CharacterCode 127)) (AND (IGREATERP CharacterCode 160) (ILESSP CharacterCode 255))) else T)) then (PRINTCCODE CCode Stream] (SETQ CharacterCode (ADD1 CharacterCode))) (printout T ".")) (MOVETO (FTIMES 0.75 InchesToPrinterUnits) (FTIMES 0.75 InchesToPrinterUnits) Stream) (DSPFONT TitleFont Stream) (if Hexadecimal then (printout Stream Title .I0.16 CharacterSet) else (printout Stream Title .I0.8 CharacterSet)) (DSPYPOSITION (PLUS (DSPYPOSITION NIL Stream) (TIMES -0.4 (FONTHEIGHT TitleFont))) Stream) (printout Stream (if Hexadecimal then "16" else "8")) [if (EQ (FILENAMEFIELD (FULLNAME Stream) 'HOST) 'LPT) then (MOVETO (FTIMES 0.75 InchesToPrinterUnits) (FTIMES 0.5 InchesToPrinterUnits) Stream) (printout Stream " on " (L-CASE (OR (FILENAMEFIELD (FULLNAME Stream) 'DEVICE) (FILENAMEFIELD (FULLNAME Stream) '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) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (657 9580 (FontSample 667 . 2302) (FontSampleFaked 2304 . 3113) (FontTable 3115 . 9578)) ))) STOP