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

(FILECREATED "27-Sep-87 16:14:14" {DSK}<OST>ANSICHATFONT.;28
 44240  

      changes to%:  (VARS ANSICHATFONTCOMS)
                    (PROPS (ANSICHATFONT MAKEFILE-ENVIRONMENT))
                    (FNS ANSI-Chat-Build-Font-Descriptors ANSI-Chat-Copy-CharSet 
                         ANSI-Chat-Copy-CharSet-DoubleHeight ANSI-Chat-Copy-CharSet-DoubleWide)
                    (FILES FONTDECLS)

      previous date%: "26-Sep-87 15:20:54" {DSK}<OST>ANSICHATFONT.;27)


(PRETTYCOMPRINT ANSICHATFONTCOMS)

(RPAQQ ANSICHATFONTCOMS
 
       ((PROP MAKEFILE-ENVIRONMENT ANSICHATFONT)
        (PROP FILETYPE ANSICHATFONT)
        (FNS ANSI-Chat-Build-Font-Descriptors ANSI-Chat-Copy-CharSet 
             ANSI-Chat-Copy-CharSet-DoubleHeight ANSI-Chat-Copy-CharSet-DoubleWide 
             ANSI-Chat-Font-Initialize)
        (INITVARS (ANSI-Chat-Font NIL))
        (GLOBALVARS ANSI-Chat-Font-Descriptor-Cache ANSI-Chat-Font)
        (ADDVARS (MISSINGDISPLAYFONTCOERCIONS ((ANSITERMINAL)
                                               (TERMINAL)))
               (ASCIITONSTRANSLATIONS (ANSITERMINAL NIL TERMINAL)))
        (FNS ANSI-Chat-Initialize-Character-Translations ANSI-Chat-Build-Map)
        (GLOBALVARS ANSI-ASCII-Graphics-Character-Set ANSI-Supplemental-Graphics-Character-Set 
               ANSI-Special-Graphics-Character-Set ANSI-British-NRC-Character-Set 
               ANSI-Dutch-NRC-Character-Set ANSI-Finnish-NRC-Character-Set 
               ANSI-French-NRC-Character-Set ANSI-French-Canadian-NRC-Character-Set 
               ANSI-German-NRC-Character-Set ANSI-Italian-NRC-Character-Set 
               ANSI-Norwegian/Danish-NRC-Character-Set ANSI-Spanish-NRC-Character-Set 
               ANSI-Swedish-NRC-Character-Set ANSI-Swiss-NRC-Character-Set)
        (P (ANSI-Chat-Initialize-Character-Translations)
           (ANSI-Chat-Font-Initialize))
        (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
                                                FONTDECLS))))

(PUTPROPS ANSICHATFONT MAKEFILE-ENVIRONMENT
 (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10))

(PUTPROPS ANSICHATFONT FILETYPE
 TCOMPL)
(DEFINEQ

(ANSI-Chat-Build-Font-Descriptors

  [LAMBDA NIL
    (DECLARE
 (GLOBALVARS PROMPTWINDOW ANSI-Chat-Font-Descriptor-Cache ANSI-Chat-Font)
           (CONSTANTS \MAXCHARSET))
                       (* ; "Edited 27-Sep-87 15:22 by R.Beeman")

          
          (* ;; "Need eight (8) FontDescriptors Normal (MRR), DoubleWide (MIR), DoubleHeightTop (MIE), DoubleHeightBottom (MIC), Bold (BRR), BoldDoubleWide (BIR), BoldDoubleHeightTop (BIE), BoldDoubleHeightBottom (BIC)")

          
          (* ;; 

          "First get the Normal and Bold conventionally, then copy them to the VIDEOTERMINAL family")


    (LET*
     [[BaseFont (FONTCREATE (OR [AND (BOUNDP 'ANSI-Chat-Font)
                                     ANSI-Chat-Font
                                     (FONTUNPARSE (FONTCOPY ANSI-Chat-Font 'FACE 'MRR]
                                '(ANSITERMINAL 10]
      (BaseBoldFont (FONTCOPY BaseFont 'WEIGHT 'BOLD]
     (COND
        ((AND (BOUNDP 'ANSI-Chat-Font-Descriptor-Cache)
              (EQP (LENGTH ANSI-Chat-Font-Descriptor-Cache)
                   3)
              (EQ BaseFont (CAR ANSI-Chat-Font-Descriptor-Cache))
              (EQ BaseBoldFont (CADR ANSI-Chat-Font-Descriptor-Cache)))
                                                             (* ; "Have already done the work")


         NIL)
        (T
         (PROMPTPRINT "Building Font Descriptors ")
          
          (* ;; "Force in the Character Sets")


         (for
 CharacterSpecification
            in
 '(0,040 41,142 42,041 46,163 50,043 356,176 357,344 360,270 361,41 375,320)
            do
 (LET ((CharacterCode (APPLY* (FUNCTION CHARCODE)
                                           CharacterSpecification)))
                    (CHARWIDTH CharacterCode BaseFont)
                    (PRINTOUT PROMPTWINDOW ".")
                    (CHARWIDTH CharacterCode BaseBoldFont)
                    (PRINTOUT PROMPTWINDOW ".")))
         [LET
          ((CharSet0AverageWidth (\AVGCHARWIDTH BaseFont))
           (SourceCharSet0 (\GETCHARSETINFO 0 BaseFont)))
          (SETQ ANSI-Chat-Font-Descriptor-Cache
           (LIST BaseFont BaseBoldFont
                 (COND
                    (SourceCharSet0
          
          (* ;; "Create Font Descriptors")


                     (LET ((CharSet0Ascent (fetch
 (CHARSETINFO CHARSETASCENT) of
 SourceCharSet0))
                           (CharSet0Descent (fetch
 (CHARSETINFO CHARSETDESCENT) of
 SourceCharSet0))
                           (NormalFont (create
 FONTDESCRIPTOR))
                           (DoubleWideFont (create
 FONTDESCRIPTOR))
                           (DoubleHeightTopFont (create
 FONTDESCRIPTOR))
                           (DoubleHeightBottomFont (create
 FONTDESCRIPTOR))
                           (BoldFont (create
 FONTDESCRIPTOR))
                           (BoldDoubleWideFont (create
 FONTDESCRIPTOR))
                           (BoldDoubleHeightTopFont (create
 FONTDESCRIPTOR))
                           (BoldDoubleHeightBottomFont (create
 FONTDESCRIPTOR)))
                          (PRINTOUT PROMPTWINDOW ".")
                          [for
 FD in
 (LIST NormalFont DoubleWideFont DoubleHeightTopFont 
                                           DoubleHeightBottomFont BoldFont BoldDoubleWideFont 
                                           BoldDoubleHeightTopFont BoldDoubleHeightBottomFont)
                             as
 Face in
 '(MRR MIR MIE MIC BRR BIR BIE BIC)
                             bind
 (Size _ (FONTPROP BaseFont 'SIZE))
                             do
 (replace
 (FONTDESCRIPTOR FONTDEVICE) of
 FD with
 'DISPLAY)
                                (replace
 (FONTDESCRIPTOR FONTFAMILY) of
 FD with
 'VIDEOTERMINAL)
                                (replace
 (FONTDESCRIPTOR FONTSIZE) of
 FD with
 Size)
                                (replace
 (FONTDESCRIPTOR FONTFACE) of
 FD with
 Face)
                                (replace
 (FONTDESCRIPTOR \SFAscent) of
 FD with
 CharSet0Ascent)
                                (replace
 (FONTDESCRIPTOR \SFDescent) of
 FD with
 CharSet0Descent)
                                (replace
 (FONTDESCRIPTOR \SFHeight) of
 FD with
 (+ CharSet0Ascent 
                                                                                  CharSet0Descent))
                                (replace
 (FONTDESCRIPTOR ROTATION) of
 FD with
 0)
                                (replace
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FD
                                   with
 (LIST 'VIDEOTERMINAL Size Face 0 'DISPLAY))
                                (replace
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FD
                                   with
 (SELECTQ Face
                                            ((MRR BRR) 
                                                 CharSet0AverageWidth)
                                            (RSH CharSet0AverageWidth -1]
                          (PRINTOUT PROMPTWINDOW ".")
          
          (* ;; "Copy Base Font Descriptors to ANSI-Chat Font Descriptors")


                          (for
 BFD in
 (LIST BaseFont BaseBoldFont) as
 SWFD
                             in
 (LIST NormalFont BoldFont)
                             do
 (for
 CharacterSet
                                   in
 '(0 33 34 38 40 238 239 240 241 253)
                                   do
 [LET ((SourceCharSet (\GETCHARSETINFO CharacterSet BFD)))
                                           (COND
                                              (SourceCharSet (\SETCHARSETINFO (fetch
 (FONTDESCRIPTOR
                                                                                      
                                                                                    FONTCHARSETVECTOR
                                                                                      ) of
 SWFD)
                                                                    CharacterSet
                                                                    (ANSI-Chat-Copy-CharSet
 
                                                                           SourceCharSet 
                                                                           CharSet0Ascent 
                                                                           CharSet0Descent 
                                                                           CharSet0AverageWidth]
                                      (PRINTOUT PROMPTWINDOW ".")))
          
          (* ;; "Next create DoubleWides")


                          (for
 SWFD in
 (LIST NormalFont BoldFont) as
 DWFD
                             in
 (LIST DoubleWideFont BoldDoubleWideFont)
                             do
 (for
 CharacterSet
                                   in
 '(0 33 34 38 40 238 239 240 241 253)
                                   do
 [LET ((SourceCharSet (\GETCHARSETINFO CharacterSet SWFD)))
                                           (COND
                                              (SourceCharSet (\SETCHARSETINFO (fetch
 (FONTDESCRIPTOR
                                                                                      
                                                                                    FONTCHARSETVECTOR
                                                                                      ) of
 DWFD)
                                                                    CharacterSet
                                                                    (

                                                                    ANSI-Chat-Copy-CharSet-DoubleWide

                                                                     SourceCharSet
                                                                     (RSH CharSet0AverageWidth -1]
                                      (PRINTOUT PROMPTWINDOW ".")))
          
          (* ;; "Finally create DoubleHeights")


                          [for
 DWFD in
 (LIST DoubleWideFont BoldDoubleWideFont) as
 DHTFD
                             in
 (LIST DoubleHeightTopFont BoldDoubleHeightTopFont) as
 DHBFD
                             in
 (LIST DoubleHeightBottomFont BoldDoubleHeightBottomFont)
                             do
 (for
 CharacterSet
                                   in
 '(0 33 34 38 40 238 239 240 241 253)
                                   do
 (LET ((SourceCharSet (\GETCHARSETINFO CharacterSet DWFD)))
                                           (COND
                                              (SourceCharSet (\SETCHARSETINFO (fetch
 (FONTDESCRIPTOR
                                                                                      
                                                                                    FONTCHARSETVECTOR
                                                                                      ) of
 DHTFD)
                                                                    CharacterSet
                                                                    (

                                                                  ANSI-Chat-Copy-CharSet-DoubleHeight

                                                                     SourceCharSet
                                                                     (RSH CharSet0AverageWidth -1)
                                                                     'Top))
                                                     (PRINTOUT PROMPTWINDOW ".")
                                                     (\SETCHARSETINFO (fetch
 (FONTDESCRIPTOR 
                                                                                    FONTCHARSETVECTOR
                                                                                    ) of
 DHBFD)
                                                            CharacterSet
                                                            (ANSI-Chat-Copy-CharSet-DoubleHeight

                                                             SourceCharSet
                                                             (RSH CharSet0AverageWidth -1)
                                                             'Bottom))
                                                     (PRINTOUT PROMPTWINDOW "."]
                          (LIST (LIST 3 DoubleHeightTopFont 4 DoubleHeightBottomFont 5 NormalFont 6 
                                      DoubleWideFont)
                                3 BoldDoubleHeightTopFont 4 BoldDoubleHeightBottomFont 5 BoldFont 6 
                                BoldDoubleWideFont)))
                    (T 
          
          (* ;; " Things are terribly wrong, just supply BaseFont and BoldBaseFont ")


                       (LIST (LIST 5 BaseFont)
                             5 BaseBoldFont]
         (PRINTOUT PROMPTWINDOW " Done" T)))
     (CADDR ANSI-Chat-Font-Descriptor-Cache])

(ANSI-Chat-Copy-CharSet

  [LAMBDA (Source Ascent Descent Width)
    (DECLARE
 (CONSTANTS \MAXTHINCHAR WORDSPERCELL))
       (* ; "Edited 27-Sep-87 15:21 by R.Beeman")


    (LET* ((Height (+ Ascent Descent))
           (SourceWidths (fetch
 (CHARSETINFO WIDTHS) of
 Source))
           (SourceOffsets (fetch
 (CHARSETINFO OFFSETS) of
 Source))
           (SourceCharSetBitMap (fetch
 (CHARSETINFO CHARSETBITMAP) of
 Source))
           (SourceImageWidths (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 Source))
           (SourceCharSetAscent (fetch
 (CHARSETINFO CHARSETASCENT) of
 Source))
           (SourceCharSetDescent (fetch
 (CHARSETINFO CHARSETDESCENT) of
 Source))
           (UnknownOffset (\FGETOFFSET SourceOffsets (ADD1 \MAXTHINCHAR)))
           (CharSetInfo (create
 CHARSETINFO))
           (DestinationWidths (fetch
 (CHARSETINFO WIDTHS) of
 CharSetInfo))
           (DestinationOffsets (fetch
 (CHARSETINFO OFFSETS) of
 CharSetInfo))
           (DestinationImageWidths (\CREATECSINFOELEMENT))
           (DestinationOffset 0)
           [DestinationUnknownOffset (ITIMES (ADD1 Width)
                                            (for
 Index from
 0 to
 \MAXTHINCHAR
                                               count
 (NOT (EQ (\FGETOFFSET SourceOffsets Index)
                                                              UnknownOffset]
           (DestinationCharSetBitMap (BITMAPCREATE (+ DestinationUnknownOffset Width)
                                            Height 1)))
          (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CharSetInfo with
 DestinationImageWidths)
          (replace
 (CHARSETINFO CHARSETBITMAP) of
 CharSetInfo with
 DestinationCharSetBitMap)
          (replace
 (CHARSETINFO CHARSETASCENT) of
 CharSetInfo with
 Ascent)
          (replace
 (CHARSETINFO CHARSETDESCENT) of
 CharSetInfo with
 Descent)
          (\FSETWIDTH DestinationWidths (ADD1 \MAXTHINCHAR)
                 Width)
          (\FSETOFFSET DestinationOffsets (ADD1 \MAXTHINCHAR)
                 DestinationUnknownOffset)
          (\FSETIMAGEWIDTH DestinationImageWidths (ADD1 \MAXTHINCHAR)
                 Width)
          [LET* [(SourceCharSetBitMapHeight (BITMAPHEIGHT SourceCharSetBitMap))
                 (SourceYOffset (IMAX 0 (- SourceCharSetDescent Descent)))
                 [DestinationYOffset (IMIN (SUB1 Height)
                                           (IMAX 0 (- (+ SourceCharSetAscent Descent)
                                                      SourceCharSetBitMapHeight]
                 (BLTHeight (IMAX 0 (IMIN (- SourceCharSetBitMapHeight SourceYOffset)
                                          (- Height DestinationYOffset]
                (for
 Index from
 0 to
 \MAXTHINCHAR
                   do
 (LET [(SourceOffset (\FGETOFFSET SourceOffsets Index))
                            (SourceImageWidth (IMIN Width (\FGETIMAGEWIDTH SourceImageWidths Index]
                           (\FSETWIDTH DestinationWidths Index Width)
                           (\FSETIMAGEWIDTH DestinationImageWidths Index Width)
                           (COND
                              ((EQ SourceOffset UnknownOffset)
                               (\FSETOFFSET DestinationOffsets Index DestinationUnknownOffset))
                              (T (\FSETOFFSET DestinationOffsets Index DestinationOffset)
                                 [COND
                                    ((NOT (ZEROP BLTHeight))
                                     (BITBLT SourceCharSetBitMap SourceOffset SourceYOffset 
                                            DestinationCharSetBitMap DestinationOffset 
                                            DestinationYOffset SourceImageWidth BLTHeight
                                            'INPUT
                                            'REPLACE]
                                 (SETQ DestinationOffset (+ DestinationOffset Width 1]
          (BLTSHADE BLACKSHADE DestinationCharSetBitMap (ADD1 DestinationUnknownOffset)
                 Descent
                 (- Width 2)
                 Ascent
                 'REPLACE)
          CharSetInfo])

(ANSI-Chat-Copy-CharSet-DoubleHeight

  [LAMBDA (Source Width Half)
    (DECLARE
 (CONSTANTS \MAXTHINCHAR WORDSPERCELL))
       (* ; "Edited 27-Sep-87 15:22 by R.Beeman")


    (LET* ((SourceWidths (fetch
 (CHARSETINFO WIDTHS) of
 Source))
           (SourceOffsets (fetch
 (CHARSETINFO OFFSETS) of
 Source))
           (SourceCharSetBitMap (fetch
 (CHARSETINFO CHARSETBITMAP) of
 Source))
           (SourceImageWidths (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 Source))
           (SourceCharSetAscent (fetch
 (CHARSETINFO CHARSETASCENT) of
 Source))
           (SourceCharSetDescent (fetch
 (CHARSETINFO CHARSETDESCENT) of
 Source))
           (Height (+ SourceCharSetAscent SourceCharSetDescent))
           (UnknownOffset (\FGETOFFSET SourceOffsets (ADD1 \MAXTHINCHAR)))
           (CharSetInfo (create
 CHARSETINFO))
           (DestinationWidths (fetch
 (CHARSETINFO WIDTHS) of
 CharSetInfo))
           (DestinationOffsets (fetch
 (CHARSETINFO OFFSETS) of
 CharSetInfo))
           (DestinationImageWidths (\CREATECSINFOELEMENT))
           (DestinationOffset 0)
           (DestinationCharSetBitMap (BITMAPCOPY SourceCharSetBitMap)))
          (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CharSetInfo with
 DestinationImageWidths)
          (replace
 (CHARSETINFO CHARSETBITMAP) of
 CharSetInfo with
 DestinationCharSetBitMap)
          (replace
 (CHARSETINFO CHARSETASCENT) of
 CharSetInfo with
 SourceCharSetAscent)
          (replace
 (CHARSETINFO CHARSETDESCENT) of
 CharSetInfo with
 SourceCharSetDescent)
          (for
 Index from
 0 to
 (ADD1 \MAXTHINCHAR) do
 (\FSETWIDTH DestinationWidths Index
                                                             (\FGETWIDTH SourceWidths Index))
                                                      (\FSETOFFSET DestinationOffsets Index
                                                             (\FGETOFFSET SourceOffsets Index))
                                                      (\FSETIMAGEWIDTH DestinationImageWidths Index
                                                             (\FGETIMAGEWIDTH SourceImageWidths Index
                                                                    )))
          (LET [(YsMiddle (IQUOTIENT Height 2))
                (Top (SUB1 Height))
                (Odd (NOT (ZEROP (IMOD Height 2]
               (SELECTQ Half
                   (Top (if
 Odd
                            then
 (BITBLT SourceCharSetBitMap 0 YsMiddle DestinationCharSetBitMap 0 0 
                                        UnknownOffset 1 'SOURCE 'REPLACE))
                        (for
 Ys from
 Top to
 (ADD1 YsMiddle) by
 -1 as
 Yd from
 Top by
 -2
                           do
 (BITBLT SourceCharSetBitMap 0 Ys DestinationCharSetBitMap 0 Yd 
                                     UnknownOffset 1 'SOURCE 'REPLACE)
                              (BITBLT SourceCharSetBitMap 0 Ys DestinationCharSetBitMap 0
                                     (SUB1 Yd)
                                     UnknownOffset 1 'SOURCE 'REPLACE)))
                   (Bottom (if
 Odd
                               then
 (BITBLT SourceCharSetBitMap 0 YsMiddle DestinationCharSetBitMap 0 
                                           Top UnknownOffset 1 'SOURCE 'REPLACE))
                           (for
 Ys from
 0 to
 (SUB1 YsMiddle) as
 Yd from
 0 by
 2
                              do
 (BITBLT SourceCharSetBitMap 0 Ys DestinationCharSetBitMap 0 Yd 
                                        UnknownOffset 1 'SOURCE 'REPLACE)
                                 (BITBLT SourceCharSetBitMap 0 Ys DestinationCharSetBitMap 0
                                        (ADD1 Yd)
                                        UnknownOffset 1 'SOURCE 'REPLACE)))
                   NIL))
          CharSetInfo])

(ANSI-Chat-Copy-CharSet-DoubleWide

  [LAMBDA (Source Width)
    (DECLARE
 (CONSTANTS \MAXTHINCHAR WORDSPERCELL))
       (* ; "Edited 27-Sep-87 15:23 by R.Beeman")


    (LET* ((SourceWidths (fetch
 (CHARSETINFO WIDTHS) of
 Source))
           (SourceOffsets (fetch
 (CHARSETINFO OFFSETS) of
 Source))
           (SourceCharSetBitMap (fetch
 (CHARSETINFO CHARSETBITMAP) of
 Source))
           (SourceImageWidths (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 Source))
           (SourceCharSetAscent (fetch
 (CHARSETINFO CHARSETASCENT) of
 Source))
           (SourceCharSetDescent (fetch
 (CHARSETINFO CHARSETDESCENT) of
 Source))
           (Height (+ SourceCharSetAscent SourceCharSetDescent))
           (UnknownOffset (\FGETOFFSET SourceOffsets (ADD1 \MAXTHINCHAR)))
           (CharSetInfo (create
 CHARSETINFO))
           (DestinationWidths (fetch
 (CHARSETINFO WIDTHS) of
 CharSetInfo))
           (DestinationOffsets (fetch
 (CHARSETINFO OFFSETS) of
 CharSetInfo))
           (DestinationImageWidths (\CREATECSINFOELEMENT))
           (DestinationOffset 0)
           [DestinationUnknownOffset (ITIMES (ADD1 Width)
                                            (for
 Index from
 0 to
 (ADD1 \MAXTHINCHAR)
                                               count
 (NOT (EQ (\FGETOFFSET SourceOffsets Index)
                                                              UnknownOffset]
           (DestinationCharSetBitMap (BITMAPCREATE (+ DestinationUnknownOffset Width)
                                            Height 1)))
          (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CharSetInfo with
 DestinationImageWidths)
          (replace
 (CHARSETINFO CHARSETBITMAP) of
 CharSetInfo with
 DestinationCharSetBitMap)
          (replace
 (CHARSETINFO CHARSETASCENT) of
 CharSetInfo with
 SourceCharSetAscent)
          (replace
 (CHARSETINFO CHARSETDESCENT) of
 CharSetInfo with
 SourceCharSetDescent)
          (\FSETWIDTH DestinationWidths (ADD1 \MAXTHINCHAR)
                 Width)
          (\FSETOFFSET DestinationOffsets (ADD1 \MAXTHINCHAR)
                 DestinationUnknownOffset)
          (\FSETIMAGEWIDTH DestinationImageWidths (ADD1 \MAXTHINCHAR)
                 Width)
          [for
 Index from
 0 to
 \MAXTHINCHAR
             do
 (LET ((SourceOffset (\FGETOFFSET SourceOffsets Index)))
                     (\FSETWIDTH DestinationWidths Index Width)
                     (\FSETIMAGEWIDTH DestinationImageWidths Index Width)
                     (COND
                        ((EQ SourceOffset UnknownOffset)
                         (\FSETOFFSET DestinationOffsets Index DestinationUnknownOffset))
                        (T (\FSETOFFSET DestinationOffsets Index DestinationOffset)
                           (for
 X from
 1 to
 (IMIN Width (\FGETIMAGEWIDTH SourceImageWidths Index))
                              as
 Xs from
 SourceOffset as
 Xd from
 DestinationOffset by
 2
                              do
 (BITBLT SourceCharSetBitMap Xs 0 DestinationCharSetBitMap Xd 0 1 
                                        Height 'SOURCE 'REPLACE)
                                 (BITBLT SourceCharSetBitMap Xs 0 DestinationCharSetBitMap
                                        (ADD1 Xd)
                                        0 1 Height 'SOURCE 'REPLACE))
                           (SETQ DestinationOffset (+ DestinationOffset Width 1]
          (BLTSHADE BLACKSHADE DestinationCharSetBitMap (ADD1 DestinationUnknownOffset)
                 SourceCharSetDescent
                 (- Width 2)
                 SourceCharSetAscent
                 'REPLACE)
          CharSetInfo])

(ANSI-Chat-Font-Initialize

  [LAMBDA NIL
    (DECLARE
 (GLOBALVARS ANSI-Chat-Font))
                 (* ; "Edited 25-Sep-87 20:06 by R.Beeman")

          
          (* ;; "Force Character Sets into memory")


    (PROMPTPRINT "Forcing Character Sets into memory ")
    [LET* [[BaseFont (FONTCREATE (OR [AND (BOUNDP 'ANSI-Chat-Font)
                                          ANSI-Chat-Font
                                          (FONTUNPARSE (FONTCOPY ANSI-Chat-Font 'FACE 'MRR]
                                     '(ANSITERMINAL 10]
           (BoldFont (FONTCOPY BaseFont 'WEIGHT 'BOLD]
          (for
 CharacterSpecification
             in
 '(0,040 41,142 42,041 46,163 50,043 356,176 357,344 360,270 361,41 375,320)
             do
 (LET ((CharacterCode (APPLY* (FUNCTION CHARCODE)
                                            CharacterSpecification)))
                     (CHARWIDTH CharacterCode BaseFont)
                     (PRINTOUT PROMPTWINDOW ".")
                     (CHARWIDTH CharacterCode BoldFont)
                     (PRINTOUT PROMPTWINDOW "."]
    (PRINTOUT PROMPTWINDOW " Done" T)
          
          (* ;; "Now build Font Descriptors")


    (ANSI-Chat-Build-Font-Descriptors
])
)

(RPAQ? ANSI-Chat-Font
 NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS ANSI-Chat-Font-Descriptor-Cache ANSI-Chat-Font)
)

(ADDTOVAR MISSINGDISPLAYFONTCOERCIONS
 ((ANSITERMINAL)
                                       (TERMINAL)))

(ADDTOVAR ASCIITONSTRANSLATIONS
 (ANSITERMINAL NIL TERMINAL))
(DEFINEQ

(ANSI-Chat-Initialize-Character-Translations

  [LAMBDA NIL
    (DECLARE
 (GLOBALVARS ANSI-ASCII-Graphics-Character-Set ANSI-Supplemental-Graphics-Character-Set 
                    ANSI-Special-Graphics-Character-Set ANSI-British-NRC-Character-Set 
                    ANSI-Dutch-NRC-Character-Set ANSI-Finnish-NRC-Character-Set 
                    ANSI-French-NRC-Character-Set ANSI-French-Canadian-NRC-Character-Set 
                    ANSI-German-NRC-Character-Set ANSI-Italian-NRC-Character-Set 
                    ANSI-Norwegian/Danish-NRC-Character-Set ANSI-Spanish-NRC-Character-Set 
                    ANSI-Swedish-NRC-Character-Set ANSI-Swiss-NRC-Character-Set))

                                                          (* ; "Edited 22-Sep-87 20:07 by R.Beeman")


    (LET [[ANSI-ASCII-Graphics-Exceptions '(($ 0,44]
          [ANSI-Supplemental-Graphics-Exceptions '((! 0,241)
                                                   (%" 0,242)
                                                   (%# 0,243)
                                                   ($ 0,40)
                                                   (%% 0,245)
                                                   (& 0,40)
                                                   (%' 0,247)
                                                   (%( 0,44)
                                                   (%) 0,323)(* 0,343)

                                                   (+ 0,253)
                                                   (%, 0,40)
                                                   (- 0,40)
                                                   (%. 0,40)
                                                   (/ 0,40)
                                                   (0 0,260)
                                                   (1 0,261)
                                                   (2 0,262)
                                                   (3 0,263)
                                                   (4 0,40)
                                                   (5 0,265)
                                                   (6 0,266)
                                                   (7 0,267)
                                                   (8 0,40)
                                                   (9 0,321)
                                                   (%: 0,353)
                                                   (; 0,273)
                                                   (< 0,274)
                                                   (= 0,275)
                                                   (> 0,40)
                                                   (? 0,277)
                                                   (@ 361,41)
                                                   (A 361,42)
                                                   (B 361,43)
                                                   (C 361,44)
                                                   (D 361,47)
                                                   (E 361,50)
                                                   (F 0,341)
                                                   (G 361,55)
                                                   (H 361,60)
                                                   (I 361,61)
                                                   (J 361,62)
                                                   (K 361,65)
                                                   (L 361,76)
                                                   (M 361,77)
                                                   (N 361,100)
                                                   (O 361,104)
                                                   (P 0,40)
                                                   (Q 361,114)
                                                   (R 361,117)
                                                   (S 361,120)
                                                   (T 361,121)
                                                   (U 361,122)
                                                   (V 361,124)
                                                   (W 0,352)
                                                   (X 0,351)
                                                   (Y 361,137)
                                                   (Z 361,140)
                                                   (%[ 361,141)
                                                   (\ 361,145)
                                                   (%] 361,155)
                                                   (^ 0,40)
                                                   (_ 0,373)
                                                   (%` 361,241)
                                                   (a 361,242)
                                                   (b 361,243)
                                                   (c 361,244)
                                                   (d 361,247)
                                                   (e 361,250)
                                                   (f 0,361)
                                                   (g 361,255)
                                                   (h 361,260)
                                                   (i 361,261)
                                                   (j 361,262)
                                                   (k 361,265)
                                                   (l 361,276)
                                                   (m 361,277)
                                                   (n 361,300)
                                                   (o 361,304)
                                                   (p 0,40)
                                                   (q 361,314)
                                                   (r 361,317)
                                                   (s 361,320)
                                                   (t 361,321)
                                                   (u 361,322)
                                                   (v 361,324)
                                                   (w 0,372)
                                                   (x 0,371)
                                                   (y 361,337)
                                                   (z 361,340)
                                                   ({ 361,341)
                                                   (%| 361,345)
                                                   (} 361,355)
                                                   (~ 0,40]
          [ANSI-Special-Graphics-Exceptions '(($ 0,44)
                                              (_ 0,040)
                                              (%` 42,041)
                                              (a 360,313)
                                              (b 360,271)
                                              (c 360,273)
                                              (d 360,274)
                                              (e 360,272)
                                              (f 0,260)
                                              (g 0,261)
                                              (h 360,275)
                                              (i 360,270)
                                              (j 50,045)
                                              (k 50,044)
                                              (l 50,043)
                                              (m 50,046)
                                              (n 357,346)
                                              (o 375,320)
                                              (p 375,321)
                                              (q 357,345)
                                              (r 375,322)
                                              (s 375,323)
                                              (t 50,047)
                                              (u 50,051)
                                              (v 50,052)
                                              (w 50,050)
                                              (x 357,344)
                                              (y 41,145)
                                              (z 41,146)
                                              ({ 46,163)
                                              (%| 41,142)
                                              (} 0,243)
                                              (~ 0,267]
          [ANSI-British-NRC-Exceptions '((%# 0,243)
                                         ($ 0,44]
          [ANSI-Dutch-NRC-Exceptions '((%# 0,243)
                                       ($ 0,44)
                                       (@ 0,276)
                                       (%[ 0,366)
                                       (\ 0,275)
                                       (%] 0,174)
                                       ({ 0,310)
                                       (%| 357,242)
                                       (} 0,274)
                                       (~ 0,302]
          [ANSI-Finnish-NRC-Exceptions '(($ 0,44)
                                         (%[ 361,047)
                                         (\ 361,124)
                                         (%] 361,050)
                                         (^ 361,145)
                                         (%` 361,261)
                                         ({ 361,247)
                                         (%| 361,324)
                                         (} 361,345)
                                         (~ 0,373]
          [ANSI-French-NRC-Exceptions '((%# 0,243)
                                        ($ 0,44)
                                        (@ 361,241)
                                        (%[ 0,312)
                                        (\ 361,255)
                                        (%] 0,247)
                                        ({ 361,261)
                                        (%| 361,337)
                                        (} 361,260)
                                        (~ 0,310]
          [ANSI-French-Canadian-NRC-Exceptions '(($ 0,44)
                                                 (@ 361,241)
                                                 (%[ 361,243)
                                                 (\ 361,255)
                                                 (%] 361,262)
                                                 (^ 361,300)
                                                 (%` 361,321)
                                                 ({ 361,261)
                                                 (%| 361,337)
                                                 (} 361,260)
                                                 (~ 361,341]
          [ANSI-German-NRC-Exceptions '(($ 0,44)
                                        (@ 0,247)
                                        (%[ 361,047)
                                        (\ 361,124)
                                        (%] 361,145)
                                        ({ 361,247)
                                        (%| 361,324)
                                        (} 361,345)
                                        (~ 0,373]
          [ANSI-Italian-NRC-Exceptions '((%# 0,243)
                                         ($ 0,44)
                                         (@ 0,247)
                                         (%[ 0,312)
                                         (\ 361,255)
                                         (%] 361,262)
                                         (%` 361,337)
                                         ({ 361,241)
                                         (%| 361,317)
                                         (} 361,260)
                                         (~ 361,277]
          [ANSI-Norwegian/Danish-NRC-Exceptions '(($ 0,44)
                                                  (@ 361,047)
                                                  (%[ 0,341)
                                                  (\ 0,351)
                                                  (%] 361,050)
                                                  (^ 361,145)
                                                  (%` 361,247)
                                                  ({ 0,361)
                                                  (%| 0,371)
                                                  (} 361,250)
                                                  (~ 361,345]
          [ANSI-Spanish-NRC-Exceptions '((%# 0,243)
                                         ($ 0,44)
                                         (@ 0,247)
                                         (%[ 0,241)
                                         (\ 361,114)
                                         (%] 0,277)
                                         ({ 0,312)
                                         (%| 361,314)
                                         (} 361,255]
          [ANSI-Swedish-NRC-Exceptions '(($ 0,44)
                                         (@ 361,061)
                                         (%[ 361,047)
                                         (\ 361,124)
                                         (%] 361,050)
                                         (^ 361,145)
                                         (%` 361,261)
                                         ({ 361,247)
                                         (%| 361,324)
                                         (} 361,250)
                                         (~ 361,345]
          (ANSI-Swiss-NRC-Exceptions '((%# 361,337)
                                       ($ 0,44)
                                       (@ 361,241)
                                       (%[ 361,261)
                                       (\ 361,255)
                                       (%] 361,262)
                                       (^ 361,300)
                                       (_ 361,260)
                                       (%` 361,321)
                                       ({ 361,247)
                                       (%| 361,324)
                                       (} 361,345)
                                       (~ 361,341]
         (SETQ ANSI-ASCII-Graphics-Character-Set (ANSI-Chat-Build-Map
 ANSI-ASCII-Graphics-Exceptions)
          )
         (SETQ ANSI-Supplemental-Graphics-Character-Set (ANSI-Chat-Build-Map
 
                                                               ANSI-Supplemental-Graphics-Exceptions)
          )
         (SETQ ANSI-Special-Graphics-Character-Set (ANSI-Chat-Build-Map
 
                                                          ANSI-Special-Graphics-Exceptions))
         (SETQ ANSI-British-NRC-Character-Set (ANSI-Chat-Build-Map
 ANSI-British-NRC-Exceptions))
         (SETQ ANSI-Dutch-NRC-Character-Set (ANSI-Chat-Build-Map
 ANSI-Dutch-NRC-Exceptions))
         (SETQ ANSI-Finnish-NRC-Character-Set (ANSI-Chat-Build-Map
 ANSI-Finnish-NRC-Exceptions))
         (SETQ ANSI-French-NRC-Character-Set (ANSI-Chat-Build-Map
 ANSI-French-NRC-Exceptions))
         (SETQ ANSI-French-Canadian-NRC-Character-Set (ANSI-Chat-Build-Map
 
                                                             ANSI-French-Canadian-NRC-Exceptions))
         (SETQ ANSI-German-NRC-Character-Set (ANSI-Chat-Build-Map
 ANSI-German-NRC-Exceptions))
         (SETQ ANSI-Italian-NRC-Character-Set (ANSI-Chat-Build-Map
 ANSI-Italian-NRC-Exceptions))
         (SETQ ANSI-Norwegian/Danish-NRC-Character-Set (ANSI-Chat-Build-Map
 
                                                              ANSI-Norwegian/Danish-NRC-Exceptions))
         (SETQ ANSI-Spanish-NRC-Character-Set (ANSI-Chat-Build-Map
 ANSI-Spanish-NRC-Exceptions))
         (SETQ ANSI-Swedish-NRC-Character-Set (ANSI-Chat-Build-Map
 ANSI-Swedish-NRC-Exceptions))
         (SETQ ANSI-Swiss-NRC-Character-Set (ANSI-Chat-Build-Map
 ANSI-Swiss-NRC-Exceptions])

(ANSI-Chat-Build-Map

  [LAMBDA (Exceptions)
                                    (* ; "Edited  9-Sep-87 16:51 by R.Beeman")


    (LET ((Table (ARRAY 95 'WORD 0 0)))
         (for
 Index from
 0 to
 94 as
 CharacterCode from
 (CHARCODE SPACE)
            do
 (SETA Table Index CharacterCode))
         [for
 Exception in
 Exceptions do
 (SETA Table (- (APPLY* (FUNCTION CHARCODE)
                                                               (CAR Exception))
                                                        (CHARCODE SPACE))
                                               (APPLY* (FUNCTION CHARCODE)
                                                      (CADR Exception]
         Table])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS ANSI-ASCII-Graphics-Character-Set ANSI-Supplemental-Graphics-Character-Set 
       ANSI-Special-Graphics-Character-Set ANSI-British-NRC-Character-Set 
       ANSI-Dutch-NRC-Character-Set ANSI-Finnish-NRC-Character-Set ANSI-French-NRC-Character-Set 
       ANSI-French-Canadian-NRC-Character-Set ANSI-German-NRC-Character-Set 
       ANSI-Italian-NRC-Character-Set ANSI-Norwegian/Danish-NRC-Character-Set 
       ANSI-Spanish-NRC-Character-Set ANSI-Swedish-NRC-Character-Set ANSI-Swiss-NRC-Character-Set)
)
(ANSI-Chat-Initialize-Character-Translations)
(ANSI-Chat-Font-Initialize)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(FILESLOAD (SOURCE)
       FONTDECLS)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2212 26462 (ANSI-Chat-Build-Font-Descriptors 2222 . 13337) (ANSI-Chat-Copy-CharSet 
13339 . 17562) (ANSI-Chat-Copy-CharSet-DoubleHeight 17564 . 21481) (ANSI-Chat-Copy-CharSet-DoubleWide 
21483 . 25219) (ANSI-Chat-Font-Initialize 25221 . 26460)) (26770 43515 (
ANSI-Chat-Initialize-Character-Translations 26780 . 42779) (ANSI-Chat-Build-Map 42781 . 43513)))))
STOP