(FILECREATED "24-JUN-83 11:33:59" {PHYLUM}<LISPUSERS>DRAWFILE.;13
 15019  

      changes to:  (VARS DRAWFILECOMS)

      previous date: "24-JUN-83 11:32:59" {PHYLUM}<LISPUSERS>DRAWFILE.;12)


(* Copyright (c) 1982, 1983 by Xerox Corporation)

(PRETTYCOMPRINT DRAWFILECOMS)

(RPAQQ DRAWFILECOMS
 [(E (RESETSAVE CLISPIFYPRETTYFLG NIL))
		     (FNS BCPLFLIN BCPLFLOUT BCPLSIN BCPLSINTIN BCPLSOUT READDRAW READKNOTS SHOWCURVE 
			  WRITECURVEHEADER WRITECURVES WRITEDRAW WRITEDRAWCOUNT WRITETEXTS)
		     (VARS DEFAULTDRAWFONTS DEFAULTDASHING)
		     (BLOCKS (READDRAW READDRAW READKNOTS BCPLFLIN BCPLSIN BCPLSINTIN)
			     (WRITEDRAW WRITEDRAW BCPLFLOUT BCPLSOUT WRITECURVEHEADER WRITECURVES 
					WRITEDRAWCOUNT WRITETEXTS))
		     (DECLARE: DONTCOPY (EXPORT (RECORDS CURVE TEXT PELT))
			       (RECORDS DRAWCURVEHEADERBYTE1 DRAWCURVEHEADERBYTE2 
					DRAWCURVEHEADERWORD2)
			       (DECLARE: EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
							       (QUOTE D))
					 (PROP 10MACRO \BIN \BOUT \WIN \WOUT)
					 (DECLARE: DONTEVAL@LOAD (FILES (SYSLOAD FROM VALUEOF 
									     LISPUSERSDIRECTORIES)
									CJSYS)))
			       (DECLARE: EVAL@COMPILEWHEN (EQ (COMPILEMODE)
							      (QUOTE D))
					 (PROP DMACRO \WIN \WOUT])
(DEFINEQ

(BCPLFLIN

  [LAMBDA (OFD)                                        (* DECLARATIONS: (BLOCKRECORD FNUM ((LH BITS 16) 

						       (RH BITS 16))))

                                                       (* rmk: " 6-NOV-81 10:52")

                                                       (* Reads a BCPL floating point number.

						       2 words are read)

    (PROG (FNUM (LH (\WIN OFD))
		(RH (\WIN OFD)))
          (SELECTQ (SYSTEMTYPE)
		   ((TENEX TOPS20)
		     (SETQ FNUM (FPLUS 0.0))
		     (replace
 LH of
 FNUM with
 LH)
		     (replace
 RH of
 FNUM with
 RH))
		   [(D ALTO)
		     (SETQ FNUM (BCPL.TO.FLOATP (LOGOR (LLSH LH 16)
						       RH]
		   (HELP))
          (RETURN FNUM])

(BCPLFLOUT

  [LAMBDA (OFD FNUM)                                   (* rmk: " 6-NOV-81 10:09")

                                                       (* Prints FNUM on OFD as a BCPL floating point number.

						       2 words are printed)

    (SELECTQ (SYSTEMTYPE)
	     ((TENEX TOPS20)
	       (SETQ FNUM (FLOAT FNUM))
	       (\WOUT OFD (LRSH (OPENR (LOC FNUM))
				20))                   (* Treat FNUM as integer bits but ignore the low-order 4 bits)

	       (\WOUT OFD (LOGAND (LRSH (OPENR (LOC FNUM))
					4)
				  65535)))
	     ((D ALTO)
	       (SETQ FNUM (FLOATP.TO.BCPL FNUM))
	       (\WOUT OFD (LRSH FNUM 16))
	       (\WOUT OFD (LOGAND FNUM 65535)))
	     (HELP])

(BCPLSIN

  [LAMBDA (OFD)                                        (* rmk: " 6-NOV-81 10:25")

                                                       (* Reads a BCPL string from OFD. The first byte is the number of 

						       characters to include. Reads an even number of bytes.)

    (APPLY (FUNCTION CONCAT)
	   (for
 I NC from
 (\BIN OFD) to
 1 by
 -1 first
 (SETQ NC I) collect
 (FCHARACTER (\BIN OFD))
	      finally
 (if
 (ZEROP (LOGAND NC 1))
			  then
 (\BIN OFD])

(BCPLSINTIN

  [LAMBDA (OFD)                                        (* rmk: " 6-NOV-81 10:07")

                                                       (* Reads a signed 16-bit integer from OFD.)

    (PROG ((INT (\WIN OFD)))
          (RETURN (if
 (ZEROP (LOGAND INT 32768))
		      then
 INT
		    else
 (LOGOR INT (CONSTANT (LOGXOR -1 (SUB1 (LLSH 1 16])

(BCPLSOUT

  [LAMBDA (OFD STRING)                                 (* rmk: " 6-NOV-81 10:28")

                                                       (* Writes a BCPL string on OFD. Puts out an even number of bytes.)

    (for
 I (NC ←(NCHARS STRING)) from
 1 first
 (\BOUT OFD NC)
       do
 (\BOUT OFD (if
 (NTHCHARCODE STRING I)
		       else
 (if
 (ZEROP (LOGAND NC 1))
				then
 (\BOUT OFD 0))
			    (RETURN])

(READDRAW

  [LAMBDA (FILE FONTS DASHING)                               (* lmm "22-JUN-83 23:00")

    (DECLARE
 (GLOBALVARS DEFAULTDRAWFONTS DEFAULTDASHING))
    (COND
      ((NOT FONTS)
	(SETQ FONTS DEFAULTDRAWFONTS)))
    (COND
      ((NOT DASHING)
	(SETQ DASHING DEFAULTDASHING)))
    (RESETLST
      [RESETSAVE (SETQ FILE (OPENFILE (PACKFILENAME (QUOTE BODY)
						    FILE
						    (QUOTE EXTENSION)
						    (QUOTE DRAW))
				      (QUOTE INPUT)
				      (QUOTE OLD)
				      8))
		 (QUOTE (PROGN (CLOSEF OLDVALUE]
      (PROG [P M TT (OFD (SELECTQ (SYSTEMTYPE)
				  ((TENEX TOPS20)
				    (OPNJFN FILE (QUOTE INPUT)))
				  (\GETOFD FILE (QUOTE INPUT]
	    (PROGN (PROGN 255 (\BIN OFD))
		   (PROGN 255 (\BIN OFD))
		   (PROGN 255 (\BIN OFD))
		   (PROGN 255 (\BIN OFD)))                   (* The two header words for the new DRAW format)

	    (SETQ M (\WIN OFD))
	    [SETQ P (for
 I BYTE WORD from
 1 to
 M
		       collect
 (SETQ BYTE (\BIN OFD))        (* First byte contains dashing, shape, and width)

			       (create
 PELT
				       PTYPE ←(QUOTE CURVE)
				       PBODY ←(create
 CURVE
						      DASHING ←(AND (fetch
 DASHFLAG of
 BYTE)
								    DASHING)
						      BRUSHSHAPE ←(SELECTQ (fetch
 SHAPEBITS
									      of
 BYTE)
									   (0 (QUOTE ROUND))
									   (1 (QUOTE SQUARE))
									   (2 (QUOTE HORIZONTAL))
									   (3 (QUOTE VERTICAL))
									   (4 (QUOTE DIAGONAL))
									   (SHOULDNT))
						      BRUSHWIDTH ←(LLSH 1 (fetch
 WIDTHBITS
									     of
 BYTE))
						      COLOR ←(fetch
 COLORBITS of
 (\BIN OFD))
						      CLOSE ←(fetch
 CLOSEFLAG of
 (SETQ WORD
										   (\WIN OFD)))
						      KNOTS ←(READKNOTS
 OFD (fetch
 NUMKNOTS
									       of
 WORD]
	    (SETQ TT (\WIN OFD))
	    (RETURN
	      (NCONC P (for
 I YPOS XPOS FONT CHARS from
 1 to
 TT
			  collect

			   (SETQ XPOS (BCPLSINTIN
 OFD))
			   (SETQ YPOS (BCPLSINTIN
 OFD)) 

          (* Adjust Y from upper-left to baseline, using individual character adjustments for the arrow font, otherwise a 

	  single number representing the ascent of the font.)



			   (create
 PELT
				   PTYPE ←(QUOTE TEXT)
				   PBODY ←(create

				     TEXT
				     FONT ←[CAR (SETQ FONT (CDR (ASSOC (\WIN OFD)
								       FONTS]
				     COLOR ←(\WIN OFD)
				     CHARACTERS ←(PROGN (\WIN OFD)
							(SETQ CHARS (BCPLSIN
 OFD)))
				     POSITION ←(create

				       POSITION
				       XCOORD ← XPOS
				       YCOORD ←(IDIFFERENCE YPOS
							    (OR [AND (EQ (NCHARS CHARS)
									 1)
								     (EQ (CAAR FONT)
									 (QUOTE ARROWS))
								     (CADR (ASSOC (CHCON1 CHARS)
										  (CDDR FONT]
								(CADR FONT])

(READKNOTS

  [LAMBDA (OFD NUM)                                    (* rmk: " 6-NOV-81 10:37")

                                                       (* Reads NUM knots from OFD, getting NUM X-coordinates, then NUM 

						       Y-coordinates)

    (PROG [(KS (for
 I from
 1 to
 NUM collect
 (create
 POSITION
						    XCOORD ←(BCPLFLIN
 OFD]
          (for
 K in
 KS do
 (replace
 YCOORD of
 K with
 (BCPLFLIN
 OFD)))
          (RETURN KS])

(SHOWCURVE

  [LAMBDA (CRV W)                                            (* lmm "22-JUN-83 23:09")

    (for
 X in
 CRV do
 (SELECTQ (CAR X)
			      (CURVE (DRAWCURVE (fetch
 KNOTS of
 (CDR X))
						(fetch
 CLOSE of
 (CDR X))
						(fetch
 BRUSH of
 (CDR X))
						(fetch
 DASHING of
 (CDR X))
						W))
			      (TEXT (MOVETO (fetch
 XCOORD of
 (fetch
 POSITION of
 (CDR X)))
					    (fetch
 YCOORD of
 (fetch
 POSITION of
 (CDR X)))
					    W)
				    (DSPFONT (FONTCREATE (fetch
 FONT of
 (CDR X)))
					     W)
				    (PRIN3 (fetch
 CHARACTERS of
 (CDR X))
					   W))
			      (POSITION (HELP))
			      (HELP])

(WRITECURVEHEADER

  [LAMBDA (OFD CURVE)                                        (* rmk: " 6-NOV-81 11:08")

                                                             (* Writes a draw curve header)

    [\BOUT OFD (create
 DRAWCURVEHEADERBYTE1
		       DASHFLAG ←(fetch
 DASHING of
 CURVE)
		       SHAPEBITS ←(SELECTQ (fetch
 BRUSHSHAPE of
 CURVE)
					   (ROUND 0)
					   (SQUARE 1)
					   (HORIZONTAL 2)
					   (VERTICAL 3)
					   (DIAGONAL 4)
					   (ERROR "illegal brush shape" (fetch
 BRUSHSHAPE
									   of
 CURVE)))
		       WIDTHBITS ←(LRSH 1 (fetch
 BRUSHWIDTH of
 CURVE]
    (\BOUT OFD (create
 DRAWCURVEHEADERBYTE2
		       COLORBITS ←(fetch
 COLOR of
 CURVE)))
    (\WOUT OFD (create
 DRAWCURVEHEADERWORD2
		       CLOSEFLAG ←(fetch
 CLOSE of
 CURVE)
		       NUMKNOTS ←(LENGTH (fetch
 KNOTS of
 CURVE])

(WRITECURVES

  [LAMBDA (FIGURE OFD)                                       (* rmk: " 6-NOV-81 11:34")

    (SELECTQ (fetch
 PTYPE of
 FIGURE)
	     [CURVE (PROG ((C (fetch
 PBODY of
 FIGURE)))      (* Put out the header)

		          (WRITECURVEHEADER
 OFD C)           (* Put out the coordinates, X's first)

		          (for
 K in
 (fetch
 KNOTS of
 C) do
 (BCPLFLOUT
 OFD (fetch
 XCOORD of
 K)))
		          (for
 K in
 (fetch
 KNOTS of
 C) do
 (BCPLFLOUT
 OFD (fetch
 YCOORD of
 K]
	     (TEXT)
	     (CIRCLE (printout
 T T "*** DRAW does not support CIRCLEs" T))
	     (ELLIPSE (printout
 T T "*** DRAW does not support ELLIPSEs" T))
	     (for
 PELT in
 FIGURE do
 (WRITECURVES
 PELT OFD])

(WRITEDRAW

  [LAMBDA (FILE FIGURE FONTS)                               (* rmk: "14-DEC-81 09:21")

    (DECLARE
 (GLOBALVARS DEFAULTDRAWFONTS))
    [PROG ((M 0)
	   (TT 0))
          (DECLARE
 (SPECVARS M TT))
          (WRITEDRAWCOUNT
 FIGURE)
          (RESETLST [RESETSAVE (SETQ FILE (OPENFILE (PACKFILENAME (QUOTE BODY)
								  FILE
								  (QUOTE EXTENSION)
								  (QUOTE DRAW))
						    (QUOTE OUTPUT)
						    (QUOTE NEW)
						    8))
			       (QUOTE (PROGN (CLOSEF OLDVALUE)
					     (AND RESETSTATE (DELFILE OLDVALUE]
		    (PROG [(OFD (SELECTQ (SYSTEMTYPE)
					 ((TENEX TOPS20)
					   (OPNJFN FILE (QUOTE OUTPUT)))
					 (\GETOFD FILE (QUOTE OUTPUT]
		          (\BOUT OFD 255)
		          (\BOUT OFD 255)
		          (\BOUT OFD 255)
		          (\BOUT OFD 255)                   (* The two header words for the new DRAW format)

		          (\WOUT OFD M)
		          (WRITECURVES
 FIGURE OFD)
		          (\WOUT OFD TT)
		          (WRITETEXTS
 FIGURE OFD (OR FONTS DEFAULTDRAWFONTS]
    FILE])

(WRITEDRAWCOUNT

  [LAMBDA (FIGURE)                                          (* rmk: "14-DEC-81 09:21")

                                                            (* Adds to global counts. Recursive cause of FIGURE 

							    groupings)

    (DECLARE
 (USEDFREE M TT))
    (if
 (LISTP FIGURE)
	then
 (SELECTQ FIGURE:PTYPE
		      (CURVE (add
 M 1))
		      (TEXT (add
 TT 1))
		      ((CIRCLE ELLIPSE))
		      (for
 PELT in
 FIGURE do
 (WRITEDRAWCOUNT
 PELT)))
      else
 (ERROR "not a figure" FIGURE])

(WRITETEXTS

  [LAMBDA (FIGURE OFD FONTS)                           (* rmk: " 6-NOV-81 10:19")

    (SELECTQ (fetch
 PTYPE of
 FIGURE)
	     (TEXT (PROG (FONT CHARS (TEXT (fetch
 PBODY of
 FIGURE)))
                                                       (* Put out the text strings -

						       headers first)

		         (SETQ FONT (OR (find
 X (F ←(fetch
 FONT of
 TEXT)) in
 FONTS
					   suchthat
 (EQUAL F (CADR X)))
					(ERROR "Unknown text font number" TEXT)))
		         (SETQ CHARS (fetch
 CHARACTERS of
 TEXT))
                                                       (* FONT and CHARS are used to adjust Y to top of box)

		         (\WOUT OFD (fetch
 XCOORD of
 (fetch
 POSITION of
 TEXT)))
		         [\WOUT OFD (IPLUS (fetch
 YCOORD of
 (fetch
 POSITION of
 TEXT))
					   (OR [AND (EQ 1 (NCHARS CHARS))
						    (EQ (CAADR FONT)
							(QUOTE ARROWS))
						    (CADR (ASSOC (CHCON1 CHARS)
								 (CDDDR FONT]
					       (CADDR FONT]
		         (\WOUT OFD (CAR FONT))
		         (\WOUT OFD (fetch
 COLOR of
 TEXT))
		         (\WOUT OFD (IPLUS 1 (LRSH (NCHARS (fetch
 CHARACTERS of
 TEXT))
						   1)))
                                                       (* Text header is now complete)

		         (BCPLSOUT
 OFD CHARS)))
	     (CURVE)
	     (for
 PELT in
 FIGURE do
 (WRITETEXTS
 PELT OFD FONTS])
)

(RPAQQ DEFAULTDRAWFONTS
 ((0 (HELVETICA 10)
			    10)
			 (1 (HELVETICA 12)
			    10)
			 (2 (HELVETICA 8)
			    7)
			 (3 (ARROWS 10)
			    5)))

(RPAQQ DEFAULTDASHING
 (8 8))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: READDRAW READDRAW READKNOTS BCPLFLIN BCPLSIN BCPLSINTIN)
(BLOCK: WRITEDRAW WRITEDRAW BCPLFLOUT BCPLSOUT WRITECURVEHEADER WRITECURVES WRITEDRAWCOUNT WRITETEXTS)
]
(DECLARE: DONTCOPY 
(* FOLLOWING DEFINITIONS EXPORTED)


[DECLARE: EVAL@COMPILE 

(RECORD CURVE
 (BRUSH COLOR CLOSE KNOTS DASHING)
	      (RECORD BRUSH (BRUSHSHAPE BRUSHWIDTH)))

(RECORD TEXT
 (FONT COLOR POSITION CHARACTERS))

(RECORD PELT
 (PTYPE . PBODY))
]


(* END EXPORTED DEFINITIONS)


[DECLARE: EVAL@COMPILE 

(ACCESSFNS DRAWCURVEHEADERBYTE1
 ([DASHFLAG (NOT (ZEROP (LOGAND DATUM 16]
				 (SHAPEBITS (LOGAND (LRSH DATUM 2)
						    3))
				 (WIDTHBITS (LOGAND DATUM 3)))
				(CREATE
 (LOGOR (COND
						 (DASHFLAG 16)
						 (T 0))
					       (LLSH (LOGAND SHAPEBITS 3)
						     2)
					       (LOGAND WIDTHBITS 3))))

(ACCESSFNS DRAWCURVEHEADERBYTE2
 ((COLORBITS (LOGAND DATUM 7)))
				(CREATE
 (LOGAND COLORBITS 7)))

(ACCESSFNS DRAWCURVEHEADERWORD2
 ([CLOSEFLAG (NOT (ZEROP (LOGAND DATUM 32768]
				 (NUMKNOTS (LOGAND DATUM 32767)))
				(CREATE
 (LOGOR (COND
						 (CLOSEFLAG 32768)
						 (T 0))
					       (LOGAND NUMKNOTS 32767))))
]

(DECLARE: EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
				(QUOTE D)) 

(PUTPROPS \BIN 10MACRO
 ((OFD)
			(JS BIN OFD NIL NIL 2)))

(PUTPROPS \BOUT 10MACRO
 ((OFD BYTE)
			 (JS BOUT OFD BYTE)))

(PUTPROPS \WIN 10MACRO
 [LAMBDA (OFD)
			       (LOGOR (LLSH (\BIN OFD)
					    8)
				      (\BIN OFD])

(PUTPROPS \WOUT 10MACRO
 [LAMBDA (OFD WORD)
				(\BOUT OFD (LOGAND (LRSH WORD 8)
						   255))
				(\BOUT OFD (LOGAND WORD 255])

(DECLARE: DONTEVAL@LOAD 
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
	   CJSYS)
)
)

(DECLARE: EVAL@COMPILEWHEN (EQ (COMPILEMODE)
			       (QUOTE D)) 

(PUTPROPS \WIN DMACRO
 (OPENLAMBDA (OFD)
				  (LOGOR (LLSH (\BIN OFD)
					       8)
					 (\BIN OFD))))

(PUTPROPS \WOUT DMACRO
 (OPENLAMBDA (OFD WORD)
				   (\BOUT OFD (LOGAND (LRSH WORD 8)
						      255))
				   (\BOUT OFD (LOGAND WORD 255))))
)
)
(PUTPROPS DRAWFILE COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1230 12681 (BCPLFLIN 1240 . 1970) (BCPLFLOUT 1972 . 2666) (BCPLSIN 2668 . 3182) (
BCPLSINTIN 3184 . 3557) (BCPLSOUT 3559 . 4006) (READDRAW 4008 . 6781) (READKNOTS 6783 . 7278) (
SHOWCURVE 7280 . 7976) (WRITECURVEHEADER 7978 . 8864) (WRITECURVES 8866 . 9654) (WRITEDRAW 9656 . 
10700) (WRITEDRAWCOUNT 10702 . 11252) (WRITETEXTS 11254 . 12679)))))
STOP