指定间距等分凸凹多边形（草稿）

a117034423 · 发表于 2020-12-23 15:05:30

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

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

×

(defun dblk (pts1 /) ;点表创建闭合多段线
(entmake (append
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(8 . "板轮廓线")
'(70 . 1)
'(100 . "AcDbPolyline")
(cons 90 (length pts1)))
(mapcar '(lambda (pt) (cons 10 pt)) pts1))
)
)
(defun sortxy (pts2 Tol / pt1 pt2) ;点表XY排序函数
(vl-sort pts2 '(lambda (pt1 pt2)
(if (equal (cadr pt1) (cadr pt2) tol)
(if (equal (car pt1) (car pt2) tol)
(< (caddr pt1) (caddr pt2))
(< (car pt1) (car pt2))
)
(< (cadr pt1) (cadr pt2))
)
)
)
)
(defun getarea (pts3 / pts1 iSum p0 p1 p2 x0 x1 x2 y0 y1 y2)
(setq pts1 pts3)
(setq iSum 0)
(setq p0 (car pts3)
x0 (car p0)
y0 (cadr p0)
)
(while (cdr pts1)
(setq p1 (car pts1)
x1 (car p1)
y1 (cadr p1)
p2 (cadr pts1)
y2 (cadr p2)
x2 (car p2)
iSum (+ iSum (- (* x1 y2) (* x2 y1)))
pts1 (cdr pts1)
)
)
(/ (+ iSum (- (* (caar pts1) y0) (* x0 (cadar pts1)))) 2.0)
)
(defun Sortnn (pts e / acaddocument acadobject e1 mspace obj objname x y)
(vl-load-com)
(defun AddPline (space lst / x)
(if (> (length lst) 2)
(vlax-invoke space 'AddLightWeightPolyline (apply
'append
(mapcar
'(lambda (x)
(list (float (car x)) ; _此处应为Double, INT会Fail
(float (cadr x))
)
)
lst
)
)
)
(progn
(vla-AddXLine space (vlax-3d-point (car lst))(vlax-3d-point (cadr lst)))
)
)
)
(cond
((and
(= (type e) 'ENAME)
(setq objname (cdr (assoc 0 (entget e))))
(wcmatch (strcase objname) "*LINE,*CIRCLE,*ARC,*ELLIPSE")
)
(setq pts1 (mapcar
'cdr
(vl-sort (mapcar
'(lambda (x)
(cons (vlax-curve-getParamAtPoint e (vlax-curve-getClosestPointTo e x t)) x)
)
pts
) '(lambda (x y)
(< (car x) (car y))
)
)
)
)
)
((and (= (type e) 'LIST)
(> (length e) 1)
)
(setq AcadObject (vlax-get-acad-object)
AcadDocument (vla-get-ActiveDocument AcadObject)
mSpace (vla-get-ModelSpace AcadDocument)
)
(addpline mspace e)
(vlax-release-object mSpace)
(vlax-release-object AcadDocument)
(vlax-release-object AcadObject)
(setq e1 (entlast))
(setq pts1 (Pnts-Sort-Cruve pts e1))
(entdel e1)
)
)
pts1
)
(defun sortonpl (pl pts7)
(setq pts7 (mapcar
'(lambda (x)
(list (vlax-curve-getdistatpoint
pl
(vlax-curve-getclosestpointto pl x)
)
x
)
)
pts7
)
pts7 (vl-sort pts7
'(lambda (e1 e2)
(< (car e1) (car e2))
)
)
)
(list pl
(mapcar
'cadr
pts
)
)
)
(defun ptjd (pts5 pts6 / i j ii jj pt1 pt2 pt3 pt4 intpt interpt) ;交点坐标计算函数
(setq ii (1- (length pts5)))
(setq jj (1- (length pts6)))
(setq intpt nil interpt nil i 0 )
(while (< i ii)
(setq pt1 (nth i pts5))
(setq pt2 (nth (1+ i) pts5))
(setq j 0)
(while (< j jj)
(setq pt3 (nth j pts6))
(setq pt4 (nth (1+ j) pts6))
(setq intpt (inters pt1 pt2 pt3 pt4 t) )
(if (/= intpt nil)
;将交点坐标存入点表
(setq interpt (append interpt (list intpt)))
)
(setq j (1+ j))
)
(setq i (1+ i))
)
interpt
)
(defun pntisin (pnt1 pnts1 / pts0 pts1 an ptn total);判断点在线内
(setq pts1
(if (not (equal (car pnts1) (last pnts1) 1e-5))
(reverse (cons (car pnts1) (reverse pnts1))) ;点表闭合
pnts1
)
pts0 (mapcar 'list pts1 (cdr pts1));首尾组对
total 0
)
(mapcar
'(lambda (x)
(setq an (- (angle pnt1 (car x)) (angle pnt1 (cadr x))))
(cond
((> an pi)
(setq an (- an pi))
)
((< an (* -1 pi))
(setq an (+ an pi))
)
)
(setq total (+ total an))
)
pts0
)
(if (equal (- (abs total) pi) 0.0 1e-5)
t
nil
)
)
(defun pntison (pnt2 pnts2 / pts0 pts1 xca xcb xa xb i gg p1 p3);判断点在线上
(setq pts1
(if (not (equal (car pnts2) (last pnts2) 1e-5))
(reverse (cons (car pnts2) (reverse pnts2))) ;点表闭合
pnts2
))
(setq pts0 (mapcar 'list pts1 (cdr pts1));首尾组对
)
(setq xca
(mapcar
'(lambda (x)
(mapcar '- pnt2 (car x))
)
pts0
))
(setq xcb
(mapcar
'(lambda (x)
(mapcar '- (cadr x) (car x))
)
pts0
))
(setq i 0)
(repeat (length xca)
(setq xa (nth i xca)
xb (nth i xcb)
xx (- (* (car xa) (cadr xb)) (* (car xb) (cadr xa)))
p1 (apply 'mapcar (cons 'min (nth i pts0)))
p3 (apply 'mapcar (cons 'max (nth i pts0)))
i (1+ i)
)
(if (and
(equal xx 0 1e-5)
(AND
(or
(< (CAR P1) (CAR pnt2) (CAR P3))
(equal (CAR P1) (CAR pnt2) 1e-5)
(equal (CAR P3) (CAR pnt2) 1e-5)
)
(or
(< (CADR P1) (CADR pnt2) (CADR P3))
(equal (CADR P1) (CADR pnt2) 1e-5)
(equal (CADR P3) (CADR pnt2) 1e-5)
)
)
)
(setq gg (cons xx gg))
)
)
(vl-some '(lambda (x)
(equal x 0 1e-5))
gg)
)
(defun c:sqdb () ;获取程序
(setq ss1 (ssget '(
(-4 . "<AND")
(0 . "LWPOLYLINE")
(8 . "板轮廓线")
(-4 . "AND>")
)
)
)
(setq i -1)
(repeat (sslength ss1)
(setq tybs (cons (ssname ss1 (setq i (1+ i))) tybs))
)
(setq tybs (reverse tybs)
n 0
)
(repeat (setq shs (sslength ss1))
(setq mod0 (vl-remove nil (mapcar '(lambda (x) (if (= (car x) 10) (cdr x))) (entget (setq yy (nth n tybs))))))
(if (/= (setq ang1 (/ (* (angle (car mod0) (cadr mod0)) 180) pi)) 0)
(progn
(setq strpt (car mod0) ;旋转点坐标
bty (ssadd) ;板选择集
)
(command "_.rotate" (nth n tybs) "" strpt (- 360 ang1))
(setq mod0 (vl-remove nil (mapcar '(lambda (x) (if (= (car x) 10) (cdr x))) (entget (setq yy (nth n tybs))))))
));旋转判断函数，若不为正交则旋转
(setq
ptmin (apply 'mapcar (cons 'min mod0)) ;;;拾取点表最小坐标值
ptmax (apply 'mapcar (cons 'max mod0)) ;;;拾取点表最大坐标值
dxy (mapcar '- ptmax ptmin)
n (1+ n)
)
(if (> (cadr dxy) (car dxy))
(progn
(setq dfs (getint "\n请输入等分数： ")
bfk (getreal "\n请输入板缝宽： ")
lbk (/ (- (cadr dxy) (* bfk (1- dfs))) dfs)
pt1 ptmin
pt2 (list (car ptmax) (cadr ptmin))
pt3 (list (car ptmax) (+ (cadr ptmin) lbk))
pt4 (list (car ptmin) (+ (cadr ptmin) lbk))
dbd (list pt1 pt2 pt3 pt4 pt1)
)
(repeat dfs
(setq db1 (append (ptjd dbd (reverse (cons (car mod0) (reverse mod0)))) (vl-remove-if '(lambda(x)
(not (or
(pntison x dbd)
(pntisin x dbd)
))) mod0)
)
db1 (XD::List:RemoveDup db1)
db1 (XD::PntS:MinX->MinY db1 1e-5)
db1 (sortnn db1 yy)
dbd (mapcar '(lambda(x)
(list (car x) (+ (cadr x) lbk bfk))) dbd)
)
(xdrx_polyline_make db1 t)
(ssadd (entlast) bty)
)
(command "_.rotate" bty "" strpt ang1)
)
)
)
)

(defun dblk (pts1 /) ;点表创建闭合多段线 
  (entmake (append 
             (list 
               '(0 . "LWPOLYLINE") 
               '(100 . "AcDbEntity") 
               '(8 . "板轮廓线") 
               '(70 . 1) 
               '(100 . "AcDbPolyline") 
                (cons 90 (length pts1))) 
                (mapcar '(lambda (pt) (cons 10 pt)) pts1)) 
  ) 
) 
(defun sortxy (pts2 Tol / pt1 pt2) ;点表XY排序函数 
  (vl-sort pts2 '(lambda (pt1 pt2) 
                  (if (equal (cadr pt1) (cadr pt2) tol) 
                    (if (equal (car pt1) (car pt2) tol) 
                      (< (caddr pt1) (caddr pt2)) 
                      (< (car pt1) (car pt2)) 
                    ) 
                    (< (cadr pt1) (cadr pt2)) 
                  ) 
                ) 
  ) 
) 
(defun getarea (pts3 / pts1 iSum p0 p1 p2 x0 x1 x2 y0 y1 y2) 
 (setq pts1 pts3) 
 (setq iSum 0) 
 (setq p0 (car pts3) 
 x0 (car  p0) 
 y0 (cadr p0) 
 ) 
 (while (cdr pts1) 
   (setq p1 (car pts1) 
   x1 (car p1) 
   y1 (cadr p1) 
   p2 (cadr pts1) 
   y2 (cadr p2) 
   x2 (car p2) 
   iSum (+ iSum (- (* x1 y2) (* x2 y1))) 
   pts1 (cdr pts1) 
   ) 
 ) 
 (/ (+ iSum (- (* (caar pts1) y0)  (* x0 (cadar pts1)))) 2.0) 
) 
(defun Sortnn (pts e / acaddocument acadobject e1 mspace  obj objname x y) 
  (vl-load-com) 
  (defun AddPline (space lst / x) 
 
    (if (> (length lst) 2) 
       (vlax-invoke space  'AddLightWeightPolyline (apply 
                                                 'append 
                                                 (mapcar 
                                                   '(lambda (x) 
                                                      (list (float (car x)) ; _此处应为Double, INT会Fail 
                                                            (float (cadr x)) 
                                                      ) 
                                                    ) 
                                                   lst 
                                                 ) 
                                               ) 
        ) 
        (progn 
          (vla-AddXLine space (vlax-3d-point (car lst))(vlax-3d-point (cadr lst))) 
        ) 
    ) 
  ) 
  (cond 
    ((and 
       (= (type e) 'ENAME) 
       (setq objname (cdr (assoc 0 (entget e)))) 
       (wcmatch (strcase objname) "*LINE,*CIRCLE,*ARC,*ELLIPSE") 
     ) 
      (setq pts1 (mapcar 
                   'cdr 
                   (vl-sort (mapcar 
                              '(lambda (x) 
                                 (cons (vlax-curve-getParamAtPoint e (vlax-curve-getClosestPointTo e x t)) x) 
                               ) 
                              pts 
                            ) '(lambda (x y) 
                                 (< (car x) (car y)) 
                               ) 
                   ) 
                 ) 
      ) 
    ) 
    ((and (= (type e) 'LIST) 
          (> (length e) 1) 
     ) 
      (setq AcadObject (vlax-get-acad-object) 
            AcadDocument (vla-get-ActiveDocument AcadObject) 
            mSpace (vla-get-ModelSpace AcadDocument) 
      ) 
      (addpline mspace e) 
      (vlax-release-object mSpace) 
      (vlax-release-object AcadDocument) 
      (vlax-release-object AcadObject) 
      (setq e1 (entlast)) 
      (setq pts1 (Pnts-Sort-Cruve pts e1)) 
      (entdel e1) 
    ) 
  ) 
  pts1 
) 
(defun sortonpl (pl pts7) 
  (setq pts7 (mapcar 
       '(lambda (x) 
   (list (vlax-curve-getdistatpoint 
    pl 
    (vlax-curve-getclosestpointto pl x) 
         ) 
         x 
   ) 
        ) 
       pts7 
     ) 
pts7 (vl-sort pts7 
       '(lambda (e1 e2) 
   (< (car e1) (car e2)) 
        ) 
     ) 
  ) 
  (list pl 
(mapcar 
   'cadr 
   pts 
) 
  ) 
) 
(defun ptjd (pts5 pts6  / i j ii jj pt1 pt2 pt3 pt4 intpt interpt) ;交点坐标计算函数 
   (setq ii (1- (length pts5))) 
   (setq jj (1- (length pts6))) 
   (setq intpt nil interpt nil i 0 ) 
   (while (
     (setq pt1 (nth i pts5)) 
     (setq pt2 (nth (1+ i) pts5)) 
     (setq j 0) 
     (while (< j jj) 
       (setq pt3 (nth j pts6)) 
       (setq pt4 (nth (1+ j) pts6)) 
       (setq intpt (inters pt1 pt2 pt3 pt4 t) ) 
       (if (/= intpt nil) 
           ;将交点坐标存入点表 
           (setq interpt (append interpt (list intpt))) 
       ) 
       (setq j (1+ j)) 
     ) 
     (setq i (1+ i)) 
   ) 
interpt 
)               
(defun pntisin (pnt1 pnts1  / pts0 pts1 an ptn total);判断点在线内 
(setq pts1 
  (if (not (equal (car pnts1) (last pnts1) 1e-5)) 
   (reverse (cons (car pnts1) (reverse pnts1))) ;点表闭合 
   pnts1 
 ) 
   pts0   (mapcar 'list pts1 (cdr pts1));首尾组对 
   total 0 
      ) 
  (mapcar 
    '(lambda (x) 
       (setq an (- (angle pnt1 (car x)) (angle pnt1 (cadr x))))    
       (cond 
         ((> an pi) 
           (setq an (- an pi)) 
         ) 
         ((< an (* -1 pi)) 
           (setq an (+ an pi)) 
         ) 
       ) 
       (setq total (+ total an)) 
     ) 
    pts0 
  ) 
  (if (equal (- (abs total) pi) 0.0 1e-5) 
    t 
    nil 
  ) 
) 
(defun pntison (pnt2 pnts2  / pts0 pts1 xca xcb xa xb i gg p1 p3);判断点在线上 
  (setq pts1 
  (if (not (equal (car pnts2) (last pnts2) 1e-5)) 
   (reverse (cons (car pnts2) (reverse pnts2)))    ;点表闭合 
   pnts2 
 )) 
   (setq pts0   (mapcar 'list pts1 (cdr pts1));首尾组对 
      ) 
(setq xca 
  (mapcar 
    '(lambda (x) 
       (mapcar '- pnt2 (car x)) 
       ) 
    pts0 
    )) 
(setq xcb 
  (mapcar 
    '(lambda (x) 
       (mapcar '- (cadr x) (car x)) 
       ) 
    pts0 
    )) 
  (setq i 0) 
  (repeat (length xca) 
    (setq xa (nth i xca) 
          xb (nth i xcb) 
          xx (- (* (car xa) (cadr xb)) (* (car xb) (cadr xa))) 
          p1 (apply 'mapcar (cons 'min (nth i pts0))) 
          p3 (apply 'mapcar (cons 'max (nth i pts0))) 
          i (1+ i) 
          ) 
  (if (and 
          (equal xx 0 1e-5) 
          (AND 
          (or 
          (< (CAR P1) (CAR pnt2) (CAR P3)) 
          (equal (CAR P1) (CAR pnt2) 1e-5) 
          (equal (CAR P3) (CAR pnt2) 1e-5) 
          ) 
          (or 
          (< (CADR P1) (CADR pnt2) (CADR P3)) 
          (equal (CADR P1) (CADR pnt2) 1e-5) 
          (equal (CADR P3) (CADR pnt2) 1e-5) 
          ) 
          ) 
        ) 
      (setq gg (cons xx gg)) 
    ) 
    ) 
  (vl-some '(lambda (x) 
                   (equal x 0 1e-5)) 
                gg) 
    ) 
(defun c:sqdb () ;获取程序   
  (setq ss1 (ssget '( 
             (-4 . "<AND") 
             (0 . "LWPOLYLINE") 
             (8 . "板轮廓线") 
             (-4 . "AND>") 
            ) 
                   ) 
        ) 
  (setq i -1) 
  (repeat (sslength ss1) 
    (setq tybs (cons (ssname ss1 (setq i (1+ i))) tybs)) 
  ) 
  (setq tybs (reverse tybs) 
        n      0 
        ) 
(repeat (setq shs (sslength ss1)) 
  (setq mod0 (vl-remove nil (mapcar  '(lambda (x) (if (= (car x) 10) (cdr x))) (entget (setq yy (nth n tybs)))))) 
  (if (/= (setq ang1 (/ (* (angle (car mod0) (cadr mod0)) 180) pi)) 0) 
      (progn 
      (setq strpt (car mod0) ;旋转点坐标 
            bty  (ssadd) ;板选择集 
            ) 
      (command "_.rotate" (nth n tybs) "" strpt  (- 360 ang1)) 
      (setq mod0 (vl-remove nil (mapcar  '(lambda (x) (if (= (car x) 10) (cdr x))) (entget (setq yy (nth n tybs)))))) 
      ));旋转判断函数，若不为正交则旋转 
        (setq 
        ptmin (apply 'mapcar (cons 'min mod0)) ;;;拾取点表最小坐标值 
        ptmax (apply 'mapcar (cons 'max mod0)) ;;;拾取点表最大坐标值 
        dxy (mapcar '- ptmax ptmin) 
        n (1+ n) 
        )      
  (if (> (cadr dxy) (car dxy)) 
    (progn 
      (setq dfs (getint "\n请输入等分数： ") 
            bfk (getreal "\n请输入板缝宽： ") 
            lbk (/ (- (cadr dxy) (* bfk (1- dfs))) dfs) 
            pt1 ptmin 
            pt2 (list (car ptmax) (cadr ptmin)) 
            pt3 (list (car ptmax) (+ (cadr ptmin) lbk)) 
            pt4 (list (car ptmin) (+ (cadr ptmin) lbk)) 
            dbd (list pt1 pt2 pt3 pt4 pt1) 
            ) 
      (repeat dfs 
      (setq db1 (append        (ptjd dbd (reverse (cons (car mod0) (reverse mod0)))) (vl-remove-if '(lambda(x) 
                                                             (not (or 
                                                               (pntison x dbd) 
                                                               (pntisin x dbd) 
                                                               ))) mod0) 
                        ) 
            db1 (XD::List:RemoveDup db1) 
            db1 (XD::PntS:MinX->MinY db1 1e-5) 
            db1 (sortnn db1 yy) 
            dbd (mapcar '(lambda(x) 
                           (list (car x) (+ (cadr x) lbk bfk))) dbd) 
            ) 
        (xdrx_polyline_make  db1 t) 
        (ssadd (entlast) bty) 
        ) 
      (command "_.rotate" bty "" strpt  ang1) 
      ) 
    ) 
  ) 
      )

连着学带做，30多岁了还有这种毅力，做出来现在这些代码还真有成就感，不得不佩服代码这东西，越写越着魔
首先还是得感谢Lispboy的点表沿实体排序函数，搜刮好久，一直没有找到合适的函数
其次得感谢 newer marting版主在我提问时给我的解答
子函数基本都是参考了XDAPI为了便于学习码的，有需要的同僚可以直接用API
主程序还缺少另一个方向的分割，但至少Y方向和非正交问题可以解决了
工夫不负有心人哪，代码优化完成后我会贴上来，各位大神可以先看看可以优化的程序结构
主程序完成时，我想定义两种等分模式，固定间距等分和模数化等分，有建议也可以指点指点

a117034423 · 发表于 2021-1-2 01:05:57

没有人指点一下嘛

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

[每日一码] 指定间距等分凸凹多边形（草稿）

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