明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: highflybird

多边形的最大内接圆

    [复制链接]
发表于 2012-8-1 14:22:27 | 显示全部楼层
是源码,就学习下,谢谢楼主。
发表于 2012-8-1 14:46:27 | 显示全部楼层
算法绝对经典
发表于 2012-8-1 15:19:25 | 显示全部楼层
支持分享、不错啊。。
发表于 2012-8-1 22:00:37 | 显示全部楼层
学习中........什么时候能达到呢..
发表于 2012-8-1 23:17:30 | 显示全部楼层
感谢分享,好好学习~
发表于 2012-8-2 17:23:55 | 显示全部楼层
21楼的问题,我也同问。期待highflybird 兄有解决办法。
发表于 2012-8-2 20:17:57 | 显示全部楼层
GP方法本身存在2个问题:
1、当第1步STEP1的数量不是足够大时,可能得不到正确结果;
2、当存在多个最大圆时得不到正确结果;
Saften方法存在2个问题:
1、自交曲线存在点在曲线内误判的可能。
2、运行效率低下。
以下GP模式改进版,支持自交曲线;(有待进一步改进得到最更多最大圆)
  1. ;;; maximum circle inscribed in a closed polyline
  2. ;;; Gian Paolo Cattaneo
  3. (defun C:TesT (/  POLY    POLY_vl   Dx        Dy
  4.         Lp  List_vert_poly      list_p_int
  5.         P_center  dist    step1     step2     t1
  6.         t2
  7.        )
  8.   (prompt "\nSelect Polyline: ")
  9.   (if (setq POLY (ssname (ssget ":S" '((0 . "LWPOLYLINE"))) 0))
  10.     (progn
  11.       (setq i  1
  12.      t1 (getvar "MilliSecs")
  13.       )
  14.       (setq step1 40)   ;--> grid_1
  15.       (setq step2 20)   ;--> grid_2
  16.       (setq list_vert_poly (LWPoly->List POLY 10))
  17.       (grid_1)
  18.       (Point_int)
  19.       (grid+)
  20.       (Point_center)
  21.       (repeat 2
  22. (grid_2)
  23. (Point_center)
  24.       )
  25.       (entmake
  26. (list
  27.    (cons 0 "CIRCLE")
  28.    (cons 10 P_center)
  29.    (cons 40 dist)
  30. )
  31.       )
  32.       (setq t2 (getvar "MilliSecs"))
  33.       (princ (strcat "time = " (rtos (- t2 t1) 2 0) " MilliSecs"))
  34.       (princ)
  35.     )
  36.   )
  37. )
  38. ;; Restituisce una griglia di punti all'interno del getboundingbox della poly selezionata
  39. ;; Returns a grid of points within the BoundingBox of the selected poly
  40. (defun grid_1 (/   p1 p2 X1 Y1 l1)
  41.   (vla-getboundingbox (vlax-ename->vla-object POLY) 'p1 'p2)
  42.   (setq p1 (vlax-safearray->list p1)
  43. p2 (vlax-safearray->list p2)
  44. p1 (list (car p1) (cadr p1))
  45. p2 (list (car p2) (cadr p2))
  46.   )
  47.   (setq Dx (/ (- (car p2) (car p1)) step1))
  48.   (setq Dy (/ (- (cadr p2) (cadr p1)) step1))  
  49.   (setq Lp (list p1)
  50. X1 (car p1)
  51. Y1 (cadr p1)
  52.   )
  53.   (repeat step1
  54.     (setq Lp (cons (list (setq X1 (+ X1 Dx)) Y1) Lp))
  55.   )
  56.   (setq Lp (list Lp))
  57.   (repeat step1
  58.     (setq  Lp (cons (mapcar (function (lambda (x)
  59.            (list (car x) (+ (cadr x) Dy))
  60.          )
  61.       )
  62.       (car lp)
  63.      )  Lp)
  64.     )
  65.   )
  66.   (setq Lp (apply (function append) Lp))
  67. )

  68. ;; Restituisce una griglia di punti intorno al punto centrale (provvisorio)
  69. ;; Returns a grid of points around the center point (provisional)
  70. (defun grid_2 (/ P1_ P> n)
  71.   (setq list_p_int nil)
  72.   (setq P1_ (list (- (car P_center) (* Dx 2))
  73.     (- (cadr P_center) (* Dy 2))
  74.      )
  75.   )
  76.   (setq Dx (/ (* 4 Dx) step2))
  77.   (setq Dy (/ (* 4 Dy) step2))
  78.   (setq n 0)
  79.   (setq P> P1_)
  80.   (setq list_p_int (list P1_))
  81.   (repeat (* (1+ step2) step2)
  82.     (setq P> (list (+ (car P>) Dx) (cadr P>)))
  83.     (setq list_p_int (cons P> list_p_int))
  84.     (setq n (1+ n))
  85.     (if (= n step2)
  86.       (progn
  87. (setq n 0)
  88. (setq P1_ (list (car P1_) (+ (cadr P1_) Dy)))
  89. (setq P> P1_)
  90. (setq list_p_int (cons P> list_p_int))
  91.       )
  92.     )
  93.   )
  94. )

  95. ;; restituisce la lista dei punti interni ad un poligono
  96. ;; dati:  - lista coordinate dei punti -> Lp
  97. ;;        - lista coordinate vertici poligono -> list_vert_poly
  98. ;; Returns the list of points inside the polyline
  99. (defun Point_int (/ n Pr cont attr p# Pa Pa_ Pb)
  100.   (setq list_p_int nil)
  101.   (foreach Pr Lp
  102.     (if (> (Point-in-ClosedCurve-p list_vert_poly Pr) 0)
  103.       (setq list_p_int (cons Pr list_p_int))
  104.     )
  105.   )
  106. )
  107. ;; Infittisce la griglia inserendo altri punti
  108. ;; nel centro delle diagonali tra i punti interni
  109. ;; Insert points (interior) to increase the density of the grid
  110. (defun grid+ (/ G+)
  111.   (setq G+
  112.   (mapcar '(lambda (x)
  113.       (list (+ (car x) (/ Dx 2)) (+ (cadr x) (/ Dy 2)))
  114.     )
  115.    list_p_int
  116.   )
  117.   )
  118.   (setq list_p_int (append G+ list_p_int))
  119. )

  120. ;; Da una lista di punti restituisce quello più lontano da un oggetto
  121. ;; dati:  - lista dei punti -> list_p_int
  122. ;;        - oggetto -> POLY_vl
  123. ;; Returns the farthest point from the polyline
  124. (defun Point_center (/ Pa n Pvic)
  125.   (setq Dist 1e-7)
  126.   (setq P_center nil)
  127.   (foreach Pa list_p_int
  128.     (setq Pvic (vlax-curve-getClosestPointTo Poly Pa))
  129.     (if (> (distance Pa Pvic) Dist)
  130.       (progn
  131. (setq P_center Pa)
  132. (setq Dist (distance Pa Pvic))
  133.       )
  134.     )
  135.   )
  136. )
  137. ;;
  138. (defun LWPoly->List (en acc / a b vetex bu p1 p2 l r ang an1 N)
  139.   ;;Acc --- 0 ~ 99
  140.   (setq ent (entget en))
  141.   (while (setq ent (member (assoc 10 ent) ent))
  142.     (setq b (cons (cdar ent) b)
  143.    ent (member (assoc 42 ent) ent)
  144.    b (cons (cdar ent) b)
  145.    ent (cdr ent)
  146.    vetex (cons b vetex)
  147.    b nil
  148.     )
  149.   )
  150.   (while vetex
  151.     (setq a (car vetex)
  152.    vetex (cdr vetex)
  153.    bu (car a)
  154.    p1 (cadr a)
  155.     )
  156.     (if l
  157.       (setq p2 (car l))
  158.       (setq p2 (cadr (last vetex))
  159.      l  (cons p2 l)
  160.       )
  161.     )
  162.     (if (equal bu 0 1e-6)
  163.       (setq l (cons p1 l))
  164.       (progn
  165. (setq ang (* 2 (atan bu))
  166.        r   (/ (distance p1 p2)
  167.        (* 2 (sin ang))
  168.     )
  169.        c   (polar p1
  170.     (+ (angle p1 p2) (- (/ pi 2) ang))
  171.     r
  172.     )
  173.        r   (abs r)
  174.        ang (abs (* ang 2.0))
  175.        N   (abs (fix (/ ang 0.0174532925199433)))
  176.        N   (min N (1+ Acc))
  177. )
  178. (if (= N 0)
  179.    (setq l (cons p1 l))
  180.    (progn
  181.      (setq an1 (/ ang N)
  182.     ang (angle c p2)
  183.      )
  184.      (if (not (minusp bu))
  185.        (setq an1 (- an1))
  186.      )
  187.      (repeat (1- N)
  188.        (setq ang (+ ang an1))
  189.        (setq l (cons (polar c ang r) l))
  190.      )
  191.      (setq l (cons p1 l))
  192.    )
  193. )
  194.       )
  195.     )
  196.   )
  197.   l
  198. )
  199. ;;
  200. ;; This method suggest by Lee Mac from http://en.wikipedia.org/wiki/Winding_number
  201. ;; function : determin the point position with the closed curve by widding-number method
  202. ;; l  ---- point set of a Closed Curve , First item must same as Last item .
  203. ;; pt ---- a given point to determin position with the Closed Curve
  204. ;;; return a num
  205. ;;;           ----  -1  pt out of curve
  206. ;;;           ----   0  pt at curve
  207. ;;;           ----   1  pt in curve
  208. ;; by GSLS(SS) 2012-08-02
  209. (defun Point-in-ClosedCurve-p (l pt / ang p1 p2 n r at)
  210.   (setq ang 0.0
  211. at  nil
  212.   )
  213.   (while (and (cadr l) (not at))
  214.     (setq p1 (car l)
  215.    p2 (cadr l)
  216.    l  (cdr l)
  217.     )
  218.     (if (equal p1 p2 1e-6)
  219.       (setq an1 0.0)
  220.       (setq an1
  221.       ((lambda (/ a b c d e f g)
  222.   (setq b (distance p1 pt)
  223.         c (distance p2 pt)
  224.         a (distance p1 p2)
  225.         d (- (* (- (car p1) (car pt)) (- (cadr p2) (cadr pt)))
  226.       (* (- (car p2) (car pt)) (- (cadr p1) (cadr pt)))
  227.    )
  228.   )
  229.   (if (and (equal d 0.0 1e-4) (setq at T))
  230.     pi
  231.     (progn
  232.       (setq
  233.         e (+ (* b b) (* c c) (* -1 a a))
  234.         f (abs ((lambda (x)
  235.     (cond ((equal x 0.0 1e-6)(* pi 0.5))
  236.           ((equal x 1.0 1e-6)0.0)
  237.           ((atan (/ (sqrt (- 1 (* x x)))
  238.       x
  239.           )
  240.            ))
  241.     ))
  242.           (/ e 2. b c)
  243.         )
  244.    )
  245.         g (if (> d 0)  1  -1)
  246.       )
  247.       (if (< e 0)
  248.         (* g (- pi f))
  249.         (* g f)
  250.       )
  251.     )
  252.   )
  253.        )
  254.       )
  255.       )
  256.     )
  257.     (setq ang (+ ang an1))
  258.   )
  259.   ;;deal widding number  
  260.   (if at
  261.     0
  262.     (progn
  263.       (setq n (/ ang 2. pi))
  264.       (if (equal (fix n) n 1e-4)
  265. (setq n (fix n))
  266. (if (and (> n 0) (equal (1+ (fix n)) n 1e-4))
  267.    (setq n (1+ (fix n)))
  268.    (if (and (< n 0) (equal (1- (fix n)) n 1e-4))
  269.      (setq n (1- (fix n)))
  270.      (setq n (fix n))
  271.    )
  272. )
  273.       )
  274.       (if (= (rem n 2) 0)
  275. -1
  276. 1
  277.       )
  278.     )
  279.   )
  280. )
  281. ;|
  282. (defun c:t1 ( / en l n)
  283.   (setq en (car (entsel))
  284. l (LWPoly->List en 10))
  285.   (while (setq pt (getpoint ))
  286.     (setq n (Point-in-ClosedCurve-p l pt))
  287.    (cond ((> n 0)
  288.      (alert "IN"))
  289.   ((= n 0)
  290.      (alert "AT"))
  291.   (t
  292.    (alert "OUT")))))
  293.    |;

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2012-8-2 20:19:52 | 显示全部楼层
对于椭圆及SPLine可以用下面函数取点:
  1. ;; get point set of a closed curve by order
  2. ;; this function you improve by yourself acordding your need .
  3. (defun get-closed-curve-pts (en / ent et)
  4.   ;;by GSLS(SS)
  5.   (setq
  6.     ent        (entget en)
  7.     et        (cdr (assoc 0 ent))
  8.   )
  9.   (cond
  10.     ((= et "LWPOLYLINE")
  11.      ((lambda (/ a b vetex bu p1 p2 l r ang an1 N)
  12.         (while (setq ent (member (assoc 10 ent) ent))
  13.           (setq        b     (cons (cdar ent) b)
  14.                 ent   (member (assoc 42 ent) ent)
  15.                 b     (cons (cdar ent) b)
  16.                 ent   (cdr ent)
  17.                 vetex (cons b vetex)
  18.                 b     nil
  19.           )
  20.         )
  21.         (while vetex
  22.           (setq        a     (car vetex)
  23.                 vetex (cdr vetex)
  24.                 bu    (car a)
  25.                 p1    (cadr a)
  26.           )
  27.           (if l
  28.             (setq p2 (car l))
  29.             (setq p2 (cadr (last vetex))
  30.                   l  (cons p2 l)
  31.             )
  32.           )
  33.           (if (equal bu 0 1e-6)
  34.             (setq l (cons p1 l))
  35.             (progn
  36.               (setq ang        (* 2 (atan bu))
  37.                     r        (/ (distance p1 p2)
  38.                            (* 2 (sin ang))
  39.                         )
  40.                     c        (polar p1
  41.                                (+ (angle p1 p2) (- (/ pi 2) ang))
  42.                                r
  43.                         )
  44.                     r        (abs r)
  45.                     ang        (abs (* ang 2.0))
  46.                     N        (abs (fix (/ ang 0.0174532925199433)))
  47.               )
  48.               (if (= N 0)
  49.                 (setq l (cons p1 l))
  50.                 (progn
  51.                   (setq        an1 (/ ang N)
  52.                         ang (angle c p2)
  53.                   )
  54.                   (if (not (minusp bu))
  55.                     (setq an1 (- an1))
  56.                   )
  57.                   (repeat (1- N)
  58.                     (setq ang (+ ang an1))
  59.                     (setq l (cons (polar c ang r) l))
  60.                   )
  61.                   (setq l (cons p1 l))
  62.                 )
  63.               )
  64.             )
  65.           )
  66.         )
  67.         l
  68.       )
  69.      )
  70.     )
  71.     ((= et "CIRCLE")
  72.      ((lambda (c R / sa ptl)
  73.         (setq sa 0.0)
  74.         (repeat        180
  75.           (setq        ptl (cons (polar c sa R) ptl)
  76.                 sa  (+ sa 0.0174532925199433)
  77.           )
  78.         )
  79.         (setq ptl (reverse ptl))
  80.         (append
  81.           ptl
  82.           (mapcar (function
  83.                     (lambda (p)
  84.                       (mapcar (function +) c (mapcar (function -) c p))
  85.                     )
  86.                   )
  87.                   ptl
  88.           )
  89.         )
  90.       )
  91.        (cdr (assoc 10 ent))
  92.        (cdr (assoc 40 ent))
  93.      )
  94.     )
  95.     ((= et "SPLINE")
  96.      ((lambda (/ r l _oce)
  97.         (setq _oce (getvar "CMDECHO"))
  98.         (setvar "CMDECHO" 0)
  99.         (if (vl-catch-all-apply
  100.               (function vl-cmdf)
  101.               (list "_PEDIT"
  102.                     (vlax-vla-object->ename
  103.                       (vla-copy (vlax-ename->vla-object en))
  104.                     )
  105.                     ""
  106.                     10
  107.                     ""
  108.               )
  109.             )
  110.           (progn
  111.             (setq l (ss-assoc 10 (entget (setq r (entlast)))))
  112.             (if        (vlax-curve-isClosed r)
  113.               (setq l (append l (list (car l))))
  114.             )
  115.             (entdel r)
  116.           )
  117.         )
  118.         (setvar "CMDECHO" _oce)
  119.         (append l (list (car l)))
  120.       )
  121.      )
  122.     )
  123.     ((= et "ELLIPSE")
  124.      ((lambda (/ e l _os)
  125.         (setq _os (getvar "OSMODE"))
  126.         (setvar "OSMODE" 0)
  127.         (vl-catch-all-apply
  128.           (function vla-offset)
  129.           (list (vlax-ename->vla-object en) 0.1)
  130.         )
  131.         (setq e (entlast))
  132.         (vl-catch-all-apply
  133.           (function vla-offset)
  134.           (list (vlax-ename->vla-object (entlast)) -0.1)
  135.         )
  136.         (entdel e)
  137.         (setq e (entlast))
  138.         (setq l (ss-assoc 10 (entget e)))
  139.         (entdel e)
  140.         (setvar "OSMODE" _os)
  141.         (append l (list (car l)))
  142.       )
  143.      )
  144.     )
  145.   )
  146. )
发表于 2012-8-5 23:45:20 | 显示全部楼层
GP再改进:
1.为了适应任意管状封闭曲线, 将第一步网格数的确定方式改为自适应方式,即使用周长与面积的开根号的比例来控制,这样可以避免陷入非最优解的困扰;
2.强制第2步Step2的网格细分数为10,10等分已经足够让半径的精度提高1个等级了;
3.改进Grid_2的计算区域,减少为原来的1/4,即将原来为上次网格划分的16个区格改为4个区格;
  1. ;;old grid_2 area
  2. + + + + +
  3. + + + + +
  4. + + o + +
  5. + + + + +
  6. + + + + +
  7. ;;new grid_2 area
  8. + + +
  9. + o +
  10. + + +
复制代码
4.改进点在曲线点集内的计算函数,仅使用angle函数,效率比原来提高了非常多倍;
5.使用控制精度的while循环来替代原本由次数控制的repeat循环,既提高了精度又可能减少大量运算,一般情况下都比原来快些;
6.限制循环次数,避免存在条状最大圆的情况陷入死循环。
新代码如下:
  1. ;;; maximum circle inscribed in a closed polyline
  2. ;;; writed by Gian Paolo Cattaneo
  3. ;;; edited by GSLS(SS) 2012-8-5

  4. (defun C:TesT (/         POLY           POLY_vl   Dx               Dy
  5.                Lp         List_vert_poly             list_p_int
  6.                P_center         dist           step1     step2     t1
  7.                t2  R0  area len i
  8.               )
  9.   (gc)
  10.   (prompt "\nSelect Polyline: ")
  11.   (if (setq POLY (ssname (ssget ":S" '((0 . "LWPOLYLINE"))) 0))
  12.     (progn
  13.       (setq i  1
  14.             t1 (getvar "MilliSecs")
  15.       )
  16.       (setq area (vlax-curve-getArea poly)
  17.             len (vlax-curve-getDistAtParam poly (vlax-curve-getEndParam poly)))
  18.       (setq step1 (max 10 (fix (/ len 0.4 (sqrt area)))));_--> grid_1      
  19.       (setq step2 10);_--> grid_2
  20.       (setq list_vert_poly (LWPoly->List POLY 10))      
  21.       (grid_1)
  22.       (Point_int)      
  23.       (grid+)
  24.       (Point_center)
  25.       (setq i 0)
  26.       (while (and (> (- Dist R0) 1e-8)(< i 10))
  27.         (grid_2)
  28.         (Point_center)
  29.         (setq i (1+ i))
  30.       )
  31.       (entmake
  32.         (list
  33.           (cons 0 "CIRCLE")
  34.           (cons 10 P_center)
  35.           (cons 40 dist)
  36.         )
  37.       )
  38.       (setq t2 (getvar "MilliSecs"))
  39.       (princ (strcat "time = " (rtos (- t2 t1) 2 0) " MilliSecs"))
  40.       (princ)
  41.     )
  42.   )
  43. )

  44. ;; Restituisce una griglia di punti all'interno del getboundingbox della poly selezionata
  45. ;; Returns a grid of points within the BoundingBox of the selected poly
  46. (defun grid_1 (/ p1 p2 X1 Y1 l1)
  47.   (vla-getboundingbox (vlax-ename->vla-object POLY) 'p1 'p2)
  48.   (setq        p1 (vlax-safearray->list p1)
  49.         p2 (vlax-safearray->list p2)
  50.         p1 (list (car p1) (cadr p1))
  51.         p2 (list (car p2) (cadr p2))
  52.   )
  53.   (setq Dx (/ (- (car p2) (car p1)) step1))
  54.   (setq Dy (/ (- (cadr p2) (cadr p1)) step1))
  55.   (setq        Lp (list p1)
  56.         X1 (car p1)
  57.         Y1 (cadr p1)
  58.   )
  59.   (repeat step1
  60.     (setq Lp (cons (list (setq X1 (+ X1 Dx)) Y1) Lp))
  61.   )
  62.   (setq Lp (list Lp))
  63.   (repeat step1
  64.     (setq Lp (cons (mapcar (function (lambda (x)
  65.                                        (list (car x) (+ (cadr x) Dy))
  66.                                      )
  67.                            )
  68.                            (car lp)
  69.                    )
  70.                    Lp
  71.              )
  72.     )
  73.   )
  74.   (setq Lp (apply (function append) Lp))
  75. )
  76. ;; Restituisce una griglia di punti intorno al punto centrale (provvisorio)
  77. ;; Returns a grid of points around the center point (provisional)
  78. (defun grid_2 (/ X1 Y1 P1)
  79.   (setq        list_p_int nil
  80.         X1           (- (car P_center) Dx)
  81.         Y1           (- (cadr P_center) Dy)
  82.         P1           (list X1 Y1)
  83.         Dx           (/ (* 2 Dx) step2)
  84.         Dy           (/ (* 2 Dy) step2)
  85.   )
  86.   (setq list_p_int (list P1))
  87.   (repeat step2
  88.     (setq list_p_int (cons (list (setq X1 (+ X1 Dx)) Y1) list_p_int))
  89.   )
  90.   (setq list_p_int (list list_p_int))
  91.   (repeat step2
  92.     (setq list_p_int
  93.            (cons (mapcar (function (lambda (x)
  94.                                      (list (car x) (+ (cadr x) Dy))
  95.                                    )
  96.                          )
  97.                          (car list_p_int)
  98.                  )
  99.                  list_p_int
  100.            )
  101.     )
  102.   )
  103.   (setq list_p_int (apply (function append) list_p_int))
  104. )
  105. ;; restituisce la lista dei punti interni ad un poligono
  106. ;; dati:  - lista coordinate dei punti -> Lp
  107. ;;        - lista coordinate vertici poligono -> list_vert_poly
  108. ;; Returns the list of points inside the polyline
  109. (defun Point_int (/ n Pr cont attr p# Pa Pa_ Pb)
  110.   (setq list_p_int nil)
  111.   (foreach Pr Lp
  112.     (if        (> (Point-in-ClosedCurve-p list_vert_poly Pr) 0)
  113.       (setq list_p_int (cons Pr list_p_int))
  114.     )
  115.   )
  116. )
  117. ;; Infittisce la griglia inserendo altri punti
  118. ;; nel centro delle diagonali tra i punti interni
  119. ;; Insert points (interior) to increase the density of the grid
  120. (defun grid+ (/ G+)
  121.   (setq        G+
  122.          (mapcar '(lambda (x)
  123.                     (list (+ (car x) (/ Dx 2)) (+ (cadr x) (/ Dy 2)))
  124.                   )
  125.                  list_p_int
  126.          )
  127.   )
  128.   (setq list_p_int (append G+ list_p_int))
  129. )
  130. ;; Da una lista di punti restituisce quello più lontano da un oggetto
  131. ;; dati:  - lista dei punti -> list_p_int
  132. ;;        - oggetto -> POLY_vl
  133. ;; Returns the farthest point from the polyline
  134. (defun Point_center (/ Pa Pvic)   
  135.   (foreach Pa list_p_int
  136.     (setq Pvic (vlax-curve-getClosestPointTo Poly Pa))
  137.     (if        (> (distance Pa Pvic) Dist)
  138.       (setq P_center Pa
  139.               R0 Dist
  140.               Dist (distance Pa Pvic))
  141.     )
  142.   )
  143. )
  144. ;;
  145. (defun LWPoly->List (en acc / a b vetex bu p1 p2 l r ang an1 N)
  146.   ;;Acc --- 0 ~ 99
  147.   (setq ent (entget en))
  148.   (while (setq ent (member (assoc 10 ent) ent))
  149.     (setq b        (cons (cdar ent) b)
  150.           ent        (member (assoc 42 ent) ent)
  151.           b        (cons (cdar ent) b)
  152.           ent        (cdr ent)
  153.           vetex        (cons b vetex)
  154.           b        nil
  155.     )
  156.   )
  157.   (while vetex
  158.     (setq a        (car vetex)
  159.           vetex        (cdr vetex)
  160.           bu        (car a)
  161.           p1        (cadr a)
  162.     )
  163.     (if        l
  164.       (setq p2 (car l))
  165.       (setq p2 (cadr (last vetex))
  166.             l  (cons p2 l)
  167.       )
  168.     )
  169.     (if        (equal bu 0 1e-6)
  170.       (setq l (cons p1 l))
  171.       (progn
  172.         (setq ang (* 2 (atan bu))
  173.               r          (/ (distance p1 p2)
  174.                      (* 2 (sin ang))
  175.                   )
  176.               c          (polar p1
  177.                          (+ (angle p1 p2) (- (/ pi 2) ang))
  178.                          r
  179.                   )
  180.               r          (abs r)
  181.               ang (abs (* ang 2.0))
  182.               N          (abs (fix (/ ang 0.0174532925199433)))
  183.               N          (min N (1+ Acc))
  184.         )
  185.         (if (= N 0)
  186.           (setq l (cons p1 l))
  187.           (progn
  188.             (setq an1 (/ ang N)
  189.                   ang (angle c p2)
  190.             )
  191.             (if        (not (minusp bu))
  192.               (setq an1 (- an1))
  193.             )
  194.             (repeat (1- N)
  195.               (setq ang        (+ ang an1)
  196.                     l        (cons (polar c ang r) l)
  197.               )
  198.             )
  199.             (setq l (cons p1 l))
  200.           )
  201.         )
  202.       )
  203.     )
  204.   )
  205.   l
  206. )
  207. ;;
  208. ;; This method suggest by Lee Mac from http://en.wikipedia.org/wiki/Winding_number
  209. ;; function : determin the point position with the closed curve by widding-number method
  210. ;; l  ---- point set of a Closed Curve , First item must same as Last item .
  211. ;; pt ---- a given point to determin position with the Closed Curve
  212. ;; return a num
  213. ;;           ----  -1  pt out of curve
  214. ;;           ----   0  pt at curve
  215. ;;           ----   1  pt in curve
  216. ;; by GSLS(SS) 2012-08-02
  217. ;; Edited : Change widding number's Acc 1e-4 into 1e-2 ,
  218. ;;          for checking point in or out it's a integer
  219. ;; Edited 2012-8-5
  220. ;;         Improved vector angle calculation , only use angle function .
  221. ;;         
  222. (defun Point-in-ClosedCurve-p (l pt / ang p1 p2 n r at)
  223.   (setq ang 0.0)
  224.   (while (and (cadr l) (not at))
  225.     (setq p1  (car l)
  226.           p2  (cadr l)
  227.           l   (cdr l)
  228.           an1 (- (angle pt p2) (angle pt p1))
  229.     )
  230.     (if        (< an1 (- pi))
  231.       (setq an1 (+ an1 pi pi))
  232.       (if (> an1 pi)
  233.         (setq an1 (- an1 pi pi))
  234.       )
  235.     )
  236.     (if        (equal (abs an1) pi 1e-14);_If it's just used to solve the maximum radius of the circle,
  237.                                  ;_here's  precision 1e-14 can be set lower , such as 1e-1 ,
  238.                                  ;_this will exclude the point of the curve edge .
  239.                                  ;_but for ultra-narrow four-point rectangle will generate an error .
  240.       (setq at T)
  241.     )
  242.     (setq ang (+ ang an1))
  243.   )
  244.   ;;deal widding number  
  245.   (if at
  246.     0
  247.     (progn
  248.       (setq n (/ ang 2. pi))
  249.       (if (and (> n 0) (equal (1+ (fix n)) n 1e-2))
  250.         (setq n (1+ (fix n)))
  251.         (if (and (< n 0) (equal (1- (fix n)) n 1e-2))
  252.           (setq n (1- (fix n)))
  253.           (setq n (fix n))
  254.         )
  255.       )
  256.       (if (= (rem n 2) 0)
  257.         -1
  258.         1
  259.       )
  260.     )
  261.   )
  262. )



评分

参与人数 2明经币 +4 金钱 +30 收起 理由
tryhi + 1 很给力!
highflybir + 3 + 30 赞一个!

查看全部评分

发表于 2012-8-6 16:31:50 | 显示全部楼层
收藏了,下来学习
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-23 15:46 , Processed in 0.277840 second(s), 20 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表