(defun jis3ps (kustr psfile) (lets ((standard-output (outopen (stream psfile))) (tag 'mincho-patch)(col 12)(line 8) (scale (fix (times 160.0 (max (//$ 9.0 (float col)) (//$ 6.0 (float line)))))) (i nil)(j nil)(page nil)(last nil)(outlines) (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)(skeleton) (minchowidth 10.0) (tateyokoratio 0.3) (hirawidth 0.35) (tatekazari 1.8) (kazariheight 1.8) (tomeheight 2.4) (date (date-time))) (do ((i 1 (1+ i)) (dig2 (make-string 2))) ((> i 94)(setq outlines (nreverse outlines))) (sset dig2 0 (+ 48 (quotient i 10))) (sset dig2 1 (+ 48 (remainder i 10))) (push (intern (symbol (string-append "1-" kustr "-" dig2))) outlines)) (format "%!/n%%BoundingBox: 95 195 /c /c/n" (plus 105 (fix (times 0.001 scale (- (* line 500) 100)))) (plus 205 (fix (times 0.001 scale (- (* col 500) 100))))) (lets ((s (inopen (stream "/home/mari/kanji/lib/psfiles/compfont.ps"))) (err:end-of-file #'(lambda (x (y))(throw 'eof)))) (catch 'eof (loop (princ (readline s))(terpri)))) (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale) (format "//Helvetica findfont 140 scalefont setfont/n") (do ((i 0 (1+ i))) ((greaterp i 11)) (format "-200 /c moveto (/c) show/n" (plus 180 (times i 500)) (cond ((lessp i 10) (string-append "0" (number-image i))) (t i)))) (do ((i 1 (1+ i))) ((greaterp i 7)) (format "/c -140 moveto (/c) show/n" (plus 160 (times i 500)) (times 12 i))) (format "0 -140 moveto (/c) show/n" (string-append "1" kustr)) (format "3000 -280 moveto (/c-/c-/c /c:/c) show/n" (substring date 0 2) (substring date 2 4)(substring date 4 6) (substring date 6 8)(substring date 8 10)) (format "//Wadalab-mincho-10 CompNF/n") (format "//Wadalab-mincho-10 findfont 400 scalefont setfont/n") ; (break) (setq i 1 j 0 page 1) (format "0 500 translate/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 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 i (1+ i)) (cond ((eq i col) (format "500 /c translate/n" (* -500 (1- col))) (setq i 0) (setq j (1+ j))) (t (format "0 500 translate/n")))) (format "showpage/n")))) (defun jis3-ku (kustr) (do ((i 1 (1+ i)) (dig2 (make-string 2)) (ret)) ((> i 94)(nreverse ret)) (sset dig2 0 (+ 48 (quotient i 10))) (sset dig2 1 (+ 48 (remainder i 10))) (push (intern (symbol (string-append "1-" kustr "-" dig2))) ret))) (defun rec_boundp (l) (cond ((symbolp l)(and (boundp l) (rec_boundp (eval l)))) ((consp l) (or (not (symbolp (car l))) (do ((ll (cdr l)(cdr ll))) ((atom ll) t) (or (rec_boundp (car ll))(exit nil))))) (t))) (defun check-ku (kustr) (do ((l (jis3-ku kustr) (cdr l))) ((atom l)) (or (rec_boundp (car l))(format ";/c/n" (car l))))) (defun check-bushu (kustr) (do ((l (jis3-ku kustr) (cdr l))(a)) ((atom l)) (and (symbolp (setq a (eval (car l))))(format ";/c,/c/n" (car l) a)))) (defun makeku (kanjis type filespec dig) (lets ((filename (string-append filespec (long-hex-image dig) ".ps"))) (format ";/c/n" filename) (out-to-ps-all (nreverse kanjis) type filename nil 12 8 nil))) (defun jis-ku (ku type filename) (do ((j #x21 (1+ j))(ret)(str (make-string 2)(make-string 2))) ((greaterp j #x7e) (out-to-ps-all (nreverse ret) type filename nil 12 8 nil)) (sset str 0 (logor #x80 ku))(sset str 1 (logor #x80 j)) (push (intern (symbol str)) ret))) (defun jis-ku-3 (ku type filename) (out-to-ps-all (jis3-ku ku) type filename nil 12 8 nil)) (defun makeallkanji (type filespec) (lets ((ret)) (do ((i #x30 (1+ i))) ((greaterp i #x4e)) (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2))) ((greaterp j #x7e)(makeku ret type filespec i)(setq ret nil)) (sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j)) (push (intern (symbol str)) ret))) (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2))) ((greaterp j #x53)(makeku ret type filespec i)(setq ret nil)) (sset str 0 (logor #x80 #x4f))(sset str 1 (logor #x80 j)) (push (intern (symbol str)) ret)) (do ((i #x50 (1+ i))) ((greaterp i #x73)) (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2))) ((greaterp j #x7e)(makeku ret type filespec i)(setq ret nil)) (sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j)) (push (intern (symbol str)) ret))) (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2))) ((greaterp j #x24)) (sset str 0 (logor #x80 #x74))(sset str 1 (logor #x80 j)) (push (intern (symbol str)) ret)) (push 'ŁĘŁµ ret) (push 'ŁĘŁ¶ ret) (makeku ret type filespec i)(setq ret nil))) (defun makeallkanjitest (type filespec) (lets ((ret)) (do ((i #x3c (1+ i))) ((greaterp i #x4e)) (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2))) ((greaterp j #x7e)(makeku ret type filespec i)(setq ret nil)) (sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j)) (push (intern (symbol str)) ret))) (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2))) ((greaterp j #x53)(makeku ret type filespec i)(setq ret nil)) (sset str 0 (logor #x80 #x4f))(sset str 1 (logor #x80 j)) (push (intern (symbol str)) ret)) (do ((i #x50 (1+ i))) ((greaterp i #x73)) (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2))) ((greaterp j #x7e)(makeku ret type filespec i)(setq ret nil)) (sset str 0 (logor #x80 i))(sset str 1 (logor #x80 j)) (push (intern (symbol str)) ret))) (do ((j #x21 (1+ j))(str (make-string 2)(make-string 2))) ((greaterp j #x24)) (sset str 0 (logor #x80 #x74))(sset str 1 (logor #x80 j)) (push (intern (symbol str)) ret)) (push 'ŁĘŁµ ret) (push 'ŁĘŁ¶ ret) (makeku ret type filespec i)(setq ret nil))) (defun makegothku (ku) (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 120) (format "//GothicBBB-Medium-H findfont 400 scalefont setfont/n") (do ((j #x21 (1+ j)) (y 0)) ((> j #x7e)(format "showpage/n")) (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n") (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n") (format "0 60 moveto show/n" (long-hex-image (+ j (* ku 256)))) (setq y (1+ y)) (cond ((eq y 12) (format "500 /c translate/n" (* -500 11))(setq y 0)) (t (format "0 500 translate/n"))))) (defun makeminku (ku) (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 120) (format "//Ryumin-Light-H findfont 400 scalefont setfont/n") (do ((j #x21 (1+ j)) (y 0)) ((> j #x7e)(format "showpage/n")) (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n") (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n") (format "0 60 moveto show/n" (long-hex-image (+ j (* ku 256)))) (setq y (1+ y)) (cond ((eq y 12) (format "500 /c translate/n" (* -500 11))(setq y 0)) (t (format "0 500 translate/n")))))