Annotation of /lisp/outline.lAnnotation of /lisp/outline.l
Parent Directory
| 
Revision Log
Revision: 1.1.1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | (defun makeoutline (orig) |
| 2 : | (lets ((all)(ass)) | ||
| 3 : | (do ((l (nconc_outs orig)(cdr l))(i 0)(j 0 (1+ j))) | ||
| 4 : | ((atom l)) | ||
| 5 : | (setq ret (nconc_self (car l))) | ||
| 6 : | ; (prind (length ret)) | ||
| 7 : | (do ((i1 (length ret)(1- i1))) | ||
| 8 : | ((<= i1 0)) | ||
| 9 : | ; (print 'soko) | ||
| 10 : | (push `(,i .,j) ass) | ||
| 11 : | (setq i (1+ i))) | ||
| 12 : | (setq all (nconc all ret))) | ||
| 13 : | ; (prind ass) | ||
| 14 : | ; (prind all) | ||
| 15 : | (unflatten_outlines | ||
| 16 : | (traceall | ||
| 17 : | (validate_flatten | ||
| 18 : | (sort_flatten | ||
| 19 : | (compute_all_cross | ||
| 20 : | (flatten_outlines all))) | ||
| 21 : | ass))))) | ||
| 22 : | |||
| 23 : | (defun flatten_outlines (orig) | ||
| 24 : | (mapcar orig #'flatten_outline)) | ||
| 25 : | (defun flatten_outline (outline) | ||
| 26 : | (do ((ll (append outline (ncons (car outline)))(cdr ll))(ret1)) | ||
| 27 : | ((atom ll)(nreverse ret1)) | ||
| 28 : | (match ll | ||
| 29 : | ((('angle x1 y1)('angle x2 y2).rest) | ||
| 30 : | (or (and (equal x1 x2)(equal y1 y2)) | ||
| 31 : | (push `((line (,x1 ,y1) (,x2 ,y2))) ret1))) | ||
| 32 : | (((`angle x1 y1)('bezier x2 y2)('bezier x3 y3)('angle x4 y4).rest) | ||
| 33 : | (push `((bezier (,x1 ,y1) (,x2 ,y2) (,x3 ,y3) (,x4 ,y4))) ret1) | ||
| 34 : | (setq ll (cddr ll)))))) | ||
| 35 : | (defun unflatten_outlines (orig) | ||
| 36 : | (mapcar orig #'unflatten_outline)) | ||
| 37 : | (defun unflatten_outline (outline) | ||
| 38 : | (do ((ll outline(cdr ll))(ret1)(lastp)) | ||
| 39 : | ((atom ll) | ||
| 40 : | (and ret1 | ||
| 41 : | ; (push `(angle .,lastp) ret1) | ||
| 42 : | (nreverse ret1))) | ||
| 43 : | (match (car ll) | ||
| 44 : | (('bezier p0 p1 p2 p3) | ||
| 45 : | ; (prind `(bezier ,p0 ,p1 ,p2 ,p3)) | ||
| 46 : | (or (equal lastp p0) | ||
| 47 : | (push `(angle .,p0) ret1)) | ||
| 48 : | (setq ret1 `((angle .,p3)(bezier .,p2)(bezier .,p1) .,ret1)) | ||
| 49 : | (setq lastp p3)) | ||
| 50 : | (('line p0 p1) | ||
| 51 : | ; (prind `(line ,p0 ,p1)) | ||
| 52 : | (or (equal lastp p0) | ||
| 53 : | (push `(angle .,p0) ret1)) | ||
| 54 : | (push `(angle .,p1) ret1) | ||
| 55 : | (setq lastp p1))))) | ||
| 56 : | (defun compute_all_cross (flatten) | ||
| 57 : | (do ((l1 flatten (cdr l1))(i1 0 (1+ i1))) | ||
| 58 : | ((atom l1)flatten) | ||
| 59 : | (do ((l2 (car l1)(cdr l2))(j1 0 (1+ j1))) | ||
| 60 : | ((atom l2)) | ||
| 61 : | (do ((l4 (cdr l2)(cdr l4))(j2 (1+ j1)(1+ j2))) | ||
| 62 : | ((or (atom l4)(and (zerop j1)(atom (cdr l4))))) | ||
| 63 : | (compute_cross (car l2)(car l4) i1 j1 i1 j2)) | ||
| 64 : | (do ((l3 (cdr l1) (cdr l3))(i2 (1+ i1) (1+ i2))) | ||
| 65 : | ((atom l3)) | ||
| 66 : | (do ((l4 (car l3)(cdr l4))(j2 0 (1+ j2))) | ||
| 67 : | ((atom l4)) | ||
| 68 : | (compute_cross (car l2)(car l4) i1 j1 i2 j2)))))) | ||
| 69 : | (defun compute_cross (e1 e2 i1 j1 i2 j2) | ||
| 70 : | (and (not (and (equal i1 i2) | ||
| 71 : | (or (equal (1- j1) j2)(equal j1 j2)(equal (1+ j1) j2)))) | ||
| 72 : | (selectq (caar e1) | ||
| 73 : | (line | ||
| 74 : | (selectq (caar e2) | ||
| 75 : | (line (compute_lineline e1 e2 i1 j1 i2 j2)) | ||
| 76 : | (bezier (compute_linebezier e1 e2 i1 j1 i2 j2)))) | ||
| 77 : | (bezier | ||
| 78 : | (selectq (caar e2) | ||
| 79 : | (line (compute_linebezier e2 e1 i2 j2 i1 j1)) | ||
| 80 : | (bezier (compute_bezierbezier e1 e2 i1 j1 i2 j2))))))) | ||
| 81 : | (defun line2line (p10 p11 p20 p21) | ||
| 82 : | ; (print 'line2line) | ||
| 83 : | (lets ((dp1 (diff2 p11 p10))(len1 (length2 dp1)) | ||
| 84 : | (dp2 (diff2 p21 p20))(len2 (length2 dp2))) | ||
| 85 : | (and | ||
| 86 : | (greaterp (abs (sintheta dp1 dp2)) 0.0001) | ||
| 87 : | (lets ((cross (cross2 p10 p20 dp1 dp2)) | ||
| 88 : | (len10 (metric2 p10 cross)) | ||
| 89 : | (len11 (metric2 p11 cross)) | ||
| 90 : | (len20 (metric2 p20 cross)) | ||
| 91 : | (len21 (metric2 p21 cross))) | ||
| 92 : | (cond | ||
| 93 : | ((or (greaterp len10 len1)(greaterp len11 len1) | ||
| 94 : | (greaterp len20 len2)(greaterp len21 len2))nil) | ||
| 95 : | (t | ||
| 96 : | (lets ((sval (//$ len10 (+$ len10 len11))) | ||
| 97 : | (tval (//$ len20 (+$ len20 len21))) | ||
| 98 : | (stheta (sintheta (diff2 p20 p10) dp1)) | ||
| 99 : | (flag (cond ((plusp stheta) -1)(t 1)))) | ||
| 100 : | `(,cross ,sval ,tval ,flag)))))))) | ||
| 101 : | |||
| 102 : | (defun compute_lineline (e1 e2 i1 j1 i2 j2) | ||
| 103 : | (lets ((p10 (cadar e1))(p11 (caddar e1)) | ||
| 104 : | (p20 (cadar e2))(p21 (caddar e2)) | ||
| 105 : | (cross (line2line p10 p11 p20 p21))) | ||
| 106 : | ; (print cross) | ||
| 107 : | (and cross | ||
| 108 : | (rplacd e1 `((,(second cross),(fourth cross),(first cross) ,i2 ,j2) | ||
| 109 : | .,(cdr e1))) | ||
| 110 : | (rplacd e2 `((,(third cross),(- (fourth cross)),(first cross) ,i1 ,j1) | ||
| 111 : | .,(cdr e2)))))) | ||
| 112 : | (defun line2bez (a0 a1 b0 b1 b2 b3 (mint 0.0)(twidth 1.0)) | ||
| 113 : | (lets ((ax0 (car a0))(ay0 (cadr a0)) | ||
| 114 : | (ax1 (car a1))(ay1 (cadr a1)) | ||
| 115 : | (maxax (max ax0 ax1)) | ||
| 116 : | (maxay (max ay0 ay1)) | ||
| 117 : | (minax (min ax0 ax1)) | ||
| 118 : | (minay (min ay0 ay1)) | ||
| 119 : | (bx0 (car b0))(by0 (cadr b0)) | ||
| 120 : | (bx1 (car b1))(by1 (cadr b1)) | ||
| 121 : | (bx2 (car b2))(by2 (cadr b2)) | ||
| 122 : | (bx3 (car b3))(by3 (cadr b3)) | ||
| 123 : | (maxbx (max bx0 bx1 bx2 bx3)) | ||
| 124 : | (maxby (max by0 by1 by2 by3)) | ||
| 125 : | (minbx (min bx0 bx1 bx2 bx3)) | ||
| 126 : | (minby (min by0 by1 by2 by3))(ret)(len0)(len1)) | ||
| 127 : | (cond ((or (lessp maxax minbx)(lessp maxbx minax) | ||
| 128 : | (lessp maxay minby)(lessp maxby minay)) | ||
| 129 : | nil) | ||
| 130 : | ((and (or (<$ (-$ maxbx minbx) 0.5) | ||
| 131 : | (<$ (-$ maxby minby) 0.5)) | ||
| 132 : | (lessp twidth 0.01)) | ||
| 133 : | (setq ret (cross2line a0 a1 b0 b3)) | ||
| 134 : | (setq lena (metric2 a0 a1) lenb (metric2 b0 b3)) | ||
| 135 : | (and ret | ||
| 136 : | (lessp (setq len0 (metric2 a0 ret)) lena) | ||
| 137 : | (lessp (setq len1 (metric2 a1 ret)) lena) | ||
| 138 : | (lessp (metric2 b0 ret) lenb) | ||
| 139 : | (lessp (metric2 b3 ret) lenb) | ||
| 140 : | (setq tt | ||
| 141 : | (plus mint | ||
| 142 : | (times twidth | ||
| 143 : | (quotient (metric2 b0 ret) | ||
| 144 : | lenb)))) | ||
| 145 : | (setq ss (quotient len0 (plus len0 len1))) | ||
| 146 : | `((,ret ,ss .,tt)))) | ||
| 147 : | (t | ||
| 148 : | (lets ((b4 (times2 0.5 (plus2 b0 b1))) | ||
| 149 : | (b5 (times2 0.25 (plus2 b0 (times2 2.0 b1) b2))) | ||
| 150 : | (b6 (times2 0.125 | ||
| 151 : | (plus2 b0 (times2 3.0 b1)(times2 3.0 b2) b3))) | ||
| 152 : | (b7 (times2 0.25 (plus2 b1 (times2 2.0 b2) b3))) | ||
| 153 : | (b8 (times2 0.5 (plus2 b2 b3))) | ||
| 154 : | (twidth1 (times twidth 0.5)) | ||
| 155 : | (t1 (plus mint twidth1))) | ||
| 156 : | (nconc (line2bez a0 a1 b0 b4 b5 b6 mint twidth1) | ||
| 157 : | (line2bez a0 a1 b6 b7 b8 b3 t1 twidth1))))))) | ||
| 158 : | (defun compute_linebezier (e1 e2 i1 j1 i2 j2) | ||
| 159 : | (lets ((a0 (cadar e1))(a1 (caddar e1)) | ||
| 160 : | (b0 (cadar e2))(b1 (caddar e2)) | ||
| 161 : | (b2 (fourth (car e2)))(b3 (fifth (car e2))) | ||
| 162 : | (crosses (line2bez a0 a1 b0 b1 b2 b3))) | ||
| 163 : | (do ((l crosses (cdr l))) | ||
| 164 : | ((atom l)) | ||
| 165 : | (lets ((cross (car l)) | ||
| 166 : | (point (car cross)) | ||
| 167 : | (tval (cddr cross)) | ||
| 168 : | (sval (cadr cross)) | ||
| 169 : | (t1 tval)(t2 (times t1 t1))(t3 (times t2 t1)) | ||
| 170 : | (db0 (times2 3.0 (diff2 b1 b0))) | ||
| 171 : | (db3 (times2 3.0 (diff2 b3 b2))) | ||
| 172 : | (dn1 (plus2 | ||
| 173 : | (times2 t2 (plus2 (times2 6.0 (diff2 b0 b3)) | ||
| 174 : | (times2 3.0 (plus2 db0 db3)))) | ||
| 175 : | (times2 t1 (diff2 (times2 6.0 (diff2 b3 b0)) | ||
| 176 : | (plus2 (times2 4.0 db0) (times2 2.0 db3)))) | ||
| 177 : | db0)) | ||
| 178 : | (flag (cond ((plusp (mul2 (diff2 a1 a0)(rot270 dn1))) 1) | ||
| 179 : | (t -1)))) | ||
| 180 : | (rplacd e1 | ||
| 181 : | `((,sval ,flag ,point ,i2 ,j2).,(cdr e1))) | ||
| 182 : | (rplacd e2 | ||
| 183 : | `((,tval ,(- flag) ,point ,i1 ,j1).,(cdr e2))))))) | ||
| 184 : | |||
| 185 : | (defun bez2bez (a0 a1 a2 a3 b0 b1 b2 b3 (mins 0.0)(mint 0.0)(twidth 1.0)) | ||
| 186 : | (lets ((ax0 (car a0))(ay0 (cadr a0)) | ||
| 187 : | (ax1 (car a1))(ay1 (cadr a1)) | ||
| 188 : | (ax2 (car a2))(ay2 (cadr a2)) | ||
| 189 : | (ax3 (car a3))(ay3 (cadr a3)) | ||
| 190 : | (maxax (max ax0 ax1 ax2 ax3)) | ||
| 191 : | (maxay (max ay0 ay1 ay2 ay3)) | ||
| 192 : | (minax (min ax0 ax1 ax2 ax3)) | ||
| 193 : | (minay (min ay0 ay1 ay2 ay3)) | ||
| 194 : | (bx0 (car b0))(by0 (cadr b0)) | ||
| 195 : | (bx1 (car b1))(by1 (cadr b1)) | ||
| 196 : | (bx2 (car b2))(by2 (cadr b2)) | ||
| 197 : | (bx3 (car b3))(by3 (cadr b3)) | ||
| 198 : | (maxbx (max bx0 bx1 bx2 bx3)) | ||
| 199 : | (maxby (max by0 by1 by2 by3)) | ||
| 200 : | (minbx (min bx0 bx1 bx2 bx3)) | ||
| 201 : | (minby (min by0 by1 by2 by3))(ret)) | ||
| 202 : | (cond ((or (lessp maxax minbx)(lessp maxbx minax) | ||
| 203 : | (lessp maxay minby)(lessp maxby minay)) | ||
| 204 : | nil) | ||
| 205 : | ((and (or (<$ (-$ maxax minax) 0.5)(<$ (-$ maxay minay) 0.5)) | ||
| 206 : | (or (<$ (-$ maxbx minbx) 0.5)(<$ (-$ maxby minby) 0.5)) | ||
| 207 : | (lessp twidth 0.01) | ||
| 208 : | ) | ||
| 209 : | (setq ret (cross2line a0 a3 b0 b3)) | ||
| 210 : | (setq lena (metric2 a0 a3) lenb (metric2 b0 b3)) | ||
| 211 : | (and ret | ||
| 212 : | (lessp (metric2 a0 ret) lena) | ||
| 213 : | (lessp (metric2 a3 ret) lena) | ||
| 214 : | (lessp (metric2 b0 ret) lenb) | ||
| 215 : | (lessp (metric2 b3 ret) lenb) | ||
| 216 : | (setq tt | ||
| 217 : | (plus mint | ||
| 218 : | (times twidth | ||
| 219 : | (quotient (metric2 b0 ret) | ||
| 220 : | lenb)))) | ||
| 221 : | (setq ss | ||
| 222 : | (plus mins | ||
| 223 : | (times twidth | ||
| 224 : | (quotient (metric2 a0 ret) | ||
| 225 : | lena)))) | ||
| 226 : | `((,ret ,ss .,tt)))) | ||
| 227 : | (t | ||
| 228 : | (lets ((a4 (times2 0.5 (plus2 a0 a1))) | ||
| 229 : | (a5 (times2 0.25 (plus2 a0 (times2 2.0 a1) a2))) | ||
| 230 : | (a6 (times2 0.125 | ||
| 231 : | (plus2 a0 (times2 3.0 a1)(times2 3.0 a2) a3))) | ||
| 232 : | (a7 (times2 0.25 (plus2 a1 (times2 2.0 a2) a3))) | ||
| 233 : | (a8 (times2 0.5 (plus2 a2 a3))) | ||
| 234 : | (b4 (times2 0.5 (plus2 b0 b1))) | ||
| 235 : | (b5 (times2 0.25 (plus2 b0 (times2 2.0 b1) b2))) | ||
| 236 : | (b6 (times2 0.125 | ||
| 237 : | (plus2 b0 (times2 3.0 b1)(times2 3.0 b2) b3))) | ||
| 238 : | (b7 (times2 0.25 (plus2 b1 (times2 2.0 b2) b3))) | ||
| 239 : | (b8 (times2 0.5 (plus2 b2 b3))) | ||
| 240 : | (twidth1 (times twidth 0.5)) | ||
| 241 : | (t1 (plus mint twidth1)) | ||
| 242 : | (s1 (plus mins twidth1))) | ||
| 243 : | (nconc (bez2bez a0 a4 a5 a6 b0 b4 b5 b6 mins mint twidth1) | ||
| 244 : | (bez2bez a0 a4 a5 a6 b6 b7 b8 b3 mins t1 twidth1) | ||
| 245 : | (bez2bez a6 a7 a8 a3 b6 b7 b8 b3 s1 t1 twidth1) | ||
| 246 : | (bez2bez a6 a7 a8 a3 b0 b4 b5 b6 s1 mint twidth1))))))) | ||
| 247 : | |||
| 248 : | |||
| 249 : | (defun compute_bezierbezier (e1 e2 i1 j1 i2 j2) | ||
| 250 : | (lets ((a0 (cadar e1))(a1 (caddar e1)) | ||
| 251 : | (a2 (fourth (car e1)))(a3 (fifth (car e1))) | ||
| 252 : | (b0 (cadar e2))(b1 (caddar e2)) | ||
| 253 : | (b2 (fourth (car e2)))(b3 (fifth (car e2))) | ||
| 254 : | (crosses (bez2bez a0 a1 a2 a3 b0 b1 b2 b3))) | ||
| 255 : | (do ((l crosses (cdr l))(cross)) | ||
| 256 : | ((atom l)) | ||
| 257 : | (setq cross (car l)) | ||
| 258 : | (lets ((point (car cross)) | ||
| 259 : | (sval (cadr cross)) | ||
| 260 : | (s1 sval)(s2 (times s1 s1))(s3 (times s2 s1)) | ||
| 261 : | (da0 (times2 3.0 (diff2 a1 a0))) | ||
| 262 : | (da3 (times2 3.0 (diff2 a3 a2))) | ||
| 263 : | (da (plus2 | ||
| 264 : | (times2 s2 (plus2 (times2 6.0 (diff2 a0 a3)) | ||
| 265 : | (times2 3.0 (plus2 da0 da3)))) | ||
| 266 : | (times2 s1 (diff2 (times2 6.0 (diff2 a3 a0)) | ||
| 267 : | (plus2 (times2 4.0 da0) | ||
| 268 : | (times2 2.0 da3)))) | ||
| 269 : | da0)) | ||
| 270 : | (tval (cddr cross)) | ||
| 271 : | (t1 tval)(t2 (times t1 t1))(t3 (times t2 t1)) | ||
| 272 : | (db0 (times2 3.0 (diff2 b1 b0))) | ||
| 273 : | (db3 (times2 3.0 (diff2 b3 b2))) | ||
| 274 : | (db (plus2 | ||
| 275 : | (times2 t2 (plus2 (times2 6.0 (diff2 b0 b3)) | ||
| 276 : | (times2 3.0 (plus2 db0 db3)))) | ||
| 277 : | (times2 t1 (diff2 (times2 6.0 (diff2 b3 b0)) | ||
| 278 : | (plus2 (times2 4.0 db0) | ||
| 279 : | (times2 2.0 db3)))) | ||
| 280 : | db0)) | ||
| 281 : | (flag (cond ((plusp (mul2 da (rot270 db))) 1) | ||
| 282 : | (t -1)))) | ||
| 283 : | (rplacd e1 | ||
| 284 : | `((,sval ,flag ,point ,i2 ,j2).,(cdr e1))) | ||
| 285 : | (rplacd e2 | ||
| 286 : | `((,tval ,(- flag) ,point ,i1 ,j1).,(cdr e2))))))) | ||
| 287 : | |||
| 288 : | (defun sort_flatten (outs) | ||
| 289 : | (do ((l outs (cdr l))(ret)) | ||
| 290 : | ((atom l)(nreverse ret)) | ||
| 291 : | (do ((ll (car l)(cdr ll))(ret1)) | ||
| 292 : | ((atom ll)(push (nreverse ret1) ret)) | ||
| 293 : | (push `(,(caar ll) .,(sort (cdar ll) | ||
| 294 : | #'(lambda (x y)(lessp (car x)(car y))))) | ||
| 295 : | ret1)))) | ||
| 296 : | |||
| 297 : | (defun rm-invalid (out) | ||
| 298 : | (filter out #'(lambda (x) (not (zerop (cadr x)))))) | ||
| 299 : | |||
| 300 : | (defun validate_1 (sorted) | ||
| 301 : | ; (prind `(soko ,sorted)) | ||
| 302 : | (do ((l (cdr sorted) (cdr l)) | ||
| 303 : | (start (second (car sorted))) | ||
| 304 : | (last (second (car sorted)))) | ||
| 305 : | ((atom l) | ||
| 306 : | (and (eq start last) | ||
| 307 : | (rplaca (cdr (car sorted)) 0))) | ||
| 308 : | (cond ((eq last (second (car l))) | ||
| 309 : | (rplaca (cdr (car l)) 0)) | ||
| 310 : | (t | ||
| 311 : | (setq last (second (car l))))))) | ||
| 312 : | (defun set_alt (cross val outs) | ||
| 313 : | (lets ((point (third cross)) | ||
| 314 : | (altline (nth (fourth cross) outs)) | ||
| 315 : | (ret)) | ||
| 316 : | (do ((l altline (cdr l))) | ||
| 317 : | ((or ret (atom l))) | ||
| 318 : | (do ((ll (cdar l) (cdr ll))) | ||
| 319 : | ((atom ll)) | ||
| 320 : | (and (equal (third (car ll)) point) | ||
| 321 : | (exit (setq ret (rplaca (cdar ll) val)))))))) | ||
| 322 : | (defun validate_2 (sorted outs) | ||
| 323 : | (do ((sorted (rm-invalid sorted)) | ||
| 324 : | (l (cdr sorted) (cdr l)) | ||
| 325 : | (start (second (car sorted))) | ||
| 326 : | (last (second (car sorted)))) | ||
| 327 : | ((atom l) | ||
| 328 : | (and (equal -1 start)(equal -1 last) | ||
| 329 : | (rplaca (cdr (car sorted)) 0))) | ||
| 330 : | (cond ((and (equal last -1) (equal -1 (second (car l)))) | ||
| 331 : | (rplaca (cdr (car l)) 0)) | ||
| 332 : | (t | ||
| 333 : | (setq last (second (car l)))))) | ||
| 334 : | (lets ((sorted1 (reverse (rm-invalid sorted)))) | ||
| 335 : | (do ((l (cdr sorted1) (cdr l)) | ||
| 336 : | (start (second (car sorted1))) | ||
| 337 : | (last (second (car sorted1)))) | ||
| 338 : | ((atom l) | ||
| 339 : | (and (equal 1 start)(equal 1 last) | ||
| 340 : | (set_alt (car sorted) 0 outs))) | ||
| 341 : | (cond ((and (equal last 1) (equal 1 (second (car l)))) | ||
| 342 : | (set_alt (car l) 0 outs)) | ||
| 343 : | (t | ||
| 344 : | (setq last (second (car l)))))))) | ||
| 345 : | (defun validate_3 (sorted ass) | ||
| 346 : | (do ((l sorted (cdr l)) | ||
| 347 : | (cross)(i)(flag)(tmp)) | ||
| 348 : | ((atom l) | ||
| 349 : | (do ((ll sorted (cdr ll))(i)(flag)(cross)) | ||
| 350 : | ((or (null tmp) (atom ll))) | ||
| 351 : | (setq cross (car ll)) | ||
| 352 : | (setq i (cdr (assq (fourth cross) ass)) flag (second cross)) | ||
| 353 : | (cond ((and (equal flag 1)(memq i tmp)) | ||
| 354 : | (setq tmp (remq i tmp))) | ||
| 355 : | ((and (equal flag -1)) | ||
| 356 : | (push i tmp) | ||
| 357 : | (rplaca (cdr cross) 0))))) | ||
| 358 : | (setq cross (car l)) | ||
| 359 : | (setq i (cdr (assq (fourth cross) ass)) flag (second cross)) | ||
| 360 : | (cond (tmp | ||
| 361 : | (cond ((and (equal flag 1)(memq i tmp)) | ||
| 362 : | (setq tmp (remq i tmp))) | ||
| 363 : | ((and (equal flag -1)) | ||
| 364 : | (push i tmp) | ||
| 365 : | (rplaca (cdr cross) 0)))) | ||
| 366 : | ((equal flag -1) | ||
| 367 : | (push i tmp))))) | ||
| 368 : | |||
| 369 : | (defun validate_out (out outs ass) | ||
| 370 : | (lets ((out (rm-invalid out)) | ||
| 371 : | (i_sort)) | ||
| 372 : | (do ((l out (cdr l))(i)(i_assq)) | ||
| 373 : | ((atom l)) | ||
| 374 : | (setq i (fourth (car l))) | ||
| 375 : | (cond ((setq i_assq (assq i i_sort)) | ||
| 376 : | (rplacd i_assq `(,(car l).,(cdr i_assq)))) | ||
| 377 : | (t | ||
| 378 : | (push `(,i ,(car l)) i_sort)))) | ||
| 379 : | (mapcar i_sort #'(lambda (x) (validate_1 (cdr x)))) | ||
| 380 : | (setq out (rm-invalid out)) | ||
| 381 : | ; (and out (validate_2 out outs)) | ||
| 382 : | ; (print "start-of-validate") | ||
| 383 : | ; (prind `(goyo ,out)) | ||
| 384 : | (and out (validate_3 out ass)) | ||
| 385 : | ; (and out (validate_2 out outs)) | ||
| 386 : | ; (prind `(soko ,out)) | ||
| 387 : | ; (print "end-of-validate") | ||
| 388 : | )) | ||
| 389 : | |||
| 390 : | |||
| 391 : | (defun validate_flatten (outs ass) | ||
| 392 : | (do ((l outs (cdr l))(ret)) | ||
| 393 : | ((atom l) | ||
| 394 : | ; (prind outs) | ||
| 395 : | outs) | ||
| 396 : | (do ((ll (car l)(cdr ll))(ret1)) | ||
| 397 : | ((atom ll) | ||
| 398 : | (validate_out ret1 outs ass) | ||
| 399 : | ; (prind ret1) | ||
| 400 : | ) | ||
| 401 : | (setq ret1 (append ret1 (cdar ll)))))) | ||
| 402 : | |||
| 403 : | (defun search_first (out) | ||
| 404 : | (do ((l out (cdr l))(ret)) | ||
| 405 : | ((or ret (atom l))ret) | ||
| 406 : | (do ((ll (cdar l)(cdr ll))) | ||
| 407 : | ((atom ll)) | ||
| 408 : | (and (memq (second (car ll)) '(-1 -2))(exit (setq ret l)))))) | ||
| 409 : | (defun traceall (outs) | ||
| 410 : | (do ((l outs (cdr l))(ret)(start)) | ||
| 411 : | ((atom l)ret) | ||
| 412 : | (setq start (search_first (car l))) | ||
| 413 : | (cond | ||
| 414 : | ((null start) | ||
| 415 : | (do ((ll (car l)(cdr ll))(ret1)) | ||
| 416 : | ((atom ll)(push (nreverse ret1) ret)) | ||
| 417 : | (push (caar ll) ret1))) | ||
| 418 : | (t | ||
| 419 : | (do ((ll (car l)(cdr ll))) | ||
| 420 : | ((atom ll)) | ||
| 421 : | (do ((lll (cdar ll)(cdr lll))) | ||
| 422 : | ((atom lll)) | ||
| 423 : | (and(equal -1 (cadar lll)) | ||
| 424 : | (rplaca (cdar lll) -2) | ||
| 425 : | ; (print (car lll)) | ||
| 426 : | (push (tracestart outs (third (car lll))(fourth (car lll)) | ||
| 427 : | (fifth (car lll))) | ||
| 428 : | ret)))))))) | ||
| 429 : | |||
| 430 : | (defun bezierdp (b0 b1 b2 b3 tval) | ||
| 431 : | (lets ((t1 tval)(t2 (times t1 t1))(t3 (times t2 t1)) | ||
| 432 : | (db0 (times2 3.0 (diff2 b1 b0))) | ||
| 433 : | (db3 (times2 3.0 (diff2 b3 b2)))) | ||
| 434 : | ; (prind `(bezierp ,b0 ,b1 ,b2 ,b3 ,tval | ||
| 435 : | ; ,(plus2 | ||
| 436 : | ; (times2 t2 (plus2 (times2 6.0 (diff2 b0 b3)) | ||
| 437 : | ; (times2 3.0 (plus2 db0 db3)))) | ||
| 438 : | ; (times2 t1 (diff2 (times2 6.0 (diff2 b3 b0)) | ||
| 439 : | ; (plus2 (times2 4.0 db0) (times2 2.0 db3)))) | ||
| 440 : | ; db0))) | ||
| 441 : | (plus2 | ||
| 442 : | (times2 t2 (plus2 (times2 6.0 (diff2 b0 b3)) | ||
| 443 : | (times2 3.0 (plus2 db0 db3)))) | ||
| 444 : | (times2 t1 (diff2 (times2 6.0 (diff2 b3 b0)) | ||
| 445 : | (plus2 (times2 4.0 db0) (times2 2.0 db3)))) | ||
| 446 : | db0))) | ||
| 447 : | (defun tracestart (outs point i j) | ||
| 448 : | ; (prind `(tracestart ,point ,i ,j)) | ||
| 449 : | (lets ((l (nth j (nth i outs))) | ||
| 450 : | (type (caar l)) | ||
| 451 : | (crosses (cdr l))(cross)) | ||
| 452 : | (do ((ll crosses (cdr ll))) | ||
| 453 : | ((atom ll)) | ||
| 454 : | (and (equal point (third (car ll)))(exit (setq cross ll)))) | ||
| 455 : | (selectq type | ||
| 456 : | (line | ||
| 457 : | (cond ((cdr cross) | ||
| 458 : | (setq point1 (third (cadr cross))) | ||
| 459 : | ; (prind `(point1 ,point1)) | ||
| 460 : | `((line ,point ,point1) | ||
| 461 : | .,(and (equal (cadr (cadr cross)) -1) | ||
| 462 : | (rplaca (cdr (cadr cross)) -2) | ||
| 463 : | (tracestart outs point1 | ||
| 464 : | (fourth (cadr cross)) | ||
| 465 : | (fifth (cadr cross)))))) | ||
| 466 : | (t | ||
| 467 : | `((line ,point ,(third (car l))) | ||
| 468 : | .,(tracecont outs (or (cdr (nthcdr j (nth i outs))) | ||
| 469 : | (nth i outs)) | ||
| 470 : | i))))) | ||
| 471 : | (bezier | ||
| 472 : | (lets ((p0 (second (car l)))(p1 (third (car l))) | ||
| 473 : | (p2 (fourth (car l)))(p3 (fifth (car l)))) | ||
| 474 : | (cond | ||
| 475 : | ((cdr cross) | ||
| 476 : | (setq t0 (caar cross) t3 (caadr cross)) | ||
| 477 : | (setq c (quotient (difference t3 t0) 3.0)) | ||
| 478 : | ; (prind c) | ||
| 479 : | (setq point3 (caddr (cadr cross))) | ||
| 480 : | ; (prind `(point3 ,point3)) | ||
| 481 : | `((bezier ,point | ||
| 482 : | ,(plus2 point | ||
| 483 : | (times2 c (bezierdp p0 p1 p2 p3 t0))) | ||
| 484 : | ,(diff2 point3 (times2 c (bezierdp p0 p1 p2 p3 t3))) | ||
| 485 : | ,point3) | ||
| 486 : | .,(and (equal (cadr (cadr cross)) -1) | ||
| 487 : | (rplaca (cdr (cadr cross)) -2) | ||
| 488 : | (tracestart outs point3 | ||
| 489 : | (fourth (cadr cross)) | ||
| 490 : | (fifth (cadr cross)))))) | ||
| 491 : | (t | ||
| 492 : | (setq t0 (caar cross)) | ||
| 493 : | (setq c (quotient (difference 1.0 t0) 3.0)) | ||
| 494 : | ; (prind `(2 ,c)) | ||
| 495 : | ; (setq point3 (caddr (car cross))) | ||
| 496 : | ; (prind (plus2 point | ||
| 497 : | ; (times2 c (bezierdp p0 p1 p2 p3 t0)))) | ||
| 498 : | ; (prind (times2 c (bezierdp p0 p1 p2 p3 1.0))) | ||
| 499 : | `((bezier ,point | ||
| 500 : | ,(plus2 point | ||
| 501 : | (times2 c (bezierdp p0 p1 p2 p3 t0))) | ||
| 502 : | ,(diff2 p3 (times2 c (bezierdp p0 p1 p2 p3 1.0))) | ||
| 503 : | ,p3) | ||
| 504 : | .,(tracecont outs (or (cdr (nthcdr j (nth i outs)))(nth i outs)) | ||
| 505 : | i))))))))) | ||
| 506 : | |||
| 507 : | (defun tracecont (outs out i) | ||
| 508 : | ; (prind `(tracecont ,(car out) ,i)) | ||
| 509 : | (selectq (caaar out) | ||
| 510 : | (line | ||
| 511 : | (do ((l (cdar out)(cdr l))) | ||
| 512 : | ((atom l) | ||
| 513 : | `(,(caar out) | ||
| 514 : | .,(tracecont outs (or (cdr out)(nth i outs)) i))) | ||
| 515 : | (and (memq (second (car l)) '(-1 -2)) | ||
| 516 : | (lets ((point0 (cadr (caar out))) | ||
| 517 : | (cross (car l)) | ||
| 518 : | (flag (second cross)) | ||
| 519 : | (point (third cross)) | ||
| 520 : | (i1 (fourth cross)) | ||
| 521 : | (j1 (fifth cross))) | ||
| 522 : | (exit | ||
| 523 : | `((line ,point0 ,point) | ||
| 524 : | .,(and (equal flag -1)(rplaca (cdr cross) -2) | ||
| 525 : | (tracestart outs point i1 j1)))))))) | ||
| 526 : | (bezier | ||
| 527 : | (do ((l (cdar out)(cdr l))) | ||
| 528 : | ((atom l) | ||
| 529 : | `(,(caar out) | ||
| 530 : | .,(tracecont outs (or (cdr out)(nth i outs)) i))) | ||
| 531 : | (and (memq (second (car l)) '(-1 -2)) | ||
| 532 : | (lets ((p0 (second (caar out))) | ||
| 533 : | (p1 (third (caar out))) | ||
| 534 : | (p2 (fourth (caar out))) | ||
| 535 : | (p3 (fifth (caar out))) | ||
| 536 : | (cross (car l)) | ||
| 537 : | (t0 (first cross)) | ||
| 538 : | (c (quotient t0 3.0)) | ||
| 539 : | (flag (second cross)) | ||
| 540 : | (point (third cross)) | ||
| 541 : | (i1 (fourth cross)) | ||
| 542 : | (j1 (fifth cross))) | ||
| 543 : | ; (prind `(1 ,c)) | ||
| 544 : | (exit | ||
| 545 : | `((bezier ,p0 | ||
| 546 : | ,(plus2 p0 | ||
| 547 : | (times2 c (bezierdp p0 p1 p2 p3 0.0))) | ||
| 548 : | ,(diff2 point (times2 c (bezierdp p0 p1 p2 p3 t0))) | ||
| 549 : | ,point) | ||
| 550 : | .,(and (eq flag -1)(rplaca (cdr cross) -2) | ||
| 551 : | (tracestart outs point i1 j1)))))))))) | ||
| 552 : | |||
| 553 : | |||
| 554 : | |||
| 555 : | ; if appended return the appended outline | ||
| 556 : | ; else return nil | ||
| 557 : | (defun nconc_out (out1 out2) | ||
| 558 : | (lets ((top1 (car out1))(tmp)(l out1)) | ||
| 559 : | (loop | ||
| 560 : | ; (prind (car l)) | ||
| 561 : | (match l | ||
| 562 : | ((('angle . p0)('angle . p1) . rest) | ||
| 563 : | (setq tmp (nconc_out1 p0 p1 out2)) | ||
| 564 : | (and tmp (progn (rplacd l (nconc tmp (cdr l))) | ||
| 565 : | (exit out1))) | ||
| 566 : | (setq l (cdr l))) | ||
| 567 : | ((('angle . p0)) | ||
| 568 : | (setq tmp (nconc_out1 p0 (cdr top1) out2)) | ||
| 569 : | (and tmp (progn (rplacd l tmp) | ||
| 570 : | (exit out1))) | ||
| 571 : | (exit nil)) | ||
| 572 : | ((('angle . p0)('bezier . p1)('bezier . p2) . rest) | ||
| 573 : | (setq l rest)) | ||
| 574 : | (nil (exit nil)))))) | ||
| 575 : | |||
| 576 : | (defun nconc_out1 (p0 p1 out2) | ||
| 577 : | ; (prind `(,p0 ,p1 ,out2)) | ||
| 578 : | (do ((l out2)(top (car out2))(lastl)) | ||
| 579 : | ((atom l) nil) | ||
| 580 : | (match l | ||
| 581 : | ((('angle . pp0)('angle . pp1) . rest) | ||
| 582 : | (and (equal pp0 p1)(equal pp1 p0) | ||
| 583 : | (progn | ||
| 584 : | (cond (lastl (rplacd lastl nil) | ||
| 585 : | (exit (nconc rest out2))) | ||
| 586 : | (t (exit rest))))) | ||
| 587 : | ; (and (equal pp0 p0)(equal pp1 p1) | ||
| 588 : | ; (progn | ||
| 589 : | ; (cond (lastl (rplacd lastl nil) | ||
| 590 : | ; (exit (nconc (nreverse out2)(nreverse rest)))) | ||
| 591 : | ; (t (exit (nreverse rest)))))) | ||
| 592 : | (setq lastl l) | ||
| 593 : | (setq l (cdr l))) | ||
| 594 : | ((('angle . pp0)) | ||
| 595 : | (and (equal pp0 p1)(equal (cdr top) p0) | ||
| 596 : | (progn | ||
| 597 : | (rplacd lastl nil) | ||
| 598 : | (exit (cdr out2)) | ||
| 599 : | ; (exit out2) | ||
| 600 : | )) | ||
| 601 : | ; (and (equal pp0 p0)(equal (cdr top) p1) | ||
| 602 : | ; (progn | ||
| 603 : | ; (rplacd lastl nil) | ||
| 604 : | ; (exit (nreverse (cdr out2))))) | ||
| 605 : | (exit nil)) | ||
| 606 : | ((('angle . pp0)('bezier . pp1)('bezier . pp2) . rest) | ||
| 607 : | (setq lastl (cddr l)) | ||
| 608 : | (setq l rest)) | ||
| 609 : | (nil (exit nil))))) | ||
| 610 : | ; | ||
| 611 : | (defun nconc_self (out1) | ||
| 612 : | (lets ((out (reverse (cons (car out1)(reverse out1))))) | ||
| 613 : | (do ((l out (cdr l))(ret)) | ||
| 614 : | ((or ret (atom l)(atom (cdr l))) | ||
| 615 : | (or ret (ncons out1))) | ||
| 616 : | (do ((ll (cdr l)(cdr ll))) | ||
| 617 : | ((or (atom l)(atom (cdr ll)))) | ||
| 618 : | (and (equal (car l)(cadr ll)) | ||
| 619 : | ; (print `(,(car l) ,(cadr ll) ,(cadr l),(car ll))) | ||
| 620 : | (equal (cadr l)(car ll)) | ||
| 621 : | (lets ((tmp (cdr l))) | ||
| 622 : | (rplacd l (cddr ll)) | ||
| 623 : | (rplacd ll nil) | ||
| 624 : | ; (prind (list out tmp)) | ||
| 625 : | (exit (setq ret (nconc (nconc_self out) | ||
| 626 : | (nconc_self tmp)))))))))) | ||
| 627 : | |||
| 628 : | ; | ||
| 629 : | (defun self_bezier (a0 a1 a2 a3 (mins 0.0)(twidth 1.0)) | ||
| 630 : | (and (line2line a0 a1 a3 a2) | ||
| 631 : | (lets ((a4 (times2 0.5 (plus2 a0 a1))) | ||
| 632 : | (a5 (times2 0.25 (plus2 a0 (times2 2.0 a1) a2))) | ||
| 633 : | (a6 (times2 0.125 | ||
| 634 : | (plus2 a0 (times2 3.0 a1)(times2 3.0 a2) a3))) | ||
| 635 : | (a7 (times2 0.25 (plus2 a1 (times2 2.0 a2) a3))) | ||
| 636 : | (a8 (times2 0.5 (plus2 a2 a3))) | ||
| 637 : | (twidth1 (times twidth 0.5)) | ||
| 638 : | (mint (plus mins twidth1)) | ||
| 639 : | (cross | ||
| 640 : | (some (bez2bez a0 a4 a5 a6 a6 a5 a8 a3 mins mint twidth1) | ||
| 641 : | #'(lambda (x) | ||
| 642 : | (greaterp (abs (cddr x)) 0.001))))) | ||
| 643 : | (or (and cross (car cross)) | ||
| 644 : | (self_bezier a0 a4 a5 a6 mins twidth1) | ||
| 645 : | (self_bezier a6 a7 a8 a3 mint twidth1))))) | ||
| 646 : | ; | ||
| 647 : | (defun rm_self_bezier (flatten) | ||
| 648 : | (do ((l flatten (cdr l))(ret)) | ||
| 649 : | ((atom l)(nreverse ret)) | ||
| 650 : | (match (caar l) | ||
| 651 : | (('line p0 p1) (push (car l) ret)) | ||
| 652 : | (('bezier p0 p1 p2 p3) | ||
| 653 : | (lets ((res (self_bezier p0 p1 p2 p3))) | ||
| 654 : | (cond (res | ||
| 655 : | ; (prind `(res ,res)) | ||
| 656 : | (lets ((crossp (car res)) | ||
| 657 : | (sval (cadr res))(tval (cddr res)) | ||
| 658 : | (twidth (difference 1.0 tval)) | ||
| 659 : | (dp0 (times2 sval (diff2 p1 p0))) | ||
| 660 : | (dp1 (times2 (quotient sval 3.0) | ||
| 661 : | (bezierdp p0 p1 p2 p3 sval))) | ||
| 662 : | (dp2 (times2 (quotient twidth 3.0) | ||
| 663 : | (bezierdp p0 p1 p2 p3 tval))) | ||
| 664 : | (dp3 (times2 twidth (diff2 p3 p2)))) | ||
| 665 : | (push `((bezier ,p0 | ||
| 666 : | ,(plus2 p0 dp0) | ||
| 667 : | ,(diff2 crossp dp1) | ||
| 668 : | ,crossp)) ret) | ||
| 669 : | (push `((bezier ,crossp | ||
| 670 : | ,(plus2 crossp dp2) | ||
| 671 : | ,(diff2 p3 dp3) | ||
| 672 : | ,p3)) ret))) | ||
| 673 : | (t (push (car l) ret)))))))) | ||
| 674 : | ; cannot compile with iwasaki ban compiler | ||
| 675 : | (comment | ||
| 676 : | (defun rm_self_bezier (flatten) | ||
| 677 : | (do ((l flatten (cdr l))(ret)) | ||
| 678 : | ((atom l)(nreverse ret)) | ||
| 679 : | (selectq (caaar l) | ||
| 680 : | (line (push (car l) ret)) | ||
| 681 : | (bezier | ||
| 682 : | (lets ((p0 (second (caar l))) | ||
| 683 : | (p1 (third (caar l))) | ||
| 684 : | (p2 (fourth (caar l))) | ||
| 685 : | (p3 (fifth (caar l))) | ||
| 686 : | (res (self_bezier p0 p1 p2 p3))) | ||
| 687 : | (cond (res | ||
| 688 : | ; (prind `(res ,res)) | ||
| 689 : | (lets ((crossp (car res)) | ||
| 690 : | (sval (cadr res))(tval (cddr res)) | ||
| 691 : | (twidth (difference 1.0 tval)) | ||
| 692 : | (dp0 (times2 sval (diff2 p1 p0))) | ||
| 693 : | (dp1 (times2 (quotient sval 3.0) | ||
| 694 : | (bezierdp p0 p1 p2 p3 sval))) | ||
| 695 : | (dp2 (times2 (quotient twidth 3.0) | ||
| 696 : | (bezierdp p0 p1 p2 p3 tval))) | ||
| 697 : | (dp3 (times2 twidth (diff2 p3 p2)))) | ||
| 698 : | (push `((bezier ,p0 | ||
| 699 : | ,(plus2 p0 dp0) | ||
| 700 : | ,(diff2 crossp dp1) | ||
| 701 : | ,crossp)) ret) | ||
| 702 : | (push `((bezier ,crossp | ||
| 703 : | ,(plus2 crossp dp2) | ||
| 704 : | ,(diff2 p3 dp3) | ||
| 705 : | ,p3)) ret))) | ||
| 706 : | (t (push (car l) ret)))))))) | ||
| 707 : | ) | ||
| 708 : | ; | ||
| 709 : | (comment | ||
| 710 : | (defun self_cross (e i j) | ||
| 711 : | (selectq (caar e) | ||
| 712 : | (line) | ||
| 713 : | (bezier | ||
| 714 : | (lets ((p0 (second (car l))) | ||
| 715 : | (p1 (third (car l))) | ||
| 716 : | (p2 (fourth (car l))) | ||
| 717 : | (p3 (fifth (car l))) | ||
| 718 : | (res (self_bezier p0 p1 p2 p3)) | ||
| 719 : | (cross (car res))(sval (cadr res))(tval (cddr res))) | ||
| 720 : | (rplacd e `((,sval ,flag ,cross ,i ,j) | ||
| 721 : | (,tval ,(- flag) ,cross ,i ,j) | ||
| 722 : | .,(cdr e)))))))) | ||
| 723 : | ; | ||
| 724 : | (defun compute_self_cross (flatten) | ||
| 725 : | (do ((l2 flatten (cdr l2))(i1 0)(j1 0 (1+ j1))) | ||
| 726 : | ((atom l2)flatten) | ||
| 727 : | ; (self_cross (car l2) i1 j1) | ||
| 728 : | (do ((l4 (cdr l2)(cdr l4))(j2 (1+ j1)(1+ j2))) | ||
| 729 : | ((or (atom l4)(and (zerop j1)(atom (cdr l4))))) | ||
| 730 : | (compute_cross (car l2)(car l4) i1 j1 i1 j2)))) | ||
| 731 : | ; | ||
| 732 : | (defun loop_len (flatten) | ||
| 733 : | (do ((sum 0) | ||
| 734 : | (l flatten (cdr l))) | ||
| 735 : | ((atom l) sum) | ||
| 736 : | (match (caar l) | ||
| 737 : | (('line p0 p1)(setq sum (plus sum (metric2 p0 p1)))) | ||
| 738 : | (('bezier p0 p1 p2 p3)(setq sum (plus sum (metric2 p0 p3))))))) | ||
| 739 : | ; | ||
| 740 : | (defun linepart (part from to) | ||
| 741 : | (match part | ||
| 742 : | (('line p0 p1) | ||
| 743 : | (lets ((fromp (cond ((eq from 0)p0) | ||
| 744 : | (t (third from)))) | ||
| 745 : | (top (cond ((eq to 1)p1) | ||
| 746 : | (t (third to))))) | ||
| 747 : | `((line ,fromp ,top)))) | ||
| 748 : | (('bezier p0 p1 p2 p3) | ||
| 749 : | (cond ((and (eq from 0)(eq to 1)) | ||
| 750 : | `(,part)) | ||
| 751 : | (t | ||
| 752 : | (lets ((fromp (cond ((eq from 0)p0) | ||
| 753 : | (t (third from)))) | ||
| 754 : | (top (cond ((eq to 1)p3) | ||
| 755 : | (t (third to)))) | ||
| 756 : | (froms (cond ((eq from 0)0) | ||
| 757 : | (t (first from)))) | ||
| 758 : | (tos (cond ((eq to 1)1) | ||
| 759 : | (t (first to)))) | ||
| 760 : | (twidth (quotient (difference tos froms) 3.0)) | ||
| 761 : | (dp0 (times2 twidth (bezierdp p0 p1 p2 p3 froms))) | ||
| 762 : | (dp1 (times2 twidth (bezierdp p0 p1 p2 p3 tos)))) | ||
| 763 : | `((bezier ,fromp ,(plus2 fromp dp0),(diff2 top dp1),top)))))))) | ||
| 764 : | |||
| 765 : | ; | ||
| 766 : | (defun rm_self_loop (outline) | ||
| 767 : | (lets ((flatten (compute_self_cross | ||
| 768 : | (rm_self_bezier (flatten_outline outline)))) | ||
| 769 : | (sorted (mapcar flatten | ||
| 770 : | #'(lambda (x) | ||
| 771 : | `(,(car x) | ||
| 772 : | .,(sort (cdr x) | ||
| 773 : | #'(lambda (y z) (lessp (car y)(car z)))))))) | ||
| 774 : | (loop_len (loop_len sorted))) | ||
| 775 : | ; (prind sorted) | ||
| 776 : | (do ((l sorted (cdr l))(alllen 0)(tmplen)) | ||
| 777 : | ((atom l)) | ||
| 778 : | (match (caar l) | ||
| 779 : | (('line p0 p1)(setq tmplen (metric2 p0 p1))) | ||
| 780 : | (('bezier p0 p1 p2 p3)(setq tmplen (metric2 p0 p3)))) | ||
| 781 : | (do ((ll (cdar l)(cdr ll))) | ||
| 782 : | ((atom ll)) | ||
| 783 : | (or (memq (second (car ll)) '(-2 -3 2 3)) | ||
| 784 : | (lets ((p0 (third (car ll))) | ||
| 785 : | (tlen (plus alllen (times tmplen (first (car ll))))) | ||
| 786 : | (p1)(len (times -1 tmplen (first (car ll))))) | ||
| 787 : | (setq | ||
| 788 : | pos | ||
| 789 : | (catch 'found | ||
| 790 : | (progn | ||
| 791 : | (do ((l4 (cdr ll)(cdr l4))) | ||
| 792 : | ((atom l4)) | ||
| 793 : | (and (equal (setq p1 (third (car l4))) p0) | ||
| 794 : | (setq len (plus len (times tmplen (first (car l4))))) | ||
| 795 : | (throw 'found (car l4)))) | ||
| 796 : | (setq len (plus len tmplen)) | ||
| 797 : | (do ((l3 (cdr l)(cdr l3))(tmplen1)) | ||
| 798 : | ((atom l3)) | ||
| 799 : | (match (caar l3) | ||
| 800 : | (('line p0 p1)(setq tmplen1 (metric2 p0 p1))) | ||
| 801 : | (('bezier p0 p1 p2 p3)(setq tmplen1 (metric2 p0 p3)))) | ||
| 802 : | (do ((l4 (cdar l3)(cdr l4))) | ||
| 803 : | ((atom l4)) | ||
| 804 : | (and (equal (setq p1 (third (car l4))) p0) | ||
| 805 : | (setq len | ||
| 806 : | (plus len (times tmplen1 (first (car l4))))) | ||
| 807 : | (throw 'found (car l4)))) | ||
| 808 : | (setq len (plus len tmplen1)))))) | ||
| 809 : | (cond ((lessp len 40.0) | ||
| 810 : | (rplaca (cdr (car ll)) -3) | ||
| 811 : | (rplaca (cdr pos) 3)) | ||
| 812 : | (t | ||
| 813 : | (rplaca (cdr (car ll)) -2) | ||
| 814 : | (rplaca (cdr pos) 2))) | ||
| 815 : | ; (prind `(len ,len loop_len ,loop_len)) | ||
| 816 : | )))) | ||
| 817 : | ; (prind sorted) | ||
| 818 : | (do ((l sorted (cdr l))(ret)(wait)) | ||
| 819 : | ((atom l) | ||
| 820 : | ; (prind (reverse ret)) | ||
| 821 : | (setq unflatten (unflatten_outline (mapcar (nreverse ret) #'car))) | ||
| 822 : | (nreverse (cdr (nreverse unflatten)))) | ||
| 823 : | (do ((ll (cdar l)(cdr ll))(start 0)) | ||
| 824 : | ((atom ll) | ||
| 825 : | (or wait | ||
| 826 : | (push (linepart (caar l) start 1) ret))) | ||
| 827 : | (cond ((member (third (car ll)) wait) | ||
| 828 : | (setq wait (remq (third (car ll)) wait)) | ||
| 829 : | (or wait (setq start (car ll)))) | ||
| 830 : | ((eq (second (car ll)) -3) | ||
| 831 : | (or wait | ||
| 832 : | (push (linepart (caar l) start (car ll)) ret)) | ||
| 833 : | (push (third (car ll)) wait))))))) | ||
| 834 : | |||
| 835 : | ; (and (eq (second (car ll) -3)) | ||
| 836 : | ; (push | ||
| 837 : | ; (setq unflatten (unflatten_outline (mapcar flatten #'car))) | ||
| 838 : | ; (and (some flatten #'cdr) | ||
| 839 : | ; (prind sorted)) | ||
| 840 : | ; (nreverse (cdr (nreverse unflatten))))) | ||
| 841 : | |||
| 842 : | ; | ||
| 843 : | (defun rm_self_loop_all (outlines) | ||
| 844 : | (mapcar outlines #'rm_self_loop)) | ||
| 845 : | ; | ||
| 846 : | (defun correct_winding (outline) | ||
| 847 : | (do ((l (rm_self_loop_all outline)(cdr l))(ret)) | ||
| 848 : | ((atom l)(nreverse ret)) | ||
| 849 : | (cond ((minusp (checkwinding (car l))) | ||
| 850 : | (cond ((eq 'bezier (caar (last (car l)))) | ||
| 851 : | (push (cons (caar l)(reverse (cdar l))) ret)) | ||
| 852 : | (t | ||
| 853 : | (push (reverse (car l)) ret)))) | ||
| 854 : | (t (push (car l) ret))))) | ||
| 855 : | ; | ||
| 856 : | (defun nconc_outs (outline) | ||
| 857 : | (do ((l outline);(l(correct_winding outline)) | ||
| 858 : | (ret)(tmp)) | ||
| 859 : | ((atom l)(nreverse ret)) | ||
| 860 : | (setq tmp (car l)) | ||
| 861 : | (do ((ll (cdr l)(cdr ll))(rest)) | ||
| 862 : | ((atom ll)(push tmp ret)(setq l (nreverse rest))) | ||
| 863 : | ; (prind ll) | ||
| 864 : | (cond ((nconc_out tmp (car ll)) | ||
| 865 : | (setq ll (nconc ll rest)) | ||
| 866 : | (setq rest nil) | ||
| 867 : | ; (print "joint") | ||
| 868 : | ) | ||
| 869 : | (t | ||
| 870 : | (push (car ll) rest)))))) | ||
| 871 : | |||
| 872 : | (defun checkwinding (out) | ||
| 873 : | (do ((l (cdr (append out (ncons (car out)))) (cdr l)) | ||
| 874 : | (lastdir (diff2 (cdr (cadr out))(cdr (car out)))) | ||
| 875 : | (thetasum 0.0)) | ||
| 876 : | ((atom (cdr l)) | ||
| 877 : | (setq thisdir (diff2 (cdr (cadr out))(cdr (car out)))) | ||
| 878 : | (setq thetasum (plus thetasum (theta thisdir lastdir))) | ||
| 879 : | thetasum) | ||
| 880 : | (and (not (equal(cdr (cadr l))(cdr (car l)))) | ||
| 881 : | (setq thisdir (diff2 (cdr (cadr l))(cdr (car l)))) | ||
| 882 : | ; (print thistheta) | ||
| 883 : | (setq thetasum (plus thetasum (theta thisdir lastdir))) | ||
| 884 : | ; (print thetasum) | ||
| 885 : | (setq lastdir thisdir)))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |