View of /lisp/test/out2ps.l

Parent Directory

Revision Log

*** empty log message ***

(defun out-to-ps-all (outlines tag psfile 
			       (nameflag)
			       (col 9)(line (fix (times 0.67 col))))
  (let ((standard-output (outopen (stream psfile)))
	(scale (fix (times 160.0 (max (//$ 9.0 (float col))
				      (//$ 6.0 (float line))))))
	(i nil)(j nil)(page nil)(last nil)
	(next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
	(date (date-time)))
    (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale)
    (format "//Helvetica findfont 70 scalefont setfont/n")
    (setq i 0 j 0 page 1)
    (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" 
	    (substring date 0 2)
	    (substring date 2 4)(substring date 4 6)
	    (substring date 6 8)(substring date 8 10)
	    psfile page)
    (do 
     ((ol outlines (cdr ol))
      (l nil))
     ((atom ol))
     (princ ";" terminal-output)
;     (princ (gccount) terminal-output)
     (print (car ol) terminal-output)
     (setq l
	   (let ((err:argument-type #'(lambda (x (y))(throw 'err)))
		 (err:number-of-arguments #'(lambda (x (y))(throw 'err)))
		 (err:unbound-variable #'(lambda (x (y))(throw 'err)))
		 (err:undefined-function #'(lambda (x (y))(throw 'err)))
		 (err:zero-division #'(lambda (x (y))(throw 'err))))
	     (catch 'err
	       (skeleton2list (applykanji (car ol)) tag))))
     (cond 
      ((atom l)
       (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
       (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
       (cond (nameflag
	      (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
		      (cond ((lessp (string-length (car ol)) 10) 100)
			    (t
			     (fix (quotient 800 (string-length (car ol)))))))
	      (format "0 410 moveto </c> show/n" (euc2jis(car ol)))))
       )
      (t
       (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
       (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
       (cond (nameflag
	      (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
		      (cond ((lessp (string-length (car ol)) 10) 100)
			    (t
			     (fix (quotient 800 (string-length (car ol)))))))
	      (format "0 410 moveto </c> show/n" (euc2jis (car ol)))))
       (do ((ll l (cdr ll)))
	   ((atom ll))
	   (setq last (caar ll))
	   (format "newpath /c /c moveto/n" (fix (cadr last))
		   (- 400 (fix (caddr last))))
	   (do ((lll (cdar ll) (cdr lll)))
	       ((atom lll))
	       (match 
		(car lll)
		(('angle x y)
		 (format "/c /c lineto/n" (fix x) (- 400 (fix y))))
		(('bezier x0 y0)
		 (setq next (cadr lll))
		 (setq nextnext 
		       (cond ((cddr lll)(setq lll (cddr lll))(car lll))
			     (t (setq lll (cdr lll))last)))
		 (setq x1 (cadr next) y1 (caddr next))
		 (setq x2 (cadr nextnext) y2 (caddr nextnext))
		 (format
		  "/c /c /c /c /c /c curveto/n"
		  (fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2))))))
	   (format "closepath fill/n"))))
     (setq i (1+ i))
     (cond ((eq i col)
	    (format "500 /c translate/n" (* -500 (1- col)))
	    (setq i 0)
	    (setq j (1+ j))
	    (cond ((eq j line)
		   (format "showpage/n50 50 translate/n")
		   (format "0.001 /c mul dup scale/n" scale)
		   (format "//Helvetica findfont 70 scalefont setfont/n")
		   (setq page (1+ page))
		   (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" 
			   (substring date 0 2)
			   (substring date 2 4)(substring date 4 6)
			   (substring date 6 8)(substring date 8 10)
			   psfile page)
		   (format "//Ryumin-Light-Ext-H findfont 100 scalefont setfont/n")
		   (setq j 0))))
	   (t (format "0 500 translate/n"))))
    (format "showpage/n")))