[wadalabfont-kit] / renderer / unit.l  

Annotation of /renderer/unit.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 ;
2 :     (setq ylimitval 0.15)
3 :     (defun add-ylimit (prim)
4 :     (cond ((assq 'ylimit (cddr prim))
5 :     prim)
6 :     (t
7 :     (lets ((nprim (add-unit prim))
8 :     (yunit (yunit nprim))
9 :     (region (realregion nprim))
10 :     (height (difference (fourth region)(second region))))
11 :     (cond
12 :     ((zerop height)
13 :     `(,(car prim) ,(cadr prim)
14 :     (ylimit ,(difference (second region) yunit)
15 :     ,(plus (second region) yunit))
16 :     .,(cddr nprim)))
17 :     (t
18 :     (do ((i 0 (1+ i))
19 :     (prim1 '(((0 0)(400 0))((ylimit (0 1)))))
20 :     (conv (vector 6 '(0 0 0 0 0 1)))
21 :     (ylimit)
22 :     (section1)
23 :     (ylimit1 (second region))
24 :     (ylimit2 (fourth region)))
25 :     ((>= i 3)
26 :     `(,(car prim)
27 :     ,(cadr prim)
28 :     (ylimit ,ylimit1 ,ylimit2).,(cddr nprim)))
29 :     (setq ylimit (times ylimitval (difference ylimit2 ylimit1)))
30 :     (setq section1 (general-section nprim prim1 conv
31 :     `((ylimit 0 . ,ylimit))))
32 :     (setq ylimit1 (rm-eq (caar section1)))
33 :     (setq ylimit2 (rm-eq (cdar (reverse section1)))))))))))
34 :     ;
35 :     (defun add-xlimit (prim)
36 :     (cond ((assq 'xlimit (cddr prim))
37 :     prim)
38 :     (t
39 :     (lets ((nprim (add-unit prim))
40 :     (prim1 '(((0 0)(0 400))((xlimit (0 1)))))
41 :     (conv (vector 6 '(0 0 0 0 1 0)))
42 :     (xlimit (times 0.8 (xunit nprim)))
43 :     (section1 (general-section nprim prim1 conv
44 :     `((xlimit 0 . ,xlimit))))
45 :     (xlimit1 (rm-eq (caar section1)))
46 :     (xlimit2 (rm-eq (cdar (reverse section1))))
47 :     (center (prim-center prim))
48 :     (centerwidth (and center (max (difference center xlimit1)
49 :     (difference xlimit2 center)))))
50 :     ; (break)
51 :     (cond (center `(,(car prim),(cadr prim)
52 :     (xlimit ,(difference center centerwidth)
53 :     ,(plus center centerwidth))
54 :     .,(cddr prim)))
55 :     (t `(,(car prim),(cadr prim)
56 :     (xlimit ,xlimit1 ,xlimit2).,(cddr prim))))))))
57 :    
58 :     ;
59 :     (defun xscale (fonttype list)
60 :     (lets ((scale (car list))
61 :     (prim (cadr list))
62 :     (nprim (add-unit (applykanji prim fonttype)))
63 :     (xunit (xunit nprim))
64 :     (affine (region-affine
65 :     (virtual-region '(nil nil (center . 200)) '(0 0 400 200))
66 :     nprim '((xlimitratio . 1.0)) '(0 0 400 200)))
67 :     (xlimit1 (//$ (float (minus (vref affine 4)))
68 :     (float (vref affine 0))))
69 :     (xlimit2 (//$ (difference 400.0 (vref affine 4))
70 :     (float (vref affine 0))))
71 :     (width (difference xlimit2 xlimit1))
72 :     (width1 (quotient width scale))
73 :     (delta (times 0.5 (difference width1 width)))
74 :     ; (soko (break))
75 :     )
76 :     `(,(car nprim)
77 :     ,(cadr nprim)
78 :     (xunit .,(//$ (float xunit) (float scale)))
79 :     (xlimit ,(difference xlimit1 delta) ,(plus xlimit2 delta))
80 :     .,(cddr nprim))))
81 :     ;
82 :     (defun yscale (fonttype list)
83 :     (lets ((scale (car list))
84 :     (prim (cadr list))
85 :     (nprim (add-unit (applykanji prim fonttype)))
86 :     (yunit (yunit nprim))
87 :     (prim1 '(((0 0)(400 0))((ylimit (0 1)))))
88 :     (conv (vector 6 '(0 0 0 0 0 1)))
89 :     (ylimit 50)
90 :     (section1 (general-section nprim prim1 conv
91 :     `((ylimit 0 . ,ylimit))))
92 :     (ylimit1 (rm-eq (caar section1)))
93 :     (ylimit2 (rm-eq (cdar (reverse section1))))
94 :     (height (difference ylimit2 ylimit1))
95 :     (height1 (quotient height scale))
96 :     (delta (times 0.5 (difference height1 height))))
97 :     `(,(car nprim)
98 :     ,(cadr nprim)
99 :     (yunit .,(//$ (float yunit) (float scale)))
100 :     (ylimit ,(difference ylimit1 delta) ,(plus ylimit2 delta))
101 :     .,(cddr nprim))))
102 :     ;
103 :     (defun prim-xlen (prim region)
104 :     (lets ((points (car prim))
105 :     (lines (cadr prim))
106 :     (alist (cddr prim))
107 :     (minx (car region))
108 :     (maxx (caddr region))
109 :     (width (difference maxx minx))
110 :     (xlen (assoc 'xlen alist)))
111 :     (cond
112 :     (xlen (cdr xlen))
113 :     ((zerop width)0.0)
114 :     (t
115 :     (do ((l lines (cdr l))
116 :     (xlen 0.0))
117 :     ((atom l)
118 :     (cond ((lessp 2.0 (quotient xlen width))(quotient xlen width))
119 :     (t 2.0)))
120 :     (do ((ll (cadar l) (cdr ll)))
121 :     ((atom (cdr ll)))
122 :     (setq
123 :     xlen
124 :     (plus xlen (abs (difference (car (nth (car ll) points))
125 :     (car (nth (cadr ll) points))))))))))))
126 :     ;
127 :     (defun prim-ylen (prim region)
128 :     (lets ((points (car prim))
129 :     (lines (cadr prim))
130 :     (alist (cddr prim))
131 :     (miny (cadr region))
132 :     (maxy (cadddr region))
133 :     (height (difference maxy miny))
134 :     (ylen (assoc 'ylen alist)))
135 :     (cond
136 :     (ylen (cdr ylen))
137 :     ((zerop height)0.0)
138 :     (t
139 :     (do ((l lines (cdr l))
140 :     (ylen 0.0))
141 :     ((atom l)
142 :     (cond ((lessp 2.0 (quotient ylen height))
143 :     (quotient ylen height))
144 :     (t 2.0)))
145 :     (do ((ll (cadar l) (cdr ll)))
146 :     ((atom (cdr ll)))
147 :     (setq
148 :     ylen
149 :     (plus ylen (abs (difference(cadr (nth (car ll) points))
150 :     (cadr (nth (cadr ll) points))))))))))))
151 :     (defun realregion (prim)
152 :     (cond ((assqcdr 'realregion (cddr prim)))
153 :     (t
154 :     (lets ((points (car prim))
155 :     (minx (caar points))
156 :     (maxx minx)
157 :     (miny (cadar points))
158 :     (maxy miny))
159 :     (do ((l (cdr points) (cdr l))
160 :     (x nil)(y nil))
161 :     ((atom l)(list minx miny maxx maxy))
162 :     (setq x (caar l) y (cadar l))
163 :     (cond ((greaterp minx x)(setq minx x))
164 :     ((lessp maxx x)(setq maxx x)))
165 :     (cond ((greaterp miny y)(setq miny y))
166 :     ((lessp maxy y)(setq maxy y))))))))
167 :     (defun affinelist (point trans)
168 :     (let ((x (float (car point)))
169 :     (y (float (cadr point))))
170 :     `(
171 :     ,(plus (vref trans 4)(times x (vref trans 0))(times y (vref trans 2)))
172 :     ,(plus (vref trans 5)(times x (vref trans 1))(times y (vref trans 3)))
173 :     .,(cddr point))))
174 :    
175 :    
176 :    
177 :     (defun affinepart (l trans)
178 :     (let ((points (car l))
179 :     (lines (cadr l))
180 :     (alist (cddr l))
181 :     (newpoints nil))
182 :     (do ((ll points (cdr ll)))
183 :     ((atom ll)`(,(nreverse newpoints) ,lines .,(affinealist alist trans)))
184 :     (push (affinelist (car ll) trans) newpoints))))
185 :     (declare (transalist) special)
186 :     (setq transalist '(tare nyou kamae kamae1 kamae2))
187 :     (defun affinealist (l trans)
188 :     (do ((ll l (cdr ll))
189 :     (p0 nil)
190 :     (p1 nil)
191 :     (ret nil))
192 :     ((atom ll)(nreverse ret))
193 :     (cond ((memq (caar ll) transalist)
194 :     (setq p0 (list (cadar ll)(caddar ll)) p1 (cdddar ll))
195 :     (push (cons (caar ll)
196 :     (append (affinelist p0 trans)
197 :     (affinelist p1 trans))) ret))
198 :     ((equal (car ll) '(center))(push '(center) ret))
199 :     ((eq (caar ll) 'center)
200 :     (push `(center .,(plus (times (vref trans 0) (cdar ll))
201 :     (vref trans 4))) ret))
202 :     ((eq (caar ll) 'xunit)
203 :     (push `(xunit .,(times (vref trans 0) (cdar ll))) ret))
204 :     ((eq (caar ll) 'yunit)
205 :     (push `(yunit .,(times (vref trans 3) (cdar ll))) ret))
206 :     )))
207 :     ; (t (push (car ll) ret)))))
208 :    
209 :     (defun appendpart (prim0 prim1 (newalist))
210 :     (lets ((points0 (car prim0))
211 :     (lines0 (cadr prim0))
212 :     ; (primalist0 (cddr prim0))
213 :     (base (length points0))
214 :     (points1 (car prim1))
215 :     (lines1 (cadr prim1))
216 :     (alist nil)(links nil)(newlinks nil)
217 :     ; (primalist1 (cddr prim1))
218 :     )
219 :     ; (prind (list primalist0 primalist1))
220 :     (do ((l lines1 (cdr l))
221 :     (newlines nil))
222 :     ((atom l)
223 :     `(,(append points0 points1)
224 :     ,(append lines0 (nreverse newlines))
225 :     ; .,(append newalist primalist0 primalist1)
226 :     .,newalist
227 :     ))
228 :     (setq alist (cddar l))
229 :     (setq links (assq 'link alist))
230 :     (setq newlinks nil)
231 :     (cond (links
232 :     (do ((ll (cdr links) (cdr ll))
233 :     (newlinks nil))
234 :     ((atom ll)(setq links `(link .,(nreverse newlinks))))
235 :     (push (+ base (car ll)) newlinks))
236 :     (push links alist)))
237 :     (do ((ll (cadar l) (cdr ll))
238 :     (newline nil))
239 :     ((atom ll)(push (cons (caar l)(cons (nreverse newline) alist)) newlines))
240 :     (push (+ base (car ll)) newline)))))
241 :     (comment
242 :     (defun movexy (x y (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
243 :     (let ((ret (vector 6 trans)))
244 :     (vset ret 4 (plus (vref ret 4)(float x)))
245 :     (vset ret 5 (plus (vref ret 5)(float y)))
246 :     ret))
247 :    
248 :     (defun movex (x (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
249 :     (let ((ret (vector 6 trans)))
250 :     (vset ret 4 (plus (vref ret 4)(float x)))
251 :     ret))
252 :    
253 :     (defun movey (y (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
254 :     (let ((ret (vector 6 trans)))
255 :     (vset ret 5 (plus (vref ret 5)(float y)))
256 :     ret))
257 :    
258 :     (defun scalex (x (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
259 :     (let ((ret (vector 6 trans)))
260 :     (vset ret 0 (times (vref ret 0)(float x)))
261 :     (vset ret 2 (times (vref ret 2)(float x)))
262 :     (vset ret 4 (times (vref ret 4)(float x)))
263 :     ret))
264 :    
265 :     (defun scalexy (x y(trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
266 :     (let ((ret (vector 6 trans)))
267 :     (vset ret 0 (times (vref ret 0)(float x)))
268 :     (vset ret 1 (times (vref ret 1)(float y)))
269 :     (vset ret 2 (times (vref ret 2)(float x)))
270 :     (vset ret 3 (times (vref ret 3)(float y)))
271 :     (vset ret 4 (times (vref ret 4)(float x)))
272 :     (vset ret 5 (times (vref ret 5)(float y)))
273 :     ret))
274 :    
275 :     (defun scaley (y (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
276 :     (let ((ret (vector 6 trans)))
277 :     (vset ret 1 (times (vref ret 1)(float y)))
278 :     (vset ret 3 (times (vref ret 3)(float y)))
279 :     (vset ret 5 (times (vref ret 5)(float y)))
280 :     ret))
281 :     )
282 :     ;
283 :     (defun add-unit (prim (ratio '(1 . 1)))
284 :     (lets ((points (car prim))
285 :     (elements (cadr prim))
286 :     (alist (cddr prim))
287 :     (xunit (assq 'xunit alist))
288 :     (yunit (assq 'yunit alist))
289 :     (units (or (and xunit yunit)(units prim)))
290 :     (newalist
291 :     (cond (xunit `((xunit .,(times (car ratio)(cdr xunit))).,alist))
292 :     ((zerop (region-width (realregion prim))) alist)
293 :     (t `((xunit .,(times (car ratio)(car units))).,alist))))
294 :     (newalist
295 :     (cond (yunit `((yunit .,(times (cdr ratio)(cdr yunit))).,newalist))
296 :     ((zerop (region-height (realregion prim))) newalist)
297 :     (t `((yunit .,(times (cdr ratio)(cdr units))).,newalist)))))
298 :     `(,points ,elements .,newalist)))
299 :     ;
300 :     (defun yunit (prim (defunit 100.0))
301 :     (let ((yunit (assq 'yunit (cddr prim))))
302 :     (cond (yunit (cdr yunit))
303 :     (t
304 :     (lets ((region (realregion prim))
305 :     (height (region-height region))
306 :     (tateheight (tateheight prim)))
307 :     (cond ((zerop height) defunit)
308 :     (t (//$ (float height)(float tateheight)))))))))
309 :     ;
310 :     ; プリミティブ固有の高さを決定する
311 :     ;
312 :     (defun tateheight (prim)
313 :     (lets ((rregion (realregion prim))
314 :     (xlen (prim-xlen prim rregion))
315 :     (height (difference (fourth rregion)(second rregion)))
316 :     (yokosort (yokosort prim))
317 :     (yokokankaku (yokokankaku prim))
318 :     (tateheight (assq 'tateheight (cddr prim))))
319 :     (cond (yokosort (quotient height yokosort))
320 :     (tateheight (cdr tateheight))
321 :     ((and yokokankaku
322 :     (greaterp (quotient height yokokankaku 1.4)
323 :     (difference xlen 1.0)))
324 :     (quotient height yokokankaku 1.4))
325 :     ((lessp xlen 2.0)1.0)
326 :     (t (difference xlen 1.0)))))
327 :     ;
328 :     (defun xunit (prim (defunit 100.0))
329 :     (let ((xunit (assq 'xunit (cddr prim))))
330 :     (cond (xunit (cdr xunit))
331 :     (t
332 :     (lets ((region (realregion prim))
333 :     (width (region-width region))
334 :     (yokowidth (yokowidth prim)))
335 :     (cond ((zerop width) defunit)
336 :     (t (//$ (float width)(float yokowidth)))))))))
337 :     ;
338 :     (defun yokowidth (prim)
339 :     (lets ((rregion (realregion prim))
340 :     (ylen (prim-ylen prim rregion))
341 :     (width (difference (third rregion)(first rregion)))
342 :     (tatekankaku (tatekankaku prim))
343 :     (yokowidth (assq 'yokowidth (cddr prim))))
344 :     (cond (yokowidth (cdr yokowidth))
345 :     ((and tatekankaku
346 :     (greaterp (quotient width tatekankaku 1.4)
347 :     (difference ylen 1.0)))
348 :     (quotient width tatekankaku 1.4))
349 :     ((lessp ylen 2.0)1.0)
350 :     (t (difference ylen 1.0)))))
351 :     (defun tatekankaku (prim)
352 :     (lets ((points (car prim))
353 :     (lines (cadr prim))
354 :     (tates nil))
355 :     (do ((l lines (cdr l)))
356 :     ((atom l))
357 :     (cond ((memq (caar l)'(tate tatehane tatehidari kokoro tsukurihane tasuki))
358 :     (push (car l) tates))))
359 :     (cond (tates
360 :     (do ((l tates (cdr l))
361 :     (minkankaku nil)
362 :     (p0 nil)(p1 nil))
363 :     ((atom (cdr l))minkankaku)
364 :     (setq p0 (nth (car (cadar l)) points)
365 :     p1 (nth (cadr (cadar l)) points))
366 :     (do ((ll (cdr l) (cdr ll))
367 :     (p2 nil)(p3 nil)(kankaku nil))
368 :     ((atom ll))
369 :     (setq p2 (nth (car (cadar ll)) points)
370 :     p3 (nth (cadr (cadar ll)) points))
371 :     (cond ((not (or (lessp (cadr p0)(cadr p1)(cadr p2))
372 :     (lessp (cadr p3)(cadr p0)(cadr p1))))
373 :     ; (prind (list p0 p1 p2 p3))
374 :     (setq kankaku (abs (difference (car p0)(car p2))))
375 :     (cond ((or (null minkankaku)
376 :     (greaterp minkankaku kankaku))
377 :     (setq minkankaku kankaku)))))))))))
378 :     (defun yokokankaku (prim)
379 :     (lets ((points (car prim))
380 :     (lines (cadr prim))
381 :     (yokos nil))
382 :     (do ((l lines (cdr l)))
383 :     ((atom l))
384 :     (cond ((eq 'yoko (caar l))
385 :     (push (car l) yokos))))
386 :     (cond (yokos
387 :     (do ((l yokos (cdr l))
388 :     (minkankaku nil)
389 :     (p0 nil)(p1 nil))
390 :     ((atom (cdr l))minkankaku)
391 :     (setq p0 (nth (car (cadar l)) points)
392 :     p1 (nth (cadr (cadar l)) points))
393 :     (do ((ll (cdr l) (cdr ll))
394 :     (p2 nil)(p3 nil)(kankaku nil))
395 :     ((atom ll))
396 :     (setq p2 (nth (car (cadar ll)) points)
397 :     p3 (nth (cadr (cadar ll)) points))
398 :     (cond ((not (or (lessp (car p0)(car p1)(car p2))
399 :     (lessp (car p3)(car p0)(car p1))))
400 :     ; (prind (list p0 p1 p2 p3))
401 :     (setq kankaku (abs (difference (cadr p0)(cadr p2))))
402 :     (cond ((or (null minkankaku)
403 :     (greaterp minkankaku kankaku))
404 :     (setq minkankaku kankaku)))))))))))
405 :     ;
406 :     (defun inlink (e1 e2 points)
407 :     (lets ((points1 (cadr e1))
408 :     (links2 (assq 'link (cddr e2)))
409 :     (links2 (and links2 (cdr links2))))
410 :     (do ((l points1 (cdr l)))
411 :     ((atom l))
412 :     (and (memq (car l) links2)(exit t)))))
413 :     ;
414 :     (defun element-cross (e1 e2 points)
415 :     (cond
416 :     ((inlink e1 e2 points))
417 :     ((inlink e2 e1 points))
418 :     (t
419 :     (do ((l (cadr e1) (cdr l))(flag))
420 :     ((atom (cdr l)))
421 :     (do ((ll (cadr e2) (cdr ll)))
422 :     ((atom (cdr ll)))
423 :     ; (print (list (nth (car l) points)(nth (cadr l) points)
424 :     ; (nth (car ll) points)(nth (cadr ll) points)))
425 :     ; (print (line-cross (nth (car l) points)(nth (cadr l) points)
426 :     ; (nth (car ll) points)(nth (cadr ll) points)))
427 :     (and (line-cross (nth (car l) points)(nth (cadr l) points)
428 :     (nth (car ll) points)(nth (cadr ll) points))
429 :     (setq flag t)
430 :     (exit t); koreja dasshutsu shinai
431 :     ))
432 :     (and flag (exit flag))))))
433 :     ;
434 :     (defun purecross (e1 e2 points)
435 :     (not (or (inlink e1 e2 points)
436 :     (inlink e2 e1 points))))
437 :     ;
438 :     (defun crossunit (e1 e2 points)
439 :     (do ((l defcrossunit (cdr l))
440 :     (type1 (car e1))
441 :     (type2 (car e2)))
442 :     ((atom l))
443 :     ; (print (list type1 type2))
444 :     (cond ((and (eq_member type1 (caar l))
445 :     (eq_member type2 (cadar l)))
446 :     (exit (funcall (cddar l) e1 points e2 points)))
447 :     ((and (eq_member type1 (cadar l))
448 :     (eq_member type2 (caar l)))
449 :     (exit (funcall (cddar l) e2 points e1 points))))))
450 :     ;
451 :     (defun nocrossunit (e1 e2 points)
452 :     (do ((l defnocrossunit (cdr l))
453 :     (type1 (car e1))
454 :     (type2 (car e2)))
455 :     ((atom l))
456 :     ; (print (list type1 type2))
457 :     (cond ((and (eq_member type1 (caar l))
458 :     (eq_member type2 (cadar l)))
459 :     (exit (funcall (cddar l) e1 points e2 points)))
460 :     ((and (eq_member type1 (cadar l))
461 :     (eq_member type2 (caar l)))
462 :     (exit (funcall (cddar l) e2 points e1 points))))))
463 :     ;
464 :     (defun elementunit (element points)
465 :     (do ((l defelementunit (cdr l))
466 :     (type (car element)))
467 :     ((atom l))
468 :     (cond ((eq_member type (caar l))
469 :     (exit (funcall (cdar l) element points))))))
470 :     ;
471 :     (defun findunit (prim)
472 :     (lets ((points (car prim))
473 :     (elements (cadr prim))
474 :     (alist (cddr prim))
475 :     (unit)
476 :     (crossunit)
477 :     (nocrossunit)
478 :     (elementunit))
479 :     (do ((l elements (cdr l)))
480 :     ((atom (cdr l))
481 :     (list crossunit nocrossunit elementunit))
482 :     (do ((ll (cdr l) (cdr ll)))
483 :     ((atom ll))
484 :     (cond ((element-cross (car l) (car ll) points)
485 :     ; (print (list "cross" (car l)(car ll)))
486 :     (and (setq unit (crossunit (car l) (car ll) points))
487 :     (push unit crossunit)))
488 :     (t
489 :     ; (print (list "nocross" (car l)(car ll)))
490 :     (and (setq unit (nocrossunit (car l) (car ll) points))
491 :     (push unit nocrossunit)
492 :     ))))
493 :     (and (setq unit (elementunit (car l) points))
494 :     (push unit elementunit)))))
495 :     ;
496 :     (defun include-el (el list)
497 :     (do ((l list (cdr l))
498 :     (ret nil))
499 :     ((atom l)ret)
500 :     (cond ((eq el (cadar l))
501 :     (push `(,(caddar l) .,(caar l)) ret))
502 :     ((eq el (caddar l))
503 :     (push `(,(cadar l) .,(caar l)) ret)))))
504 :     ;
505 :     (defun nodup (x list)
506 :     (lets ((val (car x))
507 :     (list1 (include-el (cadr x) list))
508 :     (list2 (include-el (caddr x) list)))
509 :     (do ((l list1 (cdr l))(assq))
510 :     ((atom l)t)
511 :     (setq assq (assq (caar l) list2))
512 :     (and assq
513 :     (greaterp val (cdar l))
514 :     (greaterp val (cdr assq))
515 :     (exit)))))
516 :     ;
517 :     (defun average (list)
518 :     (do ((n 0 (1+ n))
519 :     (l list (cdr l))
520 :     (sum 0))
521 :     ((atom l)(cond ((plusp n)(//$ (float sum)(float n)))))
522 :     (setq sum (plus sum (caar l)))))
523 :    
524 :     ;
525 :     (defun checkxunit (units)
526 :     (do ((l units (cdr l))
527 :     (ret))
528 :     ((atom l)
529 :     (average ret))
530 :     (and (caaar l)(push `(,(caaar l) .,(cdar l)) ret))))
531 :     (defun checkyunit (units)
532 :     (do ((l units (cdr l))
533 :     (ret))
534 :     ((atom l)
535 :     (average ret))
536 :     (and (cdaar l)(push `(,(cdaar l) .,(cdar l)) ret))))
537 :     ;
538 :     (defun units (prim)
539 :     (lets ((findunit (findunit prim))
540 :     (crossunit (car findunit))
541 :     (nocrossunit (cadr findunit))
542 :     (elementunit (caddr findunit))
543 :     (yokosort (yokosort prim))
544 :     (nocrossx)(nocrossx1)
545 :     (nocrossy)(nocrossy1))
546 :     (do ((l nocrossunit (cdr l)))
547 :     ((atom l))
548 :     (and (caaar l)(push `(,(caaar l) .,(cdar l)) nocrossx))
549 :     (and (cdaar l)(push `(,(cdaar l) .,(cdar l)) nocrossy)))
550 :     (do ((l nocrossx (cdr l)))
551 :     ((atom l))
552 :     (and (nodup (car l) nocrossx)
553 :     (push (car l) nocrossx1)))
554 :     (setq newxunit (average nocrossx1))
555 :     (cond (yokosort
556 :     (setq newyunit yokosort))
557 :     (t
558 :     (do ((l nocrossy (cdr l)))
559 :     ((atom l))
560 :     (and (nodup (car l) nocrossy)
561 :     (push (car l) nocrossy1)))
562 :     (setq newyunit (average nocrossy1))))
563 :     ; (print (list newxunit newyunit))
564 :     (cons (or newxunit
565 :     (checkxunit elementunit)
566 :     (checkxunit crossunit)
567 :     (xunit prim))
568 :     (or newyunit
569 :     (checkyunit elementunit)
570 :     (checkyunit crossunit)
571 :     (yunit prim)))))
572 :     ;
573 :     (defmacro p (n m)
574 :     (cond ((minusp m)
575 :     (cond ((eq n 1)
576 :     `(nth (car (last (cadr e1))) points1))
577 :     ((eq n 2)
578 :     `(nth (car (last (cadr e2))) points2))))
579 :     (t
580 :     (cond ((eq n 1)
581 :     `(nth (nth ,(1- m) (cadr e1)) points1))
582 :     ((eq n 2)
583 :     `(nth (nth ,(1- m) (cadr e2)) points2))))))
584 :     ;
585 :     (defmacro x (n m)
586 :     `(car (p ,n ,m)))
587 :     ;
588 :     (defmacro y (n m)
589 :     `(cadr (p ,n ,m)))
590 :     ;
591 :     (defun xsection (element points)
592 :     (let ((p0 (nth (car (cadr element)) points))
593 :     (p1 (nth (car (last (cadr element))) points)))
594 :     (ncons (cons (min (car p0)(car p1))(max (car p0)(car p1))))))
595 :     ;
596 :     ;
597 :     (defun ysection (element points)
598 :     (let ((p0 (nth (car (cadr element)) points))
599 :     (p1 (nth (car (last (cadr element))) points)))
600 :     (ncons (cons (min (cadr p0)(cadr p1))(max (cadr p0)(cadr p1))))))
601 :     ;
602 :     (defun absdiff (x y) (abs (difference x y)))
603 :     ;
604 :     (defun elx2y (element points x)
605 :     (do ((l (cadr element) (cdr l))
606 :     (p0 (nth (car (cadr element)) points))(p1)(s))
607 :     ((atom (cdr l))
608 :     (print "Fatal error in elx2y" terminal-output)
609 :     (break))
610 :     (setq p1 (nth (cadr l) points))
611 :     (cond ((and (=$ (float (car p0)) (float x))
612 :     (=$ (float x)(float (car p1))))
613 :     (exit (times 0.5 (plus (cadr p0) (cadr p1)))))
614 :     ((<=$ (float (car p0)) (float x) (float (car p1)))
615 :     (setq s (//$ (float (difference x (car p0)))
616 :     (float (difference (car p1)(car p0)))))
617 :     (exit (plus (times (difference 1 s)(cadr p0))(times s (cadr p1)))))
618 :     ((<=$ (float (car p1)) (float x) (float (car p0)))
619 :     (setq s (//$ (float (difference x (car p1)))
620 :     (float (difference (car p0)(car p1)))))
621 :     (exit (plus (times (difference 1 s)(cadr p1))(times s (cadr p0))))))
622 :     (setq p0 p1)))
623 :     ;
624 :     (defun diffy (e1 points1 e2 points2 xsec)
625 :     (lets ((x0 (rm-eq (caar xsec)))
626 :     (x1 (rm-eq (cdar xsec)))
627 :     (y10 (elx2y e1 points1 x0))
628 :     (y11 (elx2y e1 points1 x1))
629 :     (y20 (elx2y e2 points2 x0))
630 :     (y21 (elx2y e2 points2 x1))
631 :     (diff1 (absdiff y10 y20))
632 :     (diff2 (absdiff y11 y21)))
633 :     ; (break)
634 :     (cond ((or (greaterp diff1 (times diff2 3.0))
635 :     (greaterp diff2 (times diff1 3.0)))
636 :     (max diff1 diff2))
637 :     (t
638 :     ; (print diff1 diff2)
639 :     (sqrt (times 0.5 (plus (times diff1 diff1)(times diff2 diff2))))))))
640 :    
641 :     ;
642 :     (defun ely2x (element points y)
643 :     (do ((l (cadr element) (cdr l))
644 :     (p0 (nth (car (cadr element)) points))(p1)(s))
645 :     ((atom (cdr l))
646 :     (print "Fatal error in ely2x" terminal-output)
647 :     (break))
648 :     (setq p1 (nth (cadr l) points))
649 :     (cond ((and (=$ (float (cadr p0)) (float y))
650 :     (=$ (float y)(float (cadr p1))))
651 :     (exit (times 0.5 (plus (car p0) (car p1)))))
652 :     ((<=$ (float (cadr p0)) (float y) (float (cadr p1)))
653 :     (setq s (//$ (float (difference y (cadr p0)))
654 :     (float (difference (cadr p1)(cadr p0)))))
655 :     (exit (plus (times (difference 1 s)(car p0))(times s (car p1)))))
656 :     ((<=$ (float (cadr p1)) (float y) (float (cadr p0)))
657 :     (setq s (//$ (float (difference y (cadr p1)))
658 :     (float (difference (cadr p0)(cadr p1)))))
659 :     (exit (plus (times (difference 1 s)(car p1))(times s (car p0))))))
660 :     (setq p0 p1)))
661 :     ;
662 :     (defun xdiff (e1 points1 e2 points2 ysec)
663 :     (lets ((y0 (rm-eq (caar ysec)))
664 :     (y1 (rm-eq (cdar ysec)))
665 :     (x10 (ely2x e1 points1 y0))
666 :     (x11 (ely2x e1 points1 y1))
667 :     (x20 (ely2x e2 points2 y0))
668 :     (x21 (ely2x e2 points2 y1))
669 :     (diff1 (absdiff x10 x20))
670 :     (diff2 (absdiff x11 x21))
671 :     )
672 :     (cond ((or (greaterp diff1 (times diff2 3.0))
673 :     (greaterp diff2 (times diff1 3.0)))
674 :     (max diff1 diff2))
675 :     (t
676 :     ; (print diff1 diff2)
677 :     (sqrt (times 0.5 (plus (times diff1 diff1)(times diff2 diff2))))))))
678 :     ;
679 :     (defun nonzerosec (sec sec1 sec2 (ratio 3.0))
680 :     (and sec (<=$ (float (caar sec))(float (cdar sec)))
681 :     (or
682 :     ; (break)
683 :     (>=$ (times ratio (difference (cdar sec)(caar sec)))
684 :     (float (difference (cdar sec1)(caar sec1))))
685 :     (>=$ (times ratio (difference (cdar sec)(caar sec)))
686 :     (float (difference (cdar sec2)(caar sec2)))))))
687 :     ;
688 :     (defun standardunit (e1 points1 e2 points2)
689 :     (lets ((xsection1 (xsection e1 points1))
690 :     (xsection2 (xsection e2 points2))
691 :     (ysection1 (ysection e1 points1))
692 :     (ysection2 (ysection e2 points2))
693 :     (xsec (andsection xsection1 xsection2))
694 :     (ydiff (and (nonzerosec xsec xsection1 xsection2)
695 :     (diffy e1 points1 e2 points2 xsec)))
696 :     (ysec (andsection ysection1 ysection2))
697 :     (xdiff (and (nonzerosec ysec ysection1 ysection2)
698 :     (xdiff e1 points1 e2 points2 ysec))))
699 :     (cond ((or xdiff ydiff)
700 :     `((,xdiff .,ydiff) ,e1 ,e2)))))
701 :     ;
702 :     (defun timesunit (ratio unit)
703 :     (and unit
704 :     (lets ((ratiox (car ratio))
705 :     (ratioy (cdr ratio))
706 :     (unitx (caar unit))
707 :     (unity (cdar unit))
708 :     (newx (and unitx ratiox (times ratiox unitx)))
709 :     (newy (and unity ratioy (times ratioy unity))))
710 :     `((,newx .,newy).,(cdr unit)))))
711 :     ;
712 :     (defun tatesection (element points)
713 :     (do ((l (cadr element) (cdr l))
714 :     (p0 (nth (caadr element) points) p1)
715 :     (p1)
716 :     )
717 :     ((atom (cdr l)))
718 :     (setq p1 (nth (cadr l) points))
719 :     (cond ((equal (car p0)(car p1))
720 :     (exit `((,(cadr p0) .,(cadr p1))))))))
721 :     ;
722 :     (defun tateunit (e1 points1 e2 points2)
723 :     (lets ((ysec (andsection
724 :     (tatesection e1 points1)
725 :     (tatesection e2 points2)))
726 :     (xdiff (and (nonzerosec ysec (tatesection e1 points1)
727 :     (tatesection e2 points2))
728 :     (xdiff e1 points1 e2 points2 ysec))))
729 :     (cond (xdiff
730 :     `((,xdiff) ,e1 ,e2))
731 :     (t (standardunit e1 points1 e2 points2)))))
732 :     ;
733 :     (defun point-relation (p1 element points)
734 :     (let ((epoints (cadr element))
735 :     (lpoints (assq 'link (cddr element))))
736 :     (cond ((eq p1 (car epoints))
737 :     'start)
738 :     ((eq p1 (car (last epoints)))
739 :     'end)
740 :     ((memq p1 lpoints)
741 :     'cross)
742 :     (t
743 :     'nocross))))
744 :     ;
745 :     (defun element-relation (e1 e2 points)
746 :     (lets ((points1 (cadr e1))
747 :     (links1 (assq 'link (cddr e1)))
748 :     (points2 (cadr e2))
749 :     (links2 (assq 'link (cddr e2)))
750 :     (cross (cond ((or (memq (car points1) links2)
751 :     (memq (car points1) points2))
752 :     'start)
753 :     ((or (memq (car (last points1)) links2)
754 :     (memq (car (last points2)) points2))
755 :     'end)
756 :     ((element-cross e1 e2 points)
757 :     'cross)
758 :     (t
759 :     'nocross)))
760 :     (start (point-relation (car points2) e1 points))
761 :     (end (point-relation (car (last points2)) e1 points)))
762 :     `(,cross ,start ,end)))
763 :    
764 :    
765 :    
766 :     ;
767 :     (setq defnocrossunit
768 :     '(
769 :     ((yoko migiue) (yoko migiue) . standardunit)
770 :     ; ((kokoro kagi)
771 :     ; (tate magaritate hidari tatehane tsukurihane tatehidari) . tateunit)
772 :     ((kokoro kagi)
773 :     (tate magaritate tatehane tatehidari tsukurihane) . tateunit)
774 :     ((tate magaritate hidari tatehane tatehidari tsukurihane tasuki)
775 :     (tate magaritate hidari tatehane tatehidari tsukugihane tasuki) . tateunit)
776 :     (migi (tate magaritate hidari tatehane tatehidari)
777 :     lambda (a b c d)
778 :     (timesunit '(0.7 . 0.7) (standardunit a b c d)))
779 :     (ten
780 :     (ten yoko hidari tate tatehidari tatehane tsukurihane tasuki
781 :     magaritate kokoro migiue)
782 :     lambda (a b c d)
783 :     (timesunit '(1.6 . 1.6) (standardunit a b c d)))
784 :     ))
785 :     ;
786 :     (setq defelementunit
787 :     '(
788 :     ((kokoro kagi)
789 :     lambda (e1 points1)
790 :     `((,(times 0.9 (absdiff (x 1 3)(x 1 2)))
791 :     .,(times 0.9 (absdiff (y 1 2)(y 1 1)))) ,e1))
792 :     ))
793 :     ;
794 :     (setq defcrossunit
795 :     '(
796 :     (yoko tsukurihane
797 :     lambda (e1 points1 e2 points2)
798 :     (lets ((p1 (cadr e1))
799 :     (p2 (cadr e2))
800 :     (p12 (second p1))
801 :     (p21 (first p2))
802 :     (p23 (third p2)))
803 :     (and (eq p12 p21)(eq points1 points2)
804 :     `((nil .,(times 0.8 (difference (cadr (nth p23 points2))
805 :     (cadr (nth p21 points2)))))
806 :     ,e1 ,e2))))
807 :     (yoko (tate tatehane tatehidari hidari)
808 :     lambda (e1 points1 e2 points2)
809 :     ; (print (list e1 e2))
810 :     (lets ((p1 (cadr e1))
811 :     (p2 (cadr e2))
812 :     (l2 (assq 'link (cddr e2)))
813 :     (l2 (and l2 (cdr l2))))
814 :     (cond ((not (or (memq (cadr p1) p2)
815 :     (memq (cadr p1) l2)))
816 :     `((,(times 1.0 (difference (car (nth (cadr p1) points1))
817 :     (car (nth (car p2) points2)))))
818 :     ,e1 ,e2)))))))
819 :     ;
820 :     ; これまでのcrossunit, nocrossunit, elementunitすべてを含む概念
821 :     ; フォーマット : (基本エレメントのリスト オプションエレメントのリスト 関数)
822 :     ;
823 :     ;
824 :     (setq complexunit
825 :     '(
826 :     (((yoko (yoko (1 nocross right right)))
827 :     (not (* (between 1 2))))
828 :     `(nil . 0.7))
829 :     (((yoko (yoko (1 nocross right right)))
830 :     (tate (1 start start right)
831 :     (2 start left end))
832 :     (tate (1 end start right)
833 :     (2 end left end))
834 :     (not (* (between 1 2)))
835 :     )
836 :     `(nil . 1.0))
837 :     (((yoko (yoko (1 nocross right right)))
838 :     (tate (1 start left right)
839 :     (2 end left end))
840 :     (tate (1 start left right)
841 :     (2 end left end)))
842 :     `(nil . 0.78))))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help