1 : |
ktanaka |
1.1 |
;; |
2 : |
|
|
;; nolink.l |
3 : |
ktanaka |
1.3 |
;; $Revision: 1.2 $ |
4 : |
ktanaka |
1.1 |
;; |
5 : |
|
|
|
6 : |
ktanaka |
1.2 |
(defun toggle-skeleton-link (win code x y prim) |
7 : |
ktanaka |
1.1 |
(lets ((ret nil) |
8 : |
|
|
(points (get-points prim)) |
9 : |
|
|
(lines (get-lines prim)) |
10 : |
|
|
(aux-info (get-aux-info prim)) |
11 : |
|
|
(now (list x y))) |
12 : |
|
|
(if points |
13 : |
|
|
(lets ((nth-nearest (nth-of-nearest-point now points)) |
14 : |
|
|
(nearest (nth nth-nearest points)) |
15 : |
|
|
(ret nil)) |
16 : |
|
|
(cond ((< (distance-points now nearest) *near-range*) |
17 : |
|
|
(lets ((l-info (cl:first (get-info nearest 'link-ok)))) |
18 : |
|
|
(put-info nearest 'link-ok (ncons (not l-info))))) |
19 : |
|
|
(t (beep win)))) |
20 : |
|
|
(beep win)) |
21 : |
|
|
(setq ret (cons points (cons lines aux-info))) |
22 : |
|
|
(clear-win win) |
23 : |
|
|
(if grid (grid-win win)) |
24 : |
ktanaka |
1.2 |
(draw-skeleton-win win ret) |
25 : |
ktanaka |
1.1 |
(redraw-win win) |
26 : |
|
|
ret)) |
27 : |
|
|
|
28 : |
|
|
(defun recursive-copy (s) |
29 : |
|
|
(cond ((listp s) (cons (recursive-copy (car s)) |
30 : |
|
|
(recursive-copy (cdr s)))) |
31 : |
|
|
((vectorp s) (let* ((len (vector-length s)) |
32 : |
|
|
(ret (vector len))) |
33 : |
|
|
(do ((i 0 (1+ i))) |
34 : |
|
|
((>= i len)) |
35 : |
|
|
(vset ret i (recursive-copy (vref s i)))) |
36 : |
|
|
(comment print (list 'vector s ret)) |
37 : |
|
|
ret)) |
38 : |
|
|
|
39 : |
|
|
((stringp s) (string-append "" s)) |
40 : |
|
|
((atom s) s) |
41 : |
|
|
(t |
42 : |
|
|
(print (list 'hatena s)) |
43 : |
|
|
s))) |
44 : |
|
|
|
45 : |
ktanaka |
1.2 |
(defun shapeup-skeleton (prim (leave nil)) |
46 : |
ktanaka |
1.1 |
(cond ((null prim) '(nil nil)) |
47 : |
|
|
((and (listp prim) (eq (car prim) 'joint)) |
48 : |
|
|
(recursive-copy prim)) |
49 : |
|
|
((and (listp prim) (symbolp (car prim))) |
50 : |
|
|
(recursive-copy prim)) |
51 : |
|
|
(t |
52 : |
|
|
(lets ((prrrrr (recursive-copy prim)) |
53 : |
|
|
(points (get-points prrrrr)) |
54 : |
|
|
(lines (get-lines prrrrr)) |
55 : |
|
|
(aux-info (get-aux-info prrrrr)) |
56 : |
|
|
(reference nil)) |
57 : |
|
|
|
58 : |
|
|
;; referenced ? |
59 : |
|
|
(setq reference (vector (length points) 0)) |
60 : |
|
|
(mapcar lines |
61 : |
|
|
(function |
62 : |
|
|
(lambda (l) |
63 : |
|
|
(mapc (second l) |
64 : |
|
|
(function (lambda (x) |
65 : |
|
|
(vset reference x 1))))))) |
66 : |
|
|
(do ((i 0 (1+ i)) |
67 : |
|
|
(next 0)) |
68 : |
|
|
((>= i (vector-length reference))) |
69 : |
|
|
(if (0= (vref reference i)) |
70 : |
|
|
(vset reference i -1) |
71 : |
|
|
(vset reference i next) |
72 : |
|
|
(incr next 1))) |
73 : |
|
|
|
74 : |
|
|
;; delete no referenced points |
75 : |
|
|
(setq points |
76 : |
|
|
(do ((i 0 (1+ i)) |
77 : |
|
|
(ret nil) |
78 : |
|
|
(rest points (cdr rest))) |
79 : |
|
|
((null rest) ret) |
80 : |
|
|
(if (>= (vref reference i) 0) |
81 : |
|
|
(setq ret (append ret (ncons (first rest))))))) |
82 : |
|
|
|
83 : |
|
|
;; change point-reference in elements |
84 : |
|
|
(setq lines |
85 : |
|
|
(mapcar lines |
86 : |
|
|
(function |
87 : |
|
|
(lambda (l) |
88 : |
|
|
(let ((top (first l)) |
89 : |
|
|
(pos (second l)) |
90 : |
|
|
(line-info (nthcdr 2 l))) |
91 : |
|
|
(cons top |
92 : |
|
|
(cons (mapcar pos |
93 : |
|
|
(function |
94 : |
|
|
(lambda (x) |
95 : |
|
|
(vref reference x)))) |
96 : |
|
|
line-info))))))) |
97 : |
|
|
|
98 : |
|
|
;; delete (link-ok nil) |
99 : |
|
|
;; and float -> fix |
100 : |
|
|
(setq points (mapcar points |
101 : |
|
|
#'(lambda (p) |
102 : |
|
|
(setf (car p) (fix (car p))) |
103 : |
|
|
(setf (cadr p) (fix (cadr p))) |
104 : |
|
|
(unless (cl:first (get-info p 'link-ok)) |
105 : |
|
|
(rem-info p 'link-ok)) |
106 : |
|
|
p))) |
107 : |
|
|
|
108 : |
ktanaka |
1.2 |
;; make skeleton link |
109 : |
ktanaka |
1.1 |
(setq |
110 : |
|
|
lines |
111 : |
|
|
(mapcar lines |
112 : |
|
|
#'(lambda (l) |
113 : |
|
|
; changed by tanaka 1993/9/18 |
114 : |
|
|
(cond ((memq (car l) '(outline stroke)) |
115 : |
|
|
(lets ((epoints (cadr l)) |
116 : |
|
|
(apoints |
117 : |
|
|
(do ((i 0 (1+ i)) |
118 : |
|
|
(ll epoints (cdr ll))(ret)) |
119 : |
|
|
((atom ll)(nreverse ret)) |
120 : |
|
|
(and (assq 'link-ok (cddr (nth (car ll) points))) |
121 : |
|
|
(push i ret))))) |
122 : |
|
|
; (prind apoints) |
123 : |
|
|
(if apoints (put-info l 'curve apoints) nil) |
124 : |
|
|
; (prind l) |
125 : |
|
|
l)) |
126 : |
|
|
(t |
127 : |
|
|
(let ((old-links (if leave |
128 : |
|
|
(get-info l 'link) |
129 : |
|
|
nil)) |
130 : |
|
|
(links |
131 : |
|
|
(do ((ret nil) |
132 : |
|
|
(i 0 (1+ i)) |
133 : |
|
|
(rest points (cdr rest))) |
134 : |
|
|
((null rest) ret) |
135 : |
|
|
(let ((now (car rest))) |
136 : |
|
|
(when (and |
137 : |
|
|
(cl:first (get-info now 'link-ok)) |
138 : |
|
|
(not (memq i (second l))) |
139 : |
|
|
(< (distance-point-element |
140 : |
|
|
now points l) |
141 : |
|
|
*link-near-range*)) |
142 : |
|
|
(push i ret)))))) |
143 : |
|
|
(setq links (append old-links links)) |
144 : |
|
|
(if links |
145 : |
|
|
(put-info l 'link links) |
146 : |
|
|
(rem-info l 'link)) |
147 : |
|
|
(mapcar links |
148 : |
|
|
#'(lambda (n) |
149 : |
|
|
(put-info (nth n points) |
150 : |
|
|
'link-ok (ncons t))))) |
151 : |
|
|
l))))) |
152 : |
|
|
|
153 : |
|
|
;; result |
154 : |
|
|
(cons points (cons lines aux-info)))))) |
155 : |
|
|
|
156 : |
|
|
(defun make-link-ok-from-old-version (prim) |
157 : |
|
|
(lets ((points (get-points prim)) |
158 : |
|
|
(lines (get-lines prim)) |
159 : |
|
|
(aux-info (get-aux-info prim)) |
160 : |
|
|
(link-ok-points nil)) |
161 : |
|
|
(mapcar lines |
162 : |
|
|
#'(lambda (now) |
163 : |
|
|
; changed by tanaka 1993/9/18 |
164 : |
|
|
(let ((ps (or (get-info now 'link) |
165 : |
|
|
(and (memq (car now) '(outline stroke)) |
166 : |
|
|
(mapcar (get-info now 'curve) |
167 : |
|
|
#'(lambda (x) (nth x (cadr now)))))))) |
168 : |
|
|
(if ps |
169 : |
|
|
(setq link-ok-points |
170 : |
|
|
(append ps link-ok-points)))))) |
171 : |
|
|
|
172 : |
|
|
(let ((i 0)) |
173 : |
|
|
(mapcar points |
174 : |
|
|
#'(lambda (np) |
175 : |
|
|
(if (memq i link-ok-points) |
176 : |
|
|
(put-info np 'link-ok '(t))) |
177 : |
|
|
(setq i (1+ i))))) |
178 : |
|
|
(cons points (cons lines aux-info)))) |
179 : |
|
|
|
180 : |
|
|
|
181 : |
|
|
|
182 : |
|
|
|