[wadalabfont-kit] / skeleton-edit / nolink.l  

Annotation of /skeleton-edit/nolink.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 ;;
2 :     ;; nolink.l
3 :     ;; $Revision: 1.2 $
4 :     ;;
5 :    
6 :     (defun toggle-skeleton-link (win code x y prim)
7 :     (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 :     (draw-skeleton-win win ret)
25 :     (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 :     (defun shapeup-skeleton (prim (leave nil))
46 :     (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 :     ;; make skeleton link
109 :     (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 :    
ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help