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

Annotation of /skeleton-edit/edprim.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 ;;
2 :     ;; edprim.l
3 :     ;; $Revision: 1.2 $
4 :     ;;
5 :    
6 :     (defun get-points (prim)
7 :     (first prim))
8 :    
9 :     (defun get-lines (prim)
10 :     (second prim))
11 :    
12 :     (defun get-aux-info (prim)
13 :     (nthcdr 2 prim))
14 :    
15 :     (defun cl:first (l)
16 :     (if (< (length l) 1)
17 :     nil
18 :     (car l)))
19 :    
20 :     (defun draw-skeleton-win (win prim (mode 'black))
21 :     (if (eq (car prim) 'joint)
22 :     (draw-jointed-primitive-win win prim)
23 :     (draw-simple-skeleton-win win prim mode)))
24 :    
25 :     (defun draw-simple-skeleton-win (win prim (mode 'black))
26 :     (let ((points (get-points prim))
27 :     (lines (get-lines prim)))
28 :     (mapcar points
29 :     #'(lambda (x)
30 :     (if (cl:first (get-info x 'link-ok))
31 :     (draw-sikaku-win win (first x) (second x))
32 :     (draw-sankaku-win win (first x) (second x)))))
33 :    
34 :     (mapcar lines
35 :     #'(lambda (x)
36 :     (lets ((pointlist (second x))
37 :     (linenum (- (length pointlist) 1)))
38 :     (do ((i 0 (1+ i)))
39 :     ((>= i linenum))
40 :     (comment print (list i linenum))
41 :     (lets ((p0 (nth (nth i pointlist) points))
42 :     (p1 (nth (nth (1+ i) pointlist) points))
43 :     (x0 (first p0))
44 :     (y0 (second p0))
45 :     (x1 (first p1))
46 :     (y1 (second p1)))
47 :     (draw-line-win win x0 y0 x1 y1 mode))))))
48 :    
49 :     (mapcar lines
50 :     #'(lambda (l)
51 :     (let ((elmname (first l)))
52 :     (let ((draw-func (get elmname 'skeleton-edit-draw-optional)))
53 :     (if draw-func
54 :     (funcall draw-func win l points))))))
55 :    
56 :     (mapcar lines
57 :     #'(lambda (x)
58 :     (lets ((hirawidth (get-info x 'hirawidth))
59 :     (pointlist (second x)))
60 :     (when (and hirawidth pointlist)
61 :     (do ((nowpnt pointlist (cdr nowpnt))
62 :     (nowwid hirawidth (cdr nowwid)))
63 :     ((or (null nowpnt) (null nowwid)))
64 :     (lets ((now (nth (first nowpnt) points))
65 :     (r (first nowwid))
66 :     (x (first now))
67 :     (y (second now)))
68 :     (draw-circle-win win x y r)))))))
69 :    
70 :     (let ((xu (get-prim-info prim 'xunit))
71 :     (yu (get-prim-info prim 'yunit)))
72 :     (if (and xu yu)
73 :     (lets ((center (center-of-primitive prim))
74 :     (cx (car center))
75 :     (cy (cadr center))
76 :     (xunit (fix (cdr xu)))
77 :     (yunit (fix (cdr yu)))
78 :     (x0 (difference cx (quotient xunit 2)))
79 :     (y0 (difference cy (quotient yunit 2))))
80 :     (draw-dash-rectangle-win win x0 y0 xunit yunit)
81 :     (comment print (list xunit yunit)))))
82 :     ))
83 :    
84 :     (defun draw-dash-rectangle-win (win x y xwid ywid)
85 :     (draw-rectangle (get-winprop win 'save)
86 :     (get-winprop win 'dashlinegc)
87 :     x y xwid ywid))
88 :    
89 :     (defun rem-nth (n l)
90 :     (do ((ret nil)
91 :     (i 0 (1+ i))
92 :     (rest l (cdr rest)))
93 :     ((or (> i n) (null rest)) ret)
94 :     (cond ((< i n) (setq ret (append ret (list (first rest)))))
95 :     (t (setq ret (append ret (cdr rest)))))))
96 :    
97 :     (defun uniq (l)
98 :     (let ((ret nil))
99 :     (mapcar l (function (lambda (x)
100 :     (if (not (memq x ret)) (push x ret)))))
101 :     ret))
102 :    
103 :     (defun cl:second (l)
104 :     (if (< (length l) 2)
105 :     nil
106 :     (second l)))
107 :    
108 :     (defun neighbor (item l)
109 :     (lets ((left (memq item l))
110 :     (right (memq item (reverse l)))
111 :     (ltop (cl:second left))
112 :     (rtop (cl:second right)))
113 :     (append (if ltop (ncons ltop) nil)
114 :     (if rtop (ncons rtop) nil))))
115 :    
116 :     (defun connected-points (n prim)
117 :     (let ((points (get-points prim))
118 :     (lines (get-lines prim))
119 :     (retpoints nil))
120 :     (mapcar lines
121 :     (function
122 :     (lambda (x)
123 :     (setq retpoints (append (neighbor n (second x)) retpoints)))))
124 :    
125 :    
126 :     (setq retpoints (uniq retpoints))
127 :     (mapcar retpoints
128 :     (function (lambda (x) (nth x points))))))
129 :    
130 :     (defun cl:third (l)
131 :     (if (< (length l) 3)
132 :     nil
133 :     (third l)))
134 :    
135 :     (defun move-skeleton-point (win code x y prim)
136 :     (lets ((ret nil)
137 :     (points (get-points prim))
138 :     (lines (get-lines prim))
139 :     (aux-info (get-aux-info prim))
140 :     (now (list x y)))
141 :     (if points
142 :     (lets ((nth-nearest (nth-of-nearest-point now points))
143 :     (nearest (nth nth-nearest points)))
144 :     (cond ((< (distance-points nearest now) *near-range*)
145 :     (let ((source (connected-points nth-nearest prim)))
146 :     (mapcar source
147 :     #'(lambda (x) (draw-line-win win
148 :     (first nearest)
149 :     (second nearest)
150 :     (first x)
151 :     (second x)
152 :     'white)))
153 :     (draw-sikaku-win win
154 :     (first nearest) (second nearest) 'white)
155 :     (redraw-win win)
156 :     (setq nearest
157 :     (get-position:drag-lines win now source
158 :     *end-by-release*))
159 :    
160 :     (lets ((link-info (cl:third (nth nth-nearest points)))
161 :     (new-nth (if link-info
162 :     (append nearest (ncons link-info))
163 :     nearest)))
164 :     (setf (nth nth-nearest points) new-nth))))
165 :     (t (beep win))))
166 :     (beep win))
167 :     (setq ret (cons points (cons lines aux-info)))
168 :     (clear-win win)
169 :     (if grid (grid-win win))
170 :     (draw-skeleton-win win ret)
171 :     (redraw-win win)
172 :     ret))
ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help