Annotation of /renderer/newjoint.lAnnotation 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 |