Jump to content

Auto Route and Show Lenght all branch of tree line

HOang6893

By HOang6893
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

HOang6893 Rookie

HOang6893

Posted
Posted (edited)

Hello experts.
I am looking for a solution to my problem.
My work involves lengthwise mass dissection on a plane.
On the plane I have main lines (Cable Trucking), you imagine it is a tree, consisting of trunk, main branches and sub-branches.
I am trying to search the forum and have found some solutions but not completely solved my problem.
Hope you can help me to solve this problem. Thank you.

Inquiry. Find the length of all branches to the origin, showing the length at the end of each branch. (end of each branch can be block, circle, or nothing, lines can be line and polyline)

I have attached the data path including: drawing and some lisp I found.

Once again, thank you very much for your support.

https://lcies-my.sharepoint.com/:f:/g/personal/hoang_m_lyoffice_net/Eq__Xnx_urpOmUdHYe4XHSUB-Y_2bA-X-1eAXdyQCcKufQ?e=5Twv8H

ARL.lsp Drawing1.dwg shortlinespath.lsp

Edited by HOang6893
marko_ribar Veteran

marko_ribar

Posted
Posted

Here is something I cobbled, but if you really need it working, you'll have to debug it further...

Regards...

  

(defun c:treelengths ( / *error* picknode process processtree maketree cmd ucsf bp ss i e el elst slst lst s tree len q enx )

  (vl-load-com)

  (defun *error* ( m )
    (if ucsf
      (if command-s
        (command-s "_.UCS" "_P")
        (vl-cmdf "_.UCS" "_P")
      )
    )
    (if command-s
      (command-s "_.UNDO" "_E")
      (vl-cmdf "_.UNDO" "_E")
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun picknode ( e / s )
    (if
      (and
        e
        (setq s (ssget "_C" (mapcar (function +) (list -1e-3 -1e-3) (trans (cadadr e) 0 1)) (mapcar (function +) (list 1e-3 1e-3) (trans (cadadr e) 0 1))))
        (ssdel (car e) s)
        (> (sslength s) 0)
      )
      s
    )
  )

  (defun process ( s e / ee )
    (setq ee (vl-remove-if-not (function (lambda ( x ) (ssmemb (car x) s))) lst))
    (setq ee (mapcar (function (lambda ( x ) (list (car x) (if (equal (caadr x) (cadadr e) 1e-6) (list (caadr x) (cadadr x)) (list (cadadr x) (caadr x)))))) ee))
    (if
      (and
        ee
        (setq s (picknode (car ee)))
      )
      (progn
        (setq tree (cons (car ee) tree))
        (process s (car ee))
      )
      (if ee
        (setq tree (cons (car ee) tree))
      )
    )
  )

  (defun processtree nil
    (setq re (cons (caar tree) re))
    (setq tree (cdr tree))
    (if
      (and
        (setq s (picknode (car tree)))
        (foreach w re
          (ssdel w s)
        )
        (> (sslength s) 0)
      )
      (process s (car tree))
      (processtree)
    )
  )

  (defun maketree ( q )
    (setq len (apply (function +) (mapcar (function (lambda ( x ) (vlax-curve-getdistatparam (car x) (vlax-curve-getendparam (car x))))) tree)))
    (entmake
      (list
        (cons 0 "TEXT")
        (cons 100 "AcDbEntity")
        (cons 100 "AcDbText")
        (cons 10 (polar (cadadr (car tree)) (* -0.5 pi) (if (/= (getvar (quote textsize)) 0.0) (getvar  (quote textsize)) (* 10.0 (/ (getvar (quote viewsize)) (cadr (getvar (quote screensize))))))))
        (cons 1 (rtos len 2 8))
        (cons 40 (if (/= (getvar (quote textsize)) 0.0) (getvar (quote textsize)) (* 10.0 (/ (getvar (quote viewsize)) (cadr (getvar (quote screensize)))))))
        (cons 50 0.0)
        (cons 62 q)
        (list 210 0.0 0.0 1.0)
      )
    )
    (setq el (entlast))
    (foreach e (mapcar (function car) tree)
      (vla-copy (vlax-ename->vla-object e))
    )
    (setq s (ssadd))
    (while (setq el (entnext el))
      (ssadd el s)
    )
    (setq el (entlast))
    (vl-cmdf "_.JOIN" s "")
    (if (not (eq el (entlast)))
      (if (assoc 62 (setq enx (entget (entlast))))
        (entupd (cdr (assoc -1 (entmod (subst (cons 62 q) (assoc 62 enx) enx)))))
        (entupd (cdr (assoc -1 (entmod (append enx (list (cons 62 q)))))))
      )
      (if (assoc 62 (setq enx (entget (ssname s 0))))
        (entupd (cdr (assoc -1 (entmod (subst (cons 62 q) (assoc 62 enx) enx)))))
        (entupd (cdr (assoc -1 (entmod (append enx (list (cons 62 q)))))))
      )
    )
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.UNDO" "_E")
  )
  (vl-cmdf "_.UNDO" "_G")
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (vl-cmdf "_.UCS" "_W")
      (setq ucsf t)
    )
  )
  (if (setq bp (getpoint "\nPick or specify base point : "))
    (progn
      (setq ss (ssget "_X" (list (cons 0 "*POLYLINE,LINE,ARC,SPLINE,ELLIPSE,HELIX") (cons 410 (if (= (getvar (quote cvport)) 1) (getvar (quote ctab)) "Model")))))
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (setq el (entlast))
        (if e
          (cond
            ( (wcmatch (cdr (assoc 0 (entget e))) "*POLYLINE")
              (vl-cmdf "_.EXPLODE" e)
              (while (setq el (entnext el))
                (vl-cmdf "_.PEDIT" el "")
                (setq elst (cons (if (and el (not (vlax-erased-p el)) (= (cdr (assoc 0 (entget el))) "LWPOLYLINE")) el (entlast)) elst))
              )
            )
            ( (wcmatch (cdr (assoc 0 (entget e))) "LINE,ARC")
              (vl-cmdf "_.PEDIT" e "")
              (setq elst (cons (if (and e (not (vlax-erased-p e)) (= (cdr (assoc 0 (entget e))) "LWPOLYLINE")) e (entlast)) elst))
            )
            ( (wcmatch (cdr (assoc 0 (entget e))) "SPLINE,ELLIPSE,HELIX")
              (setq slst (cons e slst))
            )
          )
        )
      )
      (setq lst (append elst slst))
      (setq lst (mapcar (function (lambda ( x ) (list x (list (vlax-curve-getstartpoint x) (vlax-curve-getendpoint x))))) lst))
      (setq e (car (vl-remove-if (function (lambda ( x ) (not (or (equal (trans bp 1 0) (caadr x) 1e-6) (equal (trans bp 1 0) (cadadr x) 1e-6))))) lst)))
      (setq e (list (car e) (if (equal (trans bp 1 0) (caadr e) 1e-6) (list (caadr e) (cadadr e)) (list (cadadr e) (caadr e)))))
      (setq tree (cons e tree))
      (if (setq s (picknode e))
        (process s e)
      )
      (while (not (equal otree tree 1e-6))
        (setq q (if (not q) 1 (1+ q)))
        (setq otree tree)
        (processtree)
        (maketree q)
      )
    )
  )
  (*error* nil)
)

 

  • Like 1
HOang6893 Rookie

HOang6893

Posted
  • Author
Posted (edited)
7 hours ago, marko_ribar said:

Here is something I cobbled, but if you really need it working, you'll have to debug it further...

Regards...

  

(defun c:treelengths ( / *error* picknode process processtree maketree cmd ucsf bp ss i e el elst slst lst s tree len q enx )

  (vl-load-com)

  (defun *error* ( m )
    (if ucsf
      (if command-s
        (command-s "_.UCS" "_P")
        (vl-cmdf "_.UCS" "_P")
      )
    )
    (if command-s
      (command-s "_.UNDO" "_E")
      (vl-cmdf "_.UNDO" "_E")
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun picknode ( e / s )
    (if
      (and
        e
        (setq s (ssget "_C" (mapcar (function +) (list -1e-3 -1e-3) (trans (cadadr e) 0 1)) (mapcar (function +) (list 1e-3 1e-3) (trans (cadadr e) 0 1))))
        (ssdel (car e) s)
        (> (sslength s) 0)
      )
      s
    )
  )

  (defun process ( s e / ee )
    (setq ee (vl-remove-if-not (function (lambda ( x ) (ssmemb (car x) s))) lst))
    (setq ee (mapcar (function (lambda ( x ) (list (car x) (if (equal (caadr x) (cadadr e) 1e-6) (list (caadr x) (cadadr x)) (list (cadadr x) (caadr x)))))) ee))
    (if
      (and
        ee
        (setq s (picknode (car ee)))
      )
      (progn
        (setq tree (cons (car ee) tree))
        (process s (car ee))
      )
      (if ee
        (setq tree (cons (car ee) tree))
      )
    )
  )

  (defun processtree nil
    (setq re (cons (caar tree) re))
    (setq tree (cdr tree))
    (if
      (and
        (setq s (picknode (car tree)))
        (foreach w re
          (ssdel w s)
        )
        (> (sslength s) 0)
      )
      (process s (car tree))
      (processtree)
    )
  )

  (defun maketree ( q )
    (setq len (apply (function +) (mapcar (function (lambda ( x ) (vlax-curve-getdistatparam (car x) (vlax-curve-getendparam (car x))))) tree)))
    (entmake
      (list
        (cons 0 "TEXT")
        (cons 100 "AcDbEntity")
        (cons 100 "AcDbText")
        (cons 10 (polar (cadadr (car tree)) (* -0.5 pi) (if (/= (getvar (quote textsize)) 0.0) (getvar  (quote textsize)) (* 10.0 (/ (getvar (quote viewsize)) (cadr (getvar (quote screensize))))))))
        (cons 1 (rtos len 2 8))
        (cons 40 (if (/= (getvar (quote textsize)) 0.0) (getvar (quote textsize)) (* 10.0 (/ (getvar (quote viewsize)) (cadr (getvar (quote screensize)))))))
        (cons 50 0.0)
        (cons 62 q)
        (list 210 0.0 0.0 1.0)
      )
    )
    (setq el (entlast))
    (foreach e (mapcar (function car) tree)
      (vla-copy (vlax-ename->vla-object e))
    )
    (setq s (ssadd))
    (while (setq el (entnext el))
      (ssadd el s)
    )
    (setq el (entlast))
    (vl-cmdf "_.JOIN" s "")
    (if (not (eq el (entlast)))
      (if (assoc 62 (setq enx (entget (entlast))))
        (entupd (cdr (assoc -1 (entmod (subst (cons 62 q) (assoc 62 enx) enx)))))
        (entupd (cdr (assoc -1 (entmod (append enx (list (cons 62 q)))))))
      )
      (if (assoc 62 (setq enx (entget (ssname s 0))))
        (entupd (cdr (assoc -1 (entmod (subst (cons 62 q) (assoc 62 enx) enx)))))
        (entupd (cdr (assoc -1 (entmod (append enx (list (cons 62 q)))))))
      )
    )
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.UNDO" "_E")
  )
  (vl-cmdf "_.UNDO" "_G")
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (vl-cmdf "_.UCS" "_W")
      (setq ucsf t)
    )
  )
  (if (setq bp (getpoint "\nPick or specify base point : "))
    (progn
      (setq ss (ssget "_X" (list (cons 0 "*POLYLINE,LINE,ARC,SPLINE,ELLIPSE,HELIX") (cons 410 (if (= (getvar (quote cvport)) 1) (getvar (quote ctab)) "Model")))))
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (setq el (entlast))
        (if e
          (cond
            ( (wcmatch (cdr (assoc 0 (entget e))) "*POLYLINE")
              (vl-cmdf "_.EXPLODE" e)
              (while (setq el (entnext el))
                (vl-cmdf "_.PEDIT" el "")
                (setq elst (cons (if (and el (not (vlax-erased-p el)) (= (cdr (assoc 0 (entget el))) "LWPOLYLINE")) el (entlast)) elst))
              )
            )
            ( (wcmatch (cdr (assoc 0 (entget e))) "LINE,ARC")
              (vl-cmdf "_.PEDIT" e "")
              (setq elst (cons (if (and e (not (vlax-erased-p e)) (= (cdr (assoc 0 (entget e))) "LWPOLYLINE")) e (entlast)) elst))
            )
            ( (wcmatch (cdr (assoc 0 (entget e))) "SPLINE,ELLIPSE,HELIX")
              (setq slst (cons e slst))
            )
          )
        )
      )
      (setq lst (append elst slst))
      (setq lst (mapcar (function (lambda ( x ) (list x (list (vlax-curve-getstartpoint x) (vlax-curve-getendpoint x))))) lst))
      (setq e (car (vl-remove-if (function (lambda ( x ) (not (or (equal (trans bp 1 0) (caadr x) 1e-6) (equal (trans bp 1 0) (cadadr x) 1e-6))))) lst)))
      (setq e (list (car e) (if (equal (trans bp 1 0) (caadr e) 1e-6) (list (caadr e) (cadadr e)) (list (cadadr e) (caadr e)))))
      (setq tree (cons e tree))
      (if (setq s (picknode e))
        (process s e)
      )
      (while (not (equal otree tree 1e-6))
        (setq q (if (not q) 1 (1+ q)))
        (setq otree tree)
        (processtree)
        (maketree q)
      )
    )
  )
  (*error* nil)
)

 

Thanks marko_ribar.
I find that the problem I am facing will have a lot of people also need it to shorten their working process. This LISP can help a lot of people once it is completed.
I have studied many programming languages, but unfortunately to get started with the language of LISP I will need some more time to understand and use the programming language fluently.
I came up with an algorithm to solve this problem but I can't implement it with LISP language.

- Algorithm:
1. Here I will use all lines which are straight line type.
2. I will define each sub-branch on the mainline
3. Check the start and end points of each line to determine how many lines are in the same coordinates (intersection). From there we determine how many branches that intersection point has.
4. Define a unique start and end point, from which we get the start and end of each branch.
5. Duplicate intersection points are defined to find the path for the endpoint and base.
6. Determine the length through the sum of the lengths of the line segments that the polyline passes from the origin to the end.

So can you or someone help me to complete this LISP?
Thanks you very much.

Drawing1.dwg

Edited by HOang6893
HOang6893 Rookie

HOang6893

Posted
  • Author
Posted
24 minutes ago, Tsuky said:

If you have lines, change before all lines in polylines (PEDIT Multiple), you can try this...

 

 

PATH_LENGTH.lsp 11.21 kB · 1 download

 

Thank you very much Tsuki.

 

Your Lisp works perfectly.
I hope others will find this post and find a solution to the problem of length mass statistics on the ground.

Your Lisp will definitely help a lot of people. And right now it's me and my colleagues. Thank you !!!

  • 2 weeks later...
marko_ribar Veteran

marko_ribar

Posted
Posted

Hi, @Tsuky
This line :
(setq lst_pt_ori (mapcar '(lambda (x) (trans x e_name 0)) (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget e_name)))))

Should actually be :
(setq lst_pt_ori (mapcar '(lambda (x) (trans (append x (list (cdr (assoc 38 (entget e_name))))) e_name 0)) (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget e_name)))))


Watch this procedure with LWPOLYLINE in 3D random orientation to see where your mistake was...

: (setq pl (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget (car (entsel))))))
Select entity: ((309.891999145573 122.498580705648) (264.933323771937 74.1796661002057) (315.368166401738 7.00581219180498) (372.810192377193 30.3384856741801) (512.820513041014 -23.4863237320238))
: (setq ple (mapcar '(lambda (x) (or ex (setq ex (entget (car (entsel))))) (append x (list (cdr (assoc 38 ex))))) pl))
Select entity: ((309.891999145573 122.498580705648 -45.829951430496) (264.933323771937 74.1796661002057 -45.829951430496) (315.368166401738 7.00581219180498 -45.829951430496) (372.810192377193 30.3384856741801 -45.829951430496) (512.820513041014 -23.4863237320238 -45.829951430496))
: (setq st (trans (car ple) (car (entsel)) 0))
Select entity: (274.278206553488 191.937921055429 32.7206009752506)
: (vlax-curve-getstartpoint (car (entsel)))
Select entity: (274.278206553488 191.937921055429 32.7206009752506)

Tsuky Community Regular

Tsuky

Posted
Posted

Hi Marko,

You're right, I forgot to address the possible elevation of lightweight polylines.
Although I think it does not influence the result on the total length...
Anyway I am completely reviewing the code (in my spare time) whether for this request or the iso-distances because I find the subject interesting.
Indeed I realized that in a complex network; my code fails.
The cause is that I exceed the number of allowed selection sets. So I plan to approach the problem from another angle by avoiding going through selection sets.
If I get to my end (I don't know when!) I will follow up on these topics or create a new one.

marko_ribar Veteran

marko_ribar

Posted
Posted (edited)
19 hours ago, Tsuky said:

Hi Marko,

You're right, I forgot to address the possible elevation of lightweight polylines.
Although I think it does not influence the result on the total length...
Anyway I am completely reviewing the code (in my spare time) whether for this request or the iso-distances because I find the subject interesting.
Indeed I realized that in a complex network; my code fails.
The cause is that I exceed the number of allowed selection sets. So I plan to approach the problem from another angle by avoiding going through selection sets.
If I get to my end (I don't know when!) I will follow up on these topics or create a new one.

 

Look, there is no need to struggle too much... I've coded for this task and posted my revisions in my previous post... There is normal version and maybe better by using Djikstra algorithm incorporated into my main versions...

Edited by marko_ribar

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...