通用函数 几何算法 点

2018-08-24 15:09 阅读(?)评论(0)

通用函数 几何算法 点.lsp





;;;=================================================================*
;;; 二维点  由  直角坐标系  转到  极坐标系                          *
(defun XY->RA (XY)
    (list (distance '(0 0) XY) (angle '(0 0) XY))
)
;;;=================================================================*
;;; 二维点  由  极坐标系  转到  直角坐标系                          *
(defun RA->XY (RA)
    (list (* (car RA) (cos (cadr RA)))
	  (* (car RA) (sin (cadr RA)))
    )
)
;;;=================================================================*
;;;极坐标系中二维点  旋转                                           *
(defun RA-ROTATE (RA ANG)
    (list (car RA) (+ (cadr RA) ANG))
)
;;;=================================================================*
;;;直角坐标系中二维点  平移                                         *
(defun XY-MOVE (XY XY0)
    (mapcar '+ XY XY0)
)
;;;=================================================================*
;;; 直角坐标系中二维点  绕指定基点  旋转  指定角度                  *
(defun ZL-ROTATE (PT BASEPOINT ROTATIONANGLE)
    (mapcar
	'+
	(RA->XY
	    (RA-ROTATE
		(XY->RA (mapcar '- PT BASEPOINT))
		ROTATIONANGLE
	    )
	)
	BASEPOINT
    )
)




 ;|;;
问题的提出:
曹*(****00466) 17:03:52
一个点集lst,基点p,角度ang
将点集lst以p为基点旋转ang度,大家有没有最简练的函数
;;|;
;;;\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\*
;;; 露水2 的方法,借助polar                        *
;;;================================================*
;;; 直角坐标系中二维点  绕指定基点  旋转  指定角度 *
(defun PT-ROTATE (PT BASEPOINT ANG)
    (polar BASEPOINT
	   (+ ANG (angle BASEPOINT PT))
	   (distance BASEPOINT PT)
    )
)


;;;=================================================================*
;;;=================================================================*
;;;功能:二维平面上,计算  指定点  到直线的距离                     *
;;;参数:PT -----指定点                                             *
;;;      pt0-----直线上一点                                         *
;;;      pt1-----直线上第二点                                       *
;;;返回:距离值。左正右负,0表示在直线上。                          *
;;;思路:先三点求面积,然后面积除以0.5倍直线段长度,即可得到结果。  *
;;;测试:(ZL-POINT-GETDIST-TOLINE '(3  5) '(0 1)'( 10 0))           *
;;;      (ZL-POINT-GETDIST-TOLINE '(3 -5) '(0 1)'( 10 0))           *
;;;日期:zml84 于 2009-05-13                                        *
(defun ZL-POINT-GETDIST-TOLINE (PT PT0 PT1 / AREA DIST)
    ;;二维化
    (setq pt (list (car pt)(cadr pt))
          pt0 (list (car pt0)(cadr pt0))
          pt1 (list (car pt1)(cadr pt1))
    )
    ;;面积
    (setq AREA (apply '+
		      (mapcar
			  '(lambda (A B)
			       (- (* 0.5 (car A) (cadr B))
				  (* 0.5 (cadr A) (car B))
			       )
			   )
			  (list PT PT0 PT1)
			  (list PT0 PT1 PT)
		      )
	       )
    )
    ;;直线段长度
    (setq DIST (distance PT0 PT1))
    ;;返回
    (if	(equal DIST 0 1e-10)
	(distance PT PT0)
	(/ AREA 0.5 DIST)
    )
)
;;;=================================================================*
;;;功能:二维平面上,计算  点到直线  的垂足                         *
;;;返回:垂足点坐标
(defun zl-inters-PT-LINE (pt ptA ptB)
    (inters pta
	    ptb
	    pt
	    (polar pt (+ (angle pta ptb) (* 0.5 pi)) 10.0)
	    nil
    )
)
;;;=================================================================*
;;;功能:二维平面上,计算  直线与圆  的交点                         *
;;;参数: pta -----直线端点1                                         *
;;;       ptb -----直线端点2                                         *
;;;       ptc -----圆心坐标                                          *
;;;       R   -----圆半径                                            *
;;;返回:两个点
(defun zl-inters-Line-Circle (pta ptb ptc R / dist pt_tmp ang dist2)
    ;;参数整理
   (setq r (abs r))

    (if	(and (setq dist (ZL-POINT-GETDIST-TOLINE PTc PTa PTb)) ;_圆心到直线距离
	     (setq dist (abs dist))
	     (<= dist r) ;_相割或相切
	)
	(progn
	    (setq pt_tmp (zl-inters-PT-LINE ptc ptA ptB) ;_垂足点
		  ang	 (angle pta ptb)
		  dist2	 (sqrt (- (* r r) (* dist dist)))
	    )
	    ;;返回
	    (list (polar pt_tmp ang dist2)
		  (polar pt_tmp ang (- dist2))
	    )
	)
    )
)
;;;=================================================================*
;;测试:直线圆相交
;;;(defun c:tt ()
;;;    (if	(and (setq en1 (car (entsel "\n点取直线: ")))
;;;	     (setq ent1 (entget en1))
;;;	     (setq pta (cdr (assoc 10 ent1)))
;;;	     (setq ptb (cdr (assoc 11 ent1)))
;;;
;;;	     (setq en2 (car (entsel "\n点取圆: ")))
;;;	     (setq ent2 (entget en2))
;;;	     (setq ptc (cdr (assoc 10 ent2)))
;;;	     (setq R (cdr (assoc 40 ent2)))
;;;
;;;	     (setq tmp (zl-inters-Line-Circle pta ptb ptc R ))
;;;	)
;;;	(command "_.line" "non"(trans (car tmp) 0 1) "non"(trans (cadr tmp) 0 1) "")
;;;    )
;;;)
;;;=================================================================*
;;;功能:二维平面上,计算  圆与圆  的交点                           *
;;;返回:两个点
(defun zl-inters-Circle-Circle
       (ptc1 R1 ptc2 R2 / dist  ang tmp ang1)
    (if	(and (setq dist (distance PTc1 PTc2)) ;_圆心到圆心距离
	     (<= (abs (- r1 r2)) dist (+ r1 r2)) ;_相割或相切
	)
	(progn
	    (setq ang (angle ptc1 ptc2))
	    (setq tmp  (/ (+ (* dist dist) (* R1 R1) (* -1 R2 R2))
			  (* 2 dist R1)
		       )
		  ang1 (ACOS tmp)
	    )
	    ;;返回
	    (list (polar ptc1 (+ ang ang1) R1)
		  (polar ptc1 (- ang ang1) R1)
	    )
	)
    )
)
;;;=================================================================*
;;测试:圆圆相交
;;;(defun c:tt ()
;;;    (if	(and (setq en1 (car (entsel "\n点取圆1: ")))
;;;	     (setq ent1 (entget en1))
;;;	     (setq ptc1 (cdr (assoc 10 ent1)))
;;;	     (setq R1 (cdr (assoc 40 ent1)))
;;;
;;;	     (setq en2 (car (entsel "\n点取圆2: ")))
;;;	     (setq ent2 (entget en2))
;;;	     (setq ptc2 (cdr (assoc 10 ent2)))
;;;	     (setq R2 (cdr (assoc 40 ent2)))
;;;
;;;	     (setq tmp (zl-inters-Circle-Circle ptc1 R1 ptc2 R2))
;;;	)
;;;	(command "_.line" "non"(trans (car tmp) 0 1) "non"(trans (cadr tmp) 0 1) "")
;;;    )
;;;)
;;;=================================================================*
;;;=================================================================*
;;;功能:判断点在多边形的位置
;;;参数:LST_PT  ----多边形轮廓线二维点表
;;;      PT      ----欲考察的点位
;;;      FUZZ    ----控制精度
;;;返回:-1 表示在多边形外部;
;;;       0 表示在多边形顶点;
;;;       1 表示在多边形边上。
;;;       2 表示在多边形内部。
(defun ZML-P (LST_PT PT	FUZZ / ZML-P-01	TEST_0 TEST_1 PT0 I0 PT1 I1 I
	      SUM II TMP)
    ;;===========================
    (defun ZML-P-01 (PTN PT FUZZ / X Y II)
	;;1.计算相对坐标
	(setq PTN (mapcar '- PTN PT))
	;;2.划分象限
	;;(x轴正半轴属于1象限 , y轴正半轴属于2象限...)
	(setq X	(car PTN)
	      Y	(cadr PTN)
	)
	(setq II (cond
		     ((and (> X 0)
			   (>= Y 0)
		      )
		      1
		     )
		     ((and (<= X 0)
			   (> Y 0)
		      )
		      2
		     )
		     ((and (< X 0)
			   (<= Y 0)
		      )
		      3
		     )
		     ((and (>= X 0)
			   (< Y 0)
		      )
		      4
		     )
		 ) ;_结束cond
	)
	(list II X Y)
    )
    ;;===========================

    ;;1.初始化
    (setq TEST_0 NIL) ;_是否在顶点的标识
    (setq TEST_1 NIL) ;_是否在边上的标识
    (setq PT0 (ZML-P-01 (last LST_PT) PT FUZZ)
	  I0  (car PT0)
	  PT0 (cdr PT0)
    )
    (setq I 0
	  SUM 0
    )
    (if	(or (equal PT0 '(0 0) FUZZ)
	    (equal PT0 '(0 0 0) FUZZ)
	)
	(setq TEST_0 t) ;_在顶点上
    )
    ;;2.循环执行
    (while (and	(not TEST_0)
		(not TEST_1)
		(< I (length LST_PT))
	   )
	;;2.1.计算象限
	(setq PT1 (ZML-P-01 (nth I LST_PT) PT FUZZ)
	      I1  (car PT1)
	      PT1 (cdr PT1)
	)
	;;2.2.判断点的位置
	(cond
	    ((or (equal PT1 '(0 0) FUZZ)
		 (equal PT1 '(0 0 0) FUZZ)
	     )
	     (setq TEST_0 t) ;_在顶点上
	    )
	    ;;4.考察相邻的点的象限关系	    
	    ((and (setq II (- I1 I0))
		  (= II 0)
	     )
	     ()
	    )
	    ((or (= II 1)
		 (= II -3)
	     )
	     (setq SUM (1+ SUM))
	    )

	    ((or (= II -1)
		 (= II 3)
	     )
	     (setq SUM (1- SUM))
	    )
	    ;;_对角象限
	    (t
	     (setq TMP (- (* (car PT0) (cadr PT1))
			  (* (cadr PT0) (car PT1))
		       )
	     )
	     (cond ((equal TMP 0 FUZZ)
		    (setq TEST_1 t) ;_在边上
		   )
		   ((> TMP 0)
		    (setq SUM (+ SUM 2))
		   )
		   (t
		    (setq SUM (- SUM 2))
		   )
	     )
	    )
	) ;_结束cond
;;;	(princ "\nsum:")
;;;	(princ SUM)
;;;	(princ "  ")
	(setq i	  (1+ i)
	      I0  I1
	      PT0 PT1
	)
    ) ;_结束while

    ;;3.返回
    (cond (TEST_0
	   0 ;_返回0 表示在顶点
	  )
	  (TEST_1
	   1 ;_返回1 表示在边上
	  )
	  ((= SUM 0)
	   -1 ;_返回-1 表示在外部
	  )
	  ((= (rem SUM 4) 0)
	   2 ;_返回2 表示在内部
	  )
	  (t
	   -1 ;_返回-1 表示在外部
	  )
    ) ;_结束cond
) ;_结束 defun
;;;=================================================================*
  最后修改于 2020-02-03 14:38    阅读(?)评论(0)
 
表  情:
加载中...
 

请各位遵纪守法并注意语言文明