github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-12 00:42:56 +00:00
Code Issues Projects Releases Wiki Activity

FontSampler sample sheet display in column major order. (#2406)

Browse Source 
FontSampler sample sheet display in column major order.
Added alternative CharacterSets designations.
Updated documentation.

Resolves #2273
This commit is contained in:
Matt Heffron 2025-12-08 11:51:51 -08:00 committed by GitHub
commit 4e510f89db
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
3 changed files with 56 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
lispusers/FONTSAMPLER
View File

@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 5-Feb-2025 17:03:38" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;11 9743 (FILECREATED " 5-Dec-2025 11:09:30" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;6 12333
:EDIT-BY "mth" :EDIT-BY "mth"
:CHANGES-TO (FNS FontSample FontTable) :CHANGES-TO (FNS FontSample FontTable)
:PREVIOUS-DATE " 3-Feb-2025 20:08:40" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;10 :PREVIOUS-DATE " 4-Dec-2025 23:56:07" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;5
) )
@ -21,9 +21,10 @@
(FontSample (FontSample
[LAMBDA (Fonts CharacterSets Printer StreamType Hexadecimal) [LAMBDA (Fonts CharacterSets Printer StreamType Hexadecimal)
(* ; "Edited 5-Dec-2025 11:06 by mth")
(* ; "Edited 5-Feb-2025 17:02 by mth") (* ; "Edited 5-Feb-2025 17:02 by mth")
(* edited%: "29-Apr-87 22:03") (* ; "Edited 29-Apr-87 22:03")
(LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer] (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (SETQ StreamType (OR StreamType (PRINTERTYPE Printer]
(FontList (if (LISTP Fonts) (FontList (if (LISTP Fonts)
else (CONS Fonts))) else (CONS Fonts)))
[Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (CONS TitleFont FontList] [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (CONS TitleFont FontList]
@ -31,20 +32,51 @@
(LastFont (CAR (LAST FontList))) (LastFont (CAR (LAST FontList)))
[CharacterSets (if (LISTP CharacterSets) [CharacterSets (if (LISTP CharacterSets)
then CharacterSets then CharacterSets
elseif (MEMB CharacterSets '(T :INCORE :ALL :INTERESTING))
then CharacterSets
else (LIST (OR CharacterSets 0] 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)) (DSPRIGHTMARGIN (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL Stream))
Stream) Stream)
(for Font in FontList do (for CharacterSet in CharacterSets (for Font in FontList do
do (FontTable Font CharacterSet Stream (OR (NEQ Font LastFont) (* ;; "Check for the special charset list builders")
(NEQ CharacterSet
LastCharacterSet (LET (FontCharacterSets (SlugCharsetInfo (\GETCHARSETINFO Font
)) SLUGCHARSET)))
TitleFont InchesToPrinterUnits Hexadecimal)) (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]) finally (CLOSEF Stream])
(FontSampleFaked (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] (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer]
(Font) (Font)
[Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (LIST TitleFont] [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (LIST TitleFont]
@ -53,14 +85,16 @@
(replace FONTFAMILY of Font with (CAR FontAsList)) (replace FONTFAMILY of Font with (CAR FontAsList))
(replace FONTSIZE of Font with (CADR FontAsList)) (replace FONTSIZE of Font with (CADR FontAsList))
(replace FONTFACE of Font with (\FONTFACE (CADDR 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]) (CLOSEF Stream])
(FontTable (FontTable
[LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits Hexadecimal) [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 5-Feb-2025 17:03 by mth")
(* ; "Edited 3-Feb-2025 20:07 by mth") (* ; "Edited 3-Feb-2025 20:07 by mth")
(* edited%: "29-Apr-87 22:36") (* ; "Edited 29-Apr-87 22:36")
(LET* (LET*
((Family (FONTPROP Font 'FAMILY)) ((Family (FONTPROP Font 'FAMILY))
(Face (FONTPROP Font 'FACE)) (Face (FONTPROP Font 'FACE))
@ -119,10 +153,12 @@
(DSPSCALE NIL Stream) (DSPSCALE NIL Stream)
'PAINT Stream) 'PAINT Stream)
(CL:UNLESS UseDisplayFontBitmaps (DSPFONT Font Stream)) (CL:UNLESS UseDisplayFontBitmaps (DSPFONT Font Stream))
(for YPosition from (TIMES 9 InchesToPrinterUnits) by (MINUS YCellSpacing) as YCounter (for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as XCounter from 0
from 0 to 15 bind (CharacterCode _ 0) to 15 bind (CharacterCode _ 0)
[RangedCodesStreamType _ (MEMB (IMAGESTREAMTYPE Stream)
'(DISPLAY INTERPRESS]
do 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 from 0 to 15
do [LET ((CCode (IPLUS (ITIMES CharacterSet 256) do [LET ((CCode (IPLUS (ITIMES CharacterSet 256)
CharacterCode))) CharacterCode)))
@ -137,8 +173,7 @@
RelativeDescent)) RelativeDescent))
ImWidth ImHeight 'INPUT 'REPLACE)) ImWidth ImHeight 'INPUT 'REPLACE))
else (if (AND (NEQ CharacterCode (CHARCODE FF)) else (if (AND (NEQ CharacterCode (CHARCODE FF))
(if (MEMB (IMAGESTREAMTYPE Stream) (if RangedCodesStreamType
'(DISPLAY INTERPRESS))
then (OR (AND (IGREATERP CharacterCode 31) then (OR (AND (IGREATERP CharacterCode 31)
(ILESSP CharacterCode 127)) (ILESSP CharacterCode 127))
(AND (IGREATERP CharacterCode 160) (AND (IGREATERP CharacterCode 160)
@ -185,6 +220,6 @@
FONT) FONT)
) )
(DECLARE%: DONTCOPY (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 STOP

BIN
lispusers/FONTSAMPLER.LCOM
View File

Binary file not shown.

BIN
lispusers/fontsampler.tedit
View File

Binary file not shown.