View of /renderer/out2ps.l

Parent Directory

Revision Log

*** empty log message ***

(defun rm-limit (prim)
  (do ((l (cadr prim) (cdr l))(ret))
    ((atom l)`(,(car prim) ,(nreverse ret).,(cddr prim)))
    (or (memq (caar l) '(xlimit ylimit))
	(push (car l) ret))))
(defun out-to-ps-all (outlines tag psfile 
			       (nameflag)
			       (col 9)(line (fix (times 0.67 col)))
			       (printfile t))
  (lets ((standard-output (outopen (stream psfile)))
	(scale (fix (times 160.0 (min (//$ 9.0 (float col))
				      (//$ 6.0 (float line))))))
	(ii nil)(jj nil)(page nil)(last nil)
	(skeleton)(hints)(type1)(kstr)
	(next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
	(date (date-time)))
    (format "%!/n%%BoundingBox: 45 45 /c /c/n" 
	    (plus 55 (fix (times 0.001 scale (- (* line 500) 100))))
	    (plus 55 (fix (times 0.001 scale (- (* col 500) 100)))))
    (lets ((s (inopen (stream "../psfiles/compfont.ps")))
	   (err:end-of-file #'(lambda (x (y))(throw 'eof))))
      (catch 'eof (loop (princ (readline s))(terpri))))
    (format "50 50 translate/n0.001 /c mul dup scale/n" scale)
    (format "//Helvetica findfont 70 scalefont setfont/n")
    (setq ii 0 jj 0 page 1)
    (and printfile
	 (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 "//Wadalab-mincho-10 CompNF/n")
    (format "//Wadalab-mincho-10 findfont 400 scalefont setfont/n")
    (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 (setq skeleton (normkanji (rm-limit (applykanji (car ol) tag)))) 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")
	)
       (t
	(format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
	(format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
	(setq hints (type1hints skeleton tag))
	(setq type1 (out2type1 (makeoutline l) hints))
	(cond ((and (= 2 (string-length (car ol)))
		    (logand 128 (sref (car ol) 0)))
	       (setq kstr (long-hex-image 
			   (plus (logand 127 (sref (car ol) 1))
				 (times 256 (logand 127 (sref (car ol) 0)))))))
	      ((and (= 7 (string-length (car ol)))
		    (string-equal (substring (car ol) 0 2) "1-"))
	       (setq kstr
		     (long-hex-image
		      (plus (logand 127 (plus 32 (number-value (substring (car ol) 5 7))))
			    (times 256 (logand 127 (plus 32 (number-value (substring (car ol) 2 4)))))))))
	       (t
	       (setq kstr "2121")))
	(princ type1)
	(format " </c> CompD/n" kstr)
	(format "0 70 moveto </c> show/n" kstr)))
      (setq ii (1+ ii))
      (cond ((eq ii col)
	     (format "500 /c translate/n" (* -500 (1- col)))
	     (setq ii 0)
	     (setq jj (1+ jj))
	     (cond ((and (eq jj line)(consp (cdr ol)))
		    (format "showpage/n")
		    (format "50 50 translate/n")
		    (format "0.001 /c mul dup scale/n" scale)
		    (format "//Helvetica findfont 70 scalefont setfont/n")
		    (setq page (1+ page))
		    (and printfile
			 (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 "//Wadalab-mincho-10 CompNF/n")
		    (format "//Wadalab-mincho-10 findfont 400 scalefont setfont/n")
		    (setq jj 0))))
	    (t (format "0 500 translate/n"))))
    (format "showpage/n")))