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

Yet another attempt to make a clean PR (compared with broken PRs #2007 & #2008 & #2013)

Browse Source
This commit is contained in:
Matt Heffron
2025-02-04 17:22:54 -08:00
parent 1f317d34ef
commit 87d3abc632
2 changed files with 36 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files

70
lispusers/FONTSAMPLER
View File

@@ -1,19 +1,15 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Feb-2025 22:56:24" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;2 8799
(FILECREATED " 3-Feb-2025 20:08:40" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;10 8777
:EDIT-BY "mth"
:CHANGES-TO (FNS FontTable)
:PREVIOUS-DATE "29-Apr-87 22:43:49" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;1
:PREVIOUS-DATE " 3-Feb-2025 13:06:38" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;7
)
(* ; "
Copyright (c) 1985, 1987, 2025 by Xerox Corporation.
")
(PRETTYCOMPRINT FONTSAMPLERCOMS)
(RPAQQ FONTSAMPLERCOMS
@@ -24,7 +20,7 @@ Copyright (c) 1985, 1987, 2025 by Xerox Corporation.
(DEFINEQ
(FontSample
[LAMBDA (Fonts CharacterSets Printer StreamType) (* edited%: "29-Apr-87 22:03")
[LAMBDA (Fonts CharacterSets Printer StreamType) (* edited%: "29-Apr-87 22:03")
(LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer]
(FontList (if (LISTP Fonts)
else (CONS Fonts)))
@@ -60,10 +56,10 @@ Copyright (c) 1985, 1987, 2025 by Xerox Corporation.
(FontTable
[LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits)
(* ; "Edited 2-Feb-2025 22:50 by mth")
(* ; "Edited 3-Feb-2025 20:07 by mth")
(* edited%: "29-Apr-87 22:36")
(LET*
[(Family (FONTPROP Font 'FAMILY))
((Family (FONTPROP Font 'FAMILY))
(Face (FONTPROP Font 'FACE))
(Size (FONTPROP Font 'SIZE))
(Title (CONCAT " " Size "pt " (L-CASE Family T)
@@ -74,25 +70,34 @@ Copyright (c) 1985, 1987, 2025 by Xerox Corporation.
'DISPLAY)
(NOT (EQ (IMAGESTREAMTYPE Stream)
'DISPLAY]
(CharSetInfo (\GETCHARSETINFO CharacterSet Font T))
(CharSetAscent (fetch (CHARSETINFO CHARSETASCENT) of CharSetInfo))
(CharSetDescent (fetch (CHARSETINFO CHARSETDESCENT) of CharSetInfo))
(CharSetRelativeDescent (FQUOTIENT CharSetDescent (IPLUS CharSetAscent CharSetDescent]
[RelativeDescent (FQUOTIENT (FONTPROP Font 'DESCENT)
(FONTPROP Font 'HEIGHT]
(XCellSpacing (TIMES 0.45 InchesToPrinterUnits))
(YCellSpacing (TIMES 0.5 InchesToPrinterUnits)))
(printout T Title .I0.8 CharacterSet "Q" T)
(RESETLST
(RESETSAVE (RADIX 8))
(for XPosition from (TIMES 0.65 InchesToPrinterUnits) by (TIMES 0.45 InchesToPrinterUnits)
as Counter from 0 to 15 bind (YPosition _ (TIMES 9.5 InchesToPrinterUnits))
(MOVETO (FTIMES 0.75 InchesToPrinterUnits)
(FTIMES 10 InchesToPrinterUnits)
Stream)
(DSPFONT TitleFont Stream)
(printout Stream Title .I0.8 CharacterSet)
(DSPYPOSITION (PLUS (DSPYPOSITION NIL Stream)
(TIMES -0.4 (FONTHEIGHT TitleFont)))
Stream)
(printout Stream "8")
(for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as Counter
from 0 to 15 bind (YPosition _ (TIMES 9.5 InchesToPrinterUnits))
do (MOVETO XPosition YPosition Stream)
(PRIN1 Counter Stream))
(for YPosition from (TIMES 9 InchesToPrinterUnits) by (TIMES -0.5 InchesToPrinterUnits)
as Counter from 0 to 240 by 16 bind (XPosition _ (TIMES 0.25 InchesToPrinterUnits))
(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)
(PRIN1 Counter Stream)))
(DRAWLINE (TIMES 0.25 InchesToPrinterUnits)
(TIMES 9.25 InchesToPrinterUnits)
(TIMES 9.3 InchesToPrinterUnits)
(TIMES 8.0 InchesToPrinterUnits)
(TIMES 9.25 InchesToPrinterUnits)
(TIMES 9.3 InchesToPrinterUnits)
(DSPSCALE NIL Stream)
'PAINT Stream)
(DRAWLINE (TIMES 0.6 InchesToPrinterUnits)
@@ -102,25 +107,23 @@ Copyright (c) 1985, 1987, 2025 by Xerox Corporation.
(DSPSCALE NIL Stream)
'PAINT Stream)
(CL:UNLESS UseDisplayFontBitmaps (DSPFONT Font Stream))
(for YPosition from (TIMES 9 InchesToPrinterUnits) by (TIMES -0.5 InchesToPrinterUnits)
as YCounter from 0 to 15 bind (CharacterCode _ 0)
(for YPosition from (TIMES 9 InchesToPrinterUnits) by (MINUS YCellSpacing) as YCounter
from 0 to 15 bind (CharacterCode _ 0)
do
(for XPosition from (TIMES 0.75 InchesToPrinterUnits) by (TIMES 0.45 InchesToPrinterUnits)
as XCounter from 0 to 15
(for XPosition from (TIMES 0.75 InchesToPrinterUnits) by XCellSpacing as XCounter
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)))
(BITBLT Glyph 0 0 Stream XPosition (- YPosition (TIMES (CDR ImSize)
CharSetRelativeDescent
))
(CAR ImSize)
(CDR ImSize)
'INPUT
'REPLACE))
(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 (MEMB (IMAGESTREAMTYPE Stream)
'(DISPLAY INTERPRESS))
@@ -165,8 +168,7 @@ Copyright (c) 1985, 1987, 2025 by Xerox Corporation.
(FILESLOAD (LOADCOMP)
FONT)
)
(PUTPROPS FONTSAMPLER COPYRIGHT ("Xerox Corporation" 1985 1987 2025))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (706 8566 (FontSample 716 . 2171) (FontSampleFaked 2173 . 2982) (FontTable 2984 . 8564))
(FILEMAP (NIL (645 8614 (FontSample 655 . 2106) (FontSampleFaked 2108 . 2917) (FontTable 2919 . 8612))
)))
STOP

BIN
lispusers/FONTSAMPLER.LCOM
View File

Binary file not shown.