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

(FILECREATED "29-Apr-87 22:43:49" {ERIS}<LISPUSERS>LYRIC>FONTSAMPLER.;4
 7992   

      changes to%:  (FNS FontSample)

      previous date%: "29-Apr-87 22:41:24" {ERIS}<LISPUSERS>KOTO>FONTSAMPLER.;6)


(* "
Copyright (c) 1985, 1987 by Xerox Corporation.  All rights reserved.
")

(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%: "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])
)

(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))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (689 7765 (FontSample 699 . 2154) (FontSampleFaked 2156 . 2965) (FontTable 2967 . 7763))
)))
STOP