[编程交流] 使用lisp扩展线

(defun c:demo ( / LWPoly _from pl pts temp corners ang mid v h 1p 2p objrot)
;;;                        Demo by pBe 06May2013                                        ;;;
;;; This demo will work only at the lower left corner and upper right corner        ;;;
;;;  It is written as a guide and not in any way complete and accurate                ::;
(setvar 'pdmode 34)
(setvar 'cmdecho 0)  
(defun LWPoly (lst)
 (entmakex (append (list (cons 0 "LWPOLYLINE")
                         (cons 100 "AcDbEntity")
                         (cons 100 "AcDbPolyline")
                         (cons 90 (length lst))
                         )
                   (mapcar (function (lambda (p) (cons 10 p))) lst))))
 
;;;        pBe05Nov2012        ;;;
 (defun _pBe:from (p d m)
   (polar p (* pi (nth m '(0.25 0.75 1.25 1.75)))
                    (* d (sqrt 2))
   )
 )
 
(if (setq pl (car (entsel "\nSelect Pline:")))
  (progn
          (setq pts (mapcar 'cdr (vl-remove-if-not '(lambda (e)
                        (= (Car e) 10))(entget pl))))
          (setq temp (ssadd))
          (foreach p pts
          (command "_point" "_non" p)
                  (ssadd (entlast) temp))
          
        (While (setq corners nil pn (ssget '((0 . "POINT"))))
;;;        Written to work with only two selected points                ;;;
                  (repeat 2
                          (setq corners (cons (cdr (assoc 10 (entget (ssname pn 0)))) corners) )
                          (ssdel (ssname pn 0) pn))
                  (setq corners (If (> (Cadr (car corners))(Cadr (cadr corners))) (reverse corners) corners ))
                  (setq ang (angle (setq 1p (car corners))(setq  2p (cadr corners))))
                (setq mid (mapcar '(lambda (x y) (* 0.5 (+ x y))) 1p 2p))
                  (Setq h (- (car 2p)(car 1p)) v (- (cadr 2p) (cadr 1p)))
                (setq pts_
                       (vl-sort
                         (list 1p
                               (list (car 1p) (cadr 2p))
                               2p
                               (list (car 2p) (cadr 1p))
                         )
                         '(lambda (a b)
                            (cond
                              ((> (cadr a) (cadr b)) T)
                              ((equal (cadr a) (cadr b) 0.1) (< (car a) (car b)))
                            )
                          )
                       )
                )
        (if (and (< ang (/ pi 2.0)) (< (car 1p)(car 2p)))
          (progn
                  (setq st ( _pBe:from (caddr pts_) 2.5 0) objrot (ssadd) tr 0)
                  (LWpoly (list (polar st (/ pi 2.0) 100)
                              st
                              (setq 3p (polar st 0 (- h 5.0)))
                              (polar 3p (/ pi 2.0) 100)
                        )
                )
                    (ssadd  (entlast) objrot)
                  (LWpoly (list (polar st 0 100)
                              st
                              (setq 3p (polar st (/ pi 2.0) (- v 5.0)))
                              (polar 3p 0 100)
                        )
                )
            (ssadd  (entlast) objrot)
          [b][color="blue"](prompt "\nMove Mouse up and down to rotate")[/color][/b]
                (while
                  (progn
                    (setq gr   (grread t 15 0)
                          mode (car gr)
                          data (cadr gr)
                    )
;;;        pBe 11Oct2010        ;;;
                    (cond ((= 5 mode)
                           (if ((if (zerop tr)
                                  <  > )  pi
                                 (angle mid data)
                               )
                             (setq tr (boole 6 1 tr)
                                   ro (command "_rotate" objrot "" "_non"
                                               mid 180)   
                             ) )  T  )
                          ((member mode '(2 3)) nil)
                    )
                  )
                )  
            
          )
    )
  )
           (command "_erase" temp "")
    )
 )(princ)
 )

5