diff --git a/lispusers/FONTSAMPLER b/lispusers/FONTSAMPLER index ca7925e9b..4841901dd 100644 --- a/lispusers/FONTSAMPLER +++ b/lispusers/FONTSAMPLER @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 5-Feb-2025 17:03:38" {DSK}matt>Interlisp>medley>lispusers>FONTSAMPLER.;11 9743 +(FILECREATED " 5-Dec-2025 11:09:30" {DSK}matt>Interlisp>medley>lispusers>FONTSAMPLER.;6 12333 :EDIT-BY "mth" :CHANGES-TO (FNS FontSample FontTable) - :PREVIOUS-DATE " 3-Feb-2025 20:08:40" {DSK}matt>Interlisp>medley>lispusers>FONTSAMPLER.;10 + :PREVIOUS-DATE " 4-Dec-2025 23:56:07" {DSK}matt>Interlisp>medley>lispusers>FONTSAMPLER.;5 ) @@ -21,9 +21,10 @@ (FontSample [LAMBDA (Fonts CharacterSets Printer StreamType Hexadecimal) + (* ; "Edited 5-Dec-2025 11:06 by mth") (* ; "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] + (* ; "Edited 29-Apr-87 22:03") + (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (SETQ StreamType (OR StreamType (PRINTERTYPE Printer] (FontList (if (LISTP Fonts) else (CONS Fonts))) [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (CONS TitleFont FontList] @@ -31,20 +32,51 @@ (LastFont (CAR (LAST FontList))) [CharacterSets (if (LISTP CharacterSets) then CharacterSets + elseif (MEMB CharacterSets '(T :INCORE :ALL :INTERESTING)) + then CharacterSets else (LIST (OR CharacterSets 0] - (LastCharacterSet (CAR (LAST CharacterSets] + (AllCharacterSets (CONSTANT (for CS from 0 to 255 collect CS] (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)) + (for Font in FontList do + (* ;; "Check for the special charset list builders") + + (LET (FontCharacterSets (SlugCharsetInfo (\GETCHARSETINFO Font + SLUGCHARSET))) + (SETQ FontCharacterSets + (SELECTQ CharacterSets + (:ALL + (* ;; "Forcibly install ALL CharacterSets.") + + (for CS in AllCharacterSets + when (\INSURECHARSETINFO Font CS) collect + CS)) + (:INTERESTING (for CS in *INTERESTING-CHARSETS* + when (\INSURECHARSETINFO Font CS) + collect CS)) + ((T :INCORE) + (for CS in AllCharacterSets + when (\GETCHARSETINFO Font CS) collect CS)) + CharacterSets)) + + (* ;; + "Exclude any CharacterSet known to reference the SlugCharsetInfo") + + (SETQ FontCharacterSets (for CS in FontCharacterSets + unless (EQ SlugCharsetInfo + (\GETCHARSETINFO Font + CS)) + collect CS)) + (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]) (FontSampleFaked - [LAMBDA (FontAsList Printer StreamType) (* N.H.Briggs "27-Apr-87 18:12") + [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] @@ -53,14 +85,16 @@ (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) + (FontTable Font '(0) + Stream NIL TitleFont InchesToPrinterUnits) (CLOSEF Stream]) (FontTable [LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits Hexadecimal) + (* ; "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") + (* ; "Edited 29-Apr-87 22:36") (LET* ((Family (FONTPROP Font 'FAMILY)) (Face (FONTPROP Font 'FACE)) @@ -119,10 +153,12 @@ (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) + (for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as XCounter from 0 + to 15 bind (CharacterCode _ 0) + [RangedCodesStreamType _ (MEMB (IMAGESTREAMTYPE Stream) + '(DISPLAY INTERPRESS] do - (for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as XCounter + (for YPosition from (TIMES 9 InchesToPrinterUnits) by (MINUS YCellSpacing) as YCounter from 0 to 15 do [LET ((CCode (IPLUS (ITIMES CharacterSet 256) CharacterCode))) @@ -137,8 +173,7 @@ RelativeDescent)) ImWidth ImHeight 'INPUT 'REPLACE)) else (if (AND (NEQ CharacterCode (CHARCODE FF)) - (if (MEMB (IMAGESTREAMTYPE Stream) - '(DISPLAY INTERPRESS)) + (if RangedCodesStreamType then (OR (AND (IGREATERP CharacterCode 31) (ILESSP CharacterCode 127)) (AND (IGREATERP CharacterCode 160) @@ -185,6 +220,6 @@ FONT) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (657 9580 (FontSample 667 . 2302) (FontSampleFaked 2304 . 3113) (FontTable 3115 . 9578)) -))) + (FILEMAP (NIL (655 12170 (FontSample 665 . 4700) (FontSampleFaked 4702 . 5524) (FontTable 5526 . 12168 +))))) STOP diff --git a/lispusers/FONTSAMPLER.LCOM b/lispusers/FONTSAMPLER.LCOM index 3f4909fdb..d6fe873ea 100644 Binary files a/lispusers/FONTSAMPLER.LCOM and b/lispusers/FONTSAMPLER.LCOM differ diff --git a/lispusers/fontsampler.tedit b/lispusers/fontsampler.tedit index d23d0de04..7d4bb12d4 100644 Binary files a/lispusers/fontsampler.tedit and b/lispusers/fontsampler.tedit differ