Challenge ? Generate N closed Plines from N groups of Points

[braudpat]

Hello

Please I am looking for a "special" routine to generate Profils / Plines from groups of Points

1) Look at the DWG ...

2) You will see 6 Groups of Points coming from a Tunnel ...

3) At the Top Level and Low Level you will see the 6 closed perfect Plines, I need ...

4) The generated Plines must be "perfect" : number of vertex = number of points

-- No double points

-- No self intersecting

5) Maybe for me the routine could be like :

51) Select 1st group of points, then Click on the center of the first group

Select second group, then Click on the center of the second group

etc ...

52) Then draw 1st closed perfect Pline, then second ...

I have drawn "by hand" the 6 perfect Plines ...

I have transformed a copy of the 6 closed Plines to MPOLYGON to check them !

So please if somebody has a MAGIC routine, I will appreciate !

The Health, Bye, Patrice (The Old French EE Froggy)

[-didier-]

Bonjour @braudpat 

Not really easy, the convex hull doesn’t work in your case.

We’ll have to think about it.

Amicalement

[ВeekeeCZ]

Something simple for a start. It's almost.

(vl-load-com)

(defun c:Tunnel ( / s l p ll ur c r p)
  
  (and (setq s (ssget '((0 . "POINT"))))
       (setq l (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
       (setq p (mapcar '(lambda (e) (cdr (assoc 10 (entget e)))) l))
       (setq ll (list (apply 'min (mapcar 'car p)) (apply 'min (mapcar 'cadr p))))
       (setq ur (list (apply 'max (mapcar 'car p)) (apply 'max (mapcar 'cadr p))))
       (vl-cmdf "_.rectang" "_non" ll "_non" ur)
       (setq r (entlast))
       (setq p (vl-sort p '(lambda (p1 p2) (< (vlax-curve-getdistatpoint r (vlax-curve-getclosestpointto r p1))
					      (vlax-curve-getdistatpoint r (vlax-curve-getclosestpointto r p2))))))
       (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length p)) (cons 70 1))
			(mapcar '(lambda (x) (cons 10 x)) p)))
       (entdel r)
       )
  (princ)
  )

[leeminardi]

"Almost" but impressively good!

[Sea-Haven]

Why would you not generate from the original XYZ points are they not in correct surveyed sequence ? This is every day for most existing feature surveys. 

Are they surveyed each section all mixed up not in sequence ?

[braudpat]

Hello @ВeekeeCZ 

1) Thanks and I am impressed by your very short routine !

2) I have joined a BETTER DWG with my better Profiles and YOURS Profiles ...

3) BRAVO : yours closed Plines are OK ... I have copied them on the right and generated MPOLYGONs !

4) I see 2 "major" differences between my "Mind" and your beautiful routine

See Profiles 1 and 2 ... I haven't any idea "how to follow" my mind !?

( In my mind I have drawn the Plines clockwise )

5) Please is it possible to have a routine for N Groups of Points to generate N closed PLines ?

6) I was thinking about a "Center / Centroid" of the Group of Points to do some X-Ray selection clockwise (or anti-clockwise) !? ... To try to avoid self-intersecting ?

Waiting and again THANKS ... Happy Sunday

The Health, Bye, Patrice

[braudpat]

Hello

1) Thanks to @-didier- which indicates me a routine from the Master Elpanov !

2) https://www.theswamp.org/index.php?topic=30434.75

Message 80 with a Routine from Elpanov improved by chlh_jd ...

3) Nice shortest pathes ...

Bye, Patrice

 

[hak_vz]

Here is my code that is not fully tested. It works as a concave hull i.,e. Alpha shape algorithm. It doesn't test if polyline self-intersects itself and don't work with inner islands of points.

(defun c:ch( / take mappend mklist flatten ss i pts pt1 tmp sorted)
	;hak_vz 25.09.2022
	(defun take (amount lst / ret)(repeat amount (setq ret (cons (car lst) (take (1- amount) (cdr lst))))))
	(defun mappend (fn lst)(apply 'append (mapcar fn lst)))
	(defun mklist (x) (if (listp x) x (list x)))
	(defun flatten (exp)(mappend 'mklist exp))
	(setq ss (ssget '((0 . "Point"))))
	(cond 
		((and ss)
			(setq i -1)
			(while (< (setq i (1+ i)) (sslength ss))
				(setq pts (cons (cdr(assoc 10 (entget (ssname ss i)))) pts))
			)
			(setq pts (vl-sort (mapcar '(lambda (x) (take 2 x)) pts) '(lambda (x y) (<(cadr x)(cadr y)))))
			(setq pt1 (car pts) pts (cdr pts) sorted (list pt1))
			(while (> (length pts) 1)
				(setq pts (vl-sort pts '(lambda (x y)(< (distance pt1 x)(distance pt1 y)))))
				(setq tmp (take 4 pts))
				(setq tmp (vl-sort tmp '(lambda (x y)(and (< (car x) (car y)) (< (car x) (car p1)) (< (car y) (car p1))))))
				(setq sorted (append sorted (list (car tmp))) pt1 (car tmp) pts (vl-remove pt1 pts))
			)
			(setq sorted (append sorted (list (car pts))))	
			(entmakex
				(apply 'append
					(cons
					  (list
						'(0 . "LWPOLYLINE")
						'(100 . "AcDbEntity")
						'(100 . "AcDbPolyline")
						'(410 . "Model")
						'(38 . 0)
						'(62 . 3)
						'(67 . 0)
						(cons 90 (length sorted))
						'(70 . 1)
					  )
					  (mapcar 'list (mapcar '(lambda (a) (cons 10 a)) sorted))
					) 
				)
			)
		)
	)
	(princ)
)

[ВeekeeCZ · Accepted solution]

---

@braudpat wrote:

...

4) I see 2 "major" differences between my "Mind" and your beautiful routine

See Profiles 1 and 2 ... I haven't any idea "how to "follow" my mind !?

( In my mind I have drawn the Plines clockwise )

It's a different algorithm. It draws a min. rectangular bounding box, then for each point finds the closest point on that rectangle, then it sorts the points by a distance along this rectangle. Therefore, those minor issues are not easily fixable. It needs to be fixed manually if not acceptable. 

Also, if you need the pline in the other direction, flip the last <.

5) Please is it possible to have a routine for N Groups of Points to generate N closed PLines ?

The possibility relies on the dwg layout - how close are the closest points of different profiles. I set 40 in the routine. For a layout in posted dwg 35 works too. If it's too low, it won't make the entire profile. If too large, joins neighboring profiles.

...

---

Hope this helps.

(vl-load-com)

(defun c:Tunnel ( / s l a b p :ll :ur c r :g g)

  (defun :ll (x) (list (apply 'min (mapcar 'car x)) (apply 'min (mapcar 'cadr x))))
  (defun :ur (x) (list (apply 'max (mapcar 'car x)) (apply 'max (mapcar 'cadr x))))
  
  (defun :g (p d / f r q)
    (while p
      (setq f (car p)
	    r (cons (vl-remove-if-not '(lambda (x) (< (distance x f) d)) p) r)
	    p (vl-remove-if '(lambda (x) (< (distance x f) d)) p)))
    (setq r (mapcar '(lambda (x) (cons (mapcar '/ (mapcar '+ (:ll x) (:ur x)) '(2 2)) x)) r))
    (while r
      (setq f (caar r)
	    q (cons (apply 'append (mapcar 'cdr (vl-remove-if-not '(lambda (x) (< (distance (car x) f) d)) r))) q)
	    r (vl-remove-if '(lambda (x) (< (distance (car x) f) d)) r)))
    q)
  
  (if (and (setq s (ssget '((0 . "POINT"))))
	   (setq a (mapcar '(lambda (e) (cdr (assoc 10 (entget e)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))))
	   )
    (foreach g (:g a 40)
      (vl-cmdf "_.rectang" "_non" (:ll g) "_non" (:ur g))
      (setq r (entlast))
      (setq g (vl-sort g '(lambda (p1 p2) (< (vlax-curve-getdistatpoint r (vlax-curve-getclosestpointto r p1))
					     (vlax-curve-getdistatpoint r (vlax-curve-getclosestpointto r p2))))))
      (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length g)) (cons 70 1))
		       (mapcar '(lambda (x) (cons 10 x)) g)))
      (entdel r)
      ))
  (princ)
  )

[CADaSchtroumpf · Accepted solution]

I took over the structure of BeeKeeCZ which was good.
I tried by projection on an ellipse to sort the parameters.
If it solves some imperfections, it creates others...
The problem with this request is that one cannot know what could be the focal point of the projection, nor the weight of the point to be projected.

(defun c:Tunnel1 ( / s l p ll ur pt_c r prm srt)
  (and (setq s (ssget '((0 . "POINT"))))
       (setq l (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
       (setq p (mapcar '(lambda (e) (cdr (assoc 10 (entget e)))) l))
       (setq ll (list (apply 'min (mapcar 'car p)) (apply 'min (mapcar 'cadr p))))
       (setq ur (list (apply 'max (mapcar 'car p)) (apply 'max (mapcar 'cadr p))))
       (setq pt_c (mapcar '* (mapcar '+ ll ur) '(0.5 0.5)))
       (vl-cmdf "_.ellipse" "_ce" "_none" pt_c "_none" (list (car ur) (cadr pt_c)) (distance pt_c (list (car pt_c) (cadr ur))))
       (setq r (entlast))
       (setq prm (mapcar '(lambda (e) (vlax-curve-getparamatpoint r (vlax-curve-getclosestpointto r e))) p))
       (setq p (mapcar '(lambda (x y) (cons x (list y))) prm p))
       (setq srt (vl-sort (mapcar 'car p) '<))
       (setq p (mapcar '(lambda (i) (cadr (assoc i p))) srt))
       (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length p)) (cons 70 1))
       (mapcar '(lambda (x) (cons 10 x)) p)))
       (entdel r)
  )
  (princ)
)

[CADaSchtroumpf]

Can generate a spline by automatically connecting the points by a maximum distance in order to have an envelope with the points having the strongest weights.
Then as with the ellipse sort according to the parameters of the projection of the points? The projection focus would be more accurate!
Not tested, not very familiar with splines depending on smoothing type.

[braudpat]

Hello @ВeekeeCZ @CADaSchtroumpf @hak_vz 

1) THANKS for your effort !

2) Please see the NEW joined DWG with all your 6 Profiles ...

3) Some funny Profiles by hak_vz !

Waiting for some other answers ...

Happy Sunday, The Health, Bye, Patrice

[Sea-Haven]

Waiting for some other answers ...

You did not answer my question as to how the points are generated in the 1st place if they are in a sequence then read the points and make the plines.

A fun 3d look modified dwg.

[braudpat]

Hello @Sea-Haven 

1) Thanks your 3D Image is right !

2) In fact I think that we cannot trust the "increasing" Handle of the Points because sometimes the Profile Points are examined : some are deleted, some are moved ... Maybe some are added to have a better Profile

The Points are coming from a Lidar Cloud : a profile extraction every 1/2/5/10 meters ...

3) So I LIKE the BeeKeeCZ solution with a distance parameter (40.0 meters) which detects all points into the "Group"

4) Next step will be a 3D "Lissage" (US Command: LOFT) of the Profiles / Plines to get a Surface or a Solid ...

The Health, Bye, Patrice

[Sea-Haven]

3D tubes are a problem, where I worked had  a huge video of an old underground brick drain, all 3d scanned. I would have thought that given point clouds now becoming so popular, that making a tube and slicing it would be possible, need other software, no idea where to look.

[braudpat]

Hello @Sea-Haven 

1) YES AutoCAD is not very good / fast in 3D for Lofting / Slicing / Sweeping / etc !

2) Maybe RHINO ?

The Health, Bye, Patrice

[3wood]

You can also try LINKPOINTS.

But its "Disconnect long distance segments" function sometimes creates a wrong result. You need select the point group manually and then select "No" to get the correct result.

Wrong result at the bottom right group when select "Yes":

Correct result when select this group of points manually and use "No":

[Sea-Haven]

This is similar to another request, I used make triangular mesh removed false triangles and made a outside boundary. Its not a fast method though.

[marko_ribar]

My contribution with template lsp I posted at the swamp... The code is same as CADaSchtroumpf's with ellipse, but should operate in 3D as well...

(defun c:Tunnel1 ( / vl-load *error* cmdfun cmderr catch_cont apply_cadr->car ftoa sysvarpreset sysvarlst sysvarvals initvalueslst ucsf ti s lst p ll ur pt_c r prm srt ocs lw d ) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;;

  (defun vl-load nil
    (or cad
      (cond
        ( (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil)))
          (setq cad (vlax-get-acad-object))
        )
        ( t
          (vl-load-com)
          (setq cad (vlax-get-acad-object))
        )
      )
    )
    (or doc (setq doc (vla-get-activedocument cad)))
    (or alo (setq alo (vla-get-activelayout doc)))
    (or spc (setq spc (vla-get-block alo)))
  )

  ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
  (or (and cad doc alo spc) (vl-load))

  (defun *error* ( m )
    (if ucsf
      (if (not (cmdfun (list "_.UCS" "_P") t))
        (cmderr 23)
      )
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if (not (cmdfun (list "_.UNDO" "_E") t))
        (cmderr 28)
        (if doc
          (vla-endundomark doc)
        )
      )
    )
    (if initvalueslst
      (mapcar (function apply_cadr->car) initvalueslst)
    )
    (if doc
      (vla-regen doc acactiveviewport)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun cmdfun ( tokenslist flag ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
    (if command-s
      (if flag
        (if (not (vl-catch-all-error-p (vl-catch-all-apply (function command-s) tokenslist)))
          flag
        )
        (apply (function command-s) tokenslist)
      )
      (if flag
        (apply (function vl-cmdf) tokenslist)
        (apply (function command) tokenslist)
      )
    )
  )

  (defun cmderr ( linenum ) ;;; linenum - integer representing line number at which used (cmdfun) failed with success execution ;;;
    (prompt (strcat "\ncommand execution failure... error at line " (itoa linenum) " ..."))
  )

  (defun catch_cont ( ctch / gr )
    (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
    (while
      (and
        (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
        (setq gr (grread))
        (/= (car gr) 3)
        (not (equal gr (list 2 13)))
      )
    )
    (if (vl-catch-all-error-p ctch)
      ctch
    )
  )

  (defun apply_cadr->car ( sysvarvaluepair / ctch )
    (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
    (if (vl-catch-all-error-p ctch)
      (progn
        (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
        (catch_cont ctch)
      )
    )
  )

  (defun ftoa ( n / m a s b )
    (if (numberp n)
      (progn
        (setq m (fix ((if (< n 0) - +) n 1e-8)))
        (setq a (abs (- n m)))
        (setq m (itoa m))
        (setq s "")
        (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
          (setq s (strcat s (itoa b)))
          (setq a (- (* a 10.0) b))
        )
        (if (= (type n) (quote int))
          m
          (if (= s "")
            m
            (if (and (= m "0") (< n 0))
              (strcat "-" m "." s)
              (strcat m "." s)
            )
          )
        )
      )
    )
  )

  (setq sysvarpreset
    (list
      (list (quote cmdecho) 0)
      (list (quote 3dosmode) 0)
      (list (quote osmode) 0)
      (list (quote unitmode) 0)
      (list (quote cmddia) 0)
      (list (quote ucsvp) 0)
      (list (quote ucsortho) 0)
      (list (quote projmode) 0)
      (list (quote orbitautotarget) 0)
      (list (quote insunits) 0)
      (list (quote hpseparate) 0)
      (list (quote hpgaptol) 0)
      (list (quote halogap) 0)
      (list (quote edgemode) 0)
      (list (quote pickdrag) 0)
      (list (quote qtextmode) 0)
      (list (quote dragsnap) 0)
      (list (quote angdir) 0)
      (list (quote aunits) 0)
      (list (quote limcheck) 0)
      (list (quote gridmode) 0)
      (list (quote nomutt) 0)
      (list (quote apbox) 0)
      (list (quote attdia) 0)
      (list (quote blipmode) 0)
      (list (quote copymode) 0)
      (list (quote circlerad) 0.0)
      (list (quote filletrad) 0.0)
      (list (quote filedia) 1)
      (list (quote autosnap) 1)
      (list (quote objectisolationmode) 1)
      (list (quote highlight) 1)
      (list (quote lispinit) 1)
      (list (quote layerpmode) 1)
      (list (quote fillmode) 1)
      (list (quote dragmodeinterrupt) 1)
      (list (quote dispsilh) 1)
      (list (quote fielddisplay) 1)
      (list (quote deletetool) 1)
      (list (quote delobj) 1)
      (list (quote dblclkedit) 1)
      (list (quote attreq) 1)
      (list (quote explmode) 1)
      (list (quote frameselection) 1)
      (list (quote ltgapselection) 1)
      (list (quote pickfirst) 1)
      (list (quote plinegen) 1)
      (list (quote plinetype) 1)
      (list (quote peditaccept) 1)
      (list (quote solidcheck) 1)
      (list (quote visretain) 1)
      (list (quote regenmode) 1)
      (list (quote celtscale) 1.0)
      (list (quote ltscale) 1.0)
      (list (quote osnapcoord) 2)
      (list (quote grips) 2)
      (list (quote dragmode) 2)
      (list (quote lunits) 2)
      (list (quote pickstyle) 3)
      (list (quote navvcubedisplay) 3)
      (list (quote pickauto) 3)
      (list (quote draworderctl) 3)
      (list (quote expert) 5)
      (list (quote auprec) 6)
      (list (quote luprec) 6)
      (list (quote pickbox) 6)
      (list (quote aperture) 6)
      (list (quote osoptions) 7)
      (list (quote dimzin) 8)
      (list (quote pdmode) 35)
      (list (quote pdsize) -1.5)
      (list (quote celweight) -1)
      (list (quote cecolor) "BYLAYER")
      (list (quote celtype) "ByLayer")
      (list (quote clayer) "0")
    )
  )
  (setq sysvarlst (mapcar (function car) sysvarpreset))
  (setq sysvarvals (mapcar (function cadr) sysvarpreset))
  (setq sysvarvals
    (vl-remove nil
      (mapcar
        (function (lambda ( x )
          (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
        ))
        sysvarlst
      )
    )
  )
  (setq sysvarlst
    (vl-remove-if-not
      (function (lambda ( x )
        (getvar x)
      ))
      sysvarlst
    )
  )
  (setq initvalueslst
    (apply (function mapcar)
      (cons (function list)
        (list
          sysvarlst
          (mapcar (function getvar) sysvarlst)
        )
      )
    )
  )
  (apply (function mapcar)
    (cons (function setvar)
      (list
        sysvarlst
        sysvarvals
      )
    )
  )
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (if (not (cmdfun (list "_.UNDO" "_E") t))
      (cmderr 234)
      (if doc
        (vla-endundomark doc)
      )
    )
  )
  (if (not (cmdfun (list "_.UNDO" "_M") t))
    (cmderr 241)
    (if doc
      (vla-startundomark doc)
    )
  )
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (if (not (cmdfun (list "_.UCS" "_W") t))
        (cmderr 249)
      )
      (setq ucsf t)
    )
  )
  (if (setq s (ssget (list (cons 0 "POINT,INSERT,CIRCLE"))))
    (progn
      (setq ti (car (_vl-times)))
      (setq lst (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s))))
      (setq p (mapcar (function (lambda ( e ) (cdr (assoc 10 (entget e))))) lst))
      (setq ll (list (apply (function min) (mapcar (function car) p)) (apply (function min) (mapcar (function cadr) p)) (apply (function min) (mapcar (function caddr) p))))
      (setq ur (list (apply (function max) (mapcar (function car) p)) (apply (function max) (mapcar (function cadr) p)) (apply (function max) (mapcar (function caddr) p))))
      (setq pt_c (mapcar (function *) (mapcar (function +) ll ur) (list 0.5 0.5 0.5)))
      (if (not (cmdfun (list "_.UCS" "_ZA" "_non" pt_c "_non" ur) t))
        (cmderr 263)
        (if (not (cmdfun (list "_.UCS" "_X" 90.0) t))
          (cmderr 265)
        )
      )
      (setq ocs (trans (list 0.0 0.0 1.0) 1 0 t))
      (setq p (mapcar (function (lambda ( x ) (trans x 0 1))) p))
      (setq ll (list (apply (function min) (mapcar (function car) p)) (apply (function min) (mapcar (function cadr) p)) (apply (function min) (mapcar (function caddr) p))))
      (setq ur (list (apply (function max) (mapcar (function car) p)) (apply (function max) (mapcar (function cadr) p)) (apply (function max) (mapcar (function caddr) p))))
      (if (not (cmdfun (list "_.ELLIPSE" "_CE" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 (cadr ur) 0.0) (abs (car ur))) t))
        (cmderr 273)
        (progn
          (setq r (entlast))
          (setq p (mapcar (function (lambda ( x ) (trans x 1 0))) p))
          (setq prm (mapcar (function (lambda ( e ) (vlax-curve-getparamatpoint r (vlax-curve-getclosestpointto r e)))) p))
          (setq p (mapcar (function (lambda ( x y ) (cons x (list y)))) prm p))
          (setq srt (vl-sort (mapcar (function car) p) (function <)))
          (setq p (mapcar (function (lambda ( i ) (cadr (assoc i p)))) srt))
          (setq lw
            (entmakex
              (append
                (list
                  (cons 0 "LWPOLYLINE")
                  (cons 100 "AcDbEntity")
                  (cons 100 "AcDbPolyline")
                  (cons 90 (length p))
                  (cons 70 1)
                  (cons 38 (caddr (trans (list 0.0 0.0 0.0) 1 ocs)))
                )
                (mapcar (function (lambda ( x ) (cons 10 (trans x 0 ocs)))) p)
                (list (cons 210 ocs))
              )
            )
          )
          (setq d (vlax-curve-getdistatparam lw (vlax-curve-getendparam lw)))
          (entdel r)
          (repeat 2
            (if (not (cmdfun (list "_.UCS" "_P") t))
              (cmderr 301)
            )
          )
          (prompt "\nLWPOLYLINE length : ") (prompt (ftoa d))
          (prompt "\nElapsed time : ") (prompt (ftoa (- (car (_vl-times)) ti))) (prompt " milliseconds...")
          (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
        )
      )
    )
    (prompt "\nNothing selected... Better luck next time...")
  )
  (*error* nil)
)

Regards, M.R.

HTH.

[marko_ribar]

With checking intersections :

(defun c:Tunnel ( / vl-load *error* cmdfun cmderr catch_cont apply_cadr->car ftoa collinear-p chkinters-p chkinters sysvarpreset sysvarlst sysvarvals initvalueslst ucsf ti ch s lst p ll ur pt_c r prm srt ocs lw d ) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;;

  (defun vl-load nil
    (or cad
      (cond
        ( (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil)))
          (setq cad (vlax-get-acad-object))
        )
        ( t
          (vl-load-com)
          (setq cad (vlax-get-acad-object))
        )
      )
    )
    (or doc (setq doc (vla-get-activedocument cad)))
    (or alo (setq alo (vla-get-activelayout doc)))
    (or spc (setq spc (vla-get-block alo)))
  )

  ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
  (or (and cad doc alo spc) (vl-load))

  (defun *error* ( m )
    (if ucsf
      (if (not (cmdfun (list "_.UCS" "_P") t))
        (cmderr 23)
      )
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if (not (cmdfun (list "_.UNDO" "_E") t))
        (cmderr 28)
        (if doc
          (vla-endundomark doc)
        )
      )
    )
    (if initvalueslst
      (mapcar (function apply_cadr->car) initvalueslst)
    )
    (if doc
      (vla-regen doc acactiveviewport)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun cmdfun ( tokenslist flag ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
    (if command-s
      (if flag
        (if (not (vl-catch-all-error-p (vl-catch-all-apply (function command-s) tokenslist)))
          flag
        )
        (apply (function command-s) tokenslist)
      )
      (if flag
        (apply (function vl-cmdf) tokenslist)
        (apply (function command) tokenslist)
      )
    )
  )

  (defun cmderr ( linenum ) ;;; linenum - integer representing line number at which used (cmdfun) failed with success execution ;;;
    (prompt (strcat "\ncommand execution failure... error at line " (itoa linenum) " ..."))
  )

  (defun catch_cont ( ctch / gr )
    (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
    (while
      (and
        (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
        (setq gr (grread))
        (/= (car gr) 3)
        (not (equal gr (list 2 13)))
      )
    )
    (if (vl-catch-all-error-p ctch)
      ctch
    )
  )

  (defun apply_cadr->car ( sysvarvaluepair / ctch )
    (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
    (if (vl-catch-all-error-p ctch)
      (progn
        (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
        (catch_cont ctch)
      )
    )
  )

  (defun ftoa ( n / m a s b )
    (if (numberp n)
      (progn
        (setq m (fix ((if (< n 0) - +) n 1e-8)))
        (setq a (abs (- n m)))
        (setq m (itoa m))
        (setq s "")
        (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
          (setq s (strcat s (itoa b)))
          (setq a (- (* a 10.0) b))
        )
        (if (= (type n) (quote int))
          m
          (if (= s "")
            m
            (if (and (= m "0") (< n 0))
              (strcat "-" m "." s)
              (strcat m "." s)
            )
          )
        )
      )
    )
  )

  (defun collinear-p ( p1 p p2 )
    (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
  )
 
  (defun chkinters-p ( pl / r )
    (or lil (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl))))))
    (setq r (vl-some (function (lambda ( x ) (vl-some (function (lambda ( y ) (and (not (equal (car x) (car y) 1e-6)) (not (equal (car x) (cadr y) 1e-6)) (not (equal (cadr x) (car y) 1e-6)) (not (equal (cadr x) (cadr y) 1e-6)) (or (inters (car x) (cadr x) (car y) (cadr y)) (collinear-p (car x) (car y) (cadr x)) (collinear-p (car x) (cadr y) (cadr x)) (collinear-p (car y) (car x) (cadr y)) (collinear-p (car y) (cadr x) (cadr y)))))) (vl-remove (if (= (vl-position x lil) 0) (last lil) (nth (1- (vl-position x lil)) lil)) (vl-remove (if (= (vl-position x lil) (1- (length lil))) (car lil) (nth (1+ (vl-position x lil)) lil)) (vl-remove x lil)))))) lil))
    (setq lil nil)
    r
  )
 
  (defun chkinters ( pl / processlil done r lill ilil iip )
 
    (defun processlil ( ilil lil / pre mid suf ret )
      (setq pre (reverse (cdr (member (car ilil) (reverse lil)))))
      (setq mid (cdr (member (car ilil) lil)))
      (setq mid (cdr (member (cadr ilil) (reverse mid))))
      (setq mid (mapcar (function reverse) mid))
      (setq suf (cdr (member (cadr ilil) lil)))
      (setq ret (append pre (list (list (car (car ilil)) (car (cadr ilil)))) mid (list (list (cadr (car ilil)) (cadr (cadr ilil)))) suf))
      ret
    )
 
    (or lil (setq lil (mapcar (function list) pl (append (cdr pl) (list (car pl))))))
    (while (not done)
      (setq ilil (vl-some (function (lambda ( a ) (vl-some (function (lambda ( b / ip ) (progn (setq iip (inters (car a) (cadr a) (car b) (cadr b))) (if (and (not (equal (cadr a) (car b) 1e-6)) (not (equal (car a) (cadr b) 1e-6)) (not (or (and (collinear-p (car a) (car b) (cadr a)) (collinear-p (car a) (cadr b) (cadr a))) (and (collinear-p (car b) (car a) (cadr b)) (collinear-p (car b) (cadr a) (cadr b))))) (not (or (and (collinear-p (car a) (car b) (cadr a)) (collinear-p (car b) (cadr a) (cadr b))) (and (collinear-p (car b) (car a) (cadr b)) (collinear-p (car a) (cadr b) (cadr a)))))) (cond ( (collinear-p (car a) (car b) (cadr a)) (setq ip (car b)) ) ( (collinear-p (car a) (cadr b) (cadr a)) (setq ip (cadr b)) ) ( (collinear-p (car b) (car a) (cadr b)) (setq ip (car a)) ) ( (collinear-p (car b) (cadr a) (cadr b)) (setq ip (cadr a)) )) (setq iip nil)) (cond ( iip (list a b iip) ) ( ip (list a b ip) ))))) (vl-remove a lil)))) lil))
      (cond
        ( (and ilil (equal iip (caddr ilil) 1e-6))
          (setq lil (processlil ilil lil))
        )
        ( (and ilil (equal (caar ilil) (caddr ilil) 1e-6))
          (cond
            ( (and (not (equal (caar ilil) (caadr ilil) 1e-6)) (not (equal (caar ilil) (cadadr ilil) 1e-6)))
              (setq lil (processlil ilil lil))
            )
            ( (equal (caar ilil) (caadr ilil) 1e-6)
              (setq lil (processlil ilil lil))
            )
            ( (equal (caar ilil) (cadadr ilil) 1e-6)
              (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
              (setq lil (processlil ilil lil))
            )
          )
        )
        ( (and ilil (equal (cadar ilil) (caddr ilil) 1e-6))
          (cond
            ( (and (not (equal (cadar ilil) (caadr ilil) 1e-6)) (not (equal (cadar ilil) (cadadr ilil) 1e-6)))
              (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
              (setq lil (processlil ilil lil))
            )
            ( (equal (cadar ilil) (caadr ilil) 1e-6)
              (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
              (setq lil (processlil ilil lil))
            )
            ( (equal (cadar ilil) (cadadr ilil) 1e-6)
              (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
              (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
              (setq lil (processlil ilil lil))
            )
          )
        )
        ( (and ilil (equal (caadr ilil) (caddr ilil) 1e-6))
          (cond
            ( (and (not (equal (caadr ilil) (caar ilil) 1e-6)) (not (equal (caadr ilil) (cadar ilil) 1e-6)))
              (setq lil (processlil ilil lil))
            )
            ( (equal (caadr ilil) (caar ilil) 1e-6)
              (setq lil (processlil ilil lil))
            )
            ( (equal (caadr ilil) (cadar ilil) 1e-6)
              (setq ilil (subst (assoc (caadr ilil) lil) (car ilil) ilil))
              (setq lil (processlil ilil lil))
            )
          )
        )
        ( (and ilil (equal (cadadr ilil) (caddr ilil) 1e-6))
          (cond
            ( (and (not (equal (cadadr ilil) (caar ilil) 1e-6)) (not (equal (cadadr ilil) (cadar ilil) 1e-6)))
              (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
              (setq lil (processlil ilil lil))
            )
            ( (equal (cadadr ilil) (caar ilil) 1e-6)
              (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
              (setq lil (processlil ilil lil))
            )
            ( (equal (cadadr ilil) (cadar ilil) 1e-6)
              (setq ilil (subst (assoc (cadadr ilil) lil) (cadr ilil) ilil))
              (setq ilil (subst (assoc (cadar ilil) lil) (car ilil) ilil))
              (setq lil (processlil ilil lil))
            )
          )
        )
        ( t (setq done t) )
      )
    )
    (setq r (mapcar (function car) lil))
    (setq lil nil)
    r
  )

  (setq sysvarpreset
    (list
      (list (quote cmdecho) 0)
      (list (quote 3dosmode) 0)
      (list (quote osmode) 0)
      (list (quote unitmode) 0)
      (list (quote cmddia) 0)
      (list (quote ucsvp) 0)
      (list (quote ucsortho) 0)
      (list (quote projmode) 0)
      (list (quote orbitautotarget) 0)
      (list (quote insunits) 0)
      (list (quote hpseparate) 0)
      (list (quote hpgaptol) 0)
      (list (quote halogap) 0)
      (list (quote edgemode) 0)
      (list (quote pickdrag) 0)
      (list (quote qtextmode) 0)
      (list (quote dragsnap) 0)
      (list (quote angdir) 0)
      (list (quote aunits) 0)
      (list (quote limcheck) 0)
      (list (quote gridmode) 0)
      (list (quote nomutt) 0)
      (list (quote apbox) 0)
      (list (quote attdia) 0)
      (list (quote blipmode) 0)
      (list (quote copymode) 0)
      (list (quote circlerad) 0.0)
      (list (quote filletrad) 0.0)
      (list (quote filedia) 1)
      (list (quote autosnap) 1)
      (list (quote objectisolationmode) 1)
      (list (quote highlight) 1)
      (list (quote lispinit) 1)
      (list (quote layerpmode) 1)
      (list (quote fillmode) 1)
      (list (quote dragmodeinterrupt) 1)
      (list (quote dispsilh) 1)
      (list (quote fielddisplay) 1)
      (list (quote deletetool) 1)
      (list (quote delobj) 1)
      (list (quote dblclkedit) 1)
      (list (quote attreq) 1)
      (list (quote explmode) 1)
      (list (quote frameselection) 1)
      (list (quote ltgapselection) 1)
      (list (quote pickfirst) 1)
      (list (quote plinegen) 1)
      (list (quote plinetype) 1)
      (list (quote peditaccept) 1)
      (list (quote solidcheck) 1)
      (list (quote visretain) 1)
      (list (quote regenmode) 1)
      (list (quote celtscale) 1.0)
      (list (quote ltscale) 1.0)
      (list (quote osnapcoord) 2)
      (list (quote grips) 2)
      (list (quote dragmode) 2)
      (list (quote lunits) 2)
      (list (quote pickstyle) 3)
      (list (quote navvcubedisplay) 3)
      (list (quote pickauto) 3)
      (list (quote draworderctl) 3)
      (list (quote expert) 5)
      (list (quote auprec) 6)
      (list (quote luprec) 6)
      (list (quote pickbox) 6)
      (list (quote aperture) 6)
      (list (quote osoptions) 7)
      (list (quote dimzin) 8)
      (list (quote pdmode) 35)
      (list (quote pdsize) -1.5)
      (list (quote celweight) -1)
      (list (quote cecolor) "BYLAYER")
      (list (quote celtype) "ByLayer")
      (list (quote clayer) "0")
    )
  )
  (setq sysvarlst (mapcar (function car) sysvarpreset))
  (setq sysvarvals (mapcar (function cadr) sysvarpreset))
  (setq sysvarvals
    (vl-remove nil
      (mapcar
        (function (lambda ( x )
          (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
        ))
        sysvarlst
      )
    )
  )
  (setq sysvarlst
    (vl-remove-if-not
      (function (lambda ( x )
        (getvar x)
      ))
      sysvarlst
    )
  )
  (setq initvalueslst
    (apply (function mapcar)
      (cons (function list)
        (list
          sysvarlst
          (mapcar (function getvar) sysvarlst)
        )
      )
    )
  )
  (apply (function mapcar)
    (cons (function setvar)
      (list
        sysvarlst
        sysvarvals
      )
    )
  )
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (if (not (cmdfun (list "_.UNDO" "_E") t))
      (cmderr 334)
      (if doc
        (vla-endundomark doc)
      )
    )
  )
  (if (not (cmdfun (list "_.UNDO" "_M") t))
    (cmderr 341)
    (if doc
      (vla-startundomark doc)
    )
  )
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (if (not (cmdfun (list "_.UCS" "_W") t))
        (cmderr 349)
      )
      (setq ucsf t)
    )
  )
  (initget 1 "3D 2D")
  (setq ch (getkword "\nChoose option [2D / 3D] : "))
  (prompt "\nSelect points, blocks or circles...")
  (if (setq s (ssget (list (cons 0 "POINT,INSERT,CIRCLE"))))
    (progn
      (setq ti (car (_vl-times)))
      (setq lst (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s))))
      (setq p (mapcar (function (lambda ( e ) (cdr (assoc 10 (entget e))))) lst))
      (setq ll (list (apply (function min) (mapcar (function car) p)) (apply (function min) (mapcar (function cadr) p)) (apply (function min) (mapcar (function caddr) p))))
      (setq ur (list (apply (function max) (mapcar (function car) p)) (apply (function max) (mapcar (function cadr) p)) (apply (function max) (mapcar (function caddr) p))))
      (setq pt_c (mapcar (function *) (mapcar (function +) ll ur) (list 0.5 0.5 0.5)))
      (if (not (cmdfun (list "_.UCS" "_ZA" "_non" pt_c "_non" ur) t))
        (cmderr 366)
        (if (not (cmdfun (list "_.UCS" "_X" 90.0) t))
          (cmderr 369)
        )
      )
      (setq ocs (trans (list 0.0 0.0 1.0) 1 0 t))
      (setq p (mapcar (function (lambda ( x ) (trans x 0 1))) p))
      (setq ll (list (apply (function min) (mapcar (function car) p)) (apply (function min) (mapcar (function cadr) p)) (apply (function min) (mapcar (function caddr) p))))
      (setq ur (list (apply (function max) (mapcar (function car) p)) (apply (function max) (mapcar (function cadr) p)) (apply (function max) (mapcar (function caddr) p))))
      (if (not (cmdfun (list "_.ELLIPSE" "_CE" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 (cadr ur) 0.0) (abs (car ur))) t))
        (cmderr 376)
        (progn
          (setq r (entlast))
          (setq p (mapcar (function (lambda ( x ) (trans x 1 0))) p))
          (setq prm (mapcar (function (lambda ( e ) (vlax-curve-getparamatpoint r (vlax-curve-getclosestpointto r e)))) p))
          (setq p (mapcar (function (lambda ( x y ) (cons x (list y)))) prm p))
          (setq srt (vl-sort (mapcar (function car) p) (function <)))
          (setq p (mapcar (function (lambda ( i ) (cadr (assoc i p)))) srt))
          (if (chkinters-p p)
            (setq p (chkinters p))
          )
          (if (= ch "2D")
            (entmake
              (append
                (list
                  (cons 0 "LWPOLYLINE")
                  (cons 100 "AcDbEntity")
                  (cons 100 "AcDbPolyline")
                  (cons 90 (length p))
                  (cons 70 1)
                  (cons 38 (caddr (trans (list 0.0 0.0 0.0) 1 ocs)))
                )
                (mapcar (function (lambda ( x ) (cons 10 (trans x 0 ocs)))) p)
                (list (cons 210 ocs))
              )
            )
            (progn
              (entmake
                (list
                  (cons 0 "POLYLINE")
                  (cons 100 "AcDbEntity")
                  (cons 100 "AcDb3dPolyline")
                  (cons 66 1)
                  (list 10 0.0 0.0 0.0)
                  (cons 70 9)
                  (list 210 0.0 0.0 1.0)
                )
              )
              (foreach pt p
                (entmake
                  (list
                    (cons 0 "VERTEX")
                    (cons 100 "AcDbEntity")
                    (cons 100 "AcDbVertex")
                    (cons 100 "AcDb3dPolylineVertex")
                    (cons 10 pt)
                    (cons 70 32)
                  )
                )
              )
              (entmake
                (list
                  (cons 0 "SEQEND")
                  (cons 100 "AcDbEntity")
                )
              )
            )
          )
          (setq d (vlax-curve-getdistatparam (entlast) (vlax-curve-getendparam (entlast))))
          (entdel r)
          (repeat 2
            (if (not (cmdfun (list "_.UCS" "_P") t))
              (cmderr 438)
            )
          )
          (prompt "\nPath length : ") (prompt (ftoa d))
          (prompt "\nElapsed time : ") (prompt (ftoa (- (car (_vl-times)) ti))) (prompt " milliseconds...")
          (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
        )
      )
    )
    (prompt "\nNothing selected... Better luck next time...")
  )
  (*error* nil)
)

Regards, M.R.