diff --git a/lispusers/DICOLOR b/lispusers/DICOLOR
deleted file mode 100644
index a5cec274..00000000
--- a/lispusers/DICOLOR
+++ /dev/null
@@ -1,446 +0,0 @@
-(FILECREATED "15-Aug-85 19:44:58" {ERIS}<LISPCORE>LIBRARY>DICOLOR.;2 15766  
-
-      changes to:  (VARS DICOLORCOMS)
-
-      previous date: " 9-Aug-85 05:58:26" {ERIS}<LISPCORE>LIBRARY>DICOLOR.;1)
-
-
-(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT DICOLORCOMS)
-
-(RPAQQ DICOLORCOMS ((FNS CNSMENUINIT CNSTOCSL CNSTORGB CSLTOCNS DICOLOR.FROM.USER GETCNS HLSTOCSL 
-			 CSLTOHLS RGBTOCNS)
-		    (VARS DICOLOR.hueMapping DICOLOR.lightnessMapping DICOLOR.saturationMapping 
-			  NEWCOLORITEM)
-		    (INITVARS (COLORNAMEMENU))
-		    (FNS DICOLOR.hueN DICOLOR.hueNvalue DICOLOR.hueNname DICOLOR.lightnessN 
-			 DICOLOR.lightnessNvalue DICOLOR.lightnessNname DICOLOR.saturationN 
-			 DICOLOR.saturationNvalue DICOLOR.saturationNname)
-		    (DECLARE: DONTCOPY (*)
-			      (RECORDS hueRecord lightnessRecord saturationRecord)
-			      (CONSTANTS * DICOLOR.hueConstants)
-			      (CONSTANTS * DICOLOR.saturationConstants)
-			      (CONSTANTS * DICOLOR.lightnessConstants))))
-(DEFINEQ
-
-(CNSMENUINIT
-  [LAMBDA NIL                                                (* gbn " 9-Aug-85 03:11")
-    [SETQ CNSHUEMENU (create MENU
-			     ITEMS _(for I in DICOLOR.hueMapping collect (CAR I]
-    [SETQ CNSSATURATIONMENU (create MENU
-				    ITEMS _(for I in DICOLOR.saturationMapping collect (CAR I]
-    (SETQ CNSLIGHTNESSMENU (create MENU
-				   ITEMS _(for I in DICOLOR.lightnessMapping collect (CAR I])
-
-(CNSTOCSL
-  [LAMBDA (hue saturation lightness)                         (* hdj "12-Apr-85 19:01")
-    (PROG ((hueAtom (MKATOM hue))
-	   (saturationAtom (MKATOM saturation))
-	   (lightnessAtom (MKATOM lightness))
-	   c s l)
-          (if [NOT (SETQ c (fetch (hueRecord ordering) of (ASSOC hueAtom DICOLOR.hueMapping]
-	      then (SETQ c DICOLOR.achromatic))
-          (if (EQ c DICOLOR.achromatic)
-	      then (SETQ s DICOLOR.noSaturation)
-	    else (if [NOT (SETQ s (fetch (saturationRecord ordering) of (ASSOC saturationAtom 
-									DICOLOR.saturationMapping]
-		     then (SETQ s DICOLOR.vivid)))
-          (SELECTQ hueAtom
-		   (Black (SETQ l DICOLOR.black))
-		   (White (SETQ l DICOLOR.white))
-		   (if [NOT (SETQ l (fetch (lightnessRecord ordering) of (ASSOC lightnessAtom 
-									 DICOLOR.lightnessMapping]
-		       then (SETQ l DICOLOR.medium)))
-          (RETURN (LIST c s l])
-
-(CNSTORGB
-  [LAMBDA (saturation lightness hue)                         (* hdj "15-Jul-85 12:33")
-    (LET ((CSL (CNSTOCSL hue saturation lightness)))
-         (HLSTORGB (APPLY (FUNCTION CSLTOHLS)
-			  CSL])
-
-(CSLTOCNS
-  [LAMBDA (c s l)                                            (* hdj "15-Jul-85 12:37")
-    (PROG (hue saturation lightness)
-          [if (EQ c DICOLOR.achromatic)
-	      then (SETQ saturation "")
-		   [SELECTC l
-			    (DICOLOR.black (SETQ hue "Black")
-					   (SETQ lightness ""))
-			    (DICOLOR.white (SETQ hue "White")
-					   (SETQ lightness ""))
-			    (PROGN (SETQ hue "Gray")
-				   (SETQ lightness (MKSTRING (fetch (lightnessRecord name)
-								of (DICOLOR.lightnessN l]
-	    else (SETQ hue (fetch (hueRecord name) of (DICOLOR.hueN c)))
-		 (SETQ saturation (fetch (saturationRecord name) of (DICOLOR.saturationN s)))
-		 (SETQ lightness (fetch (lightnessRecord name) of (DICOLOR.lightnessN l]
-          (RETURN (LIST saturation lightness hue])
-
-(DICOLOR.FROM.USER
-  [LAMBDA (NAMES?)                                           (* gbn " 9-Aug-85 04:51")
-
-          (* * returns an RGB triple. If NAMES? prompts the user first with the global color name menu.
-	  She can then choose NEWCOLOR which can be specified as RGB or CNS)
-
-
-    (PROG (NAME RGB)
-          (if NAMES?
-	      then                                           (* first try to get a color name)
-		   [SETQ NAME (MENU (OR COLORNAMEMENU (SETQ COLORNAMEMENU
-					  (CREATE MENU
-						  ITEMS _(CONS NEWCOLORITEM
-							       (FOR ENTRY IN COLORNAMES
-								  COLLECT (CAR ENTRY]
-		   (if (NOT NAME)
-		       then                                  (* the user clicked outside the menu)
-			    (RETURN))
-		   [SETQ RGB (SELECTQ NAME
-				      (RGB (READCOLOR1 "specify new color"))
-				      (CNS (APPLY (FUNCTION CNSTORGB)
-						  (GETCNS)))
-				      (RETURN (CDR (ASSOC NAME COLORNAMES]
-		   (if (NOT (SETQ NAME (TTYIN "New color name? ")))
-		       then                                  (* user must have decided that she didn't want to keep 
-							     (name) the color)
-			    (RETURN))
-		   (push COLORNAMES (CONS (CAR NAME)
-					  RGB))
-		   (SETQ COLORNAMEMENU NIL)                  (* invalidate the menu)
-		   (RETURN RGB])
-
-(GETCNS
-  [LAMBDA NIL                                                (* gbn " 9-Aug-85 03:13")
-    (LIST (MENU CNSLIGHTNESSMENU)
-	  (MENU CNSSATURATIONMENU)
-	  (MENU CNSHUEMENU])
-
-(HLSTOCSL
-  [LAMBDA (hue lightness saturation)                         (* hdj "15-Jul-85 12:14")
-    (LET ((ISLHue (FQUOTIENT (MOD (PLUS hue 240)
-				  360)
-			     360)))
-         (PROG (c s l)
-	       (for old s from DICOLOR.noSaturation to DICOLOR.vivid
-		  do (if (EQ s DICOLOR.vivid)
-			 then (RETURN))
-		     (if (LEQ saturation (PLUS (DICOLOR.saturationNvalue s)
-					       (QUOTIENT (DIFFERENCE (DICOLOR.saturationNvalue
-								       (ADD1 s))
-								     (DICOLOR.saturationNvalue s))
-							 2)))
-			 then (RETURN)))
-	       [if (EQ s DICOLOR.noSaturation)
-		   then (SETQ c DICOLOR.achromatic)
-			(for old l from DICOLOR.black to DICOLOR.white
-			   do (if (EQ l DICOLOR.white)
-				  then (RETURN))
-			      (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l)
-						       (QUOTIENT (DIFFERENCE (DICOLOR.lightnessNvalue
-									       (ADD1 l))
-									     (DICOLOR.lightnessNvalue
-									       l))
-								 2)))
-				  then (RETURN)))
-		 else (for old c from DICOLOR.red to DICOLOR.purplishRed
-			 do                                  (* (HELP c))
-			    (if (EQ c DICOLOR.purplishRed)
-				then (if (GREATERP ISLHue (PLUS (DICOLOR.hueNvalue c)
-								(QUOTIENT (DIFFERENCE 1 (
-										DICOLOR.hueNvalue
-											c))
-									  2)))
-					 then (SETQ c DICOLOR.red))
-				     (RETURN))
-			    (if (LEQ ISLHue (PLUS (DICOLOR.hueNvalue c)
-						  (QUOTIENT (DIFFERENCE (DICOLOR.hueNvalue
-									  (ADD1 c))
-									(DICOLOR.hueNvalue c))
-							    2)))
-				then (RETURN)))
-		      (for old l from DICOLOR.veryDark to DICOLOR.veryLight
-			 do (if (EQ l DICOLOR.veryLight)
-				then (RETURN))
-			    (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l)
-						     (QUOTIENT (DIFFERENCE (DICOLOR.lightnessNvalue
-									     (ADD1 l))
-									   (DICOLOR.lightnessNvalue
-									     l))
-							       2)))
-				then (RETURN]
-	       (RETURN (LIST c s l])
-
-(CSLTOHLS
-  [LAMBDA (c s l)                                            (* hdj "15-Jul-85 12:23")
-    (PROG (hue saturation lightness)
-          (if (EQ c DICOLOR.achromatic)
-	      then (SETQ hue 0.0)
-		   (SETQ saturation 0.0)
-		   (SETQ lightness (DICOLOR.lightnessNvalue l))
-	    else (SETQ hue (DICOLOR.hueNvalue c))
-		 (SETQ saturation (DICOLOR.saturationNvalue s))
-		 (SETQ lightness (DICOLOR.lightnessNvalue l)))
-          (RETURN (LIST (MOD (FPLUS 120 (FTIMES hue 360))
-			     360)
-			lightness saturation])
-
-(RGBTOCNS
-  [LAMBDA (Red Green Blue)                                   (* hdj "15-Jul-85 12:36")
-    (APPLY (FUNCTION CSLTOCNS)
-	   (APPLY (FUNCTION HLSTOCSL)
-		  (RGBTOHLS Red Green Blue])
-)
-
-(RPAQQ DICOLOR.hueMapping ((Achromatic 0.0 -1)
-			   (Red 0.0 0)
-			   (OrangishRed .01 1)
-			   (RedOrange .02 2)
-			   (ReddishOrange .03 3)
-			   (Orange .04 4)
-			   (YellowishOrange .07 5)
-			   (OrangeYellow .1 6)
-			   (OrangishYellow .13 7)
-			   (Yellow .1673 8)
-			   (GreenishYellow .2073 9)
-			   (YellowGreen .2473 10)
-			   (YellowishGreen .2873 11)
-			   (Green .3333 12)
-			   (BluishGreen .4133 13)
-			   (GreenBlue .4933 14)
-			   (GreenishBlue .5733 15)
-			   (Blue .6666 16)
-			   (PurplishBlue .6816 17)
-			   (BluePurple .6966 18)
-			   (BluishPurple .7116 19)
-			   (Purple .73 20)
-			   (ReddishPurple .8 21)
-			   (PurpleRed .87 22)
-			   (PurplishRed .94 23)
-			   (BrownishRed .01 24)
-			   (RedBrown .02 25)
-			   (ReddishBrown .03 26)
-			   (Brown .04 27)
-			   (YellowishBrown .07 28)
-			   (BrownYellow .1 29)
-			   (BrownishYellow .13 30)))
-
-(RPAQQ DICOLOR.lightnessMapping ((Black 0.0 0)
-				 (VeryDark .1666 1)
-				 (Dark .3333 2)
-				 (Medium .5 3)
-				 (Light .6666 4)
-				 (VeryLight .8333 5)
-				 (White 1.0 6)))
-
-(RPAQQ DICOLOR.saturationMapping ((NoSaturation 0.0 0)
-				  (Grayish .25 1)
-				  (Moderate .5 2)
-				  (Strong .75 3)
-				  (Vivid 1.0 4)))
-
-(RPAQQ NEWCOLORITEM (New% Color (QUOTE CNS)
-				"Allows specification of a new color"
-				(SUBITEMS (RGB (QUOTE RGB)
-					       "Specify a new color using Red, Green, Blue sliders")
-					  (CNS (QUOTE CNS)
-					       "Specify a new color using English"))))
-
-(RPAQ? COLORNAMEMENU )
-(DEFINEQ
-
-(DICOLOR.hueN
-  [LAMBDA (N)                                                (* hdj "17-Apr-85 13:38")
-    (DECLARE (GLOBALVARS DICOLOR.hueMapping))
-    (for ELT in DICOLOR.hueMapping suchthat (EQ (fetch (hueRecord ordering) of ELT)
-						N])
-
-(DICOLOR.hueNvalue
-  [LAMBDA (N)                                                (* hdj "18-Apr-85 09:58")
-    (fetch (hueRecord value) of (DICOLOR.hueN N])
-
-(DICOLOR.hueNname
-  [LAMBDA (N)                                                (* hdj "18-Apr-85 10:07")
-    (fetch (hueRecord name) of (DICOLOR.hueN N])
-
-(DICOLOR.lightnessN
-  [LAMBDA (N)                                                (* hdj "17-Apr-85 13:40")
-    (DECLARE (GLOBALVARS DICOLOR.lightnessMapping))
-    (for ELT in DICOLOR.lightnessMapping suchthat (EQ (fetch (lightnessRecord ordering) of ELT)
-						      N])
-
-(DICOLOR.lightnessNvalue
-  [LAMBDA (N)                                                (* hdj "17-Apr-85 13:36")
-    (fetch (lightnessRecord value) of (DICOLOR.lightnessN N])
-
-(DICOLOR.lightnessNname
-  [LAMBDA (N)                                                (* hdj "17-Apr-85 14:02")
-    (fetch (lightnessRecord name) of (DICOLOR.lightnessN N])
-
-(DICOLOR.saturationN
-  [LAMBDA (N)                                                (* hdj "17-Apr-85 13:39")
-    (DECLARE (GLOBALVARS DICOLOR.saturationMapping))
-    (for ELT in DICOLOR.saturationMapping suchthat (EQ (fetch (saturationRecord ordering)
-							  of ELT)
-						       N])
-
-(DICOLOR.saturationNvalue
-  [LAMBDA (N)                                                (* hdj "17-Apr-85 13:36")
-    (fetch (saturationRecord value) of (DICOLOR.saturationN N])
-
-(DICOLOR.saturationNname
-  [LAMBDA (N)                                                (* hdj "17-Apr-85 14:02")
-    (fetch (saturationRecord name) of (DICOLOR.saturationN N])
-)
-(DECLARE: DONTCOPY 
-[DECLARE: EVAL@COMPILE 
-
-(RECORD hueRecord (name value ordering))
-
-(RECORD lightnessRecord (name value ordering))
-
-(RECORD saturationRecord (name value ordering))
-]
-
-
-(RPAQQ DICOLOR.hueConstants (DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen 
-						DICOLOR.bluishPurple DICOLOR.brown 
-						DICOLOR.brownYellow DICOLOR.brownishRed 
-						DICOLOR.brownishYellow DICOLOR.green 
-						DICOLOR.greenBlue DICOLOR.greenishBlue 
-						DICOLOR.greenishYellow DICOLOR.orange 
-						DICOLOR.orangeYellow DICOLOR.orangishRed 
-						DICOLOR.orangishYellow DICOLOR.purple 
-						DICOLOR.purpleRed DICOLOR.purplishBlue 
-						DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown 
-						DICOLOR.redOrange DICOLOR.reddishBrown 
-						DICOLOR.reddishOrange DICOLOR.reddishPurple 
-						DICOLOR.yellow DICOLOR.yellowGreen 
-						DICOLOR.yellowishBrown DICOLOR.yellowishGreen 
-						DICOLOR.yellowishOrange))
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ DICOLOR.achromatic -1)
-
-(RPAQQ DICOLOR.blue 16)
-
-(RPAQQ DICOLOR.bluePurple 18)
-
-(RPAQQ DICOLOR.bluishGreen 13)
-
-(RPAQQ DICOLOR.bluishPurple 19)
-
-(RPAQQ DICOLOR.brown 27)
-
-(RPAQQ DICOLOR.brownYellow 29)
-
-(RPAQQ DICOLOR.brownishRed 24)
-
-(RPAQQ DICOLOR.brownishYellow 30)
-
-(RPAQQ DICOLOR.green 12)
-
-(RPAQQ DICOLOR.greenBlue 14)
-
-(RPAQQ DICOLOR.greenishBlue 15)
-
-(RPAQQ DICOLOR.greenishYellow 9)
-
-(RPAQQ DICOLOR.orange 4)
-
-(RPAQQ DICOLOR.orangeYellow 6)
-
-(RPAQQ DICOLOR.orangishRed 1)
-
-(RPAQQ DICOLOR.orangishYellow 7)
-
-(RPAQQ DICOLOR.purple 20)
-
-(RPAQQ DICOLOR.purpleRed 22)
-
-(RPAQQ DICOLOR.purplishBlue 17)
-
-(RPAQQ DICOLOR.purplishRed 23)
-
-(RPAQQ DICOLOR.red 0)
-
-(RPAQQ DICOLOR.redBrown 25)
-
-(RPAQQ DICOLOR.redOrange 2)
-
-(RPAQQ DICOLOR.reddishBrown 26)
-
-(RPAQQ DICOLOR.reddishOrange 3)
-
-(RPAQQ DICOLOR.reddishPurple 21)
-
-(RPAQQ DICOLOR.yellow 8)
-
-(RPAQQ DICOLOR.yellowGreen 10)
-
-(RPAQQ DICOLOR.yellowishBrown 28)
-
-(RPAQQ DICOLOR.yellowishGreen 11)
-
-(RPAQQ DICOLOR.yellowishOrange 5)
-
-(CONSTANTS DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen 
-	   DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed 
-	   DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue 
-	   DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed 
-	   DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue 
-	   DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown 
-	   DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen 
-	   DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange)
-)
-
-
-(RPAQQ DICOLOR.saturationConstants (DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate 
-							 DICOLOR.strong DICOLOR.vivid))
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ DICOLOR.noSaturation 0)
-
-(RPAQQ DICOLOR.grayish 1)
-
-(RPAQQ DICOLOR.moderate 2)
-
-(RPAQQ DICOLOR.strong 3)
-
-(RPAQQ DICOLOR.vivid 4)
-
-(CONSTANTS DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid)
-)
-
-
-(RPAQQ DICOLOR.lightnessConstants (DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium 
-						 DICOLOR.light DICOLOR.veryLight DICOLOR.white))
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ DICOLOR.black 0)
-
-(RPAQQ DICOLOR.veryDark 1)
-
-(RPAQQ DICOLOR.dark 2)
-
-(RPAQQ DICOLOR.medium 3)
-
-(RPAQQ DICOLOR.light 4)
-
-(RPAQQ DICOLOR.veryLight 5)
-
-(RPAQQ DICOLOR.white 6)
-
-(CONSTANTS DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight 
-	   DICOLOR.white)
-)
-)
-(PUTPROPS DICOLOR COPYRIGHT ("Xerox Corporation" 1985))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (1005 8438 (CNSMENUINIT 1015 . 1502) (CNSTOCSL 1504 . 2550) (CNSTORGB 2552 . 2782) (
-CSLTOCNS 2784 . 3683) (DICOLOR.FROM.USER 3685 . 5118) (GETCNS 5120 . 5322) (HLSTOCSL 5324 . 7615) (
-CSLTOHLS 7617 . 8217) (RGBTOCNS 8219 . 8436)) (9938 12002 (DICOLOR.hueN 9948 . 10228) (
-DICOLOR.hueNvalue 10230 . 10405) (DICOLOR.hueNname 10407 . 10580) (DICOLOR.lightnessN 10582 . 10892) (
-DICOLOR.lightnessNvalue 10894 . 11087) (DICOLOR.lightnessNname 11089 . 11280) (DICOLOR.saturationN 
-11282 . 11606) (DICOLOR.saturationNvalue 11608 . 11804) (DICOLOR.saturationNname 11806 . 12000)))))
-STOP
diff --git a/lispusers/POSTSCRIPT/POSTSCRIPTSTREAM b/lispusers/POSTSCRIPT/POSTSCRIPTSTREAM
deleted file mode 100644
index c2112627..00000000
--- a/lispusers/POSTSCRIPT/POSTSCRIPTSTREAM
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP")
(FILECREATED "18-Feb-91 11:52:53" {DSK}<users>gadener>medley>work>PS>POSTSCRIPTSTREAM.;5 149573 

      changes to%:  (VARS POSTSCRIPTSTREAMCOMS)

      previous date%: "15-Feb-91 16:35:41" {DSK}<users>gadener>medley>work>PS>POSTSCRIPTSTREAM.;4)


(* ; "
Copyright (c) 1989, 1990, 1991 by Savoir and Beckman.  All rights reserved.
")

(PRETTYCOMPRINT POSTSCRIPTSTREAMCOMS)

(RPAQQ POSTSCRIPTSTREAMCOMS
       [(RECORDS FONTID PSCFONT \POSTSCRIPTDATA)
        (FNS CLOSEPOSTSCRIPTSTREAM OPENPOSTSCRIPTSTREAM POSTSCRIPT.BITMAPSCALE POSTSCRIPT.CLOSESTRING
             POSTSCRIPT.ENDPAGE POSTSCRIPT.FONTCREATE POSTSCRIPT.FONTSAVAILABLE POSTSCRIPT.GETFONTID
             POSTSCRIPT.HARDCOPYW POSTSCRIPT.INIT POSTSCRIPT.OUTSTR POSTSCRIPT.PUTBITMAPBYTES 
             POSTSCRIPT.PUTCOMMAND POSTSCRIPT.SHOWACCUM POSTSCRIPT.STARTPAGE POSTSCRIPT.TEDIT 
             POSTSCRIPT.TEXT POSTSCRIPTFILEP PSCFONT.READFONT PSCFONT.SPELLFILE PSCFONT.WRITEFONT 
             READ-AFM-FILE \BITBLT.PSC \BLTSHADE.PSC \CHARWIDTH.PSC \DRAWARC.PSC \DRAWCIRCLE.PSC 
             \DRAWCURVE.PSC \DRAWELLIPSE.PSC \DRAWLINE.PSC \DRAWPOINT.PSC \DRAWPOLYGON.PSC 
             \DSPBOTTOMMARGIN.PSC \DSPCLIPPINGREGION.PSC \DSPFONT.PSC \DSPLEFTMARGIN.PSC 
             \DSPLINEFEED.PSC \DSPRESET.PSC \DSPRIGHTMARGIN.PSC \DSPROTATE.PSC \DSPSCALE.PSC 
             \DSPSPACEFACTOR.PSC \DSPTOPMARGIN.PSC \DSPTRANSLATE.PSC \DSPXPOSITION.PSC 
             \DSPYPOSITION.PSC \FILLCIRCLE.PSC \FILLPOLYGON.PSC \FIXLINELENGTH.PSC \MOVETO.PSC 
             \NEWPAGE.PSC \POSTSCRIPTTAB \PS.BOUTFIXP \PS.SCALEHACK \PS.SCALEREGION \SCALEDBITBLT.PSC
             \SETPOS.PSC \SETXFORM.PSC \STRINGWIDTH.PSC \SWITCHFONTS.PSC \TERPRI.PSC)
        (FNS \POSTSCRIPT.OUTCHARFN \POSTSCRIPT.SYMBOLOUTCHAR)
        (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)
               (POSTSCRIPTFONTDIRECTORIES (LIST (IF (EQL (MACHINETYPE)
                                                         'MAIKO)
                                                    then "{DSK}/usr/local/lde/fonts/postscript/" else
                                                    "{DSK}<LISPFILES>FONTS>PSC>")))
               (\POSTSCRIPT.MAX.WILD.FONTSIZE 72))
        [ADDVARS (POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA)
                        (HELVETICAD . HELVETICA)
                        (TIMESROMAN . TIMES)
                        (TIMESROMAND . TIMES)
                        (COURIER . COURIER)
                        (GACHA . COURIER)
                        (CLASSIC . TIMES)
                        (MODERN . HELVETICA)
                        (CREAM . HELVETICA)
                        (TERMINAL . COURIER)
                        (LOGO . HELVETICA)
                        (TITAN . COURIER))
               [PRINTERTYPES ((POSTSCRIPT)
                              (CANPRINT (POSTSCRIPT))
                              (STATUS TRUE)
                              (PROPERTIES NILL)
                              (SEND POSTSCRIPT.SEND)
                              (BITMAPSCALE POSTSCRIPT.BITMAPSCALE)
                              (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION 
                                                 ROTATION TITLE]
               [PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP)
                                      (EXTENSION (PS PSC))
                                      (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT]
               (IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM)
                                        (FONTCREATE POSTSCRIPT.FONTCREATE)
                                        (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE)
                                        (CREATECHARSET NILL]
        (INITVARS (POSTSCRIPT.PAGETYPE 'LETTER))
        [APPENDVARS (POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11)
                                                   (0.197 0.197 8.1 10.6))
                           (LEGAL (0 0 8.5 14)
                                  (0.89 0.5 6.72 13.0))
                           (NOTE (0 0 8.5 11)
                                 (0.405 0.42 7.69 10.16]
        (GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.EOL POSTSCRIPT.FONT.ALIST
               POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE 
               POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.MAX.WILD.FONTSIZE 
               \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPTIMAGEOPS POSTSCRIPT.PAGETYPE 
               POSTSCRIPT.PAGEREGIONS)
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (POSTSCRIPT.INIT)))
        (PROP (FILETYPE MAKEFILE-ENVIRONMENT)
              POSTSCRIPTSTREAM)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA 
                                                                                POSTSCRIPT.PUTCOMMAND
                                                                                   ])
(DECLARE%: EVAL@COMPILE

(RECORD FONTID (FONTIDNAME FONTXFACTOR FONTOBLIQUEFACTOR))

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

(DATATYPE \POSTSCRIPTDATA 
          (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 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")
                 )
          POSTSCRIPTX _ 0 POSTSCRIPTY _ 0 POSTSCRIPTTRANSX _ 0 POSTSCRIPTTRANSY _ 0 
          POSTSCRIPTSPACEFACTOR _ 1 POSTSCRIPTPAGENUM _ 0 POSTSCRIPTSCALEHACK _ 1 POSTSCRIPTTEMPARRAY
          _ (ARRAY \PS.TEMPARRAYLEN 'BYTE 0 0))
)

(/DECLAREDATATYPE '\POSTSCRIPTDATA
       '(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)
       '((\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))
       '58)
(DEFINEQ

(CLOSEPOSTSCRIPTSTREAM
  [LAMBDA (STREAM)                                (* ; "Edited 30-Mar-90 17:18 by Matt Heffron")
    (POSTSCRIPT.ENDPAGE STREAM)
    (POSTSCRIPT.PUTCOMMAND STREAM :EOL "%%%%Trailer" :EOL)
    (BOUT STREAM (CHARCODE ^D])

(OPENPOSTSCRIPTSTREAM
  [LAMBDA (FILE OPTIONS)                          (* ; "Edited 30-Mar-90 17:02 by Matt Heffron")
    (LET ([FP (OPENSTREAM FILE 'OUTPUT NIL `((EOL ,POSTSCRIPT.EOL)
                                             (TYPE POSTSCRIPT)
                                             (SEQUENTIAL T]
          (IMAGEDATA (create \POSTSCRIPTDATA))
          PAPER IMAGESIZEFACTOR CLIP REG)
         (replace (STREAM OUTCHARFN) of FP with '\FILEOUTCHARFN)
         (replace (STREAM IMAGEDATA) of FP with IMAGEDATA)
         (replace (STREAM IMAGEOPS) of FP with \POSTSCRIPTIMAGEOPS)
         (printout FP "%%!PS-Adobe-2.0" T "%%%%Title: " (MKSTRING (OR (LISTGET OPTIONS 
                                                                             'DOCUMENT.NAME)
                                                                      FILE))
                T 
                "%%%%Creator: PostScript ImageStream Driver Copyright Beckman Instruments and Savoir"
                T "%%%%CreationDate: " (DATE)
                T "%%%%For: " (if (STRING-EQUAL INITIALS "Edited:")
                                  then (MKSTRING USERNAME)
                                else INITIALS)
                T "%%%%EndComments" T)
         (for X in \POSTSCRIPT.JOB.SETUP do (POSTSCRIPT.OUTSTR FP X)
                                                       (\FILEOUTCHARFN FP (CHARCODE EOL)))
         (SETQ PAPER (OR (CDR (FASSOC (SETQ PAPER (OR (LISTGET OPTIONS 'PAGETYPE)
                                                      (LISTGET OPTIONS 'PAPERTYPE)
                                                      POSTSCRIPT.PAGETYPE))
                                     POSTSCRIPT.PAGEREGIONS))
                         (ERROR "Unknown PostScript page type" PAPER)))
         (if (NOT (AND [SETQ IMAGESIZEFACTOR (NUMBERP (LISTGET OPTIONS 'IMAGESIZEFACTOR]
                           (CL:PLUSP IMAGESIZEFACTOR)))
             then (SETQ IMAGESIZEFACTOR 1))
         (if (AND (NUMBERP POSTSCRIPT.IMAGESIZEFACTOR)
                      (CL:PLUSP POSTSCRIPT.IMAGESIZEFACTOR))
             then (SETQ IMAGESIZEFACTOR (TIMES IMAGESIZEFACTOR POSTSCRIPT.IMAGESIZEFACTOR)))
         (printout FP "/imagesizefactor " IMAGESIZEFACTOR " def" T)
         (printout FP "%%%%EndSetup" T)
         (replace POSTSCRIPTSCALE of IMAGEDATA with \PS.SCALE0)
         (replace (STREAM OUTCHARFN) of FP with '\POSTSCRIPT.OUTCHARFN)
         (replace POSTSCRIPTPAGEREGION of IMAGEDATA with (\PS.SCALEREGION
                                                                      (/ (TIMES 72 \PS.SCALE0)
                                                                         IMAGESIZEFACTOR)
                                                                      (CAR PAPER)))
         [replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA
            with (SETQ CLIP (\PS.SCALEREGION (/ (TIMES 72 \PS.SCALE0)
                                                        IMAGESIZEFACTOR)
                                       (CADR PAPER]

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

         (SETQ REG (OR (AND (SETQ REG (LISTGET OPTIONS 'REGION))
                            (INTERSECTREGIONS REG CLIP))
                       CLIP))
         (replace POSTSCRIPTLEFTMARGIN of IMAGEDATA with (fetch LEFT of REG))
         (replace POSTSCRIPTBOTTOMMARGIN of IMAGEDATA with (fetch BOTTOM of
                                                                                         REG))
         (replace POSTSCRIPTTOPMARGIN of IMAGEDATA with (PLUS (fetch BOTTOM
                                                                             of REG)
                                                                          (fetch HEIGHT
                                                                             of REG)
                                                                          -1))
         (replace POSTSCRIPTRIGHTMARGIN of IMAGEDATA with (PLUS (fetch LEFT
                                                                               of REG)
                                                                            (fetch WIDTH
                                                                               of REG)
                                                                            -1))
         (\DSPFONT.PSC FP (FONTCREATE (OR [CAR (MKLIST (LISTGET OPTIONS 'FONTS]
                                              DEFAULTFONT)
                                     NIL NIL NIL FP))
         [if (replace POSTSCRIPTHEADING of IMAGEDATA with (LISTGET OPTIONS
                                                                                 'HEADING))
             then (replace POSTSCRIPTHEADINGFONT of IMAGEDATA
                         with (if (LISTGET OPTIONS 'HEADINGFONT)
                                      then (FONTCREATE (LISTGET OPTIONS 'HEADINGFONT)
                                                      NIL NIL NIL FP)
                                    else (fetch POSTSCRIPTFONT of IMAGEDATA]
         (if (if (EQL (CL:GETF OPTIONS 'ROTATION 'DEFAULT)
                              'DEFAULT)
                     then (if (EQL POSTSCRIPT.PREFER.LANDSCAPE 'ASK)
                                  then (MENU \POSTSCRIPT.ORIENTATION.MENU)
                                else POSTSCRIPT.PREFER.LANDSCAPE)
                   else (CL:GETF OPTIONS 'ROTATION))
             then (\DSPROTATE.PSC FP 90))
         (POSTSCRIPT.STARTPAGE FP)
         FP])

(POSTSCRIPT.BITMAPSCALE
  [LAMBDA (WIDTH HEIGHT)                          (* ; "Edited 26-Jul-89 19:11 by Matt Heffron")
    (LET* ([PAGEREGION (\PS.SCALEREGION (/ 72 POSTSCRIPT.BITMAP.SCALE)
                              (CADDR (FASSOC POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS]
           (LONGEDGE (MAX (fetch WIDTH of PAGEREGION)
                          (fetch HEIGHT of PAGEREGION)))
           (SHORTEDGE (MIN (fetch WIDTH of PAGEREGION)
                           (fetch 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 12-Jan-88 12:33 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (if (fetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA)
             then (POSTSCRIPT.OUTSTR STREAM ") ")
                   (replace POSTSCRIPTCHARSTOSHOW of IMAGEDATA with NIL)
                   T
           else NIL])

(POSTSCRIPT.ENDPAGE
  [LAMBDA (STREAM)                                (* ; "Edited 30-Mar-90 17:20 by Matt Heffron")
    (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)))
         (POSTSCRIPT.SHOWACCUM STREAM)
         (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with NIL)
         (if (NOT (PROG1 (fetch POSTSCRIPTPAGEBLANK of IMAGEDATA)
                             (POSTSCRIPT.PUTCOMMAND STREAM "grestore savepage restore ")))
             then (POSTSCRIPT.PUTCOMMAND STREAM "showpage" :EOL])

(POSTSCRIPT.FONTCREATE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)             (* ; "Edited 13-Jul-90 01:41 by jds")
    (LET (UNITFONT FULLNAME SCALEFONTP PSCFD ASCENT DESCENT FIXPWIDTHS CHARSETINFO0 CHARSETINFO357 
                WIDTHS357 WIDTHSBLOCK FD FACECHANGED (WEIGHT (CAR FACE))
                (SLOPE (CADR FACE))
                (EXPANSION (CADDR FACE)))

         (* ;; 
  "Ignore rotations, it is **MUCH** easier to rotate the Postscript stream user space coordinates.")

         [COND
            [(EQ SIZE 1)

             (* ;; "Since a 1 point font is rediculously small, and it is the standard size for Postscript font info, a 1 point font is presumed to be the unit size Postscript font info")

             (COND
                ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE))
                 (SETQ FACECHANGED NIL))
                ((AND (NEQ EXPANSION 'REGULAR)
                      (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT SLOPE
                                                                              'REGULAR)
                                            ROTATION DEVICE)))
                 (SETQ FACECHANGED T))
                ((AND (EQ SLOPE 'ITALIC)
                      (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR 
                                                                              EXPANSION)
                                            ROTATION DEVICE)))
                 (SETQ FACECHANGED T))
                ((AND (NEQ EXPANSION 'REGULAR)
                      (EQ SLOPE 'ITALIC)
                      (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR
                                                                              'REGULAR)
                                            ROTATION DEVICE)))
                 (SETQ FACECHANGED T))
                ((AND (NEQ WEIGHT 'MEDIUM)
                      (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE EXPANSION
                                                                              )
                                            ROTATION DEVICE)))
                 (SETQ FACECHANGED T))
                ((AND (NEQ WEIGHT 'MEDIUM)
                      (NEQ EXPANSION 'REGULAR)
                      (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE
                                                                              'REGULAR)
                                            ROTATION DEVICE)))
                 (SETQ FACECHANGED T))
                ((AND (NEQ WEIGHT 'MEDIUM)
                      (EQ SLOPE 'ITALIC)
                      (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR 
                                                                              EXPANSION)
                                            ROTATION DEVICE)))
                 (SETQ FACECHANGED T))
                ((AND (NEQ WEIGHT 'MEDIUM)
                      (NEQ EXPANSION 'REGULAR)
                      (EQ SLOPE 'ITALIC)
                      (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR
                                                                              'REGULAR)
                                            ROTATION DEVICE)))
                 (SETQ FACECHANGED T)))
             (COND
                (FULLNAME (SETQ PSCFD (PSCFONT.READFONT FULLNAME))
                       (SETQ ASCENT (FIXR (TIMES (fetch (PSCFONT ASCENT) of PSCFD)
                                                 0.1)))
                       (SETQ DESCENT (FIXR (TIMES (fetch (PSCFONT DESCENT) of PSCFD)
                                                  0.1)))
                       (COND
                          (FACECHANGED (replace (PSCFONT IL-FONTID) of PSCFD
                                          with (POSTSCRIPT.GETFONTID (fetch (PSCFONT
                                                                                         FID)
                                                                                of PSCFD)
                                                          WEIGHT SLOPE EXPANSION]
            ((SETQ UNITFONT (FONTCREATE FAMILY 1 FACE ROTATION DEVICE T))
             (SETQ PSCFD (LISTGET (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of UNITFONT)
                                'PSCFONT))

             (* ;; "Scale the ASCENT and DESCENT")

             (SETQ ASCENT (FIXR (TIMES SIZE (fetch (PSCFONT ASCENT) of PSCFD)
                                       0.1)))
             (SETQ DESCENT (FIXR (TIMES SIZE (fetch (PSCFONT DESCENT) of PSCFD)
                                        0.1)))
             (SETQ SCALEFONTP T))
            (T 
               (* ;; "Here for fonts that only come in specific sizes.  Their info is not scaled like built-in Postscript fonts, it is already correct for this pointsize.")

               (COND
                  ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE))
                   (SETQ PSCFD (PSCFONT.READFONT FULLNAME))
                   (SETQ ASCENT (fetch (PSCFONT ASCENT) of PSCFD))
                   (SETQ DESCENT (fetch (PSCFONT DESCENT) of PSCFD))
                   (SETQ SCALEFONTP NIL]
         (COND
            (PSCFD (SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of PSCFD))
                   (SETQ CHARSETINFO0 (create CHARSETINFO))
                   (SETQ CHARSETINFO357 (create CHARSETINFO))
                   (SETQ WIDTHSBLOCK (fetch (CHARSETINFO WIDTHS) of CHARSETINFO0))
                   (SETQ FD
                    (create FONTDESCRIPTOR
                           OTHERDEVICEFONTPROPS _ (LIST 'PSCFONT PSCFD)
                           FONTSCALE _ 100
                           FONTDEVICE _ DEVICE
                           FONTFAMILY _ FAMILY
                           FONTSIZE _ SIZE
                           FONTFACE _ FACE
                           ROTATION _ 0
                           \SFHeight _ (IPLUS ASCENT DESCENT)
                           \SFAscent _ ASCENT
                           \SFDescent _ DESCENT))
                   (replace (CHARSETINFO IMAGEWIDTHS) of CHARSETINFO0 with WIDTHSBLOCK)
                   (replace (CHARSETINFO CHARSETASCENT) of CHARSETINFO0 with ASCENT)
                   (replace (CHARSETINFO CHARSETDESCENT) of CHARSETINFO0 with DESCENT)
                   (replace (CHARSETINFO IMAGEWIDTHS) of CHARSETINFO357
                      with (SETQ WIDTHS357 (fetch (CHARSETINFO WIDTHS) of CHARSETINFO357)
                                ))
                   (replace (CHARSETINFO CHARSETASCENT) of CHARSETINFO357 with ASCENT)
                   (replace (CHARSETINFO CHARSETDESCENT) of CHARSETINFO357 with DESCENT)
                   [COND
                      [SCALEFONTP (for CH from 0 to 255
                                     do (\FSETWIDTH WIDTHSBLOCK CH (FIXR (TIMES SIZE
                                                                                    (ELT FIXPWIDTHS 
                                                                                         CH)
                                                                                    0.1]
                      (T (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH
                                                                         (ELT FIXPWIDTHS CH]
                   [LET [(TMP (COND
                                 (FULLNAME (\FONTINFOFROMFILENAME FULLNAME DEVICE))
                                 (UNITFONT (fetch FONTDEVICESPEC of UNITFONT]

                        (* ;; "If face got coerced (possibly in recursive call for unit font) then set FONTDEVICESPEC to describe what we really got")

                        (COND
                           ((AND TMP (NEQ FAMILY (CAR TMP)))
                            (replace FONTDEVICESPEC of FD with (LIST (CAR TMP)
                                                                                 SIZE
                                                                                 (COPY FACE)
                                                                                 0 DEVICE]

                   (* ;; "Fill in character widths for known NS characters with PSC equivalents in CS0:  Bullet, M-dash, N-dash, dagger, and double-dagger, respectiely.")

                   (for NSCHAR in '(36 37 48 49 102) as PSCCHAR
                      in '(183 208 177 178 179) do (\FSETWIDTH WIDTHS357 NSCHAR
                                                                  (ELT FIXPWIDTHS PSCCHAR)))
                   [LET* [(SYMBOLFILE (PSCFONT.SPELLFILE 'SYMBOL 1 '(MEDIUM REGULAR REGULAR)
                                             ROTATION DEVICE))
                          (SYMBOLPS (AND SYMBOLFILE (PSCFONT.READFONT SYMBOLFILE)))
                          (SYMWIDTHS (AND SYMBOLPS (SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS)
                                                                       of SYMBOLPS]
                         (AND SYMWIDTHS (for NSCHAR in '(210 211 212) as SYMCHAR
                                           in '(226 227 228)
                                           do (\FSETWIDTH WIDTHSBLOCK NSCHAR
                                                         (FIXR (TIMES SIZE (ELT SYMWIDTHS SYMCHAR)
                                                                      0.1]
                   (\SETCHARSETINFO (fetch FONTCHARSETVECTOR of FD)
                          0 CHARSETINFO0)
                   (\SETCHARSETINFO (fetch FONTCHARSETVECTOR of FD)
                          239 CHARSETINFO357)
                   FD)
            (T NIL])

(POSTSCRIPT.FONTSAVAILABLE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)      (* ; "Edited 12-Jan-88 13:04 by Matt Heffron")

    (* ;; "the filtering code was borrowed from Richard Burton's \SEARCHINTERPRESSFONTS.  Note that without it [HELVETICA * (MEDIUM REGULAR REGULAR)]  would pick up [HELVETICA-NARROW * (MEDIUM REGULAR REGULAR)] as well.")

    (LET
     ((PATTERN (\FONTFILENAME (OR (CDR (ASSOC FAMILY POSTSCRIPT.FONT.ALIST))
                                  FAMILY)
                      SIZE FACE 'PSCFONT))
      [INVERSE.ALIST (for PAIR in POSTSCRIPT.FONT.ALIST collect (CONS (CDR PAIR)
                                                                                  (CAR PAIR]
      FONTSAVAILABLE)
     (SETQ FONTSAVAILABLE
      (for FD in [for DIRECTORY in POSTSCRIPTFONTDIRECTORIES
                            join (for FILE in (DIRECTORY (CONCAT DIRECTORY PATTERN))
                                        collect (LET* ((RAWFD (\FONTINFOFROMFILENAME FILE DEVICE)
                                                                  )
                                                           (RAWNAME (CAR RAWFD)))
                                                          (RPLACA RAWFD
                                                                 (OR (CDR (ASSOC RAWNAME 
                                                                                 INVERSE.ALIST))
                                                                     RAWNAME]
         when (AND (OR (EQ FAMILY '*)
                           (EQ FAMILY (CAR FD)))
                       (OR (EQ SIZE '*)
                           (EQ SIZE (CADR FD))
                           (EQ (CADR FD)
                               1))
                       (OR (EQ FACE '*)
                           (EQUAL FACE (CADDR FD))
                           (EQUAL [CDR (ASSOC FACE '((MRR MEDIUM REGULAR REGULAR)
                                                     (STANDARD MEDIUM REGULAR REGULAR)
                                                     (MIR MEDIUM ITALIC REGULAR)
                                                     (ITALIC MEDIUM ITALIC REGULAR)
                                                     (BRR BOLD REGULAR REGULAR)
                                                     (BOLD BOLD REGULAR REGULAR)
                                                     (BIR BOLD ITALIC REGULAR)
                                                     (BOLDITALIC BOLD ITALIC REGULAR]
                                  (CADDR FD)))
                       (NOT (MEMBER FD $$VAL))) collect FD))
     (if (EQ SIZE '*)
         then

(* ;;; "If SIZE was wildcarded, then provide list of pointsizes for Postscript scaled fonts (those with a 1 point descriptor file)")

         (for FD in FONTSAVAILABLE
            join (if (EQ 1 (CADR FD))
                         then (CONS FD (for NF
                                              in (for S from 2 to 
                                                                        \POSTSCRIPT.MAX.WILD.FONTSIZE
                                                        collect (LET ((NFD (COPY FD)))
                                                                         (RPLACA (CDR NFD)
                                                                                S)
                                                                         NFD))
                                              unless (MEMBER NF FONTSAVAILABLE) collect
                                                                                    NF))
                       else (LIST FD)))
       else FONTSAVAILABLE])

(POSTSCRIPT.GETFONTID
  [LAMBDA (FID WEIGHT SLOPE EXPANSION)            (* ; "Edited 12-Jan-88 12:58 by Matt Heffron")
    (LET (FONTID)
         (SETQ FONTID (create FONTID
                             FONTIDNAME _ (CAR FID)
                             FONTXFACTOR _ 1.0
                             FONTOBLIQUEFACTOR _ 0.0))
         [if (AND (NEQ (CADDR FID)
                           SLOPE)
                      (EQ SLOPE 'ITALIC))
             then (replace FONTOBLIQUEFACTOR of FONTID with (CONSTANT (TAN 7.0]
         (if (AND (NEQ (CADR FID)
                           WEIGHT)
                      (EQ WEIGHT 'BOLD))
             then                                        (* ; "Fake bold by slight expansion.")
                   (replace FONTXFACTOR of FONTID with 1.1))
         [if (NEQ EXPANSION 'REGULAR)
             then (replace FONTXFACTOR of FONTID
                         with (TIMES (fetch FONTXFACTOR of FONTID)
                                         (if (EQ EXPANSION 'COMPRESSED)
                                             then (CONSTANT (QUOTIENT 1.0 GOLDEN.RATIO))
                                           else GOLDEN.RATIO]
         FONTID])

(POSTSCRIPT.HARDCOPYW
  [LAMBDA (FILE BITMAP SCALEFACTOR REGION Landscape? TITLE)
                                                      (* ; "Edited 30-Mar-90 17:07 by Matt Heffron")
    (ALLOW.BUTTON.EVENTS)
    (LET* ((STREAM (OPENPOSTSCRIPTSTREAM FILE (LIST 'DOCUMENT.NAME TITLE 'ROTATION Landscape?
                                                        'IMAGESIZEFACTOR SCALEFACTOR)))
           (IMAGEDATA (fetch IMAGEDATA of STREAM))
           (SCLIP (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA))
           SCALE)
          [if REGION
              then (SETQ REGION (COPY REGION))           (* ; "In case we need to change it.")
                    [if (< (fetch BITMAPWIDTH of BITMAP)
                               (+ (fetch (REGION LEFT) of REGION)
                                  (fetch (REGION WIDTH) of REGION)))
                        then (replace (REGION WIDTH) of REGION
                                    with (- (fetch BITMAPWIDTH of BITMAP)
                                                (fetch (REGION LEFT) of REGION]
                    [if (< (fetch BITMAPHEIGHT of BITMAP)
                               (+ (fetch (REGION BOTTOM) of REGION)
                                  (fetch (REGION HEIGHT) of REGION)))
                        then (replace (REGION HEIGHT) of REGION
                                    with (- (fetch BITMAPHEIGHT of BITMAP)
                                                (fetch (REGION BOTTOM) of REGION]
            else (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 POSTSCRIPTSCALE of IMAGEDATA)))
          (BITBLT BITMAP (fetch (REGION LEFT) of REGION)
                 (fetch (REGION BOTTOM) of REGION)
                 STREAM
                 (PLUS (fetch LEFT of SCLIP)
                       (QUOTIENT (DIFFERENCE (fetch WIDTH of SCLIP)
                                        (TIMES SCALE (fetch WIDTH of REGION)))
                              2))
                 (PLUS (fetch BOTTOM of SCLIP)
                       (QUOTIENT (DIFFERENCE (fetch HEIGHT of SCLIP)
                                        (TIMES SCALE (fetch HEIGHT of REGION)))
                              2))
                 (fetch WIDTH of REGION)
                 (fetch HEIGHT of REGION)
                 'INPUT
                 'REPLACE)
          (CLOSEF STREAM)
          (FULLNAME STREAM])

(POSTSCRIPT.INIT
  [LAMBDA NIL                                            (* ; "Edited  7-Apr-89 15:36 by TAL")
    (DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE))
    [MAPC
     [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]
     (FUNCTION (LAMBDA (CLASS)
                 (LET
                  (COPYFD OLDPSCFD)
                  (if (BOUNDP CLASS)
                      then
                      (SETQ CLASS (EVALV CLASS))
                      (if (TYPEP CLASS 'FONTCLASS)
                          then (SETQ COPYFD (OR (fetch (FONTCLASS PRESSFD) of CLASS)
                                                    (fetch (FONTCLASS INTERPRESSFD) of CLASS)
                                                    (fetch (FONTCLASS DISPLAYFD) of CLASS)))
                                (if (SETQ OLDPSCFD (ASSOC 'POSTSCRIPT (fetch (FONTCLASS
                                                                                      OTHERFDS)
                                                                             of CLASS)))
                                    then [if (NOT (CDR OLDPSCFD))
                                                 then (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]
    (SETQ \POSTSCRIPT.CHARTYPE (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT T))

    (* ;; "\POSTSCRIPT.OUTCHARFN uses this array to quickly determine whether a character needs any special processing -- T means yes")

    (for x from (CHARCODE SP) to 126 unless (FMEMB x (CHARCODE (%( %) \)))
       do (CL:SETF (CL:AREF \POSTSCRIPT.CHARTYPE x)
                     NIL))
    (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)
                                     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])

(POSTSCRIPT.OUTSTR
  [LAMBDA (STREAM X)                              (* ; "Edited 14-Jul-89 14:05 by Matt Heffron")
    (DECLARE (LOCALVARS . T))
    (if (FIXP X)
        then                                             (* ; "Common case, speed helps")
              (\PS.BOUTFIXP STREAM X)
      elseif (STRINGP X)
        then                                             (* ; "Other common case")
              (if (ffetch (STRINGP FATSTRINGP) of X)
                  then (for c infatstring X do (BOUT STREAM (\CHAR8CODE c)))
                else (\BOUTS STREAM (ffetch (STRINGP BASE) of X)
                                (ffetch (STRINGP OFFST) of X)
                                (ffetch (STRINGP LENGTH) of X)))
      elseif (LITATOM X)
        then (for c inatom X do (BOUT STREAM (\CHAR8CODE c)))
      elseif (ZEROP X)
        then (BOUT STREAM (CHARCODE 0))
      else (if (TYPEP X 'RATIO)
                   then (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 30-Mar-90 20:15 by Matt Heffron")
    (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)))
     (if DELIMFLG
         then (LET ((POS 0)
                        BYTE)
                       (\FILEOUTCHARFN STREAM (CHARCODE SPACE))
                       (\FILEOUTCHARFN STREAM (CHARCODE <))
                       (\FILEOUTCHARFN STREAM (CHARCODE EOL))
                       (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 (if (IGEQ POS 254)
                                               then (\FILEOUTCHARFN STREAM (CHARCODE EOL))
                                                     (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)))
                                (\FILEOUTCHARFN STREAM (CHARCODE EOL))
                                (SETQ POS 0))
                       (\FILEOUTCHARFN STREAM (CHARCODE SPACE))
                       (\FILEOUTCHARFN STREAM (CHARCODE >))
                       (\FILEOUTCHARFN STREAM (CHARCODE EOL)))
       else
       (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))
               (if (IGEQ REPC 3)
                   then (SETQ B (IPLUS B REPC))
                         (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC))
                         (SETQ PRVO (IPLUS PRVO REPC))
                         (while (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1)))
                            do (if (IGEQ POS 251)
                                       then (\FILEOUTCHARFN STREAM (CHARCODE EOL))
                                             (SETQ POS 0))
                                  (BOUT STREAM (CHARCODE B))
                                  (BOUT STREAM (CHARCODE 3))
                                  [if (IGEQ REPC 256)
                                      then (BOUT STREAM (CHARCODE F))
                                            (BOUT STREAM (CHARCODE F))
                                    else [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)))
                 else (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))
                       (if (IGEQ REPC 3)
                           then (SETQ B (IPLUS B REPC))
                                 (SETQ BYTEOFFSET (IPLUS BYTEOFFSET REPC))
                                 (SETQ PRVO (IPLUS PRVO REPC))
                                 (while (CL:PLUSP (SETQ REPC (IDIFFERENCE REPC 1)))
                                    do (if (IGEQ POS 249)
                                               then (\FILEOUTCHARFN STREAM (CHARCODE EOL))
                                                     (SETQ POS 0))
                                          (BOUT STREAM (CHARCODE B))
                                          (BOUT STREAM (CHARCODE 2))
                                          [if (IGEQ REPC 256)
                                              then (BOUT STREAM (CHARCODE F))
                                                    (BOUT STREAM (CHARCODE F))
                                            else [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)))
                         else (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET))
                               (if (IGEQ POS 251)
                                   then (\FILEOUTCHARFN STREAM (CHARCODE EOL))
                                         (SETQ POS 0))
                               (if (FMEMB BYTE '(178 179 180))
                                   then 

                                         (* ;; "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]
            (\FILEOUTCHARFN STREAM (CHARCODE EOL)))
           (\MOVEBYTES BMBASE ROWOFFSET PRVBASE 0 BYTESPERROW])

(POSTSCRIPT.PUTCOMMAND
  [LAMBDA S.STRS                                  (* ; "Edited 30-Mar-90 17:37 by Matt Heffron")
    (LET* ((STREAM (ARG S.STRS 1))
           (IMAGEDATA (fetch IMAGEDATA of STREAM))
           S#S)
          (freplace POSTSCRIPTPAGEBLANK of IMAGEDATA with NIL)
          (if (ffetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA)
              then (POSTSCRIPT.SHOWACCUM STREAM))
          (if (ffetch POSTSCRIPTPENDINGXFORM of IMAGEDATA)
              then (\SETXFORM.PSC STREAM IMAGEDATA))
          (for STR# from 2 to S.STRS do (if (EQ (SETQ S#S (ARG S.STRS STR#))
                                                                    :EOL)
                                                            then (\FILEOUTCHARFN STREAM
                                                                            (CHARCODE EOL))
                                                          else (POSTSCRIPT.OUTSTR STREAM S#S])

(POSTSCRIPT.SHOWACCUM
  [LAMBDA (STREAM)                                (* ; "Edited 30-Mar-90 17:38 by Matt Heffron")
    (LET ((IMAGEDATA (ffetch IMAGEDATA of STREAM)))
         (if (fetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA)
             then [if (EQP (ffetch POSTSCRIPTSPACEFACTOR of IMAGEDATA)
                                   1)
                          then (POSTSCRIPT.OUTSTR STREAM ") S")
                        else (POSTSCRIPT.OUTSTR STREAM ") ")
                              [POSTSCRIPT.OUTSTR STREAM (DIFFERENCE (ffetch 
                                                                               POSTSCRIPTSPACEWIDTH
                                                                           of IMAGEDATA)
                                                                   (\FGETWIDTH (ffetch 
                                                                                     POSTSCRIPTWIDTHS
                                                                                  of IMAGEDATA)
                                                                          (CHARCODE SPACE]
                              (POSTSCRIPT.OUTSTR STREAM (CONSTANT (CONCAT " 0 " (CHARCODE SPACE)
                                                                             " 4 -1 roll widthshow"]
                   (\FILEOUTCHARFN STREAM (CHARCODE EOL))
                   (freplace POSTSCRIPTCHARSTOSHOW of IMAGEDATA with NIL])

(POSTSCRIPT.STARTPAGE
  [LAMBDA (STREAM)                                (* ; "Edited 30-Mar-90 17:41 by Matt Heffron")
    (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)))
         (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with NIL)
                                                             (* ; "shouldnt need this")
         (POSTSCRIPT.PUTCOMMAND STREAM :EOL "%%%%BeginPageSetup" :EOL "/savepage save def" :EOL
                (FQUOTIENT 1 \PS.SCALE0)
                " imagesizefactor mul dup scale" :EOL "%%%%EndPageSetup" :EOL "%%%%Page" :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 POSTSCRIPTFONTCHANGEDFLG of IMAGEDATA with T)
         (replace POSTSCRIPTPAGEBLANK of IMAGEDATA with T)
         (if (fetch POSTSCRIPTHEADING of IMAGEDATA)
             then 

                   (* ;; "Here we handle headings.  This imitates the INTERPRESS code.")

                   (LET [(FONT (\DSPFONT.PSC STREAM (fetch POSTSCRIPTHEADINGFONT of
                                                                                         IMAGEDATA]
                        (\DSPRESET.PSC STREAM)
                        (PRIN3 (fetch POSTSCRIPTHEADING of IMAGEDATA)
                               STREAM)
                        (RELMOVETO (CONSTANT (TIMES 72 \PS.SCALE0))
                               0 STREAM)                     (* ; "Skip an inch before page number")
                        (PRIN3 "Page " STREAM)
                        (PRIN3 (CL:INCF (fetch POSTSCRIPTPAGENUM of IMAGEDATA))
                               STREAM)
                        (\TERPRI.PSC STREAM)             (* ; "Skip 2 lines")
                        (\TERPRI.PSC STREAM)
                        (\DSPFONT.PSC STREAM FONT))
           else (\DSPRESET.PSC STREAM])

(POSTSCRIPT.TEDIT
  [LAMBDA (FILE PFILE)                                 (* ; "Edited 15-Feb-91 16:34 by gadener")
    [SETQ FILE (OPENTEXTSTREAM (OR (STREAMP FILE)
                                   (MKATOM FILE]
    (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL NIL 'POSTSCRIPT)
    (CLOSEF? FILE)
    PFILE])

(POSTSCRIPT.TEXT
  [LAMBDA (FILE PSCFILE FONTS HEADING TABS)              (* ; "Edited 23-Apr-89 11:31 by TAL")
    (TEXTTOIMAGEFILE FILE PSCFILE 'POSTSCRIPT FONTS HEADING TABS
           `(REGION ,POSTSCRIPT.DEFAULT.PAGEREGION ROTATION ,(NOT (NOT POSTSCRIPT.TEXTFILE.LANDSCAPE])

(POSTSCRIPTFILEP
  [LAMBDA (FILE)                                         (* ; "Edited 27-Aug-90 23:59 by jds")
    (OR (CL:MEMBER (UNPACKFILENAME.STRING FILE 'EXTENSION)
               '("PS" "PSC")
               :TEST
               (FUNCTION STRING-EQUAL))
        (PROGN (SETFILEPTR FILE 0)
               (AND (EQ (BIN FILE)
                        (CHARCODE %%))
                    (EQ (BIN FILE)
                        (CHARCODE !])

(PSCFONT.READFONT
  [LAMBDA (FONTFILENAME)                                 (* ; "Edited  1-Sep-89 10:55 by jds")

    (* ;; "Read one of Matt Heffron's .PSC files, to get postscript font metrics.")

    (LET ((PF (create PSCFONT))
          [S (OPENSTREAM FONTFILENAME 'INPUT NIL '((SEQUENTIAL T]
          FID W)
         [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)))
         PF])

(PSCFONT.SPELLFILE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)             (* ; "Edited  3-Apr-89 13:30 by TAL")
    (FINDFILE (\FONTFILENAME (OR (CDR (FASSOC FAMILY POSTSCRIPT.FONT.ALIST))
                                 FAMILY)
                     SIZE FACE '.PSCFONT)
           NIL POSTSCRIPTFONTDIRECTORIES])

(PSCFONT.WRITEFONT
  [LAMBDA (FONTFILENAME PF)                       (* ; "Edited 15-Oct-87 11:12 by Matt Heffron")
    (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])

(READ-AFM-FILE
  [LAMBDA (FILE)                                  (* ; "Edited 20-Jan-88 17:22 by Matt Heffron")
    (LET ((IFILE (OPENSTREAM FILE 'INPUT))
          (PSCFONT (create PSCFONT))
          (FCHAR 1000)
          (LCHAR 0)
          (W (ARRAY 256 'SMALLPOSP 0 0))
          TOKEN WEIGHT SLOPE CMCOUNT FBBOX)
         (with PSCFONT PSCFONT (repeatuntil (STRING-EQUAL "FontName" (RSTRING IFILE))
                                      do (READCCODE IFILE))
                (repeatwhile (STRING-EQUAL "" (SETQ TOKEN (RSTRING IFILE)))
                   do (READCCODE IFILE))
                [if (NOT (AND (BOUNDP 'WeightMenu)
                                  (type? MENU WeightMenu)))
                    then (SETQ WeightMenu (create MENU
                                                     ITEMS _ WeightMenuItems
                                                     MENUFONT _ (FONTCREATE 'HELVETICA 12]
                [if (NOT (AND (BOUNDP 'SlopeMenu)
                                  (type? MENU SlopeMenu)))
                    then (SETQ SlopeMenu (create MENU
                                                    ITEMS _ SlopeMenuItems
                                                    MENUFONT _ (FONTCREATE 'HELVETICA 12]
                (printout T T "Font WEIGHT for " PSCFONT ": " (SETQ WEIGHT (MENU WeightMenu))
                       T)
                (printout T T "Font SLOPE for " PSCFONT ": " (SETQ SLOPE (MENU SlopeMenu))
                       T)
                (SETQ FID (LIST TOKEN WEIGHT SLOPE 'REGULAR))
                [SETQ IL-FONTID (if (AND (EQ SLOPE 'REGULAR)
                                             (EQ WEIGHT 'MEDIUM))
                                    then TOKEN
                                  else (POSTSCRIPT.GETFONTID FID WEIGHT SLOPE 'REGULAR]
                (repeatuntil (STRING-EQUAL "StartCharMetrics" TOKEN)
                   do (SETQ TOKEN (RSTRING IFILE))
                         (if (STRING-EQUAL "FontBBox" TOKEN)
                             then (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.")

                                   (SETQ DESCENT (IABS (CADR FBBOX)))
                                   (SETQ ASCENT (CADDDR FBBOX))
                           else (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))
                               (if (CL:PLUSP CCODE)
                                   then (if (ILESSP CCODE FCHAR)
                                                then (SETQ FCHAR CCODE))
                                         (if (IGREATERP CCODE LCHAR)
                                             then (SETQ LCHAR CCODE))
                                         (RATOMS 'WX IFILE)
                                         (SETA W CCODE (READ IFILE)))
                               (repeatuntil (EQ (CHARCODE EOL)
                                                    (READCCODE IFILE)) do)))
                (SETQ FIRSTCHAR FCHAR)
                (SETQ LASTCHAR LCHAR))
         (CLOSEF IFILE)
         PSCFONT])

(\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 30-Mar-90 17:44 by Matt Heffron")

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

    (LET ((RGN (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT))
          (IMAGEDATA (fetch IMAGEDATA of STREAM))
          TEXTUREBM TEXTUREWIDTH LEFT BOTTOM WIDTH HEIGHT)
         [if CLIPPINGREGION
             then (SETQ RGN (INTERSECTREGIONS RGN CLIPPINGREGION (fetch 
                                                                            POSTSCRIPTCLIPPINGREGION
                                                                        of IMAGEDATA)))
           else (SETQ RGN (INTERSECTREGIONS RGN (fetch POSTSCRIPTCLIPPINGREGION of 
                                                                                            IMAGEDATA
                                                           ]
         (if RGN
             then (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)))
                   (if (FIXP TEXTURE)
                       then (SETQ TEXTURE (SELECT TEXTURE ((BLACKSHADE -1)
                                                               0.0)
                                                     (WHITESHADE 1.0)
                                                     TEXTURE)))
                   (if (AND (FLOATP TEXTURE)
                                (<= 0.0 TEXTURE 1.0))
                       then (POSTSCRIPT.PUTCOMMAND STREAM HEIGHT " " WIDTH " " LEFT " " 
                                       BOTTOM " " TEXTURE " R" :EOL)
                     elseif (OR (TEXTUREP TEXTURE)
                                    (NULL TEXTURE))
                       then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1))
                             (SETQ TEXTUREWIDTH 16)
                             (BLTSHADE TEXTURE TEXTUREBM)
                     elseif (BITMAPP TEXTURE)
                       then (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))
                   (if TEXTUREBM
                       then (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
           else NIL])

(\CHARWIDTH.PSC
  [LAMBDA (STREAM CHARCODE)                       (* ; "Edited 14-Jul-89 14:37 by Matt Heffron")

    (* ;; "no NS character set treatment yet")

    (LET ((IMAGEDATA (ffetch IMAGEDATA of STREAM)))
         (if (EQ CHARCODE (CHARCODE SPACE))
             then (fetch POSTSCRIPTSPACEWIDTH of IMAGEDATA)
           else (\FGETWIDTH (fetch POSTSCRIPTWIDTHS of IMAGEDATA)
                           (\CHAR8CODE CHARCODE])

(\DRAWARC.PSC
  [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING)
                                                      (* ; "Edited 30-Mar-90 17:46 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))
          WIDTH COLOR)
         (if (NUMBERP BRUSH)
             then (SETQ WIDTH BRUSH)
           elseif (LISTP BRUSH)
             then (if (NEQ (fetch BRUSHSHAPE of BRUSH)
                                   'ROUND)
                          then (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))
           else                                          (* ; 
                                                           "If FUNCTIONAL BRUSH big trouble!")
                 (printout T T 
                     "[In \DRAWARC.PSC: Functional BRUSH not supported.]
[Using ROUND 1 point BRUSH]" T)
                 (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA)))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 
                                                             (* ; 
                                               "COLOR is specified in POSTSCRIPT setgray notation.")
                          )
                   (if (LISTP DASHING)
                       then (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 30-Mar-90 17:48 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))
          WIDTH COLOR)
         (if (NUMBERP BRUSH)
             then (SETQ WIDTH BRUSH)
           elseif (LISTP BRUSH)
             then (if (NEQ (fetch BRUSHSHAPE of BRUSH)
                                   'ROUND)
                          then (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))
           else                                          (* ; 
                                                           "If FUNCTIONAL BRUSH big trouble!")
                 (printout T T 
                      "[In \DRAWCIRCLE.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
                 (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA)))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 
                                                             (* ; 
                                               "COLOR is specified in POSTSCRIPT setgray notation.")
                          )
                   (if (LISTP DASHING)
                       then (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 30-Mar-90 20:12 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))
          WIDTH SHAPE COLOR PSPLINE XA YA DXA DYA N PREVX PREVY PREV-DX3 PREV-DY3)
         (if (NUMBERP BRUSH)
             then (SETQ WIDTH BRUSH)
                   (SETQ SHAPE 'ROUND)
           elseif (LISTP BRUSH)
             then (SETQ WIDTH (fetch BRUSHSIZE of BRUSH))
                   (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH))
                   (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))
           else 

                 (* ;; "If FUNCTIONAL BRUSH then BIG trouble!")

                 (printout T T 
                       "[In \DRAWCURVE.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
                 (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA))
                 (SETQ SHAPE 'ROUND))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 

                             (* ;; "COLOR is specified in POSTSCRIPT setgray notation.")
)
                   (if (LISTP DASHING)
                       then (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 30-Mar-90 17:51 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))
          WIDTH COLOR)
         (if (NUMBERP BRUSH)
             then (SETQ WIDTH BRUSH)
           elseif (LISTP BRUSH)
             then (if (NEQ (fetch BRUSHSHAPE of BRUSH)
                                   'ROUND)
                          then (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))
           else                                          (* ; 
                                                           "If FUNCTIONAL BRUSH, big trouble!")
                 (printout T T 
                     "[In \DRAWELLIPSE.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
                 (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA)))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 
                                                             (* ; 
                                               "COLOR is specified in POSTSCRIPT setgray notation.")
                          )
                   (if (LISTP DASHING)
                       then (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 30-Mar-90 17:52 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (if (NOT (NUMBERP WIDTH))
             then 

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

                   (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA)))
         (if (NOT (ZEROP WIDTH))
             then (if (NOT (OR (FLOATP COLOR)
                                       (LISTP DASHING)))
                          then                           (* ; "Simple case, no dash or gray")
                                (POSTSCRIPT.PUTCOMMAND STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH 
                                       " L" :EOL)
                        else                             (* ; 
                                                           "COLOR is interpreted as gray factor")
                              (POSTSCRIPT.PUTCOMMAND STREAM X2 " " Y2 " " X1 " " Y1 " " WIDTH " "
                                     (OR (FLOATP COLOR)
                                         "0")
                                     " [")
                              (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 "] L1" :EOL)))
         (replace POSTSCRIPTX of IMAGEDATA with X2)
         (freplace POSTSCRIPTY of IMAGEDATA with Y2)
         (freplace 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 30-Mar-90 17:54 by Matt Heffron")
    (LET ((LASTPOINT (CAR (LAST POINTS)))
          (IMAGEDATA (fetch IMAGEDATA of STREAM))
          WIDTH SHAPE COLOR)
         (if (NUMBERP BRUSH)
             then (SETQ WIDTH BRUSH)
                   (SETQ SHAPE 'ROUND)
           elseif (LISTP BRUSH)
             then (SETQ WIDTH (fetch BRUSHSIZE of BRUSH))
                   (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH))
                   (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))
           else 

                 (* ;; "If FUNCTIONAL BRUSH then BIG trouble!")

                 (printout T T 
                     "[In \DRAWPOLYGON.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
                 (SETQ WIDTH (fetch POSTSCRIPTSCALE of IMAGEDATA))
                 (SETQ SHAPE 'ROUND))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM :EOL "gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 

                             (* ;; "COLOR is specified in POSTSCRIPT setgray notation.")
)
                   (if (LISTP DASHING)
                       then (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 XCOORD of (CAR POINTS))
                          " "
                          (fetch YCOORD of (CAR POINTS))
                          " M" :EOL)
                   (for P in (CDR POINTS) do (POSTSCRIPT.PUTCOMMAND STREAM
                                                                (fetch XCOORD of P)
                                                                " "
                                                                (fetch YCOORD of P)
                                                                " lineto" :EOL))
                   (if CLOSED
                       then (POSTSCRIPT.PUTCOMMAND STREAM " closepath"))
                   (POSTSCRIPT.PUTCOMMAND STREAM " stroke" :EOL "grestore" :EOL))
         (\MOVETO.PSC STREAM (fetch XCOORD of LASTPOINT)
                (fetch YCOORD of LASTPOINT])

(\DSPBOTTOMMARGIN.PSC
  [LAMBDA (STREAM YPOSITION)                      (* ; "Edited 12-Jan-88 13:14 by Matt Heffron")
    (PROG1 (fetch POSTSCRIPTBOTTOMMARGIN of (fetch IMAGEDATA of STREAM))
        (if YPOSITION
            then (replace POSTSCRIPTBOTTOMMARGIN of (fetch IMAGEDATA of STREAM)
                        with YPOSITION)))])

(\DSPCLIPPINGREGION.PSC
  [LAMBDA (STREAM REGION)                         (* ; "Edited 14-Jul-89 14:41 by Matt Heffron")
    (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
           (OLDCLIP (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA)))
          (if [AND REGION (NOT (AND (EQP (fetch LEFT of OLDCLIP)
                                             (fetch LEFT of REGION))
                                        (EQP (fetch BOTTOM of OLDCLIP)
                                             (fetch BOTTOM of REGION))
                                        (EQP (fetch WIDTH of OLDCLIP)
                                             (fetch WIDTH of REGION))
                                        (EQP (fetch HEIGHT of OLDCLIP)
                                             (fetch HEIGHT of REGION]
              then (POSTSCRIPT.SHOWACCUM STREAM)
                    (replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA with REGION)
                    (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with T)
                    (\FIXLINELENGTH.PSC STREAM IMAGEDATA))
          OLDCLIP])

(\DSPFONT.PSC
  [LAMBDA (STREAM FONT)                           (* ; "Edited 14-Jul-89 14:42 by Matt Heffron")
    (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
           (OLDFONT (fetch POSTSCRIPTFONT of IMAGEDATA))
           NEWFONT)
          (if (AND FONT (SETQ NEWFONT (OR (\COERCEFONTDESC FONT STREAM)
                                              (FONTCOPY OLDFONT FONT)))
                       (type? FONTDESCRIPTOR NEWFONT)
                       (NEQ NEWFONT OLDFONT))
              then (POSTSCRIPT.SHOWACCUM STREAM)
                    (replace POSTSCRIPTFONT of IMAGEDATA with NEWFONT)
                    (replace POSTSCRIPTWIDTHS of IMAGEDATA
                       with (fetch (CHARSETINFO WIDTHS) of (\GETBASEPTR (fetch 
                                                                                    FONTCHARSETVECTOR
                                                                                       of NEWFONT
                                                                                           )
                                                                              0)))
                    [replace POSTSCRIPTSPACEWIDTH of IMAGEDATA
                       with (FIXR (TIMES (fetch POSTSCRIPTSPACEFACTOR of IMAGEDATA)
                                             (\FGETWIDTH (fetch POSTSCRIPTWIDTHS of IMAGEDATA
                                                                )
                                                    (CHARCODE SPACE]
                    (replace POSTSCRIPTFONTCHANGEDFLG of IMAGEDATA with T)
                    (\DSPLINEFEED.PSC STREAM (IMINUS (fetch (FONTDESCRIPTOR \SFHeight)
                                                            of NEWFONT)))
                    (\FIXLINELENGTH.PSC STREAM IMAGEDATA))
          OLDFONT])

(\DSPLEFTMARGIN.PSC
  [LAMBDA (STREAM XPOSITION)                             (* ; "Edited  6-Apr-89 14:01 by TAL")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (PROG1 (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA)
             (COND
                (XPOSITION (replace POSTSCRIPTLEFTMARGIN of IMAGEDATA with XPOSITION)
                       (\FIXLINELENGTH.PSC STREAM IMAGEDATA))))])

(\DSPLINEFEED.PSC
  [LAMBDA (STREAM LINELEADING)                    (* ; "Edited 12-Jan-88 13:16 by Matt Heffron")
    (PROG1 (fetch POSTSCRIPTLINESPACING of (fetch IMAGEDATA of STREAM))
        (if LINELEADING
            then (replace POSTSCRIPTLINESPACING of (fetch IMAGEDATA of STREAM)
                        with LINELEADING)))])

(\DSPRESET.PSC
  [LAMBDA (STREAM)                                       (* ; "Edited  6-Apr-89 13:18 by TAL")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (replace (STREAM CHARPOSITION) of STREAM with 0)
         (\MOVETO.PSC STREAM (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA)
                (DIFFERENCE (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA)
                       (FONTPROP (fetch POSTSCRIPTFONT of IMAGEDATA)
                              'ASCENT])

(\DSPRIGHTMARGIN.PSC
  [LAMBDA (STREAM XPOSITION)                      (* ; "Edited 14-Jul-89 14:44 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (PROG1 (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA)
             (if XPOSITION
                 then (replace POSTSCRIPTRIGHTMARGIN of IMAGEDATA with XPOSITION)
                       (\FIXLINELENGTH.PSC STREAM IMAGEDATA)))])

(\DSPROTATE.PSC
  [LAMBDA (STREAM ROTATION)                       (* ; "Edited 27-Jul-89 18:03 by Matt Heffron")

    (* ;; "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))
           (OLAND (COND
                     ((fetch POSTSCRIPTLANDSCAPE of IMAGEDATA)
                      90)
                     (T 0)))
           LAND C0 P0 C P ML MB MR MT)
          (if (AND ROTATION (NEQ (SETQ LAND (NOT (ZEROP ROTATION)))
                                     (fetch POSTSCRIPTLANDSCAPE of IMAGEDATA)))
              then (POSTSCRIPT.SHOWACCUM STREAM)
                    (\DSPTRANSLATE.PSC STREAM 0 0)
                    (SETQ C0 (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA))
                    (SETQ P0 (fetch POSTSCRIPTPAGEREGION of IMAGEDATA))
                    (SETQ C (create REGION
                                   WIDTH _ (fetch HEIGHT of C0)
                                   HEIGHT _ (fetch WIDTH of C0)))
                    (SETQ P (create REGION
                                   LEFT _ 0
                                   BOTTOM _ 0
                                   WIDTH _ (fetch HEIGHT of P0)
                                   HEIGHT _ (fetch WIDTH of P0)))
                    (if LAND
                        then (replace LEFT of C with (fetch BOTTOM of C0))
                              [replace BOTTOM of C with (- (fetch WIDTH of P0)
                                                                       (+ (fetch LEFT
                                                                             of C0)
                                                                          (fetch WIDTH
                                                                             of C0]
                              (SETQ ML (fetch POSTSCRIPTBOTTOMMARGIN of IMAGEDATA))
                              (SETQ MB (- (fetch WIDTH of P0)
                                          (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA)
                                          1))
                              (SETQ MR (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA))
                              (SETQ MT (- (fetch WIDTH of P0)
                                          (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA)
                                          1))
                      else [replace LEFT of C with (- (fetch HEIGHT of P0)
                                                                      (+ (fetch BOTTOM
                                                                            of C0)
                                                                         (fetch HEIGHT
                                                                            of C0]
                            (replace BOTTOM of C with (fetch LEFT of C0))
                            (SETQ ML (- (fetch HEIGHT of P0)
                                        (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA)
                                        1))
                            (SETQ MB (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA))
                            (SETQ MR (- (fetch HEIGHT of P0)
                                        (fetch POSTSCRIPTBOTTOMMARGIN of IMAGEDATA)
                                        1))
                            (SETQ MT (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA)))
                    (replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA with C)
                    (replace POSTSCRIPTPAGEREGION of IMAGEDATA with P)
                    (replace POSTSCRIPTLEFTMARGIN of IMAGEDATA with ML)
                    (replace POSTSCRIPTBOTTOMMARGIN of IMAGEDATA with MB)
                    (replace POSTSCRIPTRIGHTMARGIN of IMAGEDATA with MR)
                    (replace POSTSCRIPTTOPMARGIN of IMAGEDATA with MT)
                    (replace POSTSCRIPTLANDSCAPE of IMAGEDATA with LAND)
                    (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with T)
                    (\DSPRESET.PSC STREAM))
          OLAND])

(\DSPSCALE.PSC
  [LAMBDA (STREAM SCALE)                          (* ; "Edited 30-Mar-90 17:56 by Matt Heffron")
    (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
           (OSCALE (fetch POSTSCRIPTSCALE of IMAGEDATA))
           NSCALE)
          (if (AND NIL 

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

                       (NUMBERP SCALE)
                       (CL:PLUSP SCALE))
              then (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 POSTSCRIPTSCALE of IMAGEDATA with SCALE))
          OSCALE])

(\DSPSPACEFACTOR.PSC
  [LAMBDA (STREAM FACTOR)                         (* ; "Edited 14-Jul-89 14:48 by Matt Heffron")
    (DECLARE (LOCALVARS . T))
    (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
           (OLDFACTOR (fetch POSTSCRIPTSPACEFACTOR of IMAGEDATA)))
          [if (AND (NUMBERP FACTOR)
                       (NOT (EQUAL FACTOR OLDFACTOR)))
              then (POSTSCRIPT.SHOWACCUM STREAM)
                    (replace POSTSCRIPTSPACEFACTOR of IMAGEDATA with FACTOR)
                    (replace POSTSCRIPTSPACEWIDTH of IMAGEDATA
                       with (FIXR (TIMES FACTOR (\FGETWIDTH (fetch POSTSCRIPTWIDTHS
                                                                   of IMAGEDATA)
                                                           (CHARCODE SPACE]
          OLDFACTOR])

(\DSPTOPMARGIN.PSC
  [LAMBDA (STREAM YPOSITION)                      (* ; "Edited 12-Jan-88 13:17 by Matt Heffron")
    (PROG1 (fetch POSTSCRIPTTOPMARGIN of (fetch IMAGEDATA of STREAM))
        (if YPOSITION
            then (replace POSTSCRIPTTOPMARGIN of (fetch IMAGEDATA of STREAM)
                        with YPOSITION)))])

(\DSPTRANSLATE.PSC
  [LAMBDA (STREAM TX TY)                          (* ; "Edited 14-Jul-89 14:58 by Matt Heffron")
    (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
           (MDX (DIFFERENCE (fetch POSTSCRIPTTRANSX of IMAGEDATA)
                       TX))
           (MDY (DIFFERENCE (fetch POSTSCRIPTTRANSY of IMAGEDATA)
                       TY)))
          (if (NOT (AND (ZEROP MDX)
                            (ZEROP MDY)))
              then (POSTSCRIPT.SHOWACCUM STREAM)
                    (for REG in (LIST (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA)
                                              (fetch POSTSCRIPTPAGEREGION of IMAGEDATA))
                       do (CL:INCF (fetch LEFT of REG)
                                     MDX)
                             (CL:INCF (fetch BOTTOM of REG)
                                    MDY))
                    (CL:INCF (fetch POSTSCRIPTX of IMAGEDATA)
                           MDX)
                    (CL:INCF (fetch POSTSCRIPTY of IMAGEDATA)
                           MDY)
                    (CL:INCF (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA)
                           MDX)
                    (CL:INCF (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA)
                           MDX)
                    (CL:INCF (fetch POSTSCRIPTBOTTOMMARGIN of IMAGEDATA)
                           MDY)
                    (CL:INCF (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA)
                           MDY)
                    (replace POSTSCRIPTTRANSX of IMAGEDATA with TX)
                    (replace POSTSCRIPTTRANSY of IMAGEDATA with TY)
                    (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with T])

(\DSPXPOSITION.PSC
  [LAMBDA (STREAM XPOSITION)                      (* ; "Edited  9-Sep-88 10:58 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))
          OLDX)
         (PROG1 (SETQ OLDX (fetch POSTSCRIPTX of IMAGEDATA))
             (if (AND XPOSITION (NOT (EQUAL XPOSITION OLDX)))
                 then (\MOVETO.PSC STREAM XPOSITION (fetch POSTSCRIPTY of IMAGEDATA))
                    ))])

(\DSPYPOSITION.PSC
  [LAMBDA (STREAM YPOSITION)                      (* ; "Edited  9-Sep-88 10:58 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))
          OLDY)
         (PROG1 (SETQ OLDY (fetch POSTSCRIPTY of IMAGEDATA))
             (if (AND YPOSITION (NOT (EQUAL YPOSITION OLDY)))
                 then (\MOVETO.PSC STREAM (fetch POSTSCRIPTX of IMAGEDATA)
                                 YPOSITION)))])

(\FILLCIRCLE.PSC
  [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE) (* ; "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 1.0)        (* ; "The setgray version of white")
                        elseif (OR (EQL TEXTURE 65535)
                                       (EQL TEXTURE -1))
                          then (SETQ TEXTURE 0.0)        (* ; "The setgray version of black")
                             ))
         (if (FLOATP TEXTURE)
             then 

                   (* ;; 
                 "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.")

                   (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ")
           elseif (OR (TEXTUREP TEXTURE)
                          (NULL TEXTURE))
             then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1))
                   (SETQ TEXTUREWIDTH 16)
                   (BLTSHADE TEXTURE TEXTUREBM)
           elseif (BITMAPP TEXTURE)
             then (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))
         (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 " " (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)
           else (POSTSCRIPT.PUTCOMMAND STREAM " eofill" :EOL "grestore" :EOL))
         (\MOVETO.PSC STREAM CENTERX CENTERY])

(\FILLPOLYGON.PSC
  [LAMBDA (STREAM KNOTS TEXTURE OPERATION WINDNUMBER)
                                                      (* ; "Edited 30-Mar-90 18:01 by Matt Heffron")
    (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 1.0)        (* ; "The setgray version of white")
                        elseif (OR (EQL TEXTURE 65535)
                                       (EQL TEXTURE -1))
                          then (SETQ TEXTURE 0.0)        (* ; "The setgray version of black")
                             ))
         (if (FLOATP TEXTURE)
             then 

                   (* ;; 
                 "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.")

                   (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ")
           elseif (OR (TEXTUREP TEXTURE)
                          (NULL TEXTURE))
             then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1))
                   (SETQ TEXTUREWIDTH 16)
                   (BLTSHADE TEXTURE TEXTUREBM)
           elseif (BITMAPP TEXTURE)
             then (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))
         (POSTSCRIPT.PUTCOMMAND STREAM (fetch XCOORD of (CAR KNOTS))
                " "
                (fetch YCOORD of (CAR KNOTS))
                " M" :EOL)
         (for K in (CDR KNOTS) do (POSTSCRIPT.PUTCOMMAND STREAM (fetch XCOORD
                                                                                   of K)
                                                     " "
                                                     (fetch 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 XCOORD of LASTPOINT)
                (fetch YCOORD of LASTPOINT])

(\FIXLINELENGTH.PSC
  [LAMBDA (STREAM IMAGEDATA)                      (* ; "Edited 27-Jul-89 17:59 by Matt Heffron")

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

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

(\MOVETO.PSC
  [LAMBDA (STREAM X Y)                            (* ; "Edited 14-Jul-89 14:49 by Matt Heffron")
    (LET ((IMAGEDATA (ffetch IMAGEDATA of STREAM)))
         (if [NOT (AND (EQP X (fetch POSTSCRIPTX of IMAGEDATA))
                           (EQP Y (ffetch POSTSCRIPTY of IMAGEDATA]
             then (POSTSCRIPT.SHOWACCUM STREAM)
                   (freplace POSTSCRIPTX of IMAGEDATA with X)
                   (freplace POSTSCRIPTY of IMAGEDATA with Y)
                   (freplace POSTSCRIPTMOVEFLG of IMAGEDATA with T])

(\NEWPAGE.PSC
  [LAMBDA (STREAM)                                       (* ; "Edited  5-Apr-89 17:31 by TAL")
    (POSTSCRIPT.ENDPAGE STREAM)
    (POSTSCRIPT.STARTPAGE STREAM])

(\POSTSCRIPTTAB
  [LAMBDA (POSTSCRIPTDATA)                               (* ; "Edited  2-Apr-89 14:22 by TAL")
    (LET [(TABSPACE (TIMES 8 (ffetch FONTAVGCHARWIDTH of (ffetch POSTSCRIPTFONT
                                                                    of POSTSCRIPTDATA]
         (IDIFFERENCE TABSPACE (IREMAINDER (IDIFFERENCE (ffetch POSTSCRIPTX of POSTSCRIPTDATA
                                                               )
                                                  (ffetch POSTSCRIPTLEFTMARGIN of 
                                                                                       POSTSCRIPTDATA
                                                         ))
                                      TABSPACE])

(\PS.BOUTFIXP
  [LAMBDA (STREAM N)                              (* ; "Edited 14-Jul-89 14:11 by Matt Heffron")

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

    (DECLARE (LOCALVARS . T))
    (if (MINUSP N)
        then (BOUT STREAM (CHARCODE -))
              (SETQ N (IMINUS N)))
    (if (LESSP N 10)
        then (BOUT STREAM (IPLUS N (CHARCODE 0)))
      elseif (LESSP N 1000000000)
        then (LET ([BASE (fetch (ARRAYP BASE) of (fetch 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)))
      else                                               (* ; "Just in case we get a bignum")
            (for c in (CHCON N) do (BOUT STREAM (\CHAR8CODE c])

(\PS.SCALEHACK
  [LAMBDA (STREAM SCALEFACTOR)                    (* ; "Edited 14-Jul-89 15:03 by Matt Heffron")
    (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
           (OLDSCALE (fetch POSTSCRIPTSCALEHACK of IMAGEDATA))
           FACTOR)
          (if (AND (NUMBERP SCALEFACTOR)
                       (NOT (EQP OLDSCALE SCALEFACTOR)))
              then (POSTSCRIPT.SHOWACCUM STREAM)
                    (SETQ FACTOR (/ OLDSCALE SCALEFACTOR))
                    [for REG in (LIST (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA)
                                              (fetch POSTSCRIPTPAGEREGION of IMAGEDATA))
                       do (change (fetch LEFT of REG)
                                     (FIXR (CL:* DATUM FACTOR)))
                             (change (fetch BOTTOM of REG)
                                    (FIXR (CL:* DATUM FACTOR)))
                             (change (fetch WIDTH of REG)
                                    (FIXR (CL:* DATUM FACTOR)))
                             (change (fetch HEIGHT of REG)
                                    (FIXR (CL:* DATUM FACTOR]
                    (change (fetch POSTSCRIPTX of IMAGEDATA)
                           (FIXR (CL:* DATUM FACTOR)))
                    (change (fetch POSTSCRIPTY of IMAGEDATA)
                           (FIXR (CL:* DATUM FACTOR)))
                    (change (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA)
                           (FIXR (CL:* DATUM FACTOR)))
                    (change (fetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA)
                           (FIXR (CL:* DATUM FACTOR)))
                    (change (fetch POSTSCRIPTBOTTOMMARGIN of IMAGEDATA)
                           (FIXR (CL:* DATUM FACTOR)))
                    (change (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA)
                           (FIXR (CL:* DATUM FACTOR)))
                    (change (fetch POSTSCRIPTTRANSX of IMAGEDATA)
                           (FIXR (CL:* DATUM FACTOR)))
                    (change (fetch POSTSCRIPTTRANSY of IMAGEDATA)
                           (FIXR (CL:* DATUM FACTOR)))
                    (replace POSTSCRIPTSCALEHACK of IMAGEDATA with SCALEFACTOR)
                    (replace 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 30-Mar-90 19:06 by Matt Heffron")

    (* ;; "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 IMAGEDATA of STREAM))
           (SCALE1 (TIMES SCALE (fetch POSTSCRIPTSCALE of IMAGEDATA)))
           (SCALE2 (TIMES SCALE1 (OR (NUMBERP POSTSCRIPT.BITMAP.SCALE)
                                     1)))
           DESTREGION
           (BITMAPWIDTH (fetch BITMAPWIDTH of SOURCEBITMAP))
           (BITMAPHEIGHT (fetch BITMAPHEIGHT of SOURCEBITMAP))
           TEMPBM)
          (if (NULL DESTINATIONLEFT)
              then (SETQ DESTINATIONLEFT (fetch POSTSCRIPTX of IMAGEDATA)))
          (if (NULL DESTINATIONBOTTOM)
              then (SETQ DESTINATIONBOTTOM (fetch POSTSCRIPTY of IMAGEDATA)))
          (if (OR (NULL WIDTH)
                      (NULL HEIGHT))
              then (SETQ WIDTH BITMAPWIDTH)
                    (SETQ HEIGHT BITMAPHEIGHT)
            elseif (OR (GREATERP WIDTH BITMAPWIDTH)
                           (GREATERP HEIGHT BITMAPHEIGHT))
              then (SETQ WIDTH (FIXR (QUOTIENT WIDTH SCALE1)))
                    (SETQ HEIGHT (FIXR (QUOTIENT HEIGHT SCALE1)))
                    (if (OR (GREATERP WIDTH BITMAPWIDTH)
                                (GREATERP HEIGHT BITMAPHEIGHT))
                        then (SETQ WIDTH BITMAPWIDTH)
                              (SETQ HEIGHT BITMAPHEIGHT)))
          [SETQ DESTREGION (INTERSECTREGIONS (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA)
                                  (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM (TIMES SCALE1 WIDTH
                                                                                         )
                                         (TIMES SCALE1 HEIGHT]
          (if (AND DESTREGION (OR (NULL CLIPPINGREGION)
                                      (REGIONSINTERSECTP DESTREGION CLIPPINGREGION)))
              then (if (AND (EQ SOURCELEFT 0)
                                    (EQ SOURCEBOTTOM 0)
                                    (EQP WIDTH BITMAPWIDTH)
                                    (EQP HEIGHT BITMAPHEIGHT))
                           then                          (* ; 
                                                           "Avoid copy if sending entire bitmap")
                                 (SETQ TEMPBM SOURCEBITMAP)
                         else (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 (if (EQ OPERATION 'PAINT)
                                                          then " true"
                                                        else " false")
                           " thebitimage" :EOL)
                    (POSTSCRIPT.PUTBITMAPBYTES STREAM TEMPBM NIL)
                    (POSTSCRIPT.PUTCOMMAND STREAM :EOL "bitbltsave restore" :EOL)
                    (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM)
                    T
            else NIL])

(\SETPOS.PSC
  [LAMBDA (STREAM IMAGEDATA)                             (* ; "Edited  3-Apr-89 18:09 by TAL")
    (POSTSCRIPT.PUTCOMMAND STREAM (fetch POSTSCRIPTX of IMAGEDATA)
           " "
           (ffetch POSTSCRIPTY of IMAGEDATA)
           " M ")
    (freplace POSTSCRIPTMOVEFLG of IMAGEDATA with NIL])

(\SETXFORM.PSC
  [LAMBDA (STREAM IMAGEDATA NORESTORE)            (* ; "Edited  4-Apr-90 17:22 by Matt Heffron")
    (LET ((CLIP (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA)))
         (replace POSTSCRIPTPENDINGXFORM of IMAGEDATA with NIL)
         (if (NOT NORESTORE)
             then (POSTSCRIPT.OUTSTR STREAM "grestore "))
         (POSTSCRIPT.PUTCOMMAND STREAM "gsave" :EOL)
         (if (NOT (EQP (fetch POSTSCRIPTSCALEHACK of IMAGEDATA)
                           1))
             then (POSTSCRIPT.PUTCOMMAND STREAM (fetch POSTSCRIPTSCALEHACK of 
                                                                                            IMAGEDATA
                                                               )
                             " dup scale" :EOL))
         (if (fetch POSTSCRIPTLANDSCAPE of IMAGEDATA)
             then (POSTSCRIPT.OUTSTR STREAM " 90 rotate "))
         (if [NOT (AND (ZEROP (fetch POSTSCRIPTTRANSX of IMAGEDATA))
                           (ZEROP (fetch POSTSCRIPTTRANSY of IMAGEDATA]
             then (POSTSCRIPT.PUTCOMMAND STREAM (fetch POSTSCRIPTTRANSX of IMAGEDATA)
                             " "
                             (fetch POSTSCRIPTTRANSY of IMAGEDATA)
                             " translate" :EOL))
         (POSTSCRIPT.PUTCOMMAND STREAM (fetch HEIGHT of CLIP)
                " "
                (fetch WIDTH of CLIP)
                " "
                (fetch LEFT of CLIP)
                " "
                (fetch BOTTOM of CLIP)
                " CLP" :EOL)
         (replace POSTSCRIPTMOVEFLG of IMAGEDATA with T)
         (replace POSTSCRIPTFONTCHANGEDFLG of IMAGEDATA with T])

(\STRINGWIDTH.PSC
  [LAMBDA (STREAM STR RDTBL)                             (* ; "Edited  2-Apr-89 18:13 by TAL")
    (LET ((IMAGEDATA (ffetch (STREAM IMAGEDATA) of STREAM)))
         (\STRINGWIDTH.GENERIC STR (fetch POSTSCRIPTFONT of IMAGEDATA)
                RDTBL
                (ffetch POSTSCRIPTSPACEWIDTH of IMAGEDATA])

(\SWITCHFONTS.PSC
  [LAMBDA (STREAM POSTSCRIPTDATA)                 (* ; "Edited 30-Mar-90 18:07 by Matt Heffron")
    (LET* [(FONT (ffetch POSTSCRIPTFONT of POSTSCRIPTDATA))
           (FONTID (fetch (PSCFONT IL-FONTID) of (LISTGET (fetch (FONTDESCRIPTOR 
                                                                                 OTHERDEVICEFONTPROPS
                                                                                    ) of FONT)
                                                                'PSCFONT]
          (if (LISTP FONTID)
              then (POSTSCRIPT.PUTCOMMAND STREAM "/" (fetch FONTIDNAME of FONTID)
                              " findfont ["
                              (TIMES (fetch FONTXFACTOR of FONTID)
                                     (fetch (FONTDESCRIPTOR FONTSIZE) of FONT)
                                     100)
                              " 0 "
                              (TIMES (fetch FONTOBLIQUEFACTOR of FONTID)
                                     (fetch (FONTDESCRIPTOR FONTSIZE) of FONT)
                                     100)
                              " "
                              (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT)
                                     100)
                              " 0 0] makefont setfont" :EOL)
            else (POSTSCRIPT.PUTCOMMAND STREAM (TIMES (fetch (FONTDESCRIPTOR FONTSIZE)
                                                                 of FONT)
                                                              100)
                            " /" FONTID " F" :EOL))
          (replace POSTSCRIPTFONTCHANGEDFLG of POSTSCRIPTDATA with NIL])

(\TERPRI.PSC
  [LAMBDA (STREAM)                                (* ; "Edited 30-Mar-90 18:08 by Matt Heffron")
    (LET* [(IMAGEDATA (fetch IMAGEDATA of STREAM))
           (NEWY (PLUS (ffetch POSTSCRIPTY of IMAGEDATA)
                       (ffetch POSTSCRIPTLINESPACING of IMAGEDATA]
          (if [LESSP NEWY (IPLUS (ffetch POSTSCRIPTBOTTOMMARGIN of IMAGEDATA)
                                     (fetch (FONTDESCRIPTOR \SFDescent)
                                        of (ffetch POSTSCRIPTFONT of IMAGEDATA]
              then (\NEWPAGE.PSC STREAM)
            else (replace (STREAM CHARPOSITION) of STREAM with 0)
                  (\MOVETO.PSC STREAM (ffetch POSTSCRIPTLEFTMARGIN of IMAGEDATA)
                         NEWY))
          NIL])
)
(DEFINEQ

(\POSTSCRIPT.OUTCHARFN
  [LAMBDA (STREAM CHAR)                                  (* ; "Edited 12-Jul-90 12:22 by jds")

(* ;;; "Output a character to be printed.   NS chars are not handled yet.")

(* ;;; "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 efficiancy.")

(* ;;;; "")

(* ;;;; "Need to inc CHARPOSITION of STREAM")

    (DECLARE (GLOBALVARS \POSTSCRIPT.CHARTYPE)
           (LOCALVARS . T))
    (PROG* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
            (XPOS (fetch POSTSCRIPTX of IMAGEDATA))
            (FONT (ffetch POSTSCRIPTFONT of IMAGEDATA))
            [CHARWID (SELCHARQ CHAR
                          (SPACE (ffetch POSTSCRIPTSPACEWIDTH of IMAGEDATA))
                          (\FGETWIDTH (ffetch POSTSCRIPTWIDTHS of IMAGEDATA)
                                 (\CHAR8CODE CHAR]
            NEWXPOS)
           [COND
              ((AND (ILEQ CHAR 254)
                    (NOT (CL:AREF \POSTSCRIPT.CHARTYPE CHAR)))
                                                             (* ; 
                                                           "non-NIL if char is special in any way")
               [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)))
                   (BOUT STREAM (CHARCODE %())
                   (freplace POSTSCRIPTCHARSTOSHOW of IMAGEDATA with T)))
               (BOUT STREAM CHAR)
               (freplace POSTSCRIPTX of IMAGEDATA with NEWXPOS))
              (T                                             (* ; "Special char")
                 (SELCHARQ CHAR
                      ((EOL LF) 
                           (\TERPRI.PSC STREAM))
                      (FF (DSPNEWPAGE STREAM))
                      (TAB (SETQ NEWXPOS (IPLUS XPOS (\POSTSCRIPTTAB IMAGEDATA)))
                           [COND
                              ((IGREATERP NEWXPOS (ffetch POSTSCRIPTRIGHTMARGIN of IMAGEDATA)
                                      )
                               (\TERPRI.PSC STREAM)
                               (SETQ NEWXPOS (IPLUS (ffetch POSTSCRIPTX of IMAGEDATA)
                                                    (\POSTSCRIPTTAB IMAGEDATA]
                           (\MOVETO.PSC STREAM NEWXPOS (ffetch POSTSCRIPTY of IMAGEDATA)))
                      ("357,146"                             (* ; "Bullet")
                                 (\POSTSCRIPT.OUTCHARFN STREAM (CHARCODE "0,267")))
                      ("357,45"                              (* ; "M-Dash")
                                (\POSTSCRIPT.OUTCHARFN STREAM (CHARCODE "0,320")))
                      ("357,44"                              (* ; "N-dash")
                                (\POSTSCRIPT.OUTCHARFN STREAM (CHARCODE "0,261")))
                      ("357,60"                              (* ; "Dagger")
                                (\POSTSCRIPT.OUTCHARFN STREAM (CHARCODE "0,262")))
                      ("357,61"                              (* ; "Double dagger")
                                (\POSTSCRIPT.OUTCHARFN STREAM (CHARCODE "0,263")))
                      ("0,322"                               (* ; "R-circle is in Symbol")
                               (\POSTSCRIPT.SYMBOLOUTCHAR STREAM (CHARCODE "0,342")))
                      ("0,323"                               (* ; "C-circle is in Symbol")
                               (\POSTSCRIPT.SYMBOLOUTCHAR STREAM (CHARCODE "0,343")))
                      ("0,324"                               (* ; "TM is in Symbol")
                               (\POSTSCRIPT.SYMBOLOUTCHAR STREAM (CHARCODE "0,344")))
                      (PROGN (SETQ CHAR (\CHAR8CODE CHAR))
                             [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)))
                                 (BOUT STREAM (CHARCODE %())
                                 (freplace POSTSCRIPTCHARSTOSHOW of IMAGEDATA with T)))
                             (BOUT STREAM (CHARCODE \))
                             [SELCHARQ CHAR
                                  ((%( %) \) 
                                       (BOUT STREAM CHAR))
                                  (PROGN [BOUT STREAM (IPLUS (CHARCODE 0)
                                                             (LOGAND 3 (LRSH CHAR 6]
                                         [BOUT STREAM (IPLUS (CHARCODE 0)
                                                             (LOGAND 7 (LRSH CHAR 3]
                                         (BOUT STREAM (IPLUS (CHARCODE 0)
                                                             (LOGAND 7 CHAR]
                             (freplace POSTSCRIPTX of IMAGEDATA with NEWXPOS]
           (RETURN CHAR])

(\POSTSCRIPT.SYMBOLOUTCHAR
  [LAMBDA (STREAM CHARCODE)                              (* ; "Edited 12-Jul-90 12:20 by jds")

    (* ;; "Print a character that's really in the Symbol font:  Change to Symbol, print the char, then change back.")

    (LET* ((OLDFONT (DSPFONT NIL STREAM))
           (SIZE (FETCH (FONTDESCRIPTOR FONTSIZE) OF OLDFONT)))
          (DSPFONT (LIST 'SYMBOL SIZE)
                 STREAM)
          (\POSTSCRIPT.OUTCHARFN STREAM CHARCODE)
          (DSPFONT OLDFONT STREAM])
)

(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 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 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 cvi def" 
              "   /yindex y 1 add 2 div bpside mul 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" "%%%%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)

(RPAQ? POSTSCRIPTFONTDIRECTORIES (LIST (IF (EQL (MACHINETYPE)
                                                    'MAIKO)
                                               then "{DSK}/usr/local/lde/fonts/postscript/" else 
                                               "{DSK}<LISPFILES>FONTS>PSC>")))

(RPAQ? \POSTSCRIPT.MAX.WILD.FONTSIZE 72)

(ADDTOVAR POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA)
                                    (HELVETICAD . HELVETICA)
                                    (TIMESROMAN . TIMES)
                                    (TIMESROMAND . TIMES)
                                    (COURIER . COURIER)
                                    (GACHA . COURIER)
                                    (CLASSIC . TIMES)
                                    (MODERN . HELVETICA)
                                    (CREAM . HELVETICA)
                                    (TERMINAL . COURIER)
                                    (LOGO . HELVETICA)
                                    (TITAN . COURIER))

(ADDTOVAR PRINTERTYPES ((POSTSCRIPT)
                            (CANPRINT (POSTSCRIPT))
                            (STATUS TRUE)
                            (PROPERTIES NILL)
                            (SEND POSTSCRIPT.SEND)
                            (BITMAPSCALE POSTSCRIPT.BITMAPSCALE)
                            (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION
                                               TITLE))))

(ADDTOVAR PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP)
                                    (EXTENSION (PS PSC))
                                    (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT))))

(ADDTOVAR IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM)
                                      (FONTCREATE POSTSCRIPT.FONTCREATE)
                                      (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE)
                                      (CREATECHARSET NILL)))

(RPAQ? POSTSCRIPT.PAGETYPE 'LETTER)

(APPENDTOVAR POSTSCRIPT.PAGEREGIONS (LETTER (0 0 8.5 11)
                                               (0.197 0.197 8.1 10.6))
                                        (LEGAL (0 0 8.5 14)
                                               (0.89 0.5 6.72 13.0))
                                        (NOTE (0 0 8.5 11)
                                              (0.405 0.42 7.69 10.16)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.EOL POSTSCRIPT.FONT.ALIST 
       POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE 
       POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.MAX.WILD.FONTSIZE 
       \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPTIMAGEOPS POSTSCRIPT.PAGETYPE POSTSCRIPT.PAGEREGIONS)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(POSTSCRIPT.INIT)
)

(PUTPROPS POSTSCRIPTSTREAM FILETYPE :TCOMPL)

(PUTPROPS POSTSCRIPTSTREAM MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP"))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA POSTSCRIPT.PUTCOMMAND)
)
(PUTPROPS POSTSCRIPTSTREAM COPYRIGHT ("Savoir and Beckman" 1989 1990 1991))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (14441 129927 (CLOSEPOSTSCRIPTSTREAM 14451 . 14713) (OPENPOSTSCRIPTSTREAM 14715 . 20560)
 (POSTSCRIPT.BITMAPSCALE 20562 . 22808) (POSTSCRIPT.CLOSESTRING 22810 . 23259) (POSTSCRIPT.ENDPAGE 
23261 . 23823) (POSTSCRIPT.FONTCREATE 23825 . 33862) (POSTSCRIPT.FONTSAVAILABLE 33864 . 37630) (
POSTSCRIPT.GETFONTID 37632 . 38912) (POSTSCRIPT.HARDCOPYW 38914 . 41832) (POSTSCRIPT.INIT 41834 . 
47366) (POSTSCRIPT.OUTSTR 47368 . 48530) (POSTSCRIPT.PUTBITMAPBYTES 48532 . 56630) (
POSTSCRIPT.PUTCOMMAND 56632 . 57666) (POSTSCRIPT.SHOWACCUM 57668 . 59202) (POSTSCRIPT.STARTPAGE 59204
 . 61319) (POSTSCRIPT.TEDIT 61321 . 61642) (POSTSCRIPT.TEXT 61644 . 61935) (POSTSCRIPTFILEP 61937 . 
62391) (PSCFONT.READFONT 62393 . 63951) (PSCFONT.SPELLFILE 63953 . 64281) (PSCFONT.WRITEFONT 64283 . 
65115) (READ-AFM-FILE 65117 . 69013) (\BITBLT.PSC 69015 . 69568) (\BLTSHADE.PSC 69570 . 73845) (
\CHARWIDTH.PSC 73847 . 74332) (\DRAWARC.PSC 74334 . 76962) (\DRAWCIRCLE.PSC 76964 . 79512) (
\DRAWCURVE.PSC 79514 . 83477) (\DRAWELLIPSE.PSC 83479 . 86097) (\DRAWLINE.PSC 86099 . 88284) (
\DRAWPOINT.PSC 88286 . 88874) (\DRAWPOLYGON.PSC 88876 . 92109) (\DSPBOTTOMMARGIN.PSC 92111 . 92504) (
\DSPCLIPPINGREGION.PSC 92506 . 93715) (\DSPFONT.PSC 93717 . 95665) (\DSPLEFTMARGIN.PSC 95667 . 96105) 
(\DSPLINEFEED.PSC 96107 . 96498) (\DSPRESET.PSC 96500 . 97027) (\DSPRIGHTMARGIN.PSC 97029 . 97482) (
\DSPROTATE.PSC 97484 . 102019) (\DSPSCALE.PSC 102021 . 102880) (\DSPSPACEFACTOR.PSC 102882 . 103766) (
\DSPTOPMARGIN.PSC 103768 . 104152) (\DSPTRANSLATE.PSC 104154 . 105996) (\DSPXPOSITION.PSC 105998 . 
106461) (\DSPYPOSITION.PSC 106463 . 106938) (\FILLCIRCLE.PSC 106940 . 109586) (\FILLPOLYGON.PSC 109588
 . 113303) (\FIXLINELENGTH.PSC 113305 . 114512) (\MOVETO.PSC 114514 . 115132) (\NEWPAGE.PSC 115134 . 
115329) (\POSTSCRIPTTAB 115331 . 116105) (\PS.BOUTFIXP 116107 . 117537) (\PS.SCALEHACK 117539 . 120034
) (\PS.SCALEREGION 120036 . 120596) (\SCALEDBITBLT.PSC 120598 . 124712) (\SETPOS.PSC 124714 . 125066) 
(\SETXFORM.PSC 125068 . 126914) (\STRINGWIDTH.PSC 126916 . 127278) (\SWITCHFONTS.PSC 127280 . 129073) 
(\TERPRI.PSC 129075 . 129925)) (129928 137959 (\POSTSCRIPT.OUTCHARFN 129938 . 137430) (
\POSTSCRIPT.SYMBOLOUTCHAR 137432 . 137957)))))
STOP
\ No newline at end of file
diff --git a/lispusers/POSTSCRIPT/POSTSCRIPTSTREAM.TEDIT b/lispusers/POSTSCRIPT/POSTSCRIPTSTREAM.TEDIT
deleted file mode 100644
index c135019b..00000000
--- a/lispusers/POSTSCRIPT/POSTSCRIPTSTREAM.TEDIT
+++ /dev/null
@@ -1,11 +0,0 @@
-en·vÅos	POSTSCRIPTSTREAM
2

4

1

POSTSCRIPTSTREAM
1

4

By:  Matt Heffron (mheffron@orion.cf.uci.edu)
INTRODUCTION
The PostScript package defines a set of imageops for printers which understand the PostScript page description language by Adobe.  At Beckman we have successfully used TEdit, Sketch, LISTFILES, and HARDCOPYW to an Apple LaserWriter and an AST TurboLaser PS.  The PostScript imagestream driver installs itself when it is loaded.  All symbols in the PostScript driver are located in the INTERLISP: package.
VARIABLES
POSTSCRIPT.FONT.ALIST	[InitVariable]
POSTSCRIPT.FONT.ALIST is an ALIST mapping Xerox Lisp font names into the root names of PostScript font files.  It is also used for font family coercions.  The default value should be acceptable for any of the fonts which are built into the Apple Laserwriter.
POSTSCRIPTFONTDIRECTORIES	[InitVariable]
POSTSCRIPTFONTDIRECTORIES is the list of directories where the PostScript .PSCFONT font files can be found.  The default value is: ("{DSK}/usr/local/lde/fonts/postscript/") on a Sun or IBM workstation and  ("{DSK}<LISPFILES>FONTS>PSC>") for other cases .
POSTSCRIPT.DEFAULT.PAGEREGION	[InitVariable]
POSTSCRIPT.DEFAULT.PAGEREGION indicates the area of the page to use for text file listings (i.e. LISTFILES).  It is in units of 100'ths of points.  The default value is: (4800 4800 52800 70800), which gives left and bottom margins of 0.75 inch and top and right margins of 0.5 inch on 8.5 x 11 paper.
POSTSCRIPT.PAGEREGIONS	[InitVariable]
POSTSCRIPT.PAGEREGIONS is an ALIST mapping pagetypes into paper size and actual imageable area on the page.  By default, it knows about LETTER, LEGAL, and NOTE pagetypes, and the corresponding sizes and imageable areas for the Apple Laserwriter.  Others can be defined by the user by adding the appropriate entries onto this ALIST.
POSTSCRIPT.PAGETYPE	[InitVariable]
POSTSCRIPT.PAGETYPE is used by OPENIMAGESTREAM to lookup the paper size and actual imageable area of the page in POSTSCRIPT.PAGEREGIONS to determine the initial margins.  This value can be overridden with the PAGETYPE or PAPERTYPE options in the OPENIMAGESTREAM call.  The name of the type of page selected is NOT passed through to the PostScript output.
\POSTSCRIPT.MAX.WILD.FONTSIZE	[InitVariable]
\POSTSCRIPT.MAX.WILD.FONTSIZE indicates the maximum point size that should be returned from FONTSAVAILABLE when the SIZE argument is wild (i.e. *).  All integer pointsizes from 1 to \POSTSCRIPT.MAX.WILD.FONTSIZE will be indicated as available.  The default value is: 72.
POSTSCRIPT.PREFER.LANDSCAPE	[InitVariable]
POSTSCRIPT.PREFER.LANDSCAPE indicates if the OPENIMAGESTREAM method should default the orientation of output files to LANDSCAPE.  It can have one of three values: NIL, T, or ASK.  NIL means prefer portrait orientation output, T means prefer landscape, and ASK says to bring up a menu to ask the preferred orientation if it wasn't explicitly indicated in the OPENIMAGESTREAM call (with the ROTATION option).  The default value is: NIL.  An item (PS Orientation) is added to the Background Menu to let you change the value of this variable. 
POSTSCRIPT.TEXTFILE.LANDSCAPE	[InitVariable]
POSTSCRIPT.TEXTFILE.LANDSCAPE indicates if the printing of TEXT files (e.g. LISTFILES, ...) should force the orientation of output files to LANDSCAPE.  When it is non-NIL the orientation of output files is forced to LANDSCAPE.  (There is no ASK option here.)  The default value is: NIL.
POSTSCRIPT.BITMAP.SCALE	[InitVariable]
POSTSCRIPT.BITMAP.SCALE specifies an independent scale factor for display of bitmap images (e.g. window hardcopies).  Values less than 1 will reduce the image size. (I.e. a value of 0.5 will give a half size bitmap image.)  The position of the scaled bitmap will still have the SAME lower-left corner (i.e. the scaled bitmap is not centered in the region of the full size bitmap image).  The default value is: 1.
HINT
Setting POSTSCRIPT.BITMAP.SCALE to 0.96, instead of 1, will give cleaner BITMAP images on a 300 dpi printer.  (This corrects for the 72 ppi imagestream vs. the 75 dpi printer, using 4x4 device dots per bitmap pixel.)  Also, values of 0.24, 0.48 and 0.72, instead of 0.25, 0.5 and 0.75, will also give cleaner images for reduced size output.  In general, use integer multiples of 0.24 for a 300 dpi printer.
POSTSCRIPT.TEXTURE.SCALE	[InitVariable]
POSTSCRIPT.TEXTURE.SCALE specifies an independent scale for the display of bitmap textures.  The value represents the number of device space units per texture unit (bitmap bit). The default value is 4, which represents each bit of the texture as a 4x4 block, so that textures are approximately the same resolution as on the screen (for 300 dpi output devices, such as the Apple Laserwriter).  
The PostScript package extends the allowed representations of a texture, beyond 16-bit FIXP and 16x16 bitmap, to ANY square bitmap.  (If the bitmap is not square, its longer edge is truncated from the top or right to make it square.)  Use this feature with caution, as large bitmap textures, or sizes other than multiples of 16 bits square, require large amounts of storage in the PostScript interpreter (in the printer controller), and can cause limitcheck errors when actually printing.
Anywhere that a texture or color can be used on an imagestream or in the specification of a BRUSH, you can instead give a FLOATP between 0.0 and 1.0 (inclusive) to represent a PostScript halftone gray shade.  (0.0 is black and 1.0 is white.  Specifically, the value sets the brightness of the shade.)  The value you specify will not be range checked, and will be passed directly through to the PostScript setgray operator.  (E.g. you can pass 0.33 as the color to DRAWLINE to get a dark gray line with approximately 67% of the pixels in the line black.)
POSTSCRIPT.IMAGESIZEFACTOR	[InitVariable]
POSTSCRIPT.IMAGESIZEFACTOR specifies an independent factor to change the overall size of the printed image.  This re-sizing affects the entire printed output (specifically, it superimposes its effects upon those of POSTSCRIPT.BITMAP.SCALE and POSTSCRIPT.TEXTURE.SCALE).  Values greater than 1 enlarge the printed image, and values less than 1 reduce it.  An invalid POSTSCRIPT.IMAGESIZEFACTOR (i.e. not a positive, non-zero number)  will use a value of 1.  The BITMAPSCALE function for the POSTSCRIPT printer type does NOT consider the POSTSCRIPT.IMAGESIZEFACTOR when determining the scale factor for a bitmap.  
MISCELLANEOUS
The SCALE of a PostScript imagestream is 100.  This is to allow enough resolution in the width information for fonts to enable TEdit to correctly fill and justify text.
The first time any PostScript imagestream is created (even if only to hardcopy a bitmap or window) the DEFAULTFONT is instantiated (unless a FONTS option was given to the OPENIMAGESTREAM, in which case the initial font for the imagestream will be set to that font, or to the CAR if a list).
The PostScript imagestream method for FILLPOLYGON uses the global variable FILL.WRULE as the default value for the WINDINGNUMBER argument.  (This is the same variable which is used by the DISPLAY imagestream method for FILLPOLYGON.)
The PostScript imagestream method for OPENIMAGESTREAM (and, therefore,  SEND.FILE.TO.PRINTER), supports an IMAGESIZEFACTOR option to change the size of the printed image.  The IMAGESIZEFACTOR re-sizing is combined with the POSTSCRIPT.IMAGESIZEFACTOR to produce an overall re-sizing of the printed image.  A HEADING option is also supported to give a running header on each page of output.  The value of the HEADING option is printed at the top left of the page, followed by "Page " and the appropriate page number.  They are printed in the DEFAULTFONT (unless a FONTS option was given to the OPENIMAGESTREAM, in which case it will be that font, or to the CAR if a list).   
The PostScript package is contained in the files: POSTSCRIPTSTREAM.LCOM & PS-SEND.LCOM, with the source in the files:  POSTSCRIPTSTREAM & PS-SEND.  The module PS-SEND.LCOM is required and will be loaded automatically when POSTSCRIPTSTREAM.LCOM is loaded.  It contains the function which is called by SEND.FILE.TO.PRINTER to actually transmit the file to the printer.  It is, by its nature, quite site specific, so it is in a separate file to make modifying it for any site relatively simple.  System record declarations required to compile POSTSCRIPTSTREAM can be found in EXPORTS.ALL. 
I'm pretty sure that the output generated by the PostScript imageops fully conforms to the Adobe Systems Document Structuring Conventions, Version 2.0, January 31, 1987.
Including Other PostScript Operations
If you wish to insert your own specific PostScript operations into a PostScript imagestream, you can do so with the following functions:
(POSTSCRIPT.OUTSTR  STREAM STRING)	[Function]
POSTSCRIPT.OUTSTR outputs a string or value to the imagestream.  STREAM must be an open PostScript imagestream.  STRING is the value to output (STRINGP and LITATOM are most efficient, but any value can be output (its PRIN1 pname is used)).
(POSTSCRIPT.PUTCOMMAND  STREAM STRING1 ... STRINGn)	[NoSpread Function]
POSTSCRIPT.PUTCOMMAND is more general for sequences of commands and values.  It calls POSTSCRIPT.OUTSTR repeatedly to output each of the STRINGi arguments to STREAM.
(\POSTSCRIPT.OUTCHARFN  STREAM CHAR)	[Function]
\POSTSCRIPT.OUTCHARFN is used to output the characters forming the text of a PostScript string (e.g. the argument to a show or charpath operator).  STREAM is the open PostScript imagestream to output to, and CHAR is the CHARCODE of the character to output.  The / (slash), ( and ) (parenthesis) characters will be quoted with /, and characters with ASCII values less than 32 (space) or greater than 126 (tilde) will be output as /nnn (in octal).  \POSTSCRIPT.OUTCHARFN will output the ( character to open the string, if necessary.  Use POSTSCRIPT.CLOSESTRING (below) to close the string.
(POSTSCRIPT.CLOSESTRING  STREAM)	[Function]
POSTSCRIPT.CLOSESTRING closes a PostScript string (e.g. the argument to a show or charpath operator).  STREAM is the open PostScript imagestream.  It is important to use POSTSCRIPT.CLOSESTRING to output the ) character to close the string, because it also clears the stream state flag that indicates that a string is in progress (otherwise, the next  POSTSCRIPT.PUTCOMMAND would output the commands to close the string and show it).
Warning
Do not attempt to create a PostScript font larger than about 600 points, as much of Interlisp's font information is stored in SMALLP integers, and too large a font would overflow the font's height, or the width for any of the wider characters.  (I know that 600 points is a ridiculously large limit (about 8.3 inches), but I thought I'd better mention it, or someone might try it!)
Changes from the Initial Medley Release
This second Medley release of the PostScript imagestream driver includes some performance enhancements when writing bitmaps to the output, some SUN-specific code (from Will Snow of envos), implementation of the SCALEDBITBLT, DSPROTATE, and DSPTRANSLATE operations, and a lot of performance enhancements (many thanks to Tom Lipkis of Savoir).
Changes from the Lyric Release
The Medley release of this PostScript imagestream driver changed the default value of POSTSCRIPT.TEXTFILE.LANDSCAPE from T to NIL.  It also added the support for the HEADING option.
Known Problems/Limitations
The output generated for a PostScript imagestream is rather brute force.  It isn't particularly careful to generate the smallest output file for a given sequence of operations.  Specifically, it often generates extra end-of-lines between PostScript operator sequences (this has no effect on the printed output, only on the file size).
Using BITMAPs or Functions as BRUSH arguments to the curve drawing functions is not supported, nor is using a non-ROUND BRUSH with DRAWCIRCLE or DRAWELLIPSE.
The implementation of DSPROTATE accepts ROTATION argument values of 0 and 90 (any non-NIL, non-zero value is converted to 90).  A value of 0 converts the page orientation to Portrait, and 90 converts the page orientation to Landscape.  These conversions perform the translations necessary to keep the clipping region on the page.  (This may or may not be the right thing to do, but since DSPROTATE is undocumented in what it should do, this is what the PostScript driver does).
There is no support for NS character sets other than 0, and there is no translation of the character code values from NS encoding to PostScript encoding.
There is no support for color.
\POSTSCRIPT.OUTCHARFN is pretty wimpy in its handling of TAB characters.  It just moves to the next multiple of (eight times the average character width of the current font) from the current left margin.
I haven't yet documented how to build the .PSCFONT files from .AFM files for new fonts that become available.(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (162 48 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (162 48 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL)))))	5È
È,66’,È5ÈÈ,È,È,ŠŠ8,ŠŠ8HÈÈPAGEHEADINGRUNNINGHEAD	CLASSICCLASSICMODERN
-ÿþ	HELVETICA
-MODERN
-MODERN
-MODERNMODERN
-MODERN			HRULE.GETFNMODERN
-HRULE.GETFNMODERN
-HRULE.GETFNMODERN
-HRULE.GETFNMODERNHRULE.GETFNMODERN.•
-ÿ-Lc�˜ýŠé*e©#é¢K©&‰
A*y
‰”62
--f4fgbá~(V¶OžÞšÌm2WÝzº
\ No newline at end of file
diff --git a/lispusers/POSTSCRIPT/PS-PATCH b/lispusers/POSTSCRIPT/PS-PATCH
deleted file mode 100644
index 2efe322b..00000000
--- a/lispusers/POSTSCRIPT/PS-PATCH
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 8-Nov-90 18:53:15" |{PELE:MV:ENVOS}<LISPUSERS>MEDLEY>POSTSCRIPT>PS-PATCH.;2| 24907  

      changes to%:  (VARS PS-PATCHCOMS)
                    (PROPS (PS-PATCH MAKEFILE-ENVIRONMENT))
                    (FNS FIX-SKETCH)

      previous date%: "22-Feb-89 14:11:29" |{PELE:MV:ENVOS}<LISPUSERS>MEDLEY>POSTSCRIPT>PS-PATCH.;1|
)


(* ; "
Copyright (c) 1989, 1990 by ENVOS Corporation.  All rights reserved.
")

(PRETTYCOMPRINT PS-PATCHCOMS)

(RPAQQ PS-PATCHCOMS
       ((PROP (MAKEFILE-ENVIRONMENT FILETYPE)
              PS-PATCH)
        (FNS ADD.KNOWN.SKETCH.FONT NEW-SK-PICK-FONT NEW-SK-DECREASING-FONT-LIST 
             NEW-SKETCHW-HARDCOPYFN FIX-SKETCH)
        [VARS (SKETCH-PATCHES '((NEW-SK-PICK-FONT . SK.PICK.FONT)
                                (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST)
                                (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN]
        
        (* ;; 
     "NOTE: to compile the following 2 functions you need FONT loaded prop and EXPORTS.ALL loaded.")

        (FNS \BUILDSLUGCSINFO \CREATECHARSET)
        (ADDVARS (POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA)
                        (TIMESROMAND . TIMESROMAN)
                        (COURIER . COURIER)
                        (GACHA . COURIER)
                        (CLASSIC . TIMESROMAN)
                        (MODERN . HELVETICA)
                        (CREAM . HELVETICA)
                        (TERMINAL . COURIER)
                        (LOGO . HELVETICA)
                        (MODERN . HELVETICA)))
        (VARS (\KNOWN.SKETCH.FONTSIZES))
        (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)
               POSTSCRIPT.FONT.CONVERSIONS)
        
        (* ;; "finally actually do the patching of sketch.")

        (P (FIX-SKETCH))))

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

(PUTPROPS PS-PATCH FILETYPE :TCOMPL)
(DEFINEQ

(ADD.KNOWN.SKETCH.FONT
  [LAMBDA (FAMILY WID DEVICE FONT)                       (* ; "Edited 21-Feb-89 15:06 by snow")

    (* ;; "add to the globally cached font list")

    (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES))
    (LET ((CACHE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES))
          (CACHED))
         (COND
            [(NULL CACHE)
             (if \KNOWN.SKETCH.FONTSIZES
                 then [NCONC1 \KNOWN.SKETCH.FONTSIZES (LIST FAMILY (LIST DEVICE (CONS WID FONT]
               else (SETQ \KNOWN.SKETCH.FONTSIZES (LIST (LIST FAMILY (LIST DEVICE
                                                                               (CONS WID FONT]
            (T (COND
                  ((SETQ CACHED (ASSOC DEVICE CACHE))
                   (NCONC1 CACHED (CONS WID FONT)))
                  (T (NCONC1 CACHE (CONS DEVICE (CONS WID FONT])

(NEW-SK-PICK-FONT
  [LAMBDA (WID STRING DEVICE FAMILY)                     (* ; "Edited 22-Feb-89 07:53 by snow")

    (* ;; "returns the font in FAMILY that text should be printed in to have the text STRING fit into a region WID points wide")

    (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES))
    (PROG (LASTFONT LASTSIZE DISPLAYFONT SCALE CACHEDFONT)
          (IF [SETQ CACHEDFONT (ASSOC WID (ASSOC DEVICE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES]
              THEN (RETURN (CDR CACHEDFONT)))
          (RETURN (for FONT in (SK.DECREASING.FONT.LIST FAMILY DEVICE)
                     when (NOT (GREATERP [SETQ LASTSIZE (COND
                                                               ((SETQ SCALE (FONTPROP FONT
                                                                                   'SCALE))

                                                                (* ;; 
                                                    "IF THERE IS A SCALE, YOU MUST SCALE THE FONT.")

                                                                (QUOTIENT (STRINGWIDTH STRING FONT)
                                                                       SCALE))
                                                               ((SETQ DISPLAYFONT (FONTCOPY
                                                                                   (SETQ LASTFONT 
                                                                                    FONT)
                                                                                   'DEVICE
                                                                                   'DISPLAY
                                                                                   'NOERROR T))
                                                             (* ; "use display if it exists.")
                                                                (STRINGWIDTH STRING DISPLAYFONT))
                                                               (T 
                                                             (* ; 
                                       "in some cases, font exists for devices other than display.")
                                                                  (QUOTIENT (STRINGWIDTH STRING FONT)
                                                                         (FONTPROP FONT 'SCALE]
                                          WID)) do       (* ; 
       "return a font for the proper device even though the display fonts are used to pick a size.")
                                                      (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE
                                                             (FONTCOPY FONT 'DEVICE DEVICE))
                                                      (RETURN (FONTCOPY FONT 'DEVICE DEVICE))
                     finally (RETURN (COND
                                            ((OR (NULL LASTFONT)
                                                 (GREATERP LASTSIZE (TIMES 1.5 WID)))
                                             'SHADE)
                                            (T               (* ; 
                                                          "use the smallest if it isn't too large.")
                                               (FONTCOPY LASTFONT 'DEVICE DEVICE])

(NEW-SK-DECREASING-FONT-LIST
  [LAMBDA (FAMILY DEVICETYPE)                            (* ; "Edited 21-Feb-89 11:26 by snow")

    (* ;; "returns a list of fonts of family FAMILY which work on device DEVICETYPE")

    [COND
       ((NULL FAMILY)
        (SETQ FAMILY 'MODERN]

    (* ;; "convert to families that exist on the known devices.")

(* ;;; "NOTE: this is a very bad way to convert the family.  It HARDCODES in the conversions for PRESS and INTERPRESS  and does nothing for new device types.  I have added the conversion for POSTSCRIPT that does things a little cleaner, but it should really look at a property of the device (fontconversions or some such animal.)  --was 2/19/89")

    (LET ((CONVERSION))
         [COND
            [(EQ DEVICETYPE 'PRESS)
             (COND
                ((EQ FAMILY 'MODERN)
                 (SETQ FAMILY 'HELVETICA))
                ((EQ FAMILY 'CLASSIC)
                 (SETQ FAMILY 'TIMESROMAN))
                ((EQ FAMILY 'TERMINAL)
                 (SETQ FAMILY 'GACHA]
            [(EQ DEVICETYPE 'INTERPRESS)
             (COND
                ((EQ FAMILY 'HELVETICA)
                 (SETQ FAMILY 'MODERN))
                ((EQ FAMILY 'TIMESROMAN)
                 (SETQ FAMILY 'CLASSIC))
                ((EQ FAMILY 'GACHA)
                 (SETQ FAMILY 'TERMINAL]
            ((EQ DEVICETYPE 'POSTSCRIPT)
             (if (SETQ CONVERSION (ASSOC FAMILY POSTSCRIPT.FONT.CONVERSIONS))
                 then 

                       (* ;; 
                  "convert the family here for postscript as well as the other well known devices.")

                       (SETQ FAMILY (CDR CONVERSION]
         (for FONT in (SK.GUESS.FONTSAVAILABLE FAMILY DEVICETYPE)
            collect (FONTCOPY FONT 'DEVICE DEVICETYPE])

(NEW-SKETCHW-HARDCOPYFN
  [LAMBDA (SKETCHW OPENIMAGESTREAM)                      (* ; "Edited 22-Feb-89 13:34 by snow")
                                                             (* ; 
                                                           "dumps the sketch onto OPENIMAGESTREAM.")
                                                             (* ; 
                                       "centers it within the DSPCLIPPINGREGION of OPENIMAGESTREAM")
    (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW)))
           (PAGEREGION (DSPCLIPPINGREGION NIL OPENIMAGESTREAM))
           (SKETCHREGION (SKETCH.REGION.VIEWED SKETCHW))
           (SCALE (VIEWER.SCALE SKETCHW))
           SKETCHREGIONINPAGECOORDS PAGELEFTSPACE PAGEBOTTOMSPACE PAGETOSKETCHFACTOR SKETCHX)
          (OR SKETCH (RETURN))
          (SPAWN.MOUSE)

     (* ;; "move the margins out of the way")

     (* ;; 
   "smallp is to maintain compatibility with koto.  For Lute release, this could be increased.")

          (DSPLEFTMARGIN (MIN 0 (fetch (REGION LEFT) of PAGEREGION))
                 OPENIMAGESTREAM)
          (DSPBOTTOMMARGIN (MIN 0 (fetch (REGION BOTTOM) of PAGEREGION))
                 OPENIMAGESTREAM)
          (DSPTOPMARGIN (MAX MAX.SMALLP (fetch (REGION TOP) of PAGEREGION))
                 OPENIMAGESTREAM)
          (DSPRIGHTMARGIN (MAX MAX.SMALLP (fetch (REGION RIGHT) of PAGEREGION))
                 OPENIMAGESTREAM)

     (* ;; "PAGETOSKETCHFACTOR is the factor to multiply the page coordinates by to get into sketch coordinates.")

          (STATUSPRINT SKETCHW "Hardcopying ...")
          [STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS (APPEND (LIST 'DOCUMENT.NAME (OR (SKETCH.TITLE
                                                                                      SKETCHW)
                                                                                     "A Sketch"))
                                                           (STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS]
          (SETQ PAGETOSKETCHFACTOR (FQUOTIENT SCALE (DSPSCALE NIL OPENIMAGESTREAM)))
          (SETQ SKETCHREGIONINPAGECOORDS (SCALE.REGION.OUT SKETCHREGION PAGETOSKETCHFACTOR))
          (COND
             ((AND (NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM)
                            'PRESS))
                   (NOT (EQ (FETCH (IMAGEOPS IMROTATE) OF (FETCH (STREAM IMAGEOPS)
                                                                     OF OPENIMAGESTREAM))
                            'NILL))
                   (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS)
                          (fetch WIDTH of PAGEREGION))
                   (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS)
                          (fetch HEIGHT of SKETCHREGIONINPAGECOORDS)))

              (* ;; "we ;have a  stream that supports rotation, use it!")

              (DSPROTATE 90 OPENIMAGESTREAM)
              (DSPTRANSLATE 0 (MINUS (FETCH (REGION HEIGHT) OF PAGEREGION))
                     OPENIMAGESTREAM)
              (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION))
                     OPENIMAGESTREAM)

              (* ;; "(ROTATE.IP OPENIMAGESTREAM 90) (CONCATT.IP OPENIMAGESTREAM) (TRANSLATE.IP OPENIMAGESTREAM 0 -21590) (CONCATT.IP OPENIMAGESTREAM) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM)")

              (* ;; "this was an incredibly bogus hack to make INTERPRESS only streams rotate the sketch image if they were too big.  Now it tries to do it on any stream that has a dsprotate function.")

              ))
          (SETQ PAGELEFTSPACE (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION)
                                               (fetch (REGION WIDTH) of 
                                                                             SKETCHREGIONINPAGECOORDS
                                                      ))
                                     2))
          (SETQ PAGEBOTTOMSPACE (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION)
                                                 (fetch (REGION HEIGHT) of 
                                                                             SKETCHREGIONINPAGECOORDS
                                                        ))
                                       2))

     (* ;; "translate the sketch so that the lower left corner of the sketch region is at the lower left corner of the image on the page.")

          [SETQ SKETCHX (TRANSLATE.SKETCH SKETCH (MINUS (TIMES (DIFFERENCE
                                                                (SETQ PAGELEFTSPACE
                                                                 (PLUS (fetch (REGION LEFT)
                                                                          of PAGEREGION)
                                                                       PAGELEFTSPACE))
                                                                (fetch (REGION LEFT) of
                                                                                         
                                                                             SKETCHREGIONINPAGECOORDS
                                                                       ))
                                                               PAGETOSKETCHFACTOR))
                               (MINUS (TIMES (DIFFERENCE (SETQ PAGEBOTTOMSPACE
                                                          (PLUS (fetch (REGION BOTTOM)
                                                                   of PAGEREGION)
                                                                PAGEBOTTOMSPACE))
                                                    (fetch (REGION BOTTOM) of 
                                                                             SKETCHREGIONINPAGECOORDS
                                                           ))
                                             PAGETOSKETCHFACTOR]
                                                             (* ; 
                                             "calculate the local parts for the interpress sketch.")
          (SETQ SKETCHX (MAKE.LOCAL.SKETCH SKETCHX (CREATEREGION (TIMES PAGELEFTSPACE 
                                                                        PAGETOSKETCHFACTOR)
                                                          (TIMES PAGEBOTTOMSPACE PAGETOSKETCHFACTOR)
                                                          (fetch (REGION WIDTH) of 
                                                                                         SKETCHREGION
                                                                 )
                                                          (fetch (REGION HEIGHT) of 
                                                                                         SKETCHREGION
                                                                 ))
                               PAGETOSKETCHFACTOR OPENIMAGESTREAM))
          (DRAW.LOCAL.SKETCH SKETCHX OPENIMAGESTREAM (CREATEREGION PAGELEFTSPACE PAGEBOTTOMSPACE
                                                            (fetch (REGION WIDTH) of 
                                                                             SKETCHREGIONINPAGECOORDS
                                                                   )
                                                            (fetch (REGION HEIGHT) of 
                                                                             SKETCHREGIONINPAGECOORDS
                                                                   )))
          (STATUSPRINT SKETCHW " done.")
          (RETURN OPENIMAGESTREAM])

(FIX-SKETCH
  [LAMBDA NIL                                            (* ; "Edited  8-Nov-90 16:32 by jds")
    (COND
       ((BOUNDP 'ALL.SKETCHES)

        (* ;; "sketch is loaded")

        (for PATCHED-FN in '(NEW-SK-PICK-FONT NEW-SK-DECREASING-FONT-LIST 
                                           NEW-SKETCHW-HARDCOPYFN) as ORIGINAL-FN
           in '(SK.PICK.FONT SK.DECREASING.FONT.LIST SKETCHW.HARDCOPYFN)
           do (MOVD PATCHED-FN ORIGINAL-FN NIL T))
        (PROMPTPRINT "Sketch has been patched!")
        T)
       (T (PROMPTPRINT "Sketch doesn't seem to be loaded!")
          (PROMPTPRINT "When you load sketch, make sure to call the function FIX-SKETCH!")
          NIL])
)

(RPAQQ SKETCH-PATCHES ((NEW-SK-PICK-FONT . SK.PICK.FONT)
                           (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST)
                           (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN)))



(* ;; "NOTE: to compile the following 2 functions you need FONT loaded prop and EXPORTS.ALL loaded."
)

(DEFINEQ

(\BUILDSLUGCSINFO
  [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE)            (* ; "Edited 14-Feb-89 16:46 by snow")

(* ;;; "builds a csinfo which contains only the slug (black rectangle) character")

    (SETQ SCALE (OR SCALE 1))
    (PROG ((CSINFO (create CHARSETINFO
                          CHARSETASCENT _ ASCENT
                          CHARSETDESCENT _ DESCENT
                          IMAGEWIDTHS _ (\CREATECSINFOELEMENT)))
           WIDTHS OFFSETS BITMAP IMAGEWIDTHS)
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
          (SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
          [SELECTQ DEVICE
              (INTERPRESS                                    (* ; 
                                                           "don't need offsets in INTERPRESS fonts")
                          NIL)
              (PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS (
                                                                                 \CREATECSINFOELEMENT
                                                                                              )))
                     (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
                     [replace (CHARSETINFO CHARSETBITMAP) of CSINFO
                        with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE))
                                                     (ROUND (QUOTIENT (IPLUS ASCENT DESCENT)
                                                                   SCALE]
                     (BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE]
          (RETURN CSINFO])

(\CREATECHARSET
  [LAMBDA (CHARSET FONT NOSLUG?)                         (* ; "Edited 14-Feb-89 16:29 by snow")

    (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR")
                                                             (* ; 
  "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")
    (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES))
    (AND (IGREATERP CHARSET \MAXCHARSET)
         (\ILLEGAL.ARG CHARSET))
    (PROG (CSINFO CREATEFN)

     (* ;; "For other charsets, create a font descriptor of info for that charset, and use it to fill things in.")

          (if (OR (AND (IGEQ CHARSET 1)
                           (ILEQ CHARSET 32))
                      (AND (IGEQ CHARSET 127)
                           (ILEQ CHARSET 160)))
              then 

                    (* ;; "this is an illegal NS character set (reserved for control codes) so just return a slug (unless NOSLUG?  is T)")

                    [if NOSLUG?
                        then (RETURN NIL)
                      else (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR 
                                                                                    FONTAVGCHARWIDTH)
                                                                     of FONT)
                                                   (FONTPROP FONT 'ASCENT)
                                                   (FONTPROP FONT 'DESCENT)
                                                   (FONTPROP FONT 'DEVICE)
                                                   (FONTPROP FONT 'SCALE]
            else [SETQ CREATEFN (COND
                                       ((FMEMB (FONTPROP FONT 'DEVICE)
                                               \DISPLAYSTREAMTYPES)
                                        (FUNCTION \CREATECHARSET.DISPLAY))
                                       (T (CADR (ASSOC 'CREATECHARSET
                                                       (CDR (ASSOC (FONTPROP FONT 'DEVICE)
                                                                   IMAGESTREAMTYPES]
                  [if [NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC)
                                                                   (LIST CHARSET FONT NOSLUG?]
                      then                               (* ; 
         "the create method returned NIL.  so if NOSLUG?  return NIL else build a slug charsetinfo")
                            (RETURN (if NOSLUG?
                                        then             (* ; 
                                  "the caller just wants NIL back to signal that nothing was found")
                                              NIL
                                      else (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR
                                                                                 FONTAVGCHARWIDTH)
                                                                        of FONT)
                                                      (FONTPROP FONT 'ASCENT)
                                                      (FONTPROP FONT 'HEIGHT)
                                                      (FONTPROP FONT 'DEVICE)
                                                      (FONTPROP FONT 'SCALE]
                  (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of
                                                                                         FONT)
                                                                    (fetch CHARSETASCENT
                                                                       of CSINFO)))
                  (replace \SFDescent of FONT with (IMAX (fetch \SFDescent
                                                                        of FONT)
                                                                     (ffetch CHARSETDESCENT
                                                                        of CSINFO)))
                  (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent
                                                                        of FONT)
                                                                     (ffetch \SFDescent
                                                                        of FONT))) 
                                                             (* ; 
                              "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)")
                 )
          (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
                         CHARSET CSINFO])
)

(ADDTOVAR POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA)
                                          (TIMESROMAND . TIMESROMAN)
                                          (COURIER . COURIER)
                                          (GACHA . COURIER)
                                          (CLASSIC . TIMESROMAN)
                                          (MODERN . HELVETICA)
                                          (CREAM . HELVETICA)
                                          (TERMINAL . COURIER)
                                          (LOGO . HELVETICA)
                                          (MODERN . HELVETICA))

(RPAQQ \KNOWN.SKETCH.FONTSIZES NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)
       POSTSCRIPT.FONT.CONVERSIONS)
)



(* ;; "finally actually do the patching of sketch.")


(FIX-SKETCH)
(PUTPROPS PS-PATCH COPYRIGHT ("ENVOS Corporation" 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2086 16850 (ADD.KNOWN.SKETCH.FONT 2096 . 2973) (NEW-SK-PICK-FONT 2975 . 6357) (
NEW-SK-DECREASING-FONT-LIST 6359 . 8183) (NEW-SKETCHW-HARDCOPYFN 8185 . 16115) (FIX-SKETCH 16117 . 
16848)) (17182 23954 (\BUILDSLUGCSINFO 17192 . 19090) (\CREATECHARSET 19092 . 23952)))))
STOP
\ No newline at end of file
diff --git a/lispusers/POSTSCRIPT/PS-RS232 b/lispusers/POSTSCRIPT/PS-RS232
deleted file mode 100644
index 5749b1fa..00000000
--- a/lispusers/POSTSCRIPT/PS-RS232
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 2-Aug-89 13:35:49" {DSK}<LISPFILES>PS>PS-RS232.;1 2639   

      changes to%:  (VARS PS-RS232COMS)
                    (PROPS (PS-RS232 MAKEFILE-ENVIRONMENT)
                           (PS-RS232 PRINTERTYPE)
                           (PS-RS232 SPOOLFILE))
                    (FNS PS-RS232-AFTERLOGOUT PS-RS232-INIT))


(* "
Copyright (c) 1989 by Beckman Instruments, Inc.  All rights reserved.
")

(PRETTYCOMPRINT PS-RS232COMS)

(RPAQQ PS-RS232COMS ((FILES POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS)
                                DLRS232C)
                         (INITVARS (PS-RS232-BAUD 9600)
                                (PS-RS232-DATABITS 8)
                                (PS-RS232-PARITY 'NONE)
                                (PS-RS232-STOPBITS 1)
                                (PS-RS232-FLOWCONTROL 'XOnXOff))
                         (FNS PS-RS232-AFTERLOGOUT PS-RS232-INIT)
                         (ADDVARS (DEFAULTPRINTINGHOST PS-RS232)
                                (AROUNDEXITFNS PS-RS232-AFTERLOGOUT))
                         (P (PS-RS232-INIT))
                         (PROP (MAKEFILE-ENVIRONMENT PRINTERTYPE SPOOLFILE)
                               PS-RS232)))

(FILESLOAD POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS)
       DLRS232C)

(RPAQ? PS-RS232-BAUD 9600)

(RPAQ? PS-RS232-DATABITS 8)

(RPAQ? PS-RS232-PARITY 'NONE)

(RPAQ? PS-RS232-STOPBITS 1)

(RPAQ? PS-RS232-FLOWCONTROL 'XOnXOff)
(DEFINEQ

(PS-RS232-AFTERLOGOUT
  [LAMBDA (EVENT)
    (if (EQ EVENT 'AFTERLOGOUT)
        then (RS232C.INIT PS-RS232-BAUD PS-RS232-DATABITS PS-RS232-PARITY PS-RS232-STOPBITS 
                        PS-RS232-FLOWCONTROL])

(PS-RS232-INIT
  [LAMBDA NIL
    [PUTPROP 'PS-RS232 'SPOOLOPTIONS `((BaudRate ,PS-RS232-BAUD)
                                       (BitsPerSerialChar ,PS-RS232-DATABITS)
                                       (Parity ,PS-RS232-PARITY)
                                       (NoOfStopBits ,PS-RS232-STOPBITS)
                                       (FlowControl ,PS-RS232-FLOWCONTROL]
    (PS-RS232-AFTERLOGOUT 'AFTERLOGOUT)                  (* ; "Fake it")
    NIL])
)

(ADDTOVAR DEFAULTPRINTINGHOST PS-RS232)

(ADDTOVAR AROUNDEXITFNS PS-RS232-AFTERLOGOUT)

(PS-RS232-INIT)

(PUTPROPS PS-RS232 MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))

(PUTPROPS PS-RS232 PRINTERTYPE POSTSCRIPT)

(PUTPROPS PS-RS232 SPOOLFILE "{RS232}FOO.PS")
(PUTPROPS PS-RS232 COPYRIGHT ("Beckman Instruments, Inc" 1989))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1528 2244 (PS-RS232-AFTERLOGOUT 1538 . 1761) (PS-RS232-INIT 1763 . 2242)))))
STOP
\ No newline at end of file
diff --git a/lispusers/POSTSCRIPT/PS-RS232.TEDIT b/lispusers/POSTSCRIPT/PS-RS232.TEDIT
deleted file mode 100644
index dcc1d6ae..00000000
Binary files a/lispusers/POSTSCRIPT/PS-RS232.TEDIT and /dev/null differ
diff --git a/lispusers/POSTSCRIPT/PS-SEND b/lispusers/POSTSCRIPT/PS-SEND
deleted file mode 100644
index aff039ac..00000000
--- a/lispusers/POSTSCRIPT/PS-SEND
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP")
(FILECREATED " 2-Aug-89 13:02:26" {DSK}<LISPFILES>PS>PS-SEND.;9 5519   

      changes to%:  (VARS PS-SENDCOMS)
                    (PROPS (PS-SEND MAKEFILE-ENVIRONMENT))

      previous date%: "27-Jan-89 12:09:04" {DSK}<LISPFILES>PS>PS-SEND.;8)


(* "
Copyright (c) 1988, 1989 by Beckman Instruments, Inc.  All rights reserved.
")

(PRETTYCOMPRINT PS-SENDCOMS)

(RPAQQ PS-SENDCOMS ((FNS POSTSCRIPT.SEND SUN.PS.SEND)
                        [P 
                           (* ;; " %"load the unixcomm software if you are on a sun.")

                           (IF (EQ (MACHINETYPE)
                                   'MAIKO)
                               THEN
                               (FILESLOAD 'UNIXCOMM]
                        (PROP (FILETYPE MAKEFILE-ENVIRONMENT)
                              PS-SEND)))
(DEFINEQ

(POSTSCRIPT.SEND
  [LAMBDA (HOST FILE PRINTOPTIONS)                (* ; "Edited 27-Jan-89 10:53 by Matt Heffron")
    (if (EQ (MACHINETYPE)
                'MAIKO)
        then 

              (* ;; "Sun code compliments of Will Snow @ Envos.")

              (* ;; "we're on a SUN, let's print this file as directly as possible.")

              (SUN.PS.SEND HOST FILE PRINTOPTIONS)
      else [OR HOST (SETQ HOST (CAR (MKLIST DEFAULTPRINTINGHOST]
            (if (LISTP HOST)
                then (SETQ HOST (CADR HOST)))
            (LET* ([INFILE (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT)
                                                         (SEQUENTIAL T]
                   (SPOOLDIRECTORY (GETPROP HOST 'SPOOLDIRECTORY))
                   (SPOOLFILE (GETPROP HOST 'SPOOLFILE))
                   (SPOOLOPTIONS (GETPROP HOST 'SPOOLOPTIONS))
                   (OUTFILE (if SPOOLFILE
                                then (OPENSTREAM SPOOLFILE 'OUTPUT NIL
                                                (APPEND '((TYPE TEXT)
                                                          (SEQUENTIAL T))
                                                       SPOOLOPTIONS))
                              elseif SPOOLDIRECTORY
                                then (OPENSTREAM (CONCAT SPOOLDIRECTORY (GENSYM USERNAME)
                                                            ".PS")
                                                'OUTPUT NIL (APPEND '((TYPE TEXT)
                                                                      (SEQUENTIAL T))
                                                                   SPOOLOPTIONS))
                              else (CL:ERROR "~&Don't know how to send to: ~S" HOST)))
                   (PRETTYDEST (if (OR SPOOLFILE SPOOLDIRECTORY)
                                   then (CONCAT (FULLNAME OUTFILE)
                                                   " (" HOST ")")
                                 else HOST)))
                  (if OUTFILE
                      then (printout PROMPTWINDOW "[Sending " FILE " to " PRETTYDEST "...]" T)
                            (LET [(POSTSCRIPTSTRING (LISTGET PRINTOPTIONS 'POSTSCRIPT.CONTROL.STRING]
                                 (PRIN1 (GET HOST 'HOST.CONTROL.STRING "")
                                        OUTFILE)
                                 (if POSTSCRIPTSTRING
                                     then (PRIN1 (CL:READ-LINE INFILE)
                                                     OUTFILE)
                                           (TERPRI OUTFILE)
                                           (PRIN1 POSTSCRIPTSTRING OUTFILE)))
                            (COPYBYTES INFILE OUTFILE)
                            (CLOSEF INFILE)
                            (PRIN1 (GET HOST 'HOST.CONTROL.AFTER.STRING "")
                                   OUTFILE)
                            (CLOSEF OUTFILE)
                            (printout PROMPTWINDOW "[Finished sending " FILE " to " PRETTYDEST ".]" T
                                   )
                    else (printout PROMPTWINDOW "[Unable to send " FILE " to " PRETTYDEST ".]" T])

(SUN.PS.SEND
  [LAMBDA (HOST FILE PRINTOPTIONS)                       (* ; "Edited 30-Dec-88 18:59 by demo")

    (* ;; "print a postscript file when you're on a sun.  The printoptions get
dropped for now.")

    [IF (NULL HOST)
        THEN (SETQ HOST (OR DEFAULTPRINTINGHOST (UNIX-GETENV "PRINTER"]
    (IF (LISTP HOST)
        THEN (SETQ HOST (CAR HOST)))
    (CL:UNLESS (STRINGP HOST)
        (L-CASE (MKSTRING HOST)))

    (* ;; "now we have a %"real%" host name for the printer")

    (CL:WITH-OPEN-STREAM [INSTREAM (OPENSTREAM FILE 'INPUT NIL '((TYPE TEXT)
                                                                 (SEQUENTIAL T]
           (CL:WITH-OPEN-STREAM (OUTSTREAM (CREATE-PROCESS-STREAM (CONCAT "/usr/ucb/lpr -P" HOST)))
                  (PRINTOUT PROMPTWINDOW "[Sending " FILE " to " HOST "...]" T)
                  (COPYBYTES INSTREAM OUTSTREAM)
                  (PRINTOUT PROMPTWINDOW "[Finished sending " FILE " to " HOST ".]" T])
)


(* ;; " %"load the unixcomm software if you are on a sun.")


(IF (EQ (MACHINETYPE)
            'MAIKO)
    THEN (FILESLOAD 'UNIXCOMM))

(PUTPROPS PS-SEND FILETYPE :TCOMPL)

(PUTPROPS PS-SEND MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP"))
(PUTPROPS PS-SEND COPYRIGHT ("Beckman Instruments, Inc" 1988 1989))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (894 5146 (POSTSCRIPT.SEND 904 . 4146) (SUN.PS.SEND 4148 . 5144)))))
STOP
\ No newline at end of file
diff --git a/lispusers/POSTSCRIPT/PS-SEND.TEDIT b/lispusers/POSTSCRIPT/PS-SEND.TEDIT
deleted file mode 100644
index 7ba8e008..00000000
Binary files a/lispusers/POSTSCRIPT/PS-SEND.TEDIT and /dev/null differ
diff --git a/lispusers/POSTSCRIPT/PS-SKETCH-PATCH b/lispusers/POSTSCRIPT/PS-SKETCH-PATCH
deleted file mode 100644
index 9e713a97..00000000
--- a/lispusers/POSTSCRIPT/PS-SKETCH-PATCH
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP")
(FILECREATED " 4-Aug-89 16:46:48" {DSK}<LISPFILES>LIBRARY>PS-SKETCH-PATCH.;1 25983  

      changes to%:  (VARS PS-SKETCH-PATCHCOMS)
                    (PROPS (PS-SKETCH-PATCH MAKEFILE-ENVIRONMENT))
                    (FNS FIX-SKETCH ADD.KNOWN.SKETCH.FONT NEW-SK-DECREASING-FONT-LIST 
                         NEW-SK-PICK-FONT NEW-SKETCHW-HARDCOPYFN \BUILDSLUGCSINFO \CREATECHARSET))


(* "
Copyright (c) 1989 by ENVOS Corporation.  All rights reserved.
")

(PRETTYCOMPRINT PS-SKETCH-PATCHCOMS)

(RPAQQ PS-SKETCH-PATCHCOMS ((FILES (SYSLOAD FROM LISPUSERS)
                                       SKETCH)
                                (FNS FIX-SKETCH ADD.KNOWN.SKETCH.FONT NEW-SK-DECREASING-FONT-LIST 
                                     NEW-SK-PICK-FONT NEW-SKETCHW-HARDCOPYFN)
                                
                                (* ;; 
                          "NOTE: to compile the following 2 functions you need EXPORTS.ALL loaded.")

                                (FNS \BUILDSLUGCSINFO \CREATECHARSET)
                                [VARS (SKETCH-PATCHES '((NEW-SK-PICK-FONT . SK.PICK.FONT)
                                                        (NEW-SK-DECREASING-FONT-LIST
                                                                           . SK.DECREASING.FONT.LIST)
                                                        (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN]
                                (ADDVARS (POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA)
                                                (TIMESROMAND . TIMESROMAN)
                                                (COURIER . COURIER)
                                                (GACHA . COURIER)
                                                (CLASSIC . TIMESROMAN)
                                                (MODERN . HELVETICA)
                                                (CREAM . HELVETICA)
                                                (TERMINAL . COURIER)
                                                (LOGO . HELVETICA)
                                                (MODERN . HELVETICA)))
                                (VARS (\KNOWN.SKETCH.FONTSIZES))
                                (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)
                                       POSTSCRIPT.FONT.CONVERSIONS)
                                
                                (* ;; "finally actually do the patching of sketch.")

                                (P (FIX-SKETCH))
                                (PROP (MAKEFILE-ENVIRONMENT FILETYPE)
                                      PS-SKETCH-PATCH)))

(FILESLOAD (SYSLOAD FROM LISPUSERS)
       SKETCH)
(DEFINEQ

(FIX-SKETCH
  [LAMBDA NIL                                     (* ; "Edited  7-Jul-89 19:40 by Matt Heffron")
    (COND
       ((BOUNDP 'ALL.SKETCHES)

        (* ;; "sketch is loaded")

        (for X in SKETCH-PATCHES do (MOVD (CAR X)
                                                      (CDR X)
                                                      NIL T))
        (PROMPTPRINT "Sketch has been patched!")
        T)
       (T (PROMPTPRINT "Sketch doesn't seem to be loaded!")
          (PROMPTPRINT "When you load sketch, make sure to call the function FIX-SKETCH!")
          NIL])

(ADD.KNOWN.SKETCH.FONT
  [LAMBDA (FAMILY WID DEVICE FONT)                       (* ; "Edited 21-Feb-89 15:06 by snow")

    (* ;; "add to the globally cached font list")

    (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES))
    (LET ((CACHE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES))
          (CACHED))
         (COND
            [(NULL CACHE)
             (if \KNOWN.SKETCH.FONTSIZES
                 then [NCONC1 \KNOWN.SKETCH.FONTSIZES (LIST FAMILY (LIST DEVICE (CONS WID FONT]
               else (SETQ \KNOWN.SKETCH.FONTSIZES (LIST (LIST FAMILY (LIST DEVICE
                                                                               (CONS WID FONT]
            (T (COND
                  ((SETQ CACHED (ASSOC DEVICE CACHE))
                   (NCONC1 CACHED (CONS WID FONT)))
                  (T (NCONC1 CACHE (CONS DEVICE (CONS WID FONT])

(NEW-SK-DECREASING-FONT-LIST
  [LAMBDA (FAMILY DEVICETYPE)                            (* ; "Edited 21-Feb-89 11:26 by snow")

    (* ;; "returns a list of fonts of family FAMILY which work on device DEVICETYPE")

    [COND
       ((NULL FAMILY)
        (SETQ FAMILY 'MODERN]

    (* ;; "convert to families that exist on the known devices.")

(* ;;; "NOTE: this is a very bad way to convert the family.  It HARDCODES in the conversions for PRESS and INTERPRESS  and does nothing for new device types.  I have added the conversion for POSTSCRIPT that does things a little cleaner, but it should really look at a property of the device (fontconversions or some such animal.)  --was 2/19/89")

    (LET ((CONVERSION))
         [COND
            [(EQ DEVICETYPE 'PRESS)
             (COND
                ((EQ FAMILY 'MODERN)
                 (SETQ FAMILY 'HELVETICA))
                ((EQ FAMILY 'CLASSIC)
                 (SETQ FAMILY 'TIMESROMAN))
                ((EQ FAMILY 'TERMINAL)
                 (SETQ FAMILY 'GACHA]
            [(EQ DEVICETYPE 'INTERPRESS)
             (COND
                ((EQ FAMILY 'HELVETICA)
                 (SETQ FAMILY 'MODERN))
                ((EQ FAMILY 'TIMESROMAN)
                 (SETQ FAMILY 'CLASSIC))
                ((EQ FAMILY 'GACHA)
                 (SETQ FAMILY 'TERMINAL]
            ((EQ DEVICETYPE 'POSTSCRIPT)
             (if (SETQ CONVERSION (ASSOC FAMILY POSTSCRIPT.FONT.CONVERSIONS))
                 then 

                       (* ;; 
                  "convert the family here for postscript as well as the other well known devices.")

                       (SETQ FAMILY (CDR CONVERSION]
         (for FONT in (SK.GUESS.FONTSAVAILABLE FAMILY DEVICETYPE)
            collect (FONTCOPY FONT 'DEVICE DEVICETYPE])

(NEW-SK-PICK-FONT
  [LAMBDA (WID STRING DEVICE FAMILY)                     (* ; "Edited 22-Feb-89 07:53 by snow")

    (* ;; "returns the font in FAMILY that text should be printed in to have the text STRING fit into a region WID points wide")

    (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES))
    (PROG (LASTFONT LASTSIZE DISPLAYFONT SCALE CACHEDFONT)
          (IF [SETQ CACHEDFONT (ASSOC WID (ASSOC DEVICE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES]
              THEN (RETURN (CDR CACHEDFONT)))
          (RETURN (for FONT in (SK.DECREASING.FONT.LIST FAMILY DEVICE)
                     when (NOT (GREATERP [SETQ LASTSIZE (COND
                                                               ((SETQ SCALE (FONTPROP FONT
                                                                                   'SCALE))

                                                                (* ;; 
                                                    "IF THERE IS A SCALE, YOU MUST SCALE THE FONT.")

                                                                (QUOTIENT (STRINGWIDTH STRING FONT)
                                                                       SCALE))
                                                               ((SETQ DISPLAYFONT (FONTCOPY
                                                                                   (SETQ LASTFONT 
                                                                                    FONT)
                                                                                   'DEVICE
                                                                                   'DISPLAY
                                                                                   'NOERROR T))
                                                             (* ; "use display if it exists.")
                                                                (STRINGWIDTH STRING DISPLAYFONT))
                                                               (T 
                                                             (* ; 
                                       "in some cases, font exists for devices other than display.")
                                                                  (QUOTIENT (STRINGWIDTH STRING FONT)
                                                                         (FONTPROP FONT 'SCALE]
                                          WID)) do       (* ; 
       "return a font for the proper device even though the display fonts are used to pick a size.")
                                                      (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE
                                                             (FONTCOPY FONT 'DEVICE DEVICE))
                                                      (RETURN (FONTCOPY FONT 'DEVICE DEVICE))
                     finally (RETURN (COND
                                            ((OR (NULL LASTFONT)
                                                 (GREATERP LASTSIZE (TIMES 1.5 WID)))
                                             'SHADE)
                                            (T               (* ; 
                                                          "use the smallest if it isn't too large.")
                                               (FONTCOPY LASTFONT 'DEVICE DEVICE])

(NEW-SKETCHW-HARDCOPYFN
  [LAMBDA (SKETCHW OPENIMAGESTREAM)               (* ; "Edited 27-Jul-89 17:52 by Matt Heffron")
                                                             (* ; 
                                                           "dumps the sketch onto OPENIMAGESTREAM.")
                                                             (* ; 
                                       "centers it within the DSPCLIPPINGREGION of OPENIMAGESTREAM")
    (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW)))
           (PAGEREGION (DSPCLIPPINGREGION NIL OPENIMAGESTREAM))
           (SKETCHREGION (SKETCH.REGION.VIEWED SKETCHW))
           (SCALE (VIEWER.SCALE SKETCHW))
           SKETCHREGIONINPAGECOORDS PAGELEFTSPACE PAGEBOTTOMSPACE PAGETOSKETCHFACTOR SKETCHX)
          (OR SKETCH (RETURN))
          (SPAWN.MOUSE)

     (* ;; "move the margins out of the way")

          (DSPLEFTMARGIN (MIN 0 (fetch (REGION LEFT) of PAGEREGION))
                 OPENIMAGESTREAM)
          (DSPBOTTOMMARGIN (MIN 0 (fetch (REGION BOTTOM) of PAGEREGION))
                 OPENIMAGESTREAM)
          (DSPTOPMARGIN (MAX (ITIMES MAX.SMALLP MAX.SMALLP)
                             (fetch (REGION TOP) of PAGEREGION))
                 OPENIMAGESTREAM)                            (* ; 
                                                           "MAX.SMALLP^2 ought to be big enough...")
          (DSPRIGHTMARGIN (MAX (ITIMES MAX.SMALLP MAX.SMALLP)
                               (fetch (REGION RIGHT) of PAGEREGION))
                 OPENIMAGESTREAM)

     (* ;; "PAGETOSKETCHFACTOR is the factor to multiply the page coordinates by to get into sketch coordinates.")

          (STATUSPRINT SKETCHW "Hardcopying ...")
          [STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS (APPEND (LIST 'DOCUMENT.NAME (OR (SKETCH.TITLE
                                                                                      SKETCHW)
                                                                                     "A Sketch"))
                                                           (STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS]
          (SETQ PAGETOSKETCHFACTOR (FQUOTIENT SCALE (DSPSCALE NIL OPENIMAGESTREAM)))
          (SETQ SKETCHREGIONINPAGECOORDS (SCALE.REGION.OUT SKETCHREGION PAGETOSKETCHFACTOR))
          (COND
             ((AND (NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM)
                            'PRESS))
                   (NOT (EQ (FETCH (IMAGEOPS IMROTATE) OF (FETCH (STREAM IMAGEOPS)
                                                                     OF OPENIMAGESTREAM))
                            'NILL))
                   (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS)
                          (fetch WIDTH of PAGEREGION))
                   (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS)
                          (fetch HEIGHT of SKETCHREGIONINPAGECOORDS)))

              (* ;; "we have a  stream that supports rotation, use it!")

              (DSPROTATE 90 OPENIMAGESTREAM)
              (COND
                 ((NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM)
                           'POSTSCRIPT))

                  (* ;; "Since PostScript's DSPROTATE does the translate also..., dont't do it here. --HACK! HACK! HACK! --Matt.")

                  (DSPTRANSLATE 0 (MINUS (FETCH (REGION HEIGHT) OF PAGEREGION))
                         OPENIMAGESTREAM)))
              (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION))
                     OPENIMAGESTREAM)

              (* ;; "(ROTATE.IP OPENIMAGESTREAM 90) (CONCATT.IP OPENIMAGESTREAM) (TRANSLATE.IP OPENIMAGESTREAM 0 -21590) (CONCATT.IP OPENIMAGESTREAM) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM)")

              (* ;; "this was an incredibly bogus hack to make INTERPRESS only streams rotate the sketch image if they were too big.  Now it tries to do it on any stream that has a dsprotate function.")

              ))
          (SETQ PAGELEFTSPACE (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION)
                                               (fetch (REGION WIDTH) of 
                                                                             SKETCHREGIONINPAGECOORDS
                                                      ))
                                     2))
          (SETQ PAGEBOTTOMSPACE (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION)
                                                 (fetch (REGION HEIGHT) of 
                                                                             SKETCHREGIONINPAGECOORDS
                                                        ))
                                       2))

     (* ;; "translate the sketch so that the lower left corner of the sketch region is at the lower left corner of the image on the page.")

          [SETQ SKETCHX (TRANSLATE.SKETCH SKETCH (MINUS (TIMES (DIFFERENCE
                                                                (SETQ PAGELEFTSPACE
                                                                 (PLUS (fetch (REGION LEFT)
                                                                          of PAGEREGION)
                                                                       PAGELEFTSPACE))
                                                                (fetch (REGION LEFT) of
                                                                                         
                                                                             SKETCHREGIONINPAGECOORDS
                                                                       ))
                                                               PAGETOSKETCHFACTOR))
                               (MINUS (TIMES (DIFFERENCE (SETQ PAGEBOTTOMSPACE
                                                          (PLUS (fetch (REGION BOTTOM)
                                                                   of PAGEREGION)
                                                                PAGEBOTTOMSPACE))
                                                    (fetch (REGION BOTTOM) of 
                                                                             SKETCHREGIONINPAGECOORDS
                                                           ))
                                             PAGETOSKETCHFACTOR]
                                                             (* ; 
                                             "calculate the local parts for the interpress sketch.")
          (SETQ SKETCHX (MAKE.LOCAL.SKETCH SKETCHX (CREATEREGION (TIMES PAGELEFTSPACE 
                                                                        PAGETOSKETCHFACTOR)
                                                          (TIMES PAGEBOTTOMSPACE PAGETOSKETCHFACTOR)
                                                          (fetch (REGION WIDTH) of 
                                                                                         SKETCHREGION
                                                                 )
                                                          (fetch (REGION HEIGHT) of 
                                                                                         SKETCHREGION
                                                                 ))
                               PAGETOSKETCHFACTOR OPENIMAGESTREAM))
          (DRAW.LOCAL.SKETCH SKETCHX OPENIMAGESTREAM (CREATEREGION PAGELEFTSPACE PAGEBOTTOMSPACE
                                                            (fetch (REGION WIDTH) of 
                                                                             SKETCHREGIONINPAGECOORDS
                                                                   )
                                                            (fetch (REGION HEIGHT) of 
                                                                             SKETCHREGIONINPAGECOORDS
                                                                   )))
          (STATUSPRINT SKETCHW " done.")
          (RETURN OPENIMAGESTREAM])
)



(* ;; "NOTE: to compile the following 2 functions you need EXPORTS.ALL loaded.")

(DEFINEQ

(\BUILDSLUGCSINFO
  [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE)            (* ; "Edited 14-Feb-89 16:46 by snow")

(* ;;; "builds a csinfo which contains only the slug (black rectangle) character")

    (SETQ SCALE (OR SCALE 1))
    (PROG ((CSINFO (create CHARSETINFO
                          CHARSETASCENT _ ASCENT
                          CHARSETDESCENT _ DESCENT
                          IMAGEWIDTHS _ (\CREATECSINFOELEMENT)))
           WIDTHS OFFSETS BITMAP IMAGEWIDTHS)
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
          (SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
          [SELECTQ DEVICE
              (INTERPRESS                                    (* ; 
                                                           "don't need offsets in INTERPRESS fonts")
                          NIL)
              (PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS (
                                                                                 \CREATECSINFOELEMENT
                                                                                              )))
                     (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
                     [replace (CHARSETINFO CHARSETBITMAP) of CSINFO
                        with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE))
                                                     (ROUND (QUOTIENT (IPLUS ASCENT DESCENT)
                                                                   SCALE]
                     (BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE]
          (RETURN CSINFO])

(\CREATECHARSET
  [LAMBDA (CHARSET FONT NOSLUG?)                         (* ; "Edited 14-Feb-89 16:29 by snow")

    (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR")
                                                             (* ; 
  "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")
    (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES))
    (AND (IGREATERP CHARSET \MAXCHARSET)
         (\ILLEGAL.ARG CHARSET))
    (PROG (CSINFO CREATEFN)

     (* ;; "For other charsets, create a font descriptor of info for that charset, and use it to fill things in.")

          (if (OR (AND (IGEQ CHARSET 1)
                           (ILEQ CHARSET 32))
                      (AND (IGEQ CHARSET 127)
                           (ILEQ CHARSET 160)))
              then 

                    (* ;; "this is an illegal NS character set (reserved for control codes) so just return a slug (unless NOSLUG?  is T)")

                    [if NOSLUG?
                        then (RETURN NIL)
                      else (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR 
                                                                                    FONTAVGCHARWIDTH)
                                                                     of FONT)
                                                   (FONTPROP FONT 'ASCENT)
                                                   (FONTPROP FONT 'DESCENT)
                                                   (FONTPROP FONT 'DEVICE)
                                                   (FONTPROP FONT 'SCALE]
            else [SETQ CREATEFN (COND
                                       ((FMEMB (FONTPROP FONT 'DEVICE)
                                               \DISPLAYSTREAMTYPES)
                                        (FUNCTION \CREATECHARSET.DISPLAY))
                                       (T (CADR (ASSOC 'CREATECHARSET
                                                       (CDR (ASSOC (FONTPROP FONT 'DEVICE)
                                                                   IMAGESTREAMTYPES]
                  [if [NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC)
                                                                   (LIST CHARSET FONT NOSLUG?]
                      then                               (* ; 
         "the create method returned NIL.  so if NOSLUG?  return NIL else build a slug charsetinfo")
                            (RETURN (if NOSLUG?
                                        then             (* ; 
                                  "the caller just wants NIL back to signal that nothing was found")
                                              NIL
                                      else (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR
                                                                                 FONTAVGCHARWIDTH)
                                                                        of FONT)
                                                      (FONTPROP FONT 'ASCENT)
                                                      (FONTPROP FONT 'HEIGHT)
                                                      (FONTPROP FONT 'DEVICE)
                                                      (FONTPROP FONT 'SCALE]
                  (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of
                                                                                         FONT)
                                                                    (fetch CHARSETASCENT
                                                                       of CSINFO)))
                  (replace \SFDescent of FONT with (IMAX (fetch \SFDescent
                                                                        of FONT)
                                                                     (ffetch CHARSETDESCENT
                                                                        of CSINFO)))
                  (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent
                                                                        of FONT)
                                                                     (ffetch \SFDescent
                                                                        of FONT))) 
                                                             (* ; 
                              "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)")
                 )
          (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
                         CHARSET CSINFO])
)

(RPAQQ SKETCH-PATCHES ((NEW-SK-PICK-FONT . SK.PICK.FONT)
                           (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST)
                           (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN)))

(ADDTOVAR POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA)
                                          (TIMESROMAND . TIMESROMAN)
                                          (COURIER . COURIER)
                                          (GACHA . COURIER)
                                          (CLASSIC . TIMESROMAN)
                                          (MODERN . HELVETICA)
                                          (CREAM . HELVETICA)
                                          (TERMINAL . COURIER)
                                          (LOGO . HELVETICA)
                                          (MODERN . HELVETICA))

(RPAQQ \KNOWN.SKETCH.FONTSIZES NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)
       POSTSCRIPT.FONT.CONVERSIONS)
)



(* ;; "finally actually do the patching of sketch.")


(FIX-SKETCH)

(PUTPROPS PS-SKETCH-PATCH MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP"))

(PUTPROPS PS-SKETCH-PATCH FILETYPE :TCOMPL)
(PUTPROPS PS-SKETCH-PATCH COPYRIGHT ("ENVOS Corporation" 1989))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2758 17798 (FIX-SKETCH 2768 . 3382) (ADD.KNOWN.SKETCH.FONT 3384 . 4261) (
NEW-SK-DECREASING-FONT-LIST 4263 . 6087) (NEW-SK-PICK-FONT 6089 . 9471) (NEW-SKETCHW-HARDCOPYFN 9473
 . 17796)) (17888 24660 (\BUILDSLUGCSINFO 17898 . 19796) (\CREATECHARSET 19798 . 24658)))))
STOP
\ No newline at end of file
diff --git a/lispusers/POSTSCRIPT/PS-SKETCH-PATCH.TEDIT b/lispusers/POSTSCRIPT/PS-SKETCH-PATCH.TEDIT
deleted file mode 100644
index 2a0f2937..00000000
Binary files a/lispusers/POSTSCRIPT/PS-SKETCH-PATCH.TEDIT and /dev/null differ
diff --git a/lispusers/POSTSCRIPT/PS-TTY b/lispusers/POSTSCRIPT/PS-TTY
deleted file mode 100644
index bc4747d1..00000000
--- a/lispusers/POSTSCRIPT/PS-TTY
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 2-Aug-89 13:43:41" {DSK}<LISPFILES>PS>PS-TTY.;10 2608   

      changes to%:  (PROPS (PS-TTY MAKEFILE-ENVIRONMENT))
                    (VARS PS-TTYCOMS)

      previous date%: " 6-Sep-88 17:09:36" {DSK}<LISPFILES>PS>PS-TTY.;9)


(* "
Copyright (c) 1988, 1989 by Beckman Instruments, Inc.  All rights reserved.
")

(PRETTYCOMPRINT PS-TTYCOMS)

(RPAQQ PS-TTYCOMS ((FILES POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS)
                              DLTTY)
                       (INITVARS (PS-TTY-BAUD 4800)
                              (PS-TTY-DATABITS 8)
                              (PS-TTY-PARITY 'NONE)
                              (PS-TTY-STOPBITS 1)
                              (PS-TTY-FLOWCONTROL 'XOnXOff))
                       (FNS PS-TTY-AFTERLOGOUT PS-TTY-INIT)
                       (ADDVARS (DEFAULTPRINTINGHOST PS-TTY)
                              (AROUNDEXITFNS PS-TTY-AFTERLOGOUT))
                       (P (PS-TTY-INIT))
                       (PROP (MAKEFILE-ENVIRONMENT PRINTERTYPE SPOOLFILE)
                             PS-TTY)))

(FILESLOAD POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS)
       DLTTY)

(RPAQ? PS-TTY-BAUD 4800)

(RPAQ? PS-TTY-DATABITS 8)

(RPAQ? PS-TTY-PARITY 'NONE)

(RPAQ? PS-TTY-STOPBITS 1)

(RPAQ? PS-TTY-FLOWCONTROL 'XOnXOff)
(DEFINEQ

(PS-TTY-AFTERLOGOUT
  [LAMBDA (EVENT)                                     (* ; "Edited 19-Apr-88 13:25 by Matt Heffron")

    (if (EQ EVENT 'AFTERLOGOUT)
        then (TTY.INIT PS-TTY-BAUD PS-TTY-DATABITS PS-TTY-PARITY PS-TTY-STOPBITS PS-TTY-FLOWCONTROL])

(PS-TTY-INIT
  [LAMBDA NIL                                         (* ; "Edited 19-Apr-88 13:24 by Matt Heffron")

    [PUTPROP 'PS-TTY 'SPOOLOPTIONS `((BaudRate ,PS-TTY-BAUD)
                                     (BitsPerSerialChar ,PS-TTY-DATABITS)
                                     (Parity ,PS-TTY-PARITY)
                                     (NoOfStopBits ,PS-TTY-STOPBITS)
                                     (FlowControl ,PS-TTY-FLOWCONTROL]
    (PS-TTY-AFTERLOGOUT 'AFTERLOGOUT)                        (* ; "Fake it")

    NIL])
)

(ADDTOVAR DEFAULTPRINTINGHOST PS-TTY)

(ADDTOVAR AROUNDEXITFNS PS-TTY-AFTERLOGOUT)

(PS-TTY-INIT)

(PUTPROPS PS-TTY MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))

(PUTPROPS PS-TTY PRINTERTYPE POSTSCRIPT)

(PUTPROPS PS-TTY SPOOLFILE "{TTY}FOO.PS")
(PUTPROPS PS-TTY COPYRIGHT ("Beckman Instruments, Inc" 1988 1989))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1377 2224 (PS-TTY-AFTERLOGOUT 1387 . 1662) (PS-TTY-INIT 1664 . 2222)))))
STOP
\ No newline at end of file
diff --git a/lispusers/POSTSCRIPT/PS-TTY.TEDIT b/lispusers/POSTSCRIPT/PS-TTY.TEDIT
deleted file mode 100644
index 64d24852..00000000
Binary files a/lispusers/POSTSCRIPT/PS-TTY.TEDIT and /dev/null differ
diff --git a/lispusers/POSTSCRIPT/PS-patch.tedit b/lispusers/POSTSCRIPT/PS-patch.tedit
deleted file mode 100644
index e5e51519..00000000
Binary files a/lispusers/POSTSCRIPT/PS-patch.tedit and /dev/null differ
diff --git a/lispusers/POSTSCRIPT/PSCFONT-FIX-FILENAME b/lispusers/POSTSCRIPT/PSCFONT-FIX-FILENAME
deleted file mode 100644
index e699ca4b..00000000
--- a/lispusers/POSTSCRIPT/PSCFONT-FIX-FILENAME
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "11-May-87 16:33:49" {DSK}<LISPFILES>PS>PSCFONT-FIX-FILENAME.\;1 5877   

      |changes| |to:|  (VARS PSCFONT-FIX-FILENAMECOMS)
                       (FNS PSCFONT-FILENAME-FIX)
                       (FILEVARS PSCFONT-FIX-FILENAMECOMS))


; Copyright (c) 1987 by Beckman Instruments, Inc.  All rights reserved.

(PRETTYCOMPRINT PSCFONT-FIX-FILENAMECOMS)

(RPAQQ PSCFONT-FIX-FILENAMECOMS ((FNS PSCFONT-FILENAME-FIX)
                                 (VARS POSTSCRIPT-FONT-FILENAME-FIXLIST)))
(DEFINEQ

(PSCFONT-FILENAME-FIX
  (LAMBDA NIL                                        (* \; "Edited 11-May-87 15:34 by Matt Heffron")

    (FOR D IN POSTSCRIPTFONTDIRECTORIES
       DO (FOR F IN POSTSCRIPT-FONT-FILENAME-FIXLIST
             DO (LET (FN)
                     (CL:WHEN (SETQ FN (INFILEP (CONCAT D (CAR F))))
                            (PRINTOUT T FN " => " (RENAMEFILE FN (CONCAT D (\\FONTFILENAME
                                                                            (CADR F)
                                                                            1
                                                                            (CADDR F)
                                                                            '.PSCFONT)))
                                   T)))))))
)

(RPAQQ POSTSCRIPT-FONT-FILENAME-FIXLIST (("AVANTGARDE-BOOK1" AVANTGARDE-BOOK (MEDIUM REGULAR REGULAR)
                                                )
                                         ("AVANTGARDE-BOOK1I" AVANTGARDE-BOOK (MEDIUM ITALIC REGULAR)
                                                )
                                         ("AVANTGARDE-DEMI1" AVANTGARDE-DEMI (MEDIUM REGULAR REGULAR)
                                                )
                                         ("AVANTGARDE-DEMI1I" AVANTGARDE-DEMI (MEDIUM ITALIC REGULAR)
                                                )
                                         ("BOOKMAN-DEMI1" BOOKMAN-DEMI (MEDIUM REGULAR REGULAR))
                                         ("BOOKMAN-DEMI1I" BOOKMAN-DEMI (MEDIUM ITALIC REGULAR))
                                         ("BOOKMAN-LIGHT1" BOOKMAN-LIGHT (MEDIUM REGULAR REGULAR))
                                         ("BOOKMAN-LIGHT1I" BOOKMAN-LIGHT (MEDIUM ITALIC REGULAR))
                                         ("COURIER1" COURIER (MEDIUM REGULAR REGULAR))
                                         ("COURIER1B" COURIER (BOLD REGULAR REGULAR))
                                         ("COURIER1BI" COURIER (BOLD ITALIC REGULAR))
                                         ("COURIER1I" COURIER (MEDIUM ITALIC REGULAR))
                                         ("HELVETICA-NARROW1" HELVETICA-NARROW (MEDIUM REGULAR 
                                                                                      REGULAR))
                                         ("HELVETICA-NARROW1B" HELVETICA-NARROW (BOLD REGULAR REGULAR
                                                                                      ))
                                         ("HELVETICA-NARROW1BI" HELVETICA-NARROW (BOLD ITALIC REGULAR
                                                                                       ))
                                         ("HELVETICA-NARROW1I" HELVETICA-NARROW (MEDIUM ITALIC 
                                                                                       REGULAR))
                                         ("HELVETICA1" HELVETICA (MEDIUM REGULAR REGULAR))
                                         ("HELVETICA1B" HELVETICA (BOLD REGULAR REGULAR))
                                         ("HELVETICA1BI" HELVETICA (BOLD ITALIC REGULAR))
                                         ("HELVETICA1I" HELVETICA (MEDIUM ITALIC REGULAR))
                                         ("NEWCENTURYSCHLBK1" NEWCENTURYSCHLBK (MEDIUM REGULAR 
                                                                                      REGULAR))
                                         ("NEWCENTURYSCHLBK1B" NEWCENTURYSCHLBK (BOLD REGULAR REGULAR
                                                                                      ))
                                         ("NEWCENTURYSCHLBK1BI" NEWCENTURYSCHLBK (BOLD ITALIC REGULAR
                                                                                       ))
                                         ("NEWCENTURYSCHLBK1I" NEWCENTURYSCHLBK (MEDIUM ITALIC 
                                                                                       REGULAR))
                                         ("PALATINO1" PALATINO (MEDIUM REGULAR REGULAR))
                                         ("PALATINO1B" PALATINO (BOLD REGULAR REGULAR))
                                         ("PALATINO1BI" PALATINO (BOLD ITALIC REGULAR))
                                         ("PALATINO1I" PALATINO (MEDIUM ITALIC REGULAR))
                                         ("SYMBOL1" SYMBOL (MEDIUM REGULAR REGULAR))
                                         ("TIMES1" TIMES (MEDIUM REGULAR REGULAR))
                                         ("TIMES1B" TIMES (BOLD REGULAR REGULAR))
                                         ("TIMES1BI" TIMES (BOLD ITALIC REGULAR))
                                         ("TIMES1I" TIMES (MEDIUM ITALIC REGULAR))
                                         ("ZAPFCHANCERY-MEDIUM1I" ZAPFCHANCERY-MEDIUM
                                                (MEDIUM REGULAR REGULAR))
                                         ("ZAPFCHANCERY1I" ZAPFCHANCERY (MEDIUM ITALIC REGULAR))
                                         ("ZAPFDINGBATS1" ZAPFDINGBATS (MEDIUM REGULAR REGULAR))))
(PUTPROPS PSCFONT-FIX-FILENAME COPYRIGHT ("Beckman Instruments, Inc" 1987))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (572 1404 (PSCFONT-FILENAME-FIX 582 . 1402)))))
STOP
\ No newline at end of file
diff --git a/lispusers/POSTSCRIPT/PS-SKETCH-PATCH.LCOM b/lispusers/PS-SKETCH-PATCH.LCOM
similarity index 100%
rename from lispusers/POSTSCRIPT/PS-SKETCH-PATCH.LCOM
rename to lispusers/PS-SKETCH-PATCH.LCOM
diff --git a/internal/library/DICOLOR b/obsolete/internal/library/DICOLOR
similarity index 100%
rename from internal/library/DICOLOR
rename to obsolete/internal/library/DICOLOR
diff --git a/internal/library/DICOLOR.LCOM b/obsolete/internal/library/DICOLOR.LCOM
similarity index 100%
rename from internal/library/DICOLOR.LCOM
rename to obsolete/internal/library/DICOLOR.LCOM
diff --git a/lispusers/POSTSCRIPT-old/POSTSCRIPT b/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT
similarity index 100%
rename from lispusers/POSTSCRIPT-old/POSTSCRIPT
rename to obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT
diff --git a/lispusers/POSTSCRIPT-old/POSTSCRIPT.PS b/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT.PS
similarity index 100%
rename from lispusers/POSTSCRIPT-old/POSTSCRIPT.PS
rename to obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT.PS
diff --git a/lispusers/POSTSCRIPT-old/PostScript.TEDIT b/obsolete/lispusers/POSTSCRIPT-old/PostScript.TEDIT
similarity index 100%
rename from lispusers/POSTSCRIPT-old/PostScript.TEDIT
rename to obsolete/lispusers/POSTSCRIPT-old/PostScript.TEDIT
