Annotation of /lisp/samples/joint-test.lAnnotation of /lisp/samples/joint-test.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | |
| 2 : | ; | ||
| 3 : | ; | ||
| 4 : | ; | ||
| 5 : | (defun naiseki2 (a b) | ||
| 6 : | (let ((x0 (car a))(y0 (cadr a))(x1 (car b))(y1 (cadr b))) | ||
| 7 : | (+$ (*$ x0 x1)(*$ y0 y1)))) | ||
| 8 : | |||
| 9 : | (defun difftoflo2 (a b) | ||
| 10 : | (list (-$ (toflo(point-xx a))(toflo (point-xx b))) | ||
| 11 : | (-$ (toflo(point-yy a))(toflo(point-yy b))))) | ||
| 12 : | (defun times2 (len a) | ||
| 13 : | (list (*$ len (car a))(*$ len (cadr a)))) | ||
| 14 : | (defun normlen2 (len a) | ||
| 15 : | (times2 len (norm2 a))) | ||
| 16 : | (defun mul2 (a b) | ||
| 17 : | (+$ (*$ (car a)(car b))(*$ (cadr a)(cadr b)))) | ||
| 18 : | (defun costheta (a b) | ||
| 19 : | (//$ (mul2 a b)(*$ (length2 a)(length2 b)))) | ||
| 20 : | (defun diff2 (a b) | ||
| 21 : | (list (difference (car a)(car b))(difference (cadr a)(cadr b)))) | ||
| 22 : | (defun length2 (a) | ||
| 23 : | (lets ((x (car a)) | ||
| 24 : | (y (cadr a))) | ||
| 25 : | (sqrt (+$ (*$ x x)(*$ y y))))) | ||
| 26 : | (defun metric2 (a b) | ||
| 27 : | (let ((x0 (car a))(y0 (cadr a))(x1 (car b))(y1 (cadr b))) | ||
| 28 : | (sqrt (+$ (*$ (-$ x0 x1)(-$ x0 x1))(*$ (-$ y0 y1)(-$ y0 y1)))))) | ||
| 29 : | (defun norm2 (a) | ||
| 30 : | (lets ((x (car a)) | ||
| 31 : | (y (cadr a)) | ||
| 32 : | (len (sqrt (+$ (*$ x x)(*$ y y))))) | ||
| 33 : | (list (//$ x len)(//$ y len)))) | ||
| 34 : | ; | ||
| 35 : | ; | ||
| 36 : | |||
| 37 : | (defun calcdist (point p0 p1) | ||
| 38 : | (lets ((v0 (difftoflo2 p1 p0)) | ||
| 39 : | (len0 (length2 v0)) | ||
| 40 : | (v1 (difftoflo2 point p0)) | ||
| 41 : | (len1 (length2 v1)) | ||
| 42 : | (naiseki (mul2 v0 v1)) | ||
| 43 : | (len2 (//$ naiseki len0)) | ||
| 44 : | (v3 (normlen2 len2 v0))) | ||
| 45 : | ; (prind (list v0 len0 v1 len1 naiseki len2 v3)) | ||
| 46 : | (cond ((<=$ 0.0 len2 len0)(length2 (diff2 v3 v1))) | ||
| 47 : | (t 1000.0)))) | ||
| 48 : | ; | ||
| 49 : | ; | ||
| 50 : | |||
| 51 : | (defun make-hist (x) | ||
| 52 : | (do ((l x (cdr l)) | ||
| 53 : | (alist nil)) | ||
| 54 : | ((atom l)alist) | ||
| 55 : | (do ((ll (cdar l) (cdr ll)) | ||
| 56 : | (pnumber nil) | ||
| 57 : | (ptr nil)) | ||
| 58 : | ((atom ll)) | ||
| 59 : | (setq pnumber (cadar ll)) | ||
| 60 : | (setq ptr (assq pnumber alist)) | ||
| 61 : | (cond (ptr (rplacd ptr (1+ (cdr ptr)))) | ||
| 62 : | (t (push (cons pnumber 1) alist)))))) | ||
| 63 : | ; | ||
| 64 : | ; | ||
| 65 : | |||
| 66 : | (defun find-kouho (x hist) | ||
| 67 : | (do ((l x (cdr l)) | ||
| 68 : | (npoint nil) | ||
| 69 : | (ret nil)) | ||
| 70 : | ((atom l)ret) | ||
| 71 : | (setq npoint (get (caar l) 'npoint)) | ||
| 72 : | (cond ((= 1 (cdr (assq (cadr (cadar l)) hist))) | ||
| 73 : | (push (cadar l) ret))) | ||
| 74 : | (cond ((= 1 (cdr (assq (cadar (last (car l))) hist))) | ||
| 75 : | (push (car (last (car l))) ret))))) | ||
| 76 : | |||
| 77 : | ; 縦方向の組合せのための解析 | ||
| 78 : | ; | ||
| 79 : | ; | ||
| 80 : | (defun metric (x0 y0 x y) | ||
| 81 : | (+(*(- x0 x)(- x0 x))(*(- y0 y)(- y0 y)))) | ||
| 82 : | |||
| 83 : | (defun mean-of-x (l) | ||
| 84 : | (let ((points (car l)) | ||
| 85 : | (lines (cadr l))) | ||
| 86 : | (do ((ll lines (cdr ll)) | ||
| 87 : | (type nil) | ||
| 88 : | (length 0.0) | ||
| 89 : | (xlength 0.0)) | ||
| 90 : | ((atom ll)(//$ xlength length 2.0)) | ||
| 91 : | (setq type (caar ll)) | ||
| 92 : | (do ((lll (cdadar ll)(cdr lll)) | ||
| 93 : | (last (caadar ll)) | ||
| 94 : | (i 1 (1+ i)) | ||
| 95 : | (len 0)) | ||
| 96 : | ((atom lll)) | ||
| 97 : | (setq point0 (nth last points)) | ||
| 98 : | (setq point1 (nth (car lll) points)) | ||
| 99 : | (setq len (sqrt (toflo | ||
| 100 : | (metric (car point0)(cadr point0) | ||
| 101 : | (car point1)(cadr point1))))) | ||
| 102 : | (setq length (+$ length len)) | ||
| 103 : | (setq xlength | ||
| 104 : | (+$ xlength | ||
| 105 : | (*$ (toflo (+ (car point0)(car point1))) len))) | ||
| 106 : | (setq last (car lll)))))) | ||
| 107 : | |||
| 108 : | (setq xsymmetry | ||
| 109 : | '( | ||
| 110 : | ((yoko 0 1)) | ||
| 111 : | ((tate 0 1)) | ||
| 112 : | ((tatehidari 0 1)) | ||
| 113 : | ((tatehane 0 1)) | ||
| 114 : | ((hidari 0 2)) | ||
| 115 : | ((ten 0 1)) | ||
| 116 : | ((tate 0 1)(tate 0 1)) | ||
| 117 : | ((ten 0 1)(hidari 0 2)) | ||
| 118 : | ((hidari 0 2)(migi 0 2)) | ||
| 119 : | ((tatehidari 0 0)(tatehane 0 0)) | ||
| 120 : | ((tatehidari 0 1)(tate 0 1)) | ||
| 121 : | ((hidari 0 0)(kokoro 0 0)) | ||
| 122 : | ((tate 0 1)(tatehane 0 1)))) | ||
| 123 : | |||
| 124 : | (setq xthresh 15.0) | ||
| 125 : | (setq ythresh 25.0) | ||
| 126 : | |||
| 127 : | (defun find-symmetry (l (meanx (mean-of-x l))) | ||
| 128 : | (lets ( | ||
| 129 : | (points (car l)) | ||
| 130 : | (lines (cadr l)) | ||
| 131 : | (ret nil) | ||
| 132 : | (a nil) | ||
| 133 : | (alist nil)) | ||
| 134 : | (do ((ll lines (cdr ll))) | ||
| 135 : | ((atom ll)) | ||
| 136 : | (setq a (assq (caar ll) alist)) | ||
| 137 : | (cond (a (rplacd a (cons (car ll) (cdr a)))) | ||
| 138 : | (t (push (cons (caar ll) (ncons (car ll))) alist)))) | ||
| 139 : | (do ((ll xsymmetry (cdr ll))) | ||
| 140 : | ((atom ll)(cons ret lines)) | ||
| 141 : | (selectq (length (car ll)) | ||
| 142 : | (1 | ||
| 143 : | (do ((lll (assq (caaar ll) alist) (cdr lll))) | ||
| 144 : | ((atom lll)) | ||
| 145 : | (cond ((atom (car lll))(setq lll (cdr lll)))) | ||
| 146 : | (cond ((check1sym (cadar lll)(cdaar ll) meanx points) | ||
| 147 : | ; (rplacd (assq (caaar ll) alist) | ||
| 148 : | ; (remq (car lll) (cdr (assq (caaar ll) alist)))) | ||
| 149 : | (setq lines (remq (car lll) lines)) | ||
| 150 : | (push (car lll) ret))))) | ||
| 151 : | (2 | ||
| 152 : | (cond | ||
| 153 : | ((eq (caaar ll)(caadar ll)) | ||
| 154 : | (do ((lll (assq (caaar ll) alist)(cdr lll))) | ||
| 155 : | ((atom lll)) | ||
| 156 : | (cond ((atom (car lll))(setq lll (cdr lll)))) | ||
| 157 : | (do ((llll (cdr lll)(cdr llll))) | ||
| 158 : | ((atom llll)) | ||
| 159 : | (cond ((atom (car llll))(setq llll (cdr llll)))) | ||
| 160 : | (cond ((and (neq (car lll)(car llll)) | ||
| 161 : | (check2sym (cadar lll)(cadar llll)(cdaar ll)(cdadar ll) meanx points)) | ||
| 162 : | ; (rplacd (assq (caaar ll) alist) | ||
| 163 : | ; (remq (car llll)(remq (car lll) (cdr (assq (caaar ll) alist))))) | ||
| 164 : | (setq lines (remq (car llll)(remq (car lll) lines))) | ||
| 165 : | (push (list (car lll)(car llll))ret)))))) | ||
| 166 : | (t | ||
| 167 : | (do ((lll (assq (caaar ll) alist)(cdr lll))) | ||
| 168 : | ((atom lll)) | ||
| 169 : | (cond ((atom (car lll))(setq lll (cdr lll)))) | ||
| 170 : | (do ((llll (assq (caadar ll) alist)(cdr llll))) | ||
| 171 : | ((atom llll)) | ||
| 172 : | (cond ((atom (car llll))(setq llll (cdr llll)))) | ||
| 173 : | (cond ((and (neq (cdar lll)(car llll)) | ||
| 174 : | (check2sym (cadar lll)(cadar llll)(cdaar ll)(cdadar ll) meanx points)) | ||
| 175 : | ; (rplacd (assq (caaar ll) alist) | ||
| 176 : | ; (remq (car llll)(remq (car lll) (cdr (assq (caaar ll) alist))))) | ||
| 177 : | (setq lines (remq (car llll)(remq (car lll) lines))) | ||
| 178 : | (push (list (car lll)(car llll))ret)))))))))))) | ||
| 179 : | |||
| 180 : | (defun point-xx (n) | ||
| 181 : | (tofix (car (nth n points)))) | ||
| 182 : | (defun point-yy (n) | ||
| 183 : | (tofix (cadr (nth n points)))) | ||
| 184 : | (defun check1sym (real temp meanx points) | ||
| 185 : | (let ((mean1 (+ (point-xx (nth (car temp) real)) | ||
| 186 : | (point-xx (nth (cadr temp) real))))) | ||
| 187 : | ; (print (list mean1 meanx (-$ (//$ (toflo mean1) 2.0) meanx))) | ||
| 188 : | (cond ((<$ (-$ xthresh) (-$ (//$ (toflo mean1) 2.0) meanx) xthresh) t) | ||
| 189 : | (t nil)))) | ||
| 190 : | |||
| 191 : | (defun check2sym (real0 real1 temp0 temp1 meanx points) | ||
| 192 : | (let ((mean1 (+ (point-xx (nth (car temp0) real0)) | ||
| 193 : | (point-xx (nth (car temp1) real1)))) | ||
| 194 : | (diff1 (- (point-yy (nth (car temp0) real0)) | ||
| 195 : | (point-yy (nth (car temp1) real1)))) | ||
| 196 : | (mean2 (+ (point-xx (nth (cadr temp0) real0)) | ||
| 197 : | (point-xx (nth (cadr temp1) real1)))) | ||
| 198 : | (diff2 (- (point-yy (nth (cadr temp0) real0)) | ||
| 199 : | (point-yy (nth (cadr temp1) real1))))) | ||
| 200 : | ; (prind (list real0 real1 temp0 temp1 meanx)) | ||
| 201 : | (cond ((and | ||
| 202 : | (<$ (-$ xthresh) (-$ (//$ (toflo mean1) 2.0) meanx) xthresh) | ||
| 203 : | (<$ (-$ xthresh) (-$ (//$ (toflo mean2) 2.0) meanx) xthresh) | ||
| 204 : | (<$ (-$ ythresh) (toflo diff1) ythresh) | ||
| 205 : | (<$ (-$ ythresh) (toflo diff2) ythresh)) | ||
| 206 : | ; (prind (list real0 real1 temp0 temp1 meanx)) | ||
| 207 : | t) | ||
| 208 : | (t nil)))) | ||
| 209 : | |||
| 210 : | ; | ||
| 211 : | ; centerを探す。もしもシンメトリの縦、縦左などが1つで存在する時はその値 | ||
| 212 : | ; そうでないときは、symmetryの平均 | ||
| 213 : | ; symmetry がない時はmean-of-x | ||
| 214 : | |||
| 215 : | (defun find-center (prim) | ||
| 216 : | (lets ((alist (cddr prim)) | ||
| 217 : | (prop (assq 'center alist))) | ||
| 218 : | (cond | ||
| 219 : | (prop (toflo (cdr prop))) | ||
| 220 : | (t | ||
| 221 : | (lets ((linkpoints nil) | ||
| 222 : | (points (car prim)) | ||
| 223 : | (symmetry (find-symmetry prim)) | ||
| 224 : | (region (realregion prim)) | ||
| 225 : | (one-prim nil)) | ||
| 226 : | (cond ((null (car symmetry)) | ||
| 227 : | (setq symmetry | ||
| 228 : | (find-symmetry prim | ||
| 229 : | (//$ (+$ (toflo (first region)) | ||
| 230 : | (toflo (third region))) 2.0))))) | ||
| 231 : | (cond | ||
| 232 : | ((null (car symmetry))(mean-of-x prim)) | ||
| 233 : | ((setq one-prim (find-tate (car symmetry))) | ||
| 234 : | (symcenter one-prim)) | ||
| 235 : | (t | ||
| 236 : | (do ((l (car symmetry) (cdr l)) | ||
| 237 : | (sum 0.0) | ||
| 238 : | (n 0 (1+ n))) | ||
| 239 : | ((atom l)(//$ sum (toflo n))) | ||
| 240 : | (setq sum (+$ sum (symcenter (car l)))))))))))) | ||
| 241 : | |||
| 242 : | ; | ||
| 243 : | ; find-tate | ||
| 244 : | ; lengthが1でそのsymmetry部分のX座標が等しいもの | ||
| 245 : | |||
| 246 : | (setq centerpart '(tate tatehidari tatehane)) | ||
| 247 : | (defun find-tate (prim) | ||
| 248 : | (do ((l prim (cdr l))) | ||
| 249 : | ((atom l)) | ||
| 250 : | (cond ((and (atom (caar l))(member (caar l) centerpart)) | ||
| 251 : | (exit (car l)))))) | ||
| 252 : | |||
| 253 : | (defun symcenter (parts) | ||
| 254 : | (cond ((atom (car parts)) | ||
| 255 : | (symcenter1 parts)) | ||
| 256 : | (t (symcenter2 (car parts)(cadr parts))))) | ||
| 257 : | |||
| 258 : | (defun symcenter1 (part) | ||
| 259 : | (let ((pattern nil) | ||
| 260 : | (body (cadr part)) | ||
| 261 : | (type (car part))) | ||
| 262 : | (do ((l xsymmetry (cdr l))) | ||
| 263 : | ((atom l)) | ||
| 264 : | (cond ((and (= 1 (length (car l))) (eq type (caaar l))) | ||
| 265 : | (setq pattern (caar l)) | ||
| 266 : | (exit)))) | ||
| 267 : | (do ((l (cdr pattern) (cdr l)) | ||
| 268 : | (sum 0.0) | ||
| 269 : | (n (length (cdr pattern)))) | ||
| 270 : | ((atom l)(//$ sum (toflo n))) | ||
| 271 : | (setq sum (+$ sum (toflo (point-xx (nth (car l) body)))))))) | ||
| 272 : | |||
| 273 : | |||
| 274 : | (defun symcenter2 (part1 part2) | ||
| 275 : | (let ((pattern1 nil) | ||
| 276 : | (pattern2 nil) | ||
| 277 : | (body1 (cadr part1)) | ||
| 278 : | (type1 (car part1)) | ||
| 279 : | (body2 (cadr part2)) | ||
| 280 : | (type2 (car part2))) | ||
| 281 : | (do ((l xsymmetry (cdr l))) | ||
| 282 : | ((atom l)) | ||
| 283 : | ; (print l) | ||
| 284 : | (cond ((= 2 (length (car l))) | ||
| 285 : | (cond ((and (eq type1 (caaar l))(eq type2 (caadar l))) | ||
| 286 : | (setq pattern1 (caar l) pattern2 (cadar l)) | ||
| 287 : | (exit)) | ||
| 288 : | ((and (eq type2 (caaar l))(eq type1 (caadar l))) | ||
| 289 : | (setq pattern2 (caar l) pattern1 (cadar l)) | ||
| 290 : | (exit)))))) | ||
| 291 : | (do ((l1 (cdr pattern1) (cdr l1)) | ||
| 292 : | (l2 (cdr pattern2) (cdr l2)) | ||
| 293 : | (sum 0.0) | ||
| 294 : | (n (* 2 (length (cdr pattern1))))) | ||
| 295 : | ((atom l1)(//$ sum (toflo n))) | ||
| 296 : | (setq sum (+$ sum (toflo(point-xx (nth (car l1) body1))) | ||
| 297 : | (toflo (point-xx (nth (car l2) body2)))))))) | ||
| 298 : | |||
| 299 : | ; | ||
| 300 : | ; 部首の中に出てくる点の最大最小を求める | ||
| 301 : | ; 補正つき | ||
| 302 : | ; partregionの作り直し | ||
| 303 : | ; | ||
| 304 : | |||
| 305 : | (defun partregion(prim) | ||
| 306 : | (lets ((alist (cddr prim)) | ||
| 307 : | (prop (assq 'region alist))) | ||
| 308 : | (cond (prop (cdr prop)) | ||
| 309 : | (t | ||
| 310 : | (simple-partregion (simplify-link prim)))))) | ||
| 311 : | |||
| 312 : | (defun simple-partregion (simple) | ||
| 313 : | (lets ((realregion (simple-realregion simple)) | ||
| 314 : | (minx (toflo (car realregion))) | ||
| 315 : | (miny (toflo (second realregion))) | ||
| 316 : | (maxx (toflo (third realregion))) | ||
| 317 : | (maxy (toflo (fourth realregion))) | ||
| 318 : | (meanx (//$ (+$ maxx minx) 2.0)) | ||
| 319 : | (meany (//$ (+$ maxy miny) 2.0)) | ||
| 320 : | (width (-$ maxx minx)) | ||
| 321 : | (height (-$ maxy miny)) | ||
| 322 : | (points (car simple)) | ||
| 323 : | (lines (cdr simple)) | ||
| 324 : | (xlen (xlength simple)) | ||
| 325 : | (ylen (ylength simple)) | ||
| 326 : | (tatesen (max 1.0 (-$ (//$ ylen height) 1.0))) | ||
| 327 : | (yokosen (max 1.0 (-$ (//$ xlen width) 1.0)))) | ||
| 328 : | (do ((l lines (cdr l)) | ||
| 329 : | (xlen nil) | ||
| 330 : | (ylen nil) | ||
| 331 : | (xoffset nil) | ||
| 332 : | (yoffset nil) | ||
| 333 : | (x nil) | ||
| 334 : | (y nil)) | ||
| 335 : | ((atom l)(list minx miny maxx maxy)) | ||
| 336 : | (setq x (//$ (+$ (toflo(cadr (assq (caar l) points))) | ||
| 337 : | (toflo(cadr (assq (cadar l) points)))) 2.0)) | ||
| 338 : | (setq y (//$ (+$ (toflo(caddr (assq (caar l) points))) | ||
| 339 : | (toflo(caddr (assq (cadar l) points)))) 2.0)) | ||
| 340 : | (setq xlen (abs (-$ (toflo(cadr (assq (caar l) points))) | ||
| 341 : | (toflo(cadr (assq (cadar l) points)))))) | ||
| 342 : | (setq ylen (abs (-$ (toflo(caddr (assq (caar l) points))) | ||
| 343 : | (toflo(caddr (assq (cadar l) points)))))) | ||
| 344 : | (cond ((0=$ ylen) | ||
| 345 : | (setq xoffset 0.0)) | ||
| 346 : | (t | ||
| 347 : | (setq xoffset (*$ (abs (-$ x meanx)) (//$ ylen height tatesen))))) | ||
| 348 : | (setq yoffset (*$ (abs (-$ y meany))(//$ xlen width yokosen))) | ||
| 349 : | ; (prind (list x y xlen ylen xoffset yoffset)) | ||
| 350 : | (cond ((>$ minx (-$ x xoffset))(setq minx (-$ x xoffset))) | ||
| 351 : | ((<$ maxx (+$ x xoffset))(setq maxx (+$ x xoffset))) | ||
| 352 : | ((>$ miny (-$ y yoffset))(setq miny (-$ y yoffset))) | ||
| 353 : | ((<$ maxy (+$ y yoffset))(setq maxy (+$ y yoffset))))))) | ||
| 354 : | |||
| 355 : | (defun prim-width (prim center rregion ylen) | ||
| 356 : | (lets ((alist (cddr prim)) | ||
| 357 : | (minx (first rregion)) | ||
| 358 : | (maxx (third rregion)) | ||
| 359 : | (height (-$ (fourth rregion)(second rregion))) | ||
| 360 : | (width (assq 'width alist))) | ||
| 361 : | (cond | ||
| 362 : | (width (toflo (cdr width))) | ||
| 363 : | ((0=$ height)(max (-$ maxx center)(-$ center minx))) | ||
| 364 : | (t | ||
| 365 : | (lets ((points (car prim)) | ||
| 366 : | (lines (cadr prim)) | ||
| 367 : | (tatesen (*$ (max 1.0 (-$ ylen 1.0)) height))) | ||
| 368 : | (do ((l lines (cdr l)) | ||
| 369 : | (type) | ||
| 370 : | (line)) | ||
| 371 : | ((atom l)(max (-$ maxx center)(-$ center minx))) | ||
| 372 : | (setq type (caar l) line (cadar l)) | ||
| 373 : | (do ((ll line (cdr ll)) | ||
| 374 : | (meanx) | ||
| 375 : | (height) | ||
| 376 : | (xoffset) | ||
| 377 : | (p0) | ||
| 378 : | (p1)) | ||
| 379 : | ((atom (cdr ll))) | ||
| 380 : | (setq p0 (nth (car ll) points) p1 (nth (cadr ll) points)) | ||
| 381 : | (setq meanx (*$ 0.5 (+$ (toflo (car p0))(toflo (car p1))))) | ||
| 382 : | (setq height (abs (-$ (toflo (cadr p0))(toflo (cadr p1))))) | ||
| 383 : | (cond ((>$ meanx center) | ||
| 384 : | (setq xoffset (*$ (-$ meanx center)(//$ height tatesen))) | ||
| 385 : | (cond ((<$ maxx (+$ meanx xoffset)) | ||
| 386 : | (setq maxx (+$ meanx xoffset))))) | ||
| 387 : | (t | ||
| 388 : | (setq xoffset (*$ (-$ center meanx)(//$ height tatesen))) | ||
| 389 : | (cond ((>$ minx (-$ meanx xoffset)) | ||
| 390 : | (setq minx (-$ meanx xoffset))))))))))))) | ||
| 391 : | (defun updown (prim rregion xlen) | ||
| 392 : | (lets ((alist (cddr prim)) | ||
| 393 : | (miny (second rregion)) | ||
| 394 : | (maxy (fourth rregion)) | ||
| 395 : | (height (-$ maxy miny)) | ||
| 396 : | (width (-$ (third rregion)(first rregion))) | ||
| 397 : | (updown (assq 'updown alist))) | ||
| 398 : | (cond | ||
| 399 : | (updown (cons (toflo (cadr updown))(toflo (cddr updown)))) | ||
| 400 : | ((0=$ width)'(1.0 . 1.0)) | ||
| 401 : | (t | ||
| 402 : | (lets ((points (car prim)) | ||
| 403 : | (lines (cadr prim)) | ||
| 404 : | (yokosen (*$ 10.0 width)) | ||
| 405 : | ; (yokosen (*$ 3.0 (max 1.0 (-$ xlen 1.0)) width)) | ||
| 406 : | ) | ||
| 407 : | (do ((l lines (cdr l)) | ||
| 408 : | (type) | ||
| 409 : | (line) | ||
| 410 : | (newminy miny) | ||
| 411 : | (newmaxy maxy)) | ||
| 412 : | ((atom l)(cons (-$ miny newminy)(-$ newmaxy maxy))) | ||
| 413 : | (setq type (caar l) line (cadar l)) | ||
| 414 : | (do ((ll line (cdr ll)) | ||
| 415 : | (meany) | ||
| 416 : | (width) | ||
| 417 : | (yoffset) | ||
| 418 : | (p0) | ||
| 419 : | (p1)) | ||
| 420 : | ((atom (cdr ll))) | ||
| 421 : | (setq p0 (nth (car ll) points) p1 (nth (cadr ll) points)) | ||
| 422 : | (setq meany (*$ 0.5 (+$ (toflo (cadr p0))(toflo (cadr p1))))) | ||
| 423 : | (setq width (abs (-$ (toflo (car p0))(toflo (car p1))))) | ||
| 424 : | (setq yoffset (*$ height (//$ width yokosen))) | ||
| 425 : | (cond ((<$ newmaxy (+$ meany yoffset)) | ||
| 426 : | (setq newmaxy (+$ meany yoffset))) | ||
| 427 : | ((>$ newminy (-$ meany yoffset)) | ||
| 428 : | (setq newminy (-$ meany yoffset))))))))))) | ||
| 429 : | |||
| 430 : | (defun updown0 (prim rregion xlen) '(0.0 . 0.0)) | ||
| 431 : | |||
| 432 : | |||
| 433 : | |||
| 434 : | (defun xlength(simple) | ||
| 435 : | (let ((points (car simple)) | ||
| 436 : | (lines (cdr simple))) | ||
| 437 : | (do ((l lines (cdr l)) | ||
| 438 : | (len 0.0)) | ||
| 439 : | ((atom l)len) | ||
| 440 : | (setq len (+$ len (abs (-$ (toflo(cadr (assq (caar l) points))) | ||
| 441 : | (toflo(cadr (assq (cadar l) points)))))))))) | ||
| 442 : | |||
| 443 : | (defun ylength(simple) | ||
| 444 : | (let ((points (car simple)) | ||
| 445 : | (lines (cdr simple))) | ||
| 446 : | (do ((l lines (cdr l)) | ||
| 447 : | (len 0.0)) | ||
| 448 : | ((atom l)len) | ||
| 449 : | (setq len (+$ len (abs (-$ (toflo(caddr (assq (caar l) points))) | ||
| 450 : | (toflo (caddr (assq (cadar l) points)))))))))) | ||
| 451 : | |||
| 452 : | ; | ||
| 453 : | ; normspace : | ||
| 454 : | ; partの空白部分をnormalizeして、heightとnormalizeしたpartと | ||
| 455 : | ; divspaceの結果、Up,Downを listにして返す | ||
| 456 : | |||
| 457 : | ; | ||
| 458 : | ; divspace : | ||
| 459 : | ; partに対して空白部分を分割してリストにして返す | ||
| 460 : | ; | ||
| 461 : | (defun divspace (part) | ||
| 462 : | (lets ((region (realregion part)) | ||
| 463 : | (simple (simplify-link part)) | ||
| 464 : | (cross (find-cross simple)) | ||
| 465 : | (link-graph (sortgraph (rmshortline (make-graph (cdr cross))(car cross)) (car cross))) | ||
| 466 : | (loop (find-loop link-graph)) | ||
| 467 : | ) | ||
| 468 : | (prind (cdr cross)) | ||
| 469 : | (prind link-graph) | ||
| 470 : | (prind loop) | ||
| 471 : | )) | ||
| 472 : | ; | ||
| 473 : | ; | ||
| 474 : | ; | ||
| 475 : | |||
| 476 : | (defun realregion(prim) | ||
| 477 : | (simple-realregion (simplify-link prim))) | ||
| 478 : | |||
| 479 : | (defun simple-realregion (simple) | ||
| 480 : | (lets ((points (car simple)) | ||
| 481 : | (point0 (car points))) | ||
| 482 : | (do ((l (cdr points) (cdr l)) | ||
| 483 : | (minx (cadr point0)) | ||
| 484 : | (maxx (cadr point0)) | ||
| 485 : | (miny (caddr point0)) | ||
| 486 : | (maxy (caddr point0)) | ||
| 487 : | (x nil) | ||
| 488 : | (y nil)) | ||
| 489 : | ((atom l)(list minx miny maxx maxy)) | ||
| 490 : | (setq x (cadar l) y (caddar l)) | ||
| 491 : | (cond ((>$ minx x)(setq minx x)) | ||
| 492 : | ((<$ maxx x)(setq maxx x))) | ||
| 493 : | (cond ((>$ miny y)(setq miny y)) | ||
| 494 : | ((<$ maxy y)(setq maxy y)))))) | ||
| 495 : | |||
| 496 : | ; | ||
| 497 : | ; norm-simplify | ||
| 498 : | ; prim と region と center を引数として渡すとx方向は-1から+1にx方向は0 | ||
| 499 : | ; からにnormalize されたsimple-linkが返る。 | ||
| 500 : | |||
| 501 : | (defun norm-simplify (prim region center rregion) | ||
| 502 : | (let ((ratio (//$ 1.0 (max (-$ center (toflo (car region))) | ||
| 503 : | (-$ (toflo (caddr region)) center)))) | ||
| 504 : | (miny (toflo (cadr rregion))) | ||
| 505 : | (simple (simplify-link prim))) | ||
| 506 : | (do ((l (car simple) (cdr l)) | ||
| 507 : | (newpoints nil)) | ||
| 508 : | ((atom l)(cons newpoints (cdr simple))) | ||
| 509 : | (push `(,(caar l) | ||
| 510 : | ,(*$ ratio (-$ (cadar l) center)) | ||
| 511 : | ,(*$ ratio (-$ (caddar l) miny))) | ||
| 512 : | newpoints)))) | ||
| 513 : | |||
| 514 : | ; tate-ratio | ||
| 515 : | ; 全体の長さ height と simple1, simple2 を受けとって線の長さの比が等しく | ||
| 516 : | ; なるようなretioを返す | ||
| 517 : | |||
| 518 : | ;(defun tate-ratio (height simple1 simple2) | ||
| 519 : | ; (let ((height1 (simple-height (car simple1))) | ||
| 520 : | ; (height2 (simple-height (car simple2))) | ||
| 521 : | ; (length1 0.0) | ||
| 522 : | ; (length2 0.0)) | ||
| 523 : | ; (cond | ||
| 524 : | ; ((0=$ height1) '(0.1 . 1.0)) | ||
| 525 : | ; ((0=$ height2) '(1.0 . 0.1)) | ||
| 526 : | ; (t | ||
| 527 : | ; (do ((i 0 (1+ i)) | ||
| 528 : | ; (ratio (//$ height1 (+$ height1 height2)) | ||
| 529 : | ; (//$ length1 (+$ length1 length2)))) | ||
| 530 : | ; ((>= i 5) | ||
| 531 : | ; (cons (//$ (*$ height ratio) height1) | ||
| 532 : | ; (//$ (*$ height (-$ 1.0 ratio)) height2))) | ||
| 533 : | ; (setq length1 | ||
| 534 : | ; (simple-length simple1 1.0 (//$ (*$ height ratio) height1))) | ||
| 535 : | ; (setq length2 | ||
| 536 : | ; (simple-length simple2 1.0 (//$ (*$ height (-$ 1.0 ratio)) height2)))))))) | ||
| 537 : | |||
| 538 : | ;(defun tate-ratio (prim1 region1 prim2 region2) | ||
| 539 : | ; (prind (list ratio1 ratio2)) | ||
| 540 : | ; (lets ((xlen1 (prim-xlen prim1 region1)) | ||
| 541 : | ; (ylen1 (prim-ylen prim1 region1)) | ||
| 542 : | ; (xlen2 (prim-xlen prim2 region2)) | ||
| 543 : | ; (ylen2 (prim-ylen prim2 region2)) | ||
| 544 : | ; (res (equation2 (-$ ylen1 ylen2) | ||
| 545 : | ; (+$ xlen1 xlen2 ylen2 (-$ ylen1)) | ||
| 546 : | ; (-$ xlen1))) | ||
| 547 : | ; (r0 (car res)) | ||
| 548 : | ; (r1 (cdr res))) | ||
| 549 : | ; (break) | ||
| 550 : | ; (cond ((<=$ 0.0 r0 1.0) r0) | ||
| 551 : | ; ((<=$ 0.0 r1 1.0) r1) | ||
| 552 : | ; (t 0.5)))) | ||
| 553 : | (defun tate-ratio (xlen1 ylen1 xlen2 ylen2) | ||
| 554 : | (lets ((res (equation2 (-$ ylen1 ylen2) | ||
| 555 : | (+$ xlen1 xlen2 ylen2 (-$ ylen1)) | ||
| 556 : | (-$ xlen1))) | ||
| 557 : | (r0 (car res)) | ||
| 558 : | (r1 (cdr res))) | ||
| 559 : | (cond ((<=$ 0.0 r0 1.0) r0) | ||
| 560 : | ((<=$ 0.0 r1 1.0) r1) | ||
| 561 : | (t 0.5)))) | ||
| 562 : | |||
| 563 : | (defun equation2 (a b c) | ||
| 564 : | (cond ((0=$ a) | ||
| 565 : | (let ((r (//$ (-$ c) b))) | ||
| 566 : | (cons r r))) | ||
| 567 : | (t | ||
| 568 : | (lets ((dd (-$ (*$ b b) (*$ 4.0 a c)))) | ||
| 569 : | (cond ((0>$ dd) '(0.5 . 0.5)) | ||
| 570 : | (t | ||
| 571 : | ; (break) | ||
| 572 : | (lets ((d (sqrt dd)) | ||
| 573 : | (r0 (//$ (+$ b d) -2.0 a)) | ||
| 574 : | (r1 (//$ (-$ d b) 2.0 a))) | ||
| 575 : | (cons r0 r1)))))))) | ||
| 576 : | |||
| 577 : | (defun yoko-ratio (xlen1 ylen1 xlen2 ylen2) | ||
| 578 : | (lets ((res (equation2 (-$ xlen1 xlen2) | ||
| 579 : | (+$ ylen1 ylen2 xlen2 (-$ xlen1)) | ||
| 580 : | (-$ ylen1))) | ||
| 581 : | (r0 (car res)) | ||
| 582 : | (r1 (cdr res))) | ||
| 583 : | (cond ((<=$ 0.0 r0 1.0) r0) | ||
| 584 : | ((<=$ 0.0 r1 1.0) r1) | ||
| 585 : | (t 0.5)))) | ||
| 586 : | |||
| 587 : | (defun prim-xlen (prim region) | ||
| 588 : | (lets ((points (car prim)) | ||
| 589 : | (lines (cadr prim)) | ||
| 590 : | (alist (cddr prim)) | ||
| 591 : | (minx (car region)) | ||
| 592 : | (maxx (caddr region)) | ||
| 593 : | (width (-$ maxx minx)) | ||
| 594 : | (xlen (assoc 'xlen alist))) | ||
| 595 : | (cond | ||
| 596 : | (xlen (cdr xlen)) | ||
| 597 : | (t | ||
| 598 : | (do ((l lines (cdr l)) | ||
| 599 : | (xlen 0.0)) | ||
| 600 : | ((atom l) (//$ xlen width)) | ||
| 601 : | (do ((ll (cadar l) (cdr ll))) | ||
| 602 : | ((atom (cdr ll))) | ||
| 603 : | (setq | ||
| 604 : | xlen | ||
| 605 : | (+$ xlen (abs (-$ (toflo (car (nth (car ll) points))) | ||
| 606 : | (toflo (car (nth (cadr ll) points))))))))))))) | ||
| 607 : | |||
| 608 : | (defun prim-ylen (prim region) | ||
| 609 : | (lets ((points (car prim)) | ||
| 610 : | (lines (cadr prim)) | ||
| 611 : | (alist (cddr prim)) | ||
| 612 : | (miny (cadr region)) | ||
| 613 : | (maxy (cadddr region)) | ||
| 614 : | (height (-$ maxy miny)) | ||
| 615 : | (ylen (assoc 'ylen alist))) | ||
| 616 : | (cond | ||
| 617 : | (ylen (cdr ylen)) | ||
| 618 : | ((0=$ height)0.0) | ||
| 619 : | (t | ||
| 620 : | (do ((l lines (cdr l)) | ||
| 621 : | (ylen 0.0)) | ||
| 622 : | ((atom l) (//$ ylen height)) | ||
| 623 : | (do ((ll (cadar l) (cdr ll))) | ||
| 624 : | ((atom (cdr ll))) | ||
| 625 : | (setq | ||
| 626 : | ylen | ||
| 627 : | (+$ ylen (abs (-$ (toflo (cadr (nth (car ll) points))) | ||
| 628 : | (toflo (cadr (nth (cadr ll) points))))))))))))) | ||
| 629 : | |||
| 630 : | |||
| 631 : | (defun tate2 (prim1 prim2 (alist)) | ||
| 632 : | (lets ( | ||
| 633 : | (rregion1 (realregion prim1)) | ||
| 634 : | (xlen1 (prim-xlen prim1 rregion1)) | ||
| 635 : | (ylen1 (prim-ylen prim1 rregion1)) | ||
| 636 : | (height1 (-$ (fourth rregion1)(second rregion1) -0.000001)) | ||
| 637 : | (center1 (find-center prim1)) | ||
| 638 : | (width1 (prim-width prim1 center1 rregion1 ylen1)) | ||
| 639 : | (rate1 (//$ 1.0 width1)) | ||
| 640 : | (rregion2 (realregion prim2)) | ||
| 641 : | (xlen2 (prim-xlen prim2 rregion2)) | ||
| 642 : | (ylen2 (prim-ylen prim2 rregion2)) | ||
| 643 : | (height2 (-$ (fourth rregion2)(second rregion2) -0.000001)) | ||
| 644 : | (center2 (find-center prim2)) | ||
| 645 : | (width2 (prim-width prim2 center2 rregion2 ylen2)) | ||
| 646 : | (rate2 (//$ 1.0 width2)) | ||
| 647 : | (ratio (assq 'ratio alist)) | ||
| 648 : | (ratio | ||
| 649 : | (cond (ratio (cdr ratio)) | ||
| 650 : | (t (tate-ratio | ||
| 651 : | (*$ xlen1 (//$ (-$ (third rregion1)(first rregion1)) | ||
| 652 : | 2.0 width1)) | ||
| 653 : | ylen1 | ||
| 654 : | (*$ xlen2 (//$ (-$ (third rregion2)(first rregion2)) | ||
| 655 : | 2.0 width2)) | ||
| 656 : | ylen2)))) | ||
| 657 : | (simple1 (simplify-link prim1)) | ||
| 658 : | (new1 (simple-scalexy | ||
| 659 : | rate1 (//$ (*$ 2.0 ratio) height1) | ||
| 660 : | (simple-movexy (-$ center1) (-$ (second rregion1)) simple1))) | ||
| 661 : | (simple2 (simplify-link prim2)) | ||
| 662 : | (new2 (simple-scalexy | ||
| 663 : | rate2 (//$ (*$ 2.0 (-$ 1.0 ratio)) height2) | ||
| 664 : | (simple-movexy (-$ center2) (-$ (second rregion2)) simple2))) | ||
| 665 : | (limit (assq 'limit alist)) | ||
| 666 : | (limit (cond (limit (cdr limit)) | ||
| 667 : | (t | ||
| 668 : | (tate-limit new1 new2)))) | ||
| 669 : | (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)) )) | ||
| 670 : | ) | ||
| 671 : | ; (break) | ||
| 672 : | (appendpart | ||
| 673 : | (affinepart | ||
| 674 : | prim1 | ||
| 675 : | (movexy 200.0 20.0 | ||
| 676 : | (scalexy (*$ rate1 180.0) | ||
| 677 : | (*$ (//$ (//$ (*$ 2.0 ratio) all) height1) 360.0) | ||
| 678 : | (movexy (-$ center1) (-$ (toflo (cadr rregion1))))))) | ||
| 679 : | (affinepart | ||
| 680 : | prim2 | ||
| 681 : | (movexy 200.0 (+$ 20.0 (*$ 360.0 (//$ limit all))) | ||
| 682 : | (scalexy (*$ rate2 180.0) | ||
| 683 : | (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio)) all) height2) | ||
| 684 : | 360.0) | ||
| 685 : | (movexy (-$ center2) (-$ (toflo (cadr rregion2))))))) | ||
| 686 : | `((width . 180)(center . 200.0)(region 0.0 0.0 400.0 400.0))))) | ||
| 687 : | (defun tate-kurosa (prim1 prim2 (alist)) | ||
| 688 : | (lets ( | ||
| 689 : | (rregion1 (realregion prim1)) | ||
| 690 : | (xlen1 (prim-xlen prim1 rregion1)) | ||
| 691 : | (ylen1 (prim-ylen prim1 rregion1)) | ||
| 692 : | (height1 (-$ (fourth rregion1)(second rregion1) -0.000001)) | ||
| 693 : | (center1 (find-center prim1)) | ||
| 694 : | (width1 (prim-width prim1 center1 rregion1 ylen1)) | ||
| 695 : | (rate1 (//$ 1.0 width1)) | ||
| 696 : | (rregion2 (realregion prim2)) | ||
| 697 : | (xlen2 (prim-xlen prim2 rregion2)) | ||
| 698 : | (ylen2 (prim-ylen prim2 rregion2)) | ||
| 699 : | (height2 (-$ (fourth rregion2)(second rregion2) -0.000001)) | ||
| 700 : | (center2 (find-center prim2)) | ||
| 701 : | (width2 (prim-width prim2 center2 rregion2 ylen2)) | ||
| 702 : | (rate2 (//$ 1.0 width2)) | ||
| 703 : | (norm1 (norm-simplify-old prim1 rregion1 center1)) | ||
| 704 : | (norm2 (norm-simplify-old prim2 rregion2 center2)) | ||
| 705 : | (ratio (kurosa-ratio 2.0 norm1 norm2)) | ||
| 706 : | (ratio (//$ (car ratio)(+$ (car ratio)(cdr ratio)))) | ||
| 707 : | (simple1 (simplify-link prim1)) | ||
| 708 : | (new1 (simple-scalexy | ||
| 709 : | rate1 (//$ (*$ 2.0 ratio) height1) | ||
| 710 : | (simple-movexy (-$ center1) (-$ (second rregion1)) simple1))) | ||
| 711 : | (simple2 (simplify-link prim2)) | ||
| 712 : | (new2 (simple-scalexy | ||
| 713 : | rate2 (//$ (*$ 2.0 (-$ 1.0 ratio)) height2) | ||
| 714 : | (simple-movexy (-$ center2) (-$ (second rregion2)) simple2))) | ||
| 715 : | (limit (assq 'limit alist)) | ||
| 716 : | (limit (cond (limit (cdr limit)) | ||
| 717 : | (t | ||
| 718 : | (tate-limit new1 new2)))) | ||
| 719 : | (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)) )) | ||
| 720 : | ) | ||
| 721 : | ; (break) | ||
| 722 : | (appendpart | ||
| 723 : | (affinepart | ||
| 724 : | prim1 | ||
| 725 : | (movexy 200.0 20.0 | ||
| 726 : | (scalexy (*$ rate1 180.0) | ||
| 727 : | (*$ (//$ (//$ (*$ 2.0 ratio) all) height1) 360.0) | ||
| 728 : | (movexy (-$ center1) (-$ (toflo (cadr rregion1))))))) | ||
| 729 : | (affinepart | ||
| 730 : | prim2 | ||
| 731 : | (movexy 200.0 (+$ 20.0 (*$ 360.0 (//$ limit all))) | ||
| 732 : | (scalexy (*$ rate2 180.0) | ||
| 733 : | (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio)) all) height2) | ||
| 734 : | 360.0) | ||
| 735 : | (movexy (-$ center2) (-$ (toflo (cadr rregion2))))))) | ||
| 736 : | `((width . 180)(center . 200.0)(region 0.0 0.0 400.0 400.0))))) | ||
| 737 : | (defun kurosa-ratio (height simple1 simple2) | ||
| 738 : | (let ((height1 (simple-height (car simple1))) | ||
| 739 : | (height2 (simple-height (car simple2))) | ||
| 740 : | (length1 0.0) | ||
| 741 : | (length2 0.0)) | ||
| 742 : | (cond | ||
| 743 : | ((0=$ height1) '(0.1 . 1.0)) | ||
| 744 : | ((0=$ height2) '(1.0 . 0.1)) | ||
| 745 : | (t | ||
| 746 : | (do ((i 0 (1+ i)) | ||
| 747 : | (ratio (//$ height1 (+$ height1 height2)) | ||
| 748 : | (//$ length1 (+$ length1 length2)))) | ||
| 749 : | ((>= i 5) | ||
| 750 : | (cons (//$ (*$ height ratio) height1) | ||
| 751 : | (//$ (*$ height (-$ 1.0 ratio)) height2))) | ||
| 752 : | (setq length1 | ||
| 753 : | (simple-length simple1 1.0 (//$ (*$ height ratio) height1))) | ||
| 754 : | (setq length2 | ||
| 755 : | (simple-length simple2 1.0 (//$ (*$ height (-$ 1.0 ratio)) height2)))))))) | ||
| 756 : | (defun simple-length (simple xratio yratio) | ||
| 757 : | (let ((points (car simple)) | ||
| 758 : | (lines (cdr simple))) | ||
| 759 : | (do ((l lines (cdr l)) | ||
| 760 : | (p0 nil) | ||
| 761 : | (p1 nil) | ||
| 762 : | (x nil) | ||
| 763 : | (y nil) | ||
| 764 : | (length 0.0)) | ||
| 765 : | ((atom l)length) | ||
| 766 : | (setq p0 (assq (caar l) points)) | ||
| 767 : | (setq p1 (assq (cadar l) points)) | ||
| 768 : | (setq x (*$ xratio (-$ (cadr p0)(cadr p1)))) | ||
| 769 : | (setq y (*$ yratio (-$ (caddr p0)(caddr p1)))) | ||
| 770 : | (setq length (+$ length (sqrt (+$ (*$ x x)(*$ y y)))))))) | ||
| 771 : | (defun norm-simplify-old (prim region center) | ||
| 772 : | (let ((ratio (//$ 1.0 (max (-$ center (toflo (car region))) | ||
| 773 : | (-$ (toflo (caddr region)) center)))) | ||
| 774 : | (miny (toflo (cadr region))) | ||
| 775 : | (simple (simplify-link prim))) | ||
| 776 : | (do ((l (car simple) (cdr l)) | ||
| 777 : | (newpoints nil)) | ||
| 778 : | ((atom l)(cons newpoints (cdr simple))) | ||
| 779 : | (push `(,(caar l) | ||
| 780 : | ,(*$ ratio (-$ (cadar l) center)) | ||
| 781 : | ,(*$ ratio (-$ (caddar l) miny))) | ||
| 782 : | newpoints)))) | ||
| 783 : | |||
| 784 : | (defun tate-nocenter (prim1 prim2 (alist)) | ||
| 785 : | (lets ( | ||
| 786 : | (rregion1 (realregion prim1)) | ||
| 787 : | (xlen1 (prim-xlen prim1 rregion1)) | ||
| 788 : | (ylen1 (prim-ylen prim1 rregion1)) | ||
| 789 : | (height1 (-$ (fourth rregion1)(second rregion1) -0.000001)) | ||
| 790 : | (center1 (find-center prim1)) | ||
| 791 : | (center10 (mean-of-x prim1)) | ||
| 792 : | (width1 (prim-width prim1 center1 rregion1 ylen1)) | ||
| 793 : | (rate1 (//$ 1.0 width1)) | ||
| 794 : | (rregion2 (realregion prim2)) | ||
| 795 : | (xlen2 (prim-xlen prim2 rregion2)) | ||
| 796 : | (ylen2 (prim-ylen prim2 rregion2)) | ||
| 797 : | (height2 (-$ (fourth rregion2)(second rregion2) -0.000001)) | ||
| 798 : | (center2 (find-center prim2)) | ||
| 799 : | (center20 (mean-of-x prim2)) | ||
| 800 : | (width2 (prim-width prim2 center2 rregion2 ylen2)) | ||
| 801 : | (rate2 (//$ 1.0 width2)) | ||
| 802 : | (ratio (assq 'ratio alist)) | ||
| 803 : | (ratio | ||
| 804 : | (cond (ratio (cdr ratio)) | ||
| 805 : | (t (tate-ratio | ||
| 806 : | (*$ xlen1 (//$ (-$ (third rregion1)(first rregion1)) | ||
| 807 : | 2.0 width1)) | ||
| 808 : | ylen1 | ||
| 809 : | (*$ xlen2 (//$ (-$ (third rregion2)(first rregion2)) | ||
| 810 : | 2.0 width2)) | ||
| 811 : | ylen2)))) | ||
| 812 : | (simple1 (simplify-link prim1)) | ||
| 813 : | (new1 (simple-scalexy | ||
| 814 : | rate1 (//$ (*$ 2.0 ratio) height1) | ||
| 815 : | (simple-movexy (-$ center10) (-$ (second rregion1)) simple1))) | ||
| 816 : | (simple2 (simplify-link prim2)) | ||
| 817 : | (new2 (simple-scalexy | ||
| 818 : | rate2 (//$ (*$ 2.0 (-$ 1.0 ratio)) height2) | ||
| 819 : | (simple-movexy (-$ center20) (-$ (second rregion2)) simple2))) | ||
| 820 : | (limit (assq 'limit alist)) | ||
| 821 : | (limit (cond (limit (cdr limit)) | ||
| 822 : | (t | ||
| 823 : | (tate-limit new1 new2)))) | ||
| 824 : | (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)) )) | ||
| 825 : | ) | ||
| 826 : | ; (break) | ||
| 827 : | (appendpart | ||
| 828 : | (affinepart | ||
| 829 : | prim1 | ||
| 830 : | (movexy 200.0 20.0 | ||
| 831 : | (scalexy (*$ rate1 180.0) | ||
| 832 : | (*$ (//$ (//$ (*$ 2.0 ratio) all) height1) 360.0) | ||
| 833 : | (movexy (-$ center10) (-$ (toflo (cadr rregion1))))))) | ||
| 834 : | (affinepart | ||
| 835 : | prim2 | ||
| 836 : | (movexy 200.0 (+$ 20.0 (*$ 360.0 (//$ limit all))) | ||
| 837 : | (scalexy (*$ rate2 180.0) | ||
| 838 : | (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio)) all) height2) | ||
| 839 : | 360.0) | ||
| 840 : | (movexy (-$ center20) (-$ (toflo (cadr rregion2))))))) | ||
| 841 : | `((width . 180)(center . 200.0)(region 0.0 0.0 400.0 400.0))))) | ||
| 842 : | |||
| 843 : | (defun tate-nowidth (prim1 prim2 (alist)) | ||
| 844 : | (lets ( | ||
| 845 : | (rregion1 (realregion prim1)) | ||
| 846 : | (xlen1 (prim-xlen prim1 rregion1)) | ||
| 847 : | (ylen1 (prim-ylen prim1 rregion1)) | ||
| 848 : | (height1 (-$ (fourth rregion1)(second rregion1) -0.000001)) | ||
| 849 : | (center1 (find-center prim1)) | ||
| 850 : | (width1 (max (-$ (third rregion1) center1)(-$ center1 (car rregion1)))) | ||
| 851 : | (rate1 (//$ 1.0 width1)) | ||
| 852 : | (rregion2 (realregion prim2)) | ||
| 853 : | (xlen2 (prim-xlen prim2 rregion2)) | ||
| 854 : | (ylen2 (prim-ylen prim2 rregion2)) | ||
| 855 : | (height2 (-$ (fourth rregion2)(second rregion2) -0.000001)) | ||
| 856 : | (center2 (find-center prim2)) | ||
| 857 : | (width2 (max (-$ (third rregion2) center2)(-$ center2 (car rregion2)))) | ||
| 858 : | (rate2 (//$ 1.0 width2)) | ||
| 859 : | (ratio (assq 'ratio alist)) | ||
| 860 : | (ratio | ||
| 861 : | (cond (ratio (cdr ratio)) | ||
| 862 : | (t (tate-ratio | ||
| 863 : | (*$ xlen1 (//$ (-$ (third rregion1)(first rregion1)) | ||
| 864 : | 2.0 width1)) | ||
| 865 : | ylen1 | ||
| 866 : | (*$ xlen2 (//$ (-$ (third rregion2)(first rregion2)) | ||
| 867 : | 2.0 width2)) | ||
| 868 : | ylen2)))) | ||
| 869 : | (simple1 (simplify-link prim1)) | ||
| 870 : | (new1 (simple-scalexy | ||
| 871 : | rate1 (//$ (*$ 2.0 ratio) height1) | ||
| 872 : | (simple-movexy (-$ center1) (-$ (second rregion1)) simple1))) | ||
| 873 : | (simple2 (simplify-link prim2)) | ||
| 874 : | (new2 (simple-scalexy | ||
| 875 : | rate2 (//$ (*$ 2.0 (-$ 1.0 ratio)) height2) | ||
| 876 : | (simple-movexy (-$ center2) (-$ (second rregion2)) simple2))) | ||
| 877 : | (limit (assq 'limit alist)) | ||
| 878 : | (limit (cond (limit (cdr limit)) | ||
| 879 : | (t | ||
| 880 : | (tate-limit new1 new2)))) | ||
| 881 : | (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)) )) | ||
| 882 : | ) | ||
| 883 : | ; (break) | ||
| 884 : | (appendpart | ||
| 885 : | (affinepart | ||
| 886 : | prim1 | ||
| 887 : | (movexy 200.0 20.0 | ||
| 888 : | (scalexy (*$ rate1 180.0) | ||
| 889 : | (*$ (//$ (//$ (*$ 2.0 ratio) all) height1) 360.0) | ||
| 890 : | (movexy (-$ center1) (-$ (toflo (cadr rregion1))))))) | ||
| 891 : | (affinepart | ||
| 892 : | prim2 | ||
| 893 : | (movexy 200.0 (+$ 20.0 (*$ 360.0 (//$ limit all))) | ||
| 894 : | (scalexy (*$ rate2 180.0) | ||
| 895 : | (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio)) all) height2) | ||
| 896 : | 360.0) | ||
| 897 : | (movexy (-$ center2) (-$ (toflo (cadr rregion2))))))) | ||
| 898 : | `((width . 180)(center . 200.0)(region 0.0 0.0 400.0 400.0))))) | ||
| 899 : | (defun tate-kuikomi (prim1 prim2 (alist)) | ||
| 900 : | (lets ( | ||
| 901 : | (rregion1 (realregion prim1)) | ||
| 902 : | (xlen1 (prim-xlen prim1 rregion1)) | ||
| 903 : | (ylen1 (prim-ylen prim1 rregion1)) | ||
| 904 : | (height1 (-$ (fourth rregion1)(second rregion1) -0.000001)) | ||
| 905 : | (center1 (find-center prim1)) | ||
| 906 : | (width1 (prim-width prim1 center1 rregion1 ylen1)) | ||
| 907 : | (rate1 (//$ 1.0 width1)) | ||
| 908 : | (rregion2 (realregion prim2)) | ||
| 909 : | (xlen2 (prim-xlen prim2 rregion2)) | ||
| 910 : | (ylen2 (prim-ylen prim2 rregion2)) | ||
| 911 : | (height2 (-$ (fourth rregion2)(second rregion2) -0.000001)) | ||
| 912 : | (center2 (find-center prim2)) | ||
| 913 : | (width2 (prim-width prim2 center2 rregion2 ylen2)) | ||
| 914 : | (rate2 (//$ 1.0 width2)) | ||
| 915 : | (ratio (assq 'ratio alist)) | ||
| 916 : | (ratio | ||
| 917 : | (cond (ratio (cdr ratio)) | ||
| 918 : | (t (tate-ratio | ||
| 919 : | (*$ xlen1 (//$ (-$ (third rregion1)(first rregion1)) | ||
| 920 : | 2.0 width1)) | ||
| 921 : | ylen1 | ||
| 922 : | (*$ xlen2 (//$ (-$ (third rregion2)(first rregion2)) | ||
| 923 : | 2.0 width2)) | ||
| 924 : | ylen2)))) | ||
| 925 : | (simple1 (simplify-link prim1)) | ||
| 926 : | (new1 (simple-scalexy | ||
| 927 : | rate1 (//$ (*$ 2.0 ratio) height1) | ||
| 928 : | (simple-movexy (-$ center1) (-$ (second rregion1)) simple1))) | ||
| 929 : | (simple2 (simplify-link prim2)) | ||
| 930 : | (new2 (simple-scalexy | ||
| 931 : | rate2 (//$ (*$ 2.0 (-$ 1.0 ratio)) height2) | ||
| 932 : | (simple-movexy (-$ center2) (-$ (second rregion2)) simple2))) | ||
| 933 : | (limit (assq 'limit alist)) | ||
| 934 : | (limit (cond (limit (cdr limit)) | ||
| 935 : | (t | ||
| 936 : | (tate-limit1 new1 new2)))) | ||
| 937 : | (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)) )) | ||
| 938 : | ) | ||
| 939 : | ; (break) | ||
| 940 : | (appendpart | ||
| 941 : | (affinepart | ||
| 942 : | prim1 | ||
| 943 : | (movexy 200.0 20.0 | ||
| 944 : | (scalexy (*$ rate1 180.0) | ||
| 945 : | (*$ (//$ (//$ (*$ 2.0 ratio) all) height1) 360.0) | ||
| 946 : | (movexy (-$ center1) (-$ (toflo (cadr rregion1))))))) | ||
| 947 : | (affinepart | ||
| 948 : | prim2 | ||
| 949 : | (movexy 200.0 (+$ 20.0 (*$ 360.0 (//$ limit all))) | ||
| 950 : | (scalexy (*$ rate2 180.0) | ||
| 951 : | (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio)) all) height2) | ||
| 952 : | 360.0) | ||
| 953 : | (movexy (-$ center2) (-$ (toflo (cadr rregion2))))))) | ||
| 954 : | `((width . 180)(center . 200.0)(region 0.0 0.0 400.0 400.0))))) | ||
| 955 : | |||
| 956 : | (defun kashira (prim) | ||
| 957 : | prim) | ||
| 958 : | |||
| 959 : | (defun tate-nohosei (prim1 prim2 (alist)) | ||
| 960 : | (tate2 `(,(car prim1),(cadr prim1).,(rm-center (cddr prim1))) | ||
| 961 : | `(,(car prim2),(cadr prim2).,(rm-center (cddr prim2))) alist)) | ||
| 962 : | |||
| 963 : | (defun rm-center (l) | ||
| 964 : | (filter l (function (lambda (x)(neq (car x) 'center))))) | ||
| 965 : | |||
| 966 : | (defun tate-nowidth (prim1 prim2 (alist)) | ||
| 967 : | (tate2 `(,(car prim1),(cadr prim1).,(rm-width (cddr prim1))) | ||
| 968 : | `(,(car prim2),(cadr prim2).,(rm-width (cddr prim2))) alist)) | ||
| 969 : | |||
| 970 : | (defun rm-width (l) | ||
| 971 : | (filter l (function (lambda (x)(neq (car x) 'width))))) | ||
| 972 : | |||
| 973 : | (defun yoko-noupdown (prim1 prim2 (alist)) | ||
| 974 : | (yoko2 `(,(car prim1),(cadr prim1).,(rm-updown (cddr prim1))) | ||
| 975 : | `(,(car prim2),(cadr prim2).,(rm-updown (cddr prim2))) alist)) | ||
| 976 : | |||
| 977 : | (defun yoko-noratio (prim1 prim2 (alist)) | ||
| 978 : | (yoko2 `(,(car prim1),(cadr prim1).,(rm-len (cddr prim1))) | ||
| 979 : | `(,(car prim2),(cadr prim2).,(rm-len (cddr prim2))) alist)) | ||
| 980 : | |||
| 981 : | (defun rm-updown (l) | ||
| 982 : | (filter l (function (lambda (x)(neq (car x) 'updown))))) | ||
| 983 : | (defun rm-len (l) | ||
| 984 : | (filter l (function (lambda (x)(and (neq (car x) 'xlen)(neq (car x) 'ylen)))))) | ||
| 985 : | |||
| 986 : | (defun yoko-nohosei (prim1 prim2 (alist)) | ||
| 987 : | (yoko2 `(,(car prim1),(cadr prim1)(updown 0.0 . 0.0) .,(cddr prim1)) | ||
| 988 : | `(,(car prim2),(cadr prim2)(updown 0.0 . 0.0) .,(cddr prim2)) alist)) | ||
| 989 : | |||
| 990 : | (defun tate12 (prim1 prim2 (alist)) | ||
| 991 : | (tate2 prim1 prim2 alist)) | ||
| 992 : | (defun tate21 (prim1 prim2 (alist)) | ||
| 993 : | (tate2 prim1 prim2 alist)) | ||
| 994 : | (defun tate3 (prim1 prim2 prim3) | ||
| 995 : | (let ((newprim (tate2 prim1 prim2))) | ||
| 996 : | (tate2 newprim prim3))) | ||
| 997 : | (defun tate4 (prim1 prim2 prim3 prim4) | ||
| 998 : | (let ((new1 (tate2 prim1 prim2)) | ||
| 999 : | (new2 (tate2 prim3 prim4))) | ||
| 1000 : | (tate2 new1 new2))) | ||
| 1001 : | (defun tate5 (prim1 prim2 prim3 prim4 prim5) | ||
| 1002 : | (let ((new1 (tate2 prim1 prim2)) | ||
| 1003 : | (new2 (tate3 prim3 prim4 prim5))) | ||
| 1004 : | (tate2 new1 new2))) | ||
| 1005 : | |||
| 1006 : | (defun yoko2 (prim1 prim2 (alist)) | ||
| 1007 : | (lets ( | ||
| 1008 : | (simple1 (simplify-link prim1)) | ||
| 1009 : | (rregion1 (realregion prim1)) | ||
| 1010 : | (xlen1 (prim-xlen prim1 rregion1)) | ||
| 1011 : | (ylen1 (prim-ylen prim1 rregion1)) | ||
| 1012 : | (width1 (-$ (third rregion1)(first rregion1))) | ||
| 1013 : | (updown1 (updown prim1 rregion1 xlen1)) | ||
| 1014 : | (height1 (+$ (car updown1)(cdr updown1) | ||
| 1015 : | (-$ (fourth rregion1)(second rregion1)))) | ||
| 1016 : | (rate1 (//$ 2.0 height1)) | ||
| 1017 : | (simple2 (simplify-link prim2)) | ||
| 1018 : | (rregion2 (realregion prim2)) | ||
| 1019 : | (xlen2 (prim-xlen prim2 rregion2)) | ||
| 1020 : | (ylen2 (prim-ylen prim2 rregion2)) | ||
| 1021 : | (updown2 (updown prim2 rregion2 xlen2)) | ||
| 1022 : | (width2 (-$ (third rregion2)(first rregion2))) | ||
| 1023 : | (region2 (partregion prim2)) | ||
| 1024 : | (height2 (+$ (car updown2)(cdr updown2) | ||
| 1025 : | (-$ (fourth rregion2)(second rregion2)))) | ||
| 1026 : | (rate2 (//$ 2.0 height2)) | ||
| 1027 : | (ratio (assq 'ratio alist)) | ||
| 1028 : | (ratio | ||
| 1029 : | (cond (ratio (cdr ratio)) | ||
| 1030 : | (t (yoko-ratio | ||
| 1031 : | xlen1 | ||
| 1032 : | (*$ ylen1 (//$ (-$ (fourth rregion1)(second rregion1)) | ||
| 1033 : | height1)) | ||
| 1034 : | xlen2 | ||
| 1035 : | (*$ ylen2 (//$ (-$ (fourth rregion2)(second rregion2)) | ||
| 1036 : | height2)))))) | ||
| 1037 : | (new1 | ||
| 1038 : | (simple-scalexy (//$ (*$ 2.0 ratio) width1) rate1 | ||
| 1039 : | (simple-movexy (-$ (first rregion1)) | ||
| 1040 : | (-$ (car updown1)(second rregion1)) | ||
| 1041 : | simple1))) | ||
| 1042 : | (new2 | ||
| 1043 : | (simple-scalexy (//$ (*$ 2.0 (-$ 1.0 ratio)) width2) rate2 | ||
| 1044 : | (simple-movexy (-$ (first rregion2)) | ||
| 1045 : | (-$ (car updown2)(second rregion2)) | ||
| 1046 : | simple2))) | ||
| 1047 : | (limit (assq 'limit alist)) | ||
| 1048 : | (limit (cond (limit (cdr limit)) | ||
| 1049 : | (t | ||
| 1050 : | (yoko-limit new1 new2)))) | ||
| 1051 : | (all (+$ limit (*$ 2.0 (-$ 1.0 ratio))))) | ||
| 1052 : | ; (break) | ||
| 1053 : | (appendpart | ||
| 1054 : | (affinepart | ||
| 1055 : | prim1 | ||
| 1056 : | (movexy 20.0 20.0 | ||
| 1057 : | (scalexy (*$ (//$ (//$ (*$ 2.0 ratio) all) width1) 360.0) | ||
| 1058 : | (*$ rate1 180.0) | ||
| 1059 : | (movexy (-$ (first rregion1)) | ||
| 1060 : | (-$ (car updown1)(second rregion1)))))) | ||
| 1061 : | (affinepart | ||
| 1062 : | prim2 | ||
| 1063 : | (movexy (+$ 20.0 (*$ 360.0 (//$ limit all))) | ||
| 1064 : | 20.0 | ||
| 1065 : | (scalexy (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio))all)width2) 360.0) | ||
| 1066 : | (*$ rate2 180.0) | ||
| 1067 : | (movexy (-$ (first rregion2)) | ||
| 1068 : | (-$ (car updown2)(second rregion2))))))))) | ||
| 1069 : | (defun yoko-noupdown (prim1 prim2 (alist)) | ||
| 1070 : | (lets ( | ||
| 1071 : | (simple1 (simplify-link prim1)) | ||
| 1072 : | (rregion1 (realregion prim1)) | ||
| 1073 : | (xlen1 (prim-xlen prim1 rregion1)) | ||
| 1074 : | (ylen1 (prim-ylen prim1 rregion1)) | ||
| 1075 : | (width1 (-$ (third rregion1)(first rregion1))) | ||
| 1076 : | (updown1 (updown0 prim1 rregion1 xlen1)) | ||
| 1077 : | (height1 (+$ (car updown1)(cdr updown1) | ||
| 1078 : | (-$ (fourth rregion1)(second rregion1)))) | ||
| 1079 : | (rate1 (//$ 2.0 height1)) | ||
| 1080 : | (simple2 (simplify-link prim2)) | ||
| 1081 : | (rregion2 (realregion prim2)) | ||
| 1082 : | (xlen2 (prim-xlen prim2 rregion2)) | ||
| 1083 : | (ylen2 (prim-ylen prim2 rregion2)) | ||
| 1084 : | (updown2 (updown0 prim2 rregion2 xlen2)) | ||
| 1085 : | (width2 (-$ (third rregion2)(first rregion2))) | ||
| 1086 : | (region2 (partregion prim2)) | ||
| 1087 : | (height2 (+$ (car updown2)(cdr updown2) | ||
| 1088 : | (-$ (fourth rregion2)(second rregion2)))) | ||
| 1089 : | (rate2 (//$ 2.0 height2)) | ||
| 1090 : | (ratio (assq 'ratio alist)) | ||
| 1091 : | (ratio | ||
| 1092 : | (cond (ratio (cdr ratio)) | ||
| 1093 : | (t (yoko-ratio | ||
| 1094 : | xlen1 | ||
| 1095 : | (*$ ylen1 (//$ (-$ (fourth rregion1)(second rregion1)) | ||
| 1096 : | height1)) | ||
| 1097 : | xlen2 | ||
| 1098 : | (*$ ylen2 (//$ (-$ (fourth rregion2)(second rregion2)) | ||
| 1099 : | height2)))))) | ||
| 1100 : | (new1 | ||
| 1101 : | (simple-scalexy (//$ (*$ 2.0 ratio) width1) rate1 | ||
| 1102 : | (simple-movexy (-$ (first rregion1)) | ||
| 1103 : | (-$ (car updown1)(second rregion1)) | ||
| 1104 : | simple1))) | ||
| 1105 : | (new2 | ||
| 1106 : | (simple-scalexy (//$ (*$ 2.0 (-$ 1.0 ratio)) width2) rate2 | ||
| 1107 : | (simple-movexy (-$ (first rregion2)) | ||
| 1108 : | (-$ (car updown2)(second rregion2)) | ||
| 1109 : | simple2))) | ||
| 1110 : | (limit (assq 'limit alist)) | ||
| 1111 : | (limit (cond (limit (cdr limit)) | ||
| 1112 : | (t | ||
| 1113 : | (yoko-limit new1 new2)))) | ||
| 1114 : | (all (+$ limit (*$ 2.0 (-$ 1.0 ratio))))) | ||
| 1115 : | ; (break) | ||
| 1116 : | (appendpart | ||
| 1117 : | (affinepart | ||
| 1118 : | prim1 | ||
| 1119 : | (movexy 20.0 (+$ 20.0 (*$ (car updown1) rate1 180.0)) | ||
| 1120 : | (scalexy (*$ (//$ (//$ (*$ 2.0 ratio) all) width1) 360.0) | ||
| 1121 : | (*$ rate1 180.0) | ||
| 1122 : | (movexy (-$ (first rregion1)) | ||
| 1123 : | (-$ (second rregion1)))))) | ||
| 1124 : | (affinepart | ||
| 1125 : | prim2 | ||
| 1126 : | (movexy (+$ 20.0 (*$ 360.0 (//$ limit all))) | ||
| 1127 : | (+$ 20.0 (*$ (car updown2) rate2 180.0)) | ||
| 1128 : | (scalexy (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio))all)width2) 360.0) | ||
| 1129 : | (*$ rate2 180.0) | ||
| 1130 : | (movexy (-$ (first rregion2)) | ||
| 1131 : | (-$ (second rregion2))))))))) | ||
| 1132 : | |||
| 1133 : | (defun yoko12 (prim1 prim2 (alist)) | ||
| 1134 : | (yoko2 prim1 prim2 alist)) | ||
| 1135 : | (defun yoko21 (prim1 prim2 (alist)) | ||
| 1136 : | (yoko2 prim1 prim2 alist)) | ||
| 1137 : | (defun yoko3 (prim1 prim2 prim3) | ||
| 1138 : | (let ((newprim (yoko2 prim1 prim2))) | ||
| 1139 : | (yoko2 newprim prim3))) | ||
| 1140 : | |||
| 1141 : | |||
| 1142 : | ; timesy | ||
| 1143 : | ; simple の y を ratio 倍する | ||
| 1144 : | (defun timesy (ratio simple) | ||
| 1145 : | (do ((l (car simple) (cdr l)) | ||
| 1146 : | (ret nil)) | ||
| 1147 : | ((atom l) (cons ret (cdr simple))) | ||
| 1148 : | (push `(,(caar l) ,(cadar l) ,(*$ (caddar l) ratio)) ret))) | ||
| 1149 : | |||
| 1150 : | (defun simple-scalexy (x y simple) | ||
| 1151 : | (do ((l (car simple) (cdr l)) | ||
| 1152 : | (ret nil)) | ||
| 1153 : | ((atom l) (cons ret (cdr simple))) | ||
| 1154 : | (push `(,(caar l) ,(*$ (cadar l) x) ,(*$ (caddar l) y)) ret))) | ||
| 1155 : | |||
| 1156 : | (defun simple-movexy (x y simple) | ||
| 1157 : | (do ((l (car simple) (cdr l)) | ||
| 1158 : | (ret nil)) | ||
| 1159 : | ((atom l) (cons ret (cdr simple))) | ||
| 1160 : | (push `(,(caar l) ,(+$ (cadar l) x) ,(+$ (caddar l) y)) ret))) | ||
| 1161 : | |||
| 1162 : | ; simple-height | ||
| 1163 : | ; maxy - miny | ||
| 1164 : | ; | ||
| 1165 : | (defun simple-height (points) | ||
| 1166 : | (do ((l points (cdr l)) | ||
| 1167 : | (y nil) | ||
| 1168 : | (maxy (caddar points)) | ||
| 1169 : | (miny (caddar points))) | ||
| 1170 : | ((atom l)(-$ maxy miny)) | ||
| 1171 : | (setq y (caddar l)) | ||
| 1172 : | (cond ((>$ miny y)(setq miny y)) | ||
| 1173 : | ((<$ maxy y)(setq maxy y))))) | ||
| 1174 : | |||
| 1175 : | ; simple-length | ||
| 1176 : | ; simpleとx方向、y方向の拡大率から長さを計算する | ||
| 1177 : | ; | ||
| 1178 : | (defun simple-length (simple xratio yratio) | ||
| 1179 : | (let ((points (car simple)) | ||
| 1180 : | (lines (cdr simple))) | ||
| 1181 : | (do ((l lines (cdr l)) | ||
| 1182 : | (p0 nil) | ||
| 1183 : | (p1 nil) | ||
| 1184 : | (x nil) | ||
| 1185 : | (y nil) | ||
| 1186 : | (length 0.0)) | ||
| 1187 : | ((atom l)length) | ||
| 1188 : | (setq p0 (assq (caar l) points)) | ||
| 1189 : | (setq p1 (assq (cadar l) points)) | ||
| 1190 : | (setq x (*$ xratio (-$ (cadr p0)(cadr p1)))) | ||
| 1191 : | (setq y (*$ yratio (-$ (caddr p0)(caddr p1)))) | ||
| 1192 : | (setq length (+$ length (abs x) (abs y)))))) | ||
| 1193 : | ; (setq length (+$ length (sqrt (+$ (*$ x x)(*$ y y)))))))) | ||
| 1194 : | |||
| 1195 : | ; tate-limit | ||
| 1196 : | ; simple1 simple2 | ||
| 1197 : | ; を渡されて、yoffset (of simple2)を返す | ||
| 1198 : | |||
| 1199 : | (defun tate-limit (simple1 simple2) | ||
| 1200 : | (lets ((yoffset 0.0) | ||
| 1201 : | (theta nil) | ||
| 1202 : | (costheta nil) | ||
| 1203 : | (maxcos 0.0) | ||
| 1204 : | (real1 (simple-realregion simple1)) | ||
| 1205 : | (region1 (simple-partregion simple1)) | ||
| 1206 : | (real2 (simple-realregion simple2)) | ||
| 1207 : | (region2 (simple-partregion simple2)) | ||
| 1208 : | (midspace (-$ (*$ 0.6 (+$ (-$ (fourth region1)(fourth real1)) | ||
| 1209 : | (-$ (second real2)(second region2)))))) | ||
| 1210 : | (midspace (cond ((>$ midspace -0.15)-0.15)(t midspace))) | ||
| 1211 : | (points1 (car simple1)) | ||
| 1212 : | (lines1 (cdr simple1)) | ||
| 1213 : | (points2 (car simple2)) | ||
| 1214 : | (lines2 (cdr simple2))) | ||
| 1215 : | ; (prind midspace) | ||
| 1216 : | (do ((l points1 (cdr l)) | ||
| 1217 : | (x nil) | ||
| 1218 : | (y nil) | ||
| 1219 : | (mincross nil)) | ||
| 1220 : | ((atom l)) | ||
| 1221 : | ; (prind midspace) | ||
| 1222 : | (setq x (cadar l) y (caddar l)) | ||
| 1223 : | (setq mincross (find-min-line simple2 x)) | ||
| 1224 : | (cond (mincross | ||
| 1225 : | (setq maxcos (maxcos mincross points2 (car l) lines1 points1)) | ||
| 1226 : | ; (prind (list mincross (car l) maxcos yoffset)) | ||
| 1227 : | (cond | ||
| 1228 : | ((>$ (-$ y (car mincross) | ||
| 1229 : | (*$ midspace maxcos maxcos maxcos)) | ||
| 1230 : | yoffset) | ||
| 1231 : | (setq yoffset | ||
| 1232 : | (-$ y (car mincross) | ||
| 1233 : | (*$ midspace maxcos maxcos maxcos))) | ||
| 1234 : | (setq theta (cdr mincross))))))) | ||
| 1235 : | (do ((l points2 (cdr l)) | ||
| 1236 : | (x nil) | ||
| 1237 : | (y nil) | ||
| 1238 : | (maxcross nil)) | ||
| 1239 : | ((atom l)yoffset) | ||
| 1240 : | (setq x (cadar l) y (caddar l)) | ||
| 1241 : | (setq maxcross (find-max-line simple1 x)) | ||
| 1242 : | (setq maxcos 0.0 costheta 0.0) | ||
| 1243 : | (cond (maxcross | ||
| 1244 : | (setq maxcos (maxcos maxcross points1 (car l) lines2 points2)) | ||
| 1245 : | (cond | ||
| 1246 : | ((>$ (-$ (car maxcross) y (*$ midspace maxcos maxcos maxcos)) | ||
| 1247 : | yoffset) | ||
| 1248 : | (setq yoffset | ||
| 1249 : | (-$ (car maxcross) y (*$ midspace maxcos maxcos maxcos))) | ||
| 1250 : | (setq theta (cdr maxcross))))))))) | ||
| 1251 : | (defun tate-limit1 (simple1 simple2) | ||
| 1252 : | (lets ((yoffset 0.0) | ||
| 1253 : | (theta nil) | ||
| 1254 : | (costheta nil) | ||
| 1255 : | (maxcos 0.0) | ||
| 1256 : | (real1 (simple-realregion simple1)) | ||
| 1257 : | (region1 (simple-partregion simple1)) | ||
| 1258 : | (real2 (simple-realregion simple2)) | ||
| 1259 : | (region2 (simple-partregion simple2)) | ||
| 1260 : | (midspace (-$ (*$ 0.6 (+$ (-$ (fourth region1)(fourth real1)) | ||
| 1261 : | (-$ (second real2)(second region2)))))) | ||
| 1262 : | (midspace 0.0) | ||
| 1263 : | (points1 (car simple1)) | ||
| 1264 : | (lines1 (cdr simple1)) | ||
| 1265 : | (points2 (car simple2)) | ||
| 1266 : | (lines2 (cdr simple2))) | ||
| 1267 : | ; (prind midspace) | ||
| 1268 : | (do ((l points1 (cdr l)) | ||
| 1269 : | (x nil) | ||
| 1270 : | (y nil) | ||
| 1271 : | (mincross nil)) | ||
| 1272 : | ((atom l)) | ||
| 1273 : | ; (prind midspace) | ||
| 1274 : | (setq x (cadar l) y (caddar l)) | ||
| 1275 : | (setq mincross (find-min-line simple2 x)) | ||
| 1276 : | (cond (mincross | ||
| 1277 : | (setq maxcos (maxcos mincross points2 (car l) lines1 points1)) | ||
| 1278 : | ; (prind (list mincross (car l) maxcos yoffset)) | ||
| 1279 : | (cond | ||
| 1280 : | ((>$ (-$ y (car mincross) | ||
| 1281 : | (*$ midspace maxcos maxcos maxcos)) | ||
| 1282 : | yoffset) | ||
| 1283 : | (setq yoffset | ||
| 1284 : | (-$ y (car mincross) | ||
| 1285 : | (*$ midspace maxcos maxcos maxcos))) | ||
| 1286 : | (setq theta (cdr mincross))))))) | ||
| 1287 : | (do ((l points2 (cdr l)) | ||
| 1288 : | (x nil) | ||
| 1289 : | (y nil) | ||
| 1290 : | (maxcross nil)) | ||
| 1291 : | ((atom l)yoffset) | ||
| 1292 : | (setq x (cadar l) y (caddar l)) | ||
| 1293 : | (setq maxcross (find-max-line simple1 x)) | ||
| 1294 : | (setq maxcos 0.0 costheta 0.0) | ||
| 1295 : | (cond (maxcross | ||
| 1296 : | (setq maxcos (maxcos maxcross points1 (car l) lines2 points2)) | ||
| 1297 : | (cond | ||
| 1298 : | ((>$ (-$ (car maxcross) y (*$ midspace maxcos maxcos maxcos)) | ||
| 1299 : | yoffset) | ||
| 1300 : | (setq yoffset | ||
| 1301 : | (-$ (car maxcross) y (*$ midspace maxcos maxcos maxcos))) | ||
| 1302 : | (setq theta (cdr maxcross))))))))) | ||
| 1303 : | |||
| 1304 : | (defun yoko-limit (simple1 simple2) | ||
| 1305 : | (lets ((xoffset 0.0) | ||
| 1306 : | (theta nil) | ||
| 1307 : | (costheta nil) | ||
| 1308 : | (maxcos 0.0) | ||
| 1309 : | (real1 (simple-realregion simple1)) | ||
| 1310 : | ; (region1 (simple-partregion simple1)) | ||
| 1311 : | (real2 (simple-realregion simple2)) | ||
| 1312 : | ; (region2 (simple-partregion simple2)) | ||
| 1313 : | ; (midspace (-$ (*$ 1.1 (+$ (-$ (fourth region1)(fourth real1)) | ||
| 1314 : | ; (-$ (second real2)(second region2)))))) | ||
| 1315 : | ; (midspace (cond ((>$ midspace -0.15)-0.15)(t midspace))) | ||
| 1316 : | (midspace (*$ -0.2 (-$ (fourth real2)(second real2)))) | ||
| 1317 : | ; (midspace 0.0) | ||
| 1318 : | (points1 (car simple1)) | ||
| 1319 : | (lines1 (cdr simple1)) | ||
| 1320 : | (points2 (car simple2)) | ||
| 1321 : | (lines2 (cdr simple2))) | ||
| 1322 : | (do ((l points1 (cdr l)) | ||
| 1323 : | (x nil) | ||
| 1324 : | (y nil) | ||
| 1325 : | (mincross nil)) | ||
| 1326 : | ((atom l)) | ||
| 1327 : | (setq x (cadar l) y (caddar l)) | ||
| 1328 : | ; (prind (list x y)) | ||
| 1329 : | (setq mincross (find-min-line-x simple2 y)) | ||
| 1330 : | (cond (mincross | ||
| 1331 : | (setq maxcos (maxcos mincross points2 (car l) lines1 points1)) | ||
| 1332 : | (cond | ||
| 1333 : | ((>$ (-$ x (car mincross) | ||
| 1334 : | (*$ midspace (+$ 0.3 (*$ maxcos maxcos)))) | ||
| 1335 : | xoffset) | ||
| 1336 : | (setq xoffset | ||
| 1337 : | (-$ x (car mincross) | ||
| 1338 : | (*$ midspace (+$ 0.3 (*$ maxcos maxcos))))) | ||
| 1339 : | (setq theta (cdr mincross))))))) | ||
| 1340 : | (do ((l points2 (cdr l)) | ||
| 1341 : | (x nil) | ||
| 1342 : | (y nil) | ||
| 1343 : | (maxcross nil)) | ||
| 1344 : | ((atom l)xoffset) | ||
| 1345 : | (setq x (cadar l) y (caddar l)) | ||
| 1346 : | (setq maxcross (find-max-line-x simple1 y)) | ||
| 1347 : | (setq maxcos 0.0 costheta 0.0) | ||
| 1348 : | (cond (maxcross | ||
| 1349 : | (setq maxcos (maxcos maxcross points1 (car l) lines2 points2)) | ||
| 1350 : | (cond | ||
| 1351 : | ((>$ (-$ (car maxcross) x | ||
| 1352 : | (*$ midspace (+$ 0.3 (*$ maxcos maxcos)))) | ||
| 1353 : | xoffset) | ||
| 1354 : | (setq xoffset | ||
| 1355 : | (-$ (car maxcross) x | ||
| 1356 : | (*$ midspace (+$ 0.3 (*$ maxcos maxcos))))) | ||
| 1357 : | (setq theta (cdr maxcross))))))))) | ||
| 1358 : | |||
| 1359 : | (defun maxcos(mincross points2 point lines1 points1) | ||
| 1360 : | (do ((ll lines1 (cdr ll)) | ||
| 1361 : | (p0 (cdr (assq (cadr mincross) points2))) | ||
| 1362 : | (p1 (cdr (assq (caddr mincross) points2))) | ||
| 1363 : | (p2 nil) | ||
| 1364 : | (p3 nil) | ||
| 1365 : | (costheta 0.0) | ||
| 1366 : | (maxcos 0.0)) | ||
| 1367 : | ((atom ll) | ||
| 1368 : | ; (prind (list mincross points2 lines1 points1 maxcos)) | ||
| 1369 : | ; (prind (list mincross point maxcos)) | ||
| 1370 : | maxcos) | ||
| 1371 : | (cond ((eq (car point) (caar ll)) | ||
| 1372 : | (setq p2 (diff2 (cdr (assq (caar ll) points1)) | ||
| 1373 : | (cdr (assq (cadar ll) points1)))) | ||
| 1374 : | (setq costheta (costheta(diff2 p1 p0) p2))) | ||
| 1375 : | ((eq (car point) (cadar ll)) | ||
| 1376 : | (setq p2 (diff2 (cdr (assq (caar ll) points1)) | ||
| 1377 : | (cdr (assq (cadar ll) points1)))) | ||
| 1378 : | (setq costheta (costheta(diff2 p1 p0) p2)))) | ||
| 1379 : | (cond ((null costheta)(setq costheta 0.0)) | ||
| 1380 : | ((0>$ costheta)(setq costheta (-$ costheta)))) | ||
| 1381 : | (cond ((<$ maxcos costheta)(setq maxcos costheta))))) | ||
| 1382 : | |||
| 1383 : | (setq xw 0.0) | ||
| 1384 : | |||
| 1385 : | (defun find-min-line (simple x) | ||
| 1386 : | (lets ((lines (cdr simple)) | ||
| 1387 : | (points (car simple))) | ||
| 1388 : | (do ((l lines (cdr l)) | ||
| 1389 : | (ret nil) | ||
| 1390 : | (miny nil) | ||
| 1391 : | (line nil) | ||
| 1392 : | (p0 nil) | ||
| 1393 : | (p1 nil) | ||
| 1394 : | (x0 nil)(x1 nil)(y0 nil)(y1 nil)(y nil)(t nil) | ||
| 1395 : | ) | ||
| 1396 : | ((atom l) | ||
| 1397 : | (cond ((null miny)nil) | ||
| 1398 : | (t (cons miny line)))) | ||
| 1399 : | (setq p0 (cdr (assq (caar l) points))) | ||
| 1400 : | (setq p1 (cdr (assq (cadar l) points))) | ||
| 1401 : | (setq x0 (car p0) y0 (cadr p0)) | ||
| 1402 : | (setq x1 (car p1) y1 (cadr p1)) | ||
| 1403 : | (cond ((=$ x0 x1) | ||
| 1404 : | (cond ((<=$ (-$ x0 xw) x (+$ x0 xw)) | ||
| 1405 : | (cond ((>$ y0 y1)(setq y (+$ y1 xw))) | ||
| 1406 : | (t (setq y (+$ y0 xw)))) | ||
| 1407 : | (cond ((or (null miny)(>$ miny y)) | ||
| 1408 : | (setq miny y) | ||
| 1409 : | (setq line (car l))))))) | ||
| 1410 : | ((or (<=$ (-$ x0 xw) x (+$ x1 xw)) | ||
| 1411 : | (<=$ (-$ x1 xw) x (+$ x0 xw))) | ||
| 1412 : | (setq t (//$ (-$ x x0)(-$ x1 x0))) | ||
| 1413 : | (cond ((<=$ 0.0 t 1.0) | ||
| 1414 : | (setq y (+$ (*$ (-$ 1.0 t) y0)(*$ t y1)))) | ||
| 1415 : | ((<$ t 0.0)(setq y y0)) | ||
| 1416 : | ((>$ t 1.0)(setq y y1))) | ||
| 1417 : | (cond ((or (null miny)(>$ miny y)) | ||
| 1418 : | (setq miny y) | ||
| 1419 : | (setq line (car l))))))))) | ||
| 1420 : | |||
| 1421 : | (defun find-max-line (simple x) | ||
| 1422 : | (lets ((lines (cdr simple)) | ||
| 1423 : | (points (car simple))) | ||
| 1424 : | (do ((l lines (cdr l)) | ||
| 1425 : | (ret nil) | ||
| 1426 : | (maxy nil) | ||
| 1427 : | (line nil) | ||
| 1428 : | (p0 nil) | ||
| 1429 : | (p1 nil) | ||
| 1430 : | (x0 nil)(x1 nil)(y0 nil)(y1 nil)(y nil)(t nil) | ||
| 1431 : | ) | ||
| 1432 : | ((atom l) | ||
| 1433 : | (cond ((null maxy) nil) | ||
| 1434 : | (t (cons maxy line)))) | ||
| 1435 : | (setq p0 (cdr (assq (caar l) points))) | ||
| 1436 : | (setq p1 (cdr (assq (cadar l) points))) | ||
| 1437 : | (setq x0 (car p0) y0 (cadr p0)) | ||
| 1438 : | (setq x1 (car p1) y1 (cadr p1)) | ||
| 1439 : | (cond ((=$ x0 x1) | ||
| 1440 : | (cond ((<=$ (-$ x0 xw) x (+$ x0 xw)) | ||
| 1441 : | (cond ((>$ y0 y1)(setq y (+$ y1 xw))) | ||
| 1442 : | (t (setq y (+$ y0 xw)))) | ||
| 1443 : | (cond ((or (null maxy)(<$ maxy y)) | ||
| 1444 : | (setq maxy y) | ||
| 1445 : | (setq line (car l))))))) | ||
| 1446 : | ((or (<=$ (-$ x0 xw) x (+$ x1 xw)) | ||
| 1447 : | (<=$ (-$ x1 xw) x (+$ x0 xw))) | ||
| 1448 : | (setq t (//$ (-$ x x0)(-$ x1 x0))) | ||
| 1449 : | (cond ((<=$ 0.0 t 1.0) | ||
| 1450 : | (setq y (+$ (*$ (-$ 1.0 t) y0)(*$ t y1)))) | ||
| 1451 : | ((<$ t 0.0)(setq y y0)) | ||
| 1452 : | ((>$ t 1.0)(setq y y1))) | ||
| 1453 : | (cond ((or (null maxy)(<$ maxy y)) | ||
| 1454 : | (setq maxy y) | ||
| 1455 : | (setq line (car l))))))))) | ||
| 1456 : | (setq yw 0.2) | ||
| 1457 : | |||
| 1458 : | (defun find-min-line-x (simple y) | ||
| 1459 : | (lets ((lines (cdr simple)) | ||
| 1460 : | (points (car simple))) | ||
| 1461 : | (do ((l lines (cdr l)) | ||
| 1462 : | (ret nil) | ||
| 1463 : | (minx nil) | ||
| 1464 : | (line nil) | ||
| 1465 : | (p0 nil) | ||
| 1466 : | (p1 nil) | ||
| 1467 : | (x0 nil)(x1 nil)(y0 nil)(y1 nil)(x nil)(t nil) | ||
| 1468 : | ) | ||
| 1469 : | ((atom l) | ||
| 1470 : | (cond ((null minx)nil) | ||
| 1471 : | (t (cons minx line)))) | ||
| 1472 : | (setq p0 (cdr (assq (caar l) points))) | ||
| 1473 : | (setq p1 (cdr (assq (cadar l) points))) | ||
| 1474 : | (setq x0 (car p0) y0 (cadr p0)) | ||
| 1475 : | (setq x1 (car p1) y1 (cadr p1)) | ||
| 1476 : | (cond ((=$ y0 y1)) | ||
| 1477 : | ((or (<=$ (-$ y0 yw) y (+$ y1 yw)) | ||
| 1478 : | (<=$ (-$ y1 yw) y (+$ y0 yw))) | ||
| 1479 : | (setq t (//$ (-$ y y0)(-$ y1 y0))) | ||
| 1480 : | (cond ((<=$ 0.0 t 1.0) | ||
| 1481 : | (setq x (+$ (*$ (-$ 1.0 t) x0)(*$ t x1)))) | ||
| 1482 : | ((<$ t 0.0)(setq x x0)) | ||
| 1483 : | ((>$ t 1.0)(setq x x1))) | ||
| 1484 : | (cond ((or (null minx)(>$ minx x)) | ||
| 1485 : | (setq minx x) | ||
| 1486 : | (setq line (car l))))))))) | ||
| 1487 : | |||
| 1488 : | (defun find-max-line-x (simple y) | ||
| 1489 : | (lets ((lines (cdr simple)) | ||
| 1490 : | (points (car simple))) | ||
| 1491 : | (do ((l lines (cdr l)) | ||
| 1492 : | (ret nil) | ||
| 1493 : | (minx nil) | ||
| 1494 : | (line nil) | ||
| 1495 : | (p0 nil) | ||
| 1496 : | (p1 nil) | ||
| 1497 : | (x0 nil)(x1 nil)(y0 nil)(y1 nil)(x nil)(t nil) | ||
| 1498 : | ) | ||
| 1499 : | ((atom l) | ||
| 1500 : | (cond ((null minx)nil) | ||
| 1501 : | (t (cons minx line)))) | ||
| 1502 : | (setq p0 (cdr (assq (caar l) points))) | ||
| 1503 : | (setq p1 (cdr (assq (cadar l) points))) | ||
| 1504 : | (setq x0 (car p0) y0 (cadr p0)) | ||
| 1505 : | (setq x1 (car p1) y1 (cadr p1)) | ||
| 1506 : | (cond ((=$ y0 y1)) | ||
| 1507 : | ((or (<=$ (-$ y0 yw) y (+$ y1 yw)) | ||
| 1508 : | (<=$ (-$ y1 yw) y (+$ y0 yw))) | ||
| 1509 : | (setq t (//$ (-$ y y0)(-$ y1 y0))) | ||
| 1510 : | (cond ((<=$ 0.0 t 1.0) | ||
| 1511 : | (setq x (+$ (*$ (-$ 1.0 t) x0)(*$ t x1)))) | ||
| 1512 : | ((<$ t 0.0)(setq x x0)) | ||
| 1513 : | ((>$ t 1.0)(setq x x1))) | ||
| 1514 : | (cond ((or (null minx)(<$ minx x)) | ||
| 1515 : | (setq minx x) | ||
| 1516 : | (setq line (car l))))))))) | ||
| 1517 : | |||
| 1518 : | |||
| 1519 : | ; linkの結果を扱いやすいフォーマットに直す | ||
| 1520 : | ; car部はlinknumberとx yのリスト(x,yはfloatに) | ||
| 1521 : | ; cdr部はlineのリスト | ||
| 1522 : | |||
| 1523 : | (defun simplify-link (prim) | ||
| 1524 : | (lets ((points (car prim)) | ||
| 1525 : | (lines (cadr prim)) | ||
| 1526 : | (newpoints nil) | ||
| 1527 : | (newlines nil)) | ||
| 1528 : | (do ((l points (cdr l)) | ||
| 1529 : | (i 0 (1+ i))) | ||
| 1530 : | ((atom l)) | ||
| 1531 : | (push (list i (toflo (caar l))(toflo (cadar l))) newpoints)) | ||
| 1532 : | (do ((l lines (cdr l))) | ||
| 1533 : | ((atom l)(cons (nreverse newpoints) (nreverse newlines))) | ||
| 1534 : | (setq newlines (append newlines (twolinks (cadar l))))))) | ||
| 1535 : | |||
| 1536 : | ; | ||
| 1537 : | ; twolinks | ||
| 1538 : | ; linkのうちの最初のn-1個のペアを返す | ||
| 1539 : | |||
| 1540 : | (defun twolinks(link) | ||
| 1541 : | (do ((l link (cdr l)) | ||
| 1542 : | (i 0 (1+ i)) | ||
| 1543 : | (ret nil)) | ||
| 1544 : | ((atom (cdr l))(nreverse ret)) | ||
| 1545 : | (push (list (car l)(cadr l)) ret))) | ||
| 1546 : | |||
| 1547 : | ; | ||
| 1548 : | ; find-cross | ||
| 1549 : | ; simplifyの結果をもらってcross pointを全部求める | ||
| 1550 : | |||
| 1551 : | (defun find-cross (simple) | ||
| 1552 : | (lets ((points (car simple)) | ||
| 1553 : | (linkcount (length points)) | ||
| 1554 : | (cross nil) | ||
| 1555 : | (lines (cdr simple))) | ||
| 1556 : | (do ((l lines (cdr l))) | ||
| 1557 : | ((atom l)(cons points lines)) | ||
| 1558 : | (do ((ll (cdr l) (cdr ll))) | ||
| 1559 : | ((atom ll)) | ||
| 1560 : | (cond ((or (memq (caar l) (car ll)) | ||
| 1561 : | (memq (car (last (car l)))(car ll)))) | ||
| 1562 : | (t | ||
| 1563 : | (setq cross (cross2 (car l)(car ll)points)) | ||
| 1564 : | (cond (cross | ||
| 1565 : | (push (cons linkcount cross)points) | ||
| 1566 : | (addcross linkcount (car l) points) | ||
| 1567 : | (addcross linkcount (car ll) points) | ||
| 1568 : | (setq linkcount (1+ linkcount)))))))))) | ||
| 1569 : | ; | ||
| 1570 : | (setq crossnoise 3.0) | ||
| 1571 : | ; cross2 | ||
| 1572 : | ; 2つのlineのcrossがあるならそれを返す | ||
| 1573 : | ; ないならnil | ||
| 1574 : | |||
| 1575 : | (defun cross2 (line1 line2 points) | ||
| 1576 : | (lets ((p11 (cdr (assq (car line1) points))) | ||
| 1577 : | (p12 (cdr (assq (car (last line1)) points))) | ||
| 1578 : | (p21 (cdr (assq (car line2) points))) | ||
| 1579 : | (p22 (cdr (assq (car (last line2)) points))) | ||
| 1580 : | (ax (car p11)) (ay (cadr p11)) | ||
| 1581 : | (bx (-$ (car p12) ax)) (by (-$ (cadr p12) ay)) | ||
| 1582 : | (n1 (//$ crossnoise (sqrt (+$ (*$ bx bx)(*$ by by))))) | ||
| 1583 : | (cx (car p21)) (cy (cadr p21)) | ||
| 1584 : | (dx (-$ (car p22) cx)) (dy (-$ (cadr p22) cy)) | ||
| 1585 : | (n2 (//$ crossnoise (sqrt (+$ (*$ dx dx)(*$ dy dy))))) | ||
| 1586 : | (mat2 (vector 4 (list bx by (-$ dx)(-$ dy)))) | ||
| 1587 : | (rmat nil) | ||
| 1588 : | (ss nil) | ||
| 1589 : | (s nil)) | ||
| 1590 : | ; (print (list n1 n2)) | ||
| 1591 : | (cond | ||
| 1592 : | ((0=$ (-$ (*$ bx dy)(*$ by dx)))nil) | ||
| 1593 : | (t | ||
| 1594 : | (setq rmat2 (rmat mat2)) | ||
| 1595 : | (setq ss (+$ (*$ (vref rmat2 0)(-$ cx ax))(*$ (vref rmat2 2)(-$ cy ay)))) | ||
| 1596 : | (setq s (+$ (*$ (vref rmat2 1)(-$ cx ax))(*$ (vref rmat2 3)(-$ cy ay)))) | ||
| 1597 : | (cond ((and (<$ (-$ n2) s (+$ 1.0 n2))(<$ (-$ n1) ss (+$ 1.0 n1))) | ||
| 1598 : | (list (+$ cx (*$ s dx))(+$ cy (*$ s dy)))) | ||
| 1599 : | (t nil)))))) | ||
| 1600 : | |||
| 1601 : | ; | ||
| 1602 : | ; 逆行列を求める | ||
| 1603 : | ; | ||
| 1604 : | |||
| 1605 : | (defun rmat (mat) | ||
| 1606 : | (let ((eigen (//$ 1.0 (-$ (*$ (vref mat 0)(vref mat 3))(*$ (vref mat 1)(vref mat 2))))) | ||
| 1607 : | (ret (vector 4))) | ||
| 1608 : | (vset ret 0 (*$ eigen (vref mat 3))) | ||
| 1609 : | (vset ret 1 (*$ eigen -1.0 (vref mat 1))) | ||
| 1610 : | (vset ret 2 (*$ eigen -1.0 (vref mat 2))) | ||
| 1611 : | (vset ret 3 (*$ eigen (vref mat 0))) | ||
| 1612 : | ret)) | ||
| 1613 : | |||
| 1614 : | ; addcross point line points | ||
| 1615 : | ; | ||
| 1616 : | |||
| 1617 : | (defun addcross (point line points) | ||
| 1618 : | (lets ((first (cdr (assq (car line) points))) | ||
| 1619 : | (p0 (cdr (assq point points))) | ||
| 1620 : | (p1 (cdr (assq (car (last line)) points))) | ||
| 1621 : | (len (metric2 first p0))) | ||
| 1622 : | (cond | ||
| 1623 : | ((0>$ (mul2 (diff2 p0 first)(diff2 p1 first))) | ||
| 1624 : | (prind (list p0 p1 first)) | ||
| 1625 : | (rplaca line point)) | ||
| 1626 : | (t | ||
| 1627 : | (do ((l (cdr line) (cdr l)) | ||
| 1628 : | (lastl line)) | ||
| 1629 : | ((atom l) | ||
| 1630 : | (rplacd lastl (ncons (car lastl))) | ||
| 1631 : | (rplaca lastl point)) | ||
| 1632 : | (cond ((<=$ len (metric2 first (cdr (assq (car l)points)))) | ||
| 1633 : | (rplacd lastl (cons point (cdr lastl))) | ||
| 1634 : | (exit))) | ||
| 1635 : | (setq lastl l)))))) | ||
| 1636 : | |||
| 1637 : | ; linesからgraphを作る | ||
| 1638 : | ; | ||
| 1639 : | ; | ||
| 1640 : | |||
| 1641 : | (defun make-graph (lines) | ||
| 1642 : | (do ((ret nil) | ||
| 1643 : | (l lines (cdr l))) | ||
| 1644 : | ((atom l)ret) | ||
| 1645 : | (do ((ll (car l) (cdr ll))) | ||
| 1646 : | ((atom (cdr ll))) | ||
| 1647 : | (setq as1 (assq (car ll) ret)) | ||
| 1648 : | (cond ((null as1)(setq as1 (ncons (car ll)))(push as1 ret))) | ||
| 1649 : | (setq as2 (assq (cadr ll) ret)) | ||
| 1650 : | (cond ((null as2)(setq as2 (ncons (cadr ll)))(push as2 ret))) | ||
| 1651 : | (rplacd as1 (cons (cadr ll) (cdr as1))) | ||
| 1652 : | (rplacd as2 (cons (car ll)(cdr as2)))))) | ||
| 1653 : | |||
| 1654 : | |||
| 1655 : | (setq shortline 5.0) | ||
| 1656 : | ; rmshortline | ||
| 1657 : | ; 短いlineを除く | ||
| 1658 : | (defun rmshortline (graph points) | ||
| 1659 : | (do ((l graph (cdr l)) | ||
| 1660 : | (ret nil)) | ||
| 1661 : | ((atom l)(nreverse ret)) | ||
| 1662 : | (cond ((and (= 2 (length (car l))) | ||
| 1663 : | (<$ (metric2 (cdr (assq (caar l) points)) | ||
| 1664 : | (cdr (assq (cadar l) points))) shortline)) | ||
| 1665 : | (print (list (caar l) (assq (cadar l) graph))) | ||
| 1666 : | (delq (caar l)(assq (cadar l) graph))) | ||
| 1667 : | (t | ||
| 1668 : | (push (car l) ret))))) | ||
| 1669 : | |||
| 1670 : | ; theta | ||
| 1671 : | ; (x y)から角度を求める | ||
| 1672 : | ; | ||
| 1673 : | (defun theta (p) | ||
| 1674 : | (lets ((x (car p)) | ||
| 1675 : | (y (cadr p)) | ||
| 1676 : | (r (sqrt (+$ (*$ x x)(*$ y y)))) | ||
| 1677 : | (ac (arcsin (//$ x r)))) | ||
| 1678 : | (cond ((0>$ x)ac) | ||
| 1679 : | (t (+$ ac 3.14159265))))) | ||
| 1680 : | |||
| 1681 : | |||
| 1682 : | ; sortgraph | ||
| 1683 : | ; 各点から接続する点の順番を時計の反対回りの順でソートする | ||
| 1684 : | ; | ||
| 1685 : | (defun sortgraph (graph points) | ||
| 1686 : | (mapcar graph | ||
| 1687 : | '(lambda (x) | ||
| 1688 : | (let ((point (cdr (assq (car x) points)))) | ||
| 1689 : | (cons (car x) | ||
| 1690 : | (sort (cdr x) | ||
| 1691 : | '(lambda (x1 x2) | ||
| 1692 : | (>$ (theta (diff2 (cdr (assq x1 points)) point)) | ||
| 1693 : | (theta (diff2 (cdr (assq x2 points)) point)))))))))) | ||
| 1694 : | |||
| 1695 : | ; find-loop : | ||
| 1696 : | ; graphからloopを探して、リストにして返す | ||
| 1697 : | ; | ||
| 1698 : | |||
| 1699 : | (defun find-loop (graph) | ||
| 1700 : | (lets ((ret (copy graph)) | ||
| 1701 : | (rest nil) | ||
| 1702 : | (len nil) | ||
| 1703 : | (isolate nil)) | ||
| 1704 : | (loop | ||
| 1705 : | (setq isolate nil) | ||
| 1706 : | (setq rest nil) | ||
| 1707 : | (do ((l ret (cdr l))) | ||
| 1708 : | ((atom l)) | ||
| 1709 : | (selectq (length (car l)) | ||
| 1710 : | (1) | ||
| 1711 : | (2 (push (car l) isolate)) | ||
| 1712 : | (t (push (car l) rest)))) | ||
| 1713 : | (cond ((null isolate)(exit rest)) | ||
| 1714 : | (t | ||
| 1715 : | (do ((l isolate (cdr l))) | ||
| 1716 : | ((atom l)) | ||
| 1717 : | (delq (caar l) (assq (cadar l) rest) 1)))) | ||
| 1718 : | (setq ret rest)))) | ||
| 1719 : | |||
| 1720 : | ; find-space | ||
| 1721 : | ; simpleとrealregionを与えると、最大の空きregionを返す | ||
| 1722 : | ; | ||
| 1723 : | |||
| 1724 : | ;(defun find-space (simple region) | ||
| 1725 : | |||
| 1726 : | (defun fix1 (x) | ||
| 1727 : | (fix (+$ x 0.5))) | ||
| 1728 : | |||
| 1729 : | (defun affine (point trans) | ||
| 1730 : | (let ((x (toflo (car point))) | ||
| 1731 : | (y (toflo (cadr point)))) | ||
| 1732 : | (list | ||
| 1733 : | (fix1 (+$ (vref trans 4)(*$ x (vref trans 0))(*$ y (vref trans 2)))) | ||
| 1734 : | (fix1 (+$ (vref trans 5)(*$ x (vref trans 1))(*$ y (vref trans 3))))))) | ||
| 1735 : | |||
| 1736 : | (defun affinecons (point trans) | ||
| 1737 : | (let ((x (toflo (car point))) | ||
| 1738 : | (y (toflo (cdr point)))) | ||
| 1739 : | `( | ||
| 1740 : | ,(fix1 (+$ (vref trans 4)(*$ x (vref trans 0))(*$ y (vref trans 2)))) | ||
| 1741 : | .,(fix1 (+$ (vref trans 5)(*$ x (vref trans 1))(*$ y (vref trans 3))))))) | ||
| 1742 : | |||
| 1743 : | (defun affinelist (point trans) | ||
| 1744 : | (let ((x (toflo (car point))) | ||
| 1745 : | (y (toflo (cadr point)))) | ||
| 1746 : | `( | ||
| 1747 : | ,(fix1 (+$ (vref trans 4)(*$ x (vref trans 0))(*$ y (vref trans 2)))) | ||
| 1748 : | ,(fix1 (+$ (vref trans 5)(*$ x (vref trans 1))(*$ y (vref trans 3)))) | ||
| 1749 : | .,(cddr point)))) | ||
| 1750 : | |||
| 1751 : | |||
| 1752 : | (defun metric (x0 y0 x y) | ||
| 1753 : | (+(*(- x0 x)(- x0 x))(*(- y0 y)(- y0 y)))) | ||
| 1754 : | |||
| 1755 : | (defun fmetric (x0 y0 x y) | ||
| 1756 : | (+$(*$(-$ x0 x)(-$ x0 x))(*$(-$ y0 y)(-$ y0 y)))) | ||
| 1757 : | |||
| 1758 : | (defun metric2 (a b) | ||
| 1759 : | (let ((x0 (car a))(y0 (cadr a))(x1 (car b))(y1 (cadr b))) | ||
| 1760 : | (sqrt (+$ (*$ (-$ x0 x1)(-$ x0 x1))(*$ (-$ y0 y1)(-$ y0 y1)))))) | ||
| 1761 : | |||
| 1762 : | |||
| 1763 : | (defun mul2 (a b) | ||
| 1764 : | (+$ (*$ (car a)(car b))(*$ (cadr a)(cadr b)))) | ||
| 1765 : | (defun plus2 (a b) | ||
| 1766 : | (list (plus (car a)(car b))(plus (cadr a)(cadr b)))) | ||
| 1767 : | |||
| 1768 : | (defun plus3 (a b c) | ||
| 1769 : | (list (plus (car a)(car b)(car c))(plus (cadr a)(cadr b)(cadr c)))) | ||
| 1770 : | |||
| 1771 : | (defun diff2 (a b) | ||
| 1772 : | (list (difference (car a)(car b))(difference (cadr a)(cadr b)))) | ||
| 1773 : | |||
| 1774 : | (defun normlen2 (len a) | ||
| 1775 : | (times2 len (norm2 a))) | ||
| 1776 : | |||
| 1777 : | (defun times2 (len a) | ||
| 1778 : | (list (times len (car a))(times len (cadr a)))) | ||
| 1779 : | |||
| 1780 : | (defun norm2 (a) | ||
| 1781 : | (lets ((x (car a)) | ||
| 1782 : | (y (cadr a)) | ||
| 1783 : | (len (sqrt (+$ (*$ x x)(*$ y y))))) | ||
| 1784 : | (list (//$ x len)(//$ y len)))) | ||
| 1785 : | |||
| 1786 : | (defun affinepart (l trans) | ||
| 1787 : | (let ((points (car l)) | ||
| 1788 : | (lines (cadr l)) | ||
| 1789 : | (alist (cddr l)) | ||
| 1790 : | (newpoints nil)) | ||
| 1791 : | (do ((ll points (cdr ll))) | ||
| 1792 : | ((atom ll)`(,(nreverse newpoints) ,lines .,alist)) | ||
| 1793 : | (push (affinelist (car ll) trans) newpoints)))) | ||
| 1794 : | |||
| 1795 : | (defun appendpart (prim0 prim1 (newalist)) | ||
| 1796 : | (lets ((points0 (car prim0)) | ||
| 1797 : | (lines0 (cadr prim0)) | ||
| 1798 : | (base (length points0)) | ||
| 1799 : | (points1 (car prim1)) | ||
| 1800 : | (lines1 (cadr prim1))) | ||
| 1801 : | (do ((l lines1 (cdr l)) | ||
| 1802 : | (newlines nil)) | ||
| 1803 : | ((atom l) | ||
| 1804 : | `(,(append points0 points1) | ||
| 1805 : | ,(append lines0 (nreverse newlines)) | ||
| 1806 : | .,newalist)) | ||
| 1807 : | (setq alist (cddar l)) | ||
| 1808 : | (setq links (assq 'link alist)) | ||
| 1809 : | (cond (links | ||
| 1810 : | (do ((ll (cdr links) (cdr ll)) | ||
| 1811 : | (newlinks nil)) | ||
| 1812 : | ((atom ll)(setq links `(link .,(nreverse newlinks)))) | ||
| 1813 : | (push (+ base (car ll)) newlinks)) | ||
| 1814 : | (push links alist))) | ||
| 1815 : | (do ((ll (cadar l) (cdr ll)) | ||
| 1816 : | (newline nil)) | ||
| 1817 : | ((atom ll)(push (cons (caar l)(cons (nreverse newline) alist)) newlines)) | ||
| 1818 : | (push (+ base (car ll)) newline))))) | ||
| 1819 : | |||
| 1820 : | |||
| 1821 : | (defun movexy (x y (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0)))) | ||
| 1822 : | (let ((ret (vector 6 trans))) | ||
| 1823 : | (vset ret 4 (+$ (vref ret 4)(toflo x))) | ||
| 1824 : | (vset ret 5 (+$ (vref ret 5)(toflo y))) | ||
| 1825 : | ret)) | ||
| 1826 : | |||
| 1827 : | (defun movex (x (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0)))) | ||
| 1828 : | (let ((ret (vector 6 trans))) | ||
| 1829 : | (vset ret 4 (+$ (vref ret 4)(toflo x))) | ||
| 1830 : | ret)) | ||
| 1831 : | |||
| 1832 : | (defun movey (y (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0)))) | ||
| 1833 : | (let ((ret (vector 6 trans))) | ||
| 1834 : | (vset ret 5 (+$ (vref ret 5)(toflo y))) | ||
| 1835 : | ret)) | ||
| 1836 : | |||
| 1837 : | (defun scalex (x (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0)))) | ||
| 1838 : | (let ((ret (vector 6 trans))) | ||
| 1839 : | (vset ret 0 (*$ (vref ret 0)(toflo x))) | ||
| 1840 : | (vset ret 2 (*$ (vref ret 2)(toflo x))) | ||
| 1841 : | (vset ret 4 (*$ (vref ret 4)(toflo x))) | ||
| 1842 : | ret)) | ||
| 1843 : | |||
| 1844 : | (defun scalexy (x y(trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0)))) | ||
| 1845 : | (let ((ret (vector 6 trans))) | ||
| 1846 : | (vset ret 0 (*$ (vref ret 0)(toflo x))) | ||
| 1847 : | (vset ret 1 (*$ (vref ret 1)(toflo y))) | ||
| 1848 : | (vset ret 2 (*$ (vref ret 2)(toflo x))) | ||
| 1849 : | (vset ret 3 (*$ (vref ret 3)(toflo y))) | ||
| 1850 : | (vset ret 4 (*$ (vref ret 4)(toflo x))) | ||
| 1851 : | (vset ret 5 (*$ (vref ret 5)(toflo y))) | ||
| 1852 : | ret)) | ||
| 1853 : | |||
| 1854 : | (defun scaley (y (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0)))) | ||
| 1855 : | (let ((ret (vector 6 trans))) | ||
| 1856 : | (vset ret 1 (*$ (vref ret 1)(toflo y))) | ||
| 1857 : | (vset ret 3 (*$ (vref ret 3)(toflo y))) | ||
| 1858 : | (vset ret 5 (*$ (vref ret 5)(toflo y))) | ||
| 1859 : | ret)) | ||
| 1860 : | |||
| 1861 : | (defun changeregion (part x0 y0 x1 y1) | ||
| 1862 : | (lets ((region (partregion part)) | ||
| 1863 : | (width (-$ (toflo (caddr region))(toflo (car region)))) | ||
| 1864 : | (height (-$ (toflo (cadddr region))(toflo (cadr region)))) | ||
| 1865 : | (dwidth (-$ (toflo x1) (toflo x0))) | ||
| 1866 : | (dheight (-$ (toflo y1) (toflo y0)))) | ||
| 1867 : | (cond ((0=$ width)(setq width dwidth))) | ||
| 1868 : | (cond ((0=$ height)(setq height dheight))) | ||
| 1869 : | (affinepart | ||
| 1870 : | part | ||
| 1871 : | (movexy (toflo x0) (toflo y0) | ||
| 1872 : | (scalexy (//$ dwidth width)(//$ dheight height) | ||
| 1873 : | (movexy (-$ (toflo (car region)))(-$ (toflo (cadr region))))))))) | ||
| 1874 : | |||
| 1875 : | (comment | ||
| 1876 : | (defun yoko2 (part1 part2) | ||
| 1877 : | (lets ((lup (cond ((and (symbolp part1)(get part1 'up)))(t 0))) | ||
| 1878 : | (ldown (cond ((and (symbolp part1)(get part1 'down)))(t 0))) | ||
| 1879 : | (rup (cond ((and (symbolp part2)(get part2 'up)))(t 0))) | ||
| 1880 : | (rdown (cond ((and (symbolp part2)(get part2 'down)))(t 0))) | ||
| 1881 : | (part1 (applykanji part1)) | ||
| 1882 : | (part2 (applykanji part2))) | ||
| 1883 : | (appendpart | ||
| 1884 : | (changeregion part1 20 (+ 20 (// (* 36 lup) 10)) | ||
| 1885 : | 200 (- 380 (// (* 36 ldown) 10))) | ||
| 1886 : | (changeregion part2 200 (+ 20 (// (* 36 rup) 10)) | ||
| 1887 : | 380 (- 380 (// (* 36 rdown) 10)))))) | ||
| 1888 : | ) | ||
| 1889 : | |||
| 1890 : | (defun kamae (part1 part2) | ||
| 1891 : | (lets ((alist (cddr part1)) | ||
| 1892 : | (kamae (assq 'kamae alist)) | ||
| 1893 : | (simple1 (simplify-link part1)) | ||
| 1894 : | (simple2 (simplify-link part2))) | ||
| 1895 : | (cond | ||
| 1896 : | ((null kamae) | ||
| 1897 : | 口) ; for no error | ||
| 1898 : | (t | ||
| 1899 : | (changeregion | ||
| 1900 : | (appendpart | ||
| 1901 : | part1 | ||
| 1902 : | (changeregion part2 (second kamae)(third kamae) | ||
| 1903 : | (fourth kamae)(fifth kamae))) | ||
| 1904 : | 10 10 390 390))))) | ||
| 1905 : | |||
| 1906 : | (defun kamae2 (part1 part2 part3) | ||
| 1907 : | (lets ((alist (caddr part1)) | ||
| 1908 : | (kamae2 (assq 'kamae2 alist)) | ||
| 1909 : | (kamae (car kamae2)) | ||
| 1910 : | (kamae1 (cdr kamae2)) | ||
| 1911 : | (simple1 (simplify-link part1)) | ||
| 1912 : | (simple2 (simplify-link part2)) | ||
| 1913 : | (simple3 (simplify-link part3))) | ||
| 1914 : | (cond | ||
| 1915 : | ((null kamae2) | ||
| 1916 : | 口) | ||
| 1917 : | (t | ||
| 1918 : | (changeregion | ||
| 1919 : | (appendpart | ||
| 1920 : | (appendpart | ||
| 1921 : | part1 | ||
| 1922 : | (changeregion part2 (second kamae)(third kamae) | ||
| 1923 : | (fourth kamae)(fifth kamae))) | ||
| 1924 : | (changeregion part3 (second kamae1)(third kamae1) | ||
| 1925 : | (fourth kamae1)(fifth kamae1)))))))) | ||
| 1926 : | |||
| 1927 : | (defun tare (prim1 prim2) | ||
| 1928 : | 口) | ||
| 1929 : | |||
| 1930 : | (defun nyuutsukuri (prim1 prim2) | ||
| 1931 : | 口) | ||
| 1932 : | |||
| 1933 : | (comment | ||
| 1934 : | (defun xscale (scale prim) | ||
| 1935 : | (lets ((points (car prim)) | ||
| 1936 : | (lines (cadr prim)) | ||
| 1937 : | (alist (cddr prim)) | ||
| 1938 : | (center (find-center prim)) | ||
| 1939 : | (region (partregion prim)) | ||
| 1940 : | (minx (car region)) | ||
| 1941 : | (miny (cadr region)) | ||
| 1942 : | (maxx (caddr region)) | ||
| 1943 : | (maxy (cadddr region)) | ||
| 1944 : | (xlen (prim-xlen prim region))) | ||
| 1945 : | `(,points | ||
| 1946 : | ,lines | ||
| 1947 : | (xlen .,xlen) | ||
| 1948 : | (center .,center) | ||
| 1949 : | (region ,(+$ center (//$ (-$ minx center)scale )) ,miny | ||
| 1950 : | ,(+$ center (//$ (-$ maxx center)scale )) ,maxy) ., alist))) | ||
| 1951 : | ) | ||
| 1952 : | |||
| 1953 : | (defun xscale (scale prim) | ||
| 1954 : | (lets ((points (car prim)) | ||
| 1955 : | (lines (cadr prim)) | ||
| 1956 : | (alist (cddr prim)) | ||
| 1957 : | (center (find-center prim)) | ||
| 1958 : | (rregion (realregion prim)) | ||
| 1959 : | (ylen (prim-ylen prim rregion)) | ||
| 1960 : | (oldwidth (prim-width prim center rregion ylen))) | ||
| 1961 : | `(,points ,lines (width .,(//$ oldwidth scale))))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |