Annotation of /lisp/tools/whichprim.lAnnotation of /lisp/tools/whichprim.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | ;; ----------- ;; |
| 2 : | ;; whichprim.l ;; | ||
| 3 : | ;; ----------- ;; | ||
| 4 : | |||
| 5 : | (defun hegemony-of-primitive (prim-exp (vec #(1.0 0.0 0.0 1.0 0.0 0.0))) | ||
| 6 : | (if (or (symbolp prim-exp) (stringp prim-exp)) | ||
| 7 : | (setq prim-exp (applykanji prim-exp))) | ||
| 8 : | (let* ((prim (affine-translate-pure-primitive prim-exp vec)) | ||
| 9 : | (points (car prim)) | ||
| 10 : | (xmax) (xmin) (ymax) (ymin)) | ||
| 11 : | (let* ((p1 (car points)) | ||
| 12 : | (x1 (car p1)) | ||
| 13 : | (y1 (cadr p1))) | ||
| 14 : | (setq xmax x1 xmin x1 ymax y1 ymin y1)) | ||
| 15 : | (do ((p (cdr points) (cdr p))) | ||
| 16 : | ((null p)) | ||
| 17 : | (let* ((p1 (car p)) | ||
| 18 : | (x (car p1)) | ||
| 19 : | (y (cadr p1))) | ||
| 20 : | (setq xmin (min x xmin) | ||
| 21 : | xmax (max x xmax) | ||
| 22 : | ymin (min y ymin) | ||
| 23 : | ymax (max y ymax)))) | ||
| 24 : | (list (fix xmin) (fix xmax) (fix ymin) (fix ymax)))) | ||
| 25 : | |||
| 26 : | (defun in-square (x y reg) | ||
| 27 : | (and (< (first reg) x) | ||
| 28 : | (< x (second reg)) | ||
| 29 : | (< (third reg) y) | ||
| 30 : | (< y (fourth reg)))) | ||
| 31 : | |||
| 32 : | (defun sub-primitive-info-current-xy (x y) | ||
| 33 : | (let ((ret nil)) | ||
| 34 : | (do ((p edittee-sub-primitives (cdr p))) | ||
| 35 : | ((null p) ret) | ||
| 36 : | (let* ((nowprim (car p)) | ||
| 37 : | (name (car nowprim)) | ||
| 38 : | (region (cadr nowprim))) | ||
| 39 : | (when (in-square x y region) | ||
| 40 : | (setq ret (cons name region)) | ||
| 41 : | (exit ret)))) | ||
| 42 : | ret)) | ||
| 43 : | |||
| 44 : | (defun draw-xor-primitive-win! (win prim-info) | ||
| 45 : | (let* ((x0 (second prim-info)) | ||
| 46 : | (x1 (third prim-info)) | ||
| 47 : | (y0 (fourth prim-info)) | ||
| 48 : | (y1 (fifth prim-info)) | ||
| 49 : | (xx0 (// (+ (* 9 x0) x1) 10)) | ||
| 50 : | (xx1 (// (+ (* 9 x1) x0) 10)) | ||
| 51 : | (yy0 (// (+ (* 9 y0) y1) 10)) | ||
| 52 : | (yy1 (// (+ (* 9 y1) y0) 10))) | ||
| 53 : | (comment print (list xx0 yy0 xx1 yy1)) | ||
| 54 : | (draw-corner-xorbox-win! win xx0 yy0 xx1 yy1))) | ||
| 55 : | |||
| 56 : | (setq %sub-primitive-name% nil) | ||
| 57 : | (defun nearest-sub-primitive-boxed (win x y) | ||
| 58 : | (let* ((prim (sub-primitive-info-current-xy x y))) | ||
| 59 : | (cond ((and prim (not (equal %sub-primitive-name% prim))) | ||
| 60 : | (comment print prim) | ||
| 61 : | (if %sub-primitive-name% | ||
| 62 : | (draw-xor-primitive-win! win %sub-primitive-name%)) | ||
| 63 : | (draw-xor-primitive-win! win prim) | ||
| 64 : | (setq %sub-primitive-name% prim))))) | ||
| 65 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |