Annotation of /skeleton-edit/edjoint.lAnnotation of /skeleton-edit/edjoint.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 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 : | (draw-skeleton-win win (affine-translate-pure-primitive s v)) | ||
| 71 : | (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 : | (draw-nikuduked-skeleton-win! | ||
| 92 : | 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 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |