[编程交流] 生成多边形LISP

;; Make Polygon by Lee McDonnell (Lee Mac)
;; 29.05.2009
(defun c:mkPly (/ flag doc spc clr pt gr cPt
                 Ang cAng cDis ptLst var)
 (vl-load-com)
 
 (setq doc (vla-get-ActiveDocument
             (vlax-get-Acad-Object))
       spc (if (zerop
                 (vla-get-activespace doc))
             (if (= (vla-get-mspace doc) :vlax-true) ; Vport
               (vla-get-modelspace doc)
               (vla-get-paperspace doc))
             (vla-get-modelspace doc))
       clr 0)
 
 (or *mkPly:Side* (setq *mkPly:Side* 4))
 (if (setq pt (getpoint "\nSelect Centre Point: "))
   (progn
     (while
       (or
         (and
           (setq gr (grread t 7 0)) (eq 5 (car gr)))
         (and
           (eq 2 (car gr))
             (member
               (cadr gr)
                 '(9 43 61 45))))
       (redraw)
       (if
         (and
           (eq 2 (car gr))
           (or
             (eq 43 (cadr gr)) ; +
             (eq 61 (cadr gr)))) ; = (as +)
           (setq *mkPly:Side* (+ *mkPly:Side* (if flag 2 1))
                 clr (1+ clr)))
       (if
         (and
           (eq 2 (car gr))
           (eq 45 (cadr gr))) ; -
         (progn
           (and (< (if flag 6 3) *mkPly:Side*)
                (setq *mkPly:Side*
                  (- *mkPly:Side* (if flag 2 1))))
           (if (zerop clr)
             (setq clr 5)
             (setq clr (1- clr)))))
       (if
         (and
           (eq 2 (car gr))
           (eq 9 (cadr gr))) ; Tab
         (progn
           (setq flag (not flag))
           (if flag
             (setq *mkPly:Side* 6))))
       (if (eq 5 (car gr))
         (progn
           (setq cPt (cadr gr)
                 Ang (/ (* 2. pi) *mkPly:Side*)
                 cAng (angle pt cPt)
                 cDis (distance pt cPt)
                 ptLst (list cPt (polar pt (+ cAng Ang)
                                        (if (and flag (< 5 *mkPly:Side*)
                                                 (zerop (rem *mkPly:Side* 2)))
                                          (/ cDis 3.) cDis))) i 2.)
           (repeat (- *mkPly:Side* 2)
             (setq ptlst
               (append ptlst
                 (list (last ptlst)
                   (polar pt (+ cAng (* i Ang))
                          (if (and flag (< 5 *mkPly:Side*)
                                   (zerop (rem *mkPly:Side* 2))
                                   (not (zerop (rem i 2))))
                            (/ cDis 3.) cDis)))) i (1+ i)))))
       (grvecs
         (setq ptlst
           (append
             (list (* -1 (1+ (rem clr 6))))
               ptlst (list (last ptlst) cPt)))))
     (if
       (and
         (eq 3 (car gr))
           (listp (cadr gr)))
       (progn
         (setq ptlst (apply
                       'append
                          (mapcar
                            (function
                              (lambda (x)
                                (list (car x) (cadr x))))
                            (append
                              (unique (cdr ptlst))
                                (list (cadr ptlst))))))
         (setq var
           (vlax-make-variant
             (vlax-safearray-fill
               (vlax-make-safearray
                 vlax-vbdouble
                   (cons 0 (1- (length ptlst))))
               ptlst)))          
         (vla-addLightWeightPolyline spc var)))
     (redraw)))
 (princ))
;; CAB
(defun unique (lst / result)
 (reverse
   (while (setq itm (car lst))
     (setq lst (vl-remove itm lst)
           result (cons itm result)))))