(declare (meshsize) special) (defun filltest1 (l tag size (meshsize size)) (setq m (1+ (fix size))) (init_window 400 400) (setq outline (skeleton2list (normkanji (applykanji l tag)) tag)) (mapcar outline (function (lambda (x)(fillpolygon (setpart1 x))))) (getimage) (do ((i 0 (plus i size))) ((greaterp (plus i size) 400)) (do ((j 0 (plus j size))) ((greaterp (plus j size)400)) (setq ii (fix (times 0.5 (plus 1.0 i i size)))) (setq jj (fix (times 0.5 (plus 1.0 j j size)))) (setq p (getpixel ii jj)) (fillrectangle (fix (plus i 0.5)) (fix (plus j 0.5)) m m 0) (cond ((0< p) (fillrectangle (fix (plus i 0.5)) (fix (plus j 0.5)) m m 1) ) (t ; (fillrectangle (fix i) (fix j) ; (- (fix (plus i size))(fix i)) ; (- (fix (plus j size))(fix j)) 0) (fillrectangle ii jj 1 1 2) )))) (freeimage) (mapcar outline (function (lambda (x)(drawlines (setpart1 x))))) (redraw) (checkevent) (close_window)) (defun out-to-ps-all-1 (outlines tag psfile (nameflag) (col 9)(line (fix (times 0.67 col)))(meshsize 1.0)) (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) (princ "/rec{/h exch def /w exch def /y exch def /x exch def") (terpri) (format "newpath x 400 y sub moveto w 0 rlineto 0 h neg rlineto/n") (format "w neg 0 rlineto closepath fill}def/n") (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) (init_window 400 400 t) (setq m (1+ (fix meshsize))) (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) 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 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 show/n" (euc2jis (car ol))))) (fillrectangle 0 0 400 400 0) (mapcar l (function (lambda (x)(fillpolygon (setpart1 x))))) (getimage) (do ((i 0 (plus i meshsize))) ((greaterp i 400)) (do ((j 0 (plus j meshsize))) ((greaterp j 400)) (setq ii (fix (plus i (times 0.5 meshsize)))) (setq jj (fix (plus j (times 0.5 meshsize)))) (setq p (getpixel ii jj)) (cond ((0< p) (format "/c /c /c /c rec/n" (fix i) (fix j) (- (fix (plus i meshsize))(fix i)) (- (fix (plus j meshsize))(fix j))))))) (freeimage) ) ) (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")))) (close_window) (format "showpage/n")))