[wadalabfont-kit] / lisp / tools / whichprim.l  

Annotation of /lisp/tools/whichprim.l

Parent Directory | Revision Log

Revision: 1.2 - (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