[编程交流] 除法lisp

(defun c:BAD (/ *error* AT:GetSel AT:DrawX _getDist ent pnt cmd undo total add dist break)
 ;; Break curve At Distance
 ;; Alan J. Thompson, 09.21.11
 ;; http://www.theswamp.org/index.php?topic=39550.0;all
 (vl-load-com)
 (defun *error* (msg)
   (and cmd (setvar 'CMDECHO cmd))
   (and *AcadDoc* (vla-endundomark *AcadDoc*))
   (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
     (princ (strcat "\nError: " msg))
   )
 )
 (defun AT:GetSel (meth msg fnc / ent)
   ;; meth - selection method (entsel, nentsel, nentselp)
   ;; msg - message to display (nil for default)
   ;; fnc - optional function to apply to selected object
   ;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC")))
   ;; Alan J. Thompson, 05.25.10
   (setvar 'ERRNO 0)
   (while
     (progn (setq ent (meth (cond (msg)
                                  ("\nSelect object: ")
                            )
                      )
            )
            (cond ((eq (getvar 'ERRNO) 7) (princ "\nMissed, try again."))
                  ((eq (type (car ent)) 'ENAME)
                   (if (and fnc (not (fnc ent)))
                     (princ "\nInvalid object!")
                   )
                  )
            )
     )
   )
   ent
 )
 (defun AT:DrawX (P C)
   ;; Draw and "X" vector at specified point
   ;; P - Placement point for "X"
   ;; C - Color of "X" (must be integer b/w 1 & 255)
   ;; Alan J. Thompson, 10.31.09
   (if (vl-consp P)
     ((lambda (d)
        (grvecs (cons C
                      (mapcar (function (lambda (n) (polar P (* n pi) d)))
                              '(0.25 1.25 0.75 1.75)
                      )
                )
        )
        P
      )
       (* (getvar 'viewsize) 0.02)
     )
   )
 )
 (defun _getDist (total point / dist)
   (and undo (initget "Undo"))
   (cond ((not (setq dist (getdist (AT:DrawX point 4)
                                   (strcat
                                     "\nDistance at which to break curve (Total= "
                                     (rtos total)
                                     (if undo
                                       ") [undo]: "
                                       "): "
                                     )
                                   )
                          )
               )
          )
          nil
         )
         ((eq dist "Undo") dist)
         ((not (< 0. dist total))
          (princ (strcat "\nValue must be between 0.0 and and " (rtos total) "!"))
          (_getDist total point)
         )
         (dist)
   )
 )
 (vla-startundomark
   (cond (*AcadDoc*)
         ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
   )
 )
 (if (setq ent (AT:GetSel
                 entsel
                 "\nSelect curve to break: "
                 (lambda (x)
                   (and (wcmatch (cdr (assoc 0 (entget (car x))))
                                 "ARC,LINE,*POLYLINE,SPLINE"
                        )
                        (not (vlax-curve-isClosed (car x)))
                   )
                 )
               )
     )
   (progn
     (setq pnt (trans (cadr ent) 1 0)
           ent (car ent)
           cmd (getvar 'CMDECHO)
     )
     (setvar 'CMDECHO 0)
     (while
       (setq
         dist (_getDist (setq total (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
                        (setq pnt
                               (trans (if (> (vlax-curve-getParamAtPoint
                                               ent
                                               (vlax-curve-getClosestPointToProjection ent pnt '(0. 0. 1.))
                                             )
                                             (vlax-curve-getParamAtDist ent (/ total 2.))
                                          )
                                        (progn (setq add total) (vlax-curve-getEndPoint ent))
                                        (progn (setq add 0.) (vlax-curve-getStartPoint ent))
                                      )
                                      0
                                      1
                               )
                        )
              )
       )
        (if (eq dist "Undo")
          (progn (vl-cmdf "_.U")
                 (setq ent  (caar undo)
                       pnt  (cadar undo)
                       undo (cdr undo)
                 )
          )
          (progn
            (setq break (trans (vlax-curve-getPointAtDist ent (abs (- add dist))) 0 1))
            (command-s "_.break" ent "_F" "_non" break "_non" break)
            (setq undo (cons (list ent pnt) undo))
            (and (zerop add) (setq ent (entlast)))
          )
        )
        (redraw)
        (foreach p (vl-remove (last undo) undo) (AT:DrawX (cadr p) 1))
     )
   )
 )
 (*error* nil)
 (princ)
)