(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)


(FILECREATED " 6-Oct-2026 23:26:39" {MEDLEY}<library>POSTSCRIPTSTREAM.;168
 249662 

      :EDIT-BY rmk

      :CHANGES-TO (VARS POSTSCRIPTSTREAMCOMS)
                  (FNS PSCFONT.TO.FONTDESCRIPTOR POSTSCRIPT.FONTCREATE)

      :PREVIOUS-DATE " 4-Oct-2026 14:48:13" {MEDLEY}<library>POSTSCRIPTSTREAM.;164)


(PRETTYCOMPRINT POSTSCRIPTSTREAMCOMS)

(RPAQQ POSTSCRIPTSTREAMCOMS

       [
        (* ;; "PostScript printer support for Medley")


        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS \POSTSCRIPTDATA POSTSCRIPTXFORM POSTSCRIPTCSINFO))
        (INITRECORDS \POSTSCRIPTDATA)
        (FNS POSTSCRIPT.INIT POSTSCRIPT.INIT.FONTPROFILE POSTSCRIPT.PUTRGBCOLOR \PSC.COLOR.TO.RGB)
        [COMS                                                (* ; "PSCFONT-reading code")

              (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FONTID PSCFONT))
              (FNS PSCFONT.READFONT PSCFONT.FILEP PSCFONT.WRITEFONT PSCFONT.FILENAME READ-AFM-FILE 
                   CONVERT-AFM-FILES POSTSCRIPT.GETFONTID PSCFONT.TO.FONTDESCRIPTOR)
              [ADDVARS (DEFAULTFILETYPELIST (PSCFONT . BINARY)
                              (PSC . BINARY))
                     (POSTSCRIPTFILETEMPLATES (PSCFONT (FAMILY SIZE - FACE)
                                                     (c0> FAMILY SIZE - FACE -C0]
              (APPENDVARS (POSTSCRIPTCHARSETFNS (PSCFONT PSCFONT.FILEP SHOULDNT]
        
        (* ;; "")


        [COMS                                                (* ; "Online fonts")

              (FNS POSTSCRIPT.FONTSAVAILABLE POSTSCRIPT.CREATECHARSET POSTSCRIPT.FONTCREATE 
                   \POSTSCRIPT.FONTCHANGESTRING)
              (GLOBALVARS POSTSCRIPTFONTEXTENSIONS POSTSCRIPTFONTDIRECTORIES POSTSCRIPTFONTCOERCIONS)
              (ADDVARS (POSTSCRIPTCHARSETFNS (MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET)))
              [INITVARS (POSTSCRIPTFONTDIRECTORIES "{MEDLEY}/fonts/medleypostscriptfonts")
                     (POSTSCRIPTFONTEXTENSIONS `(MEDLEYPOSTSCRIPTFONT PSCFONT))
                                                             (* ; 

                                               "MEDLEYPOSTSCRIPTFONT comes first, for import writing")

                     (POSTSCRIPTCHARCOERCIONS NIL)
                     (POSTSCRIPTFONTCOERCIONS '((CLASSIC (NEWCENTURYSCHLBK 0))
                                                (COURIER (COURIER 0))
                                                (CREAM (HELVETICA 0))
                                                (GACHA (COURIER 0))
                                                (HELVETICA (HELVETICA 0))
                                                (HELVETICAD (HELVETICA 0))
                                                (LOGO (HELVETICA 0))
                                                (MODERN (HELVETICA 0))
                                                (OPTIMA (PALATINO 0))
                                                (TERMINAL (COURIER 0))
                                                (TIMESROMAN (TIMES 0))
                                                (TIMESROMAND (TIMES 0))
                                                (TITAN (COURIER 0))
                                                (HIPPO CLASSIC)
                                                (MATH CLASSIC)
                                                (* (* 0]
              (ADDVARS (DEFAULTFILETYPELIST (PS . BINARY)
                              (PSF . BINARY)
                              (POSTSCRIPT . BINARY]
        
        (* ;; "")


        (FNS OPENPOSTSCRIPTSTREAM CLOSEPOSTSCRIPTSTREAM)
        (INITVARS (*POSTSCRIPT-FILE-TYPE* 'BINARY))
        (FNS POSTSCRIPT.HARDCOPYW POSTSCRIPT.TEDIT POSTSCRIPTFILEP MAKEEPSFILE)
        (FNS POSTSCRIPT.BITMAPSCALE POSTSCRIPT.CLOSESTRING POSTSCRIPT.ENDPAGE POSTSCRIPT.OUTSTR 
             POSTSCRIPT.PUTBITMAPBYTES POSTSCRIPT.PUTCOMMAND POSTSCRIPT.SET-FAKE-LANDSCAPE 
             POSTSCRIPT.SHOWACCUM POSTSCRIPT.STARTPAGE \POSTSCRIPTTAB \PS.BOUTFIXP \PS.SCALEHACK 
             \PS.SCALEREGION \SCALEDBITBLT.PSC \SETPOS.PSC \SETXFORM.PSC \STRINGWIDTH.PSC 
             \SWITCHFONTS.PSC \TERPRI.PSC)
        
        (* ;; "DIG operations: ")


        (FNS \BITBLT.PSC \BLTSHADE.PSC \CHARWIDTH.PSC \DRAWARC.PSC \DRAWCIRCLE.PSC \DRAWCURVE.PSC 
             \DRAWELLIPSE.PSC \DRAWLINE.PSC \DRAWPOINT.PSC \DRAWPOLYGON.PSC \DSPBOTTOMMARGIN.PSC 
             \DSPCLIPPINGREGION.PSC \DSPCOLOR.PSC \DSPFONT.PSC \DSPLEFTMARGIN.PSC \DSPLINEFEED.PSC 
             \DSPPUSHSTATE.PSC \DSPPOPSTATE.PSC \DSPRESET.PSC \DSPRIGHTMARGIN.PSC \DSPROTATE.PSC 
             \DSPSCALE.PSC \DSPSCALE2.PSC \DSPSPACEFACTOR.PSC \DSPTOPMARGIN.PSC \DSPTRANSLATE.PSC 
             \DSPXPOSITION.PSC \DSPYPOSITION.PSC \FILLCIRCLE.PSC \FILLPOLYGON.PSC \FIXLINELENGTH.PSC
             \MOVETO.PSC \NEWPAGE.PSC)
        (COMS 
              (* ;; "Character-output, plus special-cases:")


              (FNS \POSTSCRIPT.CHANGECHARSET \POSTSCRIPT.OUTCHARFN \POSTSCRIPT.PRINTSLUG 
                   \POSTSCRIPT.SPECIALOUTCHARFN \UPDATE.PSC \POSTSCRIPT.ACCENTPAIR)
              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \POSTSCRIPT.MAPPING \POSTSCRIPT.NEWLINE? 
                                                      \POSTSCRIPT.STARTSTRING? \POSTSCRIPT.FRACTION 
                                                      OCTAL3OUT))
              
              (* ;; "Spacing-character (M-quad, etc.) and ballot-box-check &c special-case functions")


              (FNS \PSC.SPACEDISP \PSC.SPACEWID \PSC.SYMBOLS)
              
              (* ;; "The mapping of MCCS characters to Postscript renderings")


              (VARS *POSTSCRIPT-MCCS-TRANSLATIONS*)
              (FNS POSTSCRIPT.MCCS.BLOCKS POSTSCRIPT.ZAPFDINGBATS.BLOCKS)
              (GLOBALVARS *POSTSCRIPT-MAPPING-BLOCKS*))
        (VARS (\POSTSCRIPT.ORIENTATION.MENU (create MENU ITEMS ← '(("Landscape" T 
                                            "Print this file/document/image in Landscape Orientation"
                                                                          )
                                                                   ("Portrait" 'NIL 
                                             "Print this file/document/image in Portrait Orientation"
                                                                          ))
                                                   TITLE ← "Orientation" CENTERFLG ← T MENUOFFSET ←
                                                   (create POSITION XCOORD ← -1 YCOORD ← 0)
                                                   CHANGEOFFSETFLG ← 'Y))
              (\POSTSCRIPT.ORIENTATION.OPTIONS.MENU (create MENU ITEMS ← '(("Ask" 'ASK 
                                   "Always ask whether to print in Landscape or Portrait Orientation"
                                                                                  )
                                                                           ("Landscape" T 
                                                          "Default printing to Landscape Orientation"
                                                                                  )
                                                                           ("Portrait" 'NIL 
                                                           "Default printing to Portrait Orientation"
                                                                                  ))
                                                           TITLE ← "Default Orientation" CENTERFLG ←
                                                           T))
              PS.BITMAPARRAY \POSTSCRIPT.JOB.SETUP SlopeMenuItems WeightMenuItems)
        [ADDVARS (BackgroundMenuCommands ("PS Orientation" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE
                                                                  (MENU 
                                                                 \POSTSCRIPT.ORIENTATION.OPTIONS.MENU
                                                                        ))
                                                
                                               "Select the default Orientation for PostScript output"
                                                (SUBITEMS ("Ask" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE
                                                                        'ASK)
                                                                 
                                   "Always ask whether to print in Landscape or Portrait Orientation"
                                                                 )
                                                       ("Landscape" '(SETQ 
                                                                          POSTSCRIPT.PREFER.LANDSCAPE
                                                                           T)
                                                              
                                                          "Default printing to Landscape Orientation"
                                                              )
                                                       ("Portrait" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE
                                                                          NIL)
                                                              
                                                           "Default printing to Portrait Orientation"
                                                              ]
        (VARS (BackgroundMenu NIL))
        (CONSTANTS (GOLDEN.RATIO 1.618034)
               (\PS.SCALE0 100)
               (\PS.TEMPARRAYLEN 20))
        (INITVARS (POSTSCRIPT.BITMAP.SCALE 1)
               (POSTSCRIPT.EOL 'CR)
               (POSTSCRIPT.IMAGESIZEFACTOR 1)
               (POSTSCRIPT.PREFER.LANDSCAPE NIL)
               (POSTSCRIPT.TEXTFILE.LANDSCAPE NIL)
               (POSTSCRIPT.DEFAULT.PAGEREGION '(4800 4800 52800 70800))
               (POSTSCRIPT.TEXTURE.SCALE 4))
        (ALISTS (PRINTFILETYPES POSTSCRIPT)
               (IMAGESTREAMTYPES POSTSCRIPT))
        (INITVARS (POSTSCRIPT.PAGETYPE 'LETTER))
        
        (* ;; "NIL means initial clipping is same as paper size.  Don't know why the other regions were specified--rmk")


        [APPENDVARS (POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11)
                                                   NIL
                                                   (-0.1 -0.1 8.7 11.2))
                           (LEGAL (0 0 8.5 14)
                                  NIL
                                  (-0.1 -0.1 8.7 14.2))
                           (NOTE (0 0 8.5 11)
                                 NIL
                                 (-0.1 -0.1 8.7 11.2]
        (GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.EOL 
               POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE 
               \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPTIMAGEOPS 
               POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS)
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (POSTSCRIPT.INIT)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA 
                                                                                POSTSCRIPT.PUTCOMMAND
                                                                                   ])



(* ;; "PostScript printer support for Medley")


(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(DATATYPE \POSTSCRIPTDATA
 
          ((NIL FLAG)                                        (* ; "Was: POSTSCRIPTACCENTED. T if we're to do MCCS-to-PS translations on characters in the current font.")

           POSTSCRIPTFONT                                    (* ; 

                                                             "The fontdescriptor of the current font")

           POSTSCRIPTX                                       (* ; "The current X")

           POSTSCRIPTY                                       (* ; "... and Y")

           POSTSCRIPTLEFTMARGIN                              (* ; "The margins")

           POSTSCRIPTRIGHTMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTLINESPACING 
                                                             (* ; "Line to line spacing")

           POSTSCRIPTCOLOR                                   (* ; 

                                             "Color (or grey shade) in effect; 0.0=black, 1.0=white.")

                                                             (* ; "Now this is an RGB triple")

           POSTSCRIPTSCALE                                   (* ; "Scale of the stream")

           POSTSCRIPTOPERATION                               (* ; 

                                                            "Default operation (PAINT, REPLACE, ...)")

           POSTSCRIPTCLIPPINGREGION                          (* ; 

                                                    "The current region available to be written into")

           POSTSCRIPTPAGENUM                                 (* ; "Current page number")

           POSTSCRIPTHEADING                                 (* ; "The heading")

           POSTSCRIPTHEADINGFONT                             (* ; "Font for the heading")

           POSTSCRIPTSPACEFACTOR                             (* ; 

                                                   "Expansion factor for spaces (see DSPSPACEFACTOR)")

           POSTSCRIPTSPACEWIDTH                              (* ; 

                                                           "The width of a space in the current font")

           POSTSCRIPTLANDSCAPE                               (* ; 

                                                             "non-NIL for paper in 'landscape' mode")

           POSTSCRIPTCHARSTOSHOW                             (* ; 

                   "non-NIL if the string (PostScript-type string) of chars has already been started")

           POSTSCRIPTFONTCHANGEDFLG                          (* ; "Font has changed")

           POSTSCRIPTMOVEFLG                                 (* ; "Need to move")

           POSTSCRIPTWIDTHS                                  (* ; 

                                                             "The widths vector of the current font")

           POSTSCRIPTTRANSX                                  (* ; "Translation in X")

           POSTSCRIPTTRANSY                                  (* ; "... and Y")

           POSTSCRIPTPENDINGXFORM                            (* ; 

                                                    "A userspace to devicespace transform is pending")

           POSTSCRIPTPAGEREGION                              (* ; "The whole page")

           POSTSCRIPTPAGEBLANK                               (* ; "This page is blank flag")

           POSTSCRIPTSCALEHACK                               (* ; 

                            "For \PS.SCALEHACK since DSPSCALE doesn't change the scale of the stream")

           POSTSCRIPTTEMPARRAY                               (* ; 

                                                       "For converting FIXP to string of digit chars")

           POSTSCRIPTXFORMSTACK                              (* ; "The stack of transformations.  DSPPUSHSTATE pushes one onto this, DSPPOPSTATE uses it to reset values.")

           POSTSCRIPTROTATION                                (* ; 

                                                             "Rotation value currently in effect.")

           POSTSCRIPTPENDINGROTATION                         (* ; 

                                                          "Rotation to take effect at next SETXFORM.")

           POSTSCRIPTFONTSUSED                               (* ; "List of FONTIDs of the fonts that've been used before. This is used to control the re-encoding of fonts for accented-character rendering.")

           (POSTSCRIPTMCCSCHARSET BYTE)                      (* ; 

                                               "Current MCCS CHARSET--widths are in POSTSCRIPTWIDTHS")

           (POSTSCRIPTNATURALSPACEWIDTH WORD)                (* ; 

                    "Width of the space in the current font, used to compute the scaled space width.")

           POSTSCRIPTCHARSETMAPPINGBLOCK                     (* ; 

                            "Arrayblock that maps thin codes in the current charset to mapping items")

           )
          POSTSCRIPTX ← 0 POSTSCRIPTY ← 0 POSTSCRIPTTRANSX ← 0 POSTSCRIPTTRANSY ← 0 
          POSTSCRIPTSPACEFACTOR ← 1 POSTSCRIPTPAGENUM ← 0 POSTSCRIPTSCALEHACK ← 1 POSTSCRIPTTEMPARRAY
          ← (ARRAY \PS.TEMPARRAYLEN 'BYTE 0 0)
          POSTSCRIPTROTATION ← 0 POSTSCRIPTCOLOR ← (ENSURE.RGB 'BLACK))

(RECORD POSTSCRIPTXFORM
 (
                         (* ;; "Holds the transformation state as saved by DSPPUSHSTATE.  Used by DSPPOPSTATE to restore the tranformation state.")


                         PSXCLIP                             (* ; "Clipping region")

                         PSXPAGE                             (* ; "Page region")

                         PSXX                                (* ; "X position?")

                         PSXY                                (* ; "Y position?")

                         PSXLEFT                             (* ; "Left margin")

                         PSXRIGHT                            (* ; "Right margin")

                         PSXTOP                              (* ; "Top margin")

                         PSXBOTTOM                           (* ; "Bottom Margin")

                         PSXTRANX                            (* ; "X-translation in effect")

                         PSXTRANY                            (* ; "Y-translation in effect")

                         PSXLAND                             (* ; "Landscape?")

                         PSXXFORMPEND                        (* ; "Are there transforms pending?  ")

                         ))

(ACCESSFNS POSTSCRIPTCSINFO
 ((CHARBLOCK (fetch
 (CHARSETINFO OFFSETS) of
 DATUM)
                                    (replace
 (CHARSETINFO OFFSETS) of
 DATUM with
 NEWVALUE))))
)

(/DECLAREDATATYPE '\POSTSCRIPTDATA
       '(FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
              BYTE WORD POINTER)
       '((\POSTSCRIPTDATA 0 (FLAGBITS . 0))
         (\POSTSCRIPTDATA 0 POINTER)
         (\POSTSCRIPTDATA 2 POINTER)
         (\POSTSCRIPTDATA 4 POINTER)
         (\POSTSCRIPTDATA 6 POINTER)
         (\POSTSCRIPTDATA 8 POINTER)
         (\POSTSCRIPTDATA 10 POINTER)
         (\POSTSCRIPTDATA 12 POINTER)
         (\POSTSCRIPTDATA 14 POINTER)
         (\POSTSCRIPTDATA 16 POINTER)
         (\POSTSCRIPTDATA 18 POINTER)
         (\POSTSCRIPTDATA 20 POINTER)
         (\POSTSCRIPTDATA 22 POINTER)
         (\POSTSCRIPTDATA 24 POINTER)
         (\POSTSCRIPTDATA 26 POINTER)
         (\POSTSCRIPTDATA 28 POINTER)
         (\POSTSCRIPTDATA 30 POINTER)
         (\POSTSCRIPTDATA 32 POINTER)
         (\POSTSCRIPTDATA 34 POINTER)
         (\POSTSCRIPTDATA 36 POINTER)
         (\POSTSCRIPTDATA 38 POINTER)
         (\POSTSCRIPTDATA 40 POINTER)
         (\POSTSCRIPTDATA 42 POINTER)
         (\POSTSCRIPTDATA 44 POINTER)
         (\POSTSCRIPTDATA 46 POINTER)
         (\POSTSCRIPTDATA 48 POINTER)
         (\POSTSCRIPTDATA 50 POINTER)
         (\POSTSCRIPTDATA 52 POINTER)
         (\POSTSCRIPTDATA 54 POINTER)
         (\POSTSCRIPTDATA 56 POINTER)
         (\POSTSCRIPTDATA 58 POINTER)
         (\POSTSCRIPTDATA 60 POINTER)
         (\POSTSCRIPTDATA 62 POINTER)
         (\POSTSCRIPTDATA 64 POINTER)
         (\POSTSCRIPTDATA 66 (BITS . 7))
         (\POSTSCRIPTDATA 67 (BITS . 15))
         (\POSTSCRIPTDATA 68 POINTER))
       '70)
)

(/DECLAREDATATYPE '\POSTSCRIPTDATA
       '(FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
              BYTE WORD POINTER)
       '((\POSTSCRIPTDATA 0 (FLAGBITS . 0))
         (\POSTSCRIPTDATA 0 POINTER)
         (\POSTSCRIPTDATA 2 POINTER)
         (\POSTSCRIPTDATA 4 POINTER)
         (\POSTSCRIPTDATA 6 POINTER)
         (\POSTSCRIPTDATA 8 POINTER)
         (\POSTSCRIPTDATA 10 POINTER)
         (\POSTSCRIPTDATA 12 POINTER)
         (\POSTSCRIPTDATA 14 POINTER)
         (\POSTSCRIPTDATA 16 POINTER)
         (\POSTSCRIPTDATA 18 POINTER)
         (\POSTSCRIPTDATA 20 POINTER)
         (\POSTSCRIPTDATA 22 POINTER)
         (\POSTSCRIPTDATA 24 POINTER)
         (\POSTSCRIPTDATA 26 POINTER)
         (\POSTSCRIPTDATA 28 POINTER)
         (\POSTSCRIPTDATA 30 POINTER)
         (\POSTSCRIPTDATA 32 POINTER)
         (\POSTSCRIPTDATA 34 POINTER)
         (\POSTSCRIPTDATA 36 POINTER)
         (\POSTSCRIPTDATA 38 POINTER)
         (\POSTSCRIPTDATA 40 POINTER)
         (\POSTSCRIPTDATA 42 POINTER)
         (\POSTSCRIPTDATA 44 POINTER)
         (\POSTSCRIPTDATA 46 POINTER)
         (\POSTSCRIPTDATA 48 POINTER)
         (\POSTSCRIPTDATA 50 POINTER)
         (\POSTSCRIPTDATA 52 POINTER)
         (\POSTSCRIPTDATA 54 POINTER)
         (\POSTSCRIPTDATA 56 POINTER)
         (\POSTSCRIPTDATA 58 POINTER)
         (\POSTSCRIPTDATA 60 POINTER)
         (\POSTSCRIPTDATA 62 POINTER)
         (\POSTSCRIPTDATA 64 POINTER)
         (\POSTSCRIPTDATA 66 (BITS . 7))
         (\POSTSCRIPTDATA 67 (BITS . 15))
         (\POSTSCRIPTDATA 68 POINTER))
       '70)
(DEFINEQ

(POSTSCRIPT.INIT

  [LAMBDA NIL
                                                (* ; "Edited  2-Oct-2026 18:17 by rmk")


                                                             (* ; "Edited 29-Sep-2026 17:14 by rmk")


                                                             (* ; "Edited 19-Sep-2026 09:23 by rmk")


                                                             (* ; "Edited 13-Sep-2026 21:44 by rmk")


                                                             (* ; "Edited  9-Sep-2026 00:34 by rmk")


                                                             (* ; "Edited 31-Aug-2026 11:05 by rmk")


                                                             (* ; "Edited 31-Dec-2025 22:38 by rmk")


                                                             (* ; "Edited  9-Sep-2025 21:57 by rmk")


                                                             (* ; "Edited 22-Aug-2025 21:34 by rmk")


                                                            (* ; "Edited 14-May-2018 10:48 by rmk:")


                                                             (* ; "Edited  4-Feb-93 21:08 by jds")


    (* ;; "Add POSTSCRIPT font descriptions to the active font profile.")


    (POSTSCRIPT.INIT.FONTPROFILE
)

    (* ;; "Eliminate any existing postscript fonts, to start with a clean slate if reinitializing.")

                                                             (* ; "Blocks indexed by charencoding")

    (FLUSHFONTCACHE NIL '* '* '* '* 'POSTSCRIPT)
    [SETQ *POSTSCRIPT-MAPPING-BLOCKS* (LIST (CONS 'MCCS (POSTSCRIPT.MCCS.BLOCKS
 
                                                               *POSTSCRIPT-MCCS-TRANSLATIONS*))
                                            (CONS 'ZAPFDINGBATS (POSTSCRIPT.ZAPFDINGBATS.BLOCKS
]
    (SETQ \POSTSCRIPTIMAGEOPS (create
 IMAGEOPS
                                     IMAGETYPE ← 'POSTSCRIPT
                                     IMCLOSEFN ← (FUNCTION CLOSEPOSTSCRIPTSTREAM)
                                     IMXPOSITION ← (FUNCTION \DSPXPOSITION.PSC)
                                     IMYPOSITION ← (FUNCTION \DSPYPOSITION.PSC)
                                     IMMOVETO ← (FUNCTION \MOVETO.PSC)
                                     IMFONT ← (FUNCTION \DSPFONT.PSC)
                                     IMLEFTMARGIN ← (FUNCTION \DSPLEFTMARGIN.PSC)
                                     IMRIGHTMARGIN ← (FUNCTION \DSPRIGHTMARGIN.PSC)
                                     IMLINEFEED ← (FUNCTION \DSPLINEFEED.PSC)
                                     IMDRAWLINE ← (FUNCTION \DRAWLINE.PSC)
                                     IMDRAWCURVE ← (FUNCTION \DRAWCURVE.PSC)
                                     IMDRAWCIRCLE ← (FUNCTION \DRAWCIRCLE.PSC)
                                     IMDRAWELLIPSE ← (FUNCTION \DRAWELLIPSE.PSC)
                                     IMFILLCIRCLE ← (FUNCTION \FILLCIRCLE.PSC)
                                     IMBLTSHADE ← (FUNCTION \BLTSHADE.PSC)
                                     IMBITBLT ← (FUNCTION \BITBLT.PSC)
                                     IMSCALEDBITBLT ← (FUNCTION \SCALEDBITBLT.PSC)
                                     IMNEWPAGE ← (FUNCTION \NEWPAGE.PSC)
                                     IMSCALE ← (FUNCTION \DSPSCALE.PSC)
                                     IMSCALE2 ← (FUNCTION \DSPSCALE2.PSC)
                                     IMCOLOR ← (FUNCTION \DSPCOLOR.PSC)
                                     IMTERPRI ← (FUNCTION \TERPRI.PSC)
                                     IMTOPMARGIN ← (FUNCTION \DSPTOPMARGIN.PSC)
                                     IMBOTTOMMARGIN ← (FUNCTION \DSPBOTTOMMARGIN.PSC)
                                     IMSPACEFACTOR ← (FUNCTION \DSPSPACEFACTOR.PSC)
                                     IMFONTCREATE ← 'POSTSCRIPT
                                     IMCLIPPINGREGION ← (FUNCTION \DSPCLIPPINGREGION.PSC)
                                     IMRESET ← (FUNCTION \DSPRESET.PSC)
                                     IMDRAWPOLYGON ← (FUNCTION \DRAWPOLYGON.PSC)
                                     IMFILLPOLYGON ← (FUNCTION \FILLPOLYGON.PSC)
                                     IMSTRINGWIDTH ← (FUNCTION \STRINGWIDTH.PSC)
                                     IMCHARWIDTH ← (FUNCTION \CHARWIDTH.PSC)
                                     IMDRAWARC ← (FUNCTION \DRAWARC.PSC)
                                     IMROTATE ← (FUNCTION \DSPROTATE.PSC)
                                     IMTRANSLATE ← (FUNCTION \DSPTRANSLATE.PSC)
                                     IMDRAWPOINT ← (FUNCTION \DRAWPOINT.PSC)
                                     IMPUSHSTATE ← (FUNCTION \DSPPUSHSTATE.PSC)
                                     IMPOPSTATE ← (FUNCTION \DSPPOPSTATE.PSC])

(POSTSCRIPT.INIT.FONTPROFILE

  [LAMBDA NIL
                                                (* ; "Edited 29-Sep-2026 17:09 by rmk")


    (* ;; "Add POSTSCRIPT font descriptions to the active font profile.")


    [for
 CLASS COPYFD OLDPSCFD
       in
 [CL:REMOVE-DUPLICATES (NCONC (for
 FD in
 FONTDEFS
                                          join
 (for
 FP in
 (CDR (ASSOC 'FONTPROFILE (CDR FD)))
                                                  collect
 (CAR FP)))
                                       '(FONT7 FONT6 FONT5 FONT4 FONT3 FONT2 FONT1 BOLDFONT 
                                               LITTLEFONT BIGFONT PRETTYCOMFONT COMMENTFONT USERFONT
                                               SYSTEMFONT CLISPFONT LAMBDAFONT CHANGEFONT DEFAULTFONT
                                               ] when
 (BOUNDP CLASS)
       do
 (SETQ CLASS (EVALV CLASS))
          (CL:WHEN (TYPEP CLASS 'FONTCLASS)
              (SETQ COPYFD (OR (fetch
 (FONTCLASS INTERPRESSFD) of
 CLASS)
                               (fetch
 (FONTCLASS DISPLAYFD) of
 CLASS)))
              [if
 (SETQ OLDPSCFD (ASSOC 'POSTSCRIPT (fetch
 (FONTCLASS OTHERFDS) of
 CLASS)))
                  then
 (CL:UNLESS (CDR OLDPSCFD)
                           (RPLACD OLDPSCFD (if
 (LISTP COPYFD)
                                                then
 COPYFD
                                              else
 (FONTUNPARSE COPYFD))))
                else
 (push
 (fetch
 (FONTCLASS OTHERFDS) of
 CLASS)
                           (CONS 'POSTSCRIPT (if
 (LISTP COPYFD)
                                                 then
 COPYFD
                                               else
 (FONTUNPARSE COPYFD])]
    [for
 FD in
 FONTDEFS do
 (for
 FP in
 (CDR (ASSOC 'FONTPROFILE (CDR FD)))
                              unless
 (ASSOC 'POSTSCRIPT (CL:NTHCDR 5 FP))
                              do
 
                                 (* ;; "If there's already a postscript spec, leave it be.")


                                 (NCONC1 FP `(POSTSCRIPT ,(OR (CL:FIFTH FP)
                                                              (CL:FOURTH FP)
                                                              (CL:THIRD FP]
    (FONTPROFILE.ADDDEVICE 'POSTSCRIPT 'INTERPRESS])

(POSTSCRIPT.PUTRGBCOLOR

  [LAMBDA (STREAM COLOR EOL?)
                                (* ; "Edited  5-Jun-2025 14:06 by mth")


                                                             (* ; "Edited 28-Apr-2025 00:02 by mth")


                                                             (* ; "Edited 26-Apr-2025 17:16 by mth")

    (AND COLOR (CL:MULTIPLE-VALUE-BIND (RGB GRAY COLORSTR)
                      (\PSC.COLOR.TO.RGB
 COLOR (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCOLOR)
                                                  of
 (fetch
 IMAGEDATA of
 STREAM)))
                      (CL:WHEN RGB                           (* ; "A valid color designation")

                          (POSTSCRIPT.PUTCOMMAND
 STREAM COLORSTR (OR (AND GRAY " setgray ")
                                                                     " setrgbcolor ")
                                 (AND EOL? :EOL)))

                      (* ;; "Return the RGB color")


                      RGB])

(\PSC.COLOR.TO.RGB

  [LAMBDA (COLOR DEFAULTRGB NOERRORFLG?)
                     (* ; "Edited  5-Jun-2025 16:03 by mth")


                                                             (* ; "Edited 31-May-2025 17:20 by mth")


                                                             (* ; "Edited 28-Apr-2025 00:10 by mth")

    (LET (RGB STR)
         (COND
            ((OR (EQ COLOR 0)
                 (EQ COLOR 1)
                 (AND (FLOATP COLOR)
                      (<= 0.0 COLOR 1.0)))

             (* ;; "The SMALLP values 0 and 1 can be checked with EQ")


             (SETQ RGB (FIX (FTIMES COLOR 255)))
             (SETQ STR (CL:FORMAT NIL "~F " RGB))
             (SETQ RGB (LIST RGB RGB RGB)))
            ([OR (NULL COLOR)
                 (AND (FIXP COLOR)
                      (<= 2 COLOR (CONSTANT (MAXIMUMCOLOR 24]

             (* ;; "Ignore any other FIXP that could be a COLORNUMBER")


             (* ;; 

             "or an RGB encoded as a single FIXP. Just use the DEFAULTRGB which MUST be a valid RGB!")


             (SETQ RGB DEFAULTRGB))
            ((SETQ RGB (ENSURE.RGB COLOR NOERRORFLG?)))
            (T 
               (* ;; " Shouldn't ever get here.")


               (* ;; " ENSURE.RGB above handled the color name, RGB, and HLS cases.")


               (* ;; "Depending on NOERRORFLG?, it will give the error for anything else invalid")


               NIL))
         (CL:WHEN RGB
             [SETQ STR (OR STR (IF
 (AND (EQ (CAR RGB)
                                            (CADR RGB))
                                        (EQ (CAR RGB)
                                            (CADDR RGB)))
                                   THEN
 
                                        (* ;; "They're all equal, this is gray.")


                                        (CL:FORMAT NIL "~F " (SETQ COLOR (FQUOTIENT (CAR RGB)
                                                                                255.0)))
                                 ELSE
 (SETQ COLOR NIL)       (* ; "Means NOT gray")

                                      (CL:FORMAT NIL "~D ~D ~D " (CAR RGB)
                                             (CADR RGB)
                                             (CADDR RGB])
         (CL:VALUES RGB COLOR STR (NOT (EQUAL RGB DEFAULTRGB])
)



(* ; "PSCFONT-reading code")


(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD FONTID
 (FONTIDNAME FONTXFACTOR FONTOBLIQUEFACTOR))

(RECORD PSCFONT
 (FID IL-FONTID FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTHS))
)
)
(DEFINEQ

(PSCFONT.READFONT

  [LAMBDA (FONTFILENAME)
                                     (* ; "Edited 12-Feb-2026 12:01 by mth")


                                                             (* ; "Edited  5-Oct-93 17:19 by rmk:")


                                                             (* ; "Edited  1-Sep-89 10:55 by jds")


    (* ;; "Read one of Matt Heffron's .PSC files, to get postscript font metrics.  First check to see if incore cache has information indexed under the file's name.")


    (LET (FID W [S (OPENSTREAM FONTFILENAME 'INPUT NIL '((SEQUENTIAL T]
              (PF (create
 PSCFONT))
              (*PACKAGE* (CL:FIND-PACKAGE "INTERLISP")))
         [replace
 (PSCFONT FID) of
 PF with
 (SETQ FID (READ S (FIND-READTABLE "INTERLISP"]

         (* ;; "Read until we hit a 255 byte, marking the end of the font-id section.")


         (CL:DO NIL
                ((EQ (BIN S)
                     255))

             (* ;; "Body of the loop is empty, the test does all of the work")


             )
         (replace
 (PSCFONT IL-FONTID) of
 PF with
 (CAR FID))
         (replace
 (PSCFONT FIRSTCHAR) of
 PF with
 (\WIN S))
         (replace
 (PSCFONT LASTCHAR) of
 PF with
 (\WIN S))
         (replace
 (PSCFONT ASCENT) of
 PF with
 (\WIN S))
         (replace
 (PSCFONT DESCENT) of
 PF with
 (\WIN S))
         (replace
 (PSCFONT WIDTHS) of
 PF with
 (SETQ W (ARRAY 256 'SMALLPOSP 0 0)))
         (for
 C from
 0 to
 255 do
 (SETA W C (\WIN S)))
         (CLOSEF S)

         (* ;; 

       "PATCH JDS 9/1/89:  The afm font reader made fonts too tall.  This should fix things pro tem.")


         (replace
 (PSCFONT ASCENT) of
 PF with
 (- 1000 (fetch
 (PSCFONT DESCENT) OF
 PF)))
         (PUSH
 POSTSCRIPTFONTCACHE (CONS (L-CASE (FILENAMEFIELD FONTFILENAME 'NAME))
                                         (CREATE
 PSCFONT USING
 PF)))
         PF])

(PSCFONT.FILEP

  [LAMBDA (FILE)
                                             (* ; "Edited 31-Aug-2026 01:00 by rmk")

    (STRING.EQUAL 'PSCFONT (FILENAMEFIELD FILE 'EXTENSION])

(PSCFONT.WRITEFONT

  [LAMBDA (FONTFILENAME PF)                                  (* ; 

                                                        "Edited  5-Aug-93 16:28 by sybalskY:MV:ENVOS")


    (* ;; "Given a PSCFONT data structure, write it out as a properly-named xxx.PSCFONT file, for later reading.")


    NIL
    (LET ([S (OPENSTREAM FONTFILENAME 'OUTPUT NIL '((TYPE BINARY)
                                                    (SEQUENTIAL T]
          (W (fetch
 (PSCFONT WIDTHS) of
 PF))
          (*READTABLE* (FIND-READTABLE "INTERLISP")))
         (PRIN3 (fetch
 (PSCFONT FID) of
 PF)
                S)
         (BOUT S 0)
         (BOUT S 255)
         (\WOUT S (fetch
 (PSCFONT FIRSTCHAR) of
 PF))
         (\WOUT S (fetch
 (PSCFONT LASTCHAR) of
 PF))
         (\WOUT S (fetch
 (PSCFONT ASCENT) of
 PF))
         (\WOUT S (fetch
 (PSCFONT DESCENT) of
 PF))
         (for
 C from
 0 to
 255 do
 (\WOUT S (ELT W C)))
         (CLOSEF S)
         FONTFILENAME])

(PSCFONT.FILENAME

  [LAMBDA (FILE/FSPEC FROMDIR)
                               (* ; "Edited 17-Sep-2026 10:46 by rmk")

    (PACKFILENAME 'BODY (if
 (type?
 FONTSPEC FILE/FSPEC)
                            then
 (FILENAMEFROMFONTSPEC (\FONT.CHECKARGS (CL:IF (FSPROP FILE/FSPEC 
                                                                                      FSSIZE)
                                                                            FILE/FSPEC
                                                                            (create
 FONTSPEC
                                                                               using
 FILE/FSPEC 
                                                                                     FSSIZE ← 0))
                                                              NIL NIL NIL NIL T))
                          else
 FILE/FSPEC)
           'DIRECTORY
           (OR FROMDIR "{FONTSOURCE}/postscript/source/")
           'EXTENSION
           'PSCFONT])

(READ-AFM-FILE

  [LAMBDA (FILE BOLDNESS ITALICNESS)                         (* ; 

                                                        "Edited  5-Aug-93 16:37 by sybalskY:MV:ENVOS")


    (* ;; 

    "Read an Adobe-version-3 AFM file, and extract the metrics from it for making a PSCFONT file.")


    (LET ((IFILE (OPENSTREAM FILE 'INPUT))
          (PSCFONT (create
 PSCFONT))
          (FCHAR 1000)
          (LCHAR 0)
          (W (ARRAY 256 'SMALLPOSP 0 0))
          TOKEN WEIGHT SLOPE HEIGHT CMCOUNT FBBOX)
         (with
 PSCFONT PSCFONT (repeatuntil
 (STRING-EQUAL "FontName" (RSTRING IFILE))
                                  do
 (READCCODE IFILE))
               (repeatwhile
 (STRING-EQUAL "" (SETQ TOKEN (RSTRING IFILE))) do
 (READCCODE IFILE))
               [COND
                  ((NOT (AND (BOUNDP 'WeightMenu)
                             (type?
 MENU WeightMenu)))
                   (SETQ WeightMenu (create
 MENU
                                           ITEMS ← WeightMenuItems
                                           MENUFONT ← (FONTCREATE 'HELVETICA 12]
               [COND
                  ((NOT (AND (BOUNDP 'SlopeMenu)
                             (type?
 MENU SlopeMenu)))
                   (SETQ SlopeMenu (create
 MENU
                                          ITEMS ← SlopeMenuItems
                                          MENUFONT ← (FONTCREATE 'HELVETICA 12]
               (OR (SETQ WEIGHT BOLDNESS)
                   (printout T T "Font WEIGHT for " PSCFONT ": " (SETQ WEIGHT (MENU WeightMenu))
                          T))
               (OR (SETQ SLOPE ITALICNESS)
                   (printout T T "Font SLOPE for " PSCFONT ": " (SETQ SLOPE (MENU SlopeMenu))
                          T))
               (SETQ FID (LIST TOKEN WEIGHT SLOPE 'REGULAR))
               [SETQ IL-FONTID (COND
                                  ((AND (EQ SLOPE 'REGULAR)
                                        (EQ WEIGHT 'MEDIUM))
                                   TOKEN)
                                  (T (POSTSCRIPT.GETFONTID
 FID WEIGHT SLOPE 'REGULAR]
               [repeatuntil
 (STRING-EQUAL "StartCharMetrics" TOKEN)
                  do
 (SETQ TOKEN (RSTRING IFILE))
                     (COND
                        [(STRING-EQUAL "FontBBox" TOKEN)
                         (SETQ FBBOX (LIST (READ IFILE)
                                           (READ IFILE)
                                           (READ IFILE)
                                           (READ IFILE)))

                         (* ;; "The Ascender and Descender properties from the AFM file are currently ignored, and the values from the FontBBox are used, SCALED to the height of the font.")


                         (SETQ DESCENT (IABS (CADR FBBOX)))
                         (SETQ ASCENT (CADDDR FBBOX))
                         (SETQ HEIGHT (IPLUS ASCENT DESCENT))
                         [SETQ DESCENT (FIXR (FTIMES DESCENT (/ 1000 HEIGHT]
                         (SETQ ASCENT (FIXR (FTIMES ASCENT (/ 1000 HEIGHT]
                        (T (READCCODE IFILE]
               (SETQ CMCOUNT (RATOM IFILE))
               (repeatuntil
 (EQ (CHARCODE EOL)
                                (READCCODE IFILE)) do
)
               (SETQ WIDTHS W)
               (for
 CC from
 1 to
 CMCOUNT
                  do
 (LET (CCODE)
                          (repeatuntil
 (EQ 'C (RATOM IFILE)) do
)
                          (SETQ CCODE (READ IFILE))
                          (RATOMS 'WX IFILE)
                          (SETQ CWIDTH (READ IFILE))
                          [COND
                             ((CL:PLUSP CCODE)               (* ; 

                         "This character appears in the standard encoding, so just use the charcode.")

                              (COND
                                 ((ILESSP CCODE FCHAR)
                                  (SETQ FCHAR CCODE)))
                              (COND
                                 ((IGREATERP CCODE LCHAR)
                                  (SETQ LCHAR CCODE)))
                              (SETA W CCODE CWIDTH))
                             (T                              (* ; "A character not in the standard encoding; look it up to see if it's one we need (eth & thorn are brought into the CS-0 codespace for UToronto's work).")

                                (repeatuntil
 (EQ 'N (RATOM IFILE)) do
 
                                                                      (* ;; 

                                          "Skip to the N entry, which gives the Adobe-standard name.")

)
                                (SETQ CNAME (RATOM IFILE))   (* ; "GET THE NAME")

                                (SETQ CCODE (LISTGET *POSTSCRIPT-EXTRA-CHARACTERS* CNAME))
                                (COND
                                   (CCODE (COND
                                             ((ILESSP CCODE FCHAR)
                                              (SETQ FCHAR CCODE)))
                                          (COND
                                             ((IGREATERP CCODE LCHAR)
                                              (SETQ LCHAR CCODE)))
                                          (SETA W CCODE CWIDTH]
                          (repeatuntil
 (EQ (CHARCODE EOL)
                                           (READCCODE IFILE)) do
)))
               (SETQ FIRSTCHAR FCHAR)
               (SETQ LASTCHAR LCHAR))
         (CLOSEF IFILE)
         PSCFONT])

(CONVERT-AFM-FILES

  [LAMBDA (FILE-LIST)
                                        (* ; "Edited  4-Sep-2026 15:33 by rmk")

                                                             (* ; 

                                                        "Edited  5-Aug-93 16:47 by sybalskY:MV:ENVOS")

    (for
 FL in
 FILE-LIST do
 (LET ((FNAME (pop
 FL))
                                  FONT FILENAME)
                                 (for
 AFM-FILE in
 FL as
 WEIGHT
                                    in
 '(MEDIUM MEDIUM BOLD BOLD) as
 SLOPE
                                    in
 '(REGULAR ITALIC REGULAR ITALIC)
                                    do
 (SETQ FONT (READ-AFM-FILE
 AFM-FILE WEIGHT SLOPE)) 
                                                             (* ; 

                                                             "Size 0 denotes an unscaled source.")

                                       [SETQ FILENAME (CAR (FONTFILES (MAKEFONTSPEC
                                                                       FNAME 0 (MAKEFONTFACE
                                                                                WEIGHT SLOPE
                                                                                'REGULAR)
                                                                       0
                                                                       'PSCFONT]
                                       (PSCFONT.WRITEFONT
 FILENAME FONT])

(POSTSCRIPT.GETFONTID

  [LAMBDA (FID WEIGHT SLOPE EXPANSION)
                       (* ; "Edited 30-Aug-2026 01:00 by rmk")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:04 by sybalsky:mv:envos")

    (LET (FONTID)
         (SETQ FONTID (create
 FONTID
                             FONTIDNAME ← (CAR FID)
                             FONTXFACTOR ← 1.0
                             FONTOBLIQUEFACTOR ← 0.0))
         (CL:WHEN (AND (NEQ (CADDR FID)
                            SLOPE)
                       (EQ SLOPE 'ITALIC))
             (replace
 (FONTID FONTOBLIQUEFACTOR) of
 FONTID with
 (CONSTANT (TAN 7.0))))
         (CL:WHEN (AND (NEQ (CADR FID)
                            WEIGHT)
                       (EQ WEIGHT 'BOLD))                    (* ; "Fake bold by slight expansion.")

             (replace
 (FONTID FONTXFACTOR) of
 FONTID with
 1.1))
         (CL:UNLESS (EQ EXPANSION 'REGULAR)
             (replace
 (FONTID FONTXFACTOR) of
 FONTID
                with
 (TIMES (fetch
 (FONTID FONTXFACTOR) of
 FONTID)
                            (if
 (EQ EXPANSION 'COMPRESSED)
                                then
 (CONSTANT (QUOTIENT 1.0 GOLDEN.RATIO))
                              else
 GOLDEN.RATIO))))
         FONTID])

(PSCFONT.TO.FONTDESCRIPTOR

  [LAMBDA (FILE/FSPEC FROMDIR)
                               (* ; "Edited  6-Oct-2026 22:31 by rmk")


                                                             (* ; "Edited  2-Oct-2026 16:45 by rmk")


                                                             (* ; "Edited 30-Sep-2026 09:13 by rmk")


                                                             (* ; "Edited 21-Sep-2026 09:42 by rmk")


                                                             (* ; "Edited 19-Sep-2026 11:30 by rmk")


                                                             (* ; "Edited 17-Sep-2026 10:54 by rmk")


                                                             (* ; "Edited 13-Sep-2026 16:17 by rmk")


                                                             (* ; "Edited  4-Sep-2026 20:45 by rmk")


                                                             (* ; "Edited  2-Sep-2026 14:34 by rmk")


                                                             (* ; "Edited 29-Jul-2026 16:04 by rmk")


                                                             (* ; "Edited  9-Jul-2026 12:17 by rmk")


                                                             (* ; "Edited  3-May-2026 22:38 by rmk")


                                                             (* ; "Edited 16-Apr-2026 22:37 by rmk")


                                                             (* ; "Edited 12-Apr-2026 13:22 by rmk")


                                                             (* ; "Edited 31-Mar-2026 15:01 by rmk")


                                                             (* ; "Edited 28-Mar-2026 09:27 by rmk")


    (* ;; "Converts PSCFONTS to unscaled Medley fontdescriptors.")


    (CL:WHEN (AND (type?
 FONTSPEC FILE/FSPEC)
                  (NOT (FSPROP FILE/FSPEC FSSIZE)))
        (SETQ FILE/FSPEC (create
 FONTSPEC using
 FILE/FSPEC FSSIZE ← 0)))
    (PROG (FONTSPEC FILENAME PSCFONT FAMILY SIZE FACE ROTATION DEVICE PSCWIDTHSBLOCK FD ASCENT 
                 DESCENT SYMFONT DINGFONT SYMWIDTHS DINGWIDTHS MAPPINGBLOCKS CHARENCODING)
          (SETQ FILENAME (PSCFONT.FILENAME
 FILE/FSPEC FROMDIR))
          (SETQ FONTSPEC (\FONT.CHECKARGS (FONTSPECFROMFILENAME FILENAME 'PSCFONT)
                                NIL NIL NIL NIL T))
          (SETQ PSCFONT (PSCFONT.READFONT
 FILENAME))
          (CL:UNLESS PSCFONT (RETURN NIL))

     (* ;; "")


          (CL:WHEN (SETQ FILENAME (INFILEP (PSCFONT.FILENAME
 (create
 FONTSPEC using
 FONTSPEC FSFAMILY
                                                                                    ← 'SYMBOL)
                                                  FROMDIR)))
              (SETQ SYMFONT (PSCFONT.READFONT
 FILENAME))
              (SETQ SYMWIDTHS (fetch
 (PSCFONT WIDTHS) of
 SYMFONT)))
          (CL:WHEN (SETQ FILENAME (INFILEP (PSCFONT.FILENAME
 (create
 FONTSPEC using
 FONTSPEC FSFAMILY
                                                                                    ← 'ZAPFDINGBATS)
                                                  FROMDIR)))
              (SETQ DINGFONT (PSCFONT.READFONT
 FILENAME))
              (SETQ DINGWIDTHS (fetch
 (PSCFONT WIDTHS) of
 DINGFONT)))
          (SPREADFONTSPEC FONTSPEC)
          (SETQ CHARENCODING (SELECTQ FAMILY
                                 (SYMBOL 'PSSYMBOL)
                                 ((ZAPFCHANCERY ZAPFDINGBAT DANCER) 
                                      FAMILY)
                                 'MCCS))
          (SETQ ASCENT (fetch
 (PSCFONT ASCENT) of
 PSCFONT))  (* ; "Not divided by 10")

          (SETQ DESCENT (fetch
 (PSCFONT DESCENT) of
 PSCFONT))
          (CL:WHEN (EQ CHARENCODING 'MCCS)                   (* ; 

                                                       "Anticipate SYMBOL and ZAPFDINGBAT characters")

              (CL:WHEN SYMFONT
                  (SETQ ASCENT (IMAX ASCENT (fetch
 (PSCFONT ASCENT) of
 SYMFONT)))
                  (SETQ DESCENT (IMAX DESCENT (fetch
 (PSCFONT DESCENT) of
 SYMFONT))))
              (CL:WHEN DINGFONT
                  (SETQ ASCENT (IMAX ASCENT (fetch
 (PSCFONT ASCENT) of
 DINGFONT)))
                  (SETQ DESCENT (IMAX DESCENT (fetch
 (PSCFONT DESCENT) of
 DINGFONT)))))
          (SETQ FD (create
 FONTDESCRIPTOR
                          OTHERDEVICEFONTPROPS ← `((PSCFONT \, (create
 PSCFONT
                                                                  using
 PSCFONT WIDTHS ← NIL)))
                          FONTSCALE ← 100
                          FONTDEVICE ← 'POSTSCRIPT
                          FONTFAMILY ← FAMILY
                          FONTSIZE ← SIZE
                          FONTFACE ← FACE
                          ROTATION ← 0
                          FONTHEIGHT ← (IPLUS ASCENT DESCENT)
                          FONTASCENT ← ASCENT
                          FONTDESCENT ← DESCENT
                          FONTCHARENCODING ← CHARENCODING))
          [replace
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FD with
 (FIXR (FTIMES 0.7 (FONTPROP
                                                                                   FD
                                                                                   'HEIGHT]
          (\SETCHARSETINFO FD 0 (create
 CHARSETINFO
                                       CHARSETASCENT ← ASCENT
                                       CHARSETDESCENT ← DESCENT
                                       CHARSETNO ← 0))

     (* ;; "PSCWIDTHSBLOCK preserves the values from the original postscript metrics. The widths for the corresponding MCCS codes is incrementally installed into the WIDTHS of the CHARSETINFO.  ")


          (SETQ PSCWIDTHSBLOCK (\CREATECSINFOELEMENT))
          (for
 CH (WARRAY ← (fetch
 (PSCFONT WIDTHS) of
 PSCFONT)) from
 0 to
 \MAXTHINCHAR
             do
 (\FSETWIDTH PSCWIDTHSBLOCK CH (ELT WARRAY CH)))
          (for
 CH from
 0 to
 \MAXTHINCHAR do
 (\FSETCHARWIDTH FD CH (\FGETWIDTH PSCWIDTHSBLOCK CH)))

     (* ;; "Now run thru the mapping table, filling in the widths of the MCCS CODEs from the widths of the CODE2 postscript codes that will render them.   (We could also install the blocks here, but that would just copy them to the imported file.  Those are installed at getcharset time.")


          [SETQ MAPPINGBLOCKS (CDR (OR (ASSOC CHARENCODING *POSTSCRIPT-MAPPING-BLOCKS*)
                                       (ASSOC 'MCCS *POSTSCRIPT-MAPPING-BLOCKS*]
          [for
 BLOCK CHARSET in
 MAPPINGBLOCKS
             do
 (SETQ CHARSET (CAR BLOCK))
                (CL:UNLESS (\GETCHARSETINFO FD CHARSET)      (* ; 

                                                       "Insure a widths-only charsetinfo, to fill in")

                    (CHARSETPROP (\SETCHARSETINFO FD CHARSET (create
 CHARSETINFO
                                                                    CHARSETNO ← CHARSET))
                           'CSCHARENCODING CHARENCODING))
                (SETQ BLOCK (CDR BLOCK))
                (for
 CODE ITEM CODE2 BASECHAR from
 (FIRSTCHARSETCODE CHARSET)
                   to
 (LASTCHARSETCODE CHARSET)
                   do
 (SETQ ITEM (\GETBASEPTR BLOCK (UNFOLD (\CHAR8CODE CODE)
                                                           WORDSPERCELL)))
                      (SETQ CODE2 (CADR ITEM)) 

                      (* ;; "Process depends on the kind of item:")


                      (SELECTQ (CAR ITEM)
                          ((BOUT ESCAPE) 
                                         (* ;; "Translate an MCCS CODE to a PSC char in CS 0.")


                               (\FSETCHARWIDTH FD CODE (\FGETWIDTH PSCWIDTHSBLOCK (\CHAR8CODE CODE2))
                                      ))
                          (SPECIAL (SELECTQ (CADDR ITEM)
                                       (SYMBOL [AND SYMWIDTHS (\FSETCHARWIDTH FD CODE
                                                                     (ELT SYMWIDTHS (\CHAR8CODE
                                                                                     CODE2])
                                       (ZAPFDINGBATS [AND DINGWIDTHS (\FSETCHARWIDTH
                                                                      FD CODE (ELT DINGWIDTHS
                                                                                   (\CHAR8CODE CODE2])
                                       (SHOULDNT)))
                          (FUNCTION 
                                    (* ;; 

           "This is fake and only works for fractions.  Need a better case.  What is 164 in PSCFONT?")


                                    [\FSETCHARWIDTH FD CODE (IPLUS (\FGETWIDTH PSCWIDTHSBLOCK 164)
                                                                   (FIXR (FTIMES 1.3
                                                                                (\FGETWIDTH
                                                                                 PSCWIDTHSBLOCK
                                                                                 (CHARCODE 1])
                          (ACCENT                            (* ; 

                            "CODE2 is the rendering character but width comes from width of basechar")

                                  (\FSETCHARWIDTH FD CODE (\FGETWIDTH PSCWIDTHSBLOCK (CADDR ITEM))))
                          (ACCENTPAIR 
                                      (* ;; "CODE2 and BASECHAR are overprinted, width is taken from CODE2 (the real character), basechar is the accent")


                                      (\FSETCHARWIDTH FD CODE (\FGETWIDTH PSCWIDTHSBLOCK CODE2)))
                          ((SLUG APPLY* REPOSITION) 

                                 (* ;; "Skip APPLY*'s on this pass, waiting until normal characters get set up, so that widths of other XCCS$ characters are available.  Slugs will be done at part of the \SLUGSETUP")


                               )
                          (SHOULDNT "Bad postscript mapping"]

     (* ;; "Now do APPLY*'s.  ITEM is of the form ('APPLY* DATA PRINTFN WIDTHFN). WIDTHFN gets applied to FD and DATA (coerced by INITFN)")


          [for
 BLOCK CHARSET in
 MAPPINGBLOCKS do
 (SETQ CHARSET (CAR BLOCK))
                                                 (SETQ BLOCK (CDR BLOCK))
                                                 (for
 CODE ITEM from
 (FIRSTCHARSETCODE CHARSET)
                                                    to
 (LASTCHARSETCODE CHARSET)
                                                    eachtime
 (SETQ ITEM (\GETBASEPTR
                                                                         BLOCK
                                                                         (UNFOLD (\CHAR8CODE CODE)
                                                                                WORDSPERCELL)))
                                                    when
 (EQ 'APPLY* (CAR ITEM))
                                                    do
 (\FSETCHARWIDTH FD CODE (APPLY* (CADDDR ITEM)
                                                                                      FD
                                                                                      (CADR ITEM]

     (* ;; "Set up the slugs.  Predicate could be mapping=SLUG?  But all slug widths should be zero at this point.")


          (\SLUGSETUP FD)
          (RETURN FD])
)

(ADDTOVAR DEFAULTFILETYPELIST
 (PSCFONT . BINARY)
                              (PSC . BINARY))

(ADDTOVAR POSTSCRIPTFILETEMPLATES
 (PSCFONT (FAMILY SIZE - FACE)
                                         (c0> FAMILY SIZE - FACE -C0)))

(APPENDTOVAR POSTSCRIPTCHARSETFNS
 (PSCFONT PSCFONT.FILEP SHOULDNT))



(* ;; "")





(* ; "Online fonts")


(DEFINEQ

(POSTSCRIPT.FONTSAVAILABLE

  [LAMBDA (FONTSPEC)
                                         (* ; "Edited 13-Sep-2026 11:52 by rmk")


                                                             (* ; "Edited 10-Sep-2026 15:01 by rmk")


                                                             (* ; "Edited  4-Sep-2026 09:20 by rmk")


                                                             (* ; "Edited  3-Sep-2026 00:18 by rmk")


                                                             (* ; "Edited  1-Sep-2026 15:43 by rmk")


                                                             (* ; "Edited 22-Aug-2026 22:30 by rmk")


                                                             (* ; "Edited 17-Dec-2025 20:55 by rmk")


                                                             (* ; "Edited 25-Aug-2025 13:09 by rmk")


                                                             (* ; "Edited 23-Aug-2025 08:19 by rmk")


    (* ;; "Postscript only has font files for %"raw%" postscript families that Medley font families are mapped to by POSTSCRIPTFONTCOERCIONS.  Therefore the search doesn't care about the given family, just looks at the corresponding raw files that exist in the directory. ")


    (LET* [(FAMILY (FSPROP FONTSPEC FSFAMILY))
           (SIZE (FSPROP FONTSPEC FSSIZE))
           (FOUND (\SEARCHFONTFILES (CONS FONTSPEC (COERCEFONTSPEC FONTSPEC]

          (* ;; "Invert the coercion:   add the Medley families that coerce to postscript font-files (GACHA for COURIER)")


          [for
 FS (COERCIONS ← (FONTDEVICEPROP FONTSPEC 'FONTCOERCIONS)) in
 FOUND
             do
 (for
 C in
 COERCIONS unless
 (EQ FAMILY '*) when
 (EQ FAMILY (CAR (CADR C)))
                   do
 
                      (* ;; "C is (medley (ps 0))--match ps return medley")


                      (push
 FOUND (create
 FONTSPEC using
 FS FSFAMILY ← (CAR C]
          (CL:UNLESS (EQ '* FAMILY)                          (* ; 

                                                     "Then filter down to an actual requested family")

              (SETQ FOUND (for
 FS in
 FOUND when
 (EQ FAMILY (FSPROP FS FSFAMILY)) collect
 FS)))
          (CL:UNLESS (MEMB SIZE '(0 *
))                      (* ; "If 0 wasn't requested")

              (for
 FS in
 FOUND when
 (EQ 0 (FSPROP FS FSSIZE)) do
 (replace
 (FONTSPEC FSSIZE)
                                                                    of
 FS with
 SIZE)))
          (CL:REMOVE-DUPLICATES FOUND :TEST (FUNCTION EQUAL
])

(POSTSCRIPT.CREATECHARSET

  [LAMBDA (FONTSPEC FONT CHARSET)
                            (* ; "Edited  2-Oct-2026 22:59 by rmk")


                                                             (* ; "Edited 30-Sep-2026 09:15 by rmk")


                                                             (* ; "Edited  6-Sep-2026 22:16 by rmk")


                                                             (* ; "Edited  4-Sep-2026 17:12 by rmk")


    (* ;; "FONT gets the widths scaled from the unscalable coercion")


                                                             (* ; "Edited  1-Sep-2026 18:01 by rmk")

    (if
 (EQ 0 (FONTPROP FONT 'SIZE))
        then
 (\READCHARSET FONT CHARSET)
      else
 (PROG ((SIZE (FONTPROP FONT 'SIZE))
                  (UNSCALEDFS (GETMULTI (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 FONT)
                                     'UNSCALEDSOURCE))
                  UNSCALEDFD CSINFO WIDTHS)
                 (CL:UNLESS UNSCALEDFS (RETURN NIL))
                 (SETQ UNSCALEDFD (FONTCREATE UNSCALEDFS))
                 (SETQ CSINFO (\INSURECHARSETINFO UNSCALEDFD CHARSET))
                 (CL:UNLESS CSINFO (RETURN NIL))

            (* ;; "")


            (* ;; "FONTCREATE returns the cached unscaled fontdescriptor, we have to copy the charsetinfo before we smash it.")


                 (SETQ CSINFO (\COPYCHARSETINFO CSINFO))
                 (CHARSETPROP CSINFO 'SOURCE FONTSPEC)       (* ; 

                                                             "Don't want indirection to unscaled")

                 (change
 (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO)
                        (FIXR (TIMES SIZE DATUM 0.1)))
                 (change
 (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO)
                        (FIXR (TIMES SIZE DATUM 0.1)))
                 (SETQ WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
                 (replace
 (CHARSETINFO WIDTHS) of
 CSINFO with
 WIDTHS)

            (* ;; "Use (\FSETWIDTH WIDTH...) instead of (\FSETCHARWIDTH FONT...) to avoid stack overflow--CSINFO hasn't been installed yet.")


                 [for
 CH from
 0 to
 \MAXTHINCHAR do
 (\FSETWIDTH WIDTHS CH
                                                          (FIXR (TIMES SIZE (\FGETCHARWIDTH 
                                                                                   UNSCALEDFD CH)
                                                                       0.1]

            (* ;; 

        "Could do the CHARBLOCK on the \READCHARSET, but then the \COPYCHARSETINFO would make a copy")


                 (replace
 (POSTSCRIPTCSINFO CHARBLOCK) of
 CSINFO with
 (GETMULTI 
                                                                          *POSTSCRIPT-MAPPING-BLOCKS*
                                                                             (FONTPROP UNSCALEDFD
                                                                                    'CHARENCODING)
                                                                             CHARSET))
                 (RETURN CSINFO])

(POSTSCRIPT.FONTCREATE

  [LAMBDA (FONTSPEC)
                                         (* ; "Edited  5-Oct-2026 22:22 by rmk")


                                                             (* ; "Edited 29-Sep-2026 16:59 by rmk")


                                                             (* ; "Edited  5-Sep-2026 10:08 by rmk")


                                                             (* ; "Edited  3-Sep-2026 19:17 by rmk")


                                                             (* ; "Edited 30-Aug-2026 21:36 by rmk")


                                                             (* ; "Edited 17-Mar-2026 16:29 by rmk")


                                                             (* ; "Edited 13-Oct-2025 18:04 by rmk")


                                                             (* ; "Edited  7-Sep-2025 23:44 by rmk")


                                                             (* ; "Edited 30-Aug-2025 23:24 by rmk")


                                                             (* ; "Edited 21-Aug-2025 18:21 by rmk")


                                                             (* ; "Edited 15-Jun-2025 23:40 by rmk")


                                                             (* ; "Edited 29-Oct-93 16:39 by rmk:")


                                                             (* ; "Edited  3-Feb-93 17:22 by jds")

    (if
 (AND (type?
 FONTSPEC FONTSPEC)
             (EQ 0 (FSPROP FONTSPEC FSSIZE)))
        then
 (MEDLEYFONT.READ.FONT FONTSPEC NIL T)
      elseif
 (type?
 FONTDESCRIPTOR FONTSPEC)
        then
 
             (* ;; "FONTSPEC is a fresh copy of the unscaled font so we can smash it.  \CREATEFONT has filled in some of the toplevel spec fields, POSTSCRIPT.CHARSETFN will later scale the widths.   Here we just have to scale the top-level parameters in advance of what the charset function might do.")


             (LET ((SIZE (FONTPROP FONTSPEC 'SIZE))
                   (FONT FONTSPEC))
                  (CL:WHEN FONT

                      (* ;; "Cache the unscaled source, so that coercion isn't needed for charsets.  (Filename might change if sysout moves).")


                      (PUTMULTI (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 FONT)
                             'UNSCALEDSOURCE
                             (FONTPROP FONT 'DEVICESPEC))

                      (* ;; "Create the command-string used to switch fonts on the stream")


                      (PUTMULTI (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 FONT)
                             'FONTCHANGESTRING
                             (\POSTSCRIPT.FONTCHANGESTRING
 FONT))
                      (replace
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FONT with
 NIL)
                                                             (* ; "Not sure about this")

                      (change
 (fetch
 (FONTDESCRIPTOR FONTASCENT) of
 FONT)
                             (FIXR (TIMES SIZE DATUM 0.1)))
                      (change
 (fetch
 (FONTDESCRIPTOR FONTDESCENT) of
 FONT)
                             (FIXR (TIMES SIZE DATUM 0.1)))
                      (change
 (fetch
 (FONTDESCRIPTOR FONTHEIGHT) of
 FONT)
                             (FIXR (TIMES SIZE DATUM 0.1)))
                      (change
 (fetch
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT)
                             (FIXR (TIMES SIZE DATUM 0.1)))
                      (for
 I (SLUGWIDTH ← (fetch
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT))
                           (SLUGWIDTHBLOCK ← (fetch
 (CHARSETINFO WIDTHS) of
 (fetch
 (FONTDESCRIPTOR
                                                                                    SLUGCSINFO)
                                                                               of
 FONT)))
                         from
 0 to
 \MAXTHINCHAR do
 (\FSETWIDTH SLUGWIDTHBLOCK I SLUGWIDTH))
                      FONT)])

(\POSTSCRIPT.FONTCHANGESTRING

  [LAMBDA (FONT)
                                             (* ; "Edited  2-Oct-2026 20:31 by rmk")


                                                             (* ; "Edited 29-Sep-2026 23:37 by rmk")


    (* ;; "Produces the string that \SWITCHFONTS.PSC uses to switch the font on the stream.  This depends only on FONT, is executed when the font is created/scaled.")


    (* ;; "4 cases: Bold/Italic vs (un)accented")


    (LET* [[FONTID (fetch
 (PSCFONT IL-FONTID) of
 (GETMULTI (FONTPROP FONT 'OTHERDEVICEFONTPROPS)
                                                        'PSCFONT]
           (FONTIDNAME (CL:IF (LISTP FONTID)
                           (fetch
 (FONTID FONTIDNAME) of
 FONTID)
                           FONTID))
           (ACCENTED (CL:IF (EQ 'MCCS)
                         (GETMULTI FONT 'CHARENCODING)
                         "-Acnt"
                         ""))
           (SIZE (TIMES 100 (FONTPROP FONT 'SIZE]
          (if
 (LISTP FONTID)
              then
 (CONCAT "/" FONTIDNAME ACCENTED " findfont [" (TIMES (fetch
 (FONTID FONTXFACTOR)
                                                                           of
 FONTID)
                                                                        SIZE)
                          " 0 "
                          (TIMES (fetch
 (FONTID FONTOBLIQUEFACTOR) of
 FONTID)
                                 SIZE)
                          " " SIZE " 0 0] makefont setfont")
            else
 (CONCAT SIZE " /" FONTIDNAME ACCENTED " F"])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS POSTSCRIPTFONTEXTENSIONS POSTSCRIPTFONTDIRECTORIES POSTSCRIPTFONTCOERCIONS)
)

(ADDTOVAR POSTSCRIPTCHARSETFNS
 (MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET))

(RPAQ? POSTSCRIPTFONTDIRECTORIES
 "{MEDLEY}/fonts/medleypostscriptfonts")

(RPAQ? POSTSCRIPTFONTEXTENSIONS
 `(MEDLEYPOSTSCRIPTFONT PSCFONT))

(RPAQ? POSTSCRIPTCHARCOERCIONS
 NIL)

(RPAQ? POSTSCRIPTFONTCOERCIONS

       '((CLASSIC (NEWCENTURYSCHLBK 0))
         (COURIER (COURIER 0))
         (CREAM (HELVETICA 0))
         (GACHA (COURIER 0))
         (HELVETICA (HELVETICA 0))
         (HELVETICAD (HELVETICA 0))
         (LOGO (HELVETICA 0))
         (MODERN (HELVETICA 0))
         (OPTIMA (PALATINO 0))
         (TERMINAL (COURIER 0))
         (TIMESROMAN (TIMES 0))
         (TIMESROMAND (TIMES 0))
         (TITAN (COURIER 0))
         (HIPPO CLASSIC)
         (MATH CLASSIC)
         (* (* 0))))

(ADDTOVAR DEFAULTFILETYPELIST
 (PS . BINARY)
                              (PSF . BINARY)
                              (POSTSCRIPT . BINARY))



(* ;; "")


(DEFINEQ

(OPENPOSTSCRIPTSTREAM

  [LAMBDA (FILE OPTIONS)
                                     (* ; "Edited 19-Jan-2026 17:04 by rmk")


                                                             (* ; "Edited 19-Sep-2025 16:02 by rmk")


                                                             (* ; "Edited 14-Sep-2025 12:50 by rmk")


                                                            (* ; "Edited 12-Jun-2021 19:14 by rmk:")

                                                             (* ; 

                                                        "Edited 31-May-93 12:42 by sybalsky:mv:envos")

                                                             (* ; "Edited 23-Dec-92 01:17 by jds")


    (* ;; "RMK:  Note:  At open, this does a lot of printing using generic functions which invoke the generic \OUTCHARFN of the stream.  We set that up as BOUT.  But after the stream is open, we install the \POSTSCRIPT.OUTCHARFN, below.  We also have to make sure that other internal printing that may want to use generic functions (PRIN1, PRIN3...) for convenience, doesn't cycle through the postscript outcharfn.")


    (LET [[STREAM (CL:IF (\GETSTREAM FILE 'OUTPUT T)
                      FILE
                      [OPENSTREAM (CL:IF (EQ 'LPT (FILENAMEFIELD FILE 'HOST))
                                      FILE
                                      (PACKFILENAME 'BODY FILE 'EXTENSION 'PS))
                             'OUTPUT NIL `((TYPE ,*POSTSCRIPT-FILE-TYPE*)
                                           (SEQUENTIAL T])]
          (IMAGEDATA (create
 \POSTSCRIPTDATA))
          PAPER IMAGESIZEFACTOR CLIP REG (BBOX (LISTGET OPTIONS 'BOUNDINGBOX]
         (replace
 (STREAM IMAGEDATA) of
 STREAM with
 IMAGEDATA)
         (replace
 (STREAM IMAGEOPS) of
 STREAM with
 \POSTSCRIPTIMAGEOPS)
         (replace
 (STREAM OUTCHARFN) OF
 STREAM WITH
 (FUNCTION BOUT))

         (* ;; "Bounding box is for encapsulated postscript.  The bounding box is in Medley's postscript-coordinate system, so we have to scale it back to default postscript since it will be interpreted outside of the operators specified below. CEIL and FLOOR to make sure that we don't leave anything out.  We may also want to change the header to have the EPSF qualifier")


         (printout STREAM "%%!PS-Adobe-2.0" T %# (CL:WHEN BBOX
                                                     (PRINTOUT STREAM "%%%%BoundingBox: "
                                                            (CL:FLOOR (CAR BBOX)
                                                                   \PS.SCALE0)
                                                            " "
                                                            (CL:FLOOR (CADR BBOX)
                                                                   \PS.SCALE0)
                                                            " "
                                                            (CL:CEILING (CADDR BBOX)
                                                                   \PS.SCALE0)
                                                            " "
                                                            (CL:CEILING (CADDDR BBOX)
                                                                   \PS.SCALE0)
                                                            T))
                "%%%%Title: "
                (MKSTRING (OR (LISTGET OPTIONS 'DOCUMENT.NAME)
                              FILE))
                T "%%%%Creator: PostScript Driver Copyright (C) 1988-1992 Venue and others" T 
                "%%%%CreationDate: " (DATE)
                T %# (COND
                        ((EQ 'LPT (FILENAMEFIELD STREAM 'HOST))

                         (* ;; "Put current user's name on break page only if going to LPT for immediate printing.  Presumably the print-spooler itself should know what the user's system login-name is, but that may not be the case for all printers in all environments.")


                         (PRINTOUT NIL "%%%%For: " (MKSTRING USERNAME)
                                T)))
                "%%%%EndComments" T)
         (for
 X in
 \POSTSCRIPT.JOB.SETUP do
 (POSTSCRIPT.OUTSTR
 STREAM X)
                                            (\BOUTEOL STREAM))
         (SETQ PAPER (OR (CDR (CL:ASSOC (SETQ PAPER (OR (LISTGET OPTIONS 'PAGETYPE)
                                                        (LISTGET OPTIONS 'PAPERTYPE)
                                                        POSTSCRIPT.PAGETYPE))
                                     POSTSCRIPT.PAGEREGIONS :TEST #'STRING-EQUAL))
                         (ERROR "Unknown PostScript page type" PAPER)))

         (* ;; "Set the paper size:")


         (PRINTOUT STREAM (L-CASE (OR (LISTGET OPTIONS 'PAGETYPE)
                                      (LISTGET OPTIONS 'PAPERTYPE)
                                      POSTSCRIPT.PAGETYPE))
                T)
         (COND
            ((NOT (AND [SETQ IMAGESIZEFACTOR (NUMBERP (LISTGET OPTIONS 'IMAGESIZEFACTOR]
                       (CL:PLUSP IMAGESIZEFACTOR)))
             (SETQ IMAGESIZEFACTOR 1)))
         [COND
            ((AND (NUMBERP POSTSCRIPT.IMAGESIZEFACTOR)
                  (CL:PLUSP POSTSCRIPT.IMAGESIZEFACTOR))
             (SETQ IMAGESIZEFACTOR (TIMES IMAGESIZEFACTOR POSTSCRIPT.IMAGESIZEFACTOR]
         (printout STREAM "/imagesizefactor " IMAGESIZEFACTOR " def" T)
         (printout STREAM "%%%%EndSetup" T)
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA with
 \PS.SCALE0)
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of
 IMAGEDATA
            with
 (\PS.SCALEREGION
 (/ (TIMES 72 \PS.SCALE0)
                                     IMAGESIZEFACTOR)
                        (CAR PAPER)))

         (* ;; 

   "Initial clipping region can be specified separately from the page size, default is to page size.")


         [replace
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA
            with
 (SETQ CLIP (\PS.SCALEREGION
 (/ (TIMES 72 \PS.SCALE0)
                                                IMAGESIZEFACTOR)
                                   (OR (CADR PAPER)
                                       (CAR PAPER]

         (* ;; "If a REGION parameter was supplied, it establishes the initial margins.")


         (SETQ REG (OR (AND (SETQ REG (OR (LISTGET OPTIONS 'REGION)
                                          POSTSCRIPT.DEFAULT.PAGEREGION))
                            (INTERSECTREGIONS REG CLIP))
                       (CREATEREGION 3600 3600 54000 72000)))
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA with
 (fetch
 (REGION LEFT)
                                                                              of
 REG))
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 IMAGEDATA with
 (fetch
 (REGION BOTTOM)
                                                                                of
 REG))
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 IMAGEDATA
            with
 (PLUS (fetch
 (REGION BOTTOM) of
 REG)
                       (fetch
 (REGION HEIGHT) of
 REG)
                       -1))
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of
 IMAGEDATA
            with
 (PLUS (fetch
 (REGION LEFT) of
 REG)
                       (fetch
 (REGION WIDTH) of
 REG)
                       -1))
         (\DSPFONT.PSC
 STREAM (FONTCREATE (OR [CAR (MKLIST (LISTGET OPTIONS 'FONTS]
                                              DEFAULTFONT)
                                     NIL NIL NIL STREAM))
         (\SWITCHFONTS.PSC
 STREAM IMAGEDATA)
         [COND
            ((replace
 (\POSTSCRIPTDATA POSTSCRIPTHEADING) of
 IMAGEDATA with
 (LISTGET OPTIONS
                                                                                   'HEADING))
             (replace
 (\POSTSCRIPTDATA POSTSCRIPTHEADINGFONT) of
 IMAGEDATA
                with
 (COND
                        ((LISTGET OPTIONS 'HEADINGFONT)
                         (FONTCREATE (LISTGET OPTIONS 'HEADINGFONT)
                                NIL NIL NIL STREAM))
                        (T (fetch
 (\POSTSCRIPTDATA POSTSCRIPTFONT) of
 IMAGEDATA]

         (* ;; "Decide if it's landscape:  if (LANDSCAPE T) appears in OPTIONS, it is.  IF ROTATION isn't DEFAULT, it is.")


         (COND
            ([COND
                ((CL:GETF OPTIONS 'LANDSCAPE NIL))
                ((EQL (CL:GETF OPTIONS 'ROTATION 'DEFAULT)
                      'DEFAULT)
                 (COND
                    ((EQL POSTSCRIPT.PREFER.LANDSCAPE 'ASK)
                     (MENU \POSTSCRIPT.ORIENTATION.MENU))
                    (T POSTSCRIPT.PREFER.LANDSCAPE)))
                (T (CL:GETF OPTIONS 'ROTATION]
             (POSTSCRIPT.SET-FAKE-LANDSCAPE
 STREAM 90)))

         (* ;; "Now we are ready for callers to use generic functions--see note above.  The special external format ensures that e.g. COPYCHARS won't do COPYBYTES when copying from  a text file to a PS stream.")


         (\EXTERNALFORMAT STREAM (CREATE
 EXTERNALFORMAT
                                        NAME ← 'POSTSCRIPT
                                        OUTCHARFN ← (FUNCTION \POSTSCRIPT.OUTCHARFN)
                                        EOL ← (FETCH
 (STREAM EOLCONVENTION) OF
 STREAM)))
         (POSTSCRIPT.STARTPAGE
 STREAM)
         STREAM])

(CLOSEPOSTSCRIPTSTREAM

  [LAMBDA (STREAM)
                                           (* ; "Edited  2-Sep-2026 22:18 by rmk")


                                                             (* ; "Edited  8-Mar-93 10:31 by jds")

    (POSTSCRIPT.ENDPAGE
 STREAM)                              (* BOUT STREAM (CHARCODE ↑D))

                                                             (* ; "Commented BOUT was at the end")

    (POSTSCRIPT.PUTCOMMAND
 STREAM :EOL "%%%%Trailer" :EOL])
)

(RPAQ? *POSTSCRIPT-FILE-TYPE*
 'BINARY)
(DEFINEQ

(POSTSCRIPT.HARDCOPYW

  [LAMBDA (FILE BITMAP SCALEFACTOR REGION Landscape? TITLE)  (* ; 

                                                        "Edited 20-Nov-92 15:11 by sybalsky:mv:envos")

    (ALLOW.BUTTON.EVENTS)
    (LET* ((STREAM (OPENPOSTSCRIPTSTREAM
 FILE (LIST 'DOCUMENT.NAME TITLE 'ROTATION Landscape?
                                                    'IMAGESIZEFACTOR SCALEFACTOR)))
           (IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (SCLIP (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA))
           SCALE)
          [COND
             [REGION (SETQ REGION (COPY REGION))             (* ; "In case we need to change it.")

                    [COND
                       ((< (fetch
 BITMAPWIDTH of
 BITMAP)
                           (+ (fetch
 (REGION LEFT) of
 REGION)
                              (fetch
 (REGION WIDTH) of
 REGION)))
                        (replace
 (REGION WIDTH) of
 REGION with
 (- (fetch
 BITMAPWIDTH of
 BITMAP)
                                                                  (fetch
 (REGION LEFT) of
 REGION]
                    (COND
                       ((< (fetch
 BITMAPHEIGHT of
 BITMAP)
                           (+ (fetch
 (REGION BOTTOM) of
 REGION)
                              (fetch
 (REGION HEIGHT) of
 REGION)))
                        (replace
 (REGION HEIGHT) of
 REGION with
 (- (fetch
 BITMAPHEIGHT of
 BITMAP)
                                                                   (fetch
 (REGION BOTTOM)
                                                                      of
 REGION]
             (T (SETQ REGION (create
 REGION
                                    LEFT ← 0
                                    BOTTOM ← 0
                                    WIDTH ← (fetch
 BITMAPWIDTH of
 BITMAP)
                                    HEIGHT ← (fetch
 BITMAPHEIGHT of
 BITMAP]
          (SETQ SCALE (TIMES POSTSCRIPT.BITMAP.SCALE (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALE)
                                                        of
 IMAGEDATA)))
          (BITBLT BITMAP (fetch
 (REGION LEFT) of
 REGION)
                 (fetch
 (REGION BOTTOM) of
 REGION)
                 STREAM
                 (PLUS (fetch
 (REGION LEFT) of
 SCLIP)
                       (QUOTIENT (DIFFERENCE (fetch
 (REGION WIDTH) of
 SCLIP)
                                        (TIMES SCALE (fetch
 (REGION WIDTH) of
 REGION)))
                              2))
                 (PLUS (fetch
 (REGION BOTTOM) of
 SCLIP)
                       (QUOTIENT (DIFFERENCE (fetch
 (REGION HEIGHT) of
 SCLIP)
                                        (TIMES SCALE (fetch
 (REGION HEIGHT) of
 REGION)))
                              2))
                 (fetch
 (REGION WIDTH) of
 REGION)
                 (fetch
 (REGION HEIGHT) of
 REGION)
                 'INPUT
                 'REPLACE)
          (CLOSEF STREAM)
          (FULLNAME STREAM])

(POSTSCRIPT.TEDIT

  [LAMBDA (FILE IMAGESTREAM)
                                 (* ; "Edited 13-Sep-2025 20:21 by rmk")


                                                             (* ; "Edited 12-Sep-2025 13:40 by rmk")


                                                             (* ; "Edited 18-Sep-91 18:16 by jds")


    (* ;; "IMAGESTREAM must be a postscript stream  ")


    (TEDIT.TO.IMAGESTREAM FILE IMAGESTREAM])

(POSTSCRIPTFILEP

  [LAMBDA (FILE)
                                             (* ; "Edited  9-Oct-2025 21:16 by rmk")


                                                             (* ; "Edited 18-Sep-2025 09:35 by rmk")


                                                             (* ; "Edited 13-Sep-2025 23:23 by rmk")


                                                             (* ; "Edited 10-Sep-2025 14:51 by rmk")


                                                             (* ; "Edited 21-Nov-2023 17:04 by rmk")


                                                             (* ; "Edited  5-Mar-93 21:40 by rmk:")


                                                             (* ; "Edited 14-Jan-93 10:56 by jds")

    (OR (MEMBER (U-CASE (FILENAMEFIELD FILE 'EXTENSION))
               (EXTENSIONS.FOR.IMAGEFILETYPE 'POSTSCRIPT)
               :TEST
               (FUNCTION STRING-EQUAL))
        (RESETLST
            [LET (STRM)
                 [if
 (SETQ STRM (\GETSTREAM FILE 'INPUT T))
                     then
 [RESETSAVE NIL `(PROGN (SETFILEPTR ,STRM ,(GETFILEPTR STRM]
                          (SETFILEPTR STRM 0)
                   else
 (RESETSAVE (SETQ STRM (OPENSTREAM FILE 'INPUT))
                               `(PROGN (CLOSEF OLDVALUE]
                 (AND (EQ (BIN STRM)
                          (CHARCODE %%))
                      (EQ (BIN STRM)
                          (CHARCODE !])])

(MAKEEPSFILE

  [LAMBDA (IMAGEOBJ FILENAME)
                                (* ; "Edited  7-Dec-2025 16:37 by rmk")


                                                             (* ; "Edited 16-Sep-2025 00:29 by rmk")


                                                             (* ; "Edited  7-Apr-94 14:48 by rmk:")


    (* ;; "Puts IMAGEOBJ on a 1-page encapsulated postscript file.  The lower-left corner of the image box will be at 0,0 on the page.")


    (* ;; "This opens a scratch stream to get the postscript imagebox of the object, then opens the true stream with that object.")


    (LET ([IMAGEBOX (APPLY* (IMAGEOBJPROP IMAGEOBJ 'IMAGEBOXFN)
                           IMAGEOBJ
                           (OPENIMAGESTREAM NIL 'POSTSCRIPT]
          STREAM)
         [SETQ STREAM (OPENIMAGESTREAM FILENAME 'POSTSCRIPT
                             `(BOUNDINGBOX (0 0 ,(FETCH
 XSIZE OF
 IMAGEBOX)
                                              ,(FETCH
 YSIZE OF
 IMAGEBOX]
         (MOVETO (FETCH
 XKERN OF
 IMAGEBOX)
                (FETCH
 YDESC OF
 IMAGEBOX)
                STREAM)
         (APPLY* (IMAGEOBJPROP IMAGEOBJ 'DISPLAYFN)
                IMAGEOBJ STREAM)
         (CLOSEF STREAM])
)
(DEFINEQ

(POSTSCRIPT.BITMAPSCALE

  [LAMBDA (WIDTH HEIGHT)
                                     (* ; "Edited 29-Apr-98 08:46 by rmk:")

                                                             (* ; 

                                                        "Edited 20-Nov-92 14:52 by sybalsky:mv:envos")

    (LET* ([PAGEREGION (\PS.SCALEREGION
 (/ 72 POSTSCRIPT.BITMAP.SCALE)
                              (CADR (FASSOC POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS]
           (LONGEDGE (MAX (fetch
 (REGION WIDTH) of
 PAGEREGION)
                          (fetch
 (REGION HEIGHT) of
 PAGEREGION)))
           (SHORTEDGE (MIN (fetch
 (REGION WIDTH) of
 PAGEREGION)
                           (fetch
 (REGION HEIGHT) of
 PAGEREGION)))
           [MINDIMP (MIN (FQUOTIENT LONGEDGE (SETQ HEIGHT (TIMES HEIGHT POSTSCRIPT.BITMAP.SCALE)))
                         (FQUOTIENT SHORTEDGE (SETQ WIDTH (TIMES WIDTH POSTSCRIPT.BITMAP.SCALE]
           (MINDIML (MIN (FQUOTIENT SHORTEDGE HEIGHT)
                         (FQUOTIENT LONGEDGE WIDTH)))
           (PPL (if
 (EQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK)
                    then
 (MENU \POSTSCRIPT.ORIENTATION.MENU)
                  else
 POSTSCRIPT.PREFER.LANDSCAPE))
           MINDIM OTHERDIM SF1 SF2)
          (if
 PPL
              then
 (SETQ MINDIM MINDIML)
                   (SETQ OTHERDIM MINDIMP)
            else
 (SETQ MINDIM MINDIMP)
                 (SETQ OTHERDIM MINDIML))
          (SETQ SF1 (if
 (GREATERP MINDIM 1)
                        then
 1
                      elseif
 (GREATERP MINDIM 0.75)
                        then
 0.75
                      elseif
 (GREATERP MINDIM 0.5)
                        then
 0.5
                      elseif
 (GREATERP MINDIM 0.25)
                        then
 0.25
                      else
 MINDIM))
          (SETQ SF2 (if
 (GREATERP OTHERDIM 1)
                        then
 1
                      elseif
 (GREATERP OTHERDIM 0.75)
                        then
 0.75
                      elseif
 (GREATERP OTHERDIM 0.5)
                        then
 0.5
                      elseif
 (GREATERP OTHERDIM 0.25)
                        then
 0.25
                      else
 OTHERDIM))
          (if
 (AND (LESSP SF1 1)
                   (LESSP SF1 SF2))
              then
 (CONS SF2 (NOT PPL))
            else
 (CONS SF1 PPL])

(POSTSCRIPT.CLOSESTRING

  [LAMBDA (STREAM)                                           (* ; 

                                                        "Edited 20-Nov-92 15:11 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM)))
         (COND
            ((fetch
 (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of
 IMAGEDATA)
             (POSTSCRIPT.OUTSTR
 STREAM ") ")
             (replace
 (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of
 IMAGEDATA with
 NIL)
             T)
            (T NIL])

(POSTSCRIPT.ENDPAGE

  [LAMBDA (STREAM)                                           (* ; 

                                                        "Edited 20-Nov-92 15:11 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM)))
         (POSTSCRIPT.SHOWACCUM
 STREAM)
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA with
 NIL)
         (COND
            ((NOT (PROG1 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of
 IMAGEDATA)
                         (POSTSCRIPT.PUTCOMMAND
 STREAM "grestore savepage restore ")))
             (POSTSCRIPT.PUTCOMMAND
 STREAM "showpage" :EOL)))

         (* ;; 

 "Force re-encoding of fonts, because the restore wipes out any you encoded while writing this page.")


         (replace
 (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of
 IMAGEDATA with
 NIL])

(POSTSCRIPT.OUTSTR

  [LAMBDA (STREAM X)
                                         (* ; "Edited 26-Apr-2025 17:44 by mth")


                                                      (* ; "Edited 14-Jul-89 14:05 by Matt Heffron")

    (DECLARE
 (LOCALVARS . T))
    (COND
       ((NULL X)

        (* ;; "Don't output anything for NIL")


        NIL)
       ((FIXP X)                                             (* ; "Common case, speed helps")

        (\PS.BOUTFIXP
 STREAM X))
       [(STRINGP X)                                          (* ; "Other common case")

        (COND
           [(ffetch
 (STRINGP FATSTRINGP) of
 X)
            (for
 c infatstring
 X do
 (BOUT STREAM (\CHAR8CODE c]
           (T (\BOUTS STREAM (ffetch
 (STRINGP BASE) of
 X)
                     (ffetch
 (STRINGP OFFST) of
 X)
                     (ffetch
 (STRINGP LENGTH) of
 X]
       [(LITATOM X)
        (for
 c inatom
 X do
 (BOUT STREAM (\CHAR8CODE c]
       ((ZEROP X)
        (BOUT STREAM (CHARCODE 0)))
       (T [COND
             ((TYPEP X 'RATIO)
              (SETQ X (FLOAT X]
          (for
 c in
 (CHCON X) do
 (BOUT STREAM (\CHAR8CODE c])

(POSTSCRIPT.PUTBITMAPBYTES

  [LAMBDA (STREAM BITMAP DELIMFLG)
    (DECLARE
 (GLOBALVARS PS.BITMAPARRAY)
           (LOCALVARS . T))
                                 (* ; "Edited 12-Jun-2021 15:17 by rmk:")

    (LET*
     ((WIDTH (fetch
 BITMAPWIDTH of
 BITMAP))
      (HEIGHT (fetch
 BITMAPHEIGHT of
 BITMAP))
      (BMBASE (fetch
 BITMAPBASE of
 BITMAP))
      (BYTESPERROW (LRSH (IPLUS WIDTH 7)
                         3))
      (BYTEOFFSETPERROW (LSH (fetch
 BITMAPRASTERWIDTH of
 BITMAP)
                             1))
      (PS.BITMAPARRAYBASE (fetch
 (ARRAYP BASE) of
 PS.BITMAPARRAY)))
     (COND
        (DELIMFLG (LET ((POS 0)
                        BYTE)
                       (BOUT STREAM (CHARCODE SPACE))
                       (BOUT STREAM (CHARCODE <))
                       (\BOUTEOL STREAM)
                       (for
 R from
 (SUB1 HEIGHT) to
 0 by
 -1 as
 ROWOFFSET
                          from
 (ITIMES (SUB1 HEIGHT)
                                      BYTEOFFSETPERROW) by
 (IMINUS BYTEOFFSETPERROW)
                          do
 (for
 B from
 1 to
 BYTESPERROW as
 BYTEOFFSET from
 ROWOFFSET by
 1
                                do
 (COND
                                      ((IGEQ POS 254)
                                       (\BOUTEOL STREAM)
                                       (SETQ POS 0)))
                                   (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET))
                                   [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE
                                                       (LOGAND 15 (LRSH BYTE 4]
                                   (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 BYTE)))
                                   (SETQ POS (IPLUS POS 2)))
                             (\BOUTEOL STREAM)
                             (SETQ POS 0))
                       (BOUT STREAM (CHARCODE SPACE))
                       (BOUT STREAM (CHARCODE >))
                       (\BOUTEOL STREAM)))
        (T
         (LET*
          ((PRVBM (BITMAPCREATE WIDTH 1))
           (PRVBASE (fetch
 BITMAPBASE of
 PRVBM)))
          (for
 R from
 0 to
 (SUB1 HEIGHT) as
 ROWOFFSET from
 (ITIMES (SUB1 HEIGHT)
                                                                  BYTEOFFSETPERROW)
             by
 (IMINUS BYTEOFFSETPERROW)
             do

             (LET ((POS 0)
                   (BYTEOFFSET ROWOFFSET)
                   (B 1)
                   (PRVO 0)
                   BYTE REPC)
                  [while
 (ILEQ B BYTESPERROW)
                     do
 (SETQ REPC
                         (for
 BB from
 B to
 BYTESPERROW as
 BO from
 BYTEOFFSET by
 1 as
 PO from
 PRVO
                            by
 1 while
 (EQ (\GETBASEBYTE BMBASE BO)
                                           (\GETBASEBYTE PRVBASE PO)) count
 T))
                        (COND
                           [(IGEQ REPC 3)
                            (SETQ B (IPLUS B REPC))
                            (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC))
                            (SETQ PRVO (IPLUS PRVO REPC))
                            (while
 (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1)))
                               do
 (COND
                                     ((IGEQ POS 251)
                                      (\BOUTEOL STREAM)
                                      (SETQ POS 0)))
                                  (BOUT STREAM (CHARCODE B))
                                  (BOUT STREAM (CHARCODE 3))
                                  [COND
                                     ((IGEQ REPC 256)
                                      (BOUT STREAM (CHARCODE F))
                                      (BOUT STREAM (CHARCODE F)))
                                     (T [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE
                                                            (LOGAND 15 (LRSH REPC 4]
                                        (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE
                                                            (LOGAND 15 REPC]
                                  (SETQ REPC (IDIFFERENCE REPC 256))
                                  (SETQ POS (IPLUS POS 4]
                           (T (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET))
                              (SETQ REPC
                               (for
 BB from
 B to
 BYTESPERROW as
 BO from
 BYTEOFFSET by
 1
                                  while
 (EQ (\GETBASEBYTE BMBASE BO)
                                            BYTE) count
 T))
                              (COND
                                 [(IGEQ REPC 3)
                                  (SETQ B (IPLUS B REPC))
                                  (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC))
                                  (SETQ PRVO (IPLUS PRVO REPC))
                                  (while
 (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1)))
                                     do
 (COND
                                           ((IGEQ POS 249)
                                            (\BOUTEOL STREAM)
                                            (SETQ POS 0)))
                                        (BOUT STREAM (CHARCODE B))
                                        (BOUT STREAM (CHARCODE 2))
                                        [COND
                                           ((IGEQ REPC 256)
                                            (BOUT STREAM (CHARCODE F))
                                            (BOUT STREAM (CHARCODE F)))
                                           (T [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE
                                                                  (LOGAND 15 (LRSH REPC 4]
                                              (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE
                                                                  (LOGAND 15 REPC]
                                        [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE
                                                            (LOGAND 15 (LRSH BYTE 4]
                                        (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE
                                                            (LOGAND 15 BYTE)))
                                        (SETQ REPC (IDIFFERENCE REPC 256))
                                        (SETQ POS (IPLUS POS 4]
                                 (T (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET))
                                    (COND
                                       ((IGEQ POS 251)
                                        (\BOUTEOL STREAM)
                                        (SETQ POS 0)))
                                    [COND
                                       ((FMEMB BYTE '(178 179 180))

                                        (* ;; "BYTE is B2, B3, or B4; quote it")


                                        (BOUT STREAM (CHARCODE B))
                                        (BOUT STREAM (CHARCODE 4))
                                        (SETQ POS (IPLUS POS 2]
                                    [BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE
                                                        (LOGAND 15 (LRSH BYTE 4]
                                    (BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 BYTE)))
                                    (SETQ B (IPLUS B 1))
                                    (SETQ BYTEOFFSET (IPLUS BYTEOFFSET 1))
                                    (SETQ PRVO (IPLUS PRVO 1))
                                    (SETQ POS (IPLUS POS 2]
                  (\BOUTEOL STREAM))
             (\MOVEBYTES BMBASE ROWOFFSET PRVBASE 0 BYTESPERROW])

(POSTSCRIPT.PUTCOMMAND

  [LAMBDA S.STRS
                                            (* ; "Edited 12-Jun-2021 15:14 by rmk:")

    (LET* ((STREAM (ARG S.STRS 1))
           (IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           S#S)
          (freplace
 (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of
 IMAGEDATA with
 NIL)
          (COND
             ((ffetch
 (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of
 IMAGEDATA)
              (POSTSCRIPT.SHOWACCUM
 STREAM)))
          (COND
             ((ffetch
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA)
              (\SETXFORM.PSC
 STREAM IMAGEDATA)))
          (for
 STR# from
 2 to
 S.STRS do
 (COND
                                           ((EQ (SETQ S#S (ARG S.STRS STR#))
                                                :EOL)
                                            (\BOUTEOL STREAM))
                                           (T (POSTSCRIPT.OUTSTR
 STREAM S#S])

(POSTSCRIPT.SET-FAKE-LANDSCAPE

  [LAMBDA (STREAM ROTATION)                                  (* ; 

                                                        "Edited 20-Nov-92 15:11 by sybalsky:mv:envos")


    (* ;; "Set up for (or disable) fake landscaping")


    (* ;; 

    "we only know 90 degrees of rotation for now (0 means portrait, anything else is landscape).")


    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (OLAND (COND
                     ((fetch
 (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of
 IMAGEDATA)
                      90)
                     (T 0)))
           LAND C0 P0 C P ML MB MR MT)
          (COND
             ((AND ROTATION (NEQ (SETQ LAND (NOT (ZEROP ROTATION)))
                                 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of
 IMAGEDATA)))
              (POSTSCRIPT.SHOWACCUM
 STREAM)
              (\DSPTRANSLATE.PSC
 STREAM 0 0)
              (SETQ C0 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA))
              (SETQ P0 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of
 IMAGEDATA))
              (SETQ C (create
 REGION
                             WIDTH ← (fetch
 (REGION HEIGHT) of
 C0)
                             HEIGHT ← (fetch
 (REGION WIDTH) of
 C0)))
              (SETQ P (create
 REGION
                             LEFT ← 0
                             BOTTOM ← 0
                             WIDTH ← (fetch
 (REGION HEIGHT) of
 P0)
                             HEIGHT ← (fetch
 (REGION WIDTH) of
 P0)))
              [COND
                 (LAND (replace
 (REGION LEFT) of
 C with
 (fetch
 (REGION BOTTOM) of
 C0))
                       [replace
 (REGION BOTTOM) of
 C with
 (- (fetch
 (REGION WIDTH) of
 P0)
                                                             (+ (fetch
 (REGION LEFT) of
 C0)
                                                                (fetch
 (REGION WIDTH) of
 C0]
                       (SETQ ML (fetch
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 IMAGEDATA))
                       (SETQ MB (- (fetch
 (REGION WIDTH) of
 P0)
                                   (fetch
 (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of
 IMAGEDATA)
                                   1))
                       (SETQ MR (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 IMAGEDATA))
                       (SETQ MT (- (fetch
 (REGION WIDTH) of
 P0)
                                   (fetch
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA)
                                   1)))
                 (T [replace
 (REGION LEFT) of
 C with
 (- (fetch
 (REGION HEIGHT) of
 P0)
                                                        (+ (fetch
 (REGION BOTTOM) of
 C0)
                                                           (fetch
 (REGION HEIGHT) of
 C0]
                    (replace
 (REGION BOTTOM) of
 C with
 (fetch
 (REGION LEFT) of
 C0))
                    (SETQ ML (- (fetch
 (REGION HEIGHT) of
 P0)
                                (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 IMAGEDATA)
                                1))
                    (SETQ MB (fetch
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA))
                    (SETQ MR (- (fetch
 (REGION HEIGHT) of
 P0)
                                (fetch
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 IMAGEDATA)
                                1))
                    (SETQ MT (fetch
 (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of
 IMAGEDATA]
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA with
 C)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of
 IMAGEDATA with
 P)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA with
 ML)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 IMAGEDATA with
 MB)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of
 IMAGEDATA with
 MR)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 IMAGEDATA with
 MT)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of
 IMAGEDATA with
 LAND)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA with
 T)
              (\DSPRESET.PSC
 STREAM)))
          OLAND])

(POSTSCRIPT.SHOWACCUM

  [LAMBDA (STREAM)
                                          (* ; "Edited 12-Jun-2021 15:16 by rmk:")


    (* ;; 

    "Send commands to SHOW the accumulated characters.  Uses S (= SHOW) for regular characters.")


    (* ;; "Uses WIDTHSHOW if the space-factor isn't 1")


    (* ;; "Uses ASHOW if a KERN value is on STREAM's properties")


    (* ;; "USES AWIDTHSHOW if both space-factor != 1 and there's a KERN value.")


    (LET ((IMAGEDATA (ffetch
 (STREAM IMAGEDATA) of
 STREAM))
          KERN)
         (COND
            ((fetch
 (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of
 IMAGEDATA)
             (SETQ KERN (STREAMPROP STREAM 'KERN))
             [COND
                [(EQP (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of
 IMAGEDATA)
                      1)
                 (COND
                    (KERN (POSTSCRIPT.OUTSTR
 STREAM (CONCAT ") " KERN " 0 3 -1 roll ashow")))
                    (T (POSTSCRIPT.OUTSTR
 STREAM ") S"]
                (T (POSTSCRIPT.OUTSTR
 STREAM ") ")
                   (POSTSCRIPT.OUTSTR
 STREAM (DIFFERENCE (ffetch
 (\POSTSCRIPTDATA 
                                                                        POSTSCRIPTSPACEWIDTH)
                                                            of
 IMAGEDATA)
                                                    (ffetch
 (\POSTSCRIPTDATA 
                                                                   POSTSCRIPTNATURALSPACEWIDTH)
                                                       of
 IMAGEDATA)))
                   (COND
                      (KERN (POSTSCRIPT.OUTSTR
 STREAM (CONCAT " 0 " (CHARCODE SPACE)
                                                             " " KERN " 0 " " 6 -1 roll awidthshow"))
                            )
                      (T (POSTSCRIPT.OUTSTR
 STREAM (CONSTANT (CONCAT " 0 " (CHARCODE SPACE)
                                                                    " 4 -1 roll widthshow"]
             (\BOUTEOL STREAM)
             (freplace
 (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW) of
 IMAGEDATA with
 NIL])

(POSTSCRIPT.STARTPAGE

  [LAMBDA (STREAM)
                                           (* ; "Edited 27-Jan-2026 17:54 by mth")


                                                            (* ; "Edited 12-Jun-2021 14:52 by rmk:")


    (* ;; "Start up a new page in a Postscript document.")


    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          NEW-PAGE)
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA with
 NIL)
                                                             (* ; "shouldnt need this")

         (SETQ NEW-PAGE (CL:INCF (fetch
 (\POSTSCRIPTDATA POSTSCRIPTPAGENUM) of
 IMAGEDATA)))
                                                             (* ; "Page number goes up by 1")


         (* ;; "Print the %"Document structuring%" info for the page, then the initial page setup")


         (POSTSCRIPT.PUTCOMMAND
 STREAM :EOL "%%%%Page: " NEW-PAGE " " NEW-PAGE :EOL 
                "%%%%BeginPageSetup" :EOL "/savepage save def" :EOL (FQUOTIENT 1 \PS.SCALE0)
                " imagesizefactor mul dup scale" :EOL "%%%%EndPageSetup" :EOL)
         (\SETXFORM.PSC
 STREAM IMAGEDATA T)

         (* ;; "Lisp depends on the current font being carried over from page to page, but in postscript there is no current font at the beginning of a page, so force a setfont.")


         (replace
 (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of
 IMAGEDATA with
 T)
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTPAGEBLANK) of
 IMAGEDATA with
 T)
                                                             (* ; "nothing printed yet...")

         (COND
            ((fetch
 (\POSTSCRIPTDATA POSTSCRIPTHEADING) of
 IMAGEDATA)

             (* ;; "Here we handle headings.")


             (LET [(FONT (\DSPFONT.PSC
 STREAM (fetch
 (\POSTSCRIPTDATA POSTSCRIPTHEADINGFONT)
                                                 of
 IMAGEDATA]
                  (\DSPRESET.PSC
 STREAM)
                  (for
 CH instring
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTHEADING) of
 IMAGEDATA)
                     do
 (\POSTSCRIPT.OUTCHARFN
 STREAM CH))
                  (RELMOVETO (CONSTANT (TIMES 72 \PS.SCALE0))
                         0 STREAM)                           (* ; "Skip an inch before page number")

                  (for
 CH instring
 (CONCAT "Page " NEW-PAGE) do
 (\POSTSCRIPT.OUTCHARFN
 STREAM CH))
                  (\TERPRI.PSC
 STREAM)                       (* ; "Skip 2 lines")

                  (\TERPRI.PSC
 STREAM)
                  (\DSPFONT.PSC
 STREAM FONT)))
            (T (\DSPRESET.PSC
 STREAM])

(\POSTSCRIPTTAB

  [LAMBDA (POSTSCRIPTDATA)                                   (* ; 

                                                        "Edited 20-Nov-92 15:11 by sybalsky:mv:envos")

    (LET [(TABSPACE (TIMES 8 (ffetch
 FONTAVGCHARWIDTH of
 (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTFONT)
                                                            of
 POSTSCRIPTDATA]
         (IDIFFERENCE TABSPACE (IREMAINDER (IDIFFERENCE (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTX)
                                                           of
 POSTSCRIPTDATA)
                                                  (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN)
                                                     of
 POSTSCRIPTDATA))
                                      TABSPACE])

(\PS.BOUTFIXP

  [LAMBDA (STREAM N)                                         (* ; 

                                                        "Edited 20-Nov-92 15:11 by sybalsky:mv:envos")


    (* ;; "BOUT the decimal representation of N to STREAM using temp storage from the imagedata.  Done this way for speed.")


    (DECLARE
 (LOCALVARS . T))
    [COND
       ((MINUSP N)
        (BOUT STREAM (CHARCODE -
))
        (SETQ N (IMINUS N]
    (COND
       [(LESSP N 10)
        (BOUT STREAM (IPLUS N (CHARCODE 0]
       [(LESSP N 1000000000)
        (LET ([BASE (fetch
 (ARRAYP BASE) of
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTEMPARRAY)
                                               of
 (fetch
 (STREAM IMAGEDATA) of
 STREAM]
              (i (SUB1 \PS.TEMPARRAYLEN)))
             [for
 old
 i by
 -1 do
 (\PUTBASEBYTE BASE i (IPLUS (IREMAINDER N 10)
                                                             (CHARCODE 0)))
                repeatwhile
 (NEQ 0 (SETQ N (IQUOTIENT N 10]
             (\BOUTS STREAM BASE i (IDIFFERENCE \PS.TEMPARRAYLEN i]
       (T                                                    (* ; "Just in case we get a bignum")

          (for
 c in
 (CHCON N) do
 (BOUT STREAM (\CHAR8CODE c])

(\PS.SCALEHACK

  [LAMBDA (STREAM SCALEFACTOR)                               (* ; 

                                                        "Edited 20-Nov-92 15:11 by sybalsky:mv:envos")

    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (OLDSCALE (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of
 IMAGEDATA))
           FACTOR)
          (COND
             ((AND (NUMBERP SCALEFACTOR)
                   (NOT (EQP OLDSCALE SCALEFACTOR)))
              (POSTSCRIPT.SHOWACCUM
 STREAM)
              (SETQ FACTOR (/ OLDSCALE SCALEFACTOR))
              [for
 REG in
 (LIST (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA)
                                (fetch
 (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of
 IMAGEDATA))
                 do
 (change
 (fetch
 (REGION LEFT) of
 REG)
                           (FIXR (CL:* DATUM FACTOR)))
                    (change
 (fetch
 (REGION BOTTOM) of
 REG)
                           (FIXR (CL:* DATUM FACTOR)))
                    (change
 (fetch
 (REGION WIDTH) of
 REG)
                           (FIXR (CL:* DATUM FACTOR)))
                    (change
 (fetch
 (REGION HEIGHT) of
 REG)
                           (FIXR (CL:* DATUM FACTOR]
              (change
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA)
                     (FIXR (CL:* DATUM FACTOR)))
              (change
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA)
                     (FIXR (CL:* DATUM FACTOR)))
              (change
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA)
                     (FIXR (CL:* DATUM FACTOR)))
              (change
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of
 IMAGEDATA)
                     (FIXR (CL:* DATUM FACTOR)))
              (change
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 IMAGEDATA)
                     (FIXR (CL:* DATUM FACTOR)))
              (change
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 IMAGEDATA)
                     (FIXR (CL:* DATUM FACTOR)))
              (change
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of
 IMAGEDATA)
                     (FIXR (CL:* DATUM FACTOR)))
              (change
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of
 IMAGEDATA)
                     (FIXR (CL:* DATUM FACTOR)))
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of
 IMAGEDATA with
 SCALEFACTOR)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA with
 T)))
          OLDSCALE])

(\PS.SCALEREGION

  [LAMBDA (SCALE REGION)
                                     (* ; "Edited  5-Apr-89 16:15 by TAL")

                                                             (* ; "Scales a region")

    (create
 REGION
           LEFT ← (FIXR (TIMES SCALE (fetch
 (REGION LEFT) of
 REGION)))
           BOTTOM ← (FIXR (TIMES SCALE (fetch
 (REGION BOTTOM) of
 REGION)))
           WIDTH ← (FIXR (TIMES SCALE (fetch
 (REGION WIDTH) of
 REGION)))
           HEIGHT ← (FIXR (TIMES SCALE (fetch
 (REGION HEIGHT) of
 REGION])

(\SCALEDBITBLT.PSC

  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
                 SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM 
                 SCALE)
                                     (* ; "Edited  8-May-2018 19:33 by rmk:")


                                                            (* ; "Edited  8-May-2018 15:05 by rmk:")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")


    (* ;; "Postscript can only handle OPERATION REPLACE and PAINT.  SOURCETYPE = TEXTURE is converted to BLTSHADE before getting here (so the TEXTURE argument can be ignored).  If the destination region lies completely outside the clipping region we do nothing, otherwise we output the whole thing and let the printer clip.  Could be more clever.")


    (OR (NUMBERP SCALE)
        (SETQ SCALE 1))
    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (SCALE1 (TIMES SCALE (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA)))
           (SCALE2 (TIMES SCALE1 (OR (NUMBERP POSTSCRIPT.BITMAP.SCALE)
                                     1)))
           DESTREGION
           (BITMAPWIDTH (fetch
 BITMAPWIDTH of
 SOURCEBITMAP))
           (BITMAPHEIGHT (fetch
 BITMAPHEIGHT of
 SOURCEBITMAP))
           TEMPBM)
          [COND
             ((NULL DESTINATIONLEFT)
              (SETQ DESTINATIONLEFT (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA]
          [COND
             ((NULL DESTINATIONBOTTOM)
              (SETQ DESTINATIONBOTTOM (fetch
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA]
          (COND
             ((OR (NULL WIDTH)
                  (NULL HEIGHT))
              (SETQ WIDTH BITMAPWIDTH)
              (SETQ HEIGHT BITMAPHEIGHT)))
          (COND
             ((GREATERP WIDTH BITMAPWIDTH)
              (SETQ WIDTH BITMAPWIDTH)))
          (COND
             ((GREATERP HEIGHT BITMAPHEIGHT)
              (SETQ HEIGHT BITMAPHEIGHT)))
          [SETQ DESTREGION (INTERSECTREGIONS (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION)
                                                of
 IMAGEDATA)
                                  (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM (TIMES SCALE1 WIDTH
                                                                                         )
                                         (TIMES SCALE1 HEIGHT]
          (COND
             ((AND DESTREGION (OR (NULL CLIPPINGREGION)
                                  (REGIONSINTERSECTP DESTREGION CLIPPINGREGION)))
              [COND
                 ((AND (EQ SOURCELEFT 0)
                       (EQ SOURCEBOTTOM 0)
                       (EQP WIDTH BITMAPWIDTH)
                       (EQP HEIGHT BITMAPHEIGHT))            (* ; 

                                                             "Avoid copy if sending entire bitmap")

                  (SETQ TEMPBM SOURCEBITMAP))
                 (T (SETQ TEMPBM (BITMAPCREATE WIDTH HEIGHT 1))
                    (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM TEMPBM 0 0 WIDTH HEIGHT SOURCETYPE
                           'REPLACE]
              (POSTSCRIPT.PUTCOMMAND
 STREAM "/bitbltsave save def " DESTINATIONLEFT " " 
                     DESTINATIONBOTTOM " translate " (TIMES SCALE2 WIDTH)
                     " "
                     (TIMES SCALE2 HEIGHT)
                     " scale " WIDTH " " HEIGHT (COND
                                                   ((EQ OPERATION 'PAINT)
                                                    " true")
                                                   (T 
                                                      (* ;; 

                                         "RMK: For REPLACE, was %"false%", but then white was black.")


                                                      " true"))
                     " thebitimage" :EOL)
              (POSTSCRIPT.PUTBITMAPBYTES
 STREAM TEMPBM NIL)
              (POSTSCRIPT.PUTCOMMAND
 STREAM :EOL "bitbltsave restore" :EOL)
              (\MOVETO.PSC
 STREAM DESTINATIONLEFT DESTINATIONBOTTOM)
              T)
             (T NIL])

(\SETPOS.PSC

  [LAMBDA (STREAM IMAGEDATA)                                 (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (POSTSCRIPT.PUTCOMMAND
 STREAM (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA)
           " "
           (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA)
           " M ")
    (freplace
 (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of
 IMAGEDATA with
 NIL])

(\SETXFORM.PSC

  [LAMBDA (STREAM IMAGEDATA NORESTORE)
                       (* ; "Edited 28-Dec-94 17:59 by jds")


    (* ;; 

    "Write transforms into the PS file to make what it prints match what we think it should print.")


    (LET ((CLIP (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA)))
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA with
 NIL)
         (COND
            ((NOT NORESTORE)
             (POSTSCRIPT.OUTSTR
 STREAM "grestore ")))
         (POSTSCRIPT.PUTCOMMAND
 STREAM "gsave" :EOL)

         (* ;; "Scaling")


         (COND
            ((NOT (EQP (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of
 IMAGEDATA)
                       1))
             (POSTSCRIPT.PUTCOMMAND
 STREAM (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALEHACK) of
 IMAGEDATA)
                    " dup scale" :EOL)))

         (* ;; 

         "Landscape mode (as in POSTSCRIPT.PREFER.LANDSCAPE, not as in TEdit doing landscaping)")


         (COND
            ((fetch
 (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of
 IMAGEDATA)
             (POSTSCRIPT.OUTSTR
 STREAM " 90 rotate 0 -61200 imagesizefactor div translate ")))

         (* ;; "Any rotation that is in effect.")


         (POSTSCRIPT.PUTCOMMAND
 STREAM " " (fetch
 (\POSTSCRIPTDATA POSTSCRIPTROTATION) of
 IMAGEDATA)
                " rotate " :EOL)

         (* ;; "Any translations that are in effect.")


         (COND
            ([NOT (AND (ZEROP (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of
 IMAGEDATA))
                       (ZEROP (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of
 IMAGEDATA]
             (POSTSCRIPT.PUTCOMMAND
 STREAM (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of
 IMAGEDATA)
                    " "
                    (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of
 IMAGEDATA)
                    " translate" :EOL)))

         (* ;; "Clipping region:")


         (POSTSCRIPT.PUTCOMMAND
 STREAM " " (fetch
 (REGION HEIGHT) of
 CLIP)
                " "
                (fetch
 (REGION WIDTH) of
 CLIP)
                " "
                (fetch
 (REGION LEFT) of
 CLIP)
                " "
                (fetch
 (REGION BOTTOM) of
 CLIP)
                " CLP" :EOL)

         (* ;; "And force recaching of location and font.")


         (replace
 (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of
 IMAGEDATA with
 T)
         (replace
 (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of
 IMAGEDATA with
 T])

(\STRINGWIDTH.PSC

  [LAMBDA (STREAM STR RDTBL)                                 (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (ffetch
 (STREAM IMAGEDATA) of
 STREAM)))
         (\STRINGWIDTH.GENERIC STR (fetch
 (\POSTSCRIPTDATA POSTSCRIPTFONT) of
 IMAGEDATA)
                RDTBL
                (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of
 IMAGEDATA])

(\SWITCHFONTS.PSC

  [LAMBDA (STREAM IMAGEDATA)
                                 (* ; "Edited 30-Sep-2026 00:15 by rmk")


                                                             (* ; "Edited  3-Sep-2026 23:53 by rmk")


                                                             (* ; "Edited 23-May-93 12:04 by rmk:")


                                                             (* ; "Edited 11-May-93 02:11 by jds")


    (* ;; "Actually emit the PS commands to change to a font on the stream known  to be different than what's currently there.")


    (LET* ((PSPROPS (ffetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 (ffetch
 (\POSTSCRIPTDATA 
                                                                                    POSTSCRIPTFONT)
                                                                        of
 IMAGEDATA)))
           [FONTID (fetch
 (PSCFONT IL-FONTID) of
 (GETMULTI PSPROPS 'PSCFONT]
           (FONTIDNAME (CL:IF (LISTP FONTID)
                           (fetch
 (FONTID FONTIDNAME) of
 FONTID)
                           FONTID)))
          (CL:UNLESS (MEMB FONTIDNAME (fetch
 (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of
 IMAGEDATA))
              (CL:PUSH FONTIDNAME (fetch
 (\POSTSCRIPTDATA POSTSCRIPTFONTSUSED) of
 IMAGEDATA))

              (* ;; "If the new font hasn't been used (on this page) before, re-encode it to support accented characters.")


              (CL:UNLESS (GETMULTI PSPROPS 'UNACCENTED)
                     (POSTSCRIPT.PUTCOMMAND
 STREAM "/" FONTIDNAME " /" FONTIDNAME "-Acnt encodefont"
                            :EOL)))
          (POSTSCRIPT.PUTCOMMAND
 STREAM (GETMULTI PSPROPS 'FONTCHANGESTRING)
                 :EOL)
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of
 IMAGEDATA with
 NIL])

(\TERPRI.PSC

  [LAMBDA (STREAM)
                                           (* ; "Edited  1-Sep-2026 12:19 by rmk")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (LET* [(IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (NEWY (PLUS (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA)
                       (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) of
 IMAGEDATA]
          (COND
             ([LESSP NEWY (IPLUS (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 IMAGEDATA)
                                 (fetch
 (FONTDESCRIPTOR FONTDESCENT) of
 (ffetch
 (\POSTSCRIPTDATA
                                                                                 POSTSCRIPTFONT)
                                                                           of
 IMAGEDATA]
              (DSPNEWPAGE STREAM))
             (T (replace
 (STREAM CHARPOSITION) of
 STREAM with
 0)
                (\MOVETO.PSC
 STREAM (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA)
                       NEWY)))
          NIL])
)



(* ;; "DIG operations: ")


(DEFINEQ

(\BITBLT.PSC

  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
                 SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM)

                                                             (* ; "Edited  7-Apr-89 19:53 by TAL")

    (\SCALEDBITBLT.PSC
 SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM
           WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
           CLIPPEDSOURCEBOTTOM 1])

(\BLTSHADE.PSC

  [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)

                                                             (* ; "Edited  5-Jun-2025 16:11 by mth")


                                                             (* ; "Edited 28-Apr-2025 00:05 by mth")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")


    (* ;; "Maybe we should do something with OPERATION")


    (LET ((RGN (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT))
          (IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          TEXTUREBM TEXTUREWIDTH LEFT BOTTOM WIDTH HEIGHT)
         [COND
            [CLIPPINGREGION (SETQ RGN (INTERSECTREGIONS RGN CLIPPINGREGION (fetch
 (\POSTSCRIPTDATA
                                                                                   
                                                                             POSTSCRIPTCLIPPINGREGION
                                                                                   ) of
 IMAGEDATA]
            (T (SETQ RGN (INTERSECTREGIONS RGN (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION)
                                                  of
 IMAGEDATA]
         (COND
            (RGN (SETQ LEFT (fetch
 (REGION LEFT) of
 RGN))
                 (SETQ BOTTOM (fetch
 (REGION BOTTOM) of
 RGN))
                 (SETQ WIDTH (CL:1- (fetch
 (REGION WIDTH) of
 RGN)))
                 (SETQ HEIGHT (CL:1- (fetch
 (REGION HEIGHT) of
 RGN)))
                 [COND
                    ((FIXP TEXTURE)
                     (SETQ TEXTURE (SELECT TEXTURE ((BLACKSHADE -1)
                                                    'BLACK)
                                          (WHITESHADE 'WHITE)
                                          TEXTURE]
                 [COND
                    ((TEXTUREP TEXTURE)
                     (SETQ TEXTUREBM (BITMAPCREATE 16 16 1))
                     (SETQ TEXTUREWIDTH 16)
                     (BLTSHADE TEXTURE TEXTUREBM))
                    ((BITMAPP TEXTURE)
                     (SETQ TEXTUREWIDTH (MIN (fetch
 BITMAPWIDTH of
 TEXTUREBM)
                                             (fetch
 BITMAPHEIGHT of
 TEXTUREBM)))
                     (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1))
                     (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE))
                    (T (CL:MULTIPLE-VALUE-BIND (COLOR GRAY COLORSTR)
                              (\PSC.COLOR.TO.RGB
 TEXTURE (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCOLOR)
                                                            of
 IMAGEDATA))

                              (* ;; "Default to the current stream color")


                              (POSTSCRIPT.PUTCOMMAND
 STREAM HEIGHT " " WIDTH " " LEFT " " BOTTOM " "
                                     COLORSTR (OR (AND GRAY "RG")
                                                  "R")
                                     :EOL]
                 (COND
                    (TEXTUREBM (POSTSCRIPT.PUTCOMMAND
 STREAM "gsave newpath ")
                           (POSTSCRIPT.PUTCOMMAND
 STREAM "100 100 scale " (QUOTIENT LEFT 100.0)
                                  " "
                                  (QUOTIENT BOTTOM 100.0)
                                  " M "
                                  (SETQ WIDTH (QUOTIENT WIDTH 100.0))
                                  " 0 rlineto 0 "
                                  (QUOTIENT HEIGHT 100.0)
                                  " rlineto "
                                  (MINUS WIDTH)
                                  " 0 rlineto closepath" :EOL)
                           (POSTSCRIPT.PUTBITMAPBYTES
 STREAM TEXTUREBM T)
                           (POSTSCRIPT.PUTCOMMAND
 STREAM TEXTUREWIDTH " "
                                  (LSH (fetch
 BITMAPRASTERWIDTH of
 TEXTUREBM)
                                       1)
                                  " 0 "
                                  (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM)
                                                   100.0))
                                  " findresolution " TEXTUREWIDTH " div div ceiling " 
                                  POSTSCRIPT.TEXTURE.SCALE " mul setpattern eofill" :EOL "grestore" 
                                  :EOL)))
                 (\MOVETO.PSC
 STREAM DESTINATIONLEFT DESTINATIONBOTTOM)
                 T)
            (T NIL])

(\CHARWIDTH.PSC

  [LAMBDA (STREAM CHARCODE)
                                  (* ; "Edited  8-May-93 11:19 by rmk:")

    (COND
       ((EQ CHARCODE (CHARCODE SPACE))
        (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of
 (ffetch
 (STREAM IMAGEDATA) of
 STREAM)))
       ((\FGETCHARWIDTH (fetch
 (\POSTSCRIPTDATA POSTSCRIPTFONT) of
 (ffetch
 (STREAM IMAGEDATA)
                                                                      of
 STREAM))
               CHARCODE])

(\DRAWARC.PSC

  [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING)

                                                             (* ; "Edited 27-Apr-2025 23:49 by mth")


                                                             (* ; "Edited 26-Apr-2025 17:16 by mth")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          WIDTH COLOR)
         [COND
            ((NUMBERP BRUSH)
             (SETQ WIDTH BRUSH))
            ((LISTP BRUSH)
             (COND
                ((NEQ (fetch
 BRUSHSHAPE of
 BRUSH)
                      'ROUND)
                 (printout T T 
                        "[In \DRAWARC.PSC: Non-ROUND BRUSH not supported.]
[Using ROUND BRUSH]" T)))
             (SETQ WIDTH (fetch
 BRUSHSIZE of
 BRUSH))
             (SETQ COLOR (fetch
 BRUSHCOLOR of
 BRUSH)))
            (T                                               (* ; "If FUNCTIONAL BRUSH big trouble!")

               (printout T T 
                     "[In \DRAWARC.PSC: Functional BRUSH not supported.]
[Using ROUND 1 point BRUSH]" T)
               (SETQ WIDTH (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA]
         (COND
            ((NOT (ZEROP WIDTH))
             (POSTSCRIPT.PUTCOMMAND
 STREAM :EOL "gsave newpath ")
             (POSTSCRIPT.PUTRGBCOLOR
 STREAM COLOR T)
             (COND
                ((LISTP DASHING)
                 (POSTSCRIPT.OUTSTR
 STREAM " [")
                 (for
 D in
 DASHING do
 (POSTSCRIPT.PUTCOMMAND
 STREAM (TIMES D WIDTH)
                                             " "))
                 (POSTSCRIPT.PUTCOMMAND
 STREAM "] 0 setdash" :EOL)
                                                             (* ; 

           "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")

                 ))
             (POSTSCRIPT.PUTCOMMAND
 STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " CENTERX
                    " " CENTERY " " RADIUS " " STARTANGLE " " (+ STARTANGLE NDEGREES)
                    " arc stroke" :EOL "grestore" :EOL)))
         (\MOVETO.PSC
 STREAM CENTERX CENTERY])

(\DRAWCIRCLE.PSC

  [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING)
      (* ; "Edited 27-Apr-2025 23:50 by mth")


                                                             (* ; "Edited 26-Apr-2025 17:16 by mth")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          WIDTH COLOR)
         [COND
            ((NUMBERP BRUSH)
             (SETQ WIDTH BRUSH))
            ((LISTP BRUSH)
             (COND
                ((NEQ (fetch
 BRUSHSHAPE of
 BRUSH)
                      'ROUND)
                 (printout T T 
                        "[In \DRAWCIRCLE.PSC: Non-ROUND BRUSH not supported.]
[Using ROUND BRUSH]" T)))
             (SETQ WIDTH (fetch
 BRUSHSIZE of
 BRUSH))
             (SETQ COLOR (fetch
 BRUSHCOLOR of
 BRUSH)))
            (T                                               (* ; "If FUNCTIONAL BRUSH big trouble!")

               (printout T T 
                      "[In \DRAWCIRCLE.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
               (SETQ WIDTH (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA]
         (COND
            ((NOT (ZEROP WIDTH))
             (POSTSCRIPT.PUTCOMMAND
 STREAM :EOL "gsave newpath ")
             (POSTSCRIPT.PUTRGBCOLOR
 STREAM COLOR T)
             (COND
                ((LISTP DASHING)
                 (POSTSCRIPT.OUTSTR
 STREAM " [")
                 (for
 D in
 DASHING do
 (POSTSCRIPT.PUTCOMMAND
 STREAM (TIMES D WIDTH)
                                             " "))
                 (POSTSCRIPT.PUTCOMMAND
 STREAM "] 0 setdash" :EOL)
                                                             (* ; 

           "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")

                 ))
             (POSTSCRIPT.PUTCOMMAND
 STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " CENTERX
                    " " CENTERY " " RADIUS " 0 360 arc stroke" :EOL "grestore" :EOL)))
         (\MOVETO.PSC
 STREAM CENTERX CENTERY])

(\DRAWCURVE.PSC

  [LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING)
                (* ; "Edited 27-Apr-2025 23:50 by mth")


                                                             (* ; "Edited 26-Apr-2025 17:17 by mth")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          WIDTH SHAPE COLOR PSPLINE XA YA DXA DYA N PREVX PREVY PREV-DX3 PREV-DY3)
         [COND
            ((NUMBERP BRUSH)
             (SETQ WIDTH BRUSH)
             (SETQ SHAPE 'ROUND))
            ((LISTP BRUSH)
             (SETQ WIDTH (fetch
 BRUSHSIZE of
 BRUSH))
             (SETQ SHAPE (fetch
 BRUSHSHAPE of
 BRUSH))
             (SETQ COLOR (fetch
 BRUSHCOLOR of
 BRUSH)))
            (T 
               (* ;; "If FUNCTIONAL BRUSH then BIG trouble!")


               (printout T T 
                      "[In \DRAWCURVE.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
               (SETQ WIDTH (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA))
               (SETQ SHAPE 'ROUND]
         (COND
            ((NOT (ZEROP WIDTH))
             (POSTSCRIPT.PUTCOMMAND
 STREAM :EOL "gsave newpath ")
             (POSTSCRIPT.PUTRGBCOLOR
 STREAM COLOR T)
             (COND
                ((LISTP DASHING)
                 (POSTSCRIPT.OUTSTR
 STREAM " [")
                 (for
 D in
 DASHING do
 (POSTSCRIPT.PUTCOMMAND
 STREAM (TIMES D WIDTH)
                                             " ") 

                                      (* ;; 

           "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")

)
                 (POSTSCRIPT.PUTCOMMAND
 STREAM "] 0 setdash" :EOL)))
             (SETQ PSPLINE (PARAMETRICSPLINE KNOTS CLOSED NIL))
             (SETQ N (pop
 PSPLINE))
             (SETQ XA (pop
 PSPLINE))
             (SETQ YA (pop
 PSPLINE))
             (SETQ DXA (pop
 PSPLINE))
             (SETQ DYA (pop
 PSPLINE))
             (POSTSCRIPT.PUTCOMMAND
 STREAM (SELECTQ SHAPE
                                               (ROUND " 1 setlinecap 1 setlinejoin ")
                                               (SQUARE " 2 setlinecap 0 setlinejoin ")
                                               " 0 setlinecap 0 setlinejoin ")
                    WIDTH " setlinewidth " (SETQ PREVX (ELT XA 1))
                    " "
                    (SETQ PREVY (ELT YA 1))
                    " M" :EOL)
             (SETQ PREV-DX3 (FQUOTIENT (ELT DXA 1)
                                   3.0))
             (SETQ PREV-DY3 (FQUOTIENT (ELT DYA 1)
                                   3.0))
             (for
 C from
 2 to
 N do
 (POSTSCRIPT.PUTCOMMAND
 STREAM (FPLUS PREVX PREV-DX3)
                                          " "
                                          (FPLUS PREVY PREV-DY3)
                                          " "
                                          (FDIFFERENCE (SETQ PREVX (ELT XA C))
                                                 (SETQ PREV-DX3 (FQUOTIENT (ELT DXA C)
                                                                       3.0)))
                                          " "
                                          (FDIFFERENCE (SETQ PREVY (ELT YA C))
                                                 (SETQ PREV-DY3 (FQUOTIENT (ELT DYA C)
                                                                       3.0)))
                                          " " PREVX " " PREVY " curveto" :EOL))
             (POSTSCRIPT.PUTCOMMAND
 STREAM "stroke" :EOL "grestore" :EOL)))
         (\MOVETO.PSC
 STREAM PREVX PREVY))
    NIL])

(\DRAWELLIPSE.PSC

  [LAMBDA (STREAM CENTERX CENTERY MINORRADIUS MAJORRADIUS ORIENTATION BRUSH DASHING)

                                                             (* ; "Edited 27-Apr-2025 23:51 by mth")


                                                             (* ; "Edited 26-Apr-2025 17:18 by mth")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          WIDTH COLOR)
         [COND
            ((NUMBERP BRUSH)
             (SETQ WIDTH BRUSH))
            ((LISTP BRUSH)
             (COND
                ((NEQ (fetch
 BRUSHSHAPE of
 BRUSH)
                      'ROUND)
                 (printout T T 
                        "[In \DRAWELLIPSE.PSC: Non-ROUND BRUSH not supported.]
[Using ROUND BRUSH]" T)))
             (SETQ WIDTH (fetch
 BRUSHSIZE of
 BRUSH))
             (SETQ COLOR (fetch
 BRUSHCOLOR of
 BRUSH)))
            (T                                               (* ; "If FUNCTIONAL BRUSH, big trouble!")

               (printout T T 
                     "[In \DRAWELLIPSE.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
               (SETQ WIDTH (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA]
         (COND
            ((NOT (ZEROP WIDTH))
             (POSTSCRIPT.PUTCOMMAND
 STREAM :EOL "gsave newpath ")
             (POSTSCRIPT.PUTRGBCOLOR
 STREAM COLOR T)
             (COND
                ((LISTP DASHING)
                 (POSTSCRIPT.OUTSTR
 STREAM " [")
                 (for
 D in
 DASHING do
 (POSTSCRIPT.PUTCOMMAND
 STREAM (TIMES D WIDTH)
                                             " ") 

                                      (* ;; 

           "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")

)
                 (POSTSCRIPT.PUTCOMMAND
 STREAM "] 0 setdash" :EOL)))
             (POSTSCRIPT.PUTCOMMAND
 STREAM WIDTH " setlinewidth 1 setlinecap 1 setlinejoin " CENTERX
                    " " CENTERY " " MAJORRADIUS " " MINORRADIUS " " ORIENTATION 
                    " 0 360 ellipse stroke" :EOL "grestore" :EOL)))
         (\MOVETO.PSC
 STREAM CENTERX CENTERY])

(\DRAWLINE.PSC

  [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING)
 (* ; "Edited  5-Jun-2025 14:19 by mth")


                                                             (* ; "Edited 28-Apr-2025 00:11 by mth")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")


    (* ;; "DRAWLINE method for postscript streams.")


    (CL:WHEN (LESSP X2 X1)

        (* ;; "For Syntelligence, make all lines move from left to right, to defeat a bug in SPARCPrinter PS decoder.")


        (CL:PSETQ X1 X2 X2 X1 Y1 Y2 Y2 Y1))
    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (CURRENTCOLOR (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCOLOR) of
 IMAGEDATA)))
          [COND
             ((NOT (NUMBERP WIDTH))

              (* ;; "The WIDTH = NIL should have been handled before here, but just in case!")


              (SETQ WIDTH (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA]
          [COND
             ((NOT (ZEROP WIDTH))
              (CL:MULTIPLE-VALUE-BIND (RGB GRAY COLORSTR DIFFERENT)
                     (\PSC.COLOR.TO.RGB
 COLOR CURRENTCOLOR T)
                     (COND
                        ((NOT (OR DIFFERENT (LISTP DASHING)))(* ; 

                                                             "Simple case, no dash or color change")

                         (POSTSCRIPT.PUTCOMMAND
 STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH " L" :EOL))
                        (T (POSTSCRIPT.PUTCOMMAND
 STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH " ")
                           (POSTSCRIPT.PUTCOMMAND
 STREAM COLORSTR " [")
                           (POSTSCRIPT.PUTCOMMAND
 STREAM)
                           (for
 D in
 (LISTP DASHING) do
 
                                                        (* ;; 

                       "Interlisp DASHING is in terms of BRUSH units, so multiply by the brush size.")


                                                        (POSTSCRIPT.PUTCOMMAND
 STREAM
                                                               (TIMES D WIDTH)
                                                               " "))
                           (POSTSCRIPT.PUTCOMMAND
 STREAM "]" (OR (AND GRAY " L1G")
                                                                 " L1")
                                  :EOL]
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA with
 X2)
          (freplace
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA with
 Y2)
          (freplace
 (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of
 IMAGEDATA with
 NIL])

(\DRAWPOINT.PSC

  [LAMBDA (STREAM X Y BRUSH OPERATION)
                (* ; "Edited 30-Mar-90 17:53 by Matt Heffron")


    (* ;; "draw a point on the stream ")


    (if
 (BITMAPP BRUSH)
        then
 (LET ((WIDTH (fetch
 BITMAPWIDTH of
 BRUSH))
                   (HEIGHT (fetch
 BITMAPHEIGHT of
 BRUSH)))
                  (BITBLT BRUSH 0 0 STREAM (- X (IQUOTIENT WIDTH 2))
                         (- Y (IQUOTIENT HEIGHT 2))
                         WIDTH HEIGHT OPERATION))
      else
 (\DRAWLINE.PSC
 STREAM X Y X Y BRUSH OPERATION])

(\DRAWPOLYGON.PSC

  [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING)
               (* ; "Edited 27-Apr-2025 23:51 by mth")


                                                             (* ; "Edited 26-Apr-2025 17:32 by mth")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:17 by sybalsky:mv:envos")

    (LET ((LASTPOINT (CAR (LAST POINTS)))
          (IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          WIDTH SHAPE COLOR)
         [COND
            ((NUMBERP BRUSH)
             (SETQ WIDTH BRUSH)
             (SETQ SHAPE 'ROUND))
            ((LISTP BRUSH)
             (SETQ WIDTH (fetch
 BRUSHSIZE of
 BRUSH))
             (SETQ SHAPE (fetch
 BRUSHSHAPE of
 BRUSH))
             (SETQ COLOR (fetch
 BRUSHCOLOR of
 BRUSH)))
            (T 
               (* ;; "If FUNCTIONAL BRUSH then BIG trouble!")


               (printout T T 
                     "[In \DRAWPOLYGON.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
               (SETQ WIDTH (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA))
               (SETQ SHAPE 'ROUND]
         (COND
            ((NOT (ZEROP WIDTH))
             (POSTSCRIPT.PUTCOMMAND
 STREAM :EOL "gsave newpath ")
             (POSTSCRIPT.PUTRGBCOLOR
 STREAM COLOR T)
             (COND
                ((LISTP DASHING)
                 (POSTSCRIPT.OUTSTR
 STREAM " [")
                 (for
 D in
 DASHING do
 (POSTSCRIPT.PUTCOMMAND
 STREAM (TIMES D WIDTH)
                                             " ") 

                                      (* ;; 

           "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")

)
                 (POSTSCRIPT.PUTCOMMAND
 STREAM "] 0 setdash" :EOL)))
             (POSTSCRIPT.PUTCOMMAND
 STREAM (SELECTQ SHAPE
                                               (ROUND " 1 setlinecap 1 setlinejoin ")
                                               (SQUARE " 2 setlinecap 0 setlinejoin ")
                                               " 0 setlinecap 0 setlinejoin ")
                    WIDTH " setlinewidth " (fetch
 (POSITION XCOORD) of
 (CAR POINTS))
                    " "
                    (fetch
 (POSITION YCOORD) of
 (CAR POINTS))
                    " M" :EOL)
             (for
 P in
 (CDR POINTS) do
 (POSTSCRIPT.PUTCOMMAND
 STREAM (fetch
 (POSITION XCOORD)
                                                                        of
 P)
                                              " "
                                              (fetch
 (POSITION YCOORD) of
 P)
                                              " lineto" :EOL))
             (COND
                (CLOSED (POSTSCRIPT.PUTCOMMAND
 STREAM " closepath")))
             (POSTSCRIPT.PUTCOMMAND
 STREAM " stroke" :EOL "grestore" :EOL)))
         (\MOVETO.PSC
 STREAM (fetch
 (POSITION XCOORD) of
 LASTPOINT)
                (fetch
 (POSITION YCOORD) of
 LASTPOINT])

(\DSPBOTTOMMARGIN.PSC

  [LAMBDA (STREAM YPOSITION)                                 (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (PROG1 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 (fetch
 (STREAM IMAGEDATA) of
 STREAM))
        (COND
           (YPOSITION (replace
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 (fetch
 (STREAM IMAGEDATA)
                                                                              of
 STREAM) with
 
                                                                                            YPOSITION
                             ))))])

(\DSPCLIPPINGREGION.PSC

  [LAMBDA (STREAM REGION)                                    (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (OLDCLIP (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA)))
          (COND
             ([AND REGION (NOT (AND (EQP (fetch
 (REGION LEFT) of
 OLDCLIP)
                                         (fetch
 (REGION LEFT) of
 REGION))
                                    (EQP (fetch
 (REGION BOTTOM) of
 OLDCLIP)
                                         (fetch
 (REGION BOTTOM) of
 REGION))
                                    (EQP (fetch
 (REGION WIDTH) of
 OLDCLIP)
                                         (fetch
 (REGION WIDTH) of
 REGION))
                                    (EQP (fetch
 (REGION HEIGHT) of
 OLDCLIP)
                                         (fetch
 (REGION HEIGHT) of
 REGION]
              (POSTSCRIPT.SHOWACCUM
 STREAM)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA with
 REGION)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA with
 T)
              (\FIXLINELENGTH.PSC
 STREAM IMAGEDATA)))
          OLDCLIP])

(\DSPCOLOR.PSC

  [LAMBDA (STREAM COLOR)
                                     (* ; "Edited  2-Oct-2026 23:29 by rmk")


                                                             (* ; "Edited  4-Jun-2025 23:51 by mth")


                                                             (* ; "Edited 26-Apr-2025 17:03 by mth")


                                                             (* ; "Edited 14-Jan-93 17:14 by jds")


    (* ;; " Code below adapted from 7-Oct-1989 version by DJVB")


    (* ;; 

    " All postscript printers accept color RGB info, though most just pick a gray based on values")


    (LET* ((IMAGEDATA (fetch
 IMAGEDATA of
 STREAM))
           (CURRENT (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCOLOR) of
 IMAGEDATA)))
          (if
 COLOR
              then
 (replace
 (\POSTSCRIPTDATA POSTSCRIPTCOLOR) of
 IMAGEDATA with
 (

                                                                               POSTSCRIPT.PUTRGBCOLOR

                                                                                 STREAM COLOR)))
          CURRENT])

(\DSPFONT.PSC

  [LAMBDA (STREAM FONT)
                                      (* ; "Edited  2-Oct-2026 23:11 by rmk")


                                                             (* ; "Edited 28-Sep-2026 21:17 by rmk")


                                                             (* ; "Edited 19-Sep-2026 22:31 by rmk")


                                                             (* ; "Edited  3-Sep-2026 23:54 by rmk")


                                                             (* ; "Edited  1-Sep-2026 12:19 by rmk")


                                                             (* ; "Edited 14-Jul-2025 22:21 by rmk")

                                                             (* ; 

                                                        "Edited 26-May-93 01:06 by sybalsky:mv:envos")

                                                             (* ; "Edited 11-May-93 02:11 by jds")

                                                             (* ; "Edited 19-Jan-93 17:17 by jds")


    (* ;; "Change fonts on the PostScript stream STREAM to be FONT.")


    (* ;; "Doesn't actually write the font-change command to the stream (it saves doing that until the font is actually needed, so that multiple font changes don't yield larger PS files).")


    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (OLDFONT (fetch
 (\POSTSCRIPTDATA POSTSCRIPTFONT) of
 IMAGEDATA))
           NEWFONT FONTID)

          (* ;; "Arg checking in FONTCREATE is expensive")


          (CL:WHEN [AND FONT (NEQ FONT OLDFONT)
                        (SETQ NEWFONT (if
 [AND (type?
 FONTDESCRIPTOR FONT)
                                               (EQ (FONTPROP OLDFONT 'DEVICE)
                                                   (FONTPROP FONT 'DEVICE]
                                          then
 FONT
                                        elseif
 (FONTCREATE FONT NIL NIL NIL STREAM T)
                                        else
 

                                           (* ;; "NOERRORFLG above so that we can fall over to FONTCOPY. FONTCOPY will error if it can't return a font descriptor")


                                             (FONTCOPY OLDFONT FONT]

              (* ;; "OK, NEWFONT is good")


              (POSTSCRIPT.SHOWACCUM
 STREAM)                  (* ; 

                                                             " Write out any accumulated characters.")


              (* ;; "Change the font in the Lisp stream:")


              (replace
 (\POSTSCRIPTDATA POSTSCRIPTFONT) of
 IMAGEDATA with
 NEWFONT)

              (* ;; "and now update all font-dependent fields in the imagedata, EXCEPT POSTSCRIPTSPACEWIDTH and POSTSCRIPTNATURALSPACEWIDTH.  These latter 2 must stay as-is up thru the actual writing of characters by SHOWACCUM, so")


              (AND T (\POSTSCRIPT.CHANGECHARSET
 IMAGEDATA 0))
              [\DSPLINEFEED.PSC
 STREAM (IMINUS (FONTPROP NEWFONT 'HEIGHT]
              [replace
 (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of
 IMAGEDATA
                 with
 (FIXR (TIMES (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of
 IMAGEDATA)
                                   (replace
 (\POSTSCRIPTDATA POSTSCRIPTNATURALSPACEWIDTH)
                                      of
 IMAGEDATA with
 (\FGETWIDTH (fetch
 (\POSTSCRIPTDATA 
                                                                                  POSTSCRIPTWIDTHS)
                                                                       of
 IMAGEDATA)
                                                               (CHARCODE SPACE]
              (\FIXLINELENGTH.PSC
 STREAM IMAGEDATA)

              (* ;; "Remember to actually write a change command")


              (replace
 (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of
 IMAGEDATA with
 T))
          OLDFONT])

(\DSPLEFTMARGIN.PSC

  [LAMBDA (STREAM XPOSITION)                                 (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM)))
         (PROG1 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA)
             (COND
                (XPOSITION (replace
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA with
 
                                                                                            XPOSITION
                                  )
                       (\FIXLINELENGTH.PSC
 STREAM IMAGEDATA))))])

(\DSPLINEFEED.PSC

  [LAMBDA (STREAM LINELEADING)                               (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (PROG1 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) of
 (fetch
 (STREAM IMAGEDATA) of
 STREAM))
        (COND
           (LINELEADING (replace
 (\POSTSCRIPTDATA POSTSCRIPTLINESPACING) of
 (fetch
 (STREAM IMAGEDATA)
                                                                               of
 STREAM)
                           with
 LINELEADING))))])

(\DSPPUSHSTATE.PSC

  [LAMBDA (STREAM)                                           (* ; 

                                                        "Edited 20-Nov-92 15:12 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM)))
         (push
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTXFORMSTACK) of
 IMAGEDATA)
               (create
 POSTSCRIPTXFORM
                      PSXCLIP ← (COPY (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA)
                                      )
                      PSXPAGE ← (COPY (fetch
 (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of
 IMAGEDATA))
                      PSXLEFT ← (fetch
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA)
                      PSXRIGHT ← (fetch
 (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of
 IMAGEDATA)
                      PSXTOP ← (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 IMAGEDATA)
                      PSXBOTTOM ← (fetch
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 IMAGEDATA)
                      PSXTRANX ← (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of
 IMAGEDATA)
                      PSXTRANY ← (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of
 IMAGEDATA)
                      PSXLAND ← (fetch
 (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of
 IMAGEDATA)
                      PSXXFORMPEND ← (fetch
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA])

(\DSPPOPSTATE.PSC

  [LAMBDA (STREAM)                                           (* ; 

                                                        "Edited 20-Nov-92 15:15 by sybalsky:mv:envos")

    (LET* [(IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (XFORM (pop
 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTXFORMSTACK) of
 IMAGEDATA]
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA with
 (fetch
 (
                                                                                      POSTSCRIPTXFORM
                                                                                        PSXCLIP)
                                                                                   of
 XFORM))
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of
 IMAGEDATA with
 (fetch
 (POSTSCRIPTXFORM
                                                                                    PSXPAGE)
                                                                               of
 XFORM))
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 IMAGEDATA with
 (fetch
 (POSTSCRIPTXFORM
                                                                                      PSXBOTTOM)
                                                                                 of
 XFORM))
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 IMAGEDATA with
 (fetch
 (POSTSCRIPTXFORM
                                                                                   PSXTOP)
                                                                              of
 XFORM))
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA with
 (fetch
 (POSTSCRIPTXFORM
                                                                                    PSXLEFT)
                                                                               of
 XFORM))
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of
 IMAGEDATA with
 (fetch
 (POSTSCRIPTXFORM
                                                                                     PSXRIGHT)
                                                                                of
 XFORM))
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTLANDSCAPE) of
 IMAGEDATA with
 (fetch
 (POSTSCRIPTXFORM
                                                                                   PSXLAND)
                                                                              of
 XFORM))
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA with
 (fetch
 (POSTSCRIPTXFORM
                                                                                      PSXXFORMPEND)
                                                                                 of
 XFORM))
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of
 IMAGEDATA with
 (fetch
 (POSTSCRIPTXFORM
                                                                                PSXTRANX)
                                                                           of
 XFORM))
          (replace
 (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of
 IMAGEDATA with
 (fetch
 (POSTSCRIPTXFORM
                                                                                PSXTRANY)
                                                                           of
 XFORM])

(\DSPRESET.PSC

  [LAMBDA (STREAM)                                           (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM)))
         (replace
 (STREAM CHARPOSITION) of
 STREAM with
 0)
         (\MOVETO.PSC
 STREAM (fetch
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA)
                (DIFFERENCE (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 IMAGEDATA)
                       (FONTPROP (fetch
 (\POSTSCRIPTDATA POSTSCRIPTFONT) of
 IMAGEDATA)
                              'ASCENT])

(\DSPRIGHTMARGIN.PSC

  [LAMBDA (STREAM XPOSITION)                                 (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM)))
         (PROG1 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of
 IMAGEDATA)
             (COND
                (XPOSITION (replace
 (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of
 IMAGEDATA with
 
                                                                                            XPOSITION
                                  )
                       (\FIXLINELENGTH.PSC
 STREAM IMAGEDATA))))])

(\DSPROTATE.PSC

  [LAMBDA (STREAM ROTATION)                                  (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")


    (* ;; "rotate the postscript  stream by ROTATION")


    (* ;; 

    "we only know 90 degrees of rotation for now (0 means portrait, anything else is landscape).")


    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (OROT (fetch
 (\POSTSCRIPTDATA POSTSCRIPTROTATION) of
 IMAGEDATA))
           LAND C0 P0 C P ML MB MR MT)
          (COND
             ((AND ROTATION (NEQ ROTATION (fetch
 (\POSTSCRIPTDATA POSTSCRIPTROTATION) of
 IMAGEDATA)))
              (POSTSCRIPT.SHOWACCUM
 STREAM)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTROTATION) of
 IMAGEDATA with
 ROTATION)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA with
 T)
              (\DSPRESET.PSC
 STREAM)))
          OROT])

(\DSPSCALE.PSC

  [LAMBDA (STREAM SCALE)                                     (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")

    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (OSCALE (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA))
           NSCALE)
          (COND
             ((AND NIL 

                   (* ;; "Changing SCALE is not implemented.  According to IRM.")


                   (NUMBERP SCALE)
                   (CL:PLUSP SCALE))
              (SETQ NSCALE (QUOTIENT SCALE OSCALE))

              (* ;; 

        "NSCALE is the adjustment for the fact that the scale operator takes RELATIVE scale changes.")


              (POSTSCRIPT.PUTCOMMAND
 STREAM " " NSCALE " " NSCALE " scale" :EOL)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA with
 SCALE)))
          OSCALE])

(\DSPSCALE2.PSC

  [LAMBDA (STREAM X-SCALE Y-SCALE)                           (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")


    (* ;; "SETS X AND Y SCALE ")


    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (OSCALE (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSCALE) of
 IMAGEDATA))
           NSCALE)
          (COND
             ((AND X-SCALE (NUMBERP X-SCALE)
                   (CL:PLUSP X-SCALE))
              (POSTSCRIPT.SHOWACCUM
 STREAM)
              (\UPDATE.PSC
 STREAM IMAGEDATA)

              (* ;; 

        "NSCALE is the adjustment for the fact that the scale operator takes RELATIVE scale changes.")


              (POSTSCRIPT.PUTCOMMAND
 STREAM " " X-SCALE " " Y-SCALE " scale" :EOL)))
          T])

(\DSPSPACEFACTOR.PSC

  [LAMBDA (STREAM FACTOR)                                    (* ; 

                                                        "Edited 26-May-93 01:18 by sybalsky:mv:envos")

    (DECLARE
 (LOCALVARS . T))
    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (OLDFACTOR (fetch
 (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of
 IMAGEDATA)))
          [COND
             ((AND (NUMBERP FACTOR)
                   (NOT (EQUAL FACTOR OLDFACTOR)))
              (POSTSCRIPT.SHOWACCUM
 STREAM)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTSPACEFACTOR) of
 IMAGEDATA with
 FACTOR)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH) of
 IMAGEDATA
                 with
 (FIXR (TIMES FACTOR (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTNATURALSPACEWIDTH)
                                             of
 IMAGEDATA]
          OLDFACTOR])

(\DSPTOPMARGIN.PSC

  [LAMBDA (STREAM YPOSITION)                                 (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")

    (PROG1 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 (fetch
 (STREAM IMAGEDATA) of
 STREAM))
        (COND
           (YPOSITION (replace
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 (fetch
 (STREAM IMAGEDATA)
                                                                           of
 STREAM) with
 YPOSITION)
                  )))])

(\DSPTRANSLATE.PSC

  [LAMBDA (STREAM TX TY)                                     (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")

    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (MDX (DIFFERENCE (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of
 IMAGEDATA)
                       TX))
           (MDY (DIFFERENCE (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of
 IMAGEDATA)
                       TY)))
          (COND
             ((NOT (AND (ZEROP MDX)
                        (ZEROP MDY)))
              (POSTSCRIPT.SHOWACCUM
 STREAM)
              (for
 REG in
 (LIST (fetch
 (\POSTSCRIPTDATA POSTSCRIPTCLIPPINGREGION) of
 IMAGEDATA)
                                (fetch
 (\POSTSCRIPTDATA POSTSCRIPTPAGEREGION) of
 IMAGEDATA))
                 do
 (CL:INCF (fetch
 (REGION LEFT) of
 REG)
                           MDX)
                    (CL:INCF (fetch
 (REGION BOTTOM) of
 REG)
                           MDY))
              (CL:INCF (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA)
                     MDX)
              (CL:INCF (fetch
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA)
                     MDY)
              (CL:INCF (fetch
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN) of
 IMAGEDATA)
                     MDX)
              (CL:INCF (fetch
 (\POSTSCRIPTDATA POSTSCRIPTRIGHTMARGIN) of
 IMAGEDATA)
                     MDX)
              (CL:INCF (fetch
 (\POSTSCRIPTDATA POSTSCRIPTBOTTOMMARGIN) of
 IMAGEDATA)
                     MDY)
              (CL:INCF (fetch
 (\POSTSCRIPTDATA POSTSCRIPTTOPMARGIN) of
 IMAGEDATA)
                     MDY)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTTRANSX) of
 IMAGEDATA with
 TX)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTTRANSY) of
 IMAGEDATA with
 TY)
              (replace
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA with
 T])

(\DSPXPOSITION.PSC

  [LAMBDA (STREAM XPOSITION)                                 (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          OLDX)
         (PROG1 (SETQ OLDX (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA))
             [COND
                ((AND XPOSITION (NOT (EQUAL XPOSITION OLDX)))
                 (\MOVETO.PSC
 STREAM XPOSITION (fetch
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA])])

(\DSPYPOSITION.PSC

  [LAMBDA (STREAM YPOSITION)                                 (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          OLDY)
         (PROG1 (SETQ OLDY (fetch
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA))
             (COND
                ((AND YPOSITION (NOT (EQUAL YPOSITION OLDY)))
                 (\MOVETO.PSC
 STREAM (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA)
                        YPOSITION))))])

(\FILLCIRCLE.PSC

  [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE)
            (* ; "Edited 27-Apr-2025 23:58 by mth")


                                                      (* ; "Edited 30-Mar-90 17:59 by Matt Heffron")

    (LET (TEXTUREBM TEXTUREWIDTH)
         (POSTSCRIPT.PUTCOMMAND
 STREAM :EOL "gsave newpath ")
         [if
 (FIXP TEXTURE)
             then
 (if
 (ZEROP TEXTURE)
                      then
 (SETQ TEXTURE 'WHITE)
                    elseif
 (OR (EQL TEXTURE 65535)
                               (EQL TEXTURE -1))
                      then
 (SETQ TEXTURE 'BLACK]
         (COND
            ((TEXTUREP TEXTURE)
             (SETQ TEXTUREBM (BITMAPCREATE 16 16 1))
             (SETQ TEXTUREWIDTH 16)
             (BLTSHADE TEXTURE TEXTUREBM))
            ((BITMAPP TEXTURE)
             (SETQ TEXTUREWIDTH (MIN (fetch
 BITMAPWIDTH of
 TEXTUREBM)
                                     (fetch
 BITMAPHEIGHT of
 TEXTUREBM)))
             (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1))
             (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE))
            (TEXTURE (POSTSCRIPT.PUTRGBCOLOR
 STREAM TEXTURE T)))
         (POSTSCRIPT.PUTCOMMAND
 STREAM " " CENTERX " " CENTERY " " RADIUS " 0 360 arc" :EOL)
         (if
 TEXTUREBM
             then
 (POSTSCRIPT.PUTCOMMAND
 STREAM "100 100 scale ")
                  (POSTSCRIPT.PUTBITMAPBYTES
 STREAM TEXTUREBM T)
                  (POSTSCRIPT.PUTCOMMAND
 STREAM TEXTUREWIDTH " " (LLSH (fetch
 BITMAPRASTERWIDTH
                                                                          of
 TEXTUREBM)
                                                                       1)
                         " 0 "
                         (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM)
                                          100.0))
                         " findresolution " TEXTUREWIDTH " div div ceiling " POSTSCRIPT.TEXTURE.SCALE
                         " mul setpattern eofill" :EOL "grestore" :EOL)
           else
 (POSTSCRIPT.PUTCOMMAND
 STREAM " eofill" :EOL "grestore" :EOL))
         (\MOVETO.PSC
 STREAM CENTERX CENTERY])

(\FILLPOLYGON.PSC

  [LAMBDA (STREAM KNOTS TEXTURE OPERATION WINDNUMBER)
        (* ; "Edited 27-Apr-2025 23:59 by mth")

                                                             (* ; 

                                                        "Edited 20-Nov-92 15:17 by sybalsky:mv:envos")

    (DECLARE
 (SPECVARS FILL.WRULE))

    (* ;; "OPERATION is ignored here")


    (LET ((LASTPOINT (CAR (LAST KNOTS)))
          TEXTUREBM TEXTUREWIDTH)
         (POSTSCRIPT.PUTCOMMAND
 STREAM :EOL "gsave newpath ")
         (if
 (NOT (OR (ZEROP WINDNUMBER)
                      (EQL WINDNUMBER 1)))
             then
 (SETQ WINDNUMBER FILL.WRULE))
         [if
 (FIXP TEXTURE)
             then
 (if
 (ZEROP TEXTURE)
                      then
 (SETQ TEXTURE 'WHITE)
                    elseif
 (OR (EQL TEXTURE 65535)
                               (EQL TEXTURE -1))
                      then
 (SETQ TEXTURE 'BLACK]
         (COND
            ((TEXTUREP TEXTURE)
             (SETQ TEXTUREBM (BITMAPCREATE 16 16 1))
             (SETQ TEXTUREWIDTH 16)
             (BLTSHADE TEXTURE TEXTUREBM))
            ((BITMAPP TEXTURE)
             (SETQ TEXTUREWIDTH (MIN (fetch
 BITMAPWIDTH of
 TEXTUREBM)
                                     (fetch
 BITMAPHEIGHT of
 TEXTUREBM)))
             (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1))
             (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE))
            (TEXTURE (POSTSCRIPT.PUTRGBCOLOR
 STREAM TEXTURE T)))
         (POSTSCRIPT.PUTCOMMAND
 STREAM (fetch
 (POSITION XCOORD) of
 (CAR KNOTS))
                " "
                (fetch
 (POSITION YCOORD) of
 (CAR KNOTS))
                " M" :EOL)
         (for
 K in
 (CDR KNOTS) do
 (POSTSCRIPT.PUTCOMMAND
 STREAM (fetch
 (POSITION XCOORD) of
 K)
                                         " "
                                         (fetch
 (POSITION YCOORD) of
 K)
                                         " lineto" :EOL))
         (POSTSCRIPT.PUTCOMMAND
 STREAM " closepath" :EOL)
         (if
 TEXTUREBM
             then
 (POSTSCRIPT.PUTCOMMAND
 STREAM "100 100 scale ")
                  (POSTSCRIPT.PUTBITMAPBYTES
 STREAM TEXTUREBM T)
                  (POSTSCRIPT.PUTCOMMAND
 STREAM TEXTUREWIDTH " " (LSH (fetch
 BITMAPRASTERWIDTH
                                                                         of
 TEXTUREBM)
                                                                      1)
                         " 0 "
                         (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM)
                                          100.0))
                         " findresolution " TEXTUREWIDTH " div div ceiling " POSTSCRIPT.TEXTURE.SCALE
                         " mul setpattern"))
         (POSTSCRIPT.PUTCOMMAND
 STREAM (if
 (ZEROP WINDNUMBER)
                                           then
 " fill"
                                         else
 " eofill")
                :EOL "grestore" :EOL)
         (\MOVETO.PSC
 STREAM (fetch
 (POSITION XCOORD) of
 LASTPOINT)
                (fetch
 (POSITION YCOORD) of
 LASTPOINT])

(\FIXLINELENGTH.PSC

  [LAMBDA (STREAM IMAGEDATA)                                 (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")


    (* ;; "Called by margin, font or rotation change to update the LINELENGTH field in the stream.")


    (LET [(TMP (MIN MAX.SMALLP (FIX (QUOTIENT (DIFFERENCE (fetch
 (\POSTSCRIPTDATA 
                                                                        POSTSCRIPTRIGHTMARGIN)
                                                             of
 IMAGEDATA)
                                                     (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTLEFTMARGIN)
                                                        of
 IMAGEDATA))
                                           (fetch
 FONTAVGCHARWIDTH of
 (ffetch
 (\POSTSCRIPTDATA 
                                                                                     POSTSCRIPTFONT)
                                                                         of
 IMAGEDATA]
         (replace
 (STREAM LINELENGTH) of
 STREAM with
 (COND
                                                        ((GREATERP TMP 1)
                                                         TMP)
                                                        (T 10])

(\MOVETO.PSC

  [LAMBDA (STREAM X Y)                                       (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")

    (LET ((IMAGEDATA (ffetch
 (STREAM IMAGEDATA) of
 STREAM)))
         (COND
            ([NOT (AND (EQP X (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA))
                       (EQP Y (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA]
             (POSTSCRIPT.SHOWACCUM
 STREAM)
             (freplace
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA with
 X)
             (freplace
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA with
 Y)
             (freplace
 (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of
 IMAGEDATA with
 T])

(\NEWPAGE.PSC

  [LAMBDA (STREAM)
                                           (* ; "Edited  5-Apr-89 17:31 by TAL")

    (POSTSCRIPT.ENDPAGE
 STREAM)
    (POSTSCRIPT.STARTPAGE
 STREAM])
)



(* ;; "Character-output, plus special-cases:")


(DEFINEQ

(\POSTSCRIPT.CHANGECHARSET

  [LAMBDA (IMAGEDATA CHARSET)
                                (* ; "Edited  2-Oct-2026 22:30 by rmk")


                                                             (* ; "Edited 29-Sep-2026 23:32 by rmk")


                                                             (* ; "Edited 20-Sep-2026 22:34 by rmk")


                                                             (* ; "Edited 19-Sep-2026 10:43 by rmk")


                                                             (* ; "Edited 13-Sep-2026 00:05 by rmk")


                                                             (* ; "Edited  4-Sep-2026 15:40 by rmk")


                                                             (* ; "Edited 30-Aug-2025 23:24 by rmk")


                                                             (* ; "Edited 29-Apr-93 13:51 by rmk:")


    (* ;; "Called when the character set information cached in a display stream doesn't correspond to CHARSET.")


    (LET ((CSINFO (\INSURECHARSETINFO (ffetch
 POSTSCRIPTFONT of
 IMAGEDATA)
                         CHARSET)))

         (* ;; 

         "Does it need to be uninterruptable?  If an error happens the stream is screwed anyway")


         (UNINTERRUPTABLY
             (freplace
 POSTSCRIPTWIDTHS of
 IMAGEDATA with
 (ffetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
             (freplace
 POSTSCRIPTMCCSCHARSET of
 IMAGEDATA with
 CHARSET)
             (freplace
 POSTSCRIPTCHARSETMAPPINGBLOCK of
 IMAGEDATA with
 (fetch
 (POSTSCRIPTCSINFO
                                                                               CHARBLOCK)
                                                                          of
 CSINFO)))])

(\POSTSCRIPT.OUTCHARFN

  [LAMBDA (STREAM CHAR)
                                      (* ; "Edited  2-Oct-2026 23:16 by rmk")


                                                             (* ; "Edited 28-Sep-2026 08:19 by rmk")


                                                             (* ; "Edited 21-Sep-2026 10:00 by rmk")


                                                             (* ; "Edited 30-Aug-2026 21:39 by rmk")


                                                             (* ; "Edited  8-Sep-2025 09:50 by rmk")


                                                             (* ; "Edited 23-May-93 12:00 by rmk:")


                                                             (* ; "Edited  4-May-93 02:20 by jds")


                                                             (* ; "Edited  3-Feb-93 00:45 by jds")


(* ;;; "Output a character to be printed.")


(* ;;; "Change font if necessary, do newline if at right margin, check for special chars and do appropriate thing, quote char and/or start postscript string if necessary.")


(* ;;; "This is called a lot, so the code is unrolled for efficiency.")


    (DECLARE
 (LOCALVARS . T))
    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (XPOS (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA))
           (FONT (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTFONT) of
 IMAGEDATA))
           CHARWID KIND NEWXPOS MAPPING)
          (CL:UNLESS (EQ (\CHARSET CHAR)
                         (ffetch
 POSTSCRIPTMCCSCHARSET of
 IMAGEDATA))

              (* ;; "Switch character set so that we get the right char width.")


              (\POSTSCRIPT.CHANGECHARSET
 IMAGEDATA (\CHARSET CHAR)))
          (SETQ MAPPING (\POSTSCRIPT.MAPPING CHAR))
          (SETQ KIND (CAR MAPPING))
          [if
 (EQ KIND 'REPOSITION)
              then
 (SELCHARQ CHAR
                        ((EOL LF) 
                             (\TERPRI.PSC
 STREAM)

                             (* ;; 

            "Set NEWXPOS to current value here and in FF to preserve value after external resetting.")


                             (SETQ NEWXPOS (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA)))
                        (FF (DSPNEWPAGE STREAM)
                            (SETQ NEWXPOS (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA)))
                        (TAB (\POSTSCRIPT.NEWLINE? (\POSTSCRIPTTAB
 IMAGEDATA))
                             (\MOVETO.PSC
 STREAM NEWXPOS (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTY)
                                                            of
 IMAGEDATA)))
                        (SHOULDNT))
            else
 [SETQ CHARWID (SELCHARQ CHAR
                                    (SPACE (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTSPACEWIDTH)
                                              of
 IMAGEDATA))
                                    (\FGETWIDTH (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTWIDTHS)
                                                   of
 IMAGEDATA)
                                           (\CHAR8CODE CHAR]
                 (\POSTSCRIPT.NEWLINE? CHARWID)              (* ; "Sets NEWXPOS")

                 (SELECTQ KIND
                     (BOUT (\POSTSCRIPT.STARTSTRING?)
                           (BOUT STREAM (CADR MAPPING)))
                     ((ESCAPE ACCENT) 
                          (\POSTSCRIPT.STARTSTRING?)         (* ; "Elsewhere in CS 0")

                          (OCTAL3OUT (CADR MAPPING)))
                     (SPECIAL (\POSTSCRIPT.SPECIALOUTCHARFN
 STREAM MAPPING))
                     (ACCENTPAIR                             (* ; "Overlap base char & accent")

                                 (\POSTSCRIPT.ACCENTPAIR
 STREAM MAPPING))
                     (APPLY* (POSTSCRIPT.SHOWACCUM
 STREAM)
                             (\UPDATE.PSC
 STREAM IMAGEDATA)

                             (* ;; "User function can call any stream operations it wants.  At the end, we guarantee that baseline hasn't changed and that xpos is where the width said it would be.")


                             [freplace
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA
                                with
 (PROG1 (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTY) OF
 IMAGEDATA)
                                         (APPLY* (CADDR MAPPING)
                                                STREAM
                                                (CADR MAPPING)))])
                     (SLUG (\POSTSCRIPT.PRINTSLUG
 STREAM CHARWID))
                     (FUNCTION                               (* ; "Done as special PS function.")

                               (POSTSCRIPT.SHOWACCUM
 STREAM)
                               (\UPDATE.PSC
 STREAM IMAGEDATA)
                               (POSTSCRIPT.OUTSTR
 STREAM (CADR MAPPING)))
                     (\ILLEGAL.ARG (CAR MAPPING]
          (freplace
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA with
 NEWXPOS)
          CHAR])

(\POSTSCRIPT.PRINTSLUG

  [LAMBDA (STREAM CHARWID)
                                   (* ; "Edited 16-Sep-2026 12:12 by rmk")


                                                             (* ; "Edited 13-Sep-2026 16:06 by rmk")


                                                             (* ; "Edited  1-Sep-2026 12:18 by rmk")


                                                             (* ; "Edited  9-May-93 21:55 by rmk:")


                                                             (* ; "Edited  4-May-93 02:20 by jds")


                                                             (* ; "Edited  3-Feb-93 00:45 by jds")


(* ;;; "Internal function to display a black box for a missing character.  Caller (\POSTSCRIPT.OUTCHARFN) is responsible for  guaranteeing proper caching of widths vector and for measurement and position updating, although \DRAWLINE.PSC also updates position.")


    (DECLARE
 (LOCALVARS . T))
    (LET* ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
           (FONT (fetch
 (\POSTSCRIPTDATA POSTSCRIPTFONT) of
 IMAGEDATA)))
          (\BLTSHADE.PSC
 BLACKSHADE STREAM (IPLUS (fetch
 (FONTDESCRIPTOR FONTSCALE) of
 FONT)
                                                  (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA))
                 (IDIFFERENCE (fetch
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA)
                        (fetch
 (FONTDESCRIPTOR FONTDESCENT) of
 FONT))
                 (IDIFFERENCE CHARWID (ITIMES 2 (fetch
 (FONTDESCRIPTOR FONTSCALE) of
 FONT)))
                 (fetch
 (FONTDESCRIPTOR FONTHEIGHT) of
 FONT)
                 'PAINT)
          (\MOVETO.PSC
 STREAM (IPLUS (fetch
 (\POSTSCRIPTDATA POSTSCRIPTX) of
 IMAGEDATA)
                                     CHARWID)
                 (fetch
 (\POSTSCRIPTDATA POSTSCRIPTY) of
 IMAGEDATA])

(\POSTSCRIPT.SPECIALOUTCHARFN

  [LAMBDA (STREAM MAPPING)
                                   (* ; "Edited 21-Sep-2026 09:59 by rmk")


                                                             (* ; "Edited  3-Sep-2026 23:25 by rmk")


                                                             (* ; "Edited 23-May-93 13:31 by rmk:")


                                                             (* ; "Edited  4-May-93 02:20 by jds")


                                                             (* ; "Edited  3-Feb-93 00:45 by jds")


    (* ;; "PSCHAR is specified as %"2,xxx%" rather than %"0,xxx%" to defeat translations to symbol that go to matching character codes. The 2 is shaved off by OCTAL3OUT.  (RMK:  WHY IS THIS NECESSARY?)")


    (* ;; "Internal function to output a special character to be printed, changing font if necessary.  Width processing is carried out at higher level.  Switches to FAMILY's font (SYMBOL, ZAPFDINGBATS) before printing, then switches back.")


    (DECLARE
 (LOCALVARS . T))
    (LET ((PSCHAR (CADR MAPPING))
          (FAMILY (CADDR MAPPING))
          (IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          (OLDFONT (\DSPFONT.PSC
 STREAM)))
         (\DSPFONT.PSC
 STREAM (create
 FONTSPEC using
 (FONTPROP OLDFONT 'DEVICESPEC)
                                                     FSFAMILY ← FAMILY))
         (\POSTSCRIPT.STARTSTRING?)
         (OCTAL3OUT PSCHAR)
         (\DSPFONT.PSC
 STREAM OLDFONT)
         PSCHAR])

(\UPDATE.PSC

  [LAMBDA (STREAM IMAGEDATA)                                 (* ; 

                                                        "Edited 20-Nov-92 15:13 by sybalsky:mv:envos")


    (* ;; "Make any outstanding font, scale, location updates, prepatory to something that might depend heavily on it. (e.g. before starting to output characters, or making a scale change)")

                                                             (* ; 

                   "This code was originally in \POSTSCRIPT.OUTCHAR &c, and is here for commonality.")

    (COND
       ((ffetch
 (\POSTSCRIPTDATA POSTSCRIPTPENDINGXFORM) of
 IMAGEDATA)
        (\SETXFORM.PSC
 STREAM IMAGEDATA)))
    (COND
       ((ffetch
 (\POSTSCRIPTDATA POSTSCRIPTFONTCHANGEDFLG) of
 IMAGEDATA)
                                                             (* ; 

                                                    "If font was changed then switch before printing")

        (\SWITCHFONTS.PSC
 STREAM IMAGEDATA)))
    (COND
       ((ffetch
 (\POSTSCRIPTDATA POSTSCRIPTMOVEFLG) of
 IMAGEDATA)
                                                             (* ; "likewise for position")

        (\SETPOS.PSC
 STREAM IMAGEDATA])

(\POSTSCRIPT.ACCENTPAIR

  [LAMBDA (STREAM MAPPING)
                                   (* ; "Edited 18-Sep-2026 21:44 by rmk")


                                                             (* ; "Edited 16-Sep-2026 11:28 by rmk")


                                                             (* ; "Edited  1-Sep-2026 12:19 by rmk")

                                                             (* ; 

                                                        "Edited 17-Aug-93 17:02 by sybalskY:MV:ENVOS")

                                                             (* ; "Edited  3-Feb-93 01:29 by jds")


(* ;;; "Output an accented character to be printed.  .")


(* ;;;; "Prints the character as \xxx, with 3 octal digits, to avoid tripping up on EOLs and other postscript-special characters.")


    (DECLARE
 (LOCALVARS . T))
    (LET ((CHAR (CADR MAPPING))
          (ACCENTS (CADDR MAPPING))
          (UNDER-ACCENTS (CADDDR MAPPING))
          (IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          FONT)
         (POSTSCRIPT.SHOWACCUM
 STREAM)
         (\UPDATE.PSC
 STREAM IMAGEDATA)
         (SETQ FONT (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTFONT) of
 IMAGEDATA))
         (BOUT STREAM (CHARCODE %())
         (OCTAL3OUT CHAR)
         (BOUT STREAM (CHARCODE %)))
         (BOUT STREAM (CHARCODE %())
         (for
 ACCENT inside
 ACCENTS do
 (OCTAL3OUT ACCENT))
         (POSTSCRIPT.PUTCOMMAND
 STREAM ") (")
         (for
 ACCENT inside
 UNDER-ACCENTS do
 (OCTAL3OUT ACCENT))
         (BOUT STREAM (CHARCODE %)))
         (COND
            (NIL (OR (IEQP ACCENT (CHARCODE "0,313"))
                     (IEQP ACCENT (CHARCODE "0,316")))       (* ; 

                     "Cedilla and ogonek are under-accents, so don't raise them for capital letters.")

                 (POSTSCRIPT.PUTCOMMAND
 STREAM " 0 "))
            ((ILESSP CHAR (CHARCODE a))                      (* ; 

                                                            "upper case, so adjust offset for accent")

             (POSTSCRIPT.PUTCOMMAND
 STREAM " " (/ (fetch
 FONTASCENT of
 FONT)
                                                  3.0)
                    " "))
            (T (POSTSCRIPT.PUTCOMMAND
 STREAM " 0 ")))
         (POSTSCRIPT.PUTCOMMAND
 STREAM " " (FONTPROP FONT 'SIZE)
                " ")
         (POSTSCRIPT.PUTCOMMAND
 STREAM " accentor ")
         CHAR])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \POSTSCRIPT.MAPPING
 MACRO
 [(CHAR)

                                     (* ;; "Block for CHAR's charset is stored in imagedata")


                                     (LET ((BLOCK (ffetch
 POSTSCRIPTCHARSETMAPPINGBLOCK of
 IMAGEDATA)
                                                  ))
                                          (CL:IF BLOCK
                                              (\GETBASEPTR BLOCK (UNFOLD (\CHAR8CODE CHAR)
                                                                        WORDSPERCELL))
                                              '(SLUG))])

(PUTPROPS \POSTSCRIPT.NEWLINE?
 MACRO
 ((WIDTH)                (* ; 

                        "WIDTH may be evaluated twice, before and after the terpri.  That's for tabs")

                                      (SETQ NEWXPOS (IPLUS XPOS WIDTH))
                                      (CL:WHEN (IGREATERP NEWXPOS (ffetch
 (\POSTSCRIPTDATA 
                                                                                POSTSCRIPTRIGHTMARGIN
                                                                                 ) of
 IMAGEDATA))
                                          (\TERPRI.PSC
 STREAM)
                                          (SETQ NEWXPOS (IPLUS (ffetch
 (\POSTSCRIPTDATA POSTSCRIPTX)
                                                                  of
 IMAGEDATA)
                                                               WIDTH)))
                                      NEWXPOS))

(PUTPROPS \POSTSCRIPT.STARTSTRING?
 MACRO
 (NIL (CL:UNLESS (ffetch
 (\POSTSCRIPTDATA 
                                                                        POSTSCRIPTCHARSTOSHOW)
                                                            of
 IMAGEDATA)
                                                  (\UPDATE.PSC
 STREAM IMAGEDATA)
                                                  (BOUT STREAM (CHARCODE %())
                                                  (freplace
 (\POSTSCRIPTDATA POSTSCRIPTCHARSTOSHOW)
                                                     of
 IMAGEDATA with
 T))))

(PUTPROPS \POSTSCRIPT.FRACTION
 MACRO
 ((STREAM STRING)

                                 (* ;; "Handle printing of a fraction, given a string that's the name of the PS function (defined in \POSTSCRIPT.JOB.SETUP) that prints it.  You must put spaces around the name.")


                                      (POSTSCRIPT.SHOWACCUM
 STREAM)
                                      [COND
                                         ((IGREATERP (SETQ NEWXPOS (IPLUS XPOS CHARWID))
                                                 (ffetch
 POSTSCRIPTRIGHTMARGIN of
 IMAGEDATA))
                                          (\TERPRI.PSC
 STREAM)
                                          (SETQ NEWXPOS (IPLUS (ffetch
 POSTSCRIPTX of
 IMAGEDATA)
                                                               CHARWID]
                                      [COND
                                         ((NOT (ffetch
 POSTSCRIPTCHARSTOSHOW of
 IMAGEDATA))
                                          (COND
                                             ((ffetch
 POSTSCRIPTPENDINGXFORM of
 IMAGEDATA)
                                              (\SETXFORM.PSC
 STREAM IMAGEDATA)))
                                          (COND
                                             ((ffetch
 POSTSCRIPTFONTCHANGEDFLG of
 IMAGEDATA)
                                                             (* ; 

                                                    "If font was changed then switch before printing")

                                              (\SWITCHFONTS.PSC
 STREAM IMAGEDATA)))
                                          (COND
                                             ((ffetch
 POSTSCRIPTMOVEFLG of
 IMAGEDATA)
                                                             (* ; "likewise for position")

                                              (\SETPOS.PSC
 STREAM IMAGEDATA]
                                      (POSTSCRIPT.OUTSTR
 STREAM STRING)))

(PUTPROPS OCTAL3OUT
 MACRO
 [(N)

                           (* ;; "3 octal digits padded with 0.  Shaves off the 2 of 2,xxx")


                           (BOUT STREAM (CHARCODE \))
                           [BOUT STREAM (IPLUS (CHARCODE 0)
                                               (LOGAND 3 (LRSH N 6]
                           [BOUT STREAM (IPLUS (CHARCODE 0)
                                               (LOGAND 7 (LRSH N 3]
                           (BOUT STREAM (IPLUS (CHARCODE 0)
                                               (LOGAND 7 N])
)
)



(* ;; "Spacing-character (M-quad, etc.) and ballot-box-check &c special-case functions")


(DEFINEQ

(\PSC.SPACEDISP

  [LAMBDA (STREAM WIDTH)
                                     (* ; "Edited 28-Sep-93 13:50 by jds")

    (POSTSCRIPT.PUTCOMMAND
 STREAM (\PSC.SPACEWID
 (DSPFONT NIL STREAM)
                                         WIDTH)
           " 0 rmoveto "])

(\PSC.SPACEWID

  [LAMBDA (FONTDESC CHAR)
                                    (* ; "Edited 28-Sep-93 13:41 by jds")


    (* ;; "Spacing character with a special width (e.g. M space, thin (1/5-M) space...")


    (* ;; "If CHAR is a list, it's (CHARCODE FACTOR), and we return a width of FACTOR * (CHARWIDTH CHARCODE).  Otherwise, we just return the width of CHARCODE.")


    (COND
       [(LISTP CHAR)
        (FIXR (FTIMES (CADR CHAR)
                     (CHARWIDTH (CHARCODE.DECODE (CAR CHAR))
                            FONTDESC]
       (T (CHARWIDTH (CHARCODE.DECODE CHAR)
                 FONTDESC])

(\PSC.SYMBOLS

  [LAMBDA (STREAM CHAR)
                                      (* ; "Edited  2-Nov-94 17:01 by jds")

    (LET ((IMAGEDATA (fetch
 (STREAM IMAGEDATA) of
 STREAM))
          (OLDFONT (\DSPFONT.PSC
 STREAM)))
         (\DSPFONT.PSC
 STREAM (LIST 'ZAPFDINGBATS (fetch
 (FONTDESCRIPTOR FONTSIZE) of
 OLDFONT)
                                    (fetch
 (FONTDESCRIPTOR FONTFACE) of
 OLDFONT)))
         (POSTSCRIPT.SHOWACCUM
 STREAM)
         (\UPDATE.PSC
 STREAM IMAGEDATA)
         (COND
            ((EQUAL CHAR "0,161")
             (POSTSCRIPT.OUTSTR
 STREAM " bboxchk ")))
         (\DSPFONT.PSC
 STREAM OLDFONT])
)



(* ;; "The mapping of MCCS characters to Postscript renderings")



(RPAQQ *POSTSCRIPT-MCCS-TRANSLATIONS*

       (
        (* ;; "Mapping of MCCS characters to Postscript renderings.")


        (¤ NIL "2,250")
                                                             (* ; "generic currency symbol")

        (‘ NIL "2,140")
                                                             (* ; "left single quote")

        (← SYMBOL "2,254")
                                                             (* ; "left arrow")

        (↑ SYMBOL "2,255")
                                                             (* ; "uparrow")

        (→ SYMBOL "2,256")
                                                             (* ; "right arrow")

        (↓ SYMBOL "2,257")
                                                             (* ; "down arrow")

        (_ BOUT "0,137")
                                                             (* ; "underscore")

        (^ BOUT "0,136")
                                                             (* ; "circumflex")

        (° SYMBOL "2,260")
                                                             (* ; "degree")

        (± SYMBOL "2,261")
                                                             (* ; "+/-")

        (× SYMBOL "2,264")
                                                             (* ; "times")

        (· NIL "2,264")
                                                             (* ; "Center-dot")

        (÷ SYMBOL "2,270")
                                                             (* ; "divide")

        (’ NIL "2,047")
                                                             (* ; "right single quote")

        (¼ FUNCTION " f14 ")
                                                             (* ; "1/4")

        (½ FUNCTION " f12 ")
                                                             (* ; "1/2")

        (¾ FUNCTION " f34 ")
                                                             (* ; "3/4")

        (® SYMBOL "2,342")
                                                             (* ; "registered")

        (© SYMBOL "2,343")
                                                             (* ; "copyright")

        (™ SYMBOL "2,344")
                                                             (* ; "tm")

        (⅛ FUNCTION " f18 ")
                                                             (* ; "1/8")

        (⅜ FUNCTION " f38 ")
                                                             (* ; "3/8")

        (⅝ FUNCTION " f58 ")
                                                             (* ; "5/8")

        (⅞ FUNCTION " f78 ")
                                                             (* ; "7/8")

        (Ð NIL "2,235")
                                                             (* ; "Eth (slashed D?)")

        (Þ NIL "2,237")
                                                             (* ; "Thorn")

        (ð NIL "2,236")
                                                             (* ; "eth")

        (þ NIL "2,240")
                                                             (* ; "thorn")

        (★ DINGBAT "0,110")
                                                             (* ; "filled star")

        ("42,42" DINGBAT "0,161")
                                                             (* ; "ballot-box")

        (⊠ APPLY* "0,161" \PSC.SYMBOLS \PSC.SPACEWID NIL)
                                                             (* ; "Checked ballot-box")

        (– NIL "2,261")
                                                             (* ; "n dash")

        (— NIL "2,320")
                                                             (* ; "m dash")

        ("357,55" APPLY* "M" \PSC.SPACEDISP \PSC.SPACEWID NIL)
                                                             (* ; "M quad")

        ("357,54" APPLY* "N" \PSC.SPACEDISP \PSC.SPACEWID NIL)
                                                             (* ; "N quad")

        ("357,56" APPLY* "1" \PSC.SPACEDISP \PSC.SPACEWID NIL)
                                                             (* ; "FIGURE quad")

        ("357,57" APPLY* ("M" 0.2)
               \PSC.SPACEDISP \PSC.SPACEWID NIL)
                                                             (* ; "This space (1/5M)")

        († NIL "2,262")
                                                             (* ; "dagger")

        (‡ NIL "2,263")
                                                             (* ; "double dagger")

        (〈 SYMBOL "2,361")
                                                             (* ; "angleright")

        (〉 SYMBOL "2,341")
                                                             (* ; "angleleft")

        (⊨ SYMBOL "2,315")
                                                             (* ; "perpendicular")

        (‰ NIL "2,275")
                                                             (* ; "per mil o/oo")

        (≮ ACCENTPAIR "<" NIL "/")
                                                             (* ; "not less than")

        (≯ ACCENTPAIR ">" "/")
                                                             (* ; "not greater than")

        (∥ SYMBOL "2,312")
                                                             (* ; "parallel")

        (∦ SYMBOL "2,315")
                                                             (* ; "not parallel")

        (∈ SYMBOL "2,316")
                                                             (* ; "element")

        (∉ SYMBOL "2,317")
                                                             (* ; "notelement")

        (∋ SYMBOL "2,047")
                                                             (* ; "suchthat")

        (⇐ SYMBOL "2,334")
                                                             (* ; "implied by, double arrow left")

        (⇔ SYMBOL "2,333")
                                                             (* ; "iff, double arrow")

        (⇒ SYMBOL "2,336")
                                                             (* ; "implies, double arrow right")

        (⇌ SYMBOL "2,253")
                                                             (* ; "double arrow")

        (⇆ SYMBOL "2,333")
                                                             (* ; "double arrow")

        (↔ SYMBOL "2,333")
                                                             (* ; "l/r arrow")

        (∩ SYMBOL "2,307")
                                                             (* ; "intersection")

        (∪ SYMBOL "2,310")
                                                             (* ; "union")

        (⊇ SYMBOL "2,312")
                                                             (* ; "reflexsuperset")

        (⊆ SYMBOL "2,315")
                                                             (* ; "reflexsubset")

        (⊃ SYMBOL "2,311")
                                                             (* ; "propersuperset")

        (⊂ SYMBOL "2,314")
                                                             (* ; "propersubset")

        (⊄ SYMBOL "2,313")
                                                             (* ; "notsubset")

        (∅ SYMBOL "2,306")
                                                             (* ; "emptyset")

        (⊕ SYMBOL "2,305")
                                                             (* ; "circleplus")

        (⊗ SYMBOL "2,304")
                                                             (* ; "circlemultiply")

        (• NIL "2,267")
                                                             (* ; "bullet")

        (∘ SYMBOL "2,260")
                                                             (* ; 

                                                        "center circle (composition), lowered degree")

        (¬ SYMBOL "2,330")
                                                             (* ; "logicalnot")

        (∠ SYMBOL "2,320")
                                                             (* ; "angle")

        (⊥ SYMBOL "2,136")
                                                             (* ; "perpendicular")

        (∝ SYMBOL "2,265")
                                                             (* ; "proportional")

        (≡ SYMBOL "2,272")
                                                             (* ; "equivalence")

        (∫ SYMBOL "2,362")
                                                             (* ; "integral")

        (≃ SYMBOL "2,273")
                                                             (* ; "approxequal")

        (≅ SYMBOL "2,100")
                                                             (* ; "congruent")

        (∑ SYMBOL "2,345")
                                                             (* ; "summation")

        (∏ SYMBOL "2,325")
                                                             (* ; "product")

        (√ SYMBOL "2,326")
                                                             (* ; "radical")

        (ƒ SYMBOL "2,246")
                                                             (* ; "florin")

        (⌈ SYMBOL "2,351")
                                                             (* ; "Ceiling, left ")

        (⌉ SYMBOL "2,371")
                                                             (* ; "Ceiling, right")

        (⌊ SYMBOL "2,353")
                                                             (* ; "Floor, left ")

        (⌋ SYMBOL "2,373")
                                                             (* ; "Floor, right")

        (∃ SYMBOL "2,44")
                                                             (* ; "exists")

        (∀ SYMBOL "2,42")
                                                             (* ; "forall")

        (⋀ SYMBOL "2,331")
                                                             (* ; "logicaland")

        (⋁ SYMBOL "2,332")
                                                             (* ; "logicalor")

        (∇ SYMBOL "2,321")
                                                             (* ; "gradient")

        (∂ SYMBOL "2,266")
                                                             (* ; "partialdiff")

        (♠ SYMBOL "2,252")
                                                             (* ; "spade")

        (✓ DINGBAT "0,63")
                                                             (* ; "check")

        (⅓ FUNCTION " f13 ")
                                                             (* ; "1/3")

        (⅔ FUNCTION " f23 ")
                                                             (* ; "2/3")

        (À ACCENT "0,4" A)
        (Á ACCENT "0,1" A)
        (Â ACCENT "0,2" A)
        (Ã ACCENT "0,6" A)
        (Ā ACCENTPAIR A "0,305")
                                                             (* ; "A-macron")

        (Ă ACCENTPAIR A "0,306")
                                                             (* ; "A-breve")

        (Ä ACCENT "0,3" A)
        (Å ACCENT "0,5" A)
        (Ç ACCENT "0,7" C)
        (È ACCENT "0,13" E)
        (É ACCENT "0,10" E)
        (Ê ACCENT "0,11" E)
        (Ē ACCENTPAIR E "0,305")
                                                             (* ; "E-macron")

        (Ë ACCENT "0,12" E)
        (Ę ACCENTPAIR E NIL "0,316")
                                                             (* ; "E-ogonek")

        (Ì ACCENT "0,17" I)
        (Ǎ ACCENT "0,14" I)
        (Î ACCENT "0,15" I)
        (Ī ACCENTPAIR I "0,305")
                                                             (* ; "I-macron")

        (Ï ACCENT "0,16" I)
        (Ñ ACCENT "0,20" N)
        (Ò ACCENT "0,24" O)
        (Ó ACCENT "0,21" O)
        (Ô ACCENT "0,22" O)
        (Õ ACCENT "0,25" O)
        (Ō ACCENTPAIR O "0,305")
                                                             (* ; "O-macron")

        (Ö ACCENT "0,23" O)
        (Š ACCENT "0,26" S)
        (Ù ACCENT "0,32" U)
        (Ú ACCENT "0,27" U)
        (Û ACCENT "0,30" U)
        (Ū ACCENTPAIR U "0,305")
                                                             (* ; "U-macron")

        (Ü ACCENT "0,31" U)
        (Ÿ ACCENT "0,33" Y)
        (Ž ACCENT "0,34" Z)
        (Ȳ ACCENTPAIR Y "0,305")
                                                             (* ; "Y-macron")

        (Ǣ ACCENTPAIR "0,341" "0,305")
                                                             (* ; "AE-macron")

        ("361,167" ACCENTPAIR "0,352" "0,305")
                                                             (* ; "OE-macron")

        (à ACCENT "0,204" a)
        (á ACCENT "0,201" a)
        (â ACCENT "0,202" a)
        (ã ACCENT "0,206" a)
        (ā ACCENTPAIR a "0,305")
                                                             (* ; "a-macron")

        (ă ACCENTPAIR a "0,306")
                                                             (* ; "a-breve")

        (ä ACCENT "0,203" a)
        (å ACCENT "0,205" a)
        (ç ACCENT "0,207" c)
        (è ACCENT "0,213" e)
        (é ACCENT "0,210" e)
        (ê ACCENT "0,211" e)
        (ē ACCENTPAIR e "0,305")
                                                             (* ; "e-macron")

        (ë ACCENT "0,212" e)
        (ę ACCENTPAIR e NIL "0,316")
                                                             (* ; "e-ogonek")

        (ě ACCENTPAIR e "0,317")
                                                             (* ; "e-caron")

        (ì ACCENT "0,217" i)
        (í ACCENT "0,214" i)
        (î ACCENT "0,215" i)
        (ī ACCENTPAIR "0,365" "0,305")
                                                             (* ; "i-macron")

        (ï ACCENT "0,216" i)
        (ñ ACCENT "0,220" n)
        (ò ACCENT "0,224" o)
        (ó ACCENT "0,221" o)
        (ô ACCENT "0,222" o)
        (õ ACCENT "0,225" o)
        (ō ACCENTPAIR o "0,305")
                                                             (* ; "o-macron")

        (ö ACCENT "0,223" o)
        (š ACCENT "0,226" s)
        (ù ACCENT "0,232" u)
        (ú ACCENT "0,227" u)
        (û ACCENT "0,230" u)
        (ū ACCENTPAIR u "0,305")
                                                             (* ; "u-macron")

        (ŭ ACCENTPAIR u "0,306")
                                                             (* ; "u-breve")

        (ü ACCENT "0,231" u)
        (ÿ ACCENT "0,233" y)
        (ž ACCENT "0,234" z)
        (ȳ ACCENTPAIR y "0,305")
                                                             (* ; "y-macron")

        (ǣ ACCENTPAIR "0,361" "0,305")
                                                             (* ; "ae-macron")

        ("361,367" ACCENTPAIR "0,372" "0,305")
                                                             (* ; "oe-macron")

        (ǎ ACCENTPAIR a "0,317")
                                                             (* ; "a-caron")

        (ǧ ACCENTPAIR g "0,317")
                                                             (* ; "g-caron")

        
        (* ;; "Special code assignments for Dictionary of Old English, UToronto:")


        ("361,370" ACCENTPAIR a ("0,305" "0,306"))
                                                             (* ; "a - breve-macron")

        (ĕ ACCENTPAIR e "0,306")
                                                             (* ; "e-breve")

        ("361,373" ACCENTPAIR e "0,305" "0,56")
                                                             (* ; "e macron underdot")

        ("361,374" ACCENTPAIR e ("0,305" "0,306"))
                                                             (* ; "e - breve-macron")

        (ĭ ACCENTPAIR "0,365" "0,306")
                                                             (* ; "i-breve")

        (ǐ ACCENTPAIR "0,365" "0,317")
                                                             (* ; "i-caron")

        ("362,241" ACCENTPAIR "0,365" ("0,305" "0,306"))
                                                             (* ; " i - breve-macron")

        ("362,243" ACCENTPAIR n "0,305")
                                                             (* ; "n-macron")

        ("362,244" ACCENTPAIR m "0,305")
                                                             (* ; "m-macron")

        (ǒ ACCENTPAIR o "0,317")
                                                             (* ; "o-caron")

        (ŏ ACCENTPAIR o "0,306")
                                                             (* ; "o-breve")

        ("362,247" ACCENTPAIR o ("0,305" "0,306"))
                                                             (* ; "o - breve-macron")

        ("362,250" ACCENTPAIR o "0,305" "0,56")
                                                             (* ; "o-macron underdot")

        (ǫ ACCENTPAIR o "0,316")
                                                             (* ; "o-ogonek")

        (ǔ ACCENTPAIR u "0,317")
                                                             (* ; "u-caron")

        ("362,253" ACCENTPAIR u ("0,305" "0,306"))
                                                             (* ; "u - breve-macron")

        ("362,254" ACCENTPAIR y "0,306")
                                                             (* ; "y-breve")

        ("362,256" ACCENTPAIR y "0,317")
                                                             (* ; "y-caron")

        ("362,255" ACCENTPAIR y ("0,305" "0,306"))
                                                             (* ; "y - breve-macron")

                                                             (* ; "235 = Eth")

                                                             (* ; "236 = eth")

                                                             (* ; "237 = Thorn")

                                                             (* ; "240 = thorn")

        
        (* ;; "MCCS Greek characters")


        (Α SYMBOL "2,101")
                                                             (* ; "Alpha")

        (Β SYMBOL "2,102")
                                                             (* ; "Beta")

        ("46,103" SYMBOL 0)
                                                             (* ; "--empty--")

        (Γ SYMBOL "2,107")
                                                             (* ; "Gamma")

        (Δ SYMBOL "2,104")
                                                             (* ; "Delta")

        (Ε SYMBOL "2,105")
                                                             (* ; "Epsilon")

        (Ϛ SYMBOL 0)
                                                             (* ; "Stigma")

        (Ϝ SYMBOL 0)
                                                             (* ; "Digamma")

        (Ζ SYMBOL "2,132")
                                                             (* ; "Zeta")

        (Η SYMBOL "2,110")
                                                             (* ; "Eta")

        (Θ SYMBOL "2,121")
                                                             (* ; "Theta")

        (Ι SYMBOL "2,111")
                                                             (* ; "Iota")

        (Κ SYMBOL "2,113")
                                                             (* ; "Kappa")

        (Λ SYMBOL "2,114")
                                                             (* ; "Lambda")

        (Μ SYMBOL "2,115")
                                                             (* ; "Mu")

        (Ν SYMBOL "2,116")
                                                             (* ; "Nu")

        (Ξ SYMBOL "2,130")
                                                             (* ; "Xi")

        (Ο SYMBOL "2,117")
                                                             (* ; "Omicron")

        (Π SYMBOL "2,120")
                                                             (* ; "Pi")

        (Ϙ SYMBOL 0)
                                                             (* ; "Koppa")

        (Ρ SYMBOL "2,122")
                                                             (* ; "Rho")

        (Σ SYMBOL "2,123")
                                                             (* ; "Sigma")

        ("46,127" SYMBOL 0)
                                                             (* ; "--empty--")

        (Τ SYMBOL "2,124")
                                                             (* ; "Tau")

        (Υ SYMBOL "2,125")
                                                             (* ; "Upsilon")

        (Φ SYMBOL "2,106")
                                                             (* ; "Phi")

        (Χ SYMBOL "2,103")
                                                             (* ; "Chi")

        (Ψ SYMBOL "2,131")
                                                             (* ; "Psi")

        (Ω SYMBOL "2,132")
                                                             (* ; "Omega")

        (α SYMBOL "2,141")
                                                             (* ; "alpha")

        (β SYMBOL "2,142")
                                                             (* ; "beta")

        (ϐ SYMBOL 0)
                                                             (* ; "(md beta)")

        (γ SYMBOL "2,147")
                                                             (* ; "gamma")

        (δ SYMBOL "2,144")
                                                             (* ; "delta")

        (ε SYMBOL "2,145")
                                                             (* ; "epsilon")

        (ϛ SYMBOL "2,126")
                                                             (* ; "stigma")

        (ϝ SYMBOL 0)
                                                             (* ; "digamma")

        (ζ SYMBOL "2,172")
                                                             (* ; "zeta")

        (η SYMBOL "2,150")
                                                             (* ; "eta")

        (θ SYMBOL "2,161")
                                                             (* ; "theta")

        (ι SYMBOL "2,151")
                                                             (* ; "iota")

        (κ SYMBOL "2,153")
                                                             (* ; "kappa")

        (λ SYMBOL "2,154")
                                                             (* ; "lambda")

        (μ SYMBOL "2,155")
                                                             (* ; "mu")

        (ν SYMBOL "2,156")
                                                             (* ; "nu")

        (ξ SYMBOL "2,170")
                                                             (* ; "xi")

        (ο SYMBOL "2,157")
                                                             (* ; "omicron")

        (π SYMBOL "2,160")
                                                             (* ; "pi")

        (ϙ SYMBOL 0)
                                                             (* ; "(koppa)")

        (ρ SYMBOL "2,162")
                                                             (* ; "rho")

        (σ SYMBOL "2,163")
                                                             (* ; "sigma")

        (ς SYMBOL "2,126")
                                                             (* ; "(fl sigma)")

        (τ SYMBOL "2,164")
                                                             (* ; "tau")

        (υ SYMBOL "2.165")
                                                             (* ; "upsilon")

        (φ SYMBOL "2,146")
                                                             (* ; "phi")

        (χ SYMBOL "2,143")
                                                             (* ; "chi")

        (ψ SYMBOL "2,171")
                                                             (* ; "psi")

        (ω SYMBOL "2,167")
                                                             (* ; "omega")

        
        (* ;; "MCCS Miscellaneous symbols")


        (≠ SYMBOL "2,271")
                                                             (* ; "notequal")

        (≤ SYMBOL "2,243")
                                                             (* ; "lessequal")

        (≥ SYMBOL "2,263")
                                                             (* ; "greaterequal")

        (∞ SYMBOL "2,245")
                                                             (* ; "infinity")

        (∴ SYMBOL "2,134")
                                                             (* ; "therefore")

        (″ SYMBOL "2,262")
                                                             (* ; "second")

        (− SYMBOL "2,055")
                                                             (* ; "minus")

        (⌑ SYMBOL "2,340")
                                                             (* ; "lozenge")

        ("356,163" SYMBOL "2,351")
                                                             (* ; "topleftbracket")

        ("356,164" SYMBOL "2,353")
                                                             (* ; "bottomleftbracket")

        ("356,165" SYMBOL "2,352")
                                                             (* ; "centerbracket")

        ("356,166" SYMBOL "2,371")
                                                             (* ; "toprightbracket")

        ("356,167" SYMBOL "2,373")
                                                             (* ; "bottomrightbracket")

        (∼ SYMBOL "2,176")
                                                             (* ; "similar")

        (♥ SYMBOL "2,251")
                                                             (* ; "heart")

        (⎫ SYMBOL "2,374")
                                                             (* ; "toprightbracce")

        (⎪ SYMBOL "2,357")
                                                             (* ; "braceextend")

        (⎬ SYMBOL "2,375")
                                                             (* ; "centerrightbracce")

        (⎭ SYMBOL "2,376")
                                                             (* ; "bottomrightbracce")

        (⎧ SYMBOL "2,354")
                                                             (* ; "topleftbracce")

        (⎩ SYMBOL "2,356")
                                                             (* ; "bottomleftbracce")

        (⎨ SYMBOL "2,355")
                                                             (* ; "centerleftbracce")

        (⌠ SYMBOL "2,363")
                                                             (* ; "integraltop")

        (⌡ SYMBOL "2,365")
                                                             (* ; "integralbottom")

        ("356,357" SYMBOL "2,364")
                                                             (* ; "integralcenter")
))
(DEFINEQ

(POSTSCRIPT.MCCS.BLOCKS

  [LAMBDA (TRANSLATIONS)
                                     (* ; "Edited  2-Oct-2026 16:27 by rmk")


                                                             (* ; "Edited 30-Sep-2026 09:14 by rmk")


                                                             (* ; "Edited 28-Sep-2026 12:59 by rmk")


                                                             (* ; "Edited 21-Sep-2026 09:42 by rmk")


                                                             (* ; "Edited 19-Sep-2026 11:29 by rmk")


                                                             (* ; "Edited 17-Sep-2026 12:16 by rmk")


    (* ;; "\POSTSCRIPT.OUTCHARFN uses the blocks created here to quickly determine how to output particular characters. ")


    (LET (BLOCKS BLOCK)
         (SETQ BLOCK (\ALLOCBLOCK (ADD1 \MAXTHINCHAR)
                            T))                              (* ; 

                                                    "Set up charset 0, initialize to slugs, then fix")

         [for
 C from
 0 to
 \MAXTHINCHAR do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                                 '(SLUG]
         (for
 C from
 (CHARCODE SPACE) to
 126 do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                                       (LIST 'BOUT C)))
         (for
 C in
 (CHARCODE (%( %) \)) do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                                  (LIST 'ESCAPE C)))
         (for
 C in
 (CHARCODE (EOL LF FORM TAB)) do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                                          (LIST 'REPOSITION C)))
                                                             (* ; "Meta-ctrl are SLUGs?")

         (for
 C from
 (CHARCODE %#SPACE) to
 254 do
 

                                     (* ;; "8-bit graphic in CS 0.  Not sure about fonts that are not MCCS (e.g. UNACCENTED).  DANCER should get its own MCCS codes.   ")


                                                  (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                                         (LIST 'ESCAPE C)))

         (* ;; "")


         (push
 BLOCKS (CONS 0 BLOCK))

         (* ;; "")


         [for
 ITEM CHARCODE in
 TRANSLATIONS unless
 (EQ '* (CAR ITEM))
            do
 (SETQ CHARCODE (CHARCODE.DECODE (CAR ITEM)))
               (CL:UNLESS (SETQ BLOCK (GETMULTI BLOCKS (\CHARSET CHARCODE)))
                   (SETQ BLOCK (\ALLOCBLOCK (ADD1 \MAXTHINCHAR)
                                      T))
                   (push
 BLOCKS (CONS (\CHARSET CHARCODE)
                                      BLOCK))
                   [for
 C from
 0 to
 \MAXTHINCHAR do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                                           '(SLUG])
               (DESTRUCTURING-BIND
                (KIND CODE2 BASECHAR UNDERACCENTS)
                (SETQ ITEM (CDR ITEM))
                (\RPLPTR BLOCK (UNFOLD (\CHAR8CODE CHARCODE)
                                      WORDSPERCELL)
                       (SELECTQ KIND
                           (NIL (LIST 'ESCAPE (OR (CHARCODE.DECODE CODE2)
                                                  CHARCODE)))
                           (SYMBOL (LIST 'SPECIAL (CHARCODE.DECODE CODE2)
                                         'SYMBOL))
                           (BOUT (LIST 'BOUT (OR (CHARCODE.DECODE CODE2)
                                                 CHARCODE)))
                           (DINGBAT (LIST 'SPECIAL (CHARCODE.DECODE CODE2)
                                          'ZAPFDINGBATS))
                           (FUNCTION (LIST 'FUNCTION CODE2))
                           ((ACCENT ACCENTPAIR) 
                                [LIST* KIND (CHARCODE.DECODE CODE2)
                                       (CHARCODE.DECODE BASECHAR)
                                       (AND UNDERACCENTS (CONS (CHARCODE.DECODE UNDERACCENTS])
                           (APPLY*                           (* ; 

                                                       "Apply setup function to coerce argument data")


                                 (* ;; "ITEM is of the form (APPLY* DATA PRINTFN WIDTHFN SETUPFN)  PRINTFN gets applied to stream and result of applying SETUPFN to DATA.  WIDTHFN gets applied to coerced data and fontdescriptor.  ")


                                   (CONS 'APPLY* (LIST (APPLY* (OR (CAR (CDDDDR ITEM))
                                                                   (FUNCTION CL:IDENTITY))
                                                              (CADR ITEM))
                                                       (CADDR ITEM)
                                                       (CADDDR ITEM))))
                           (ERROR "UNRECOGNIZED POSTSCRIPT CHARACTER TYPE" ITEM]
         (SORT BLOCKS T])

(POSTSCRIPT.ZAPFDINGBATS.BLOCKS

  [LAMBDA NIL
                                                (* ; "Edited  2-Oct-2026 16:36 by rmk")


    (* ;; "Taken from Wikipedia  ZAPFDINGBATS")


    (LET ((BLOCK (\ALLOCBLOCK (ADD1 \MAXTHINCHAR)
                        T)))
         [for
 C from
 0 to
 (SUB1 (CHARCODE SPACE)) do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                                            '(SLUG]
         (for
 C from
 (CHARCODE SPACE) to
 126 do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                                       (LIST 'BOUT C)))
         (for
 C in
 (CHARCODE (%( %) \)) do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                                  (LIST 'ESCAPE C)))
         (\RPLPTR BLOCK (UNFOLD 127 WORDSPERCELL)
                '(SLUG))
         (for
 C from
 128 to
 141 do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                          (LIST 'ESCAPE C)))
         [for
 C from
 142 to
 160 do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                          '(SLUG]
         (for
 C from
 161 to
 254 do
 (\RPLPTR BLOCK (UNFOLD C WORDSPERCELL)
                                          (LIST 'ESCAPE C)))
         (\RPLPTR BLOCK (UNFOLD 240 WORDSPERCELL)
                '(SLUG))                                     (* ; "Cleanup")

         (\RPLPTR BLOCK (UNFOLD 255 WORDSPERCELL)
                '(SLUG))
         (LIST (CONS 0 BLOCK])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *POSTSCRIPT-MAPPING-BLOCKS*)
)

(RPAQ \POSTSCRIPT.ORIENTATION.MENU

      (create MENU ITEMS ← '(("Landscape" T "Print this file/document/image in Landscape Orientation"
                                    )
                             ("Portrait" 'NIL 
                                    "Print this file/document/image in Portrait Orientation"))
             TITLE ← "Orientation" CENTERFLG ← T MENUOFFSET ←
             (create POSITION XCOORD ← -1 YCOORD ← 0)
             CHANGEOFFSETFLG ← 'Y))

(RPAQ \POSTSCRIPT.ORIENTATION.OPTIONS.MENU
 (create MENU ITEMS ← '(("Ask" 'ASK 
                                   "Always ask whether to print in Landscape or Portrait Orientation"
                                                                         )
                                                                  ("Landscape" T 
                                                          "Default printing to Landscape Orientation"
                                                                         )
                                                                  ("Portrait" 'NIL 
                                                           "Default printing to Portrait Orientation"
                                                                         ))
                                                  TITLE ← "Default Orientation" CENTERFLG ← T))

(RPAQ PS.BITMAPARRAY (READARRAY-FROM-LIST 16 (QUOTE BYTE) 0 (QUOTE (48 49 50 51 52 53 54 55 56 57 65 
66 67 68 69 70 NIL))))


(RPAQQ \POSTSCRIPT.JOB.SETUP

       ("/bdef {bind def} bind def" "/ldef {load def} bdef" "/S /show ldef" "/M /moveto ldef" 
              "/DR {transform round exch round exch itransform} bdef" 
              "/L {gsave newpath setlinewidth 0 setlinecap" 
              "  M lineto currentpoint stroke grestore M} bdef" 
              "/L1 {gsave newpath 0 setdash setrgbcolor setlinewidth 0 setlinecap" 
              "  M lineto currentpoint stroke grestore M} bdef" 
              "/L1G {gsave newpath 0 setdash setgray setlinewidth 0 setlinecap" 
              "  M lineto currentpoint stroke grestore M} bdef" 
              "/F {findfont exch scalefont setfont} bdef" 
              "/CLP {newpath M dup 0 rlineto exch 0 exch rlineto" 
              "  neg 0 rlineto closepath clip newpath} bdef" 
              "/R {gsave setrgbcolor newpath M dup 0 rlineto exch 0 exch" 
              "  rlineto neg 0 rlineto closepath eofill grestore} bdef" 
              "/RG {gsave setgray newpath M dup 0 rlineto exch 0 exch" 
              "  rlineto neg 0 rlineto closepath eofill grestore} bdef" "/ellipsedict 9 dict def" 
              "ellipsedict /mtrx matrix put" "/ellipse" " { ellipsedict begin" "  /endangle exch def"
              "  /startangle exch def" "  /orientation exch def" "  /minorrad exch def" 
              "  /majorrad exch def" "  /y exch def" "  /x exch def" 
              "  /savematrix mtrx currentmatrix def" "  x y translate" "  orientation rotate" 
              "  majorrad minorrad scale" "  0 0 1 startangle endangle arc" "  savematrix setmatrix"
              " end } bdef" "/concatprocs" " {/proc2 exch cvlit def" "  /proc1 exch cvlit def" 
              "  /newproc proc1 length proc2 length add array def" "  newproc 0 proc1 putinterval" 
              "  newproc proc1 length proc2 putinterval" "  newproc cvx" " } bdef" 
              "/resmatrix matrix def" "/findresolution" " {72 0 resmatrix defaultmatrix dtransform" 
              "  /yres exch def /xres exch def" "  xres dup mul yres dup mul add sqrt" " } bdef" 
              "/thebitimage" " {/maskp exch def" "  /bihgt exch def" "  /biwid exch def" 
              "  /byte 1 string def" "  /strbufl biwid 8 div ceiling cvi def" 
              "  /strbuf strbufl string def" 
              "  maskp not{{1 exch sub} currenttransfer concatprocs settransfer} if" "  biwid bihgt"
              "  maskp { true } { 1 } ifelse" "  [biwid 0 0 bihgt 0 0]" "  {/col 0 def" 
              "   {currentfile byte readhexstring pop 0 get" "    dup 16#B2 eq {pop" 
              "    currentfile byte readhexstring pop 0 get 1 add" 
              "    currentfile byte readhexstring pop pop /nbyte byte 0 get def" 
              "    { strbuf col nbyte put /col col 1 add def} repeat}" 
              "   {dup 16#B3 eq {pop /col col" "    currentfile byte readhexstring pop" 
              "    0 get add 1 add def}" "    {16#B4 eq {currentfile byte readhexstring pop pop} if"
              "     strbuf col byte 0 get put /col col 1 add def} ifelse" "   } ifelse" 
              "   col strbufl ge { exit } if } loop" "   strbuf }" 
              "  maskp { imagemask } { image } ifelse" " } bdef" "/setuserscreendict 22 dict def" 
              "setuserscreendict begin" " /tempctm matrix def" " /temprot matrix def" 
              " /tempscale matrix def" "end" "/setuserscreen" " {setuserscreendict begin" 
              "   /spotfunction exch def" "   /screenangle exch def" "   /cellsize exch def" 
              "   /m tempctm currentmatrix def" "   /rm screenangle temprot rotate def" 
              "   /sm cellsize dup tempscale scale def" 
              "   sm rm m m concatmatrix m concatmatrix pop" 
              "   1 0 m dtransform /y1 exch def /x1 exch def" 
              "   /veclength x1 dup mul y1 dup mul add sqrt def" 
              "   /frequency findresolution veclength div def" "   /newscreenangle y1 x1 atan def" 
              "   m 2 get m 1 get mul m 0 get m 3 get mul sub" 
              "   0 gt { { neg } /spotfunction load concatprocs" 
              "          /spotfunction exch def } if" 
              "   frequency newscreenangle /spotfunction load setscreen" "  end" " } bdef" 
              "/setpatterndict 18 dict def" "setpatterndict begin" " /bitison" 
              "  {/ybit exch def /xbit exch def" 
              "   /bytevalue bstring ybit bwidth mul xbit 8 idiv add get def" 
              "   /mask 1 7 xbit 8 mod sub bitshift def" "   bytevalue mask and 0 ne" "  } bdef" 
              "end" "/bitpatternspotfunction" " {setpatterndict begin" "   /y exch def /x exch def" 
              "   /xindex x 1 add 2 div bpside mul 1 sub cvi def" 
              "   /yindex y 1 add 2 div bpside mul 1 sub cvi def" "   xindex yindex bitison" 
              "    {/onbits onbits 1 add def 1}" "    {/offbits offbits 1 add def 0} ifelse" "  end"
              " } bdef" "/setpattern" " {setpatterndict begin" "   /cellsz exch def" 
              "   /angle exch def" "   /bwidth exch def" "   /bpside exch def" "   /bstring exch def"
              "   /onbits 0 def /offbits 0 def" 
              "   cellsz angle /bitpatternspotfunction load setuserscreen" "   {} settransfer" 
              "   offbits offbits onbits add div setgray" "  end" " } bdef" 
              "%% - - - - - Fraction-setting code, to support NS fonts better - - - - -" 
              "/fractiondict 20 dict def" "/fractionshow " "{ fractiondict begin" "/denom exch def "
              "/num exch def " "/regfont currentfont def" 
              "/fractfont currentfont [.65 0 0 .6 0 0] makefont def " "gsave newpath 0 0 moveto " 
              "(1) true charpath flattenpath pathbbox " "/height exch def pop pop pop" " grestore" 
              "0 .4 height mul rmoveto" "fractfont setfont num show" 
              "0 .4 height mul neg rmoveto regfont setfont (\244) show" 
              "fractfont setfont denom show regfont setfont end } bdef" 
              "/f14 { (1) (4) fractionshow } bdef" "/f12 { (1) (2) fractionshow } bdef" 
              "/f34 { (3) (4) fractionshow } bdef" "/f18 { (1) (8) fractionshow } bdef" 
              "/f38 { (3) (8) fractionshow } bdef" "/f58 { (5) (8) fractionshow } bdef" 
              "/f78 { (7) (8) fractionshow } bdef" "/f13 { (1) (3) fractionshow } bdef" 
              "/f23 { (2) (3) fractionshow } bdef" "/bboxdict 20 dict def" 
              "/bboxchk { bboxdict begin" "/regfont currentfont def" 
              "/chkfont currentfont [1.25 0 0 1.25 0 0] makefont def " "gsave newpath 0 0 moveto " 
              "(\161) true charpath flattenpath pathbbox " "/height exch def pop pop pop " 
              " grestore " " currentpoint " " .2 height mul .3 height mul rmoveto" 
              "chkfont setfont (\063) show" " moveto" " regfont setfont" "(\161) show end } bdef" 
              "/rencdict 15 dict def" "/encodefont { rencdict begin" "/newname exch def" 
              "/oldfont exch def" "/newcodes [" "8#001 /Aacute" "8#002 /Acircumflex" 
              "8#003 /Adieresis" "8#004 /Agrave" "8#005 /Aring" "8#006 /Atilde" "8#007 /Ccedilla" 
              "8#010 /Eacute" "8#011 /Ecircumflex" "8#012 /Edieresis" "8#013 /Egrave" "8#014 /Iacute"
              "8#015 /Icircumflex" "8#016 /Idieresis" "8#017 /Igrave" "8#020 /Ntilde" "8#021 /Oacute"
              "8#022 /Ocircumflex" "8#023 /Odieresis" "8#024 /Ograve" "8#025 /Otilde" "8#026 /Scaron"
              "8#027 /Uacute" "8#030 /Ucircumflex" "8#031 /Udieresis" "8#032 /Ugrave" 
              "8#033 /Ydieresis" "8#034 /Zcaron" "8#177 /periodinferior" "8#201 /aacute" 
              "8#202 /acircumflex" "8#203 /adieresis" "8#204 /agrave" "8#205 /aring" "8#206 /atilde"
              "8#207 /ccedilla" "8#210 /eacute" "8#211 /ecircumflex" "8#212 /edieresis" 
              "8#213 /egrave" "8#214 /iacute" "8#215 /icircumflex" "8#216 /idieresis" "8#217 /igrave"
              "8#220 /ntilde" "8#221 /oacute" "8#222 /ocircumflex" "8#223 /odieresis" "8#224 /ograve"
              "8#225 /otilde" "8#226 /scaron" "8#227 /uacute" "8#230 /ucircumflex" "8#231 /udieresis"
              "8#232 /ugrave" "8#233 /ydieresis" "8#234 /zcaron" "8#235 /Eth" "8#236 /eth" 
              "8#237 /Thorn" "8#240 /thorn" " ] def" 
              "/olddict oldfont findfont def /newfont olddict maxlength dict def" 
              "olddict { exch dup /FID ne { dup /Encoding eq" 
              "{ exch dup length array copy newfont 3 1 roll put }" 
              "{ exch newfont 3 1 roll put } ifelse }" " { pop pop } ifelse } forall" 
              "newfont /FontName newname put" "newcodes aload pop" 
              "newcodes length 2 idiv { newfont /Encoding get 3 1 roll put } repeat " 
              "newname newfont definefont pop end } def" " /accentdict 10 dict def " 
              " /accentor { accentdict begin /scaler exch def /delta exch def " 
              "/unders exch def /accents exch def /mainch exch def /scrt (X) def" 
              " /w1 mainch stringwidth pop def " " currentpoint mainch show currentpoint 4 2 roll " 
              "accents { /ch exch def 2 copy moveto " "         scrt 0 ch put " 
              "         /w2 scrt stringwidth pop def " 
              "         w1 w2 sub 2 div delta rmoveto scrt show " 
              "         /delta delta 150 scaler mul 9 div add def" "        } forall " 
              "unders { /ch exch def 2 copy moveto " "         scrt 0 ch put " 
              "         /w2 scrt stringwidth pop def " 
        "         ch 46 eq { w1 w2 sub 2 div -175 scaler mul 9 div rmoveto scrt show 0 175 rmoveto }"
              "           { w1 w2 sub 2 div 0 rmoveto scrt show } ifelse " "        } forall " 
              " pop pop moveto end } def " "%%%%EndProlog" "%%%%BeginSetup"))

(RPAQQ SlopeMenuItems
 ((Italic 'ITALIC "This is an Italic Slope font")
                       (Regular 'REGULAR "This is a Regular Slope font")))

(RPAQQ WeightMenuItems
 ((Bold 'BOLD "This is a Bold Weight font")
                        (Medium 'MEDIUM "This is a Medium Weight font")
                        (Light 'LIGHT "This is a Light Weight font")))

(ADDTOVAR BackgroundMenuCommands

          ("PS Orientation" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE (MENU 
                                                                 \POSTSCRIPT.ORIENTATION.OPTIONS.MENU
                                                                     ))
                 "Select the default Orientation for PostScript output"
                 (SUBITEMS ("Ask" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK)
                                  "Always ask whether to print in Landscape or Portrait Orientation")
                        ("Landscape" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE T)
                               "Default printing to Landscape Orientation")
                        ("Portrait" '(SETQ POSTSCRIPT.PREFER.LANDSCAPE NIL)
                               "Default printing to Portrait Orientation"))))

(RPAQQ BackgroundMenu
 NIL)
(DECLARE%: EVAL@COMPILE 

(RPAQQ GOLDEN.RATIO
 1.618034)

(RPAQQ \PS.SCALE0
 100)

(RPAQQ \PS.TEMPARRAYLEN
 20)


(CONSTANTS (GOLDEN.RATIO 1.618034)
       (\PS.SCALE0 100)
       (\PS.TEMPARRAYLEN 20))
)

(RPAQ? POSTSCRIPT.BITMAP.SCALE
 1)

(RPAQ? POSTSCRIPT.EOL
 'CR)

(RPAQ? POSTSCRIPT.IMAGESIZEFACTOR
 1)

(RPAQ? POSTSCRIPT.PREFER.LANDSCAPE
 NIL)

(RPAQ? POSTSCRIPT.TEXTFILE.LANDSCAPE
 NIL)

(RPAQ? POSTSCRIPT.DEFAULT.PAGEREGION
 '(4800 4800 52800 70800))

(RPAQ? POSTSCRIPT.TEXTURE.SCALE
 4)

(ADDTOVAR PRINTFILETYPES
 (POSTSCRIPT (TEST POSTSCRIPTFILEP)
                                (EXTENSION (PS PSC PSF POSTSCRIPT))
                                (BITMAPSCALE POSTSCRIPT.BITMAPSCALE)
                                (BITMAPFILE (POSTSCRIPT.HARDCOPYW IMAGEFILE BITMAP SCALEFACTOR REGION
                                                   ROTATION TITLE))))

(ADDTOVAR IMAGESTREAMTYPES
 (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM)
                                  (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE)
                                  (FONTCREATE POSTSCRIPT.FONTCREATE)
                                  (CREATECHARSET POSTSCRIPT.CREATECHARSET)))

(RPAQ? POSTSCRIPT.PAGETYPE
 'LETTER)



(* ;; 
"NIL means initial clipping is same as paper size.  Don't know why the other regions were specified--rmk"
)



(APPENDTOVAR POSTSCRIPT.PAGEREGIONS
 (LETTER (0 0 8.5 11)
                                           NIL
                                           (-0.1 -0.1 8.7 11.2))
                                    (LEGAL (0 0 8.5 14)
                                           NIL
                                           (-0.1 -0.1 8.7 14.2))
                                    (NOTE (0 0 8.5 11)
                                          NIL
                                          (-0.1 -0.1 8.7 11.2)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.EOL POSTSCRIPT.PREFER.LANDSCAPE 
       POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE \POSTSCRIPT.JOB.SETUP 
       \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPTIMAGEOPS POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(POSTSCRIPT.INIT
)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 POSTSCRIPT.PUTCOMMAND)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (22280 32989 (POSTSCRIPT.INIT 22290 . 27222) (POSTSCRIPT.INIT.FONTPROFILE 27224 . 29595)
 (POSTSCRIPT.PUTRGBCOLOR 29597 . 30619) (\PSC.COLOR.TO.RGB 30621 . 32987)) (33232 57737 (
PSCFONT.READFONT 33242 . 35253) (PSCFONT.FILEP 35255 . 35442) (PSCFONT.WRITEFONT 35444 . 36478) (
PSCFONT.FILENAME 36480 . 37509) (READ-AFM-FILE 37511 . 43111) (CONVERT-AFM-FILES 43113 . 44636) (
POSTSCRIPT.GETFONTID 44638 . 46042) (PSCFONT.TO.FONTDESCRIPTOR 46044 . 57735)) (58099 69628 (
POSTSCRIPT.FONTSAVAILABLE 58109 . 60761) (POSTSCRIPT.CREATECHARSET 60763 . 63960) (
POSTSCRIPT.FONTCREATE 63962 . 68020) (\POSTSCRIPT.FONTCHANGESTRING 68022 . 69626)) (70725 80820 (
OPENPOSTSCRIPTSTREAM 70735 . 80306) (CLOSEPOSTSCRIPTSTREAM 80308 . 80818)) (80865 87199 (
POSTSCRIPT.HARDCOPYW 80875 . 83990) (POSTSCRIPT.TEDIT 83992 . 84444) (POSTSCRIPTFILEP 84446 . 85934) (
MAKEEPSFILE 85936 . 87197)) (87200 126794 (POSTSCRIPT.BITMAPSCALE 87210 . 89666) (
POSTSCRIPT.CLOSESTRING 89668 . 90221) (POSTSCRIPT.ENDPAGE 90223 . 91114) (POSTSCRIPT.OUTSTR 91116 . 
92333) (POSTSCRIPT.PUTBITMAPBYTES 92335 . 100147) (POSTSCRIPT.PUTCOMMAND 100149 . 101138) (
POSTSCRIPT.SET-FAKE-LANDSCAPE 101140 . 105672) (POSTSCRIPT.SHOWACCUM 105674 . 107829) (
POSTSCRIPT.STARTPAGE 107831 . 110533) (\POSTSCRIPTTAB 110535 . 111332) (\PS.BOUTFIXP 111334 . 112614) 
(\PS.SCALEHACK 112616 . 115259) (\PS.SCALEREGION 115261 . 115833) (\SCALEDBITBLT.PSC 115835 . 120145) 
(\SETPOS.PSC 120147 . 120628) (\SETXFORM.PSC 120630 . 123214) (\STRINGWIDTH.PSC 123216 . 123689) (
\SWITCHFONTS.PSC 123691 . 125556) (\TERPRI.PSC 125558 . 126792)) (126829 179889 (\BITBLT.PSC 126839 . 
127391) (\BLTSHADE.PSC 127393 . 132054) (\CHARWIDTH.PSC 132056 . 132563) (\DRAWARC.PSC 132565 . 134943
) (\DRAWCIRCLE.PSC 134945 . 137196) (\DRAWCURVE.PSC 137198 . 141042) (\DRAWELLIPSE.PSC 141044 . 143408
) (\DRAWLINE.PSC 143410 . 146150) (\DRAWPOINT.PSC 146152 . 146728) (\DRAWPOLYGON.PSC 146730 . 149859) 
(\DSPBOTTOMMARGIN.PSC 149861 . 150548) (\DSPCLIPPINGREGION.PSC 150550 . 151925) (\DSPCOLOR.PSC 151927
 . 153063) (\DSPFONT.PSC 153065 . 157035) (\DSPLEFTMARGIN.PSC 157037 . 157723) (\DSPLINEFEED.PSC 
157725 . 158315) (\DSPPUSHSTATE.PSC 158317 . 159797) (\DSPPOPSTATE.PSC 159799 . 163284) (\DSPRESET.PSC
 163286 . 163951) (\DSPRIGHTMARGIN.PSC 163953 . 164642) (\DSPROTATE.PSC 164644 . 165643) (
\DSPSCALE.PSC 165645 . 166597) (\DSPSCALE2.PSC 166599 . 167439) (\DSPSPACEFACTOR.PSC 167441 . 168362) 
(\DSPTOPMARGIN.PSC 168364 . 168935) (\DSPTRANSLATE.PSC 168937 . 170968) (\DSPXPOSITION.PSC 170970 . 
171534) (\DSPYPOSITION.PSC 171536 . 172127) (\FILLCIRCLE.PSC 172129 . 174354) (\FILLPOLYGON.PSC 174356
 . 177593) (\FIXLINELENGTH.PSC 177595 . 178914) (\MOVETO.PSC 178916 . 179686) (\NEWPAGE.PSC 179688 . 
179887)) (179945 194047 (\POSTSCRIPT.CHANGECHARSET 179955 . 181742) (\POSTSCRIPT.OUTCHARFN 181744 . 
186842) (\POSTSCRIPT.PRINTSLUG 186844 . 188770) (\POSTSCRIPT.SPECIALOUTCHARFN 188772 . 190314) (
\UPDATE.PSC 190316 . 191562) (\POSTSCRIPT.ACCENTPAIR 191564 . 194045)) (198959 200551 (\PSC.SPACEDISP 
198969 . 199248) (\PSC.SPACEWID 199250 . 199873) (\PSC.SYMBOLS 199875 . 200549)) (228112 234676 (
POSTSCRIPT.MCCS.BLOCKS 228122 . 233127) (POSTSCRIPT.ZAPFDINGBATS.BLOCKS 233129 . 234674)))))
STOP