| 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))))) |
Annotation of /lisp/test/region.l
Parent Directory
| 
Revision Log