FONTSAMPLER can show DISPLAYFONT on non display stream (2nd retry)

lispusers/FONTSAMPLER

@@ -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