diff --git a/lispusers/FONTSAMPLER b/lispusers/FONTSAMPLER index 4841901dd..cc932f12d 100644 --- a/lispusers/FONTSAMPLER +++ b/lispusers/FONTSAMPLER @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 5-Dec-2025 11:09:30" {DSK}matt>Interlisp>medley>lispusers>FONTSAMPLER.;6 12333 +(FILECREATED " 9-Dec-2025 14:00:20" {DSK}matt>Interlisp>medley>lispusers>FONTSAMPLER.;2 14236 :EDIT-BY "mth" - :CHANGES-TO (FNS FontSample FontTable) + :CHANGES-TO (FNS FontTable FontSample) - :PREVIOUS-DATE " 4-Dec-2025 23:56:07" {DSK}matt>Interlisp>medley>lispusers>FONTSAMPLER.;5 + :PREVIOUS-DATE " 8-Dec-2025 22:17:11" {DSK}matt>Interlisp>medley>lispusers>FONTSAMPLER.;1 ) @@ -20,7 +20,8 @@ (DEFINEQ (FontSample - [LAMBDA (Fonts CharacterSets Printer StreamType Hexadecimal) + [LAMBDA (Fonts CharacterSets Printer StreamType Hexadecimal ColumnMajor) + (* ; "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") @@ -30,12 +31,10 @@ [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 - elseif (MEMB CharacterSets '(T :INCORE :ALL :INTERESTING)) - then CharacterSets - else (LIST (OR CharacterSets 0] (AllCharacterSets (CONSTANT (for CS from 0 to 255 collect CS] + (CL:UNLESS [OR (LISTP CharacterSets) + (MEMB CharacterSets '(T :INCORE :ALL :INTERESTING] + (SETQ CharacterSets (LIST (OR CharacterSets 0)))) (DSPRIGHTMARGIN (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL Stream)) Stream) (for Font in FontList do @@ -62,21 +61,35 @@ (* ;;  "Exclude any CharacterSet known to reference the SlugCharsetInfo") - (SETQ FontCharacterSets (for CS in FontCharacterSets - unless (EQ SlugCharsetInfo - (\GETCHARSETINFO Font - CS)) - collect CS)) + (CL:WHEN 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))) - finally (CLOSEF Stream]) + TitleFont InchesToPrinterUnits Hexadecimal + ColumnMajor))) finally (CLOSEF Stream]) (FontSampleFaked - [LAMBDA (FontAsList Printer StreamType) (* N.H.Briggs "27-Apr-87 18:12") + [LAMBDA (FontAsList Printer StreamType ColumnMajor) (* ; "Edited 8-Dec-2025 21:19 by mth") + (* ; "Edited 27-Apr-87 18:12 by N.H.Briggs ") (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer] (Font) [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (LIST TitleFont] @@ -86,11 +99,12 @@ (replace FONTSIZE of Font with (CADR FontAsList)) (replace FONTFACE of Font with (\FONTFACE (CADDR FontAsList))) (FontTable Font '(0) - Stream NIL TitleFont InchesToPrinterUnits) + Stream NIL TitleFont InchesToPrinterUnits NIL ColumnMajor) (CLOSEF Stream]) (FontTable - [LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits Hexadecimal) + [LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits Hexadecimal ColumnMajor) + (* ; "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") @@ -103,14 +117,15 @@ " " (L-CASE Face T) " Character set ")) + (StreamType (IMAGESTREAMTYPE Stream)) [UseDisplayFontBitmaps (AND (EQ (FONTPROP Font 'DEVICE) 'DISPLAY) - (NOT (EQ (IMAGESTREAMTYPE Stream) - 'DISPLAY] + (NOT (EQ StreamType 'DISPLAY] [RelativeDescent (FQUOTIENT (FONTPROP Font 'DESCENT) (FONTPROP Font 'HEIGHT] (XCellSpacing (TIMES 0.45 InchesToPrinterUnits)) - (YCellSpacing (TIMES 0.5 InchesToPrinterUnits))) + (YCellSpacing (TIMES 0.5 InchesToPrinterUnits)) + ColLabelStep RowLabelStep) (printout T Title .I0.8 CharacterSet "Q" T) (RESETLST (RESETSAVE (RADIX (if Hexadecimal @@ -129,15 +144,31 @@ (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 15 bind (YPosition _ (TIMES 9.5 InchesToPrinterUnits)) + from 0 to (ITIMES ColLabelStep 15) by ColLabelStep bind (YPosition _ (TIMES 9.5 + InchesToPrinterUnits + )) do (MOVETO XPosition YPosition Stream) - (PRIN1 Counter 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 240 by 16 bind (XPosition _ (TIMES 0.25 InchesToPrinterUnits)) + 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) @@ -154,33 +185,32 @@ 'PAINT Stream) (CL:UNLESS UseDisplayFontBitmaps (DSPFONT Font Stream)) (for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as XCounter from 0 - to 15 bind (CharacterCode _ 0) - [RangedCodesStreamType _ (MEMB (IMAGESTREAMTYPE Stream) - '(DISPLAY INTERPRESS] + to 15 bind [RangedCodesStreamType _ (MEMB StreamType '(DISPLAY INTERPRESS] do - (for YPosition from (TIMES 9 InchesToPrinterUnits) by (MINUS YCellSpacing) as YCounter + [for YPosition from (TIMES 9 InchesToPrinterUnits) by (MINUS YCellSpacing) as YCounter 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 RangedCodesStreamType - 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))) + 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) @@ -220,6 +250,6 @@ FONT) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (655 12170 (FontSample 665 . 4700) (FontSampleFaked 4702 . 5524) (FontTable 5526 . 12168 + (FILEMAP (NIL (655 14073 (FontSample 665 . 5357) (FontSampleFaked 5359 . 6317) (FontTable 6319 . 14071 ))))) STOP diff --git a/lispusers/FONTSAMPLER.LCOM b/lispusers/FONTSAMPLER.LCOM index d6fe873ea..06eb6cb52 100644 Binary files a/lispusers/FONTSAMPLER.LCOM and b/lispusers/FONTSAMPLER.LCOM differ diff --git a/lispusers/fontsampler.tedit b/lispusers/fontsampler.tedit index 7d4bb12d4..c50b991e7 100644 Binary files a/lispusers/fontsampler.tedit and b/lispusers/fontsampler.tedit differ