1 : |
ktanaka |
1.1 |
;; |
2 : |
|
|
;; delprim.l |
3 : |
|
|
;; $Revistion$ |
4 : |
|
|
;; |
5 : |
|
|
|
6 : |
|
|
(defun distance-point-element (org points elem) |
7 : |
|
|
(lets ((linepoints (second elem)) |
8 : |
|
|
(kouho-distance *range-too-large*)) |
9 : |
|
|
(if (= (length linepoints) 1) |
10 : |
|
|
(min kouho-distance |
11 : |
|
|
(distance-points org (nth (first linepoints) points))) |
12 : |
|
|
(do ((rest linepoints (cdr rest)) |
13 : |
|
|
(next (cdr linepoints) (cdr next))) |
14 : |
|
|
((null next) kouho-distance) |
15 : |
|
|
(lets ((p1 (first rest)) |
16 : |
|
|
(p2 (first next)) |
17 : |
|
|
(ko-line (list |
18 : |
|
|
(nth p1 points) |
19 : |
|
|
(nth p2 points))) |
20 : |
|
|
(now-distance (distance-point-line |
21 : |
|
|
org |
22 : |
|
|
ko-line))) |
23 : |
|
|
(if (< now-distance kouho-distance) |
24 : |
|
|
(setq kouho-distance now-distance))))))) |
25 : |
|
|
|
26 : |
|
|
(defun nth-of-nearest-element (org points lines) |
27 : |
|
|
(let ((kouho-distance (distance-point-element org points (car lines))) |
28 : |
|
|
(kouho-line 0)) |
29 : |
|
|
(do ((rest (cdr lines) (cdr rest)) |
30 : |
|
|
(i 1 (1+ i))) |
31 : |
|
|
((null rest) kouho-line) |
32 : |
|
|
(lets ((now (car rest)) |
33 : |
|
|
(now-distance (distance-point-element org points now))) |
34 : |
|
|
(cond ((< now-distance kouho-distance) |
35 : |
|
|
(setq kouho-distance now-distance |
36 : |
|
|
kouho-line i))))))) |
37 : |
|
|
|
38 : |
ktanaka |
1.2 |
(defun delete-skeleton-element (win code x y prim) |
39 : |
ktanaka |
1.1 |
(lets ((ret nil) |
40 : |
|
|
(points (get-points prim)) |
41 : |
|
|
(lines (get-lines prim)) |
42 : |
|
|
(aux-info (get-aux-info prim)) |
43 : |
|
|
(now (list x y))) |
44 : |
|
|
(if lines |
45 : |
|
|
(lets ((nth-nearest (nth-of-nearest-element now points lines)) |
46 : |
|
|
(nearest (nth nth-nearest lines))) |
47 : |
|
|
(cond ((< (distance-point-element now points nearest) *near-range*) |
48 : |
|
|
(setq lines (rem-nth nth-nearest lines))) |
49 : |
|
|
(t (beep win)))) |
50 : |
|
|
(beep win)) |
51 : |
ktanaka |
1.2 |
(setq ret (shapeup-skeleton (cons points (cons lines aux-info)))) |
52 : |
ktanaka |
1.1 |
(clear-win win) |
53 : |
|
|
(if grid (grid-win win)) |
54 : |
ktanaka |
1.2 |
(draw-skeleton-win win ret) |
55 : |
ktanaka |
1.1 |
(redraw-win win) |
56 : |
|
|
ret)) |
57 : |
|
|
|
58 : |
|
|
(defun draw-dash-nth-element-win! (win prim n) |
59 : |
|
|
(lets ((points (get-points prim)) |
60 : |
|
|
(lines (get-lines prim)) |
61 : |
|
|
(pointlist (second (nth n lines))) |
62 : |
|
|
(linenum (1- (length pointlist)))) |
63 : |
|
|
(do ((i 0 (1+ i))) |
64 : |
|
|
((>= i linenum)) |
65 : |
|
|
(lets ((p0 (nth (nth i pointlist) points)) |
66 : |
|
|
(p1 (nth (nth (1+ i) pointlist) points)) |
67 : |
|
|
(x0 (first p0)) |
68 : |
|
|
(y0 (second p0)) |
69 : |
|
|
(x1 (first p1)) |
70 : |
|
|
(y1 (second p1))) |
71 : |
|
|
(draw-line win |
72 : |
|
|
(get-winprop win 'dashlinegc) |
73 : |
|
|
x0 y0 x1 y1))))) |
74 : |
|
|
|
75 : |
|
|
(defun draw-nth-element-win! (win prim n) |
76 : |
|
|
(lets ((points (get-points prim)) |
77 : |
|
|
(lines (get-lines prim)) |
78 : |
|
|
(pointlist (second (nth n lines))) |
79 : |
|
|
(linenum (1- (length pointlist)))) |
80 : |
|
|
(do ((i 0 (1+ i))) |
81 : |
|
|
((>= i linenum)) |
82 : |
|
|
(lets ((p0 (nth (nth i pointlist) points)) |
83 : |
|
|
(p1 (nth (nth (1+ i) pointlist) points)) |
84 : |
|
|
(x0 (first p0)) |
85 : |
|
|
(y0 (second p0)) |
86 : |
|
|
(x1 (first p1)) |
87 : |
|
|
(y1 (second p1))) |
88 : |
|
|
(draw-line win (get-winprop win 'blackgc) |
89 : |
|
|
x0 y0 x1 y1))))) |
90 : |
|
|
|
91 : |
|
|
|
92 : |
|
|
(setq %pred-nearest-element% nil) |
93 : |
|
|
(defun nearest-line-dotted (win x y prim) |
94 : |
|
|
(lets ((points (get-points prim)) |
95 : |
|
|
(lines (get-lines prim)) |
96 : |
|
|
(now (list x y))) |
97 : |
|
|
(when lines |
98 : |
|
|
(lets ((nth-nearest (nth-of-nearest-element now points lines)) |
99 : |
|
|
(nearest (nth nth-nearest lines)) |
100 : |
|
|
(distance (distance-point-element now points nearest)) |
101 : |
|
|
(leng-lines (length lines))) |
102 : |
|
|
(comment |
103 : |
|
|
(print (list %pred-nearest-element% nth-nearest |
104 : |
|
|
distance *near-range*))) |
105 : |
|
|
(cond ((and (neq %pred-nearest-element% nth-nearest) |
106 : |
|
|
(< distance *near-range*)) |
107 : |
|
|
(if (and %pred-nearest-element% |
108 : |
|
|
(< %pred-nearest-element% leng-lines)) |
109 : |
|
|
(draw-nth-element-win! win prim %pred-nearest-element%)) |
110 : |
|
|
(draw-dash-nth-element-win! win prim nth-nearest) |
111 : |
|
|
(display-force-output (window-display win)) |
112 : |
|
|
(setq %pred-nearest-element% nth-nearest)) |
113 : |
|
|
((and (eq %pred-nearest-element% nth-nearest) |
114 : |
|
|
(< distance *near-range*)) |
115 : |
|
|
'do-nothing) |
116 : |
|
|
((and %pred-nearest-element% |
117 : |
|
|
(< %pred-nearest-element% leng-lines)) |
118 : |
|
|
(draw-nth-element-win! win prim %pred-nearest-element%) |
119 : |
|
|
(setq %pred-nearest-element% nil))))))) |
120 : |
|
|
|