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

Annotation of /lisp/test/region.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 (defun region-affine (prim1 prim2 alist region)
2 :     (lets ((realregion (realregion prim2))
3 :     (rw (float (region-width realregion)))
4 :     (rh (float (region-height realregion)))
5 :     (xunit (xunit prim2))
6 :     (yunit (yunit prim2))
7 :     (center1 (prim-center prim1))
8 :     (center2 (prim-center prim2))
9 :     (center (and center1 (goodcenter center1 region) center2))
10 :     (affine1
11 :     (cond
12 :     (center
13 :     (movexy
14 :     center1 (times 0.5 (plus (second region)(fourth region)))
15 :     (scalexy (cond ((zerop rw)1)
16 :     (t (//$ (float (region-width region))
17 :     rw)))
18 :     (cond ((zerop rh)1)
19 :     (t (//$ (float (region-height region))
20 :     rh)))
21 :     (movexy
22 :     (minus center2)
23 :     (minus (times 0.5 (plus (second realregion)
24 :     (fourth realregion))))))))
25 :     (t (region2region realregion region))))
26 :     (rc (region-center region))
27 :     (rc (cond (center `(,center1 ,(cadr rc)))(t rc)))
28 :     (scalexy (scaleconv rc))
29 :     (scalex (vector 6 `(1 0 0 0 ,(minus (car rc)) 0)))
30 :     (scaley (vector 6 `(0 1 0 0 0 ,(minus (cadr rc)))))
31 :     (transx #(0 0 0 0 1 0))
32 :     (transy #(0 0 0 0 0 1)))
33 :     (and (boundp 'DEBUG)(prind affine1))
34 :     (setq affine2 (good-scale prim1 prim2 affine1 scalexy xunit yunit alist))
35 :     (setq size (times (vref affine2 0)(vref affine2 3)))
36 :     (do ((i 0 (1+ i))(oldsize))
37 :     ((and oldsize (lessp (times size 0.98) oldsize))
38 :     (and (boundp 'DEBUG)(prind `(,size ,oldsize)))
39 :     affine2)
40 :     (and (boundp 'DEBUG)(prind affine2))
41 :     (setq affine3
42 :     (cond (center affine2)
43 :     (t (good-trans prim1 prim2 affine2 transx xunit yunit alist))))
44 :     (and (boundp 'DEBUG)(prind affine3))
45 :     (setq affine4 (good-trans prim1 prim2 affine3 transy xunit yunit alist))
46 :     (and (boundp 'DEBUG)(prind affine4))
47 :     (setq affine5 (good-scale prim1 prim2 affine4 scalexy xunit yunit alist))
48 :     (and (boundp 'DEBUG)(prind affine5))
49 :     (setq affine6 (good-scale prim1 prim2 affine5 scalex xunit yunit alist))
50 :     (and (boundp 'DEBUG)(prind affine6))
51 :     (setq affine2 (good-scale prim1 prim2 affine6 scalex xunit yunit alist))
52 :     (setq oldsize size)
53 :     (setq size (times (vref affine2 0)(vref affine2 3)))
54 :     (and (boundp 'DEBUG)(prind `(,size ,oldsize)))
55 :     )))
56 :    
57 :     (defun good-trans (prim1 prim2 affine1 conv xunit yunit alist)
58 :     (lets ((prim21 (affinepart prim2 affine1))
59 :     (xunit1 (times xunit (vref affine1 0)))
60 :     (yunit1 (times yunit (vref affine1 3)))
61 :     (xlimitratio (cdr (or (assq 'xlimitratio alist)'(nil . 0.3))))
62 :     (ylimitratio (cdr (or (assq 'ylimitratio alist)'(nil . 0.5))))
63 :     (alist_xlimit (assqcdr 'xlimit alist))
64 :     (alist_ylimit (assqcdr 'ylimit alist))
65 :     (xlimit (times xlimitratio xunit1))
66 :     (ylimit (times ylimitratio yunit1))
67 :     (oldparam `((xlimit .,(or alist_xlimit (cons 0 xlimit)))
68 :     (ylimit .,(or alist_ylimit (cons 0 ylimit)))))
69 :     (section1 (general-section prim1 prim21 conv
70 :     `((xunit 0 .,xunit1)
71 :     (yunit 0 .,yunit1).,oldparam)))
72 :     (ax (section-plus section1))
73 :     (bx (section-minus section1))
74 :     (cx (quotient (plus ax bx) 2.0))
75 :     (affine2 (times-affine (scale-affine cx conv) affine1)))
76 :     affine1))
77 :    
78 :     (defun good-scale (prim1 prim2 affine1 conv xunit yunit alist)
79 :     (lets ((prim21 (affinepart prim2 affine1))
80 :     (xunit1 (times xunit (vref affine1 0)))
81 :     (yunit1 (times yunit (vref affine1 3)))
82 :     (xlimitratio (cdr (or (assq 'xlimitratio alist)'(nil . 0.3))))
83 :     (ylimitratio (cdr (or (assq 'ylimitratio alist)'(nil . 0.5))))
84 :     (alist_xlimit (assqcdr 'xlimit alist))
85 :     (alist_ylimit (assqcdr 'ylimit alist))
86 :     (xlimit (times xlimitratio xunit1))
87 :     (ylimit (times ylimitratio yunit1))
88 :     (oldparam `((xlimit .,(or alist_xlimit (cons xlimit xlimit)))
89 :     (ylimit .,(or alist_ylimit (cons ylimit ylimit)))))
90 :     (section1 (goodsection1
91 :     (general-section prim1 prim21 conv
92 :     `((xunit ,xunit1 .,xunit1)
93 :     (yunit ,yunit1 .,yunit1).,oldparam))))
94 :     (limit1 (difference (rm-eq (cdr section1)) 0.01))
95 :     (affine2 (times-affine (scale-affine limit1 conv) affine1)))
96 :     affine2))
97 :    
98 :     (defun jointtest (prim1 prim2 affine type)
99 :     (filltest
100 :     (rmlimit (appendpart prim1
101 :     (affinepart prim2 affine))) type))
102 :     (defun rmlimit (x)
103 :     (lets ((elements (cadr x))(ret))
104 :     (do ((l elements (cdr l)))
105 :     ((atom l)`(,(car x) ,(nreverse ret) .,(cddr x)))
106 :     (or (memq (caar l) '(xlimit ylimit))(push (car l) ret)))))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help