Annotation of /lisp/tools/delhirapnt.lAnnotation of /lisp/tools/delhirapnt.l
Parent Directory
| 
Revision Log
Revision: 1.3 - (view) (download)
| 1 : | ktanaka | 1.1 | ;; ------------ ;; |
| 2 : | ;; delhirapnt.l ;; | ||
| 3 : | ;; ------------ ;; | ||
| 4 : | |||
| 5 : | (defun nearest-point-of-hira (prim x y) | ||
| 6 : | (let ((points (get-points prim)) | ||
| 7 : | (lines (get-lines prim)) | ||
| 8 : | (info (get-aux-info prim)) | ||
| 9 : | (maxdist *near-range*) | ||
| 10 : | (ret nil)) | ||
| 11 : | (mapcar | ||
| 12 : | lines | ||
| 13 : | #'(lambda (l) | ||
| 14 : | (when (memq (car l) '(outline stroke hira-long)) | ||
| 15 : | (let* ((p-no (cadr l))) | ||
| 16 : | (do ((p p-no (cdr p))) | ||
| 17 : | ((endp p)) | ||
| 18 : | (let* ((p-1 (car p)) | ||
| 19 : | (pp-1 (nth p-1 points)) | ||
| 20 : | (dist (distance-points (list x y) | ||
| 21 : | pp-1))) | ||
| 22 : | (when (< dist maxdist) | ||
| 23 : | (setq maxdist dist) | ||
| 24 : | (setq ret (list p-1 pp-1))))))))) | ||
| 25 : | (cond ((null ret) | ||
| 26 : | nil) | ||
| 27 : | ((< maxdist *near-range*) | ||
| 28 : | ret) | ||
| 29 : | (t | ||
| 30 : | nil)))) | ||
| 31 : | |||
| 32 : | (defun setup-del-hira-point () | ||
| 33 : | (setq %end% nil)) | ||
| 34 : | |||
| 35 : | (defun remove-member (mem lst) | ||
| 36 : | (cond ((null lst) nil) | ||
| 37 : | ((eq (car lst) mem) | ||
| 38 : | (remove-member mem (cdr lst))) | ||
| 39 : | (t | ||
| 40 : | (cons (car lst) | ||
| 41 : | (remove-member mem (cdr lst)))))) | ||
| 42 : | |||
| 43 : | (defun remove-member-2 (mem lst lst2) | ||
| 44 : | (cond ((or (null lst) (null lst2)) | ||
| 45 : | (cons nil nil)) | ||
| 46 : | ((eq (car lst) mem) | ||
| 47 : | (remove-member-2 mem (cdr lst) (cdr lst2))) | ||
| 48 : | (t | ||
| 49 : | (let ((sub (remove-member-2 mem (cdr lst) (cdr lst2)))) | ||
| 50 : | (cons (cons (car lst) (car sub)) | ||
| 51 : | (cons (car lst2) (cdr sub))))))) | ||
| 52 : | |||
| 53 : | |||
| 54 : | (defun del-hira-point (win x y prim) | ||
| 55 : | (let* ((selected (nearest-point-of-hira prim x y))) | ||
| 56 : | (if (null selected) | ||
| 57 : | (progn (beep win) prim) | ||
| 58 : | (setq selected (car selected)) | ||
| 59 : | (let* ((points (get-points prim)) | ||
| 60 : | (lines (get-lines prim)) | ||
| 61 : | (info (get-aux-info prim)) | ||
| 62 : | (newlines nil) | ||
| 63 : | (ret nil)) | ||
| 64 : | (mapcar lines | ||
| 65 : | #'(lambda (l) | ||
| 66 : | (let ((pnts (cadr l)) | ||
| 67 : | (info (cddr l)) | ||
| 68 : | (wid (get-info l 'hirawidth))) | ||
| 69 : | (when (and (memq (car l) '(outline stroke hira-long)) (memq selected pnts)) | ||
| 70 : | (if (null wid) | ||
| 71 : | (setq wid (make-list (length pnts) | ||
| 72 : | *default-hirawidth*))) | ||
| 73 : | (let* ((newpntdef (remove-member-2 selected pnts wid)) | ||
| 74 : | (newpnts (car newpntdef)) | ||
| 75 : | (newwid (cdr newpntdef)) | ||
| 76 : | (newl (cons (car l) (ncons newpnts)))) | ||
| 77 : | (and (eq (car l) 'hira-long) | ||
| 78 : | (put-info newl 'hirawidth newwid)) | ||
| 79 : | (setq l newl))) | ||
| 80 : | (setq newlines (append newlines (ncons l)))))) | ||
| 81 : | ktanaka | 1.2 | (setq ret (shapeup-skeleton (cons points (cons newlines info)))) |
| 82 : | ktanaka | 1.1 | |
| 83 : | (clear-win win) | ||
| 84 : | (if grid (grid-win win)) | ||
| 85 : | ktanaka | 1.2 | (draw-skeleton-win win ret) |
| 86 : | ktanaka | 1.1 | (redraw-win win) |
| 87 : | ret)))) | ||
| 88 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |