(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(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 " 3-Feb-2025 13:06:38" {DSK}<home>matt>Interlisp>medley>lispusers>FONTSAMPLER.;7
)


(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))))
(DEFINEQ

(FontSample

  [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)))
           [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
                            else
 (LIST (OR CharacterSets 0]
           (LastCharacterSet (CAR (LAST CharacterSets]
          (DSPRIGHTMARGIN (fetch
 (REGION WIDTH) of
 (DSPCLIPPINGREGION NIL Stream))
                 Stream)
          (for
 Font in
 FontList do
 (for
 CharacterSet in
 CharacterSets
                                      do
 (FontTable
 Font CharacterSet Stream (OR (NEQ Font LastFont)
                                                                                 (NEQ CharacterSet 
                                                                                     LastCharacterSet
                                                                                      ))
                                                TitleFont InchesToPrinterUnits))
             finally
 (CLOSEF Stream])

(FontSampleFaked

  [LAMBDA (FontAsList Printer StreamType)
                    (* N.H.Briggs "27-Apr-87 18:12")

    (LET* [[TitleFont (FONTCREATE NIL 12 'MRR 0 (OR StreamType (PRINTERTYPE Printer]
           (Font)
           [Stream (OPENIMAGESTREAM Printer StreamType (LIST 'FONTS (LIST TitleFont]
           (InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream]
          [SETQ Font (NCREATE 'FONTDESCRIPTOR (DEFAULTFONT (OR StreamType (PRINTERTYPE Printer]
          (replace
 FONTFAMILY of
 Font with
 (CAR FontAsList))
          (replace
 FONTSIZE of
 Font with
 (CADR FontAsList))
          (replace
 FONTFACE of
 Font with
 (\FONTFACE (CADDR FontAsList)))
          (FontTable
 Font '(0) Stream NIL TitleFont InchesToPrinterUnits)
          (CLOSEF Stream])

(FontTable

  [LAMBDA (Font CharacterSet Stream FormFeed TitleFont InchesToPrinterUnits)

                                                             (* ; "Edited  3-Feb-2025 20:07 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 "))
      [UseDisplayFontBitmaps (AND (EQ (FONTPROP Font 'DEVICE)
                                      'DISPLAY)
                                  (NOT (EQ (IMAGESTREAMTYPE Stream)
                                           'DISPLAY]
      [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))
         (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
 (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.3 InchesToPrinterUnits)
            (TIMES 8.0 InchesToPrinterUnits)
            (TIMES 9.3 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
 (MINUS YCellSpacing) as
 YCounter
        from
 0 to
 15 bind
 (CharacterCode _ 0)
        do

        (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))
                                   (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))
                                       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)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (645 8614 (FontSample 655 . 2106) (FontSampleFaked 2108 . 2917) (FontTable 2919 . 8612))
)))
STOP