[LISP程序]：急需直线合并的LISP FOR2005

chenhang

急需直线合并的LISP FOR2005*-*9

lijiao

http://www.xdcad.net/forum/showthread.php?s=&postid=434934

chenhang

最初由 lijiao 发布
[B]http://www.xdcad.net/forum/showthread.php?s=&postid=434934 [/B]

我是想要把两跟断开的直线合并在一起
能给我个LISP吗

lijiao

最初由 chenhang 发布
[B]
我是想要把两跟断开的直线合并在一起
能给我个LISP吗 [/B]

用了一个小时时间为你写了一个，供你参考
[php]
;;;将共线的二直线合并为一条直线
;;;编写：李蛟
(defun c:hebing
       (/ ent1 ent2 entlist1 entlist2 pt11 pt12 pt21 pt22 ptlist)
  (cond
    ((and
       (setq ent1 (entsel "\n选择第一条直线:"))
       (not (redraw (car ent1) 3))
       (setq ent2 (entsel "\n选择第二条直线:"))
;;;       (not (redraw (car ent2) 3))
     )
;;;     取得端点
     (setq ent1            (car ent1)
           ent2            (car ent2)
           entlist1 (entget ent1 '("*"))
           entlist2 (entget ent2 '("*"))
           pt11            (cdr (assoc 10 entlist1))
           pt12            (cdr (assoc 11 entlist1))
           pt21            (cdr (assoc 10 entlist2))
           pt22            (cdr (assoc 11 entlist2))
     )
;;;     判断是否共线
     (if (and (gongxian pt11 pt12 pt21)
              (gongxian pt11 pt12 pt22)
         )
       (progn
         (if (equal (angle pt11 pt12) (* 0.5 pi) 0.01)
           (setq ptlist        (sorty pt11 pt12)
                 pt11        (car ptlist)
                 pt12        (cadr ptlist)
                 ptlist        (sorty pt21 pt22)
                 pt21        (car ptlist)
                 pt22        (cadr ptlist)
                 ptlist        (sorty pt11 pt21)
                 pt11        (car ptlist)
                 pt21        (cadr ptlist)
                 ptlist        (sorty pt12 pt22)
                 pt22        (car ptlist)
                 pt12        (cadr ptlist)
           )
           (setq ptlist        (sortx pt11 pt12)
                 pt11        (car ptlist)
                 pt12        (cadr ptlist)
                 ptlist        (sortx pt21 pt22)
                 pt21        (car ptlist)
                 pt22        (cadr ptlist)
                 ptlist        (sortx pt11 pt21)
                 pt11        (car ptlist)
                 pt21        (cadr ptlist)
                 ptlist        (sortx pt12 pt22)
                 pt22        (car ptlist)
                 pt12        (cadr ptlist)
           )
         )
         (setq entlist1        (subst (cons 10 pt11) (assoc 10 entlist1) entlist1)
               entlist1        (subst (cons 11 pt12) (assoc 11 entlist1) entlist1)
         )
;;;         更新图元
         (entmod entlist1)
         (redraw ent1)
         (entdel ent2)
       )
       (princ "\n二直线不共线。")
     )
    )
    (t (princ))
  )
  (princ)
)
;;;三点共线
(defun gongxian        (pt1 pt2 pt3 / dis1 dis2 dis3)
  (setq        dis1 (distance pt1 pt2)
        dis2 (distance pt2 pt3)
        dis3 (distance pt3 pt1)
  )
  (equal (* 0.5 (+ dis1 dis2 dis3))
         (max dis1 dis2 dis3)
         0.000001
  )
)
;;;排序
(defun sortx (pt1 pt2 /)
  (vl-sort (list pt1 pt2)
           (function (lambda (e1 e2)
                       (< (car e1) (car e2))
                     )
           )
  )
)
(defun sorty (pt1 pt2 /)
  (vl-sort (list pt1 pt2)
           (function (lambda (e1 e2)
                       (< (cadr e1) (cadr e2))
                     )
           )
  )
)
[/php]

陌生人

[php]
;c:joinline=连接2直线－－陌生人.2004.1
(defun c:jl (/ e1 e2 obj1 obj2 pt11 pt12 pt21 pt22 ptlst z angsub ptmin ptmax el1 nlin del)
  (if (and (progn (setq  e1 (car (entsel)))(= "LINE"  (cdr(assoc 0 (entget e1)))))
           (progn (setq  e2 (car (entsel)))(= "LINE"  (cdr(assoc 0 (entget e2))))))
    (progn
      (setq obj1 (vlax-ename->vla-object e1)
          obj2 (vlax-ename->vla-object e2)
          pt11 (vlax-get obj1 'startpoint)
          pt12 (vlax-get obj1 'endpoint)
          pt21 (vlax-get obj2 'startpoint)
          pt22 (vlax-get obj2 'endpoint)
          ptlst (list pt11 pt12 pt21 pt22)
          z     (last pt11)
          angsub(abs (- (angle pt11 pt12) (angle pt21 pt22)))
          ptmin (list (apply 'min (mapcar 'car ptlst))(apply 'min (mapcar 'cadr ptlst)) z)
          ptmax (list (apply 'max (mapcar 'car ptlst))(apply 'max (mapcar 'cadr ptlst)) z))
    (if (equal pt11 pt21 0.001)
      (setq angsub2 (abs (- (angle pt11 pt12) (angle pt11 pt22))))
      (setq angsub2 (abs (- (angle pt11 pt12) (angle pt11 pt21))))
    )
    (if (and (equal (rem angsub PI) 0 0.001)(equal (rem angsub2 PI) 0 0.001))
    ;;;(if (equal (rem angsub PI) 0 0.001)
        (setq el1 (entget e1)
              el1 (subst (cons 10 ptmin) (assoc 10 el1) el1)
              el1 (subst (cons 11 ptmax) (assoc 11 el1) el1)
              nlin(entmod el1)
              del (entdel e2))
    )
   );(princ "\n无法连接合并")
)
(princ)
)[/php]

aeo

最初由 陌生人 发布
[B]
;c:joinline=连接2直线－－陌生人.2004.1
(defun c:jl (/ e1 e2 obj1 obj2 pt11 pt12 pt21 pt22 ptlst z angsub ptmin ptmax el1 nlin del)
  (if (and (progn (setq  e1 (car (entsel)))(= "LINE"  (cdr(a... [/B]

(equal (rem angsub PI) 0 0.001)
还没共线吧.

p11 p12    -- p21 p22 --  p11 p21 才行.

陌生人

谢谢指出。
原来仅可以判断平行。已经修改了。
”p11 p12 -- p21 p22 -- p11 p21 才行.“－－－－是什么意思？

aeo

不就是你的意思吗:
p11 p12 -- p21 p22 -- p11 p21  ,三条线平行，就成不了四边形，就是共线.


---------------------
(if (equal pt11 pt21 0.001)
      (setq angsub2 (abs (- (angle pt11 pt12) (angle pt11 pt22))))
      (setq angsub2 (abs (- (angle pt11 pt12) (angle pt11 pt21))))
    )
p12 = p21时,还是不成立.
你把问题复杂了，还不对.

lijiao  方法就很好

非要角度计算:
[php]
(and (equal(sin(- (angle p11 p12)(angle p21 p22))) 0 1e-4)  ;平行
        (or (equal p11 p21 1e-4)                  ;共点（没角度了)
            (equal(sin(- (angle p11 p12)(angle p11  p21))) 0 1e-4);p11 p12 p21成不了三角形
)        )
[/php]

可以面积是0 相当于用矢量差积求.

陌生人

p12 = p21时,还是不成立.
你把问题复杂了，还不对.
－－－我没明白，为什么不对了？
我后面用了(and (equal (rem angsub PI) 0 0.001)(equal (rem angsub2 PI) 0 0.001))

LUCAS

;;陌生人:程序只能用於XY平面?? 為甚麼把Z請樣處理,另有目的嗎?

ydf7332462

不共面时，给个选项，能交于ucs下的app

daemo2002

我是新手，请问程序怎么运行啊

urljit

新手：将以上代码存入一个文本文件，命名为lsp为扩展名的文件，再用appload加载这个文件即可。
楼上的几位大侠：是否可以判断（-（angle pt11 pt21）（angle pt11 pt22）
（-（angle pt12 pt21）（angle pt12 pt22）同时为零即可确定共线呢？

lijiao

ANGLE不好，因为它有些不确定，如0、PI、和2PI，还要增加其他判断。

urljit

李蛟：（-（angle pt11 pt21）（angle pt11 pt22）
计算的是向量还不行吗？