| 1 : |
ktanaka |
1.1 |
;;-----------;; |
| 2 : |
|
|
;; edjoint.l ;; |
| 3 : |
|
|
;;-----------;; |
| 4 : |
|
|
|
| 5 : |
|
|
(defun triads-of-jointed-primitive (prim) |
| 6 : |
|
|
(comment prind prim) |
| 7 : |
|
|
(let* ((vecs (cadr (second prim))) |
| 8 : |
|
|
(subs (cadr (third prim))) |
| 9 : |
|
|
(ret nil)) |
| 10 : |
|
|
(loop |
| 11 : |
|
|
(let* ((v (car vecs)) |
| 12 : |
|
|
(s (car subs)) |
| 13 : |
|
|
(as (applykanji s))) |
| 14 : |
|
|
|
| 15 : |
|
|
(push (list s v as) ret) |
| 16 : |
|
|
|
| 17 : |
|
|
(setq vecs (cdr vecs) |
| 18 : |
|
|
subs (cdr subs)) |
| 19 : |
|
|
(if (or (endp vecs) (endp subs)) (exit)))) |
| 20 : |
|
|
ret)) |
| 21 : |
|
|
|
| 22 : |
|
|
(defun frame-points-of-primitive (prim) |
| 23 : |
|
|
(let* ((pr (applykanji prim)) |
| 24 : |
|
|
(points (car pr)) |
| 25 : |
|
|
(1st (car points))) |
| 26 : |
|
|
(do ((points (cdr points) (cdr points)) |
| 27 : |
|
|
(maxx (car 1st)) |
| 28 : |
|
|
(minx (car 1st)) |
| 29 : |
|
|
(maxy (cadr 1st)) |
| 30 : |
|
|
(miny (cadr 1st))) |
| 31 : |
|
|
((endp points) (list (list minx miny) (list maxx maxy))) |
| 32 : |
|
|
(let* ((p (car points)) |
| 33 : |
|
|
(x (car p)) |
| 34 : |
|
|
(y (cadr p))) |
| 35 : |
|
|
(cond ((lessp x minx) (setq minx x)) |
| 36 : |
|
|
((greaterp x maxx) (setq maxx x))) |
| 37 : |
|
|
(cond ((lessp y miny) (setq miny y)) |
| 38 : |
|
|
((greaterp y maxy) (setq maxy y))))))) |
| 39 : |
|
|
|
| 40 : |
|
|
(defun range-of-primitive-of-jp (prim vec) |
| 41 : |
|
|
(let* ((frame (frame-points-of-primitive prim)) |
| 42 : |
|
|
(ps (affine-translate-points frame vec)) |
| 43 : |
|
|
(x0 (caar ps)) |
| 44 : |
|
|
(y0 (cadar ps)) |
| 45 : |
|
|
(x1 (caadr ps)) |
| 46 : |
|
|
(y1 (cadadr ps)) |
| 47 : |
|
|
(xx0 (times (plus (times 9.0 x0) x1) 0.1)) |
| 48 : |
|
|
(xx1 (times (plus x0 (times 9.0 x1)) 0.1)) |
| 49 : |
|
|
(yy0 (times (plus (times 9.0 y0) y1) 0.1)) |
| 50 : |
|
|
(yy1 (times (plus y0 (times 9.0 y1)) 0.1))) |
| 51 : |
|
|
(list (list (tofix xx0) (tofix yy0)) |
| 52 : |
|
|
(list (tofix xx1) (tofix yy1))))) |
| 53 : |
|
|
|
| 54 : |
|
|
(defun draw-frame-of-primitive-win (win prim vec) |
| 55 : |
|
|
(let* ((range (range-of-primitive-of-jp prim vec)) |
| 56 : |
|
|
(xx0 (caar range)) |
| 57 : |
|
|
(yy0 (cadar range)) |
| 58 : |
|
|
(xx1 (caadr range)) |
| 59 : |
|
|
(yy1 (cadadr range))) |
| 60 : |
|
|
(draw-rectangle-win win xx0 yy0 xx1 yy1))) |
| 61 : |
|
|
|
| 62 : |
|
|
(defun draw-joint-vecs-primname-win (win prim) |
| 63 : |
|
|
(let* ((vecs (cadr (second prim))) |
| 64 : |
|
|
(subs (cadr (third prim))) |
| 65 : |
|
|
(a-list (cdddr prim))) |
| 66 : |
|
|
(loop |
| 67 : |
|
|
(let ((v (car vecs)) |
| 68 : |
|
|
(s (applykanji (car subs)))) |
| 69 : |
|
|
(if grid (grid-win win)) |
| 70 : |
ktanaka |
1.2 |
(draw-skeleton-win win (affine-translate-pure-primitive s v)) |
| 71 : |
ktanaka |
1.1 |
(draw-frame-of-primitive-win win s v) |
| 72 : |
|
|
(setq vecs (cdr vecs) |
| 73 : |
|
|
subs (cdr subs)) |
| 74 : |
|
|
(if (or (endp vecs) (endp subs)) (exit)))))) |
| 75 : |
|
|
|
| 76 : |
|
|
(defun draw-jointed-primitive-win (win pr) |
| 77 : |
|
|
(if (and (listp pr) (eq (car pr) 'joint)) |
| 78 : |
|
|
(draw-joint-vecs-primname-win win pr) |
| 79 : |
|
|
(draw-joint-vecs-primname-win win (expandkanji pr)))) |
| 80 : |
|
|
|
| 81 : |
|
|
(defun draw-nikuduked-jointed-primitive-win! (win pr-def) |
| 82 : |
|
|
(let* ((prim pr-def) |
| 83 : |
|
|
(vecs (cadr (second prim))) |
| 84 : |
|
|
(subs (cadr (third prim))) |
| 85 : |
|
|
(a-list (cdddr prim))) |
| 86 : |
|
|
(clear-win! win) |
| 87 : |
|
|
(loop |
| 88 : |
|
|
(let ((v (car vecs)) |
| 89 : |
|
|
(s (car subs))) |
| 90 : |
|
|
|
| 91 : |
ktanaka |
1.2 |
(draw-nikuduked-skeleton-win! |
| 92 : |
ktanaka |
1.1 |
win |
| 93 : |
|
|
(affine-translate-pure-primitive (applykanji s) v) |
| 94 : |
|
|
'mincho) |
| 95 : |
|
|
|
| 96 : |
|
|
(setq vecs (cdr vecs) |
| 97 : |
|
|
subs (cdr subs)) |
| 98 : |
|
|
(if (or (endp vecs) (endp subs)) (exit)))))) |
| 99 : |
|
|
|
| 100 : |
|
|
(defun redisplay-win (win) |
| 101 : |
|
|
(redraw-win win) |
| 102 : |
|
|
(display-force-output (window-display win))) |
| 103 : |
|
|
|
| 104 : |
|
|
(defun inrange (nowpoint range) |
| 105 : |
|
|
(let ((nowx (car nowpoint)) |
| 106 : |
|
|
(nowy (cadr nowpoint)) |
| 107 : |
|
|
(x0 (caar range)) |
| 108 : |
|
|
(y0 (cadar range)) |
| 109 : |
|
|
(x1 (caadr range)) |
| 110 : |
|
|
(y1 (cadadr range))) |
| 111 : |
|
|
(and (lessp x0 nowx) (lessp nowx x1) |
| 112 : |
|
|
(lessp y0 nowy) (lessp nowy y1)))) |
| 113 : |
|
|
|
| 114 : |
|
|
(defun move-primitive-of-jointed-primitive (win code x0 y0) |
| 115 : |
|
|
(let* ((save-bp-handler (get-winprop win 'button-press-handler)) |
| 116 : |
|
|
(save-br-handler (get-winprop win 'button-release-handler)) |
| 117 : |
|
|
(save-mn-handler (get-winprop win 'motion-notify-handler)) |
| 118 : |
|
|
(save-event-mask (window-event-mask win)) |
| 119 : |
|
|
(%pred-position% nil) |
| 120 : |
|
|
(%end% nil) |
| 121 : |
|
|
(whichprim-nth nil) |
| 122 : |
|
|
(whichprim nil) |
| 123 : |
|
|
(nth-prim nil) |
| 124 : |
|
|
(range nil) |
| 125 : |
|
|
(triads (triads-of-jointed-primitive joint-prim-def))) |
| 126 : |
|
|
|
| 127 : |
|
|
(setq whichprim-nth |
| 128 : |
|
|
(do ((len (length triads)) |
| 129 : |
|
|
(nowp triads (cdr nowp)) |
| 130 : |
|
|
(i 0 (1+ i)) |
| 131 : |
|
|
(found nil)) |
| 132 : |
|
|
((or found (endp nowp)) (cons (- len i) found)) |
| 133 : |
|
|
(let* ((pr (car nowp)) |
| 134 : |
|
|
(vec (second pr)) |
| 135 : |
|
|
(prdef (third pr))) |
| 136 : |
|
|
(setq range (range-of-primitive-of-jp prdef vec)) |
| 137 : |
|
|
(if (inrange (list x0 y0) range) |
| 138 : |
|
|
(setq found pr))))) |
| 139 : |
|
|
|
| 140 : |
|
|
(setq whichprim (cdr whichprim-nth) |
| 141 : |
|
|
nth-prim (car whichprim-nth)) |
| 142 : |
|
|
(if (null whichprim) |
| 143 : |
|
|
(progn (beep win) joint-prim-def) |
| 144 : |
|
|
(catch 'exit-move-pjp |
| 145 : |
|
|
(let ((prim-n (car whichprim)) |
| 146 : |
|
|
(prim-vec (cadr whichprim)) |
| 147 : |
|
|
(prim-def (caddr whichprim))) |
| 148 : |
|
|
|
| 149 : |
|
|
(let* ((minx (caar range)) |
| 150 : |
|
|
(miny (cadar range)) |
| 151 : |
|
|
(maxx (caadr range)) |
| 152 : |
|
|
(maxy (cadadr range)) |
| 153 : |
|
|
(xwid (// (- maxx minx) 2)) |
| 154 : |
|
|
(ywid (// (- maxy miny) 2))) |
| 155 : |
|
|
|
| 156 : |
|
|
(draw-corner-xorbox-win! win minx miny maxx maxy) |
| 157 : |
|
|
(draw-corner-dashbox-win! win minx miny maxx maxy) |
| 158 : |
|
|
|
| 159 : |
|
|
(setq %pred-position% nil) |
| 160 : |
|
|
(setq %end% nil) |
| 161 : |
|
|
|
| 162 : |
|
|
(put-winprop win |
| 163 : |
|
|
'button-press-handler |
| 164 : |
|
|
#'(lambda (win code x y) |
| 165 : |
|
|
(setq %end% (if (eq code *end-mode*) |
| 166 : |
|
|
'exit-move-some |
| 167 : |
|
|
t)) |
| 168 : |
|
|
(setq %pred-position% (list x y)))) |
| 169 : |
|
|
|
| 170 : |
|
|
(put-winprop win |
| 171 : |
|
|
'motion-notify-handler |
| 172 : |
|
|
`(lambda (win x y) |
| 173 : |
|
|
(move-boxes-win! win x y ,xwid ,ywid))) |
| 174 : |
|
|
|
| 175 : |
|
|
(setf (window-event-mask win) '(:exposure |
| 176 : |
|
|
:button-press |
| 177 : |
|
|
:button-release |
| 178 : |
|
|
:pointer-motion)) |
| 179 : |
|
|
|
| 180 : |
|
|
(move-boxes-win! win x0 y0 xwid ywid) |
| 181 : |
|
|
|
| 182 : |
|
|
(loop-disable-other-win win #'(lambda () %end%)) |
| 183 : |
|
|
|
| 184 : |
|
|
(if (eq %end% 'exit-move-some) (throw 'exit-move-pjp nil)) |
| 185 : |
|
|
|
| 186 : |
|
|
(let* ((src joint-prim-def) |
| 187 : |
|
|
(vecs (cadadr src)) |
| 188 : |
|
|
(v (nth nth-prim vecs)) |
| 189 : |
|
|
(dx (difference (first %pred-position%) |
| 190 : |
|
|
(times (plus minx maxx) 0.5))) |
| 191 : |
|
|
(dy (difference (second %pred-position%) |
| 192 : |
|
|
(times (plus miny maxy) 0.5))) |
| 193 : |
|
|
(e (vref v 4)) |
| 194 : |
|
|
(f (vref v 5)) |
| 195 : |
|
|
|
| 196 : |
|
|
(vec (vector (vector-length v) v))) |
| 197 : |
|
|
(setf (nth nth-prim vecs) vec) |
| 198 : |
|
|
|
| 199 : |
|
|
(vset vec 4 (plus e dx)) |
| 200 : |
|
|
(vset vec 5 (plus f dy)) |
| 201 : |
|
|
|
| 202 : |
|
|
(clear-win win) |
| 203 : |
|
|
(draw-joint-vecs-primname-win win src) |
| 204 : |
|
|
(redraw-win win) |
| 205 : |
|
|
|
| 206 : |
|
|
(setf (window-event-mask win) save-event-mask) |
| 207 : |
|
|
(put-winprop win |
| 208 : |
|
|
'button-press-handler |
| 209 : |
|
|
save-bp-handler) |
| 210 : |
|
|
(put-winprop win |
| 211 : |
|
|
'button-release-handler |
| 212 : |
|
|
save-br-handler) |
| 213 : |
|
|
(put-winprop win |
| 214 : |
|
|
'motion-notify-handler |
| 215 : |
|
|
save-mn-handler) |
| 216 : |
|
|
src |
| 217 : |
|
|
))))))) |
| 218 : |
|
|
|
| 219 : |
|
|
(defun draw-rectangle-win (win x y x1 y1 (mode 'black)) |
| 220 : |
|
|
(setq x (fix x) y (fix y) x1 (fix x1) y1 (fix y1)) |
| 221 : |
|
|
(draw-rectangle (get-winprop win 'save) |
| 222 : |
|
|
(selectq mode |
| 223 : |
|
|
(white (get-winprop win 'savewhitegc)) |
| 224 : |
|
|
(black (get-winprop win 'saveblackgc)) |
| 225 : |
|
|
(t (funcall err:argument-type mode))) |
| 226 : |
|
|
x y (- x1 x) (- y1 y))) |
| 227 : |
|
|
|
| 228 : |
|
|
(defun resize-primitive-of-jointed-primitive (win code x0 y0) |
| 229 : |
|
|
(let* ((save-bp-handler (get-winprop win 'button-press-handler)) |
| 230 : |
|
|
(save-br-handler (get-winprop win 'button-release-handler)) |
| 231 : |
|
|
(save-mn-handler (get-winprop win 'motion-notify-handler)) |
| 232 : |
|
|
(save-event-mask (window-event-mask win)) |
| 233 : |
|
|
(%pred-position% nil) |
| 234 : |
|
|
(%end% nil) |
| 235 : |
|
|
(whichprim-nth nil) |
| 236 : |
|
|
(whichprim nil) |
| 237 : |
|
|
(nth-prim nil) |
| 238 : |
|
|
(range nil) |
| 239 : |
|
|
(triads (triads-of-jointed-primitive joint-prim-def))) |
| 240 : |
|
|
|
| 241 : |
|
|
(setq whichprim-nth |
| 242 : |
|
|
(do ((len (length triads)) |
| 243 : |
|
|
(nowp triads (cdr nowp)) |
| 244 : |
|
|
(i 0 (1+ i)) |
| 245 : |
|
|
(found nil)) |
| 246 : |
|
|
((or found (endp nowp)) (cons (- len i) found)) |
| 247 : |
|
|
(let* ((pr (car nowp)) |
| 248 : |
|
|
(vec (second pr)) |
| 249 : |
|
|
(prdef (third pr))) |
| 250 : |
|
|
(setq range (range-of-primitive-of-jp prdef vec)) |
| 251 : |
|
|
(if (inrange (list x0 y0) range) |
| 252 : |
|
|
(setq found pr))))) |
| 253 : |
|
|
|
| 254 : |
|
|
(setq whichprim (cdr whichprim-nth) |
| 255 : |
|
|
nth-prim (car whichprim-nth)) |
| 256 : |
|
|
(if (null whichprim) |
| 257 : |
|
|
(progn (beep win) joint-prim-def) |
| 258 : |
|
|
(catch 'exit-move-pjp |
| 259 : |
|
|
(let ((prim-n (car whichprim)) |
| 260 : |
|
|
(prim-vec (cadr whichprim)) |
| 261 : |
|
|
(prim-def (caddr whichprim))) |
| 262 : |
|
|
|
| 263 : |
|
|
(let* ((minx (caar range)) |
| 264 : |
|
|
(miny (cadar range)) |
| 265 : |
|
|
(maxx (caadr range)) |
| 266 : |
|
|
(maxy (cadadr range)) |
| 267 : |
|
|
(xfar nil) |
| 268 : |
|
|
(yfar nil) |
| 269 : |
|
|
(xnear nil) |
| 270 : |
|
|
(ynear nil)) |
| 271 : |
|
|
|
| 272 : |
|
|
(if (greaterp (difference x0 minx) (difference maxx x0)) |
| 273 : |
|
|
(setq xfar minx xnear maxx) |
| 274 : |
|
|
(setq xfar maxx xnear minx)) |
| 275 : |
|
|
(if (greaterp (difference y0 miny) (difference maxy y0)) |
| 276 : |
|
|
(setq yfar miny ynear maxy) |
| 277 : |
|
|
(setq yfar maxy ynear miny)) |
| 278 : |
|
|
|
| 279 : |
|
|
(draw-corner-xorbox-win! win minx miny maxx maxy) |
| 280 : |
|
|
(draw-corner-dashbox-win! win minx miny maxx maxy) |
| 281 : |
|
|
|
| 282 : |
|
|
(setq %pred-position% nil) |
| 283 : |
|
|
(setq %end% nil) |
| 284 : |
|
|
|
| 285 : |
|
|
(put-winprop win |
| 286 : |
|
|
'button-press-handler |
| 287 : |
|
|
#'(lambda (win code x y) |
| 288 : |
|
|
(setq %end% (if (eq code *end-mode*) |
| 289 : |
|
|
'exit-move-some |
| 290 : |
|
|
t)) |
| 291 : |
|
|
(setq %pred-position% (list x y)))) |
| 292 : |
|
|
|
| 293 : |
|
|
(put-winprop win |
| 294 : |
|
|
'motion-notify-handler |
| 295 : |
|
|
`(lambda (win x y) |
| 296 : |
|
|
(drag-corner-boxes-win! win ,xfar ,yfar x y))) |
| 297 : |
|
|
|
| 298 : |
|
|
(setf (window-event-mask win) '(:exposure |
| 299 : |
|
|
:button-press |
| 300 : |
|
|
:button-release |
| 301 : |
|
|
:pointer-motion)) |
| 302 : |
|
|
|
| 303 : |
|
|
|
| 304 : |
|
|
(loop-disable-other-win win #'(lambda () %end%)) |
| 305 : |
|
|
|
| 306 : |
|
|
(if (eq %end% 'exit-move-some) (throw 'exit-move-pjp nil)) |
| 307 : |
|
|
|
| 308 : |
|
|
(setf (window-event-mask win) save-event-mask) |
| 309 : |
|
|
(put-winprop win |
| 310 : |
|
|
'button-press-handler |
| 311 : |
|
|
save-bp-handler) |
| 312 : |
|
|
(put-winprop win |
| 313 : |
|
|
'button-release-handler |
| 314 : |
|
|
save-br-handler) |
| 315 : |
|
|
(put-winprop win |
| 316 : |
|
|
'motion-notify-handler |
| 317 : |
|
|
save-mn-handler) |
| 318 : |
|
|
|
| 319 : |
|
|
(let* ((src joint-prim-def) |
| 320 : |
|
|
(vecs (cadadr src)) |
| 321 : |
|
|
(v (nth nth-prim vecs)) |
| 322 : |
|
|
(vec (vector (vector-length v) v)) |
| 323 : |
|
|
(from (list (list xfar yfar) (list xnear ynear))) |
| 324 : |
|
|
(to (list (list xfar yfar) %pred-position%)) |
| 325 : |
|
|
(newvec (affine-affine (resolve-affine from to) |
| 326 : |
|
|
vec))) |
| 327 : |
|
|
|
| 328 : |
|
|
(setf (nth nth-prim vecs) vec) |
| 329 : |
|
|
|
| 330 : |
|
|
(do ((i 0 (1+ i))) |
| 331 : |
|
|
((>= i 6)) |
| 332 : |
|
|
(vset vec i (vref newvec i))) |
| 333 : |
|
|
|
| 334 : |
|
|
(clear-win win) |
| 335 : |
|
|
(draw-joint-vecs-primname-win win src) |
| 336 : |
|
|
(redraw-win win) |
| 337 : |
|
|
|
| 338 : |
|
|
src))))))) |
| 339 : |
|
|
|
| 340 : |
|
|
|
| 341 : |
|
|
|
| 342 : |
|
|
|
Annotation of /lisp/tools/edjoint.l
Parent Directory
| 
Revision Log