最小锐角+线自相交+面相交检查+调整多线段方向

cz7873559 · 发表于 2014-7-7 15:29:02

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 cz7873559 于 2014-7-7 15:31 编辑

由于工作需要，我整理了几个需要实现的功能，见附件说明。麻烦各位高手帮我看看。
主要实现的是4个功能：1.最小锐角+2.线自相交+3.面相交检查+4.调整多线段方向
如果哪位高手能全部做出来的，可以私聊。qq：369147191

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:最小锐角线自相交面相交检查调整多线段方向.rar
下载次数:30 文件大小:8.5 KB
下载权限: 不限以上 [免费赚D豆]

st788796 · 发表于 2014-7-8 08:25:43

1 xdrx_vector_angle求夹角
2 xdrx_polyline_isselfintersect判断自相交，交点规则在Net论坛有个帖子有论述
3 面相交用xdrx_entity_intersectwith判断
4 (xdrx_curve_reverse (ssget))就是反向，任意指定起点的程序论坛有

newer · 发表于 2014-7-8 10:14:18

有问题最好把图片贴到论坛上详细说明方便讨论。

st788796 · 发表于 2014-7-8 20:34:27

xd-lisp-lib.vlx 问题太多，很严重！
最小夹角

(defun c:tt (/ ss an)
(if (and (setq an (getangle "\n最小角度: "))
(setq ss (ssget '((0 . "*polyline"))))
)
(progn
(mapcar
'(lambda (x / pts ptl vl anl i)
(setq pts (xdrx_getpropertyvalue x "Vertices"))
(if (vlax-curve-isclosed x)
(setq pts (reverse (cons (car pts) (reverse pts))))
)
(mapcar '(lambda (a b c / v1 v2)
(setq v1 (mapcar '- a b)
v2 (mapcar '- c b)
)
(if (< (xdrx_vector_angle v1 v2) an)
(entmake (list '(0 . "circle")
(cons 10 b)
'(40 . 1.0)
'(8 . "最小锐角")
'(62 . 3)
)
)
)
)
pts
(cdr pts)
(cddr pts)
)
)
(xdrx_pickset->ents ss)
)
)
)
(princ)
)

(defun c:tt (/ ss an) 
  (if (and (setq an (getangle "\n最小角度: ")) 
           (setq ss (ssget '((0 . "*polyline")))) 
      ) 
    (progn 
      (mapcar 
        '(lambda (x / pts ptl vl anl i) 
           (setq pts (xdrx_getpropertyvalue x "Vertices")) 
           (if (vlax-curve-isclosed x) 
             (setq pts (reverse (cons (car pts) (reverse pts)))) 
           ) 
           (mapcar '(lambda (a b c / v1 v2) 
                      (setq v1 (mapcar '- a b) 
                            v2 (mapcar '- c b) 
                      ) 
                      (if (< (xdrx_vector_angle v1 v2) an) 
                        (entmake (list '(0 . "circle") 
                                       (cons 10 b) 
                                       '(40 . 1.0) 
                                       '(8 . "最小锐角") 
                                       '(62 . 3) 
                                 ) 
                        ) 
                      ) 
                    ) 
                   pts 
                   (cdr pts) 
                   (cddr pts) 
           ) 
         ) 
        (xdrx_pickset->ents ss) 
      ) 
    ) 
  ) 
  (princ) 
)

st788796 · 发表于 2014-7-8 20:35:17

相交

(defun c:tt (/ ss lst e1 lst1 s tf)
(if (setq ss (ssget '((0 . "*polyline") (-4 . "&=") (70 . 0))))
(progn
(setq lst (xdrx_pickset->ents ss))
(while lst
(setq e1 (car lst)
lst (cdr lst)
lst1 lst
tf t
)
(while (and tf lst1) ;_仅判断两两相交
(if (setq s (xdrx_curve_intersect e1 (car lst1) 0.))
(progn
(if (not (tblsearch "layer" "多段线相交"))
(xdrx_layer_make "多段线相交" 3)
)
(xdrx_entity_setlayer s "多段线相交")
(setq tf nil)
)
)
(setq lst1 (cdr lst1))
)
)
)
)
(princ)
)

st788796 · 发表于 2014-7-8 20:57:40

标示自相交点

(defun c:tt (/ ss GetIntersPnt)
(defun GetIntersPnt (e / pts ep pams iPams dPams num n i)
(if (xdrx_polyline_isselfintersect e)
(progn
(setq pts (xdrx_entity_intersectwith e e 0)
ep (vlax-curve-getendpoint e)
pams (mapcar '(lambda (x) (vlax-curve-getparamatpoint e x))
pts
)
iPams (mapcar 'fix
(vl-remove-if '(lambda (x) (/= x (fix x))) pams)
)
dPams (vl-remove-if '(lambda (x) (= x (fix x))) pams)
num (xdrx_polyline_numverts e)
n (- num 2)
i 1
)
(while (<= i n)
(if (not (vl-position i iPams))
(setq dPams (cons i dPams))
)
(if (equal ep (vlax-curve-getpointatparam e i) 1e-3)
(setq dPams (cons (1- num) dPams))
)
(setq i (1+ i))
)
(setq dPams (vl-sort dPams '<))
(mapcar
'(lambda (x)
(entmake (list '(0 . "CIRCLE")
(cons 10 (vlax-curve-getpointatparam e x))
'(40 . 1.0)
'(8 . "线自相交")
'(62 . 3)
)
)
)
dPams
)
)
)
)
(if (setq ss (ssget '((0 . "*polyline"))))
(mapcar '(lambda (x)
(GetIntersPnt x)
)
(xdrx_pickset->ents ss)
)
)
(princ)
)

(defun c:tt (/ ss GetIntersPnt) 
  (defun GetIntersPnt (e / pts ep pams iPams dPams num n i) 
    (if        (xdrx_polyline_isselfintersect e) 
      (progn 
        (setq pts   (xdrx_entity_intersectwith e e 0) 
              ep    (vlax-curve-getendpoint e) 
              pams  (mapcar '(lambda (x) (vlax-curve-getparamatpoint e x)) 
                            pts 
                    ) 
              iPams (mapcar 'fix 
                            (vl-remove-if '(lambda (x) (/= x (fix x))) pams) 
                    ) 
              dPams (vl-remove-if '(lambda (x) (= x (fix x))) pams) 
              num   (xdrx_polyline_numverts e) 
              n            (- num 2) 
              i            1 
        ) 
        (while (<= i n) 
 
          (if (not (vl-position i iPams)) 
            (setq dPams (cons i dPams)) 
          ) 
          (if (equal ep (vlax-curve-getpointatparam e i) 1e-3) 
            (setq dPams (cons (1- num) dPams)) 
          ) 
          (setq i (1+ i)) 
        ) 
        (setq dPams (vl-sort dPams '<)) 
        (mapcar 
          '(lambda (x) 
             (entmake (list '(0 . "CIRCLE") 
                            (cons 10 (vlax-curve-getpointatparam e x)) 
                            '(40 . 1.0) 
                            '(8 . "线自相交") 
                            '(62 . 3) 
                      ) 
             ) 
           ) 
          dPams 
        ) 
      ) 
    ) 
  ) 
  (if (setq ss (ssget '((0 . "*polyline")))) 
    (mapcar '(lambda (x) 
               (GetIntersPnt x) 
             ) 
            (xdrx_pickset->ents ss) 
    ) 
  ) 
  (princ) 
)

st788796 · 发表于 2014-7-8 21:19:39

(XD:: Polyline:ResetStartpoint)任意指定闭合多段线起点

风树 · 发表于 2014-7-8 21:37:28

st788796 发表于 2014-7-8 21:19
(XD:: Polyline:ResetStartpoint)任意指定闭合多段线起点

支持一下

st788796 · 发表于 2014-7-9 11:44:40

这个西北角不好定，最上最左或者最右最上都不一定是西北角

(defun c:tt (/ ss)
(if (setq ss (ssget '((0 . "*polyline"))))
(progn
(mapcar '(lambda (x / pts tf p)
(setq pts (xdrx_getpropertyvalue x "Vertices")
tf (apply 'xdrx_points_area pts)
)
(if (> tf 0)
(progn
(xdrx_curve_reverse x)
(setq pts (reverse pts))
)
)
(setq p
(car (vl-sort pts
'(lambda (x1 x2)
(if (equal (cadr x1) (cadr x2) 1e-6)
(< (car x1) (car x2))
(> (cadr x1) (cadr x2))
)
)
)
)
)
(if (not (equal (vlax-curve-getstartpoint x) p 1e-3))
(XD::Polyline:ResetStartPoint x p)
)
)
(xdrx_pickset->ents ss)
)
)
)
(princ)
)

(defun c:tt (/ ss) 
  (if (setq ss (ssget '((0 . "*polyline")))) 
    (progn 
      (mapcar '(lambda (x / pts tf p) 
                 (setq pts (xdrx_getpropertyvalue x "Vertices") 
                       tf  (apply 'xdrx_points_area pts) 
                 ) 
                 (if (> tf 0) 
                   (progn 
                     (xdrx_curve_reverse x) 
                     (setq pts (reverse pts)) 
                   ) 
                 ) 
                 (setq p 
                        (car (vl-sort pts 
                                      '(lambda (x1 x2) 
                                         (if (equal (cadr x1) (cadr x2) 1e-6) 
                                           (< (car x1) (car x2)) 
                                           (> (cadr x1) (cadr x2)) 
                                         ) 
                                       ) 
                             ) 
                        ) 
                 ) 
                 (if (not (equal (vlax-curve-getstartpoint x) p 1e-3)) 
                   (XD::Polyline:ResetStartPoint x p) 
                 ) 
               ) 
              (xdrx_pickset->ents ss) 
      ) 
    ) 
  ) 
  (princ) 
)

st788796 · 发表于 2014-7-9 14:37:22

这样求西北角点可能更好

(defun LeftUpPnt (pts / box v bp vl)
(setq box (apply 'xdrx_points_box pts)
v (mapcar '- (last box) (caddr box))
bp (last box)
pts (vl-remove bp pts)
vl (mapcar '(lambda (x / vv d)
(setq vv (trans (mapcar '- x bp) 0 v)
d (+ (* (car vv) (car vv))
(* (cadr vv) (cadr vv))
(* (caddr vv) (caddr vv))
)
)
(list d (caddr vv) x)
)
pts
)
)
(caddar (vl-sort vl
'(lambda (x1 x2)
(if (equal (car x1) (car x2) 1e-3)
(< (cadr x1) (cadr x2))
(< (car x1) (car x2))
)
)
)
)
)

(defun LeftUpPnt (pts / box v bp vl) 
  (setq        box (apply 'xdrx_points_box pts) 
        v   (mapcar '- (last box) (caddr box)) 
        bp  (last box) 
        pts (vl-remove bp pts) 
        vl  (mapcar '(lambda (x / vv d) 
                       (setq vv        (trans (mapcar '- x bp) 0 v) 
                             d        (+ (* (car vv) (car vv)) 
                                   (* (cadr vv) (cadr vv)) 
                                   (* (caddr vv) (caddr vv)) 
                                ) 
                       ) 
                       (list d (caddr vv) x) 
                     ) 
                    pts 
            ) 
  ) 
  (caddar (vl-sort vl 
                  '(lambda (x1 x2) 
                     (if (equal (car x1) (car x2) 1e-3) 
                       (< (cadr x1) (cadr x2)) 
                       (< (car x1) (car x2)) 
                     ) 
                   ) 
         ) 
  ) 
)

cz7873559 · 发表于 2014-7-11 17:43:16

st788796 发表于 2014-7-8 08:25
1 xdrx_vector_angle求夹角
2 xdrx_polyline_isselfintersect判断自相交，交点规则在Net论坛有个帖子有论 ...

这几天都没来。谢谢大家给我提供的思路。

账号		自动登录	找回密码
密码			立即注册

[编程申请] 最小锐角+线自相交+面相交检查+调整多线段方向

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

点评

点评