;;mode1
;;point in rection
;;点 P 是否在多边形 PM 内
;;If 'p' is in 'pm', return T.
;;'mx' is a very long distance.
(defun isInorOut (p pm / i p1 p2 tf tf1 tf2 px jp ret)
(setq px (list (+ 1e+100 (car p)) (cadr p))
p1 (last pm)
i -1
)
(while (and (not ret)
(setq p2 (nth (setq i (1+ i)) pm))
)
(if (setq jp (inters px p p1 p2))
(if (equal (car jp) (car p) 0.0001)
(setq ret t)
(setq tf2 (if (> (cadr p1) (cadr p2)) 1 0)
tf (if (= tf1 tf2) tf (not tf))
tf1 tf2
)
)
(setq tf1 nil)
)
(setq p1 p2)
)
(cond
(ret 0) ;线上
(tf 1) ;内
(t -1) ;外
)
)
;;mode2方法2
;;点是否在多边形内
(defun ptinpm (pt lst / i p1 p2 an anl ret)
(setq i -1 p1 (last lst))
(while (and (not ret)
(setq p2 (nth (setq i (1+ i)) lst))
)
(cond
((equal p2 pt 1e-4) (setq ret t))
(t
(setq an (- (angle pt p1) (angle pt p2)))
(if (equal pi (abs an) 1e-4)
(setq ret t)
(setq anl (cons (rem an PI) anl))
)
)
)
(setq p1 p2)
)
(cond
(ret 0) ;线上;
(t
(if (equal PI (abs (apply '+ anl)) 1e-4)
1 ;内;
-1 ;外;
)
)
)
)
;;test program
(DEFUN C:tt (/ Curve Pt lst a b c)
(IF (SETQ Curve (CAR (ENTSEL "\n选择一条曲线:")))(progn
(setq lst (MAPCAR (FUNCTION CDR)
(VL-REMOVE-IF (FUNCTION (LAMBDA (x) (/= 10 (CAR x)))) (entget Curve))
)
)
(WHILE (SETQ Pt (GETPOINT "\n点取测试点:"))
(setq pt (list (car pt) (cadr pt))
c 1
)
(setq a (ptinpm Pt lst))
(princ "\nxd-point_inm:") (princ (cond ((= 0 a) "线上")
((= 1 a) "内")
(t "外")))
(setq a (xd-point_inm Pt lst))
(princ "\nptinpm:") (princ (cond ((= 0 a) "线上")
((= 1 a) "内")
(t "外")))
)
))
(PRINC)
)
posted on 2008-03-12 21:31
深藏记忆 阅读(399)
评论(2) 编辑 收藏 所属分类:
Vlisp之韵