(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 " CompD/n" kstr) (format "0 70 moveto 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")))