[wadalabfont-kit] / renderer / newjoint.l  

Annotation of /renderer/newjoint.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 ;
2 :     (defun joint (fonttype affines prims (alist))
3 :     (do ((outlines (affinepart (applykanji (car prims)fonttype)(car affines)))
4 :     (a (cdr affines)(cdr a))
5 :     (p (cdr prims)(cdr p)))
6 :     ((atom p)`(,(car outlines),(cadr outlines).,(append alist a)))
7 :     (setq outlines
8 :     (appendpart outlines
9 :     (affinepart (applykanji (car p) fonttype)(car a))))))
10 :     ;
11 :     (defun applyhook (prim jointtype i n)
12 :     (lets ((alist (cddr prim))
13 :     (hook (assq 'primhook alist)))
14 :     (cond ((and hook (funcall (cadr hook) jointtype i n)
15 :     (funcall (cddr hook) prim jointtype i n)))
16 :     (t prim))))
17 :     ;
18 :     (putprop
19 :     'tate
20 :     #'(lambda (fonttype prims)
21 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
22 :     (affines (affine-tate-n nprims fonttype)))
23 :     `(joint ',affines ',prims nil)))
24 :     'expand)
25 :     (defun tate (fonttype prims)
26 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
27 :     (affines (affine-tate-n nprims fonttype)))
28 :     (joint fonttype affines nprims nil)))
29 :     (defun affine-tate-n (primlist fonttype (alist))
30 :     (lets ((n (length primlist))
31 :     (nprims)
32 :     (affines)(newaffines)
33 :     (yunits)(yunit1)
34 :     (vals)(val)(ratio)
35 :     (aprim)
36 :     (param)(yscale)(centerp)
37 :     (newalist `((xlimitratio . 1.0) .,alist))
38 :     (xunit))
39 :     (do ((l primlist (cdr l))
40 :     (i 0 (1+ i))
41 :     (prim)
42 :     (xunitmin)
43 :     (realregion)
44 :     (region)
45 :     )
46 :     ((atom l)
47 :     (setq yunits (nreverse yunits))
48 :     (setq affines (nreverse affines))
49 :     (setq xunit xunitmin)
50 :     )
51 :     (setq aprim (applykanji (car l) fonttype))
52 :     (setq aprim (applyhook aprim 'tate i n))
53 :     (and (prim-center aprim)(setq centerp 200))
54 :     (push (add-xlimit (add-unit aprim)) nprims)
55 :     (setq xlimit (assq 'xlimit (cddar nprims)))
56 :     (setq realregion (realregion (car nprims)))
57 :     (push (region2region `(,(cadr xlimit) ,(second realregion)
58 :     ,(caddr xlimit) ,(fourth realregion))
59 :     '(0 0 400 200))
60 :     affines)
61 :     (setq prim (affinepart (car nprims) (car affines)))
62 :     (push (yunit prim 200.0) yunits)
63 :     (setq xunit (xunit prim 100.0))
64 :     (and xunit (or (null xunitmin)(greaterp xunitmin xunit))
65 :     (setq xunitmin xunit)))
66 :     (setq primlist (nreverse nprims))
67 :     (setq yunit1 (car yunits))
68 :     (setq param `((xunit 0 .,xunit)(yunit 0 .,yunit1)))
69 :     (do ((l (cdr primlist) (cdr l))
70 :     (yunit_l (cdr yunits) (cdr yunit_l))
71 :     (affine_l (cdr affines)(cdr affine_l))
72 :     (affine)(prim)
73 :     (lastprim (affinepart (car primlist)(car affines))))
74 :     ((atom l))
75 :     (setq ratio (//$ (float yunit1)(float (car yunit_l))))
76 :     (setq affine
77 :     (times-affine (vector 6 `(1 0 0 ,ratio 0 10000)) (car affine_l)))
78 :     (setq prim (affinepart (car l) affine))
79 :     (setq val (difference 10005
80 :     (general-limit lastprim prim #(0 0 0 0 0 -1) param)))
81 :     ; (prind val)
82 :     (push (times-affine (vector 6 `(1 0 0 ,ratio 0 ,val))(car affine_l))
83 :     newaffines)
84 :     (setq lastprim (affinepart (car l)(car newaffines))))
85 :     (setq yscale (quotient 400.0 (plus val (times ratio 200.0))))
86 :     (do ((l newaffines (cdr l))
87 :     (ret `((yunit .,(times yscale yunit1))
88 :     (xunit .,xunit)
89 :     (xlimit 0 400)
90 :     (center .,centerp)))
91 :     (vec (vector 6 `(1 0 0 ,yscale 0 0))))
92 :     ((atom l)
93 :     (push (times-affine vec (car affines)) ret)
94 :     ret)
95 :     (push (times-affine vec (car l)) ret))))
96 :    
97 :     ;
98 :     ; 横方向
99 :     ;
100 :     (putprop
101 :     'yoko
102 :     #'(lambda (fonttype prims)
103 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
104 :     (affines (affine-yoko-n nprims fonttype)))
105 :     `(joint ',affines ',prims nil)))
106 :     'expand)
107 :     (defun yoko (fonttype prims)
108 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
109 :     (affines (affine-yoko-n nprims fonttype)))
110 :     (joint fonttype affines nprims nil)))
111 :     (defun affine-yoko-n (primlist fonttype (alist))
112 :     (lets ((n (length primlist))
113 :     (nprims)
114 :     (affines)(newaffines)
115 :     (xunits)(xunit1)
116 :     (vals)(val)(ratio)
117 :     (param)(xscale)
118 :     ; (newalist `((ylimitratio . 0.5)(xlimitratio . 0.1) .,alist))
119 :     (realregion)(region)
120 :     (yunit))
121 :     (do ((l primlist (cdr l))
122 :     (i 0 (1+ i))(prim)
123 :     ; (yunitsum 0)
124 :     (aprim)
125 :     (yunitmin)
126 :     )
127 :     ((atom l)
128 :     (setq xunits (nreverse xunits))
129 :     (setq affines (nreverse affines))
130 :     ; (setq yunit (//$ (float yunitsum)(float n)))
131 :     (setq yunit yunitmin)
132 :     )
133 :     (setq aprim (applykanji (car l) fonttype))
134 :     (setq aprim (applyhook aprim 'yoko i n))
135 :     (and (prim-center aprim)(setq centerp 200))
136 :     (push (add-ylimit (add-unit aprim)) nprims)
137 :     ; (cond (
138 :     (setq ylimit (assq 'ylimit (cddar nprims)))
139 :     (setq realregion (realregion (car nprims)))
140 :     (push (region2region `(,(first realregion) ,(cadr ylimit)
141 :     ,(third realregion) ,(caddr ylimit))
142 :     '(0 0 200 400))
143 :     affines)
144 :     ; )
145 :     ; (t
146 :     ; (push (region-affine
147 :     ; (virtual-region '(nil nil) '(0 0 200 400))
148 :     ; (car nprims) `((ylimit 0 . 50).,newalist) '(0 0 200 400))
149 :     ; affines)))
150 :     (setq prim (affinepart (car nprims) (car affines)))
151 :     (push (xunit prim 200.0) xunits)
152 :     ; (setq yunitsum (plus yunitsum (yunit prim 100.0)))
153 :     (setq yunit (yunit prim 100.0))
154 :     (and yunit
155 :     (or (null yunitmin)(greaterp yunitmin yunit))
156 :     (setq yunitmin yunit))
157 :     )
158 :     (setq primlist (nreverse nprims))
159 :     (setq xunit1 (car xunits))
160 :     (setq param `((yunit 0 .,yunit)(xunit 0 .,xunit1)))
161 :     (do ((l (cdr primlist) (cdr l))
162 :     (xunit_l (cdr xunits) (cdr xunit_l))
163 :     (affine_l (cdr affines)(cdr affine_l))
164 :     (affine)(prim)
165 :     (lastprim (affinepart (car primlist)(car affines))))
166 :     ((atom l))
167 :     (setq ratio (//$ (float xunit1)(float (car xunit_l))))
168 :     (setq affine
169 :     (times-affine (vector 6 `(,ratio 0 0 1 1000 0)) (car affine_l)))
170 :     (setq prim (affinepart (car l) affine))
171 :     ; (prind (list param lastprim prim))
172 :     ; (setq val (difference 1000
173 :     ; (general-limit lastprim prim #(0 0 0 0 -1 0) param)))
174 :     (setq val (difference 1001
175 :     (general-limit lastprim prim #(0 0 0 0 -1 0) param)))
176 :     ; (prind val)
177 :     (push (times-affine (vector 6 `(,ratio 0 0 1 ,val 0))(car affine_l))
178 :     newaffines)
179 :     (setq lastprim (affinepart (car l)(car newaffines))))
180 :     (setq xscale (quotient 400.0 (plus val (times ratio 200.0))))
181 :     (do ((l newaffines (cdr l))
182 :     (ret `((xunit .,(times xscale xunit1))
183 :     (yunit .,yunit)
184 :     (ylimit 0 400)
185 :     (center)))
186 :     (vec (vector 6 `(,xscale 0 0 1 0 0))))
187 :     ((atom l)
188 :     (push (times-affine vec (car affines)) ret)
189 :     ret)
190 :     (push (times-affine vec (car l)) ret))))
191 :     ;
192 :     (defun normkanji (prim)
193 :     (lets ((nprim (add-xlimit (add-ylimit (add-unit prim))))
194 :     (alist (cddr nprim))
195 :     (xlimit (assq 'xlimit alist))
196 :     (ylimit (assq 'ylimit alist))
197 :     (affine (region2region `(,(cadr xlimit),(cadr ylimit)
198 :     ,(caddr xlimit),(caddr ylimit))
199 :     '(15 15 385 385))))
200 :     (affinepart prim affine)))
201 :     ;
202 :     ; たれ, かまえ
203 :     ;
204 :     (defun affine-tare (prim1 prim2 fonttype)
205 :     (affine-inner2 (applyhook prim1 'tare 0 2)
206 :     (applyhook prim2 'tare 1 2)
207 :     nil '(300 300)
208 :     (assqcdr '(tare kamae) (cddr prim1))
209 :     ))
210 :     ;
211 :     (putprop
212 :     'tare
213 :     #'(lambda (fonttype prims)
214 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
215 :     (affines (affine-tare (car nprims)(cadr nprims) fonttype)))
216 :     `(joint ',affines ',prims nil)))
217 :     'expand)
218 :     (defun tare (fonttype prims)
219 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
220 :     (prim1 (car nprims))(prim2 (cadr nprims)))
221 :     (cond ((checkhook2 'tare prim1 prim2 nil))
222 :     (t
223 :     (joint fonttype
224 :     (affine-tare (car nprims)(cadr nprims) fonttype)
225 :     nprims nil)))))
226 :     ;
227 :     (defun affine-kamae (prim1 prim2 fonttype)
228 :     (affine-inner2 (applyhook prim1 'kamae 0 2)
229 :     (applyhook prim2 'kamae 1 2)
230 :     nil '(200 300)
231 :     (assqcdr 'kamae (cddr prim1))))
232 :     ;
233 :     ;
234 :     (putprop
235 :     'kamae
236 :     #'(lambda (fonttype prims)
237 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
238 :     (affines (affine-kamae (car nprims)(cadr nprims) fonttype)))
239 :     `(joint ',affines ',prims nil)))
240 :     'expand)
241 :     (defun kamae (fonttype prims)
242 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
243 :     (prim1 (car nprims))(prim2 (cadr nprims)))
244 :     (cond ((checkhook2 'kamae prim1 prim2 nil))
245 :     (t
246 :     (joint fonttype
247 :     (affine-kamae (car nprims)(cadr nprims) fonttype)
248 :     nprims nil)))))
249 :     ;
250 :     (defun assqcdr (key list)
251 :     (cond ((consp key)
252 :     (do ((l key (cdr l))(assq))
253 :     ((atom l))
254 :     (setq assq (assq (car l) list))
255 :     (and assq (exit (cdr assq)))))
256 :     (t
257 :     (let ((assq (assq key list)))
258 :     (and assq (cdr assq))))))
259 :     ;
260 :     (defun affine-kamae2 (prim1 prim2 prim3 fonttype)
261 :     (lets ((nprim1 `(,(car prim1) ,(cadr prim1) (center).,(cddr prim1)))
262 :     (affine1 (affine-inner2 nprim1 prim2 nil '(150 130)
263 :     (assqcdr 'kamae1 (cddr nprim1))))
264 :     (affine2 (affine-inner2 nprim1 prim3 nil '(250 130)
265 :     (assqcdr 'kamae2 (cddr nprim1)))))
266 :     `(,(car affine1),(cadr affine1),(cadr affine2).,(cddr affine1))))
267 :     ;
268 :     (putprop
269 :     'kamae2
270 :     #'(lambda (fonttype prims)
271 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
272 :     (affines
273 :     (affine-kamae2 (car nprims)(cadr nprims)(third nprims) fonttype)))
274 :     `(joint ',affines ',prims nil)))
275 :     'expand)
276 :     (defun kamae2 (fonttype prims)
277 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
278 :     (prim1 (car nprims))(prim2 (cadr nprims))(prim3 (third nprims)))
279 :     (joint fonttype
280 :     (affine-kamae2 prim1 prim2 prim3 fonttype)
281 :     nprims nil)))
282 :     ;
283 :     (defun affine-nyou (prim1 prim2 (alist))
284 :     (affine-inner2 (applyhook prim1 'nyou 0 2)
285 :     (applyhook prim2 'nyou 1 2)
286 :     alist '(300 100)
287 :     (assqcdr 'nyou (cddr prim1))
288 :     ))
289 :     ;
290 :     (putprop
291 :     'nyou
292 :     #'(lambda (fonttype prims)
293 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
294 :     (affines (affine-nyou (car nprims)(cadr nprims) fonttype)))
295 :     `(joint ',affines ',prims nil)))
296 :     'expand)
297 :     (defun nyou (fonttype prims)
298 :     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
299 :     (prim1 (car nprims))(prim2 (cadr nprims)))
300 :     (cond ((checkhook2 'nyou prim1 prim2 nil))
301 :     (t
302 :     (joint fonttype
303 :     (affine-nyou (car nprims)(cadr nprims) fonttype)
304 :     nprims nil)))))
305 :     ;
306 :     (defun enlarge-region (region (rate 1.1))
307 :     (lets ((minx (first region))
308 :     (miny (second region))
309 :     (maxx (third region))
310 :     (maxy (fourth region))
311 :     (centerx (times 0.5 (plus minx maxx)))
312 :     (centery (times 0.5 (plus miny maxy)))
313 :     (minx (max 0 (plus centerx (times rate (difference minx centerx)))))
314 :     (maxx (min 400 (plus centerx (times rate (difference maxx centerx)))))
315 :     (miny (max 0 (plus centery (times rate (difference miny centery)))))
316 :     (maxy (min 400 (plus centery (times rate (difference maxy centery)))))
317 :     )
318 :     `(,minx ,miny ,maxx ,maxy)))
319 :     ;
320 :     (defun interregion (r1 r2)
321 :     `(,(max (first r1)(first r2))
322 :     ,(max (second r1)(second r2))
323 :     ,(min (third r1)(third r2))
324 :     ,(min (fourth r1)(fourth r2))))
325 :    
326 :     ;
327 :     (defun affine-inner2 (prim1 prim2 alist init-point (region))
328 :     (lets ((realregion (realregion prim1))
329 :     (region (or region (largest-region prim1 init-point realregion)))
330 :     ; (soko (print region))
331 :     (nprim1 (add-unit prim1))
332 :     (xunit1 (xunit nprim1))
333 :     (yunit1 (yunit nprim1))
334 :     (nprim1
335 :     (virtual-region prim1
336 :     (enlarge-region region 1.0)))
337 :     (center1 (prim-center prim1))
338 :     (nprim2 (add-unit prim2))
339 :     (xunit2 (xunit nprim2))
340 :     (yunit2 (yunit nprim2))
341 :     ; (newalist `((xlimitratio . 0.7) .,alist))
342 :     (newalist `((ylimit 0 . 50)(xlimitratio . 0.7) .,alist))
343 :     (nprim3 `(,(car nprim1) ,(cadr nprim1)
344 :     (center .,center1) .,(cddr nprim1)))
345 :     ; (soko (break))
346 :     (affine (region-affine nprim3 nprim2 newalist region))
347 :     (xunit2 (times (vref affine 0) xunit2))
348 :     (yunit2 (times (vref affine 3) yunit2))
349 :     (xunit (min xunit1 xunit2))
350 :     (yunit (min yunit1 yunit2))
351 :     )
352 :     `(#(1 0 0 1 0 0)
353 :     ,affine
354 :     (center .,center1)
355 :     (xunit .,xunit)
356 :     (yunit .,yunit)
357 :     .,(cddr prim1)
358 :     )))
359 :     ;
360 :     (defun goodcenter (center region)
361 :     (let ((x0 (first region))
362 :     (x1 (third region)))
363 :     (lessp (plus (times 0.7 x0)(times 0.3 x1))
364 :     center
365 :     (plus (times 0.3 x0)(times 0.7 x1)))))
366 :     ;
367 :     (comment
368 :     (defun region-affine (prim1 prim2 alist region)
369 :     (lets ((realregion (realregion prim2))
370 :     (rw (float (region-width realregion)))
371 :     (rh (float (region-height realregion)))
372 :     (xunit (xunit prim2))
373 :     (yunit (yunit prim2))
374 :     (center1 (prim-center prim1))
375 :     (center2 (prim-center prim2))
376 :     (center (and center1 (goodcenter center1 region) center2))
377 :     (affine1
378 :     (cond
379 :     (center
380 :     (movexy
381 :     center1 (times 0.5 (plus (second region)(fourth region)))
382 :     (scalexy (cond ((zerop rw)1)
383 :     (t (//$ (float (region-width region))
384 :     rw)))
385 :     (cond ((zerop rh)1)
386 :     (t (//$ (float (region-height region))
387 :     rh)))
388 :     (movexy
389 :     (minus center2)
390 :     (minus (times 0.5 (plus (second realregion)
391 :     (fourth realregion))))))))
392 :     (t (region2region realregion region))))
393 :     (prim21 (affinepart prim2 affine1))
394 :     (rc (region-center region))
395 :     (rc (cond (center `(,center1 ,(cadr rc)))(t rc)))
396 :     (conv1 (scaleconv rc))
397 :     (xunit1 (times xunit (vref affine1 0)))
398 :     (yunit1 (times yunit (vref affine1 3)))
399 :     (xlimitratio (cdr (or (assq 'xlimitratio alist)'(nil . 0.3))))
400 :     (ylimitratio (cdr (or (assq 'ylimitratio alist)'(nil . 0.5))))
401 :     (alist_xlimit (assqcdr 'xlimit alist))
402 :     (alist_ylimit (assqcdr 'ylimit alist))
403 :     (xlimit (times xlimitratio xunit1))
404 :     (ylimit (times ylimitratio yunit1))
405 :     (oldparam `((xlimit .,(or alist_xlimit (cons xlimit xlimit)))
406 :     (ylimit .,(or alist_ylimit (cons ylimit ylimit)))))
407 :     ; (soko (break))
408 :     (section1 (goodsection1
409 :     (general-section prim1 prim21 conv1
410 :     `((xunit ,xunit1 .,xunit1)
411 :     (yunit ,yunit1 .,yunit1).,oldparam))))
412 :     ; (soko (break))
413 :     (limit1 (plus 1 (rm-eq (cdr section1))))
414 :     (llimit1 (plus 1 (rm-eq (car section1))))
415 :     (limit11)(limit12)
416 :     (lratio (cond ((and llimit1 (lessp (times 0.63 limit1) llimit1))
417 :     ; (break)
418 :     (setq limit11 (//$ (float llimit1)(float limit1)))
419 :     (setq limit12 (plus (times 0.5 limit11) 0.5))
420 :     (setq limit11 (plus (times 0.25 limit11) 0.75))
421 :     (//$ limit11 (difference limit11 limit12)))
422 :     (t (setq limit11 0.7 limit12 0.63) 10.0)))
423 :    
424 :     (limit11 (difference (times limit11 limit1) 1))
425 :     (affine21 (times-affine (scale-affine limit11 conv1) affine1))
426 :     (prim221 (affinepart prim2 affine21))
427 :     (xunit21 (times (plus 1 limit11) xunit1))
428 :     (yunit21 (times (plus 1 limit11) yunit1))
429 :     (xlimit1 (times xlimitratio xunit21))
430 :     (ylimit1 (times ylimitratio yunit21))
431 :     (oldparam `((xlimit .,(or alist_xlimit (cons 0 xlimit1)))
432 :     (ylimit .,(or alist_ylimit (cons 0 ylimit1)))))
433 :     (param `((xunit 0 .,xunit21)(yunit 0 .,yunit21).,oldparam))
434 :     (section21 (general-section prim1 prim221 #(0 0 0 0 0 1) param))
435 :     (ay (section-plus section21))
436 :     (by (section-minus section21))
437 :     (section31 (general-section prim1 prim221 #(0 0 0 0 1 0) param))
438 :     (ax (section-plus section31))
439 :     (bx (section-minus section31))
440 :    
441 :     (limit12 (difference (times limit12 limit1) 1))
442 :     (affine22 (times-affine (scale-affine limit12 conv1) affine1))
443 :     (prim222 (affinepart prim2 affine22))
444 :     (xunit22 (times (plus 1 limit12) xunit1))
445 :     (yunit22 (times (plus 1 limit12) yunit1))
446 :     (xlimit2 (times xlimitratio xunit22))
447 :     (ylimit2 (times ylimitratio yunit22))
448 :     (oldparam `((xlimit .,(or alist_xlimit (cons 0 xlimit2)))
449 :     (ylimit .,(or alist_ylimit (cons 0 ylimit2)))))
450 :     (param `((xunit 0 .,xunit22)(yunit 0 .,yunit22).,oldparam))
451 :     (section22 (general-section prim1 prim222 #(0 0 0 0 0 1) param))
452 :     (cy (section-plus section22))
453 :     (dy (section-minus section22))
454 :     (section32 (general-section prim1 prim222 #(0 0 0 0 1 0) param))
455 :     (cx (section-plus section32))
456 :     (dx (section-minus section32))
457 :     (px (times lratio (difference cx ax)))
458 :     (qx (times lratio (difference dx bx)))
459 :     (py (times lratio (difference cy ay)))
460 :     (qy (times lratio (difference dy by)))
461 :     ; (soko (print rc))
462 :     (rc1 `(,(plus (car rc)
463 :     (times 0.5 (difference (plus px ax)(plus qx bx))))
464 :     ,(plus (cadr rc)
465 :     (times 0.5 (difference (plus py ay)(plus qy by))))))
466 :     (rc1 (cond (center `(,center1 ,(cadr rc1)))(t rc1)))
467 :     ; (soko (print rc1))
468 :     (sx (cond (center
469 :     (min (//$ (plus ax px) px)(//$ (plus bx qx) qx)))
470 :     (t (//$ (float (plus px qx ax bx))(float (plus qx px))))))
471 :     (sy (//$ (float (plus py qy ay by))(float (plus qy py))))
472 :     ; (soko (print (list "sx sy" sx sy)))
473 :     (dx (cond (center 0)(t (times 0.5 (difference ax bx)))))
474 :     (dy (times 0.5 (difference ay by)))
475 :     ; (soko (print (list "dx dy" dx dy)))
476 :     (affine5 (movexy (car rc1)(cadr rc1)
477 :     (scalexy sx sy
478 :     (movexy(difference dx (car rc1))
479 :     (difference dy (cadr rc1))
480 :     affine21))))
481 :     (prim25 (affinepart prim2 affine5))
482 :     (conv5 (scaleconv rc1))
483 :     (xunit5 (times xunit (vref affine5 0)))
484 :     (yunit5 (times yunit (vref affine5 3)))
485 :     (xlimit (times xlimitratio xunit5))
486 :     (ylimit (times ylimitratio yunit5))
487 :     (oldparam `((xlimit .,(or alist_xlimit (cons xlimit xlimit)))
488 :     (ylimit .,(or alist_ylimit (cons ylimit ylimit)))))
489 :     (limit5 (general-limit prim1 prim25 conv5
490 :     `((xunit ,xunit5 .,xunit5)
491 :     (yunit ,yunit5 .,yunit5).,oldparam)))
492 :     (limit5 (or limit5 0.8)))
493 :     (times-affine (scale-affine limit5 conv5) affine5)))
494 :     )
495 :     ;
496 :     (defun largest-region (prim point (orgregion '(0 0 400 400)))
497 :     (lets ((px (car point))
498 :     (py (cadr point))
499 :     (points (car prim))
500 :     (lines (cadr prim))
501 :     (largest-region (assq 'largest-region (cddr prim)))
502 :     (minx (first orgregion))
503 :     (miny (second orgregion))
504 :     (maxx (third orgregion))
505 :     (maxy (fourth orgregion)))
506 :     (cond
507 :     (largest-region (cdr largest-region))
508 :     (t
509 :     (do ((l lines (cdr l)))
510 :     ((atom l)`(,minx ,miny ,maxx ,maxy))
511 :     (do ((ll (cadar l) (cdr ll))(p0)(p1)(x0)(x1)(y0)(y1)(x)(y))
512 :     ((atom (cdr ll)))
513 :     (setq p0 (nth (car ll) points) p1 (nth (cadr ll) points))
514 :     (setq x0 (car p0) y0 (cadr p0))
515 :     (setq x1 (car p1) y1 (cadr p1))
516 :     (cond
517 :     ((and (greaterp y0 py)(greaterp y1 py)
518 :     (or (greaterp x0 px x1)(greaterp x1 px x0))
519 :     (lessp
520 :     (setq y
521 :     (plus
522 :     (times (float y1)
523 :     (//$
524 :     (float (difference px x0))
525 :     (float (difference x1 x0))))
526 :     (times y0
527 :     (//$
528 :     (float (difference x1 px))
529 :     (float (difference x1 x0))))))
530 :     maxy))
531 :     (setq maxy y))
532 :     ((and (lessp y0 py)(lessp y1 py)
533 :     (or (greaterp x0 px x1)(greaterp x1 px x0))
534 :     (greaterp
535 :     (setq y
536 :     (plus
537 :     (times (float y1)
538 :     (//$
539 :     (float (difference px x0))
540 :     (float (difference x1 x0))))
541 :     (times y0
542 :     (//$
543 :     (float (difference x1 px))
544 :     (float (difference x1 x0))))))
545 :     miny))
546 :     (setq miny y))
547 :     ((and (greaterp x0 px)(greaterp x1 px)
548 :     (or (greaterp y0 py y1)(greaterp y1 py y0))
549 :     (lessp
550 :     (setq x
551 :     (plus
552 :     (times (float x1)
553 :     (//$
554 :     (float (difference py y0))
555 :     (float (difference y1 y0))))
556 :     (times x0
557 :     (//$
558 :     (float (difference y1 py))
559 :     (float (difference y1 y0))))))
560 :     maxx))
561 :     (setq maxx x))
562 :     ((and (lessp x0 px)(lessp x1 px)
563 :     (or
564 :     (greaterp y0 py y1)(greaterp y1 py y0)
565 :     )
566 :     (greaterp
567 :     (setq x
568 :     (plus
569 :     (times (float x1)
570 :     (//$
571 :     (float (difference py y0))
572 :     (float (difference y1 y0))))
573 :     (times x0
574 :     (//$
575 :     (float (difference y1 py))
576 :     (float (difference y1 y0))))))
577 :     minx))
578 :     (setq minx x)))))))))
579 :     ;
580 :     (defun region2region (region1 region2)
581 :     (lets ((x11 (first region1))(y11 (second region1))
582 :     (x21 (first region2))(y21 (second region2))
583 :     (diffx1 (difference (third region1)(first region1)))
584 :     (diffy1 (difference (fourth region1)(second region1)))
585 :     (diffx2 (difference (third region2)(first region2)))
586 :     (diffy2 (difference (fourth region2)(second region2))))
587 :     (cond ((and (zerop diffx1)(zerop diffy1))
588 :     (lets
589 :     ((cx (difference (times 0.5 (plus x21 (third region2))) x11))
590 :     (cy (difference (times 0.5 (plus y21 (fourth region2))) y11)))
591 :     (vector 6 `(1 0 0 1 ,cx ,cy))))
592 :    
593 :     ((zerop diffx1)
594 :     (lets ((scaley (//$ (float diffy2)(float diffy1)))
595 :     (cx (difference (times 0.5 (plus x21 (third region2))) x11))
596 :     (cy (difference y21 (times y11 scaley))))
597 :     (vector 6 `(1 0 0 ,scaley ,cx ,cy))))
598 :     ((zerop diffy1)
599 :     (lets ((scalex (//$ (float diffx2)(float diffx1)))
600 :     (cy (difference (times 0.5 (plus y21 (fourth region2))) y11))
601 :     (cx (difference x21 (times x11 scalex))))
602 :     (vector 6 `(,scalex 0 0 1 ,cx ,cy))))
603 :     (t
604 :     (lets ((scalex (//$ (float diffx2)(float diffx1)))
605 :     (scaley (//$ (float diffy2)(float diffy1)))
606 :     (cx (difference x21 (times x11 scalex)))
607 :     (cy (difference y21 (times y11 scaley))))
608 :     (vector 6 `(,scalex 0 0 ,scaley ,cx ,cy)))))))
609 :     ;
610 :     (defun scaleconv (center)
611 :     (lets ((cx (car center))
612 :     (cy (cadr center)))
613 :     (vector 6 `(1 0 0 1 ,(minus cx) ,(minus cy)))))
614 :     ;
615 :     (defun virtual-region (prim region)
616 :     (lets ((points (car prim))
617 :     (lines (cadr prim))
618 :     (alist (cddr prim))
619 :     (index (length points))
620 :     (x0 (first region))(y0 (second region))
621 :     (x1 (third region))(y1 (fourth region)))
622 :     `(,(append points `((,x0 ,y0)(,x1 ,y0)(,x0 ,y1)(,x1 ,y1)))
623 :     ((ylimit (,index ,(1+ index)))
624 :     (ylimit (,(+ index 2) ,(+ index 3)))
625 :     (xlimit (,index ,(+ index 2)))
626 :     (xlimit (,(1+ index) ,(+ index 3)))
627 :     .,lines)
628 :     .,alist)))
629 :     ;
630 :     (defun times-affine (a b)
631 :     (lets ((a11 (vref a 0))(a12 (vref a 2))(a13 (vref a 4))
632 :     (a21 (vref a 1))(a22 (vref a 3))(a23 (vref a 5))
633 :     (b11 (vref b 0))(b12 (vref b 2))(b13 (vref b 4))
634 :     (b21 (vref b 1))(b22 (vref b 3))(b23 (vref b 5))
635 :     (n11 (plus (times a11 b11)(times a12 b21)))
636 :     (n12 (plus (times a11 b12)(times a12 b22)))
637 :     (n13 (plus a13 (times a11 b13)(times a12 b23)))
638 :     (n21 (plus (times a21 b11)(times a22 b21)))
639 :     (n22 (plus (times a21 b12)(times a22 b22)))
640 :     (n23 (plus a23 (times a21 b13)(times a22 b23))))
641 :     (vector 6 `(,n11 ,n21 ,n12 ,n22 ,n13 ,n23))))
642 :     ;
643 :     (defun scaleregion (region sx sy)
644 :     (lets ((x0 (first region))
645 :     (y0 (second region))
646 :     (x1 (third region))
647 :     (y1 (fourth region))
648 :     (cx (times 0.5 (plus x0 x1)))
649 :     (cy (times 0.5 (plus y0 y1)))
650 :     (wx (times sx (difference x1 cx)))
651 :     (wy (times sy (difference y1 cy))))
652 :     `(,(difference cx wx) ,(difference cy wy) ,(plus cx wx) ,(plus cy wy))))
653 :     ;
654 :     (defun section-width (section)
655 :     (let ((sec (goodsection section)))
656 :     (difference (rm-eq (cdr sec))(rm-eq (car sec)))))
657 :     ;
658 :     (defun section-center (section)
659 :     (let ((sec (goodsection section)))
660 :     (times 0.5 (plus (rm-eq (cdr sec))(rm-eq (car sec))))))
661 :     ;
662 :     (defun section-plus (section)
663 :     (let ((sec (goodsection section)))
664 :     (rm-eq (cdr sec))))
665 :     ;
666 :     (defun section-minus (section)
667 :     (let ((sec (goodsection section)))
668 :     (minus (rm-eq (car sec)))))
669 :     ;
670 :     (defun goodsection (section)
671 :     (do ((l (notsection section) (cdr l)))
672 :     ((atom (cdr l))
673 :     ; (print "illegal section" terminal-output)
674 :     ; (print section terminal-output)
675 :     (car l))
676 :     (and (numberp (rm-eq (caar l)))(not (plusp (rm-eq (caar l))))
677 :     (numberp (rm-eq (cdar l)))(not (minusp (rm-eq (cdar l))))
678 :     (exit (car l)))
679 :     (and (cdr l)
680 :     (numberp (rm-eq (cdar l)))(not (plusp (rm-eq (cdar l))))
681 :     (numberp (rm-eq (caadr l)))(not (minusp (rm-eq (caadr l))))
682 :     (exit (car l)))))
683 :     ;
684 :     (comment
685 :     (defun goodsection1 (section)
686 :     (do ((l (notsection section) (cdr l)))
687 :     ((atom (cdr l))
688 :     ; (print "illegal section" terminal-output)
689 :     ; (print section terminal-output)
690 :     (car l))
691 :     (and (numberp (rm-eq (caar l)))(not (plusp (add1 (rm-eq (caar l)))))
692 :     (numberp (rm-eq (cdar l)))(not (minusp (add1 (rm-eq (cdar l)))))
693 :     (exit (car l)))
694 :     (and (cdr l)
695 :     (numberp (rm-eq (cdar l)))(not (plusp (add1(rm-eq (cdar l)))))
696 :     (numberp (rm-eq (caadr l)))(not (minusp (add1 (rm-eq (caadr l)))))
697 :     (exit (car l)))))
698 :     )
699 :     ; sectionの中にあればvalを返す
700 :     (defun in-section (val section)
701 :     (do ((l section (cdr l)))
702 :     ((atom l) nil)
703 :     (and (gt val (cdar l))(gt (caadr l) val)(exit val))))
704 :     ;
705 :     (defun in-section-width (val section)
706 :     (do ((l section (cdr l)))
707 :     ((atom l) nil)
708 :     (and (gt val (cdar l))(gt (caadr l) val)
709 :     (exit (times 2.0 (min (difference (rm-eq (caadr l)) val)
710 :     (difference val (rm-eq (cdar l)))))))))
711 :     ;
712 :     (defun region-width (region)
713 :     (difference (third region)(first region)))
714 :     ;
715 :     (defun region-height (region)
716 :     (difference (fourth region)(second region)))
717 :     ;
718 :     (defun region-center (region)
719 :     `(,(times 0.5 (plus (first region)(third region)))
720 :     ,(times 0.5 (plus (second region)(fourth region)))))
721 :     ; scale-affine
722 :     ; x+(Ax+c)t のtを代入する
723 :     (defun scale-affine (limit affine)
724 :     (vector 6 `(,(plus 1 (times limit (vref affine 0)))
725 :     ,(times limit (vref affine 1))
726 :     ,(times limit (vref affine 2))
727 :     ,(plus 1 (times limit (vref affine 3)))
728 :     ,(times limit (vref affine 4))
729 :     ,(times limit (vref affine 5)))))
730 :    
731 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help