(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) (FILECREATED " 7-Aug-2026 11:16:03" {MEDLEY}FONTSAMPLER.;26 14193 :EDIT-BY rmk :CHANGES-TO (FNS FontSample) :PREVIOUS-DATE " 6-Aug-2026 23:36:07" {MEDLEY}FONTSAMPLER.;25) (PRETTYCOMPRINT FONTSAMPLERCOMS) (RPAQQ FONTSAMPLERCOMS [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES EXPORTS.ALL)) (FNS FontSample FontSampleFaked FontTable) (VARS (*INTERESTING-CHARSETS* '(LATIN JAPANESE-SYMBOLS1 JAPANESE-SYMBOLS2 Greek Cyrillic SYMBOLS2 SYMBOLS1 LIGATURES ACCENTED-LATIN1]) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD EXPORTS.ALL) ) (DEFINEQ (FontSample [LAMBDA (Fonts CharacterSets ImageFile ImageType Hexadecimal ColumnMajor NoSlugOnlyCS) (* ; "Edited 7-Aug-2026 11:15 by rmk") (* ; "Edited 4-Aug-2026 15:37 by rmk") (* ; "Edited 26-Dec-2025 16:25 by mth") (* ; "Edited 9-Dec-2025 13:48 by mth") (* ; "Edited 5-Dec-2025 11:06 by mth") (* ; "Edited 5-Feb-2025 17:02 by mth") (* ; "Edited 29-Apr-87 22:03") (CL:UNLESS (MEMB CharacterSets '(T :INCORE :ALL :INTERESTING)) (SETQ CharacterSets (MKLIST (OR (CHARSET.DECODE CharacterSets) 0)))) (LET* [(Stream (OPENIMAGESTREAM ImageFile ImageType)) (TitleFont (FONTCREATE NIL 12 'MRR 0 Stream)) (FontList (for F in (CL:IF (OR (type? FONTSPEC Fonts) (type? FONTDESCRIPTOR Fonts)) (CONS Fonts) Fonts) collect (FONTCREATE F))) (InchesToPrinterUnits (FTIMES PTSPERINCH (DSPSCALE NIL Stream))) (LastFont (CAR (LAST FontList] (DSPRIGHTMARGIN (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL Stream)) Stream) (for Font FontCharacterSets SlugCharsetInfo in FontList do (* ;; "Check for the special charset list builders") (SETQ FontCharacterSets (SELECTQ CharacterSets (:ALL (* ;; "Forcibly install ALL CharacterSets.") (for CS from 0 to \MAXCHARSET when (\INSURECHARSETINFO Font CS) collect CS)) (:INTERESTING (for CS in (CHARSET.DECODE *INTERESTING-CHARSETS*) when (\INSURECHARSETINFO Font CS) collect CS)) ((T :INCORE) (for CS from 0 to \MAXCHARSET when (\GETCHARSETINFO Font CS) collect CS)) CharacterSets)) (SETQ SlugCharsetInfo (SLUGCSINFO Font)) (* ;;  "If requested to do so, exclude any CharacterSet known to reference the SlugCharsetInfo") (CL:WHEN (AND NoSlugOnlyCS SlugCharsetInfo) (* ;;  "Only if SlugCharsetInfo is non-NIL, else it won't load a requested charset") (SETQ FontCharacterSets (for CS in FontCharacterSets unless (EQ SlugCharsetInfo (\GETCHARSETINFO Font CS)) collect CS))) (* ;; "Probably ought to report charsets eliminated by the above.") (* ;; " At least report if NO charsets remain for this font.") (CL:UNLESS FontCharacterSets (printout T "All requested character sets are empty for this font: " Font T)) (for CharacterSet in FontCharacterSets bind (LastCharacterSet _ (CAR (LAST FontCharacterSets ))) do (FontTable Font CharacterSet Stream (OR (NEQ Font LastFont) (NEQ CharacterSet LastCharacterSet)) TitleFont InchesToPrinterUnits Hexadecimal ColumnMajor))) (CLOSEF Stream]) (FontSampleFaked [LAMBDA (Family Size Face ImageFile ImageType ColumnMajor) (* ; "Edited 5-Aug-2026 09:21 by rmk") (* ; "Edited 8-Dec-2025 21:19 by mth") (* ; "Edited 27-Apr-87 18:12 by N.H.Briggs ") (LET ((Stream (OPENIMAGESTREAM ImageFile ImageType))) (FontTable (create FONTDESCRIPTOR using (DEFAULTFONT Stream) FONTFAMILY _ Family FONTSIZE _ Size FONTFACE _ (\FONTFACE Face)) 0 Stream NIL (FONTCREATE NIL 12 'MRR 0 Stream) (FTIMES PTSPERINCH (DSPSCALE NIL Stream)) NIL ColumnMajor) (CLOSEF Stream]) (FontTable [LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits Hexadecimal ColumnMajor) (* ; "Edited 5-Aug-2026 11:20 by rmk") (* ; "Edited 9-Dec-2025 13:23 by mth") (* ; "Edited 5-Dec-2025 11:09 by mth") (* ; "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 ")) (ImageType (IMAGESTREAMTYPE Stream)) (UseDisplayFontBitmaps (AND (EQ 'DISPLAY (FONTPROP Font 'DEVICE)) (NEQ 'DISPLAY ImageType))) [RelativeDescent (FQUOTIENT (FONTPROP Font 'DESCENT) (FONTPROP Font 'HEIGHT] (XCellSpacing (TIMES 0.45 InchesToPrinterUnits)) (YCellSpacing (TIMES 0.5 InchesToPrinterUnits)) ColLabelStep RowLabelStep) (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)) (RELMOVETO 0 (TIMES -0.4 (FONTHEIGHT TitleFont)) Stream) (printout Stream (if Hexadecimal then "16" else "8")) (if ColumnMajor then (SETQ ColLabelStep 16) (SETQ RowLabelStep 1) else (SETQ ColLabelStep 1) (SETQ RowLabelStep 16)) (for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as Counter from 0 to (ITIMES ColLabelStep 15) by ColLabelStep bind (YPosition _ (TIMES 9.5 InchesToPrinterUnits )) do (MOVETO XPosition YPosition Stream) (PRINTNUM (if Hexadecimal then '(FIX 2 16 T) elseif ColumnMajor then '(FIX 1 8 NIL T) else '(FIX 2 8)) Counter Stream)) (for YPosition from (TIMES 9 InchesToPrinterUnits) by (MINUS YCellSpacing) as Counter from 0 to (ITIMES RowLabelStep 15) by RowLabelStep bind (XPosition _ (TIMES 0.25 InchesToPrinterUnits )) do (MOVETO XPosition YPosition Stream) (PRINTNUM (if Hexadecimal then '(FIX 2 16 T) elseif ColumnMajor then '(FIX 2 8) 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 XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as XCounter from 0 to 15 bind [RangedCodesStreamType _ (MEMB ImageType '(DISPLAY INTERPRESS] do [for YPosition from (TIMES 9 InchesToPrinterUnits) by (MINUS YCellSpacing) as YCounter from 0 to 15 do (LET* ((CharacterCode (IPLUS (ITIMES YCounter RowLabelStep) (ITIMES XCounter ColLabelStep))) (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 RangedCodesStreamType then (OR (AND (IGREATERP CharacterCode 31) (ILESSP CharacterCode 127)) (AND (IGREATERP CharacterCode 160) (ILESSP CharacterCode 255))) else T)) then (PRINTCCODE CCode Stream] (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* (LATIN JAPANESE-SYMBOLS1 JAPANESE-SYMBOLS2 Greek Cyrillic SYMBOLS2 SYMBOLS1 LIGATURES ACCENTED-LATIN1)) (DECLARE%: DONTCOPY (FILEMAP (NIL (826 13993 (FontSample 836 . 5402) (FontSampleFaked 5404 . 6234) (FontTable 6236 . 13991 ))))) STOP