Annotation of /lisp/skeledit.lAnnotation of /lisp/skeledit.l
Parent Directory
| 
Revision Log
Revision: 1.2 - (view) (download)
| 1 : | ktanaka | 1.1 | (cond ((definedp 'init_window)) |
| 2 : | (t (code-load "/home/misa/kanji/lib/window.o" "-lX11"))) | ||
| 3 : | ;(exfile (string-append system_lib_path "lisplib/readmacro.l")) | ||
| 4 : | ;(cond ((definedp 'init_window)) | ||
| 5 : | ; (t (exfile "/home/misa/kanji/lib/new/window.l"))) | ||
| 6 : | ;(defun readsharp () | ||
| 7 : | ; (let ((r (read))) | ||
| 8 : | ; (cond ((listp r)(vector (length r) r)) | ||
| 9 : | ; ((symbolp r)(character r)) | ||
| 10 : | ; (t r)))) | ||
| 11 : | ;(readmacro 35 'readsharp) | ||
| 12 : | |||
| 13 : | (declare (marksize marksize1 linknumber linkpoints partlist nolinkpoints) special) | ||
| 14 : | (declare (linkthresh) special) | ||
| 15 : | (setq marksize 3 marksize1 3) | ||
| 16 : | (defun sankaku (x y) | ||
| 17 : | (drawline x (- y marksize1)(+ x marksize)(+ y marksize1)) | ||
| 18 : | (drawline x (- y marksize1)(- x marksize)(+ y marksize1)) | ||
| 19 : | (drawline (+ x marksize)(+ y marksize1)(- x marksize)(+ y marksize1))) | ||
| 20 : | (defun shikaku (x y) | ||
| 21 : | (drawline (- x marksize)(- y marksize)(+ x marksize)(- y marksize)) | ||
| 22 : | (drawline (+ x marksize)(- y marksize)(+ x marksize)(+ y marksize)) | ||
| 23 : | (drawline (+ x marksize)(+ y marksize)(- x marksize)(+ y marksize)) | ||
| 24 : | (drawline (- x marksize)(+ y marksize)(- x marksize)(- y marksize))) | ||
| 25 : | |||
| 26 : | (defun hex2 (l) | ||
| 27 : | (string-append (string (sref "0123456789abcdef" (logand 15 (logshift l -4)))) | ||
| 28 : | (string (sref "0123456789abcdef" (logand 15 l))))) | ||
| 29 : | (defun setlinkpoint (x y) | ||
| 30 : | (push (list 'link linknumber x y) linkpoints) | ||
| 31 : | (setq linknumber (1+ linknumber))) | ||
| 32 : | |||
| 33 : | (defun metric (x0 y0 x y) | ||
| 34 : | (+(*(- x0 x)(- x0 x))(*(- y0 y)(- y0 y)))) | ||
| 35 : | |||
| 36 : | (defun bestlink (x y) | ||
| 37 : | (do ((min 1000000) | ||
| 38 : | (ret nil) | ||
| 39 : | (met nil) | ||
| 40 : | (l linkpoints (cdr l))) | ||
| 41 : | ((atom l)(cond (ret) | ||
| 42 : | (t (push (list 'link linknumber x y) linkpoints) | ||
| 43 : | (car linkpoints)))) | ||
| 44 : | (setq met (metric x y (caddr (car l))(cadddr (car l)))) | ||
| 45 : | (cond ((< met min) | ||
| 46 : | (setq ret (car l) min met))))) | ||
| 47 : | |||
| 48 : | (defun bestpoint (x y) | ||
| 49 : | (lets ((min 1000000) | ||
| 50 : | (ret nil) | ||
| 51 : | (met nil)) | ||
| 52 : | (do ((l linkpoints (cdr l))(met nil)) | ||
| 53 : | ((atom l)) | ||
| 54 : | (setq met (metric x y (caddr (car l))(cadddr (car l)))) | ||
| 55 : | (cond ((< met min) | ||
| 56 : | (setq ret (car l) min met)))) | ||
| 57 : | (do ((l partlist (cdr l))) | ||
| 58 : | ((atom l)) | ||
| 59 : | (do ((ll (cdar l)(cdr ll))) | ||
| 60 : | ((atom ll)) | ||
| 61 : | (setq met (metric x y (point-x (car ll))(point-y (car ll)))) | ||
| 62 : | (cond ((< met min) | ||
| 63 : | (setq ret (car ll) min met))))) | ||
| 64 : | (cond ((eq 'link (car ret))(cddr ret)) | ||
| 65 : | (ret)))) | ||
| 66 : | |||
| 67 : | |||
| 68 : | (defun movepoint (fromx fromy tox toy) | ||
| 69 : | (cond ;((and (null partlist)linkpoints)) | ||
| 70 : | (t | ||
| 71 : | (let ((point (bestpoint fromx fromy))) | ||
| 72 : | (rplaca point (+ (car point)(- tox fromx))) | ||
| 73 : | (rplaca (cdr point)(+ (cadr point)(- toy fromy))))))) | ||
| 74 : | (defun neighbor (point) | ||
| 75 : | (do ((l partlist (cdr l)) | ||
| 76 : | (ret nil)) | ||
| 77 : | ((atom l)ret) | ||
| 78 : | (do ((ll (cdar l)(cdr ll)) | ||
| 79 : | (last nil)) | ||
| 80 : | ((atom (cdr ll))) | ||
| 81 : | (cond ((eq point (cddar ll)) | ||
| 82 : | (push (cddadr ll) ret)) | ||
| 83 : | ((eq point (cddadr ll)) | ||
| 84 : | (push (cddar ll) ret)))))) | ||
| 85 : | (defun yokosoroe () | ||
| 86 : | (let ((event nil) | ||
| 87 : | (fromx nil) | ||
| 88 : | (fromy nil) | ||
| 89 : | (neighbor nil) | ||
| 90 : | (point nil)) | ||
| 91 : | (loop | ||
| 92 : | (setq event (checkevent)) | ||
| 93 : | (match event | ||
| 94 : | (('ButtonPress 'button1 x y) | ||
| 95 : | (setq fromx x fromy y) | ||
| 96 : | (exit)))) | ||
| 97 : | (setq point (bestpoint fromx fromy)) | ||
| 98 : | (setq neighbor (neighbor point)) | ||
| 99 : | (do ((l neighbor (cdr l)) | ||
| 100 : | (miny 20) | ||
| 101 : | (y fromy)) | ||
| 102 : | ((atom l)(rplaca (cdr point)y)) | ||
| 103 : | (cond ((> miny (abs (- fromy (cadr (car l))))) | ||
| 104 : | (setq miny (abs (- fromy (cadr (car l))))) | ||
| 105 : | (setq y (cadr (car l)))))))) | ||
| 106 : | (defun tatesoroe () | ||
| 107 : | (let ((event nil) | ||
| 108 : | (fromx nil) | ||
| 109 : | (fromy nil) | ||
| 110 : | (neighbor nil) | ||
| 111 : | (point nil)) | ||
| 112 : | (loop | ||
| 113 : | (setq event (checkevent)) | ||
| 114 : | (match event | ||
| 115 : | (('ButtonPress 'button1 x y) | ||
| 116 : | (setq fromx x fromy y) | ||
| 117 : | (exit)))) | ||
| 118 : | (setq point (bestpoint fromx fromy)) | ||
| 119 : | (setq neighbor (neighbor point)) | ||
| 120 : | (do ((l neighbor (cdr l)) | ||
| 121 : | (minx 20) | ||
| 122 : | (x fromx)) | ||
| 123 : | ((atom l)(rplaca point x)) | ||
| 124 : | (cond ((> minx (abs (- fromx (car (car l))))) | ||
| 125 : | (setq minx (abs (- fromx (car (car l))))) | ||
| 126 : | (setq x (car (car l)))))))) | ||
| 127 : | (defun set-link () | ||
| 128 : | (let ((event nil) | ||
| 129 : | (fromx nil) | ||
| 130 : | (fromy nil) | ||
| 131 : | (point nil)) | ||
| 132 : | (loop | ||
| 133 : | (setq event (checkevent)) | ||
| 134 : | (match event | ||
| 135 : | (('ButtonPress 'button1 x y) | ||
| 136 : | (setq fromx x fromy y) | ||
| 137 : | (exit)))) | ||
| 138 : | (setq point (bestpoint fromx fromy)) | ||
| 139 : | (cond ((memq point nolinkpoints) | ||
| 140 : | (setq nolinkpoints (remq point nolinkpoints))) | ||
| 141 : | (t (push point nolinkpoints))))) | ||
| 142 : | (defun delete () | ||
| 143 : | (let ((x nil)(y nil)(point nil)) | ||
| 144 : | (do ((event (checkevent)(checkevent))) | ||
| 145 : | ((eq (car event) 'ButtonPress) | ||
| 146 : | (setq x (caddr event) y (cadddr event)))) | ||
| 147 : | (setq point (bestpoint x y)))) | ||
| 148 : | |||
| 149 : | (defun concat () | ||
| 150 : | (let ((fromx nil)(fromy nil)(tox nil)(toy nil)(p0 nil)(p1 nil)) | ||
| 151 : | (do ((event (checkevent)(checkevent))) | ||
| 152 : | () | ||
| 153 : | (match event | ||
| 154 : | (('ButtonPress 'button1 x y) | ||
| 155 : | (setq fromx x fromy y)(exit)))) | ||
| 156 : | (do ((event (checkevent)(checkevent))) | ||
| 157 : | () | ||
| 158 : | (match event | ||
| 159 : | (('ButtonPress 'button1 x y) | ||
| 160 : | (setq tox x toy y)(exit)))) | ||
| 161 : | (setq p0 (bestlink fromx fromy) p1 (bestlink tox toy)))) | ||
| 162 : | |||
| 163 : | |||
| 164 : | |||
| 165 : | (defun newpart (sym) | ||
| 166 : | (push (ncons sym) partlist) | ||
| 167 : | (do ((i 0) | ||
| 168 : | (npoints (get sym 'npoint)) | ||
| 169 : | (points nil) | ||
| 170 : | (event (checkevent)(checkevent))) | ||
| 171 : | ((>= i npoints)) | ||
| 172 : | (match event | ||
| 173 : | (('KeyPress #r) | ||
| 174 : | (setq points nil) | ||
| 175 : | (setq partlist (cons nil (cdr partlist))) | ||
| 176 : | (setq i -1)) | ||
| 177 : | (('KeyPress #q) | ||
| 178 : | (setq partlist (cdr partlist)) | ||
| 179 : | (exit)) | ||
| 180 : | (('ButtonPress 'button1 x y) | ||
| 181 : | (push (bestlink x y)points) | ||
| 182 : | (setq i (1+ i)))) | ||
| 183 : | (setq partlist (cons (cons sym (reverse points)) (cdr partlist))) | ||
| 184 : | (disp))) | ||
| 185 : | |||
| 186 : | (defun point-x (l) | ||
| 187 : | (cond ((eq 'link (car l)) | ||
| 188 : | (caddr l)) | ||
| 189 : | (t (car l)))) | ||
| 190 : | |||
| 191 : | (defun point-y (l) | ||
| 192 : | (cond ((eq 'link (car l)) | ||
| 193 : | (cadddr l)) | ||
| 194 : | (t (cadr l)))) | ||
| 195 : | |||
| 196 : | (setq nolinkpoints nil) | ||
| 197 : | (defun disp () | ||
| 198 : | (copybg) | ||
| 199 : | (do ((l linkpoints (cdr l))) | ||
| 200 : | ((atom l)) | ||
| 201 : | (cond ((memq (cddr (car l)) nolinkpoints) | ||
| 202 : | (sankaku (caddr (car l))(cadddr (car l)))) | ||
| 203 : | (t | ||
| 204 : | (shikaku (caddr (car l))(cadddr (car l)))))) | ||
| 205 : | (do ((l partlist (cdr l))) | ||
| 206 : | ((atom l)) | ||
| 207 : | (do ((ll (cdar l)(cdr ll)) | ||
| 208 : | (npoints (get (caar l) 'npoint)) | ||
| 209 : | (i 0 (1+ i))) | ||
| 210 : | ((or (atom ll)(>= i npoints))) | ||
| 211 : | (cond ((neq (caar ll) 'link) | ||
| 212 : | (sankaku (caar ll)(cadar ll)))) | ||
| 213 : | (cond ((and (neq i (1- npoints))(cdr ll)) | ||
| 214 : | (drawline (point-x (car ll))(point-y (car ll)) | ||
| 215 : | (point-x (cadr ll))(point-y (cadr ll))))))) | ||
| 216 : | (redraw)) | ||
| 217 : | |||
| 218 : | (defun skeledit (symbol (code)(fonttype 'mincho)) | ||
| 219 : | (princ ";") | ||
| 220 : | (print (list symbol code)) | ||
| 221 : | (init_window 400 400) | ||
| 222 : | ; (cond (code | ||
| 223 : | ; (cond ((= 2 (string-length code)) | ||
| 224 : | ; (setq code (string-append (hex2 (logand 127 (sref code 0))) | ||
| 225 : | ; (hex2 (logand 127 (sref code 1))))))) | ||
| 226 : | ; (loadpbm (string-append "/home/misa/kanji/pbm/mincho/" code ".pbm")))) | ||
| 227 : | (cond (code | ||
| 228 : | (cond ((= 2 (string-length code)) | ||
| 229 : | (setq code (string-append (hex2 (logand 127 (sref code 0))) | ||
| 230 : | (hex2 (logand 127 (sref code 1))))))) | ||
| 231 : | (loadjis code))) | ||
| 232 : | (setq partlist nil) | ||
| 233 : | (setq linkpoints nil) | ||
| 234 : | (setq nolinkpoints nil) | ||
| 235 : | (setq linknumber 0) | ||
| 236 : | (do ((event (checkevent)(checkevent)) | ||
| 237 : | (curx nil)(cury nil)) | ||
| 238 : | () | ||
| 239 : | ; (print event) | ||
| 240 : | (match event | ||
| 241 : | (('KeyPress code) | ||
| 242 : | (selectq code | ||
| 243 : | (#\t | ||
| 244 : | (do ((event (checkevent)(checkevent))) | ||
| 245 : | () | ||
| 246 : | (match event | ||
| 247 : | (('KeyPress #\s)(newpart 'tasuki)(exit)) | ||
| 248 : | (('KeyPress #\l)(newpart 'tatehidari)(exit)) | ||
| 249 : | (('KeyPress #\h)(newpart 'tatehane)(exit))))) | ||
| 250 : | (#\k | ||
| 251 : | (do ((event (checkevent)(checkevent))) | ||
| 252 : | () | ||
| 253 : | (match event | ||
| 254 : | (('KeyPress #\z)(newpart 'kozato)(exit)) | ||
| 255 : | (('KeyPress #\k)(newpart 'kokoro)(exit)) | ||
| 256 : | (('KeyPress #\g)(newpart 'kagi)(exit))))) | ||
| 257 : | (#\p (newpart 'ten)) | ||
| 258 : | (#\b (newpart 'tate)) | ||
| 259 : | (#\y (newpart 'yoko)) | ||
| 260 : | (#\u (newpart 'migiue)) | ||
| 261 : | (#\l (newpart 'hidari)) | ||
| 262 : | (#\r (newpart 'migi)) | ||
| 263 : | (#\h (newpart 'tsukurihane)) | ||
| 264 : | (#\s (newpart 'sanzui)) | ||
| 265 : | (#\m (newpart 'magaritate)) | ||
| 266 : | (#\n (newpart 'shin-nyuu)) | ||
| 267 : | (#\c (concat)) | ||
| 268 : | (#\q (close_window) | ||
| 269 : | ktanaka | 1.2 | (prind `(setq ,symbol ',(convskeleton1 (convskeleton (add-link partlist)))))(exit)) |
| 270 : | ktanaka | 1.1 | ; (#\r (reset)) |
| 271 : | (#\i (setq partlist nil linkpoints nil) | ||
| 272 : | (setq nolinkpoints nil linknumber 0)) | ||
| 273 : | (#\f (set-link)) | ||
| 274 : | (#\x (yokosoroe)) | ||
| 275 : | (#\z (tatesoroe)) | ||
| 276 : | (#\d (showfill fonttype)) | ||
| 277 : | (#\d (delete)))) | ||
| 278 : | (('ButtonPress 'button1 x y) | ||
| 279 : | (setlinkpoint x y)) | ||
| 280 : | (('ButtonPress 'button2 x y) | ||
| 281 : | (setq curx x cury y)) | ||
| 282 : | (('ButtonRelease 'button2 x y) | ||
| 283 : | (movepoint curx cury x y))) | ||
| 284 : | (disp))) | ||
| 285 : | (defun showfill (fonttype) | ||
| 286 : | ktanaka | 1.2 | (fill1 (convskeleton1 (convskeleton (add-link partlist))) fonttype)) |
| 287 : | ktanaka | 1.1 | (defun fill1 (l tag) |
| 288 : | (let ((outline nil)) | ||
| 289 : | ktanaka | 1.2 | (setq outline (skeleton2list (applykanji l) tag)) |
| 290 : | ktanaka | 1.1 | (mapcar outline '(lambda (x)(fillpolygon (setpart1 x)))) |
| 291 : | (redraw) | ||
| 292 : | (checkevent))) | ||
| 293 : | |||
| 294 : | ;(print (list (vref readtable 35)(vref macrotable 35))) | ||
| 295 : | |||
| 296 : | (defprop ten 2 npoint) | ||
| 297 : | (defprop tate 2 npoint) | ||
| 298 : | (defprop yoko 2 npoint) | ||
| 299 : | (defprop migiue 3 npoint) | ||
| 300 : | (defprop hidari 3 npoint) | ||
| 301 : | (defprop tatehidari 4 npoint) | ||
| 302 : | (defprop migi 3 npoint) | ||
| 303 : | (defprop kozato 3 npoint) | ||
| 304 : | (defprop tatehane 3 npoint) | ||
| 305 : | (defprop tsukurihane 4 npoint) | ||
| 306 : | (defprop sanzui 2 npoint) | ||
| 307 : | (defprop kokoro 4 npoint) | ||
| 308 : | (defprop tasuki 4 npoint) | ||
| 309 : | (defprop magaritate 3 npoint) | ||
| 310 : | (defprop kagi 3 npoint) | ||
| 311 : | (defprop shin-nyuu 3 npoint) | ||
| 312 : | |||
| 313 : | ktanaka | 1.2 | (defun convskeleton (prim) |
| 314 : | ktanaka | 1.1 | (let ((linkpoints nil) |
| 315 : | (points nil) | ||
| 316 : | (linkcount 0) | ||
| 317 : | (p nil)(as nil)(pp nil) | ||
| 318 : | (lines nil)) | ||
| 319 : | (do ((l prim (cdr l))) | ||
| 320 : | ((atom l) | ||
| 321 : | `(,(nreverse points) ,(nreverse lines) nil nil)) | ||
| 322 : | (do ((ll (cdar l)(cdr ll)) | ||
| 323 : | (line nil) | ||
| 324 : | (link nil) | ||
| 325 : | (pointnmb 0) | ||
| 326 : | (i 0 (1+ i)) | ||
| 327 : | (npoints (get (caar l) 'npoint))) | ||
| 328 : | ((atom ll) | ||
| 329 : | ; (print link) | ||
| 330 : | (push (cons (caar l)(cons (nreverse line) (nreverse link))) lines)) | ||
| 331 : | (setq p (car ll)) | ||
| 332 : | (cond ((eq 'link (car p)) | ||
| 333 : | (setq as (assq (cadr p) linkpoints)) | ||
| 334 : | (cond ((null as) | ||
| 335 : | (push (cons (cadr p) linkcount) linkpoints) | ||
| 336 : | (setq pointnmb linkcount) | ||
| 337 : | (cond ((null (cddr p)) | ||
| 338 : | (push nil points)) | ||
| 339 : | (t | ||
| 340 : | (push (cons (caddr p)(cadddr p)) points))) | ||
| 341 : | (setq linkcount (1+ linkcount))) | ||
| 342 : | (t | ||
| 343 : | (setq pointnmb (cdr as)) | ||
| 344 : | (setq pp (nthcdr (- linkcount pointnmb 1) points)) | ||
| 345 : | (cond ((and (cddr p)(null (car pp))) | ||
| 346 : | (rplaca pp (cons (caddr p)(cadddr p)))))))) | ||
| 347 : | (t | ||
| 348 : | (setq pointnmb linkcount) | ||
| 349 : | (push (cons (car p)(cadr p))points) | ||
| 350 : | (setq linkcount (1+ linkcount)))) | ||
| 351 : | (cond ((>= i npoints) | ||
| 352 : | (push pointnmb link) | ||
| 353 : | ; (print link) | ||
| 354 : | ) | ||
| 355 : | (t | ||
| 356 : | (push pointnmb line))))))) | ||
| 357 : | |||
| 358 : | ktanaka | 1.2 | (defun convskeleton1(prim) |
| 359 : | ktanaka | 1.1 | (cond |
| 360 : | ((atom prim)prim) | ||
| 361 : | (t | ||
| 362 : | (lets ((points (car prim)) | ||
| 363 : | (lines (cadr prim)) | ||
| 364 : | (alist (caddr prim)) | ||
| 365 : | (newpoints nil) | ||
| 366 : | (newlines nil)) | ||
| 367 : | (do ((l points (cdr l))) | ||
| 368 : | ((atom l)) | ||
| 369 : | (push (list (caar l)(cdar l)) newpoints)) | ||
| 370 : | (do ((l lines (cdr l)) | ||
| 371 : | (line nil)) | ||
| 372 : | ((atom l)`(,(nreverse newpoints) ,(nreverse newlines) .,alist)) | ||
| 373 : | (setq line (car l)) | ||
| 374 : | (cond ((cddr line) | ||
| 375 : | (push `(,(car line),(cadr line)(link .,(cddr line))) newlines)) | ||
| 376 : | (t | ||
| 377 : | (push line newlines)))))))) | ||
| 378 : | (setq linkthresh 10.0) | ||
| 379 : | (defun add-link (body) | ||
| 380 : | (lets ((newbody nil) | ||
| 381 : | (linkpoints nil) | ||
| 382 : | (pointhist (make-hist body)) | ||
| 383 : | (tmpdist nil) | ||
| 384 : | (kouho (find-kouho body pointhist))) | ||
| 385 : | (setq linkpoints nil) | ||
| 386 : | (do ((l kouho (cdr l)) | ||
| 387 : | (curpoint nil) | ||
| 388 : | (ret nil)) | ||
| 389 : | ((atom l) | ||
| 390 : | (do ((ll body (cdr ll))) | ||
| 391 : | ((atom ll)(setq body (reverse newbody))) | ||
| 392 : | ; (print (car ll)) | ||
| 393 : | (do ((lll ret (cdr lll)) | ||
| 394 : | (newline nil)) | ||
| 395 : | ((atom lll) | ||
| 396 : | (push (append (car ll)newline) newbody) | ||
| 397 : | ; (print newbody) | ||
| 398 : | ) | ||
| 399 : | (cond ((eq (cdar lll)(car ll)) | ||
| 400 : | (push (caar lll) newline)))))) | ||
| 401 : | (setq curpoint (car l)) | ||
| 402 : | (do ((ll body (cdr ll)) | ||
| 403 : | (curlink nil) | ||
| 404 : | (minlink nil) | ||
| 405 : | (mindist 1000.0)) | ||
| 406 : | ((atom ll) | ||
| 407 : | (cond ((<$ mindist linkthresh) | ||
| 408 : | (push (cons curpoint minlink) ret)))) | ||
| 409 : | (setq curlink (car ll)) | ||
| 410 : | ; (print curlink) | ||
| 411 : | (cond ((member-point curpoint curlink)) | ||
| 412 : | (t | ||
| 413 : | (do ((lll (cdr curlink) (cdr lll))) | ||
| 414 : | ((atom (cdr lll))) | ||
| 415 : | (setq tmpdist (calcdist-old curpoint (car lll)(cadr lll))) | ||
| 416 : | ; (print tmpdist) | ||
| 417 : | (cond ((<$ tmpdist mindist) | ||
| 418 : | (setq mindist tmpdist) | ||
| 419 : | (setq minlink curlink)))))))))) | ||
| 420 : | |||
| 421 : | (defun member-point (point link) | ||
| 422 : | (cond ((atom link)nil) | ||
| 423 : | ((eq point (car link))t) | ||
| 424 : | ((member-point point (cdr link))))) | ||
| 425 : | |||
| 426 : | (defun difffloat2-old (a b) | ||
| 427 : | (list (-$ (float(point-x a))(float (point-x b))) | ||
| 428 : | (-$ (float(point-y a))(float(point-y b))))) | ||
| 429 : | |||
| 430 : | (defun calcdist-old (point p0 p1) | ||
| 431 : | (lets ((v0 (difffloat2-old p1 p0)) | ||
| 432 : | (len0 (length2 v0)) | ||
| 433 : | (v1 (difffloat2-old point p0)) | ||
| 434 : | (len1 (length2 v1)) | ||
| 435 : | (naiseki (mul2 v0 v1)) | ||
| 436 : | (len2 (//$ naiseki len0)) | ||
| 437 : | (v3 (normlen2 len2 v0))) | ||
| 438 : | ; (prind (list v0 len0 v1 len1 naiseki len2 v3)) | ||
| 439 : | (cond ((<=$ 0.0 len2 len0)(length2 (diff2 v3 v1))) | ||
| 440 : | (t 1000.0)))) | ||
| 441 : | |||
| 442 : | (defun make-hist (x) | ||
| 443 : | (do ((l x (cdr l)) | ||
| 444 : | (alist nil)) | ||
| 445 : | ((atom l)alist) | ||
| 446 : | (do ((ll (cdar l) (cdr ll)) | ||
| 447 : | (pnumber nil) | ||
| 448 : | (ptr nil)) | ||
| 449 : | ((atom ll)) | ||
| 450 : | (setq pnumber (cadar ll)) | ||
| 451 : | (setq ptr (assq pnumber alist)) | ||
| 452 : | (cond (ptr (rplacd ptr (1+ (cdr ptr)))) | ||
| 453 : | (t (push (cons pnumber 1) alist)))))) | ||
| 454 : | |||
| 455 : | (defun find-kouho (x hist) | ||
| 456 : | (do ((l x (cdr l)) | ||
| 457 : | (npoint nil) | ||
| 458 : | (ret nil)) | ||
| 459 : | ((atom l)ret) | ||
| 460 : | (setq npoint (get (caar l) 'npoint)) | ||
| 461 : | (cond ((and (= 1 (cdr (assq (cadr (cadar l)) hist))) | ||
| 462 : | (not (memq (cddr (cadar l)) nolinkpoints))) | ||
| 463 : | ; (prind (cadar l)) | ||
| 464 : | (push (cadar l) ret))) | ||
| 465 : | (cond ((and(= 1 (cdr (assq (cadar (last (car l))) hist))) | ||
| 466 : | (not (memq (cddr (car (last (car l)))) nolinkpoints))) | ||
| 467 : | ; (prind (car (last (car l)))) | ||
| 468 : | (push (car (last (car l))) ret))))) | ||
| 469 : | |||
| 470 : | ;(exfile 'disp.l) | ||
| 471 : | ;(exfile 'mincho.l) | ||
| 472 : | ;(exfile 'lib.l) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |