Skip to content

FONTSAMPLER labelling fixed - ColumnMajor selectable #2411

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
MattHeffron wants to merge 3 commits into
base: master
Choose a base branch
from
Open

FONTSAMPLER labelling fixed - ColumnMajor selectable #2411

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
4706af1
Make the layout orientation, ColumnMajor or not, be selectable.
MattHeffron Dec 9, 2025
fd7f50c
Merge branch 'master' into mth57--FONTSAMPLER_fix_labels_ColumnMajor_…
MattHeffron Dec 9, 2025
32c52cd
Fixed unloaded charset didn't display.
MattHeffron Dec 9, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
132 changes: 81 additions & 51 deletions lispusers/FONTSAMPLER
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED " 5-Dec-2025 11:09:30" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;6 12333
(FILECREATED " 9-Dec-2025 14:00:20" {DSK}<home>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}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;5
:PREVIOUS-DATE " 8-Dec-2025 22:17:11" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;1
)


Expand All @@ -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")
Expand All @@ -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
Expand All @@ -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]
Expand All @@ -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")
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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)
Expand Down Expand Up @@ -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
Binary file modified lispusers/FONTSAMPLER.LCOM
View file
Open in desktop
Binary file not shown.
Binary file modified lispusers/fontsampler.tedit
View file
Open in desktop
Binary file not shown.