github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-13 15:37:38 +00:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into rmk126--HARDCOPY-to-printers

Browse Source
This commit is contained in:
rmkaplan 2025-12-30 08:45:26 -08:00
commit 2e0193f646
6 changed files with 642 additions and 568 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
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-Dec-2025 11:09:30" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;6 12333 (FILECREATED "26-Dec-2025 16:37:05" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;4 14367
:EDIT-BY "mth" :EDIT-BY "mth"
:CHANGES-TO (FNS FontSample FontTable) :CHANGES-TO (FNS FontSample)
:PREVIOUS-DATE " 4-Dec-2025 23:56:07" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;5 :PREVIOUS-DATE " 9-Dec-2025 14:00:20" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;3
) )
@ -20,7 +20,9 @@
(DEFINEQ (DEFINEQ
(FontSample (FontSample
[LAMBDA (Fonts CharacterSets Printer StreamType Hexadecimal) [LAMBDA (Fonts CharacterSets Printer StreamType Hexadecimal ColumnMajor NoSlugOnlyCS)
(* ; "Edited 26-Dec-2025 16:25 by mth")
(* ; "Edited 9-Dec-2025 13:48 by mth")
(* ; "Edited 5-Dec-2025 11:06 by mth") (* ; "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")
@ -30,12 +32,10 @@
[Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (CONS TitleFont FontList] [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (CONS TitleFont FontList]
(InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream))) (InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream)))
(LastFont (CAR (LAST FontList))) (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] (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)) (DSPRIGHTMARGIN (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL Stream))
Stream) Stream)
(for Font in FontList do (for Font in FontList do
@ -60,23 +60,37 @@
CharacterSets)) CharacterSets))
(* ;; (* ;;
 "Exclude any CharacterSet known to reference the SlugCharsetInfo")  "If requested to do so, exclude any CharacterSet known to reference the SlugCharsetInfo")
(SETQ FontCharacterSets (for CS in FontCharacterSets (CL:WHEN (AND NoSlugOnlyCS SlugCharsetInfo)
unless (EQ SlugCharsetInfo
(\GETCHARSETINFO Font (* ;;
CS))  "Only if SlugCharsetInfo is non-NIL, else it won't load a requested charset")
collect CS))
(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 (for CharacterSet in FontCharacterSets
bind (LastCharacterSet _ (CAR (LAST FontCharacterSets))) bind (LastCharacterSet _ (CAR (LAST FontCharacterSets)))
do (FontTable Font CharacterSet Stream do (FontTable Font CharacterSet Stream
(OR (NEQ Font LastFont) (OR (NEQ Font LastFont)
(NEQ CharacterSet LastCharacterSet)) (NEQ CharacterSet LastCharacterSet))
TitleFont InchesToPrinterUnits Hexadecimal))) TitleFont InchesToPrinterUnits Hexadecimal
finally (CLOSEF Stream]) ColumnMajor))) finally (CLOSEF Stream])
(FontSampleFaked (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] (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]
@ -86,11 +100,12 @@
(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) (FontTable Font '(0)
Stream NIL TitleFont InchesToPrinterUnits) Stream NIL TitleFont InchesToPrinterUnits NIL ColumnMajor)
(CLOSEF Stream]) (CLOSEF Stream])
(FontTable (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-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")
@ -103,14 +118,15 @@
" " " "
(L-CASE Face T) (L-CASE Face T)
" Character set ")) " Character set "))
(StreamType (IMAGESTREAMTYPE Stream))
[UseDisplayFontBitmaps (AND (EQ (FONTPROP Font 'DEVICE) [UseDisplayFontBitmaps (AND (EQ (FONTPROP Font 'DEVICE)
'DISPLAY) 'DISPLAY)
(NOT (EQ (IMAGESTREAMTYPE Stream) (NOT (EQ StreamType 'DISPLAY]
'DISPLAY]
[RelativeDescent (FQUOTIENT (FONTPROP Font 'DESCENT) [RelativeDescent (FQUOTIENT (FONTPROP Font 'DESCENT)
(FONTPROP Font 'HEIGHT] (FONTPROP Font 'HEIGHT]
(XCellSpacing (TIMES 0.45 InchesToPrinterUnits)) (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) (printout T Title .I0.8 CharacterSet "Q" T)
(RESETLST (RESETLST
(RESETSAVE (RADIX (if Hexadecimal (RESETSAVE (RADIX (if Hexadecimal
@ -129,15 +145,31 @@
(printout Stream (if Hexadecimal (printout Stream (if Hexadecimal
then "16" then "16"
else "8")) 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 (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
do (MOVETO XPosition YPosition Stream) InchesToPrinterUnits
(PRIN1 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))
do (MOVETO XPosition YPosition Stream) do (MOVETO XPosition YPosition Stream)
(PRINTNUM (if Hexadecimal (PRINTNUM (if Hexadecimal
then '(FIX 2 16 T) 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 (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)) else '(FIX 3 8))
Counter Stream))) Counter Stream)))
(DRAWLINE (TIMES 0.25 InchesToPrinterUnits) (DRAWLINE (TIMES 0.25 InchesToPrinterUnits)
@ -154,13 +186,13 @@
'PAINT Stream) 'PAINT Stream)
(CL:UNLESS UseDisplayFontBitmaps (DSPFONT Font Stream)) (CL:UNLESS UseDisplayFontBitmaps (DSPFONT Font Stream))
(for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as XCounter from 0 (for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as XCounter from 0
to 15 bind (CharacterCode _ 0) to 15 bind [RangedCodesStreamType _ (MEMB StreamType '(DISPLAY INTERPRESS]
[RangedCodesStreamType _ (MEMB (IMAGESTREAMTYPE Stream)
'(DISPLAY INTERPRESS]
do 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 from 0 to 15
do [LET ((CCode (IPLUS (ITIMES CharacterSet 256) do (LET* ((CharacterCode (IPLUS (ITIMES YCounter RowLabelStep)
(ITIMES XCounter ColLabelStep)))
(CCode (IPLUS (ITIMES CharacterSet 256)
CharacterCode))) CharacterCode)))
(MOVETO XPosition YPosition Stream) (MOVETO XPosition YPosition Stream)
(if UseDisplayFontBitmaps (if UseDisplayFontBitmaps
@ -180,7 +212,6 @@
(ILESSP CharacterCode 255))) (ILESSP CharacterCode 255)))
else T)) else T))
then (PRINTCCODE CCode Stream] then (PRINTCCODE CCode Stream]
(SETQ CharacterCode (ADD1 CharacterCode)))
(printout T ".")) (printout T "."))
(MOVETO (FTIMES 0.75 InchesToPrinterUnits) (MOVETO (FTIMES 0.75 InchesToPrinterUnits)
(FTIMES 0.75 InchesToPrinterUnits) (FTIMES 0.75 InchesToPrinterUnits)
@ -220,6 +251,6 @@
FONT) FONT)
) )
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (655 12170 (FontSample 665 . 4700) (FontSampleFaked 4702 . 5524) (FontTable 5526 . 12168 (FILEMAP (NIL (645 14204 (FontSample 655 . 5488) (FontSampleFaked 5490 . 6448) (FontTable 6450 . 14202
))))) )))))
STOP STOP

BIN
lispusers/FONTSAMPLER.LCOM
View File

Binary file not shown.

861
lispusers/READ-BDF
View File

File diff suppressed because it is too large Load Diff

BIN
lispusers/READ-BDF.DFASL
View File

Binary file not shown.

BIN
lispusers/READ-BDF.TEDIT
View File

Binary file not shown.

BIN
lispusers/fontsampler.tedit
View File

Binary file not shown.