[wadalabfont-kit] / lisp / test / lowdev.l  

Annotation of /lisp/test/lowdev.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 (declare (meshsize) special)
2 :     (defun filltest1 (l tag size (meshsize size))
3 :     (setq m (1+ (fix size)))
4 :     (init_window 400 400)
5 :     (setq outline (skelton2list (normkanji (applykanji l tag)) tag))
6 :     (mapcar outline
7 :     (function (lambda (x)(fillpolygon (setpart1 x)))))
8 :     (getimage)
9 :     (do ((i 0 (plus i size)))
10 :     ((greaterp (plus i size) 400))
11 :     (do ((j 0 (plus j size)))
12 :     ((greaterp (plus j size)400))
13 :     (setq ii (fix (times 0.5 (plus 1.0 i i size))))
14 :     (setq jj (fix (times 0.5 (plus 1.0 j j size))))
15 :     (setq p (getpixel ii jj))
16 :     (fillrectangle (fix (plus i 0.5)) (fix (plus j 0.5)) m m 0)
17 :     (cond ((0< p)
18 :     (fillrectangle (fix (plus i 0.5)) (fix (plus j 0.5)) m m 1)
19 :     )
20 :     (t
21 :     ; (fillrectangle (fix i) (fix j)
22 :     ; (- (fix (plus i size))(fix i))
23 :     ; (- (fix (plus j size))(fix j)) 0)
24 :     (fillrectangle ii jj 1 1 2)
25 :     ))))
26 :     (freeimage)
27 :     (mapcar outline
28 :     (function (lambda (x)(drawlines (setpart1 x)))))
29 :     (redraw)
30 :     (checkevent)
31 :     (close_window))
32 :    
33 :     (defun out-to-ps-all-1 (outlines tag psfile
34 :     (nameflag)
35 :     (col 9)(line (fix (times 0.67 col)))(meshsize 1.0))
36 :     (let ((standard-output (outopen (stream psfile)))
37 :     (scale (fix (times 160.0 (max (//$ 9.0 (float col))
38 :     (//$ 6.0 (float line))))))
39 :     (i nil)(j nil)(page nil)(last nil)
40 :     (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
41 :     (date (date-time)))
42 :     (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale)
43 :     (princ "/rec{/h exch def /w exch def /y exch def /x exch def")
44 :     (terpri)
45 :     (format "newpath x 400 y sub moveto w 0 rlineto 0 h neg rlineto/n")
46 :     (format "w neg 0 rlineto closepath fill}def/n")
47 :     (format "//Helvetica findfont 70 scalefont setfont/n")
48 :     (setq i 0 j 0 page 1)
49 :     (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"
50 :     (substring date 0 2)
51 :     (substring date 2 4)(substring date 4 6)
52 :     (substring date 6 8)(substring date 8 10)
53 :     psfile page)
54 :     (init_window 400 400 t)
55 :     (setq m (1+ (fix meshsize)))
56 :     (do
57 :     ((ol outlines (cdr ol))
58 :     (l nil))
59 :     ((atom ol))
60 :     (princ ";" terminal-output)
61 :     ; (princ (gccount) terminal-output)
62 :     (print (car ol) terminal-output)
63 :     (setq l
64 :     (let ((err:argument-type #'(lambda (x (y))(throw 'err)))
65 :     (err:number-of-arguments #'(lambda (x (y))(throw 'err)))
66 :     (err:unbound-variable #'(lambda (x (y))(throw 'err)))
67 :     (err:undefined-function #'(lambda (x (y))(throw 'err)))
68 :     (err:zero-division #'(lambda (x (y))(throw 'err))))
69 :     (catch 'err
70 :     (skelton2list (applykanji (car ol) tag) tag))))
71 :     (cond
72 :     ((atom l)
73 :     (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
74 :     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
75 :     (cond (nameflag
76 :     (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
77 :     (cond ((lessp (string-length (car ol)) 10) 100)
78 :     (t
79 :     (fix (quotient 800 (string-length (car ol)))))))
80 :     (format "0 410 moveto </c> show/n" (euc2jis(car ol)))))
81 :     )
82 :     (t
83 :     (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
84 :     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
85 :     (cond (nameflag
86 :     (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
87 :     (cond ((lessp (string-length (car ol)) 10) 100)
88 :     (t
89 :     (fix (quotient 800 (string-length (car ol)))))))
90 :     (format "0 410 moveto </c> show/n" (euc2jis (car ol)))))
91 :     (fillrectangle 0 0 400 400 0)
92 :     (mapcar l
93 :     (function (lambda (x)(fillpolygon (setpart1 x)))))
94 :     (getimage)
95 :     (do ((i 0 (plus i meshsize)))
96 :     ((greaterp i 400))
97 :     (do ((j 0 (plus j meshsize)))
98 :     ((greaterp j 400))
99 :     (setq ii (fix (plus i (times 0.5 meshsize))))
100 :     (setq jj (fix (plus j (times 0.5 meshsize))))
101 :     (setq p (getpixel ii jj))
102 :     (cond ((0< p)
103 :     (format "/c /c /c /c rec/n" (fix i) (fix j)
104 :     (- (fix (plus i meshsize))(fix i))
105 :     (- (fix (plus j meshsize))(fix j)))))))
106 :     (freeimage)
107 :     )
108 :     )
109 :     (setq i (1+ i))
110 :     (cond ((eq i col)
111 :     (format "500 /c translate/n" (* -500 (1- col)))
112 :     (setq i 0)
113 :     (setq j (1+ j))
114 :     (cond ((eq j line)
115 :     (format "showpage/n50 50 translate/n")
116 :     (format "0.001 /c mul dup scale/n" scale)
117 :     (format "//Helvetica findfont 70 scalefont setfont/n")
118 :     (setq page (1+ page))
119 :     (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"
120 :     (substring date 0 2)
121 :     (substring date 2 4)(substring date 4 6)
122 :     (substring date 6 8)(substring date 8 10)
123 :     psfile page)
124 :     (format "//Ryumin-Light-Ext-H findfont 100 scalefont setfont/n")
125 :     (setq j 0))))
126 :     (t (format "0 500 translate/n"))))
127 :     (close_window)
128 :     (format "showpage/n")))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help