;;;; igraphics.lisp
;;;
;;; created 8/30/90 by Kevin Lynch
;;;
;;; This package allows the user to create postscript files from Lisp
;;; which will be accepted by the idraw program for editing.  
;;; Since it creates a postscript file, it can also just be printed out.  All 
;;; graphics for a given image are stored in an image data structure, 
;;; created by icreate-image, until the user is ready to save it either
;;; to an idraw formatted file or a file just to store the data
;;; structure.
;;;
;;; Every drawing function should update the image data structure;
;;; therefore, the data structure should be setq'ed to every drawing
;;; command.  If the image data structure is *image*, all igraphics
;;; drawing calls are of the form:
;;;
;;; (setq *image* (idraw-command *image* arg2 arg3 ...))
;;;
;;; Each drawing command takes the data structure, updates it, and 
;;; returns it.
;;;
;;; **NOTE** This code assumes the file "header.ps" is available in
;;; the following directory.  
;;; To change the directory to look for it, change the
;;; line below.  "header.ps" is just the header common to all idraw files,
;;; in double quotes (so it is read as one long string).

(let ((*header* "/home/lynch/lisp/header.ps")
      (*defwidth* 1)
      (*defarrow* 'none)
      (*defline* 'regular)
      (*deffill* 'none)
      (*deffont* 'courier-10)
      *units-per-inch* *lines* *linecodes* *fills* *fillcodes*
      *fonts* *fontcodes* *fontcomments* *scale* *maxcurvepts*)

(setq *scale* 0.1) ; scale relative to idraw definition

;; units per inch below defined as postscript standard 72, divided by
;; scaling 0.9 in idraw header, divided by scaling defined above
;; to give more units per inch

(setq *units-per-inch* (round (/ 72 0.9 *scale*)))

;; To define your own line style, simply provide a name for the line
;; style at the end of the *lines* list and the code at the end of
;; the *linecodes* list.  The linecode should have an even number of
;; entries, summing to 16.  The 1st, 3rd, etc. entries correspond to
;; the number of points the line is written, and the 2nd, 4th, etc.
;; entries correspond to the number of points the line is blank.

(setq *lines* (list 'regular 'none 'dash 'shortdash 'longdash 'dotdash
		      'dotdotdash 'smalldots 'dotout))
(setq *linecodes* (list 'regular 'none '(4 4 4 4) '(2 2 2 2 2 2 2 2)
			  '(8 8) '(10 2 2 2) '(8 2 1 2 1 2)
			  '(1 7 1 7) '(14 2)))

(setq *fills* (list 'none 'white 'black
		            'plaid 'checked 'vertical 'horizontal 
			    'squares 'down-hatch 'up-hatch 'weave))
(setq *fillcodes* (list nil "1" "0" 
			  "< 88 55 22 55 88 55 22 55 > -1"
			  "< cc cc 33 33 cc cc 33 33 > -1"
			  "< 88 88 88 88 88 88 88 88 > -1"
			  "< ff 00 00 00 ff 00 00 00 > -1"
			  "< ff 88 88 88 ff 88 88 88 > -1"
			  "< 88 44 22 11 88 44 22 11 > -1"
			  "< 11 22 44 88 11 22 44 88 > -1"
			  "< 77 bb ee dd 77 bb ee dd > -1"))

(setq *fonts* (list 'courier-8 'courier-10 'courier-bold-12
			    'times-roman-12 'times-roman-14 'times-bold-14
			    'times-italic-14 'helvetica-12 'helvetica-14
			    'helvetica-bold-14 'helvetica-oblique-14
			    'helvetica-8 'helvetica-10 'helvetica-bold-10
			    'helvetica-bold-12 'helvetica-bold-18
			    'times-bold-18 'times-bold-24 'symbol-10
			    'symbol-12 'symbol-14 'symbol-18 'symbol-24))
(setq *fontcodes* (list "Courier 8" "Courier 10" "Courier-Bold 12"
			  "Times-Roman 12" "Times-Roman 14" "Times-Bold 14"
			  "Times-Italic 14" "Helvetica 12" "Helvetica 14"
			  "Helvetica-Bold 14" "Helvetica-Oblique 14"
			  "Helvetica 8" "Helvetica 10" "Helvetica-Bold 10"
			  "Helvetica-Bold 12" "Helvetica-Bold 18"
			  "Times-Bold 18" "Times-Bold 24" "Symbol 10"
			  "Symbol 12" "Symbol 14" "Symbol 18" "Symbol 24"))
(setq *fontcomments* (list "*-courier-medium-r-*-80-*"
			     "*-courier-medium-r-*-100-*"
			     "*-courier-bold-r-*-120-*"
			     "*-times-medium-r-*-120-*"
			     "*-times-medium-r-*-140-*"
			     "*-times-bold-r-*-140-*"
			     "*-times-medium-i-*-140-*"
			     "*-helvetica-medium-r-*-120-*"
			     "*-helvetica-medium-r-*-140-*"
			     "*-helvetica-bold-r-*-140-*"
			     "*-helvetica-medium-o-*-140-*"
			     "*-helvetica-medium-r-*--*-80-*"
			     "*-helvetica-medium-r-*--*-100-*"
			     "*-helvetica-bold-r-*--*-100-*"
			     "*-helvetica-bold-r-*--*-120-*"
			     "*-helvetica-bold-r-*--*-180-*"
			     "*-times-bold-r-*--*-180-*"
			     "*-times-bold-r-*--*-240-*"
			     "*-symbol-medium-r-*--*-100-*"
			     "*-symbol-medium-r-*--*-120-*"
			     "*-symbol-medium-r-*--*-140-*"
			     "*-symbol-medium-r-*--*-180-*"
			     "*-symbol-medium-r-*--*-240-*"))

(setq *maxcurvepts* 300)  ; max number of curve points before breaking it up
                          ; (but still grouped)

;;; icreate-image returns scaling and other info for the specified image
;;; the parameters are:
;;;	xscale, yscale: these parameters specify the number of inches to
;;;		each user-defined unit
;;;	psx,psy: these parameters specify the location of the origin
;;;		in inches from the lower left corner of the page (in the
;;;		postscript coord system)
;;;     rot: this parameter specifies the amount the user-defined coord
;;;             system should be rotated from the default postscript
;;;             coordinate system (where x increases from left to right
;;;             and y increases from bottom to top)

(defun icreate-image (&key xscale yscale psx psy rot)
    (cond ((and (numberp xscale)(numberp yscale)(numberp psx)
		(numberp psy)(numberp rot))
	   (list xscale yscale psx psy rot))
	  (t (format t "~%Error in igraphics:  invalid keyword arguments.~%"))))

;;; idraw-x draws an x centered at pt in a square of half-width mag

(defun idraw-x (image pt mag &key (fillstyle *deffill*) (linestyle *defline*)
		      (linewidth *defwidth*))
    (let ((pt1 (list (- (first pt) mag) (- (second pt) mag)))
	  (pt2 (list (+ (first pt) mag) (+ (second pt) mag)))
	  (pt3 (list (- (first pt) mag) (+ (second pt) mag)))
	  (pt4 (list (+ (first pt) mag) (- (second pt) mag))))
	 (setq image (igroup image))
	 (setq image (idraw-line image pt1 pt2 :fillstyle fillstyle
			 :linestyle linestyle :linewidth linewidth))
	 (setq image (idraw-line image pt3 pt4 :fillstyle fillstyle
			 :linestyle linestyle :linewidth linewidth))
	 (iendgroup image)))

;;; idraw-crosshair draws a crosshair (gunsight) centered at pt
;;; in a square of half-width mag

(defun idraw-crosshair (image pt mag &key (fillstyle *deffill*) 
			      (linestyle *defline*)
			      (linewidth *defwidth*))
    (let ((x (first pt))(y (second pt)))
	 (setq image (igroup image))
	 (setq image (idraw-line image (list (- x mag) y) (list (+ x mag) y)
			 :fillstyle fillstyle :linestyle linestyle
			 :linewidth linewidth))
	 (setq image (idraw-line image (list x (- y mag)) (list x (+ y mag))
			 :fillstyle fillstyle :linestyle linestyle
			 :linewidth linewidth))
	 (iendgroup image)))

;;; idraw-centermass draws a circle with inscribed crosshair centered
;;; at center with radius radius

(defun idraw-centermass (image center radius)
    (setq image (igroup image))
    (setq image (idraw-circle image center radius))
    (setq image (idraw-crosshair image center radius))
    (iendgroup image))

;;; idraw-abcline takes coefficients a, b, and c of equation ax+by+c=0,
;;; and the bounding box defined by xmin, xmax, ymin, and ymax
;;; It then draws the segment of the line which passes through the
;;; bounding box (if it does pass through); else data structure
;;; is not changed, no drawing done

(defun idraw-abcline (image a b c &key xmin xmax ymin ymax (fillstyle *deffill*) 
			    (linestyle *defline*) (linewidth *defwidth*)
			    (arrow *defarrow*))
    (cond ((or (null xmin)(null xmax)(null ymin)(null ymax))
	   (format t 
		"~%Error in igraphics:  must specify bounds for abcline.~%")
	   image)
	  (t (let ((endpoints nil) temp)
		  (cond ((not (= b 0.0))
			 (setq temp (/ (+ c (* a xmin)) (- 0 b)))
			 (cond ((and (>= temp ymin)(<= temp ymax))
				(setq endpoints (cons (list xmin temp)
						      endpoints))))
			 (setq temp (/ (+ c (* a xmax)) (- 0 b)))
			 (cond ((and (>= temp ymin)(<= temp ymax))
				(setq endpoints (cons (list xmax temp)
						      endpoints))))))
		  (cond ((not (= a 0.0))
			 (setq temp (/ (+ c (* b ymin)) (- 0 a)))
			 (cond ((and (>= temp xmin)(<= temp xmax))
				(setq endpoints (cons (list temp ymin)
						      endpoints))))
			 (setq temp (/ (+ c (* b ymax)) (- 0 a)))
			 (cond ((and (>= temp xmin)(<= temp xmax))
				(setq endpoints (cons (list temp ymax)
						      endpoints))))))
		  (cond ((>= (length endpoints) 2)
			 (idraw-line image (first endpoints)
			     (second endpoints) :fillstyle fillstyle
			     :linestyle linestyle :linewidth linewidth
			     :arrow arrow))
			(t image))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; following functions are used for scaling dimensions and transforming
;;; points

(defun ixscale (xform num)
    (round (* num *units-per-inch* (first xform))))

(defun iyscale (xform num)
    (round (* num *units-per-inch* (second xform))))

(defun transform-pts (xform pts)
    (mapcar #'(lambda(x) (trans xform x)) pts))
    
(defun transform-pt (xform pt)
    (trans xform pt))

(defun trans (xform pt)
    (let (xs ys xxs xys yxs yys (x (first pt)) (y (second pt)))
	 (setq xs (* x (first xform) *units-per-inch*)
	       ys (* y (second xform) *units-per-inch*))
	 (setq xxs (* xs (cos (fifth xform)))
	       xys (* ys -1 (sin (fifth xform)))
	       yxs (* xs (sin (fifth xform)))
	       yys (* ys (cos (fifth xform))))
	 (list (round (+ (* (third xform) *units-per-inch*) xxs xys)) 
	       (round (+ (* (fourth xform) *units-per-inch*) yxs yys)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; igroup just gives the command to group graphics until the
;;; iendgroup command is received.  Comment is a string describing the group.

(defun igroup (image &optional (comment1 nil) (other nil))
    (append image (list (list 'group comment1 other))))

;;; iendgroup gives command to end a group of graphics images

(defun iendgroup (image &optional (comment nil))
    (append image (list (list 'endgroup comment))))

;;; idraw-line draws a line from pt1 to pt2

(defun idraw-line (image pt1 pt2 &key (fillstyle *deffill*)
			 (linestyle *defline*) (linewidth *defwidth*)
			 (arrow *defarrow*))
    (cond ((valid-line? linestyle)
	   (append image (list (list 'line pt1 pt2 fillstyle
				     linestyle linewidth
				     arrow))))
	  (t image)))

;;; idraw-circle draws a circle centered at pt with radius radius

(defun idraw-circle (image pt radius &key (fillstyle *deffill*)
			   (linestyle *defline*)
			   (linewidth *defwidth*))
    (cond ((and (valid-line? linestyle)(valid-fill? fillstyle))
	   (append image (list (list 'circle pt radius 
				     fillstyle linestyle linewidth))))
	  (t image)))

;;; idraw-lines draws lines from the first pt in list to second,
;;; from second to third, etc.

(defun idraw-lines (image ptlist &key (fillstyle *deffill*)
			  (linestyle *defline*)
			  (linewidth *defwidth*)
			  (arrow *defarrow*))
    (cond ((and (valid-line? linestyle)
		(valid-fill? fillstyle))
	   (append image (list (list 'lines ptlist fillstyle
				     linestyle linewidth arrow))))
	  (t image)))

;;; idraw-polygon takes n vertices and draws the associated
;;; n-gon, where consecutive points are adjacent (and first
;;; adjacent to last)

(defun idraw-polygon (image ptlist &key (fillstyle *deffill*) 
			    (linestyle *defline*)
			    (linewidth *defwidth*))
    (cond ((and (valid-fill? fillstyle)(valid-line? linestyle))
	   (append image (list (list 'polygon ptlist 
				     fillstyle linestyle
				     linewidth))))
	  (t image)))

;;; idraw-transformed-polygon takes n vertices and draws the
;;; associated n-gon, where the origin of the polygon (0, 0)
;;; is translated to (dx, dy), and the n-gon is rotated by theta.

(defun idraw-transformed-polygon (image ptlist dx dy theta &key
					(fillstyle *deffill*)
					(linestyle *defline*)
					(linewidth *defwidth*))
  (cond ((and (valid-fill? fillstyle)(valid-line? linestyle))
	 (let ((newptlist (mapcar #'(lambda(pt)
				      (let ((x (first pt))(y (second pt)))
					(list (+ dx (* x (cos theta))
						 (* y -1 (sin theta)))
					      (+ dy (* x (sin theta))
						 (* y (cos theta))))))
				  ptlist)))
	   (append image (list (list 'polygon newptlist fillstyle linestyle
				     linewidth)))))
	(t image)))

(defun idraw-transformed-circle (image pt rad dx dy &key
					(fillstyle *deffill*)
					(linestyle *defline*)
					(linewidth *defwidth*))
  (idraw-circle image (list (+ (first pt) dx) (+ (second pt) dy))
		rad :fillstyle fillstyle :linestyle linestyle
		:linewidth linewidth))

;;; idraw-rectangle draws the rectangle of which pt1 and pt2
;;; are opposite vertices

(defun idraw-rectangle (image pt1 pt2 &key (fillstyle *deffill*)
			      (linestyle *defline*) (linewidth *defwidth*))
    (let ((x1 (first pt1))(y1 (second pt1))
	  (x2 (first pt2))(y2 (second pt2)))
	 (idraw-polygon image (list (list x1 y1)
				    (list x1 y2)
				    (list x2 y2)
				    (list x2 y1))
	     :fillstyle fillstyle :linestyle linestyle
	     :linewidth linewidth)))

;;; idraw-text takes a point at which to begin drawing the textstring,
;;; the font, and 2 scaling and 1 rotation parameter;  the scaling
;;; parameters allow stretching of the font and the rotation parameter
;;; specifies direction to print text (0 rotation, the text is lined up
;;; with the +x axis; pi rotation, the text is lined up with -x axis
;;; [ie text is upside down])

(defun idraw-text (image pt textstring &key (font *deffont*)
			 (width 1) (height 1) (rot 0))
    (cond ((member font *fonts*)
	   (append image (list (list 'text pt textstring font
				     width height rot))))
	  (t (format t "~%Error in igraphics:  invalid font.~%"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; below functions check for valid specified types

(defun valid-line? (linestyle)
    (cond ((or (member linestyle *lines*)
	       (and (numberp linestyle) (>= linestyle 0)))
	   t)
	  (t (format t "~%Error in igraphics:  invalid linestyle.~%"))))

(defun valid-fill? (fillstyle)
    (cond ((or (member fillstyle *fills*)
	       (and (numberp fillstyle) (>= fillstyle 0)
		    (<= fillstyle 1))) 
	   t)
	  (t (format t "~%Error in igraphics:  invalid fillstyle.~%"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; isave-image takes the image data structure and the filename
;;; and saves the data structure in Lisp format.  When this file
;;; is loaded into Lisp, the variable 'image' will be set to this
;;; data structure.	   
	 
(defun isave-image (image filename)
    (let ((save-file (open filename :direction :output :if-exists :supersede))
	  lis)
	 (format save-file "~%(setq image '(~a ~a ~a ~a ~a~%" (first image) 
		 (second image)(third image)(fourth image)(fifth image))
	 (dotimes (j (- (length image) 5))
	     (format save-file "  (")
	     (setq lis (nth (+ j 5) image))
	     (dotimes (k (length lis))
		 (cond ((stringp (nth k lis))
			(format save-file "\"~a\" " (nth k lis)))
		       (t (format save-file "~a " (nth k lis)))))
	     (format save-file ")~%"))
	 (format save-file "))~%")
	 (close save-file)))

;;; isave-image-in-idraw-format takes image data structure and a filename
;;; and saves the image in idraw readable format by first putting the
;;; standard header in the outfile, then encoding the image data, and
;;; then putting the standard idraw trailer.

(defun isave-image-in-idraw-format (image filename)
    (let ((infile (open *header* :direction :input))
	  (outfile (open filename :direction :output :if-exists :supersede)))
	 (format outfile "~A~%" (read infile))
	 (close infile)
	 (encode-group outfile)
	 (encode-image image outfile)
	 (encode-endgroup outfile)
	 (encode-endimage outfile)
	 (close outfile)))

;;; concatenate-idraw-files takes a list of idraw files and makes 1 idraw file
;;; containing the graphics from both.  this is done by putting the 
;;; standard header in the output file, stripping file1 of its header
;;; and trailer and putting this in the file, and stripping file2 of
;;; its header and trailer and putting this in the outfile, then
;;; putting the trailer in the outfile.

(defun concatenate-idraw-files (&key inlist out)
    (let ((headfile (open *header* :direction :input))
          (fout (open out :direction :output :if-exists :supersede))
	  fin)
         (format fout "~A" (read headfile))
         (close headfile)
	 (do ((templis inlist (cdr templis)))
	     ((null templis))
	     (setq fin (open (first templis) :direction :input))
	     (skip-header fin)
	     (copy-til-tailer fin fout)
	     (close fin))
         (format fout "End %I eop~%")
         (format fout "~%showpage~%~%%%Trailer~%~%end~%")
         (close fout)))

;;; skips an idraw file's header

(defun skip-header (f)
    (do ()((string= (read-line f) "/originalCTM matrix currentmatrix def"))))

;;; copies f contents into fout until it finds the trailer

(defun copy-til-tailer (f fout)
    (let ((num-begin-picts 1)(num-end-picts 0) text)
	 (loop 
	       (setq text (read-line f))
	       (cond ((string= text "Begin %I Pict")
		      (setq num-begin-picts (1+ num-begin-picts)))
		     ((string= text "End %I eop")
		      (setq num-end-picts (1+ num-end-picts))))
	       (cond ((= num-begin-picts num-end-picts)(return))
		     (t (format fout "~A~%" text))))))

;;; encode-image goes through image data structure and calls encoding
;;; routine for each graphic

(defun encode-image (image outfile)
    (do ((graphics-list (nthcdr 5 image) (cdr graphics-list)))
	((null graphics-list))
	(encode-graphic (first-5 image) (car graphics-list) outfile)))

;;; returns first 5 elements of a list

(defun first-5 (lis)
    (reverse (nthcdr (- (length lis) 5) (reverse lis))))

;;; encode graphic takes a graphic from the data structure and calls
;;; the appropriate routine to encode this graphic in idraw format.

(defun encode-graphic (xform graphic outfile)
    (let ((kind (first graphic)))
	 (cond ((equal kind 'line)
		(encode-line xform (cdr graphic) outfile))
	       ((equal kind 'lines)
		(encode-lines xform (cdr graphic) outfile))
	       ((equal kind 'circle)
		(encode-circle xform (cdr graphic) outfile))
	       ((equal kind 'polygon)
		(encode-polygon xform (cdr graphic) outfile))
	       ((equal kind 'text)
		(encode-text xform (cdr graphic) outfile))
	       ((equal kind 'group)
		(encode-group outfile))
	       ((equal kind 'endgroup)
		(encode-endgroup outfile)))))

;;; prints out the info to group the following graphics until the endgroup
;;; there may be a label after the group command; it's ignored

(defun encode-group (outfile)
    (format outfile "Begin %I Pict~%")
    (format outfile "%I b u~%%I cfg u~%%I cbg u~%%I f u~%%I p u~%%I t u~%~%"))

;;; prints out the info to end a graphics group

(defun encode-endgroup (outfile)
    (format outfile "End %I eop~%~%"))

;;; prints out the info to end the idraw image file
    
(defun encode-endimage (outfile)
    (format outfile "End %I eop~%~%")
    (format outfile "showpage~%~%%%Trailer~%~%end~%"))

;;; encodes line in idraw format

(defun encode-line (xform data outfile)
    (let (pt1 pt2)
	 (format outfile "Begin %I Line~%")
	 (setbrush (fourth data) (fifth data) (sixth data) outfile)
	 (setcfg-cbg outfile)
	 (setpattern (third data) outfile)
	 (concat xform nil outfile)
	 (format outfile "%I~%")
	 (setq pt1 (transform-pt xform (first data))
	       pt2 (transform-pt xform (second data)))
	 (format outfile "~d ~d ~d ~d Line~%End~%~%" (first pt1) (second pt1)
		 (first pt2) (second pt2))))


;;; encodes multiple lines in idraw format
;;; modified 2/22/95 to break up large curves into smaller curves
;;; of at most *maxcurvepts* points, so printers don't run out of
;;; memory

(defun encode-lines (xform data outfile)
  (let (count len totallen)
    (encode-group outfile)
    (format outfile "Begin %I MLine~%")
    (setbrush (third data) (fourth data) (fifth data) outfile)
    (setcfg-cbg outfile)
    (setpattern (second data) outfile)
    (concat xform nil outfile)
    (setq totallen (length (first data)))
    (cond ((> totallen *maxcurvepts*) (setq len *maxcurvepts*))
	  (t (setq len totallen)))
    (format outfile "%I ~d~%" len)
    (setq count 0)
    (do ((tail (transform-pts xform (first data)) (cdr tail)))
	((null tail))
	(format outfile "~d ~d~%" (caar tail) (cadar tail))
	(setq count (1+ count))
	(cond ((and (= count *maxcurvepts*) (> totallen *maxcurvepts*))
	       (format outfile "~d MLine~%End~%~%" len)
	       (format outfile "Begin %I MLine~%")
	       (setbrush (third data) (fourth data) (fifth data) outfile)
	       (setcfg-cbg outfile)
	       (setpattern (second data) outfile)
	       (concat xform nil outfile)
	       (setq count 1 totallen (1+ (- totallen *maxcurvepts*)))
	       (cond ((> totallen *maxcurvepts*)
		      (setq len *maxcurvepts*))
		     (t (setq len totallen)))
	       (format outfile "%I ~d~%" len)
	       (format outfile "~d ~d~%" (caar tail) (cadar tail)))))
    (format outfile "~d MLine~%End~%~%" len)
    (encode-endgroup outfile)))

;;; encodes polygon in idraw format

(defun encode-polygon (xform data outfile)
    (let ((pts (first data))(fill (second data))(line (third data))
	  (width (fourth data)))
	 (format outfile "Begin %I Poly~%")
	 (setbrush line width 'none outfile)
	 (setcfg-cbg outfile)
	 (setpattern fill outfile)
	 (concat xform nil outfile)
	 (format outfile "%I ~d~%" (length pts))
	 (do ((tail (transform-pts xform pts) (cdr tail)))
	     ((null tail))
	     (format outfile "~d ~d~%" (caar tail) (cadar tail)))
	 (format outfile "~d Poly~%End~%~%" (length pts))))

;;; encodes a circle in idraw format

(defun encode-circle (xform data outfile)
    (let ((pt (first data))(radius (second data))
	  (fill (third data))(line (fourth data))(width (fifth data))
	  temppt)
	 (format outfile "Begin %I Elli~%")
	 (setbrush line width 'none outfile)
	 (setcfg-cbg outfile)
	 (setpattern fill outfile)
	 (concat xform nil outfile)
	 (setq temppt (transform-pt xform pt))
	 (format outfile "%I~%~d ~d ~d ~d Elli~%End~%~%"
		 (first temppt) (second temppt)
		 (ixscale xform radius) (iyscale xform radius))))

;;; encodes text in idraw format

(defun encode-text (xform data outfile)
    (let ((pt (first data))(text (postscript-text (second data)))
	  (font (third data))(width (fourth data))
	  (height (fifth data))(rot (sixth data)))
	 (format outfile "Begin %I Text~%")
	 (setcfg outfile)
	 (setfont font outfile)
	 (concat xform (list width height rot pt) outfile)
	 (format outfile "%I~%[~%(~A)~%] Text~%End~%~%" text)))    

;;; returns the element in lis2 which is in same position elt is in lis1

(defun corresponding-elt (elt lis1 lis2)
    (car (nthcdr (- (length lis1) (length (member elt lis1)))
		 lis2)))

;;; postscript-text takes a string and returns the string as it should
;;; be printed in idraw formatted file; basically, any parentheses
;;; in a string should be preceded by a backslash so they will be printed
;;; out by postscript
;;; note that currently any backslashes \ in textstring will be ignored

(defun postscript-text (text)
    (let ((ps-text-list nil)(text-list (coerce text 'list)))
	 (dotimes (k (length text-list))
	     (cond ((char= #\( (nth k text-list))
		    (setq ps-text-list (append ps-text-list 
					       (list #\\ #\())))
		   ((char= #\) (nth k text-list))
		    (setq ps-text-list (append ps-text-list
					       (list #\\ #\)))))
		   (t (setq ps-text-list (append ps-text-list
						 (list (nth k text-list)))))))
	 (coerce ps-text-list 'string)))

;;; setfont prints the idraw SetF commands

(defun setfont (font outfile)
    (format outfile "%I f ~A~%" 
	    (corresponding-elt font *fonts* *fontcomments*))
    (format outfile "/~A SetF~%"
	    (corresponding-elt font *fonts* *fontcodes*)))

;;; setbrush prints the idraw SetB commands

(defun setbrush (line width arrow outfile)
  (cond ((numberp line)
	 (setq width line)
	 (setq line 'regular)))
  (cond ((equal line 'none)
	 (format outfile "none SetB %I b n~%"))
	(t (encode-idraw-linecode line outfile)
	   (cond ((integerp width)
		  (format outfile "~d " width))
		 (t (format outfile "~6,3f " width)))
	   (cond ((equal arrow 'beginning)
		  (format outfile "1 0 "))
		 ((equal arrow 'end)
		  (format outfile "0 1 "))
		 ((equal arrow 'both)
		  (format outfile "1 1 "))
		 (t (format outfile "0 0 ")))
	   (encode-postscript-linecode line outfile))))

(defun encode-idraw-linecode (line outfile)
  (cond ((equal line 'regular) (format outfile "%I b 65535~%"))
	(t
	 (let* ((style (corresponding-elt line *lines* *linecodes*))
	        (len (length style))
		(total 0) (currentslot 32768) times
		onindex offindex on off)
	   (format t "style ~a len ~a~%" style len)
	   (dotimes (k (floor (/ (1+ len) 2)))
		    (setq onindex (* k 2) offindex (+ 1 (* k 2)))
		    (setq on (nth onindex style))
		    (cond ((< offindex len)
			   (setq off (nth offindex style)))
			  (t (setq off 0)))
		    (format t "onindex ~a on ~a offindex ~a off ~a~%"
			    onindex on offindex off)
		    (setq times (+ on off))
		    (format t "here~%")
		    (dotimes (j times)
			     (cond ((> on 0)
				    (setq total (+ total currentslot))
				    (setq on (1- on))))
			     (setq currentslot (/ currentslot 2))))
	   (format outfile "%I b ~d~%" total)))))

(defun encode-postscript-linecode (line outfile)
  (cond ((equal line 'regular) (format outfile "[] 0 SetB~%"))
	(t
	 (let* ((style (corresponding-elt line *lines* *linecodes*)))
	   (format outfile "~a 17 SetB~%"
		   (substitute #\] #\)
			       (substitute #\[ #\(
					   (format nil "~a" style))))))))

;;; setcfg-cbg sets background to white, foreground to black

(defun setcfg-cbg (outfile)
    (format outfile "%I cfg Black~%0 0 0 SetCFg~%%I cbg White~%1 1 1 SetCBg~%"))

;;; setcfg sets foreground to black
    
(defun setcfg (outfile)
    (format outfile "%I cfg Black~%0 0 0 SetCFg~%"))

;;; setpattern prints the idraw SetP commands

(defun setpattern (pattern outfile)
    (cond ((equal pattern 'none)
	   (format outfile "none SetP %I p n~%"))
	  ((numberp pattern) 
	   (format outfile "%I p~%")
	   (format outfile "~A SetP~%" (get-gray-level pattern)))
	  (t (format outfile "%I p~%")
	     (format outfile "~A SetP~%" 
		     (corresponding-elt pattern *fills* *fillcodes*)))))

(defun get-gray-level (pattern)
    (cond ((<= pattern 0) 0.0)
	  ((>= pattern 1) 1.0)
	  (t (coerce pattern 'float))))

;;; concat prints the idraw concat matrix

(defun concat (xform matrix outfile)
    (cond ((null matrix)
	   (format outfile "%I t~%[ ~5,3F 0 0 ~5,3F 0 0 ] concat~%"
		   *scale* *scale*))
	  (t
;; below is currently only used to rotate and scale font; 
;; therefore scaling should be specified by user with respect to
;; normal size idraw fonts
;; (also note normal concat is not being used, so must do transform here)
	    (let ((width (first matrix))(height (second matrix))
		  (th (third matrix)) (rot (fifth xform))
		  (pt (fourth matrix)) xs1 ys1 xxs1 xys1 yxs1 yys1)
		 (setq xs1 (* (first pt) (first xform) 80)
		       ys1 (* (second pt) (second xform) 80))
		 (setq xxs1 (* xs1 (cos rot))
		       xys1 (* ys1 -1 (sin rot))
		       yxs1 (* xs1 (sin rot))
		       yys1 (* ys1 (cos rot)))
		 (setq xs1 (round (+ (* 80 (third xform)) xxs1 xys1))
		       ys1 (round (+ (* 80 (fourth xform)) yxs1 yys1)))
		 (format outfile "%I t~%[ ~10,4F ~10,4F ~10,4F ~10,4F ~10,4F ~10,4F ] concat~%"
			 (* width (cos (+ rot th))) 
			 (* width (sin (+ rot th)))
			 (* -1 height (sin (+ rot th))) 
			 (* height (cos (+ rot th)))
			 xs1 ys1)))))


) ; closes the let at the beginning