All Activity

x y z 21.0937p1 200.4997p1 0p1 22.0937p2 201.4997p2 0p2 23.0937p3 203.4997p3 0p3 23.0807p3 203.4797p3 0p3 The txt file should always be kept in the above uniform format

Yes, rename the block first, then use the @ronjonp code.

Probably, for my task, it will be easier to change the @mhupp code. ;; Copy dimension value to another location (x0.001) + text angle = 0 ;; DimCopy.lsp the original / creator mhupp ;; https://www.cadtutor.net/forum/topic/75587-help-with-extracting-text-from-one-dimension/#findComment-597630 ;; modification using AI (defun _DimCopy001:OnlyNum (s / lst out c) ;; we leave only numbers, minus sign, period/comma (setq lst (vl-string->list s) out "") (foreach c lst (if (member c (vl-string->list "0123456789-.,")) (setq out (strcat out (chr c))) ) ) ;; comma -> period (vl-string-subst "." "," out) ) (defun _DimCopy001:SetText (e / ed txt num new r50) (setq ed (entget e) txt (cdr (assoc 1 ed))) ;; change the text to *0.001 (if (and txt (/= txt "")) (progn (setq txt (_DimCopy001:OnlyNum txt)) (if (and txt (/= txt "")) (progn (setq num (atof txt)) (setq new (rtos (* num 0.001) 2 3)) ; for example 4250 -> 4.250 (setq ed (subst (cons 1 new) (assoc 1 ed) ed)) ) ) ) ) ;; ang 0 (DXF 50) (if (setq r50 (assoc 50 ed)) (setq ed (subst (cons 50 0.0) r50 ed)) (setq ed (append ed (list (cons 50 0.0)))) ) (entmod ed) (entupd e) ) (defun C:DimCopy001Txt (/ dim BP LastEnt en obj oldEcho) (vl-load-com) (setq oldEcho (getvar 'cmdecho)) (setvar 'cmdecho 0) (while (setq dim (car (entsel "\nSelect Dimension: "))) (setq obj (vlax-ename->vla-object dim)) (setq BP (vlax-get obj 'TextPosition)) (setq LastEnt (entlast)) (command "_.Copy" dim "" "_non" BP (getpoint BP "\nCopy to: ")) (command "_Explode" (entlast)) (if (setq en (entnext LastEnt)) (while en (cond ((= "MTEXT" (cdr (assoc 0 (entget en)))) (command "_Explode" en) ; convert mtext to text ) ((= "TEXT" (cdr (assoc 0 (entget en)))) (_DimCopy001:SetText en) ; <<< scale + angle 0 ) (t (entdel en) ) ) (setq en (entnext en)) ) ) ) (setvar 'cmdecho oldEcho) (princ) ) Perhaps this code can be made prettier and shorter...

Drawing2.dwg As shown in the figure below: Select multiple graphics in batch and change the R value from 0.2 to another value?

@ronjonp thanks. This code reduces the height of the text, but I need to reduce the dimension value (x 0.001) and insert the text (angle text 0, text height = height of the dimtext).

You could use this to rename the reference in question so that it references a different (duplicate) block definition, which could then be marked as explodable.

Something like this? (defun c:foo (/ e el m p1 p2) (cond ((and (setq e (car (entsel "\nPick dimension: "))) (progn (vlax-for a (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (cdr (assoc 2 (entget e))) ) (and (= "AcDbMText" (vla-get-objectname a)) (setq m (vlax-vla-object->ename a))) ) m ) (setq p1 (cdr (assoc 10 (setq el (entget m))))) (setq p2 (getpoint p1 "\nSpecify second point: ")) ) (setq e (entmakex (append (vl-remove-if '(lambda (x) (= 330 (car x))) el) (list (cons 10 p2)))) ) (vla-put-height (setq e (vlax-ename->vla-object e)) (* 0.001 (vla-get-height e))) ) ) (princ) )

This is not possible that I'm aware of. The code above could be modified to explode the blocks selected then make those block definitions un-explodable again.

You may have to Wblock one block, open the wblock, change the explode to "Yes" then rename the block. You can now insert that block into your dwg say deleting the original block. But you will have 2 blocks.

@SLW210 I like the idea of choices in layout name, the main issue is how each company names their layouts or sheet names etc. We used a simple year+projectnumber so a a 2026002-D01 was the name of a layout and single PDF when plotted. If a multi page pdf it would be just 2026002.pdf but we had revisions and a plot date on each sheet.

@GLAVCVS I’ve been testing your latest code. It’s truly impressive. I’m attaching an image of the most difficult area of the last drawing: it’s hard to find a spot where the centerline is not perfectly equidistant. And where it isn’t, it’s always below the tolerance — hats off to you. I’ve also been curious to try the code on embedded geometric figures. As you said, the code fails quite badly here. But when it does work, it returns results that are quite different from those of the @dexus or @GP_ codes, which are much simpler I wonder: why?

I apologize for my English. I use a translator, but I'm not sure if it translates well enough. I have several blocks with the same name. I want to allow exploding for only one selected block. Convert one unexplodable block to explodable block (another translation). Is it possible to leave the other blocks of the same name unchanged?

Ron, I think he thinks to make explodable only selected references and not definitions... Unfortunately, I think this is impossible...

Hi, it's me again... I've implemented lastly coded interventions by @GLAVCVS into my cleaned version... It should work well with user selection of network entities... Still filter for selection is now very robust, but it seems that it should be coded like that (I don't know how to make it better - shorter)... I think that this version fulfills any situation that may occur LINES, POLYLINES (2D-Heavy, 3D), LWPOLYLINES (without arced segments). If you see something I missed, please don't hasitate to inform - post reply... ;; Pathfinding with the A* algorithm by ymg 22/07/2024 ; ;; ; ;; Revised a prog by HELMUT SCHRÖDER - heschr@gmx.de - 2014-09-14 ; ;; found at Cadtutor.net ; ;; ; ;; Kept the same format for edges list but added lines as valid choice ; ;; Format: (((x1 y1 z1) (x2 y2 z2)) ((x2 y2 z2) (x3 y3 z3))....) ; ;; ; ;; The user is asked to pick a start and an endpoint. ; ;; The program will find the shortest path in a network of connected ; ;; lines and draw a new 3dpolyline representing the result. ; ;; ; ;; Two lists of nodes openlst and closelst are created from the above ; ;; mentionned edges list. The format of a node list is: ; ;; (((Point) (Prev Point) Cumulated_Distance Estimated_Total_Distance)...) ; ;; ; ;; Main change from origina are: ; ;; - cons the list instead of append ; ;; - vl-sort the openlist instead of the quicksort ; ;; - Replaced and renamed some vars and subroutine. ; ;; - Added fuzz 1e-4 to all points comparison ; ;; - Change the get_path function ; ;; - Added line as possible edges ; ;; - Added an error handler ; ;; - Added a timer to the search portion of the program ; ;; ; ;; The above changes amounted to an acceleration of about 4x from the ; ;; original program. ; ;; : ;; If you compile this program to a .fas you'll get more than 10x faster. ; ;; ; ;| Added or modified code by GLAVCVS (january 2026) -All set are grouped into one -An associative sparse matrix cell->handles is created for faster cell querying (using new 'addToDict' and 'getCell' functions) -The "edges" list is replaced with the local search retourned by 'getCell' T E S T S ===== fas: 4-5 x faster than previous fas lsp: 7-8 x faster than previous lsp |; (defun c:A* (/ *error* addToDict getCell upd_openlst in_openlst get_path memberfuzz mk_lwp f3Dpol LM:rtos set_errhandler sspl i startp endp e openlst closelst found acdoc lstClvs Pathlay Pathcol Pathlwt varl node ti ) (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com)) (defun *error* (msg) (if e (if command-s (command-s "_.draworder" e "" "_f") (vl-cmdf "_.draworder" e "" "_f") ) ) (mapcar (function eval) varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (vla-endundomark acdoc) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS ;;;Create dictionary (defun addToDict (en / p val id clv i l c a) (setq i -1 id (cdr (assoc 5 (setq l (entget en)))) c (= (cdr (assoc 0 l)) "LINE") a 10) (while (setq p (if (and (setq i (1+ i)) c) (cdr (assoc (+ a i) l)) (vlax-curve-getPointAtParam en i))) (if (setq val (assoc (setq clv (strcat (LM:rtos (car p) 2 4) "-" (LM:rtos (cadr p) 2 4) "-" (LM:rtos (caddr p) 2 4))) lstClvs)) (setq lstClvs (subst (append val (list (cons id i))) val lstClvs)) (setq lstClvs (cons (list clv (cons id i)) lstClvs)) ) ) ) ;;;return list cell ;;*** Modified to access the new dictionary format *** (defun getCell (pt / val clv lr pr par l c oc) (defun oc (c e i) (if c (cdr (assoc (+ i 10) l)) (vlax-curve-getPointAtParam e i))) (if (setq val (assoc (setq clv (strcat (LM:rtos (car pt) 2 4) "-" (LM:rtos (cadr pt) 2 4) "-" (LM:rtos (caddr pt) 2 4))) lstClvs)) (foreach par (cdr val) (setq e (handent (car par)) c (= (cdr (assoc 0 (setq l (entget e)))) "LINE")) (if (zerop (setq pr (cdr par))) (setq lr (cons (list (oc c e pr) (oc c e (1+ pr))) lr)) (setq lr (cons (list (oc c e (1- pr)) (setq p0 (oc c e pr))) lr) lr (if (setq p (oc c e (1+ pr))) (cons (list p0 p) lr) lr) ) ) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ; ;; upd_openlst ; ;; ; ;; Each node of the openlst is passed to this sub and we scan the edges list ; ;; to find the corresponding edges. Then both points of the edges are tested ; ;; for equality to the nodes. The fixed cost (distance) is updated and so is ; ;; the estimated total distance. Updates are first put in a temporary node. ; ;; ; ;; We then proceed to test if the temp variable is already in the closelst ; ;; and proceed to the next edge. ; ;; ; ;; If temp is true and temp is not in closelst we go to the recursive sub ; ;; in_openlst which adjust the values and return the updated openlst ; ;; ; ;; Upon return we sort the openlst on smallest estimated distance ; ;; and return the openlst to the main routine ; ;; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun upd_openlst (node endp openlst closelst / lEdges pt fcost p1 p2 d temp) (setq pt (car node) fcost (caddr node) ) (setq lEdges (getCell pt)) (foreach edge lEdges (setq p1 (car edge) p2 (cadr edge) d (distance p1 p2) temp nil ) (cond ((equal pt p1 1e-4) (setq temp (list p2 p1 (+ fcost d) (+ fcost d (distance p2 endp)))) ) ((equal pt p2 1e-4) (setq temp (list p1 p2 (+ fcost d) (+ fcost d (distance p1 endp)))) ) ) (if (and temp (not (memberfuzz (car temp) closelst))) (setq openlst (in_openlst temp openlst)) ) ) (vl-sort openlst (function (lambda (a b) (< (cadddr a) (cadddr b))))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun in_openlst (node lst) (cond ((not lst) (list node)) ((equal (car node) (caar lst) 1e-4) (if (< (cadddr node) (cadddr (car lst))) (cons node (cdr lst)) lst ) ) (t (cons (car lst) (in_openlst node (cdr lst)))) ) ) ;; ; ;; get_path ; ;; ; ;; Returns The list of points of shortest path found from closelst. ; ;; ; (defun get_path (lst / path) (setq path (list (caar lst)) prev (cadar lst) lst (cdr lst) ) (while (setq lst (memberfuzz prev lst)) (setq prev (cadar lst) path (cons (caar lst) path) ) ) path ) ;; ; ;; memberfuzz by Gile Chanteau ; ;; ; ;; Modified to work with nodes list ; ;; ; (defun memberfuzz (p lst) (while (and lst (not (equal p (caar lst) 1e-4))) (setq lst (cdr lst)) ) lst ) ;; ; ;; f3Dpol ; ;; ; ;; Draw an 3dpolyline given a point list ; ;; ; ;; Will be drawn on layer, lineweight and color defined by Variables ; ;; at beginnung of program. ; ;; ; (defun f3Dpol (pts c / ep ll la e) (setq ep (if (= 1 (getvar (quote cvport))) (vla-get-PaperSpace acdoc) (vla-get-ModelSpace acdoc)) ll (apply (function append) pts) la (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length ll)))) (mapcar (function float) ll)) e (vla-Add3DPoly ep la) ) (vla-put-Color e c) (vla-put-Layer e Pathlay) (vla-put-Lineweight e Pathlwt) (vlax-vla-object->ename e) ) ;; ; ;; mk_lwp ; ;; ; ;; Draw an lwpolyline given a point list ; ;; ; ;; Will be drawn on layer with color and lineweight defined by Variables ; ;; at beginnung of program. ; ;; ; (defun mk_lwp (pl) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 8 Pathlay) (cons 62 Pathcol) (cons 90 (length pl)) (cons 70 0) (cons 370 Pathlwt) ) (mapcar (function (lambda (a) (cons 10 a))) pl) ) ) ) ;; A wrapper for the rtos function to negate the effect of DIMZIN - Lee Mac (defun LM:rtos (real units prec / dimzin result) (setq dimzin (getvar (quote dimzin))) (setvar (quote dimzin) 0) (setq result (vl-catch-all-apply (function rtos) (list real units prec))) (setvar (quote dimzin) dimzin) (if (not (vl-catch-all-error-p result)) result ) ) ;; Error Handler by Elpanov Evgenyi ; (defun set_errhandler (l) (setq varl (mapcar (function (lambda (a) (list (quote setvar) a (getvar a)))) l)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Change values of following 3 variables to suit your need. ; (setq Pathlay "0" Pathcol 3 ; 1=Red 2=Yellow 3=Green etc. ; Pathlwt 30 ; lineweight for path 0.3 mm ; ) (or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))) (set_errhandler (list "clayer" "osmode" "cmdecho")) (setvar (quote cmdecho) 0) (setvar (quote osmode) 1) (setvar (quote lwdisplay) 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (prompt "\nSelect LINE and polygonal POLYLINE network entities...") (if (setq sspl (ssget (list (cons -4 "<or") (cons 0 "LINE") (cons -4 "<and") (cons 0 "POLYLINE") (cons -4 "<or") (cons 70 8) (cons 70 9) (cons 70 0) (cons 70 1) (cons 70 128) (cons 70 129) (cons -4 "or>") (cons -4 "and>") (cons -4 "<and") (cons 0 "LWPOLYLINE") (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>") (cons -4 "and>") (cons -4 "or>")))) (foreach en (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex sspl))) (addToDict en) ) ) (initget 1) (setq startp (getpoint "\nPick or specify Start Point : ")) (initget 1) (setq endp (getpoint "\nPick or specify End Point : ")) (setq openlst (list (list startp (list 0.0 0.0 0.0) 0.0 (distance startp endp)))) (vla-startundomark acdoc) (setq ti (getvar (quote millisecs))) (while (and openlst (not found)) (setq node (car openlst)) (if (equal (car node) endp 1e-4) (setq found t closelst (cons node closelst)) (setq closelst (cons node closelst) openlst (upd_openlst node endp (cdr openlst) closelst)) ) ) (if found (if (vl-some (function (lambda (x) (not (equal (last x) 0.0 1e-4)))) (setq path (get_path closelst))) (setq e (f3Dpol path Pathcol)) (setq e (mk_lwp path)) ) (alert "No path was found...") ) (princ (strcat "\nExecution time : " (itoa (- (getvar (quote millisecs)) ti)) " milliseconds...")) (*error* nil) ) HTH. Regards, M.R.

Hi Nikon. I'm not sure what you're asking?

Your txt file does not have a uniform format You should fix that first.

Hello everyone. It's been a long time since I first visited this forum, but I didn't register until recently. Perhaps it's because of some interesting topics I've seen here lately Regarding this previous post, I think I finally understand: the path returned by the code isn't the shortest in this drawing. What's going on here? Is this one of the cases where A* can escape? Or is it a bug in the code? Thank you so much for being here and sharing your time and knowledge

I forgot to include the creation of the 3D polyline. This last code creates the path in 2D or 3D as needed. ;; Pathfinding with the A* algorithm by ymg 22/07/2024 ; ;; ; ;; Revised a prog by HELMUT SCHRÖDER - heschr@gmx.de - 2014-09-14 ; ;; found at Cadtutor.net ; ;; ; ;; Kept the same format for edges list but added lines as valid choice ; ;; Format: (((x1 y1) (x2 y2)) (((x2 y2) (x3 y3))....(xn yn))) ; ;; ; ;; The user is asked to pick a start and an endpoint. ; ;; The program will find the shortest path in a network of connected ; ;; polylines and/or lines and draw a new polyline representing the result. ; ;; ; ;; Two lists of nodes openlst and closelst are created from the above ; ;; mentionned edges list. The format of a node list is: ; ;; (((Point) (Prev Point) Cumulated_Distance Estimated_Total_Distance)...) ; ;; ; ;; Main change from origina are: ; ;; - cons the list instead of append ; ;; - vl-sort the openlist instead of the quicksort ; ;; - Replaced and renamed some vars and subroutine. ; ;; - Added fuzz 1e-4 to all points comparison ; ;; - Change the get_path function ; ;; - Added line as possible edges ; ;; - Added an error handler ; ;; - Added a timer to the search portion of the program ; ;; ; ;; The above changes amounted to an acceleration of about 4x from the ; ;; original program. ; ;; : ;; If you compile this program to a .fas you'll get more than 10x faster. ; ;; ; ;| Added or revised code by GLAVCVS (january 2026) -All set are grouped into one -An associative sparse matrix cell->handles is created for faster cell querying (using new 'addToDict' and 'getCell' functions) -The "edges" list is replaced with the local search retourned by 'getCell' T E S T S ===== fas: 4-5 x faster than previous fas lsp: 7-8 x faster than previous lsp |; (defun c:A* (/ sspl i edges startp endp openlst closelst found acdoc Edgelay Pathlay Pathcol Pathlwt lstClvs path ) (vl-load-com) ; Changes values of following 4 global variables to suit your need. ; (setq Edgelay "0" Pathlay "0" Pathcol 1 ; 1=Red 2=Yellow etc. ; Pathlwt 70 ; lineweight for path 0.7mm ; ) (or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object))) ) (set_errhandler '("CLAYER" "OSMODE" "CMDECHO")) (setvar 'CMDECHO 0) (setvar 'OSMODE 1) ;;; (if (setq ;;; ssp (ssget '"X" (list (cons 0 "LWPOLYLINE") (cons 8 Edgelay))) ;;; ) ;;; (foreach en (mapcar (function cadr) (ssnamex ssp)) ;;; (addToDict en) ;;; (setq edges (append edges (mk_edge (listpol2d en)))) ;;; ) ;;; nil ;;; ) ;;; ;;; (if (setq ssl (ssget '"X" (list (cons 0 "LINE") (cons 8 Edgelay)))) ;;; (foreach en (mapcar (function cadr) (ssnamex ssl)) ;;; (setq edges (cons (list (butlast (vlax-curve-getstartpoint en)) ;;; (butlast (vlax-curve-getendpoint en)) ;;; ) ;;; edges ;;; ) ;;; ) ;;; ) ;;; ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS (if (setq sspl (ssget "X" (list '(0 . "*LINE") (cons 8 EdgeLay)))) (foreach en (mapcar (function cadr) (ssnamex sspl)) (addToDict en) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq startp (getpoint "\nPick Start Point: ") ; Startpoint ; endp (getpoint "\nPick End Point: ") ; Endpoint ; openlst (list (list startp '(0 0 0) 0.0 (distance startp endp))) ; Add starting node to openlst ; ) (vla-startundomark acdoc) (setq ti (getvar 'MILLISECS)) (while (and openlst (not found)) (setq node (car openlst)); coge el primero (el que más progresa) (if (equal (car node) endp 1e-4) (setq found T closelst (cons node closelst) ) (setq closelst (cons node closelst) openlst (upd_openlst edges node endp (cdr openlst) closelst) ) ) ) (if found (if (vl-some '(lambda(x) (not (equal (last x) 0.0 1e-3))) (setq path (get_path closelst))) (f3Dpol path Pathcol) (mk_lwp path) ) (alert "No path was found") ) (princ (strcat "\nExecution time:" (itoa (- (getvar 'MILLISECS) ti)) " milliseconds." ) ) (*error* nil) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS ;;;Create dictionary ;;;[Modified to consider all segments within any polyline] (defun addToDict (en / p1 p2 id clv i l c a) (setq i -1 id (cdr (assoc 5 (setq l (entget en)))) c (= (cdr (assoc 0 l)) "LINE") a 10) (while (setq p (if (and (setq i (1+ i)) c) (cdr (assoc (+ a i) l)) (vlax-curve-getPointAtParam en i))) (if (setq val (assoc (setq clv (strcat (itoa (fix (car p))) "-" (itoa (fix (cadr p))))) lstClvs)) (setq lstClvs (subst (append val (list (cons id i))) val lstClvs)) (setq lstClvs (cons (list clv (cons id i)) lstClvs)) ) ) ) ;;;return list cell (defun getCell (pt / clv v lr id p p0 pr par l c oc) (defun oc (c e i) (if c (cdr (assoc (+ i 10) l)) (vlax-curve-getPointAtParam e i))) (if (setq val (assoc (setq clv (strcat (itoa (fix (car pt))) "-" (itoa (fix (cadr pt))))) lstClvs)) (foreach par (cdr val) (setq e (handent (car par)) c (= (cdr (assoc 0 (setq l (entget e)))) "LINE")) (if (zerop (setq pr (cdr par))) (setq lr (cons (list (oc c e pr) (oc c e (1+ pr))) lr)) (setq lr (cons (list (oc c e (1- pr)) (setq p0 (oc c e pr))) lr) lr (if (setq p (oc c e (1+ pr))) (cons (list p0 p) lr) lr) ) ) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ; ;; upd_openlst ; ;; ; ;; Each node of the openlst is passed to this sub and we scan the edges list ; ;; to find the corresponding edges. Then both points of the edges are tested ; ;; for equality to the nodes. The fixed cost (distance) is updated and so is ; ;; the estimated total distance. Updates are first put in a temporary node. ; ;; ; ;; We then proceed to test if the temp variable is already in the closelst ; ;; and proceed to the next edge. ; ;; ; ;; If temp is true and temp is not in closelst we go to the recursive sub ; ;; in_openlst which adjust the values and return the updated openlst : ;; ; ;; Upon return we sort the openlst on smallest estimated distance ; ;; and return the openlst to the main routine ; ;; ; (defun upd_openlst (edges node endp openlst closelst / lEdges edge pt fcost p1 p2 d temp) (setq pt (car node) fcost (caddr node) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;added By GLAVCVS (setq lEdges (getCell pt)) (foreach edge lEdges (setq p1 (car edge) p2 (cadr edge) d (distance p1 p2) temp nil ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (while edges ;;; (setq p1 (caar edges) ;;; p2 (cadar edges) ;;; edges (cdr edges) ;;; d (distance p1 p2) ;;; temp nil ;;; ) ;Testing both points of an edge and building a temporary node ; (cond ((and (equal pt p1 1e-4) (not (memberfuzz p2 closelst))) (setq openlst (in_openlst (list p2 p1 (+ fcost d) (+ fcost d (distance p2 endp))) openlst)) ;;; (setq temp (list p2 p1 (+ fcost d) (+ fcost d (distance p2 endp)))) ) ((and (equal pt p2 1e-4) (not (memberfuzz p1 closelst))) (setq openlst (in_openlst (list p1 p2 (+ fcost d) (+ fcost d (distance p1 endp))) openlst)) ;;; (setq temp (list p1 p2 (+ fcost d) (+ fcost d (distance p1 endp)))) ) ) ;;; (if (and temp (not (memberfuzz (car temp) closelst))) ;;; (setq openlst (in_openlst temp openlst)) ;;; ) ) ; Keep openlist sorted on smallest Estimated Total Cost ; (vl-sort openlst (function (lambda (a b) (< (cadddr a) (cadddr b)))) ) ) ;in_lst Replaced by memberfuzz ; ;(defun in_lst (pt lst) ; (cond ; ((not lst) nil) ; ((equal pt (caar lst) 1e-4) lst) ; (T (in_lst pt (cdr lst))) ; ) ;) ; returns a new openlst with a double exchanged if cost is lower ; ;; ; (defun in_openlst (node lst) (cond ((not lst) (list node)) ((equal (car node) (caar lst) 1e-4) (if (< (cadddr node) (cadddr (car lst))) (cons node (cdr lst)) lst ) ) (T (cons (car lst) (in_openlst node (cdr lst)))) ) ) (defun in_openlst2 (node lst / s c) (setq s (splitat (caar node) lst) c (cadddr node) ) (cond ((not lst) (list node)) ((not (car s)) (cons node (cadr s))) ((not (cadr s)) (cons node (car s))) (T (if (< (cadddr node) (cadddr (cadr s))) (append (car s) (cons node (cdr s))) lst ) ) ;(T (c ns node lst)) ) ) ;; ; ;; listpol2D by ymg (Simplified a Routine by Gile Chanteau ; ;; ; ;; Parameter: en, Entity Name or Object Name of Any Type of Polyline ; ;; ; ;; Returns: List of Points in 2D WCS ; ;; ; ;; Notes: Requires butlast function for 2d points. ; ;; ; (defun listpol2d (en / i lst) (repeat (setq i (fix (1+ (vlax-curve-getEndParam en)))) (setq lst (cons (butlast (vlax-curve-getPointAtParam en (setq i (1- i)))) lst ) ) ) ) ;; ; ;; mk_edge ; ;; ; ;; From a list of consecutives points as supplied by listpol2D, ; ;; Returns a list of edges (((x1 y1)(x2 y2)) ((x2 y2)(x3 y3))...) ; ;; ; (defun mk_edge (lst) (mapcar (function (lambda (a b) (list a b))) lst (cdr lst)) ) ;; ; ;; butlast ; ;; ; ;; Returns a list without the last item ; ;; Used here mainly to change points to 2D ; ;; ; (defun butlast (lst) (reverse (cdr (reverse lst)))) ;; ; ;; get_path ; ;; ; ;; Returns The list of points of shortest path found from closelst. ; ;; ; (defun get_path (lst / path) (setq path (list (caar lst)) prev (cadar lst) lst (cdr lst) ) (while (setq lst (memberfuzz prev lst)) (setq prev (cadar lst) path (cons (caar lst) path) ) ) path ) ;; ; ;; memberfuzz by Gile Chanteau ; ;; ; ;; Modified to work with nodes list ; ;; ; (defun memberfuzz (p lst) (while (and lst (not (equal p (caar lst) 1e-4))) (setq lst (cdr lst)) ) lst ) (defun splitat (p lst / tr) (while (and lst (not (equal p (caar lst) 1e-4))) (setq tr (cons (car lst) tr) lst (cdr lst) ) ) (list (reverse tr) lst) ) (defun truncfuzz (p lst) (if (and lst (not (equal p (caar lst) 1e-4))) (cons (car lst) (truncfuzz p (cdr lst))) ) ) (defun posfuzz (p lst) (- (length lst) (length (memberfuzz p lst))) ) (defun rotleft (lst) (append (cdr lst) (list (car lst)))) (defun rotright (lst) (cons (last lst) lst)) ;Added by GLAVCVS (defun f3Dpol (pts c / doc ep ll la e x) (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)) ep (if (= 1 (getvar "CVPORT")) (vla-get-PaperSpace doc) (vla-get-ModelSpace doc)) ll (apply 'append pts) la (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length ll)))) (mapcar 'float ll)) e (vla-Add3DPoly ep la) x (vla-put-Color e c) ) ) ;; ; ;; mk_lwp ; ;; ; ;; Draw an lwpolyline given a point list ; ;; ; ;; Will be drawn on layer with color and lineweight defined by Variables ; ;; at beginnung of program. ; ;; ; (defun mk_lwp (pl) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 8 Pathlay) (cons 62 Pathcol) (cons 90 (length pl)) (cons 70 0) (cons 370 Pathlwt) ) (mapcar (function (lambda (a) (cons 10 a))) pl) ) ) ) ;; Error Handler by Elpanov Evgenyi ; (defun set_errhandler (l) (setq varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) l ) ) ) (defun *error* (msg) (mapcar 'eval varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) ) (princ (strcat "\nError: " msg)) ) (vla-endundomark acdoc) (princ) )

@marko_ribar The 3d is a nice addition, but the general case is 2d in the context of graph. Your suggestion for the filter is indeed more robust. ymg

I agree with ymg and thanks for improvement ab Dictionary... Nevertheless, IMHO the general case is to perform A* with 3D entities, so 3D polyline is my preferable result... You can explode polylines, select LINES in 2D, or 3D and perform A*; with my version you'll get 3D POLYLINE, after which you can just COPYBASE it with 0,0,0 base and put it into clipboard... Then, do several UNDO until before you exploded anything... Finally, you PASTECLIP with 0,0,0 from clipboard and if network was 3D, then 3D POLYLINE should be just fine, and if network was 2D, you explode 3D POLYLINE into LINE segments, and just do JOIN command on Previous selection - you'll get LWPOLYLINE to which you should just manually adjust lineweight... That's all, simple and unexaustive procedure... BTW., your filter '(0 . "*LINE") in acquirying selection sspl also involves SPLINE entities, for which A* isn't adequate... Perhaps, you should do it with '(0 . "LINE,LWPOLYLINE,POLYLINE") as proper filter... Little robust, but appropriate...

@GLAVCVS Now you know why I had two different selection set for lines and polylines. ymg

It's an honor to know you find it useful. I have some of your excellent code and use it often ("c:TIN", for example) because, quite simply, no one has done anything better yet.

I think I understand the problem now. But it only happens with lines. With polylines, whether 3D or not, this doesn't happen. The issue is that "getPointAtParam" doesn't work the same way with lines as it does with polylines. If param=1, it doesn't return the expected result. I've modified the code to fix this (I think) ;; Pathfinding with the A* algorithm by ymg 22/07/2024 ; ;; ; ;; Revised a prog by HELMUT SCHRÖDER - heschr@gmx.de - 2014-09-14 ; ;; found at Cadtutor.net ; ;; ; ;; Kept the same format for edges list but added lines as valid choice ; ;; Format: (((x1 y1) (x2 y2)) (((x2 y2) (x3 y3))....(xn yn))) ; ;; ; ;; The user is asked to pick a start and an endpoint. ; ;; The program will find the shortest path in a network of connected ; ;; polylines and/or lines and draw a new polyline representing the result. ; ;; ; ;; Two lists of nodes openlst and closelst are created from the above ; ;; mentionned edges list. The format of a node list is: ; ;; (((Point) (Prev Point) Cumulated_Distance Estimated_Total_Distance)...) ; ;; ; ;; Main change from origina are: ; ;; - cons the list instead of append ; ;; - vl-sort the openlist instead of the quicksort ; ;; - Replaced and renamed some vars and subroutine. ; ;; - Added fuzz 1e-4 to all points comparison ; ;; - Change the get_path function ; ;; - Added line as possible edges ; ;; - Added an error handler ; ;; - Added a timer to the search portion of the program ; ;; ; ;; The above changes amounted to an acceleration of about 4x from the ; ;; original program. ; ;; : ;; If you compile this program to a .fas you'll get more than 10x faster. ; ;; ; ;| Added or revised code by GLAVCVS (january 2026) -All set are grouped into one -An associative sparse matrix cell->handles is created for faster cell querying (using new 'addToDict' and 'getCell' functions) -The "edges" list is replaced with the local search retourned by 'getCell' T E S T S ===== fas: 4-5 x faster than previous fas lsp: 7-8 x faster than previous lsp |; (defun c:A* (/ sspl i edges startp endp openlst closelst found acdoc Edgelay Pathlay Pathcol Pathlwt lstClvs ) (vl-load-com) ; Changes values of following 4 global variables to suit your need. ; (setq Edgelay "0" Pathlay "0" Pathcol 1 ; 1=Red 2=Yellow etc. ; Pathlwt 70 ; lineweight for path 0.7mm ; ) (or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object))) ) (set_errhandler '("CLAYER" "OSMODE" "CMDECHO")) (setvar 'CMDECHO 0) (setvar 'OSMODE 1) ;;; (if (setq ;;; ssp (ssget '"X" (list (cons 0 "LWPOLYLINE") (cons 8 Edgelay))) ;;; ) ;;; (foreach en (mapcar (function cadr) (ssnamex ssp)) ;;; (addToDict en) ;;; (setq edges (append edges (mk_edge (listpol2d en)))) ;;; ) ;;; nil ;;; ) ;;; ;;; (if (setq ssl (ssget '"X" (list (cons 0 "LINE") (cons 8 Edgelay)))) ;;; (foreach en (mapcar (function cadr) (ssnamex ssl)) ;;; (setq edges (cons (list (butlast (vlax-curve-getstartpoint en)) ;;; (butlast (vlax-curve-getendpoint en)) ;;; ) ;;; edges ;;; ) ;;; ) ;;; ) ;;; ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS (prompt "\rWait...\n") (vla-update (vlax-get-acad-object)) (if (setq sspl (ssget "X" (list '(0 . "*LINE") (cons 8 EdgeLay)))) (foreach en (mapcar (function cadr) (ssnamex sspl)) (addToDict en) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq startp (butlast (getpoint "\nPick Start Point: ")) ; Startpoint - reduced to 2D ; endp (butlast (getpoint "\nPick End Point: ")) ; Endpoint - reduced to 2D ; openlst (list (list startp '(0 0) 0.0 (distance startp endp))) ; Add starting node to openlst ; ) (vla-startundomark acdoc) (setq ti (getvar 'MILLISECS)) (while (and openlst (not found)) (setq node (car openlst)) (if (equal (car node) endp 1e-4) (setq found T closelst (cons node closelst) ) (setq closelst (cons node closelst) openlst (upd_openlst edges node endp (cdr openlst) closelst) ) ) ) (if found (mk_lwp (get_path closelst)) (alert "No path was found") ) (princ (strcat "\nExecution time:" (itoa (- (getvar 'MILLISECS) ti)) " milliseconds." ) ) (*error* nil) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS ;;;Create dictionary (defun addToDict (en / p1 p2 id clv i l c a) (setq i -1 id (cdr (assoc 5 (setq l (entget en)))) c (= (cdr (assoc 0 l)) "LINE") a 10) (while (setq p (if (and (setq i (1+ i)) c) (cdr (assoc (+ a i) l)) (vlax-curve-getPointAtParam en i))) (if (setq val (assoc (setq clv (strcat (itoa (fix (car p))) "-" (itoa (fix (cadr p))))) lstClvs)) (setq lstClvs (subst (append val (list (cons id i))) val lstClvs)) (setq lstClvs (cons (list clv (cons id i)) lstClvs)) ) ) ) ;;;return list cell (defun getCell (pt / clv v lr id p p0 pr par l c oc) (defun oc (c e i) (if c (cdr (assoc (+ i 10) l)) (vlax-curve-getPointAtParam e i))) (if (setq val (assoc (setq clv (strcat (itoa (fix (car pt))) "-" (itoa (fix (cadr pt))))) lstClvs)) (foreach par (cdr val) (setq e (handent (car par)) c (= (cdr (assoc 0 (setq l (entget e)))) "LINE")) (if (zerop (setq pr (cdr par))) (setq lr (cons (list (butlast (oc c e pr)) (butlast (oc c e (1+ pr)))) lr)) (setq lr (cons (list (butlast (oc c e (1- pr))) (setq p0 (butlast (oc c e pr)))) lr) lr (if (setq p (oc c e (1+ pr))) (cons (list p0 (butlast p)) lr) lr) ) ) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ; ;; upd_openlst ; ;; ; ;; Each node of the openlst is passed to this sub and we scan the edges list ; ;; to find the corresponding edges. Then both points of the edges are tested ; ;; for equality to the nodes. The fixed cost (distance) is updated and so is ; ;; the estimated total distance. Updates are first put in a temporary node. ; ;; ; ;; We then proceed to test if the temp variable is already in the closelst ; ;; and proceed to the next edge. ; ;; ; ;; If temp is true and temp is not in closelst we go to the recursive sub ; ;; in_openlst which adjust the values and return the updated openlst : ;; ; ;; Upon return we sort the openlst on smallest estimated distance ; ;; and return the openlst to the main routine ; ;; ; (defun upd_openlst (edges node endp openlst closelst / lEdges edge pt fcost p1 p2 d temp) (setq pt (car node) fcost (caddr node) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;added By GLAVCVS (setq lEdges (getCell pt)) (foreach edge lEdges (setq p1 (car edge) p2 (cadr edge) d (distance p1 p2) temp nil ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (while edges ;;; (setq p1 (caar edges) ;;; p2 (cadar edges) ;;; edges (cdr edges) ;;; d (distance p1 p2) ;;; temp nil ;;; ) ;Testing both points of an edge and building a temporary node ; (cond ((equal pt p1 1e-4) (setq temp (list p2 p1 (+ fcost d) (+ fcost d (distance p2 endp)))) ) ((equal pt p2 1e-4) (setq temp (list p1 p2 (+ fcost d) (+ fcost d (distance p1 endp))) ) ) ) (if (and temp (not (memberfuzz (car temp) closelst))) (setq openlst (in_openlst temp openlst)) ) ) ; Keep openlist sorted on smallest Estimated Total Cost ; (vl-sort openlst (function (lambda (a b) (< (cadddr a) (cadddr b)))) ) ) ;in_lst Replaced by memberfuzz ; ;(defun in_lst (pt lst) ; (cond ; ((not lst) nil) ; ((equal pt (caar lst) 1e-4) lst) ; (T (in_lst pt (cdr lst))) ; ) ;) ; returns a new openlst with a double exchanged if cost is lower ; ;; ; (defun in_openlst (node lst) (cond ((not lst) (list node)) ((equal (car node) (caar lst) 1e-4) (if (< (cadddr node) (cadddr (car lst))) (cons node (cdr lst)) lst ) ) (T (cons (car lst) (in_openlst node (cdr lst)))) ) ) (defun in_openlst2 (node lst / s c) (setq s (splitat (caar node) lst) c (cadddr node) ) (cond ((not lst) (list node)) ((not (car s)) (cons node (cadr s))) ((not (cadr s)) (cons node (car s))) (T (if (< (cadddr node) (cadddr (cadr s))) (append (car s) (cons node (cdr s))) lst ) ) ;(T (c ns node lst)) ) ) ;; ; ;; listpol2D by ymg (Simplified a Routine by Gile Chanteau ; ;; ; ;; Parameter: en, Entity Name or Object Name of Any Type of Polyline ; ;; ; ;; Returns: List of Points in 2D WCS ; ;; ; ;; Notes: Requires butlast function for 2d points. ; ;; ; (defun listpol2d (en / i lst) (repeat (setq i (fix (1+ (vlax-curve-getEndParam en)))) (setq lst (cons (butlast (vlax-curve-getPointAtParam en (setq i (1- i)))) lst ) ) ) ) ;; ; ;; mk_edge ; ;; ; ;; From a list of consecutives points as supplied by listpol2D, ; ;; Returns a list of edges (((x1 y1)(x2 y2)) ((x2 y2)(x3 y3))...) ; ;; ; (defun mk_edge (lst) (mapcar (function (lambda (a b) (list a b))) lst (cdr lst)) ) ;; ; ;; butlast ; ;; ; ;; Returns a list without the last item ; ;; Used here mainly to change points to 2D ; ;; ; (defun butlast (lst) (reverse (cdr (reverse lst)))) ;; ; ;; get_path ; ;; ; ;; Returns The list of points of shortest path found from closelst. ; ;; ; (defun get_path (lst / path) (setq path (list (caar lst)) prev (cadar lst) lst (cdr lst) ) (while (setq lst (memberfuzz prev lst)) (setq prev (cadar lst) path (cons (caar lst) path) ) ) path ) ;; ; ;; memberfuzz by Gile Chanteau ; ;; ; ;; Modified to work with nodes list ; ;; ; (defun memberfuzz (p lst) (while (and lst (not (equal p (caar lst) 1e-4))) (setq lst (cdr lst)) ) lst ) (defun splitat (p lst / tr) (while (and lst (not (equal p (caar lst) 1e-4))) (setq tr (cons (car lst) tr) lst (cdr lst) ) ) (list (reverse tr) lst) ) (defun truncfuzz (p lst) (if (and lst (not (equal p (caar lst) 1e-4))) (cons (car lst) (truncfuzz p (cdr lst))) ) ) (defun posfuzz (p lst) (- (length lst) (length (memberfuzz p lst))) ) (defun rotleft (lst) (append (cdr lst) (list (car lst)))) (defun rotright (lst) (cons (last lst) (butlast lst))) ;; ; ;; mk_lwp ; ;; ; ;; Draw an lwpolyline given a point list ; ;; ; ;; Will be drawn on layer with color and lineweight defined by Variables ; ;; at beginnung of program. ; ;; ; (defun mk_lwp (pl) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 8 Pathlay) (cons 62 Pathcol) (cons 90 (length pl)) (cons 70 0) (cons 370 Pathlwt) ) (mapcar (function (lambda (a) (cons 10 a))) pl) ) ) ) ;; Error Handler by Elpanov Evgenyi ; (defun set_errhandler (l) (setq varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) l ) ) ) (defun *error* (msg) (mapcar 'eval varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) ) (princ (strcat "\nError: " msg)) ) (vla-endundomark acdoc) (princ) )

Marko, the point about @GLAVCVS is the use of a dictionnary to accelerate access to the edges and it is brilliant. As for 3D we all know that it can be extended to it. Dictionnaries in this context acts just like a hash table and is technique that I had overlooked for far too long and on which I am currently exploring further. Once again Thanks @GLAVCVS