Построение средней линии между двумя существующими

Построение средней линии, что есть в МенюГЕО работает отвратительно на мой взгляд. Делюсь тем, что нашёл на просторах интернета. Оба лиспа работают по разным алгоритмам и иногда один делает лучше второго. Украл тут Lisp to create polyline between polylines - AutoLISP, Visual LISP & DCL - AutoCAD Forums (cadtutor.net) и тут The centreline feature is not available..... - Autodesk Community - AutoCAD

Код:

(defun c:cPoly (/ ent1 ent2 i j mPt len pt p1 ptlst grlst grlin)
 (vl-load-com)
 
 (if (and (setq ent1 (car (entsel "\nSelect First Polyline: ")))
          (wcmatch (cdr (assoc 0 (entget ent1))) "*POLYLINE"))
   (if (and (setq ent2 (car (entsel "\nSelect Second Polyline: ")))
            (wcmatch (cdr (assoc 0 (entget ent2))) "*POLYLINE"))
     (progn
       (setq i -1 len (/ (vla-get-Length
                           (vlax-ename->vla-object ent1)) 100.) grlin '( ))
       (while (and (grread 't)
                   (setq pt (vlax-curve-getPointatDist ent1 (* (setq i (1+ i)) len))))
         (redraw)
         (setq p1 (vlax-curve-getClosestPointto ent2 pt t)
               ptlst (cons
                       (setq mPt
                         (polar pt (angle pt p1) (/ (distance pt p1) 2.))) ptlst) j -1 grlst nil)
         (repeat 500
           (setq grlst
             (cons
               (polar mPt (* (setq j (1+ j)) (/ pi 250.)) (distance mPt p1)) grlst)))
         (setq grlin (append grlin (list (if grlin (last grlin) mPt) mPt)))
         (grvecs (append '(3) grlst (cdr grlst) (list (car grlst))))
         (grvecs (append '(1) grlin)))
       (redraw)
       (setq ptlst (apply 'append
                     (mapcar
                       (function
                         (lambda (x)
                           (list (car x) (cadr x)))) ptlst)))
       (vla-AddLightWeightPolyline
         (vla-get-ModelSpace
           (vla-get-ActiveDocument
             (vlax-get-acad-object)))
         (vlax-make-variant
           (vlax-safearray-fill
             (vlax-make-safearray
               vlax-VBDouble (cons 0 (1- (length ptlst)))) ptlst))))))
 
 (princ)) 

Код:

;;;************************ centerPline.LSP ***********************;;;
;;;                                                                ;;;
;;;                Centerline between two polyline                 ;;;
;;;                                                                ;;;
;;;                  author: Gian Paolo Cattaneo                   ;;;
;;;                                                                ;;;
;;;                  version: 1.0  -  21.12.2013                   ;;;
;;;                                                                ;;;
;;;****************************************************************;;;
 
 
(defun c:CPL ( / *error* Loft_n Loft_p Loft_u Loft_v :e1 :e2
                 e1 e2 p1 p2 D_off EL e1o e2o L1 L2 EL1 E_new
                 *pl* E_join pa pb e_del results rip)
 
    (defun *error* ( msg )
        (command "_.undo" "_end")
        (if Loft_n (setvar 'loftnormals Loft_n))
        (if Loft_p (setvar 'loftparam Loft_p))
        (if Loft_u (setvar 'surfu Loft_u))
        (if Loft_v (setvar 'surfv Loft_v))
        (if pl_type (setvar 'plinetype pl_type))
        (setvar 'cmdecho cmd)
 
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (setq cmd (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (command "_.undo" "_begin")    
 
    (if (null ETmsg) (check_ET))
    (check_ucs)
    (check_view)
    (check_ver)
 
    (setq Loft_n (getvar 'loftnormals))
    (setq Loft_p (getvar 'loftparam))
    (setq Loft_u (getvar 'surfu))
    (setq Loft_v (getvar 'surfv))
    (setq pl_type (getvar 'plinetype))
 
    (setvar 'loftnormals 0)
    (setvar 'loftparam 7)
    (setvar 'surfu 0)
    (setvar 'surfv 0)
    (if (= 0 (getvar 'plinetype)) (setvar 'plinetype 1))
 
    (if (and
            (setq :e1 (<sel> "\nSelect First Polyline"))
    (setq p1 (cadr :e1))
    (setq :e1 (car :e1))
            (not (redraw :e1 3))
            (setq :e2 (<sel> "\nSelect Second Polyline"))
    (setq p2 (cadr :e2))
    (setq :e2 (car :e2))     
        )
        (progn
            (redraw :e1 4)
            (check_elev)
            (check_normal)
            (setq e1 (entmakex (cdr (entget :e1))))
            (setq e2 (entmakex (cdr (entget :e2))))
            (setq D_off (* (Max (MaxDist e1 e2) (MaxDist e2 e1)) 0.53))
    
            (setq EL (entlast))
            (command "_offset" D_off e1 "_non" p2 "")
            (setq e1o (entlast))     
            (check_offset)
 
            (setq EL (entlast))
            (command "_offset" D_off e2 "_non" p1 "")
            (setq e2o (entlast))
            (check_offset)   
 
            (command "_move" e1o e2o "" "_non" "0,0,0" "_non" (list 0.0 0.0 (* D_off 0.5)))
 
            (command "_loft" e1 e1o "" "")
            (setq L1 (entlast))
            (command "_loft" e2 e2o "" "")
            (setq L2 (entlast))
 
            (setq EL (entlast) EL1 EL)
 
            (command "_intersect" L1 L2 "")
 
            (mapcar
               '(lambda (x)
                    (if (not (vlax-erased-p x)) (entdel x))
                )
                (list e1o e2o e1 e2 L1 L2)
            )       
 
            (if (> (sslength (setq E_new (e_next EL "SS"))) 0)
                (progn
                    (if :ET:     
                        (acet-flatn E_new nil)
                        (progn
                            (command "_move" E_new "" "_non" "0,0,0" "_non" "0,0,1e99")
                            (command "_move" E_new "" "_non" "0,0,0" "_non" "0,0,-1e99")
                        )
                    )
                    (setq E_join (e_next EL1 "LS"))
 
                    (if (= "LINE" (cdr (assoc 0 (entget (car E_join)))))
                        (progn
                            (setq pa (trans (cdr (assoc 10 (entget (car E_join)))) 0 1))
                            (setq pb (trans (cdr (assoc 11 (entget (car E_join)))) 0 1))
                            (command "_pline" "_non" pa "_non" pb "")
                            (setq E_join (subst (entlast) (setq e_del (car E_join)) E_join))
                            (entdel e_del)
                        )
                    )
                    (command "_.join")
                    (apply 'command E_join)
                    (command "")
                    (setq results t)
                )
            )
        )
    )
    (setvar 'loftnormals Loft_n)
    (setvar 'loftparam Loft_p)
    (setvar 'surfu Loft_u)
    (setvar 'surfv Loft_v)
    (setvar 'plinetype pl_type)
    (command "_.undo" "_end")
    (setvar 'cmdecho cmd)
    (prompt "\n ") (prompt "\n ")(prompt "\n ")
    (if results (prompt (strcat "\nCenterline created " (if :ET: "(Polyline)." "(Spline)."))))
    (princ)
)
 
;****************************************************************************
 
(defun check_ET ()
    (if (member "acetutil.arx" (arx))
        (progn
            (or acet-flatn (load "FLATTENSUP.LSP"))
            (setq :ET: t)
        )
        (progn
            (setq :ET: nil)
            (alert
                (strcat
                    "Express Tools are not installed."
                    "\nIf there are curves the centerline is drawn with a spline."
                )
            )
    (setq ETmsg t) 
        )
    )
)
 
;****************************************************************************
 
(defun check_ucs ()
    (or
        (and
            (zerop (caddr (getvar 'ucsxdir)))
            (zerop (caddr (getvar 'ucsydir)))
        )
        (progn
            (alert "UCS not normal to the WCS")
            (exit)
        )
    )
)
                           
;****************************************************************************
 
(defun check_view ()
    (or
        (and
            (zerop (car (getvar 'viewdir)))
            (zerop (cadr (getvar 'viewdir)))
            (> (caddr (getvar 'viewdir)) 0)
        )
        (progn
            (alert "View needs to be in plan (0 0 1)")
            (exit)
        )
    )
)
 
;****************************************************************************
 
(defun check_ver ()
    (if (< (atoi (substr (ver) 13)) 2011)
        (progn
            (alert "This routine require AutoCAD 2011 or higher.")
            (exit)
        )
    )
)
 
;****************************************************************************
 
(defun <sel> (<msg> / *poly* *esel* *p*)
    (while (not *poly*)
        (setvar "errno" 0)
        (setq *esel* (entsel <msg>))
        (setq *poly* (car *esel*))
        (setq *p* (cadr *esel*))
        (if (= 7 (getvar 'errno))
            (alert "No objects selected")
        )
        (if (= 'ename (type *poly*))
            (cond
                ( (null (wcmatch (cdr (assoc 0 (entget *poly*))) "LWPOLYLINE"))
                  (alert "Invalid selection, the object is not a LWPOLYLINE.")
                  (setq *poly* nil)
                )
                ( (= 1 (logand 1 (cdr (assoc 70 (entget *poly*)))))
                  (alert "Invalid selection, the polyline is not open.")
                  (setq *poly* nil)
                )
            )
        )
    )
    (list *poly* *p*)
)
 
;****************************************************************************
 
(defun check_elev ()
    (if
        (not
            (equal
                (cdr (assoc 38 (entget :e1)))
                (cdr (assoc 38 (entget :e2)))
                1e-6
            )
        )
        (progn
            (alert "Polylines have different elevation.")
            (exit)
        )
    )
)
 
;****************************************************************************
 
(defun check_normal ()
    (if
        (or
            (not (equal (cdr (assoc 210 (entget :e1))) '(0.0 0.0 1.0) ))
            (not (equal (cdr (assoc 210 (entget :e2))) '(0.0 0.0 1.0) ))
        )
        (progn
            (alert "Polyline is not normal to the WCS.")
            (exit)
        )
    )
)
 
;****************************************************************************
 
(defun e_next (entL mode / next)
    (if (= mode "SS") (setq next (ssadd)))
    (if (/= entL (entlast))
        (while (setq entL (entnext entL))
            (if (entget entL)
                (cond
                    ( (= mode "LS") (setq next (cons entL next)) )
                    ( (= mode "SS") (setq next (ssadd entL next)) )
                )
            )
        )
    )
    next
)
 
;****************************************************************************
 
(defun check_offset ( / o_del)
    (if rip (setq rip (1+ rip)) (setq rip 1))
    (if (> (length (setq o_del (e_next EL "LS"))) 1)
        (progn
            (entdel e1)
            (entdel e2)
            (if (= rip 2) (entdel e1o))
            (mapcar
               '(lambda (x)
                    (if (not (vlax-erased-p x)) (entdel x))
                )
                o_del
            )
            (alert
                (strcat
                    "Modeling failed."
                    "\nTry to split the polylines into more portions."
                )
            )
            (exit)
        )
    )
)
 
;****************************************************************************
 
(defun MaxDist (ent1 ent2 / :step De1 :div p_step :D Dmax)
    (setq :step (/ (setq De1 (vlax-curve-getDistAtParam ent1 (vlax-curve-getEndParam ent1))) 500))
    (setq :div :step)
    (setq Dmax 0.00)
    (while (< :div De1)
        (setq p_step (vlax-curve-getPointAtDist ent1 :div))
        (setq :D (distance p_step (vlax-curve-getClosestPointTo ent2 p_step)))
        (if (> :D Dmax) (setq Dmax :D))
        (setq :div (+ :div :step))
    )
    Dmax
)
 
;****************************************************************************
 
(vl-load-com)
 
(prompt "\n ") (prompt "\n ")
(princ "\nCenterline between two polyline - by Gian Paolo Cattaneo")
(princ "\ncenterPline.LSP loaded ............... Type \"CPL\" to run ")
(princ)

 

Есть еще MPL из очень полезного для очень многого PlTools.