View of /lisp/tools/whichprim.l

Parent Directory

Revision Log

change to CVS wadalab font project

;; ----------- ;;
;; whichprim.l ;;
;; ----------- ;;

(defun hegemony-of-primitive (prim-exp (vec #(1.0 0.0 0.0 1.0 0.0 0.0)))
  (if (or (symbolp prim-exp) (stringp prim-exp))
      (setq prim-exp (applykanji prim-exp)))
  (let* ((prim (affine-translate-pure-primitive prim-exp vec))
	 (points (car prim))
	 (xmax) (xmin) (ymax) (ymin))
    (let* ((p1 (car points))
	   (x1 (car p1))
	   (y1 (cadr p1)))
      (setq xmax x1 xmin x1 ymax y1 ymin y1))
    (do ((p (cdr points) (cdr p)))
	((null p))
	(let* ((p1 (car p))
	       (x (car p1))
	       (y (cadr p1)))
	  (setq xmin (min x xmin)
		xmax (max x xmax)
		ymin (min y ymin)
		ymax (max y ymax))))
    (list (fix xmin) (fix xmax) (fix ymin) (fix ymax))))

(defun in-square (x y reg)
  (and (< (first reg) x)
       (< x (second reg))
       (< (third reg) y)
       (< y (fourth reg))))

(defun sub-primitive-info-current-xy (x y)
  (let ((ret nil))
    (do ((p edittee-sub-primitives (cdr p)))
	((null p) ret)
	(let* ((nowprim (car p))
	       (name (car nowprim))
	       (region (cadr nowprim)))
	  (when (in-square x y region)
	    (setq ret (cons name region))
	    (exit ret))))
    ret))

(defun draw-xor-primitive-win! (win prim-info)
  (let* ((x0 (second prim-info))
	 (x1 (third prim-info))
	 (y0 (fourth prim-info))
	 (y1 (fifth prim-info))
	 (xx0 (// (+ (* 9 x0) x1) 10))
	 (xx1 (// (+ (* 9 x1) x0) 10))
	 (yy0 (// (+ (* 9 y0) y1) 10))
	 (yy1 (// (+ (* 9 y1) y0) 10)))
    (comment print (list xx0 yy0 xx1 yy1))
    (draw-corner-xorbox-win! win xx0 yy0 xx1 yy1)))

(setq %sub-primitive-name% nil)
(defun nearest-sub-primitive-boxed (win x y)
  (let* ((prim (sub-primitive-info-current-xy x y)))
    (cond ((and prim (not (equal %sub-primitive-name% prim)))
	   (comment print prim)
	   (if %sub-primitive-name% 
	       (draw-xor-primitive-win! win %sub-primitive-name%))
	   (draw-xor-primitive-win! win prim)
	   (setq %sub-primitive-name% prim)))))