FONTSAMPLER display glyphs from bitmap font to PDF

lispusers/EDITFONT

@@ -1,18 +1,13 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
 
-
(FILECREATED "12-Jul-2022 14:18:56" 
-{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>EDITFONT.;10
 28741  
+
(FILECREATED " 1-Feb-2025 12:28:41" {DSK}<home>matt>Interlisp>medley>lispusers>EDITFONT.;2
 28339  
 
-      :CHANGES-TO (FNS READSTRIKEFONTFILE)
-                  (VARS EDITFONTCOMS)
+      :EDIT-BY "mth"
 
-      :PREVIOUS-DATE "27-Jun-2022 10:59:12" 
-{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>EDITFONT.;5)
+      :CHANGES-TO (VARS EDITFONTCOMS)
 
+      :PREVIOUS-DATE "12-Jul-2022 14:18:56" {DSK}<home>matt>Interlisp>medley>lispusers>EDITFONT.;1)
 
-(* ; "
-Copyright (c) 1985-1986 by Xerox Corporation.
-")
 
 (PRETTYCOMPRINT EDITFONTCOMS)
 
@@ -26,9 +21,7 @@ Copyright (c) 1985-1986 by Xerox Corporation.
              COPYFONT READSTRIKEFONTFILE)
         (FNS BLANKFONTCREATE EDITFONT)
         (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (BITSPERWORD 16)
-                                                (BYTESPERWORD 2)
-                                                (MAXCODE 255)
-                                                (DUMMYINDEX 256))
+                                                (BYTESPERWORD 2))
                (FILES (LOADCOMP)
                       FONT))
         (P (EF.INIT))))
@@ -527,15 +520,9 @@ Copyright (c) 1985-1986 by Xerox Corporation.
 
 (RPAQQ BYTESPERWORD
 2)
 
-(RPAQQ MAXCODE
 255)
-
-(RPAQQ DUMMYINDEX
 256)
-
 
 (CONSTANTS (BITSPERWORD 16)
-       (BYTESPERWORD 2)
-       (MAXCODE 255)
-       (DUMMYINDEX 256))
+       (BYTESPERWORD 2))
 )
 
 
@@ -544,12 +531,11 @@ Copyright (c) 1985-1986 by Xerox Corporation.
 )
 
 (EF.INIT
)
-(PUTPROPS EDITFONT COPYRIGHT ("Xerox Corporation" 1985 1986))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1567 26117 (EF.INIT 1577 . 2303) (EF.PROMPT 2305 . 2887) (EF.MESSAGE 2889 . 3101) (
-EF.CLOSEFN 3103 . 3630) (EF.CHARITEMS 3632 . 5853) (EF.BUTTONEVENTFN 5855 . 6267) (EF.WHENSELECTEDFN 
-6269 . 6673) (EF.EDITBM 6675 . 8073) (EF.MIDDLEBUTTONFN 8075 . 8320) (EF.CHANGESIZE 8322 . 9541) (
-EF.DELETE 9543 . 10308) (EF.ENTER 10310 . 11141) (EF.REPLACE 11143 . 12006) (EF.SAVE 12008 . 16681) (
-EF.BLANK 16683 . 22308) (COPYFONT 22310 . 24750) (READSTRIKEFONTFILE 24752 . 26115)) (26118 28332 (
-BLANKFONTCREATE 26128 . 26385) (EDITFONT 26387 . 28330)))))
+  (FILEMAP (NIL (1325 25875 (EF.INIT 1335 . 2061) (EF.PROMPT 2063 . 2645) (EF.MESSAGE 2647 . 2859) (
+EF.CLOSEFN 2861 . 3388) (EF.CHARITEMS 3390 . 5611) (EF.BUTTONEVENTFN 5613 . 6025) (EF.WHENSELECTEDFN 
+6027 . 6431) (EF.EDITBM 6433 . 7831) (EF.MIDDLEBUTTONFN 7833 . 8078) (EF.CHANGESIZE 8080 . 9299) (
+EF.DELETE 9301 . 10066) (EF.ENTER 10068 . 10899) (EF.REPLACE 10901 . 11764) (EF.SAVE 11766 . 16439) (
+EF.BLANK 16441 . 22066) (COPYFONT 22068 . 24508) (READSTRIKEFONTFILE 24510 . 25873)) (25876 28090 (
+BLANKFONTCREATE 25886 . 26143) (EDITFONT 26145 . 28088)))))
 STOP

lispusers/FONTSAMPLER

@@ -1,21 +1,26 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-
(FILECREATED "29-Apr-87 22:43:49" {ERIS}<LISPUSERS>LYRIC>FONTSAMPLER.;4
 7992   
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
 
-      changes to%:  (FNS FontSample)
+
(FILECREATED " 2-Feb-2025 22:56:24" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;2
 8799   
 
-      previous date%: "29-Apr-87 22:41:24" {ERIS}<LISPUSERS>KOTO>FONTSAMPLER.;6)
+      :EDIT-BY "mth"
 
+      :CHANGES-TO (FNS FontTable)
 
-(* "
-Copyright (c) 1985, 1987 by Xerox Corporation.  All rights reserved.
+      :PREVIOUS-DATE "29-Apr-87 22:43:49" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;1
+)
+
+
+(* ; "
+Copyright (c) 1985, 1987, 2025 by Xerox Corporation.
 ")
 
 (PRETTYCOMPRINT FONTSAMPLERCOMS)
 
-(RPAQQ FONTSAMPLERCOMS
 ((FNS FontSample FontSampleFaked FontTable)
-                        [VARS (*INTERESTING-CHARSETS* '(0 33 34 38 39 238 239 240 241]
-                        (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
-                                                                FONT))))
+(RPAQQ FONTSAMPLERCOMS

+       ((FNS FontSample FontSampleFaked FontTable)
+        [VARS (*INTERESTING-CHARSETS* '(0 33 34 38 39 238 239 240 241]
+        (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
+                                                FONT))))
 (DEFINEQ
 
 (FontSample

@@ -55,94 +60,113 @@ Copyright (c) 1985, 1987 by Xerox Corporation.  All rights reserved.
 
 (FontTable

   [LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits)

+                                                             (* ; "Edited  2-Feb-2025 22:50 by mth")

                                                              (* edited%: "29-Apr-87 22:36")

-    (LET* ((Family (FONTPROP Font 'FAMILY))
-           (Face (FONTPROP Font 'FACE))
-           (Size (FONTPROP Font 'SIZE))
-           (Title (CONCAT " " Size "pt " (L-CASE Family T)
-                         " "
-                         (L-CASE Face T)
-                         " Character set ")))
-          (printout T Title |.I0.8| CharacterSet "Q")
-          (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))
-                    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
-                                                                            ))
-                    do
 (MOVETO XPosition YPosition Stream)
-                       (PRIN1 Counter Stream)))
-          (DRAWLINE (TIMES 0.25 InchesToPrinterUnits)
-                 (TIMES 9.25 InchesToPrinterUnits)
-                 (TIMES 8.0 InchesToPrinterUnits)
-                 (TIMES 9.25 InchesToPrinterUnits)
-                 (DSPSCALE NIL Stream)
-                 'PAINT Stream)
-          (DRAWLINE (TIMES 0.6 InchesToPrinterUnits)
-                 (TIMES 9.7 InchesToPrinterUnits)
-                 (TIMES 0.6 InchesToPrinterUnits)
-                 (TIMES 1.25 InchesToPrinterUnits)
-                 (DSPSCALE NIL Stream)
-                 'PAINT Stream)
-          (DSPFONT Font Stream)
-          (for
 YPosition from
 (TIMES 9 InchesToPrinterUnits) by
 (TIMES -0.5 InchesToPrinterUnits)
-             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
-                   do
 (MOVETO XPosition YPosition Stream)
-                      (if
 (AND (NEQ CharacterCode (CHARCODE FF))
-                               (if
 (MEMB (IMAGESTREAMTYPE Stream)
-                                         '(DISPLAY INTERPRESS))
-                                   then
 (OR (AND (IGREATERP CharacterCode 31)
-                                                 (ILESSP CharacterCode 127))
-                                            (AND (IGREATERP CharacterCode 160)
-                                                 (ILESSP CharacterCode 255)))
-                                 else
 T))
-                          then
 (PRINTCCODE (IPLUS (ITIMES CharacterSet 256)
-                                                  CharacterCode)
-                                      Stream))
-                      (SETQ CharacterCode (ADD1 CharacterCode)))
-                (printout T "."))
-          (MOVETO (FTIMES 0.75 InchesToPrinterUnits)
-                 (FTIMES 0.75 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")
-          [if
 (EQ (FILENAMEFIELD (FULLNAME Stream)
-                         'HOST)
-                  'LPT)
-              then
 (MOVETO (FTIMES 0.75 InchesToPrinterUnits)
-                          (FTIMES 0.5 InchesToPrinterUnits)
-                          Stream)
-                   (printout Stream " on " (L-CASE (OR (FILENAMEFIELD (FULLNAME Stream)
-                                                              'DEVICE)
-                                                       (FILENAMEFIELD (FULLNAME Stream)
-                                                              'NAME))
-                                                  T)
-                          ", "
-                          (GDATE NIL (DATEFORMAT NO.TIME SPACES]
-          (if
 FormFeed
-              then
 (DSPNEWPAGE Stream))
-          (printout T " done." T])
+    (LET*
+     [(Family (FONTPROP Font 'FAMILY))
+      (Face (FONTPROP Font 'FACE))
+      (Size (FONTPROP Font 'SIZE))
+      (Title (CONCAT " " Size "pt " (L-CASE Family T)
+                    " "
+                    (L-CASE Face T)
+                    " Character set "))
+      [UseDisplayFontBitmaps (AND (EQ (FONTPROP Font 'DEVICE)
+                                      '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]
+     (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))
+            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))
+            do
 (MOVETO XPosition YPosition Stream)
+               (PRIN1 Counter Stream)))
+     (DRAWLINE (TIMES 0.25 InchesToPrinterUnits)
+            (TIMES 9.25 InchesToPrinterUnits)
+            (TIMES 8.0 InchesToPrinterUnits)
+            (TIMES 9.25 InchesToPrinterUnits)
+            (DSPSCALE NIL Stream)
+            'PAINT Stream)
+     (DRAWLINE (TIMES 0.6 InchesToPrinterUnits)
+            (TIMES 9.7 InchesToPrinterUnits)
+            (TIMES 0.6 InchesToPrinterUnits)
+            (TIMES 1.25 InchesToPrinterUnits)
+            (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)
+        do

+        (for
 XPosition from
 (TIMES 0.75 InchesToPrinterUnits) by
 (TIMES 0.45 InchesToPrinterUnits)
+           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))
+                     else
 (if
 (AND (NEQ CharacterCode (CHARCODE FF))
+                                   (if
 (MEMB (IMAGESTREAMTYPE Stream)
+                                             '(DISPLAY INTERPRESS))
+                                       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)))
+        (printout T "."))
+     (MOVETO (FTIMES 0.75 InchesToPrinterUnits)
+            (FTIMES 0.75 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")
+     [if
 (EQ (FILENAMEFIELD (FULLNAME Stream)
+                    'HOST)
+             'LPT)
+         then
 (MOVETO (FTIMES 0.75 InchesToPrinterUnits)
+                     (FTIMES 0.5 InchesToPrinterUnits)
+                     Stream)
+              (printout Stream " on " (L-CASE (OR (FILENAMEFIELD (FULLNAME Stream)
+                                                         'DEVICE)
+                                                  (FILENAMEFIELD (FULLNAME Stream)
+                                                         'NAME))
+                                             T)
+                     ", "
+                     (GDATE NIL (DATEFORMAT NO.TIME SPACES]
+     (if
 FormFeed
+         then
 (DSPNEWPAGE Stream))
+     (printout T " done." T])
 )
 
 (RPAQQ *INTERESTING-CHARSETS*
 (0 33 34 38 39 238 239 240 241))
 (DECLARE%: EVAL@COMPILE DONTCOPY 
+
 (FILESLOAD (LOADCOMP)
        FONT)
 )
-(PUTPROPS FONTSAMPLER COPYRIGHT ("Xerox Corporation" 1985 1987))
+(PUTPROPS FONTSAMPLER COPYRIGHT ("Xerox Corporation" 1985 1987 2025))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (689 7765 (FontSample 699 . 2154) (FontSampleFaked 2156 . 2965) (FontTable 2967 . 7763))
+  (FILEMAP (NIL (706 8566 (FontSample 716 . 2171) (FontSampleFaked 2173 . 2982) (FontTable 2984 . 8564))
 )))
 STOP