View of /lisp/test/jis3ku.l| [wadalabfont-kit] / lisp / test / jis3ku.l |
View of /lisp/test/jis3ku.l
Parent Directory
| 
Revision Log
*** empty log message ***
(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 " </c> CompD/n" kstr)
(format "0 70 moveto </c> 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 </c> 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 </c> 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")))))
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |