Trying to draw a centerline between two contour lines

[marko_ribar]

This is old topic, still I've run into this and I wanted to correct the code by Lee Mac...

 

This :

       (setq foo
         (if (< (distance (vlax-curve-getStartPoint e1) (vlax-curve-getStartPoint e2))
                (distance (vlax-curve-getStartPoint e1) (vlax-curve-getEndPoint   e2)))

           (lambda ( x ) (x))
           (lambda ( x ) (- l2 x))            
         )
       )

 

When you analyze closer all input things should be :

 

       (setq foo
         (if (< (distance (vlax-curve-getStartPoint e1) (vlax-curve-getStartPoint e2))
                (distance (vlax-curve-getStartPoint e1) (vlax-curve-getEndPoint   e2)))

           (lambda ( x ) (* x (/ l2 len)))
           (lambda ( x ) (- l2 (* x (/ l2 len))))            
         )
       )

 

Else as I see is fine...

M.R.

[marko_ribar]

Also (LM:Polyline ptlst) should be like this (3d polyline) :

 

(defun LM:Polyline ( lst )
 ;; © Lee Mac  ~  23.06.10
 (entmake (list (cons 0 "POLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDb3dPolyline") (cons 10 '(0 0 0)) (cons 70 ))  
 (mapcar
  '(lambda ( x )
     (entmake
       (list (cons 0 "VERTEX") (cons 100 "AcDbEntity") (cons 100 "AcDbVertex") (cons 100 "AcDb3dPolylineVertex") (cons 10 x) (cons 70 32))
     )
   )
   lst
 )
 (entmake (list (cons 0 "SEQEND") (cons 100 "AcDbEntity")))
)

[Least]

A good improvement Marko. Thanks

[roy437]

Hi,

Here is another version of the rolling ball by the bisection method. Part of the code is from Lee-Mac, thank you.

The code does not work for any curves and in the case presented in jpg you must first select the upper curve then the lower one (line).

; Mid of the two curves, method rolling ball

; Part of the code is from Lee-Mac (thank you)

; 2020-05-28  = Roy437 =

(vl-load-com)

(defun c:mc ( / *error* a b c d1 d2 dis ds ent1 ent2 eps len_ent1 p1 p2 pp sel tmp )
    (setvar 'CMDECHO 0)
    (setvar 'OSMODE 0)
    (setq eps 0.0001)
    (command "color" 3)
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    (if
        (not
            (and
                (setq ds (getenv "LMac\\dist"))
                (setq ds (atof ds))
                (< 0  ds)
            )
        )
        (setenv "LMac\\dist" (rtos (setq ds 1.0)))
    )
    (if (setq sel
            (ssget "_:L"
               '(
                    (0 . "ARC,CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE")
                    (-4 . "<NOT")
                        (-4 . "<AND")
                            (0 . "POLYLINE") (-4 . "&") (70 . 88)
                        (-4 . "AND>")
                    (-4 . "NOT>")
                )
            )
        )
        (progn
            (initget 4)
            (if (setq tmp (getreal (strcat "\nSpecify length of arc(ds) <" (rtos ds) ">: ")))
                (setenv "LMac\\dist" (rtos (setq ds tmp)))
            )
            (LM:startundo (LM:acdoc))
            (setq ent1 (ssname sel 0)
                  ent2 (ssname sel 1)
                  dis 0.0
                  len_ent1 (vlax-curve-getdistatparam ent1 (vlax-curve-getendparam ent1))
            )
            (command "pline")
            (while (< dis len_ent1)
                (if (setq p1 (vlax-curve-getpointatdist ent1 dis))
                  (progn
                    (setq   p2 (vlax-curve-getClosestPointTo ent2 p1)
                             a p2
                             b p1
                            d1 0.0
                            d2 1.0
                    )

;   Bisection method
;   ---------------------------------------------------------------------
                    (while (> (abs (- d2 d1)) eps)
                      (setq
                              c (midp a b)
                             pp (vlax-curve-getClosestPointTo ent1 c)
                             d1 (distance c pp)
                             d2 (distance c p2)
                      )
                      (if (< d1 d2)
                        (setq  b c)
                        (setq  a c)
                      )
                    )
;   ---------------------------------------------------------------------

                   (command c)
                  )
                )
                (setq dis (+ dis ds))
             )
             (command)
             (LM:endundo (LM:acdoc))
        )
    )
    (princ)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

;; Midpoint  -  Lee Mac
;; Returns the midpoint of two points

(defun midp ( a b )
    (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) a b)
)

(princ "\nMC")
(princ)

 

I'm waiting for comments.