(XD::Geom:pathIsLand)获得两个嵌套多边形中间的海洋部分（海->陆地）

Lispboy · 发表于 2013-7-27 22:14:01

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

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

×

本帖最后由 Lispboy 于 2013-7-28 02:29 编辑

;|
获得两个嵌套多边形中间的海洋部分（海-》陆地）
参数：
e1---内部多边形
e2---外部多边形
返回值：
表（两块陆地）
|;
(defun XD::Geom:pathIsLand (e1 e2 / e3 e4 e5 e6 el p1 p2 pts1 pts2 ss ss3 x)
(xdrx_document_ucson)
(if (and
(/= e1 e2)
(setq pts1 (xdrx_entity_getStretchPoint e1)
pts2 (xdrx_entity_getStretchPoint e2)
)
(>= (length pts1) 3)
(>= (length pts2) 3)
(XD::Pnts:IsInPolyWithPnts pts1 pts2)
)
(progn
(setq p1 (car (XD::PNTS:MinX->MinY pts1 1e-5))
p2 (car (XD::PNTS:MinX->MinY pts2 1e-5))
pts1 (XD::PntS:UnClockWise pts1 p1 1e-5)
pts2 (XD::PntS:UnClockWise pts2 p2 1e-5)
)
(if (vl-some '(lambda (x)
(XD::Pnt:IsOn x pts2)
) pts1
)
(progn
(setq ss3 (xdrx_curve_subtract e2 e1 0.0))
(setq el (XD::SS:Ents ss3))
(if (> (length el) 2)
(progn
(entdel (car el))
(entdel (last el))
(list (cadr el) (caddr el))
)
el
)
)
(progn
(setq ss (ssadd))
(ssadd e1 ss)
(ssadd e2 ss)
(xdrx_line_make (trans (car pts1) 1 0) (trans (car pts2) 1 0))
(ssadd (setq e3 (entlast))
ss
)
(xdrx_line_make (trans (caddr pts1) 1 0) (trans (caddr pts2) 1 0))
(ssadd (setq e4 (entlast))
ss
)
(xdrx_geom_bpoly (xdrx_midp (last pts1) (last pts2)) ss)
(setq e5 (entlast))
(xdrx_geom_bpoly (xdrx_midp (cadr pts1) (cadr pts2)) ss)
(setq e6 (entlast))
(entdel e3)
(entdel e4)
(list e5 e6)
)
)
)
)
)

;| 
获得两个嵌套多边形中间的海洋部分（海-》陆地） 
参数： 
  e1---内部多边形 
  e2---外部多边形 
返回值： 
  表（两块陆地） 
|; 
(defun XD::Geom:pathIsLand (e1 e2 / e3 e4 e5 e6 el p1 p2 pts1 pts2 ss ss3 x) 
  (xdrx_document_ucson) 
  (if (and 
        (/= e1 e2) 
        (setq pts1 (xdrx_entity_getStretchPoint e1) 
              pts2 (xdrx_entity_getStretchPoint e2) 
        ) 
        (>= (length pts1) 3) 
        (>= (length pts2) 3) 
        (XD::Pnts:IsInPolyWithPnts pts1 pts2) 
      ) 
    (progn 
      (setq p1 (car (XD::PNTS:MinX->MinY pts1 1e-5)) 
            p2 (car (XD::PNTS:MinX->MinY pts2 1e-5)) 
            pts1 (XD::PntS:UnClockWise pts1 p1 1e-5) 
            pts2 (XD::PntS:UnClockWise pts2 p2 1e-5) 
      ) 
      (if (vl-some '(lambda (x) 
                      (XD::Pnt:IsOn x pts2) 
                    ) pts1 
          ) 
        (progn 
          (setq ss3 (xdrx_curve_subtract e2 e1 0.0)) 
          (setq el (XD::SS:Ents ss3)) 
          (if (> (length el) 2) 
            (progn 
              (entdel (car el)) 
              (entdel (last el)) 
              (list (cadr el) (caddr el)) 
            ) 
            el 
          ) 
        ) 
        (progn 
          (setq ss (ssadd)) 
          (ssadd e1 ss) 
          (ssadd e2 ss) 
          (xdrx_line_make (trans (car pts1) 1 0) (trans (car pts2) 1 0)) 
          (ssadd (setq e3 (entlast)) 
                 ss 
          ) 
          (xdrx_line_make (trans (caddr pts1) 1 0) (trans (caddr pts2) 1 0)) 
          (ssadd (setq e4 (entlast)) 
                 ss 
          ) 
          (xdrx_geom_bpoly (xdrx_midp (last pts1) (last pts2)) ss) 
          (setq e5 (entlast)) 
          (xdrx_geom_bpoly (xdrx_midp (cadr pts1) (cadr pts2)) ss) 
          (setq e6 (entlast)) 
          (entdel e3) 
          (entdel e4) 
          (list e5 e6) 
        ) 
      ) 
    ) 
  ) 
)

测试代码：

(defun c:t5()
(if (and (setq e1 (car (entsel)))
(setq e2 (car (entsel)))
)
(progn
(XD::Begin)
(xdrx_document_setPrec 3.0 1)
(setq el (XD::Geom:PathIsland e1 e2))
(setq i 1)
(foreach n el
(setq pts (xdrx_entity_getstretchpoint n))
(apply 'xdrx_grdraw (append (list i 3) pts))
(setq i (1+ i))
)
(XD::End)
)
)
(princ)
)

拉契 · 发表于 2014-3-17 16:04:15

虽然不知道什么地方用到这个但是感觉挺复杂的！学习
{:soso_e179:}

wowan1314 · 发表于 2013-7-27 23:36:39

我瞎耍。。
下面代码只适应于演示。

(defun enbox (ename / ll ur p2 p4)
(vla-getboundingbox (vlax-ename->vla-object ename) 'll 'ur)
(setq ll (vlax-safearray->list ll)ur (vlax-safearray->list ur))
(setq p4 (list (car ll)(cadr ur))p2 (list (car ur)(cadr ll)))
(list ll p2 ur p4)
)
(defun c:t11 ( / e1 e2 e11 e22 e111 e222)
(setq e11 (car(entsel)) e22 (car(entsel)))
(setq e1 (enbox e11) e2 (enbox e22))
(command "line" (car e1) (car e2) "")
(setq e11 (entlast))
(command "line" (caddr e1) (caddr e2) "")
(setq e22 (entlast))
(command "boundary" (mapcar '+ (last e1) '(55 -55)) "")
;(bpoly (mapcar '+ (last e1) '(1 -1)))怎么不好使？
(setq e222 (entlast))
(command "boundary" (mapcar '+ (cadr e1) '(-55 55)) "")
(setq e111 (entlast))
(entdel e11)(entdel e22)
(sssetfirst nil (ssadd e111 (ssadd e222 (ssadd))))
)

Lispboy · 发表于 2013-7-27 23:50:51

wowan1314 发表于 2013-7-27 23:36
我瞎耍。。
下面代码只适应于演示。

葛老，多边形要是斜的呢？

wowan1314 · 发表于 2013-7-28 00:04:29

本帖最后由 wowan1314 于 2013-7-28 00:20 编辑

Lispboy 发表于 2013-7-27 23:50
葛老，多边形要是斜的呢？

话说 bpoly函数或者boundary命令对于点离边界太近了就不认了？！
就像上面的代码偏移20都不行。必须偏移多些。而且跟拾取框大小都有关系。关闭捕捉也没用。
这两函数的点看来最好是由用户自定，lisp内部指定容易留下隐患。

用下面的代码代替包围盒函数会好些。

(mapcar 'cdr(vl-remove-if
'(lambda(x)(/= (car x) 10))
(entget (car(entsel))
)
)
)

Lispboy · 发表于 2013-7-28 01:01:55

本帖最后由 Lispboy 于 2013-7-28 01:05 编辑

wowan1314 发表于 2013-7-28 00:04
话说 bpoly函数或者boundary命令对于点离边界太近了就不认了？！
就像上面的代码偏移20都不行。必须偏 ...

xdrx_geom_bpoly 可不是bpoly ，屏幕看不到也能求出结果。另外xdrx_geom_bpoly 能对选择集进行操作，你可以试试。

代码修改了，多适用了几种情况，好像全了？看下一楼的演示。

不能用BOX，因为多边形可能是斜的。

清风明月10 · 发表于 2013-7-28 13:12:12

谢谢楼主的分享！很有用啊。

wowan1314 · 发表于 2013-7-28 22:15:42

本帖最后由 wowan1314 于 2013-7-29 18:47 编辑

Lispboy 发表于 2013-7-28 01:01
xdrx_geom_bpoly 可不是bpoly ，屏幕看不到也能求出结果。另外xdrx_geom_bpoly 能对选择集进行操作，你可 ...

呵呵！
下图这个情况呢？
测试了下DX-API的 xdrx_geom_bpoly比lisp自带的好用。没有精度的bug。
(bpoly (mapcar '+ '(1 1)(getpoint)));;选边界上的点。然后说点在对象上，无法成功。
(xdrx_geom_bpoly (mapcar '+ '(1 1)(getpoint)));;而这句可以运行。

同时测试了XD-API的删除比VLA-DELETE函数快不少。
XD-API的矩阵比lisp的矩阵函数效率也要高不少。LISP矩阵转换比VLA方法转换快一点点。

呵呵。真心动ing.

wowan1314 · 发表于 2013-7-28 23:27:16

本帖最后由 wowan1314 于 2013-7-28 23:36 编辑

Lispboy 发表于 2013-7-28 01:01
xdrx_geom_bpoly 可不是bpoly ，屏幕看不到也能求出结果。另外xdrx_geom_bpoly 能对选择集进行操作，你可 ...

呵呵！我又来耍了。。

下面的代码只为了演示。。。且仅适用于演示。

(defun enbox1(e)(mapcar 'cdr(vl-remove-if '(lambda(x)(/= (car x) 10))(entget e))))
(defun minpt (A B)(mapcar '* '(0.5 0.5)(mapcar '+ A B)))
(defun MKLINE (X Y)(command "line" X Y "")(entlast))
(defun c:t11 ( / e1 e2 e11 e22 e111 e222 ss a1 a2 a11 a22)
(setq e11 (car(entsel)) e22 (car(entsel)) ss (ssadd e11 (ssadd e22 (ssadd)))
a1 (enbox1 e11) a2(enbox1 e22)
a11 (minpt (car a1) (caddr a1))
a22 (minpt (car a2) (caddr a2))
e1 (vl-sort a1 '(lambda(x y)(<(angle x a11)(angle y a11))))
e2 (vl-sort a2 '(lambda(x y)(<(angle x a22)(angle y a22))))
E11 (MKLINE (cadr e1) (cadr e2))
E22 (MKLINE (last e1) (last e2))
e222 (bpoly(mapcar '- (minpt (car e1) (car e2))'(-200 -200)) ss '(1 0))
e111 (bpoly(mapcar '- (minpt (caddr e1) (caddr e2))'(200 200)) ss '(1 0))
)
(entdel e11)(entdel e22)
(sssetfirst nil (ssadd e111 (ssadd e222 (ssadd))))
)

(defun enbox1(e)(mapcar 'cdr(vl-remove-if '(lambda(x)(/= (car x) 10))(entget e)))) 
(defun minpt (A B)(mapcar '* '(0.5 0.5)(mapcar '+ A B))) 
(defun MKLINE (X Y)(command "line" X Y "")(entlast)) 
(defun c:t11 ( / e1 e2 e11 e22 e111 e222 ss a1 a2 a11 a22) 
    (setq e11 (car(entsel)) e22 (car(entsel)) ss (ssadd e11 (ssadd e22 (ssadd))) 
          a1 (enbox1 e11) a2(enbox1 e22) 
        a11 (minpt (car a1) (caddr a1)) 
        a22 (minpt (car a2) (caddr a2)) 
          e1 (vl-sort a1 '(lambda(x y)(<(angle x a11)(angle y a11)))) 
          e2 (vl-sort a2 '(lambda(x y)(<(angle x a22)(angle y a22)))) 
          E11 (MKLINE (cadr e1) (cadr e2)) 
          E22 (MKLINE (last e1) (last e2)) 
          e222 (bpoly(mapcar '- (minpt (car e1) (car e2))'(-200 -200)) ss '(1 0)) 
          e111 (bpoly(mapcar '- (minpt (caddr e1) (caddr e2))'(200 200)) ss '(1 0)) 
     ) 
    (entdel e11)(entdel e22) 
    (sssetfirst nil (ssadd e111 (ssadd e222 (ssadd)))) 
)

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

[几何] (XD::Geom:pathIsLand)获得两个嵌套多边形中间的海洋部分（海->陆地）

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

相关帖子

点评

评分

点评

点评

点评

浏览过的版块