[求助]：请大家看看我编写的这个Lisp有什么问题？

gjt1244

如图所示：
首先判断线段papb、pcpd是否在同一方向；
我的方法是用angle函数；如果是则用直线命令连接pa、pd形成新线段papd，并删除线段papb和pcpd；刚刚学lisp，请大家指教；

(defun c:Link()
  (setq L1 (entsel "\n选取左边直线:"))
  (setq L2 (entsel "\n选取右边直线:"))
  (setq n1 (car L1))
  (setq n2 (car L2))
  (setq d1 (entget n1))
  (setq d2 (entget n2))
  (setq pa (cdr (assoc 10 d1)))
  (setq pb (cdr (assoc 11 d1)))
  (setq pc (cdr (assoc 10 d2)))
  (setq pd (cdr (assoc 11 d2)))
  (setq ang1 (angle pa pc))
  (setq ang2 (angle pa pd))
  (if (= ang1 ang2)
    (progn
      (command "line" pa pd "")
      (command "erase" L1 L2 "")
      )
    (alert "\n所选取的两直线不在同一直线上")
    )
  )

ljpnb

最初由 gjt1244 发布
[B]如图所示：
首先判断线段papb、pcpd是否在同一方向；
我的方法是用angle函数；如果是则用直线命令连接pa、pd形成新线段papd，并删除线段papb和pcpd；刚刚学lisp，请大家指教；

(defun c:Link()
  (setq L1 (en... [/B]

问题比较多,首先一点缺少判断,就是你怎么会知道pa和pd就是最远点,也是说pa和pd  的距离最远!
其次,(command "erase" n1 n2 ""),而不是(command "erase" L1 L2 "")

gjt1244

一 “你怎么会知道pa和pd就是最远点,也是说pa和pd 的距离最远”
      那我知道应该怎样做了。
二 “(command "erase" n1 n2 ""),而不是(command "erase" L1 L2 "")”
      entsel 返回的是一个表, 此表的第一个元素是被选取图元的图元名, 而第二个元素则是用来选取    图元的点坐标(UCS)。也就是说L1、L2是一个表，n1、n2才是图元的名称；按照我的方法是可以删除实体的，我试过了；

问题的关键我想是angle，如果我按照这样判断是否很正确的判断两线段在同一方向上？
如图：如果两线段在是水平上的，程序可以成功；否则（如上图）就显示“两直线不在同一方向上”；

ljpnb

这是我好几年之前写得,跟你的想法一样,只是我增加一些判断,可能当时水平有限,凑合着用了
(DEFUN C:JL()
    (setq a1 (entsel "\n 请选择第一条线:"))
    (setq a2 (entsel "\n 请选择第二条线:"))
    (setq b1(entget (car a1)))
    (setq b2(entget (car a2)))
    (setq c1(cdr (assoc 0 b1)))
    (setq c2(cdr (assoc 0 b2)))
    (if (and (= c1 "LINE") (= c2 "LINE"))
         (progn
            (setq p1(cdr (assoc 10 b1)))
            (setq p2(cdr (assoc 11 b1)))
            (setq p3(cdr (assoc 10 b2)))
            (setq p4(cdr (assoc 11 b2)))
            (setq n1(car a1))
            (setq n2(car a2))
            (setq d1(distance p1 p2))
            (setq d2(distance p2 p3))
            (setq d3(distance p1 p3))
            (setq d4(distance p3 p4))
            (setq d5(distance p2 p4))
            (if (equal (+ d1 d2) d3 0.0001)
                (progn
                   (if (equal (+ d2 d4) d5 0.0001)
                      (progn
                         (command "line" p1 p4 "")
                         (command "erase" n1 n2 "")
                      )
                      (progn
                            (command "line" p1 p3 "")
                            (command "erase" n1 n2 "")
                      )
                    )
                 )
                 (progn
                    (if (equal (+ d2 d4) d5 0.0001)
                        (progn
                           (command "line" p2 p4 "")
                           (command "erase" n1 n2 "")
                        )
                        (progn
                               (command "line" p2 p3 "")
                               (command "erase" n1 n2 "")
                        )
                     )
                  )
             )
             )
           (prompt "\n 未选到边界线，请重新输入!!\n")
         )
   )

gjt1244

(equal (+ d1 d2) d3 0.0001)；
我不明白其中的意思，不可以用“＝”代替equal吗？还有最后那个0.0001有什么意义？

ljpnb

(equal (+ d1 d2) d3 0.0001)    改成   (= (+ d1 d2) d3)
如果两条线段是水平或是竖直的,不会有问题,如果是斜的就会判断出错

Free-Lancer

看样子楼主的是用来合并直线，这样的功能没有这么简单，判断是否在一个直线，用 angle 只能判断平行，但不一定在一条直线上。CAD中的 Line 是线段，表现相同，angle 可能相差 PI，还是学学数学吧，会有更好的算法的。

狂刀

搜索论坛，有判断两条直线是否共线的贴子

gjt1244

感激2楼主和7楼主的指教，看来要多学学数学，但关键还是多练练lisp，刚学不久，经验缺乏，不知道什么时候用什么函数比较好！
以下是修改了2楼主的lisp，增加了用所选取线段的所在图层重新绘制新线段，最后恢复旧图层的功能！

(DEFUN C:JL()
(setq a1 (entsel "\n 请选择第一条线:"))
(setq a2 (entsel "\n 请选择第二条线:"))
(setq b1(entget (car a1)))
(setq b2(entget (car a2)))
(setq old_lay (getvar "clayer"))        ;取得当前使用的图层名称
(setq new_lay (cdr (assoc 8 b1)))        ;取得第一条线段所在的图层名称
(setq c1(cdr (assoc 0 b1)))
(setq c2(cdr (assoc 0 b2)))
(if (and (= c1 "LINE") (= c2 "LINE"))
(progn
(setq p1(cdr (assoc 10 b1)))        ;取得第一条线段的起点坐标
(setq p2(cdr (assoc 11 b1)))        ;取得第一条线段的终点坐标
(setq p3(cdr (assoc 10 b2)))        ;取得第二条线段的起点坐标
(setq p4(cdr (assoc 11 b2)))        ;取得第二条线段的终点坐标
(setq n1(car a1))
(setq n2(car a2))
(setq d1(distance p1 p2))
(setq d2(distance p2 p3))
(setq d3(distance p1 p3))
(setq d4(distance p3 p4))
(setq d5(distance p2 p4))
(if (equal (+ d1 d2) d3 0.0001)
(progn
(setvar "clayer" new_lay)        ;应用所选取线段的图层
(if (equal (+ d2 d4) d5 0.0001)
(progn
(command "line" p1 p4 "")
(command "erase" n1 n2 "")
)
(progn
(command "line" p1 p3 "")
(command "erase" n1 n2 "")
)
)
)
(progn
(setvar "clayer" new_lay)
(if (equal (+ d2 d4) d5 0.0001)
(progn
(command "line" p2 p4 "")
(command "erase" n1 n2 "")
)
(progn
(command "line" p2 p3 "")
(command "erase" n1 n2 "")
)
)
)
)
)
(prompt "\n 未选到边界线，请重新输入!!\n")
)
(setvar "clayer" old_lay)        ;恢复旧图层
)

Free-Lancer

[iframe h=600 w=100%]http://www.frontfree.net/view/article_748.html#矢量叉积[/iframe]

2. 
   
3. (defun c:tt (/ e1 e2 el1 el2 sp1 ep1 sp2 ep2 intpt ptl minpt maxpt)
   
4.   (if (and (setq e1 (car (entsel "\nSelect First Line: ")))
   
5.            (setq e2 (car (entsel "\nSelect Second Line: ")))
   
6.       )
   
7.     (progn
   
8.       (setq el1        (entget e1)
   
9.             el2        (entget e2)
   
10.       )
    
11.       (setq sp1        (cdr (assoc 10 el1))
    
12.             ep1        (cdr (assoc 11 el1))
    
13.             sp2        (cdr (assoc 10 el2))
    
14.             ep2        (cdr (assoc 11 el2))
    
15.       )
    
16.       (setq intpt (inters sp1 ep1 sp2 ep2 nil))
    
17.       (if (not intpt)
    
18.         (progn
    
19.           (setq ptl (list sp1 ep1 sp2 ep2))
    
20.           (setq        minpt (list (apply 'min (mapcar 'car ptl))
    
21.                             (apply 'min (mapcar 'cadr ptl))
    
22.                             (apply 'min (mapcar 'last ptl))
    
23.                       )
    
24.                 maxpt (list (apply 'max (mapcar 'car ptl))
    
25.                             (apply 'max (mapcar 'cadr ptl))
    
26.                             (apply 'max (mapcar 'last ptl))
    
27.                       )
    
28.           )
    
29.           (setq        el1 (subst (cons 10 minpt)
    
30.                            (assoc 10 el1)
    
31.                            el1
    
32.                     )
    
33.                 el1 (subst (cons 11 maxpt)
    
34.                            (assoc 11 el1)
    
35.                            el1
    
36.                     )
    
37.           )
    
38.           (entmod el1)
    
39.           (entdel e2)
    
40.         )
    
41.       )
    
42.     )
    
43.   )
    
44.   (princ)
    
45. )

<br /> (defun c:tt (/ e1 e2 el1 el2 sp1 ep1 sp2 ep2 intpt ptl minpt maxpt)<br />   (if (and (setq e1 (car (entsel "\nSelect First Line: ")))<br />            (setq e2 (car (entsel "\nSelect Second Line: ")))<br />       )<br />     (progn<br />       (setq el1        (entget e1)<br />             el2        (entget e2)<br />       )<br />       (setq sp1        (cdr (assoc 10 el1))<br />             ep1        (cdr (assoc 11 el1))<br />             sp2        (cdr (assoc 10 el2))<br />             ep2        (cdr (assoc 11 el2))<br />       )<br />       (setq intpt (inters sp1 ep1 sp2 ep2 nil))<br />       (if (not intpt)<br />         (progn<br />           (setq ptl (list sp1 ep1 sp2 ep2))<br />           (setq        minpt (list (apply 'min (mapcar 'car ptl))<br />                             (apply 'min (mapcar 'cadr ptl))<br />                             (apply 'min (mapcar 'last ptl))<br />                       )<br />                 maxpt (list (apply 'max (mapcar 'car ptl))<br />                             (apply 'max (mapcar 'cadr ptl))<br />                             (apply 'max (mapcar 'last ptl))<br />                       )<br />           )<br />           (setq        el1 (subst (cons 10 minpt)<br />                            (assoc 10 el1)<br />                            el1<br />                     )<br />                 el1 (subst (cons 11 maxpt)<br />                            (assoc 11 el1)<br />                            el1<br />                     )<br />           )<br />           (entmod el1)<br />           (entdel e2)<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )

gjt1244

好东西，谢谢10楼主的分享，对以后编写lisp很有帮助！在下又编写了一个程序，不知道出了什么问题，请大家指教！不要见笑：

程序功能：选择现有的多线，提示输入新的比例，并显示更改比例后的多线；；；


(defun c:chgml()
  (
    (setq ml (entsel "\n请选择多线:"))
    (setq en_ml (entget (car ml)))
    (setq sca_list (assoc 40 en_ml))
    (setq sca (cdr sca_list))       
    (princ "\n你所选取的多线的比例S＝ ")(princ sca)
    (setq new_sca (getreal "请输入多线的新比例:"))       
    (setq new_sca_list (cons 40 new_sca))
    (setq en_ml (subst new_sca_list sca_list en_ml))
    (entmod en_ml)
    (entupd ml)
    (prin1)
    )
  )

梦断江南

(setq intpt (inters sp1 ep1 sp2 ep2 nil))
      (if (not intpt) ...)
两共线直线有部分重合的时候,这个判断不充分

楼上的朋友注意 括号的使用

ljpnb

(entupd ml) 要改成(entupd en_ml)

gjt1244

更改后如下：
(defun c:chgml ()
   (setq ml (entsel "\n请选择多线:"))
    (setq en_ml (entget (car ml)))
    (setq sca_list (assoc 40 en_ml))
    (setq sca (cdr sca_list))
    (princ "\n你所选取的多线的比例S＝ ")
    (princ sca)
    (setq new_sca (getreal "请输入多线的新比例:"))
    (setq new_sca_list (cons 40 new_sca))
    (setq en_ml (subst new_sca_list sca_list en_ml))
    (entmod en_ml)
    (entupd ml)
    (prin1)
)

仍然不能成功，显示参数类型错误，为何？

Free-Lancer

最初由 梦断江南 发布
[B](setq intpt (inters sp1 ep1 sp2 ep2 nil))
      (if (not intpt) ...)
两共线直线有部分重合的时候,这个判断不充分

楼上的朋友注意 括号的使用 [/B]

如斑竹所言，本程序是一时有兴趣临时写的，没有考虑详细。
合并直线这样点来点去的就没有多少使用价值，还是能框选的好。