Display in column major order.
Added alternative CharacterSets designations. Updated documentation.
This commit is contained in:
Matt Heffron
parent
e43fb61bee
commit
87e8f2dc21
@ -1,12 +1,12 @@
|
||||
(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"
|
||||
|
||||
: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
|
||||
[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
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user