[wadalabfont-kit] / lisp / disp.l  

Annotation of /lisp/disp.l

Parent Directory | Revision Log

Revision: 1.5 - (view) (download)

1 : ktanaka 1.1 ; X-Windowを扱うためのCの関数をロードする
2 :     ;
3 :     ;
4 : ktanaka 1.2 ;(code-load '("/home/ktanaka/work/wadalabfont/lisp/window.o") "/usr/X11R6/lib/libX11.so")
5 : ktanaka 1.4 ; (code-load "/usr/X11R6/lib/libX11.so" "/home/ktanaka/work/wadalabfont/lisp/window.o")
6 : ktanaka 1.1 ;
7 :     (declare (err:argument-type err:number-of-arguments err:unbound-variable
8 :     err:zero-division err:undefined-function) special)
9 :    
10 :     ;
11 :     ; PSファイルの出力
12 :     ;
13 :    
14 :     (comment
15 :     (defun out-to-ps-all (outlines tag psfile
16 :     (nameflag)
17 :     (col 9)(line (fix (times 0.67 col)))
18 :     (printfile t))
19 :     (let ((standard-output (outopen (stream psfile)))
20 :     (scale (fix (times 160.0 (min (//$ 9.0 (float col))
21 :     (//$ 6.0 (float line))))))
22 :     (ii nil)(jj nil)(page nil)(last nil)
23 :     (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
24 :     (date (date-time)))
25 :     (format "%!/n%%BoundingBox: 45 45 /c /c/n"
26 :     (plus 55 (fix (times 0.001 scale (- (* line 500) 100))))
27 :     (plus 55 (fix (times 0.001 scale (- (* col 500) 100)))))
28 :     (format "50 50 translate/n0.001 /c mul dup scale/n" scale)
29 :     (format "//Helvetica findfont 70 scalefont setfont/n")
30 :     (setq ii 0 jj 0 page 1)
31 :     (and printfile
32 :     (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"
33 :     (substring date 0 2)
34 :     (substring date 2 4)(substring date 4 6)
35 :     (substring date 6 8)(substring date 8 10)
36 :     psfile page))
37 :     (do
38 :     ((ol outlines (cdr ol))
39 :     (l nil))
40 :     ((atom ol))
41 :     (princ ";" terminal-output)
42 :     ; (princ (gccount) terminal-output)
43 :     (print (car ol) terminal-output)
44 :     (setq l
45 :     (let ((err:argument-type #'(lambda (x (y))(throw 'err)))
46 :     (err:number-of-arguments #'(lambda (x (y))(throw 'err)))
47 :     (err:unbound-variable #'(lambda (x (y))(throw 'err)))
48 :     (err:undefined-function #'(lambda (x (y))(throw 'err)))
49 :     (err:zero-division #'(lambda (x (y))(throw 'err))))
50 :     (catch 'err
51 : ktanaka 1.3 (skeleton2list (normkanji (rm-limit (applykanji (car ol) tag)) tag)))))
52 : ktanaka 1.1 (cond
53 :     ((atom l)
54 :     (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
55 :     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
56 :     (cond (nameflag
57 :     (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
58 :     (cond ((lessp (string-length (car ol)) 10) 100)
59 :     (t
60 :     (fix (quotient 800 (string-length (car ol)))))))
61 :     (format "0 410 moveto </c> show/n" (euc2jis(car ol)))))
62 :     )
63 :     (t
64 :     (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
65 :     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
66 :     (cond (nameflag
67 :     (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
68 :     (cond ((lessp (string-length (car ol)) 10) 100)
69 :     (t
70 :     (fix (quotient 800 (string-length (car ol)))))))
71 :     (format "0 410 moveto </c> show/n" (euc2jis (car ol)))))
72 :     (do ((ll l (cdr ll)))
73 :     ((atom ll))
74 :     (setq last (caar ll))
75 :     (format "newpath /c /c moveto/n" (fix (cadr last))
76 :     (- 400 (fix (caddr last))))
77 :     (do ((lll (cdar ll) (cdr lll)))
78 :     ((atom lll))
79 :     (match
80 :     (car lll)
81 :     (('angle x y)
82 :     (format "/c /c lineto/n" (fix x) (- 400 (fix y))))
83 :     (('bezier x0 y0)
84 :     (setq next (cadr lll))
85 :     (setq nextnext
86 :     (cond ((cddr lll)(setq lll (cddr lll))(car lll))
87 :     (t (setq lll (cdr lll))last)))
88 :     (setq x1 (cadr next) y1 (caddr next))
89 :     (setq x2 (cadr nextnext) y2 (caddr nextnext))
90 :     (format
91 :     "/c /c /c /c /c /c curveto/n"
92 :     (fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2))))))
93 :     (format "closepath fill/n"))))
94 :     (setq ii (1+ ii))
95 :     (cond ((eq ii col)
96 :     (format "500 /c translate/n" (* -500 (1- col)))
97 :     (setq ii 0)
98 :     (setq jj (1+ jj))
99 :     (cond ((and (eq jj line)(consp (cdr ol)))
100 :     (format "showpage/n")
101 :     (format "50 50 translate/n")
102 :     (format "0.001 /c mul dup scale/n" scale)
103 :     (format "//Helvetica findfont 70 scalefont setfont/n")
104 :     (setq page (1+ page))
105 :     (and printfile
106 :     (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"
107 :     (substring date 0 2)
108 :     (substring date 2 4)(substring date 4 6)
109 :     (substring date 6 8)(substring date 8 10)
110 :     psfile page))
111 :     (format "//Ryumin-Light-Ext-H findfont 100 scalefont setfont/n")
112 :     (setq jj 0))))
113 :     (t (format "0 500 translate/n"))))
114 :     (format "showpage/n")))
115 :     )
116 :    
117 :     ;
118 : ktanaka 1.2 ; アウトライン形式のデータを表示する
119 :     ;
120 :     (defun showOutline (outline)
121 :     (init_window 400 400)
122 :     (mapcar outline '(lambda (x)(drawlines (setpart1 x))))
123 :     (redraw)
124 :     (checkevent)
125 :     (close_window))
126 :     ;
127 :     ; スケルトンデータを renderingして表示する
128 :     ;
129 :     (defun showSkeleton (skeleton tag)
130 : ktanaka 1.3 (showOutline (skeleton2list skeleton tag)))
131 : ktanaka 1.2 ;
132 :     ; スケルトンデータを折れ線に変換する.
133 :     ;
134 :     (defun skeletonToLinesList (skeleton)
135 :     (lets ((points (car skeleton))
136 :     (lineslist)
137 :     (elements (cadr skeleton))
138 :     (linkPoints))
139 :     (mapc elements
140 :     #'(lambda (element)
141 :     (lets ((links (assq 'link (cddr element))))
142 :     (and links
143 :     (mapc (cdr links)
144 :     #'(lambda (p) (or (memq p linkPoints)
145 :     (push p linkPoints))))))))
146 :     (mapc elements
147 :     #'(lambda (element)
148 :     (lets ((lines))
149 :     (mapc (cadr element)
150 :     #'(lambda (p)
151 :     (lets ((point (nth p points))
152 :     (x (fix (car point)))
153 :     (y (fix (cadr point))))
154 :     (push `(,x .,y) lines))))
155 :     (push lines lineslist))))
156 :     (mapc linkPoints
157 :     #'(lambda (p) (push (makeSquareLines (nth p points)) lineslist)))
158 :     lineslist))
159 :     ;
160 :     ; ある点を中心に四角を書く
161 :     ; (100.0 100.0) ->
162 :     ; ((98 . 98)(98 . 102)(102 . 102)(102 . 98)(98 . 98)
163 :     (defun makeSquareLines (point (d 2))
164 :     (lets ((x (fix (car point)))
165 :     (y (fix (cadr point))))
166 :     `((,(- x d).,(- y d))
167 :     (,(- x d).,(+ y d))
168 :     (,(+ x d).,(+ y d))
169 :     (,(+ x d).,(- y d))
170 :     (,(- x d).,(- y d)))))
171 :    
172 : ktanaka 1.1 ;
173 :     ;
174 :     ;
175 : ktanaka 1.2 (defun showSkeletonByLines (skeleton)
176 :     (init_window 400 400)
177 :     (mapcar (skeletonToLinesList skeleton) #'drawlines)
178 :     (redraw)
179 :     (checkevent)
180 :     (close_window))
181 :    
182 : ktanaka 1.1
183 : ktanaka 1.2
184 :     ;
185 :     ;
186 :     ;
187 : ktanaka 1.1 (defun showtest (l tag)
188 : ktanaka 1.2 (showSkeleton (applykanji l tag) tag))
189 : ktanaka 1.1 ;
190 :     (defun showtest1 (l tag)
191 :     (lets ((outline nil))
192 :     (init_window 400 400)
193 : ktanaka 1.3 (setq outline (makeoutline (skeleton2list (applykanji l tag) tag)))
194 : ktanaka 1.1 (mapcar outline '(lambda (x)(drawlines (setpart1 x))))
195 :     (redraw)
196 :     (checkevent)
197 :     (close_window)))
198 :     ;
199 :     ; 塗りつぶして表示する
200 :     ;
201 :    
202 :     (defun filltest (l tag)
203 :     (init_window 400 400)
204 : ktanaka 1.3 (mapcar (skeleton2list (rm-limit (applykanji l tag)) tag)
205 : ktanaka 1.1 (function (lambda (x)(fillpolygon (setpart1 x)))))
206 :     (redraw)
207 :     (checkevent)
208 :     (close_window))
209 :    
210 :    
211 :     (defun drawpoints (points)
212 :     (init_window 400 400)
213 :     (do ((l points (cdr l))
214 :     (ret nil))
215 :     ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))
216 :     (push (cons (fix (caar l))(fix (cadar l))) ret)))
217 :     (defun drawbezier (points bezier)
218 :     (init_window 400 400)
219 :     (drawlines (setpart1 bezier))
220 :     (do ((l points (cdr l))
221 :     (ret nil))
222 :     ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))
223 :     (push (cons (fix (caar l))(fix (cadar l))) ret)))
224 :     (defun drawbezier1 (points bezier)
225 :     (init_window 400 400)
226 :     (do ((l bezier (cdr l))
227 :     (ret nil))
228 :     ((atom l)(drawlines ret))
229 :     (push (cons (fix (cadr (car l)))(fix (caddr (car l)))) ret))
230 :     (do ((l points (cdr l))
231 :     (ret nil))
232 :     ((atom l)(drawlines ret)(redraw)(checkevent)(close_window))
233 :     (push (cons (fix (caar l))(fix (cadar l))) ret)))
234 :     ;
235 : ktanaka 1.4 (defun jointtest (prim1 prim2 affine type)
236 :     (filltest
237 :     (rmlimit (appendpart prim1
238 :     (affinepart prim2 affine))) type))
239 :     (defun rmlimit (x)
240 :     (lets ((elements (cadr x))(ret))
241 :     (do ((l elements (cdr l)))
242 :     ((atom l)`(,(car x) ,(nreverse ret) .,(cddr x)))
243 :     (or (memq (caar l) '(xlimit ylimit))(push (car l) ret)))))
244 : ktanaka 1.5 ;
245 :     ; Bezier曲線を直線群で近似する
246 :     ;
247 :     (defun bez (x0 y0 x1 y1 x2 y2 x3 y3 (dlist))
248 :     (lets ((maxx (max x0 x1 x2 x3))
249 :     (maxy (max y0 y1 y2 y3))
250 :     (minx (min x0 x1 x2 x3))
251 :     (miny (min y0 y1 y2 y3)))
252 :     (cond
253 :     ((or (lessp (difference maxx minx) 2)
254 :     (lessp (difference maxy miny) 2))
255 :     `((,(fix x3) . ,(fix y3)).,dlist))
256 :     (t
257 :     (lets ((tempx (times 0.125 (plus x0 (times 3 x1)(times 3 x2) x3)))
258 :     (tempy (times 0.125 (plus y0 (times 3 y1)(times 3 y2) y3))))
259 :     (bez tempx tempy
260 :     (times (plus x3 x2 x2 x1) 0.25)
261 :     (times (plus y3 y2 y2 y1) 0.25)
262 :     (times (plus x3 x2) 0.5)
263 :     (times (plus y3 y2) 0.5)
264 :     x3 y3
265 :     (bez x0 y0
266 :     (times (plus x0 x1) 0.5)
267 :     (times (plus y0 y1) 0.5)
268 :     (times (plus x0 x1 x1 x2) 0.25)
269 :     (times (plus y0 y1 y1 y2) 0.25)
270 :     tempx tempy dlist)))))))
271 :     ;
272 :     ; アウトラインから折れ線への変換を行なう
273 :     ;
274 :    
275 :     (defun setpart1 (l)
276 :     (and l
277 :     (lets ((last (car l))
278 :     (curx (cadr last))
279 :     (cury (caddr last))
280 :     (x0)(y0)(x1)(y1)(x2)(y2)
281 :     (ret `((,(fix curx).,(fix cury)))))
282 :     (do ((ll (cdr l) (cdr ll)))
283 :     ((atom ll)ret)
284 :     (match ll
285 :     ((('angle x0 y0).next)
286 :     (setq ret `((,(fix x0).,(fix y0)).,ret))
287 :     (setq curx x0 cury y0))
288 :     ((('bezier x0 y0)('bezier x1 y1))
289 :     (exit (bez curx cury x0 y0 x1 y1 (cadr last)(caddr last) ret)))
290 :     ((('bezier x0 y0)('bezier x1 y1)('angle x2 y2).next)
291 :     (setq ret (bez curx cury x0 y0 x1 y1 x2 y2 ret))
292 :     (setq curx x2 cury y2)
293 :     (setq ll (cddr ll)))
294 :     (any (break) ; 想定しない入力
295 :     ))))))
296 :    
297 :     (defun jointtest (prim1 prim2 affine type)
298 :     (filltest
299 :     (rmlimit (appendpart prim1
300 :     (affinepart prim2 affine))) type))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help