[求助]：这个图的LISP程序应该这么写？

SLMin

如图，已知两点!

xyp1964

[php]
;;;任意两点
(defun c:test (/ PT1 PT2 PT3 PT4 PT5 PT6 PT7 PT8 PT9 PT10)
  (setq pt1 (getpoint "\n起点位置<退出> :"))
  (setq pt2 (getcorner pt1 "\n对角点位置<退出> :"))
  (while pt2
    (if        (or (and (> (car pt2) (car pt1)) (> (cadr pt2) (cadr pt1)))
            (and (< (car pt2) (car pt1)) (< (cadr pt2) (cadr pt1)))
        )
      (progn
        (setq pt3  (list (car pt2) (cadr pt1))
              pt4  (list (car pt1) (cadr pt2))
              h           (/ (distance pt1 pt4) 4)
              pt5  (_midp pt1 pt4)
              pt6  (_midpup pt1 pt5 h)
              pt7  (_midpup pt5 pt4 h)
              pt8  (_midp pt3 pt2)
              pt9  (_midpdn pt3 pt8 h)
              pt10 (_midpdn pt8 pt2 h)
        )
      )
      (progn
        (setq pt3  (list (car pt2) (cadr pt1))
              pt4  (list (car pt1) (cadr pt2))
              h           (/ (distance pt1 pt4) 4)
              pt5  (_midp pt1 pt4)
              pt6  (_midpdn pt1 pt5 h)
              pt7  (_midpdn pt5 pt4 h)
              pt8  (_midp pt3 pt2)
              pt9  (_midpup pt3 pt8 h)
              pt10 (_midpup pt8 pt2 h)
        )
      )
    )
    (setq osm (getvar "osmode"))
    (SETVaR "osmode" 0)
    (setvar "plinewid" 0)
    (command "PLINE" PT1 PT2 PT3 PT4 "c")
    (command "arc" pt1 pt6 pt5)
    (command "arc" pt5 pt7 pt4)
    (command "arc" pt3 pt9 pt8)
    (command "arc" pt8 pt10 pt2)
    (SETVaR "osmode" osm)
    (setq pt1 (getpoint "\n起点位置<退出> :"))
    (setq pt2 (getcorner pt1 "\n对角点位置<退出> :"))
  )
  (princ)
)
(defun _midp(p1 p2)(list(+(/(-(car p1)(car p2))2)(car p2))(+(/(-(cadr p1)(cadr p2))2)(cadr p2))))
(defun _midPUP(pta ptb fb)(polar(_midP pta ptb)(+(angle pta ptb)(/ pi 2))fb))
(defun _midPDN(pta ptb fb)(polar(_midP pta ptb)(-(angle pta ptb)(/ pi 2))fb))
[/php]

urljit

楼上的弟兄效率好高呀。

eachy

ARC 部分可以画一边的，另一边的用 Mirror 命令

SLMin

谢谢2楼！

偶是初学，这样写的！
[php](defun c:lx()
  (setvar "cmdecho" 0)
  (setq p1 (getpoint "\n 第一点:"))
  (setq p2 (getcorner p1 "\n 第二点:"))
  (setq p3 (list(car p2) (cadr p1)))
  (setq p4 (list(car p1) (cadr p2)))
  (command "pline" p1 p2 p3 p4 "C")
  (setq ang1 (angle p1 p4))
  (setq ang2 (angle p2 p3))
  (setq hh (/(distance p1 p4) 2))
  (setq p5 (polar p1 ang1 hh))
  (setq p6 (polar p2 ang2 hh))
  (if (and (= ang1 (/ pi 2)) (>(abs(car p6)) (abs(car p5))))
    (progn
      (command "pline" p4 "a" "a" 180 p5 "a" 180 p1 "")
      (command "pline" p3 "a" "a" 180 p6 "a" 180 p2 "")
      )
    (if (and (= ang1 (/ pi 2)) (<(abs(car p6)) (abs(car p5))))
      (progn
        (command "pline" p2 "a" "a" 180 p6 "a" 180 p3 "")
        (command "pline" p1 "a" "a" 180 p5 "a" 180 p4 "")
        )
      (if (and (= ang1 (* pi 1.5)) (>(abs(car p6)) (abs(car p5))))
        (progn
          (command "pline" p1 "a" "a" 180 p5 "a" 180 p4 "")
          (command "pline" p2 "a" "a" 180 p6 "a" 180 p3 "")
          )
        (if (and (= ang1 (* pi 1.5)) (<(abs(car p6)) (abs(car p5))))
          (progn
            (command "pline" p4 "a" "a" 180 p5 "a" 180 p1 "")
            (command "pline" p3 "a" "a" 180 p6 "a" 180 p2 "")
            )
          ))))
   (princ)
)[/php]

真要好好学习一下你的程序！

xyp1964

程序不稳定：用pline画弧，有可能方向是反的，还是用arc命令较好。

SLMin

最初由 xyp1964 发布
[B]程序不稳定：用pline画弧，有可能方向是反的，还是用arc命令较好。 [/B]

以前偶没有加判断，用PL 或ARC画半园是出现了方向问题！上面的程序加了判断，偶试过了，不会出现方向问题！！！谢谢！

xyp1964

程序依然不稳定，可能判断用abs存在问题，或着用pline画arc有问题。

urljit

要想程序稳定，最好不使用command

梦断江南

try my lsp
[php]
(defun c:pigu (/ a b y1 y2 x1 x2 y12)
  (if (and (setq a (getpoint "\n 1th point:"))
             (setq b (getcorner a "\n 2nd point:"))
             (/= (cadr a)(cadr b)))
    (progn
      (setq xs (vl-sort (list(car a)(car b)) '< )
            ys (vl-sort (list(cadr a)(cadr b)) '< )
            x1 (car xs)
            x2 (cadr xs)
            y1 (car ys)
            y2 (cadr ys)
            y12(/ (+ y2 y1) 2))
      (vl-cmdf ".pline" (list x1 y1)(list x1 y12)(list x1 y2)(list x2 y1)(list x2 y12)(list x2 y2)"cl")
      (setq o (vlax-ename->vla-object(entlast)))
      (mapcar '(lambda(x y)(vla-SetBulge o x y))'(0 1 3 4)'(-1 -1 1 1))
      (vl-cmdf ".line" (list x1 y1)(list x1 y2) "")
      (vl-cmdf ".line" (list x2 y1)(list x2 y2) "")
    )
  )(princ)
)
[/php]

xyp1964

这个“PIGU”程序确实精练，程序看不太明白！但图像好像是……
当线宽plinewid为90时的效果：

梦断江南

;;详解:(本例未考虑ucs,大家自己完善吧)
[php]
(defun c:pigu (/ a b y1 y2 x1 x2 y12) ;; 'pigu = 屁股，因为画的图像是两个大屁股.'
  ;;'可考虑加(vl-cmdf ".undo" "be")'
  (setq a (getpoint "\n 1th point:") ;;'取第一点。'
    b (getcorner a "\n 2nd point:")) ;;'coner方法取第二点，范围框出，略为直观，如要实时显示，可考虑grread方法.'
  (if (and a b (/= (cadr a)(cadr b))) ;;'两点y值相等，圆画不出来，故做此判断.'
    (progn
      (setq xs (vl-sort (list(car a)(car b)) '< ) ;;x值排序。'
        ys (vl-sort (list(cadr a)(cadr b)) '< ) ;;y值排序。'
        x1 (car xs) ;;'肯定是最小x值'
        x2 (cadr xs)
        y1 (car ys) ;;'肯定是最小y值'
        y2 (cadr ys)
        y12(/ (+ y2 y1) 2)) ;;'y中间值，画圆用.'
      (vl-cmdf ".pline" (list x1 y1)(list x1 y12)(list x1 y2)(list x2 y1)(list x2 y12)(list x2 y2)"cl") ;;'按点位做封闭pl线条.'
      (setq o (vlax-ename->vla-object(entlast)))
      (mapcar '(lambda(x y)(vla-SetBulge o x y))'(0 1 3 4)'(-1 -1 1 1)) ;;'对pl线第0,1,3,4段分别设置凸度.'
      ;;'如果不要pl线，此处可加一行:(vl-cmdf ".explode" (entlast) "")'
      (vl-cmdf ".line" (list x1 y1)(list x1 y2) "") ;;'画线.也可考虑用"pline"。'
      (vl-cmdf ".line" (list x2 y1)(list x2 y2) "") ;;'同上.
    )
  )
  ;;可考虑加(vl-cmdf ".undo" "e")
  (princ)
)
[/php]

eachy

mine

2. 
   
3. (defun c:test (/ midp ferr olderr oldos p1 p2 p3 p4 pm doc ar)
   
4.   (defun midp (p0 p00)
   
5.     (mapcar '(lambda (x y) (/ (+ x y) 2)) p0 p00)
   
6.   )
   
7.   (defun ferr (msg)
   
8.     (if        msg
   
9.       (princ "\n*Cancel*")
   
10.     )
    
11.     (setvar "osmode" oldos)
    
12.     (setq *error* olderr)
    
13.     (princ)
    
14.   )
    
15.   (if (and (setq p1 (getpoint "\nBase Point: "))
    
16.            (setq p3 (getcorner p1 "\nSecond Point: "))
    
17.       )
    
18.     (progn
    
19.       (vla-startundomark
    
20.         (setq doc (vla-get-activedocument (vlax-get-acad-object)))
    
21.       )
    
22.       (setq olderr  *error*
    
23.             *error* ferr
    
24.       )
    
25.       (setq oldos (getvar "osmode"))
    
26.       (setq p2 (list (car p3) (cadr p1) 0.)
    
27.             p4 (list (car p1) (cadr p3) 0.)
    
28.       )
    
29.       (setvar "osmode" 0)
    
30.       (setvar "cmdecho" 0)
    
31.       (vl-cmdf ".pline" p1 p3 p2 p4 "c")
    
32.       (vl-cmdf ".arc"
    
33.                p1
    
34.                "e"
    
35.                (setq pm (midp p1 p4))
    
36.                "d"
    
37.                (polar p1 (angle p2 p1) 1.)
    
38.       )
    
39.       (setq ar (entlast))
    
40.       (vl-cmdf ".copy" ar "" p1 pm)
    
41.       (vl-cmdf ".mirror"
    
42.                ar
    
43.                (entlast)
    
44.                ""
    
45.                (midp p1 p3)
    
46.                (midp p1 p2)
    
47.                "n"
    
48.       )
    
49.       (setvar "osmode" oldos)
    
50.       (setq *error* olderr)
    
51.       (vla-endundomark doc)
    
52.     )
    
53.   )
    
54.   (princ)
    
55. )
    

<br /> (defun c:test (/ midp ferr olderr oldos p1 p2 p3 p4 pm doc ar)<br />   (defun midp (p0 p00)<br />     (mapcar '(lambda (x y) (/ (+ x y) 2)) p0 p00)<br />   )<br />   (defun ferr (msg)<br />     (if        msg<br />       (princ "\n*Cancel*")<br />     )<br />     (setvar "osmode" oldos)<br />     (setq *error* olderr)<br />     (princ)<br />   )<br />   (if (and (setq p1 (getpoint "\nBase Point: "))<br />            (setq p3 (getcorner p1 "\nSecond Point: "))<br />       )<br />     (progn<br />       (vla-startundomark<br />         (setq doc (vla-get-activedocument (vlax-get-acad-object)))<br />       )<br />       (setq olderr  *error*<br />             *error* ferr<br />       )<br />       (setq oldos (getvar "osmode"))<br />       (setq p2 (list (car p3) (cadr p1) 0.)<br />             p4 (list (car p1) (cadr p3) 0.)<br />       )<br />       (setvar "osmode" 0)<br />       (setvar "cmdecho" 0)<br />       (vl-cmdf ".pline" p1 p3 p2 p4 "c")<br />       (vl-cmdf ".arc"<br />                p1<br />                "e"<br />                (setq pm (midp p1 p4))<br />                "d"<br />                (polar p1 (angle p2 p1) 1.)<br />       )<br />       (setq ar (entlast))<br />       (vl-cmdf ".copy" ar "" p1 pm)<br />       (vl-cmdf ".mirror"<br />                ar<br />                (entlast)<br />                ""<br />                (midp p1 p3)<br />                (midp p1 p2)<br />                "n"<br />       )<br />       (setvar "osmode" oldos)<br />       (setq *error* olderr)<br />       (vla-endundomark doc)<br />     )<br />   )<br />   (princ)<br /> )<br />

amanjmy

原来都是对对象操作,各位都好强啊

缘分哪

对对象操作是不是要稳定得多？command出错的机率高，编些简单程序还行。