简单操作不堪重负，深夜求急诊！！--平行图块自动连线

半听可乐 · 发表于 2014-5-17 01:50

水专业的喷头连管道，以及画一些辅助线（便于施工定位），用天正画断然能自动连管线，但是辅助线还是无能为力，对于不用天正的同行来说，工作量更是繁重，故再次翘首以盼一个巧夺天工的lisp程序来解决这个枯燥而重复繁琐的简单劳动！！！

longcashman · 发表于 2014-5-17 01:50

我刚看到你图纸上还有一个不输入方向的要求；替换下面的函数大概可以满足要求
其实是个偷懒的办法，高飞鸟的分治求点集最短距离算法最靠谱

(defun assistLine (/ dir1 dir2 ss enlst ptlst dirlistpt)
(if (not (setq en (car (entsel "\n 选择样例喷头"))))
(setq blkName "j_pt1");
(setq blkName (cdr (assoc 2 (entget en))))
)
(princ "\n 框选喷头范围")
(setq ss (ssget (list '(0 . "INSERT") (cons 2 blkName))))
(setq enlst (ss->lst ss))
(setq
ptlst (mapcar '(lambda (en) (car (MJ:Massoc 10 (entget en))))
enlst
)
)
(setq dirlistpt(list(car ptlst) (cadr ptlst) (caddr ptlst)))
(setq distanclst (list (apply ' distance (list(car ptlst)(cadr ptlst))) (apply ' distance (list (car ptlst)(caddr ptlst)))))
(if (= 0 (vl-position (apply 'min distanclst)distanclst))(setq dir1 (mapcar '- (car ptlst) (cadr ptlst) ))(setq dir1 (mapcar '- (car ptlst) (cadr ptlst) )))
;;; (setvar "osmode" 4)
;;; (setq dirlinent (entget(car(entsel"\n 选择方向线"))))
(setq dir2 (MAT:Rot90 dir1))
(setvar "osmode" 0)
(toDraw (makeDirPts ptlst dir1))
(toDraw (makeDirPts ptlst dir2))
)

(defun assistLine  (/ dir1 dir2 ss enlst ptlst dirlistpt) 
   (if (not (setq en (car (entsel "\n 选择样例喷头")))) 
    (setq blkName "j_pt1"); 
    (setq blkName (cdr (assoc 2 (entget en)))) 
  ) 
   (princ "\n 框选喷头范围") 
 
  (setq ss (ssget (list '(0 . "INSERT") (cons 2 blkName)))) 
  (setq enlst (ss->lst ss)) 
  (setq 
    ptlst (mapcar '(lambda (en) (car (MJ:Massoc 10 (entget en)))) 
                  enlst 
                  ) 
    ) 
  (setq dirlistpt(list(car ptlst) (cadr ptlst) (caddr ptlst))) 
  (setq distanclst (list (apply ' distance (list(car ptlst)(cadr ptlst))) (apply ' distance (list (car ptlst)(caddr ptlst))))) 
  (if (= 0 (vl-position (apply 'min distanclst)distanclst))(setq dir1 (mapcar '-      (car ptlst)    (cadr ptlst)    ))(setq dir1 (mapcar '-      (car ptlst)    (cadr ptlst)    ))) 
;;;  (setvar "osmode" 4) 
;;;  (setq dirlinent (entget(car(entsel"\n 选择方向线")))) 
  (setq dir2 (MAT:Rot90 dir1)) 
  (setvar "osmode" 0) 
   
                                  
(toDraw (makeDirPts ptlst dir1)) 
  (toDraw (makeDirPts ptlst dir2)) 
  )

半听可乐 · 发表于 2014-5-17 15:29

自己顶一下，盼高手来相助

xyp1964 · 发表于 2014-5-30 23:25

xyp1964 · 发表于 2014-5-30 23:37

Gu_xl · 发表于 2014-5-31 11:42

本帖最后由 Gu_xl 于 2014-5-31 11:56 编辑

这只需对坐标进行简单的排序分组即可，以下提供一个点表坐标排序函数样例：

;;点表按Y方向从大到小，X方向从小到大排序，即（横向）自上而下，自左而右排序分组
;;pts 点表 tol 容差值
(defun sortPts-row (pts tol / LST L)
(setq pts
(vl-sort
pts
'(lambda (a b)
(if (equal (cadr a) (cadr b) tol)
(< (car a) (car b)) ;_ X方向从小到大排序
(> (cadr a) (cadr b)) ;_ Y方向从大到小
)
)
)
)
;;对pts进行分组
(setq lst nil
l (list (car pts))
pts (cdr pts)
)
(while pts
(if (equal (cadar pts) (cadar l) tol)
(setq l (cons (car pts) l)
pts (cdr pts)
)
(setq lst (cons l lst)
l (list (car pts))
pts (cdr pts)
)
)
)
(setq lst (cons l lst)) ;_ 以按行分好组的点表
)

点表按X方向从小到大，Y方向小到大排序，即(纵向)自左而右、自下而上排序，原理和上面相同，请自己参照写出；
非水平方向的，只需先对坐标转换到非水平方向的UCS坐标即可，或者采用矩阵来进行坐标变换，可参照高飞鸟的矩阵相关帖子。
完整的程序完成，需要你自己来完成！
实际演示效果：

zhuquanmao · 发表于 2014-5-31 18:27

Gu_xl 发表于 2014-5-31 11:42
这只需对坐标进行简单的排序分组即可，以下提供一个点表坐标排序函数样例：

点表按X方向从小到大，Y方向 ...

经典啊谢谢老大们的无私奉献

半听可乐 · 发表于 2014-5-31 22:14

Gu_xl 发表于 2014-5-31 11:42
这只需对坐标进行简单的排序分组即可，以下提供一个点表坐标排序函数样例：

点表按X方向从小到大，Y方向 ...

非常感谢G版的再次发力，现在很需要这个功能，非常感谢！

半听可乐 · 发表于 2014-5-31 22:23

xyp1964 发表于 2014-5-30 23:37

院长，你第二个演示中的效果我这里怎么出不来呢？横平竖直的倒是可以

longcashman · 发表于 2014-6-5 23:37

来看看我榨出来的脑汁
老顾的排序太高大上了，看不懂。
突然想到直接画构造线然后打断的法子，
一试之下没想到交点打断那么复杂还特别慢。
榨了三四天才榨出这个东西来。借用了各大的函数；自己写的难看，好在还能用。
30*30个喷头大概在9秒左右

;;示例 (MJ:Massoc 10 (entget (car (entsel))))
;; Notes:特别适合多段线各顶点;作者
(defun MJ:Massoc (key alist)
(apply
'append
(mapcar '(lambda (x)
(if (eq (car x) key)
(list (cdr x))
)
)
alist
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;[功能] 选择集->图元列表 By caiqs ;
(defun ss->lst (ss / retu)
(setq retu (apply 'append (ssnamex ss)))
(setq retu (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) retu))
)
;;;判断平面上的三点是否共线By highflybir ;
;;;----------------------------------------------------;
;;;功能: 判断平面上的三点是否共线 ;
;;;输入: 三点 P1,P2,P3 ;
;;;输出: T 说明三点共线，否则不共线 ;
;;;----------------------------------------------------;
(defun ptAtLine? (p1 p2 p3 / a b c eps)
(setq eps 1e-6)
(setq a (distance p2 p3))
(setq b (distance p3 p1))
(setq c (distance p1 p2))
(or (equal (+ a b) c eps)
(equal (+ b c) a eps)
(equal (+ c a) b eps)
)
)
;;; 旋转一个向量或者点90度By highflybird ;
(defun MAT:Rot90 (vec)
(vl-list* (- (cadr vec)) (car vec) (cddr vec))
)
;;==============================================================;
(defun sortbydistance (tlst / resortedalst clst alst xlst sortedalst outer inner)
(while (> (length tlst) 2)
(setq clst
(cons
(mapcar '(lambda (x) (distance (car tlst) x)) (cdr tlst))
clst
)
)
(setq tlst (cdr tlst))
)
(setq clst (cons (list (apply 'distance tlst)) clst))
(setq clst (reverse clst)) ;点到其余各点距离
(setq alst (apply 'append clst)) ;摊平
(setq xlst (makepart clst))
(setq sortedalst (vl-sort-i alst '>)) ;从大到小
(foreach vp sortedalst
(setq outer (getpart vp xlst)) ;外层的位置即第几个区间
(setq inner (vl-position (nth vp alst) (nth outer clst)))
;内层的位置
(setq resortedalst
(cons (cons outer (+ outer inner 1)) resortedalst)
)
)
resortedalst
)
;;==============================================================;
(defun makepart (clst / i low up xlst indexlst)
(setq i 0
low 0
up -1
xlst nil
)
(setq indexlst (mapcar 'length clst))
(repeat (length indexlst)
(setq up (+ (1+ up) (1- (nth i indexlst))))
(setq xlst (cons (cons low up) xlst))
(setq low (1+ up))
(setq i (1+ i))
)
(setq xlst (reverse xlst))
)
;;==============================================================;
(defun getpart (num xlst / i q)
(setq i 0)
(foreach part xlst
(if (and (>= num (car part)) (<= num (cdr part)))
(setq q i)
(setq i (1+ i))
)
)
q
)
;;==============================================================;
(defun makeDirPts (ptlst dir / aline ent p1 p2 sumaline)
(while ptlst
(setq aline nil)
(setq p1 (car ptlst))
(setq p2 (mapcar '+ p1 dir))
(setq aline (cons p1 aline))
(setq ptlst (cdr ptlst))
(foreach pt ptlst
(if (ptAtLine? pt p1 p2)
(progn
(setq aline (cons pt aline))
(setq ptlst (vl-remove-if '(lambda (x) (equal pt x)) ptlst))
)
)
)
(setq sumaline (cons aline sumaline))
)
sumaline
)
;;==============================================================;
(defun toDraw (dir1pts / tyu culst i finaldrawpts templst newtyu)
(foreach ptlst dir1pts
(setq leng (length ptlst)) ;ptlst是一条线上的点表
(setq
tyu (cons (cons (sortbydistance ptlst) (list (1- leng))) tyu)
)
)
(setq newtyu (mapcar '(lambda (onetyu)
(setq ls (car onetyu))
(setq newonetyu nil)
(repeat (last onetyu)
(setq newonetyu (cons (car ls) newonetyu))
(setq ls (cdr ls))
)
newonetyu
)
tyu
)
)
(setq finaldrawpts
(mapcar '(lambda (aNewtyu aDir1pts)
(mapcar '(lambda (aptpair)
(list (nth (car aptpair) aDir1pts)
(nth (cdr aptpair) aDir1pts)))
aNewtyu))
newtyu
dir1pts)
)
(foreach ps finaldrawpts
(foreach oneps ps
(vl-cmdf "LINE"
(car oneps)
(cadr oneps)
""
)
)
)
)
;;==============================================================;
(defun assitLinemain
(/ dir dir90 ss enlst ptlst blkName dir1pts dir2pts)
(if (not (setq en (car (entsel "\n 选择样例喷头"))))
(setq blkName "j_pt1");这里，你懂的！
(setq blkName (cdr (assoc 2 (entget en))))
)
(setvar "osmode" 4)
(setq dir (mapcar '-
(getpoint "\n 点取辅助线方向点1")
(getpoint "\n 点取辅助线方向点2")
)
)
(setq dir90 (MAT:Rot90 dir))
(setvar "osmode" 0)
(princ "\n 框选喷头范围")
(setq ss (ssget (list '(0 . "INSERT") (cons 2 blkName))))
(setq enlst (ss->lst ss))
(setq ptlst (mapcar '(lambda (en) (car (MJ:Massoc 10 (entget en))))
enlst
)
)
(toDraw (makeDirPts ptlst dir))
(toDraw (makeDirPts ptlst dir90))
)
;;==============================================================;
(defun c:tt (/ oldOs)
(setq oldOs (getvar "osmode"))
(assitLinemain)
(setvar "osmode" oldOs)
)

;;示例 (MJ:Massoc 10 (entget (car (entsel)))) 
;; Notes:特别适合多段线各顶点;作者       
(defun MJ:Massoc (key alist) 
  (apply 
    'append 
    (mapcar '(lambda (x) 
               (if (eq (car x) key) 
                 (list (cdr x)) 
               ) 
             ) 
            alist 
    ) 
  ) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;[功能] 选择集->图元列表 By caiqs          ; 
(defun ss->lst (ss / retu) 
  (setq retu (apply 'append (ssnamex ss))) 
  (setq retu (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) retu)) 
) 
;;;判断平面上的三点是否共线By highflybir               ; 
;;;----------------------------------------------------; 
;;;功能: 判断平面上的三点是否共线                      ; 
;;;输入: 三点 P1,P2,P3                                 ; 
;;;输出: T 说明三点共线，否则不共线                    ; 
;;;----------------------------------------------------; 
(defun ptAtLine? (p1 p2 p3 / a b c eps) 
  (setq eps 1e-6) 
  (setq a (distance p2 p3)) 
  (setq b (distance p3 p1)) 
  (setq c (distance p1 p2)) 
  (or (equal (+ a b) c eps) 
      (equal (+ b c) a eps) 
      (equal (+ c a) b eps) 
  ) 
) 
;;; 旋转一个向量或者点90度By highflybird               ; 
(defun MAT:Rot90 (vec) 
  (vl-list* (- (cadr vec)) (car vec) (cddr vec)) 
) 
;;==============================================================; 
(defun sortbydistance (tlst / resortedalst clst alst xlst sortedalst outer inner) 
  (while (> (length tlst) 2) 
    (setq clst 
           (cons 
             (mapcar '(lambda (x) (distance (car tlst) x)) (cdr tlst)) 
             clst 
           ) 
    ) 
    (setq tlst (cdr tlst)) 
  ) 
  (setq clst (cons (list (apply 'distance tlst)) clst)) 
  (setq clst (reverse clst))                ;点到其余各点距离 
  (setq alst (apply 'append clst))        ;摊平 
 
  (setq xlst (makepart clst)) 
 
  (setq sortedalst (vl-sort-i alst '>))        ;从大到小 
 
  (foreach vp sortedalst 
    (setq outer (getpart vp xlst))        ;外层的位置即第几个区间 
    (setq inner (vl-position (nth vp alst) (nth outer clst))) 
                                        ;内层的位置 
    (setq resortedalst 
           (cons (cons outer (+ outer inner 1)) resortedalst) 
    ) 
  ) 
  resortedalst 
) 
;;==============================================================; 
(defun makepart        (clst / i low up xlst indexlst) 
  (setq        i    0 
        low  0 
        up   -1 
        xlst nil 
  ) 
  (setq indexlst (mapcar 'length clst)) 
  (repeat (length indexlst) 
    (setq up (+ (1+ up) (1- (nth i indexlst)))) 
    (setq xlst (cons (cons low up) xlst)) 
    (setq low (1+ up)) 
 
    (setq i (1+ i)) 
  ) 
  (setq xlst (reverse xlst)) 
) 
;;==============================================================; 
(defun getpart (num xlst / i q) 
  (setq i 0) 
  (foreach part        xlst 
    (if        (and (>= num (car part)) (<= num (cdr part))) 
      (setq q i) 
      (setq i (1+ i)) 
    ) 
 
  ) 
  q 
) 
 
;;==============================================================; 
(defun makeDirPts (ptlst dir / aline ent p1 p2 sumaline) 
 
  (while ptlst 
    (setq aline nil) 
    (setq p1 (car ptlst)) 
    (setq p2 (mapcar '+ p1 dir)) 
    (setq aline (cons p1 aline)) 
    (setq ptlst (cdr ptlst)) 
    (foreach pt        ptlst 
      (if (ptAtLine? pt p1 p2) 
        (progn 
          (setq aline (cons pt aline)) 
          (setq ptlst (vl-remove-if '(lambda (x) (equal pt x)) ptlst)) 
        ) 
      ) 
    ) 
    (setq sumaline (cons aline sumaline)) 
  ) 
  sumaline 
) 
;;==============================================================; 
(defun toDraw (dir1pts / tyu culst i finaldrawpts templst newtyu) 
 
  (foreach ptlst dir1pts 
    (setq leng (length ptlst))                ;ptlst是一条线上的点表 
    (setq 
      tyu (cons (cons (sortbydistance ptlst) (list (1- leng))) tyu) 
    ) 
  ) 
 
  (setq        newtyu (mapcar '(lambda        (onetyu) 
                          (setq ls (car onetyu)) 
                          (setq newonetyu nil) 
                          (repeat (last onetyu) 
                            (setq newonetyu (cons (car ls) newonetyu)) 
                            (setq ls (cdr ls)) 
                          ) 
                          newonetyu 
                        ) 
                       tyu 
               ) 
  ) 
  (setq        finaldrawpts 
         (mapcar '(lambda (aNewtyu aDir1pts) 
                    (mapcar '(lambda (aptpair) 
                               (list (nth (car aptpair) aDir1pts) 
                                     (nth (cdr aptpair) aDir1pts))) 
                            aNewtyu)) 
                 newtyu 
                 dir1pts) 
 
 
        ) 
  (foreach ps finaldrawpts 
    (foreach oneps ps 
      (vl-cmdf "LINE" 
               (car oneps) 
               (cadr oneps) 
               "" 
      ) 
 
    ) 
  ) 
) 
;;==============================================================; 
(defun assitLinemain 
       (/ dir dir90 ss enlst ptlst blkName dir1pts dir2pts) 
  (if (not (setq en (car (entsel "\n 选择样例喷头")))) 
    (setq blkName "j_pt1");这里，你懂的！ 
    (setq blkName (cdr (assoc 2 (entget en)))) 
  ) 
  (setvar "osmode" 4) 
  (setq        dir (mapcar '- 
                    (getpoint "\n 点取辅助线方向点1") 
                    (getpoint "\n 点取辅助线方向点2") 
            ) 
  ) 
  (setq dir90 (MAT:Rot90 dir)) 
  (setvar "osmode" 0) 
  (princ "\n 框选喷头范围") 
 
  (setq ss (ssget (list '(0 . "INSERT") (cons 2 blkName)))) 
  (setq enlst (ss->lst ss)) 
  (setq        ptlst (mapcar '(lambda (en) (car (MJ:Massoc 10 (entget en)))) 
                      enlst 
              ) 
  )                                
   
  (toDraw (makeDirPts ptlst dir)) 
  (toDraw (makeDirPts ptlst dir90)) 
) 
;;==============================================================; 
(defun c:tt (/ oldOs) 
  (setq oldOs (getvar "osmode")) 
  (assitLinemain) 
  (setvar "osmode" oldOs) 
)

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

[已解答] 简单操作不堪重负，深夜求急诊！！--平行图块自动连线

最佳答案

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

点评