Jump to content

Name my Roads

CivilTechSource

By CivilTechSource
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

CivilTechSource Enthusiast

CivilTechSource

Posted
Posted

Hi, 

With help of AI I manage to get this lisp working. Name my Roads. Allows the user to select number of polylines and then select starting polyline (Road) and names all the rest. I would welcome any further improvements on it.

  

;;; =========================================================================
;;; USER CONFIGURATION - EDIT THESE VARIABLES EASILY
;;; =========================================================================
(setq road-text-height 2.5)          ; How tall the road number text should be
(setq road-text-layer "Road-Labels") ; The layer where the text numbers will go
(setq road-text-color 2)             ; Color index for the text numbers (2 = Yellow)

(setq road-default-prefix "Road")    ; The default name if you just press Enter

(setq error-circle-radius 5.0)       ; How big the warning circles should be
(setq error-circle-layer "Unnamed-Roads") ; Layer for roads that were skipped
(setq error-circle-color 1)          ; Color for warning circles (1 = Red)
;;; =========================================================================

(vl-load-com) ; Loads advanced geometry functions for handling polylines


(defun c:NumberRoads ( / road-ss user-prefix first-road start-point i entity)
  ;; Reset our trackers
  (setq global:road-counter 1)
  (setq global:all-roads '())
  (setq global:visited-list '())
  
  (princ "\nSelect all polylines and lines that make up the road network: ")
  (setq road-ss (ssget '((0 . "LINE,*POLYLINE"))))
  
  (if road-ss
    (progn
      ;; Convert the selection set into a clean list of entities for the algorithm
      (setq i 0)
      (while (setq entity (ssname road-ss i))
        (setq global:all-roads (cons entity global:all-roads))
        (setq i (1+ i))
      )
      
      (setq user-prefix (getstring t (strcat "\nEnter road prefix <" road-default-prefix ">: ")))

      (if (= user-prefix "")
        (setq global:road-prefix road-default-prefix)
        (setq global:road-prefix user-prefix)
      )
      
      (setq first-road (car (entsel "\nSelect the FIRST road (from your selection): ")))
      
      (setq start-point (getpoint "\nClick near the START point of the first road: "))
      
      (if (and first-road start-point)
        (progn
          ;; Start the main driving loop
          (explore-road-logic first-road start-point)
          
          ;; SCAN FOR UNNAMED ROADS: Look for any lines left behind
          (foreach entity global:all-roads
            (if (not (member entity global:visited-list))
              (action-mark-unnamed entity)
            )
          )
          
          (princ "\nRoad numbering complete! Skipped roads have been marked with red circles.")
        )
        (princ "\nMissing first road or start point selection.")
      )
    )
    (princ "\nNo roads were selected.")
  )
  (princ)
)

;;; CORE LOGIC FUNCTION
(defun explore-road-logic (current-road current-start-pt / road-num intersections intersection-info next-road next-pt)
  (setq road-num global:road-counter)
  (setq global:visited-list (cons current-road global:visited-list))
  
  (action-label-road current-road road-num)
  
  (setq intersections (helper-find-and-sort-intersections current-road current-start-pt))
  
  (foreach intersection-info intersections
    (setq next-pt (car intersection-info))
    (setq next-road (cdr intersection-info))
    
    (if (not (member next-road global:visited-list))
      (progn
        (setq global:road-counter (+ global:road-counter 1))
        (explore-road-logic next-road next-pt)
      )
    )
  )
)

;;; MTEXT CREATION FUNCTION (WITH ROTATION & READABILITY LOGIC)
(defun action-label-road (road-entity number / mid-param mid-pt deriv ang readable-ang)

  (setq mid-param (/ (vlax-curve-getEndParam road-entity) 2.0))
  (setq mid-pt (vlax-curve-getPointAtParam road-entity mid-param))
  
  (setq deriv (vlax-curve-getFirstDeriv road-entity mid-param))
  (setq ang (angle '(0 0 0) deriv)) ; Convert vector to angle in radians

  (if (and (> ang (/ pi 2.0)) (<= ang (* pi 1.5)))
    (setq readable-ang (+ ang pi)) ; Flip 180 degrees if necessary
    (setq readable-ang ang)         ; Keep original angle otherwise
  )

  (entmake (list
    '(0 . "MTEXT")
    '(100 . "AcDbEntity")
    (cons 8 road-text-layer)   ; Applies your layer
    (cons 62 road-text-color)  ; Applies your color
    '(100 . "AcDbMText")
    (cons 10 mid-pt)           ; Places text at the middle of the road
    (cons 40 road-text-height) ; Applies your text size
    (cons 50 readable-ang)     ; <--- APPLIES CALCULATED READABLE ROTATION
    '(71 . 5)                  ; Forces "Middle Center" alignment
    (cons 1 (strcat global:road-prefix " " (itoa number))) ; Text content
  ))
)

(defun action-mark-unnamed (road-entity / mid-param mid-pt)
  (setq mid-param (/ (vlax-curve-getEndParam road-entity) 2.0))
  (setq mid-pt (vlax-curve-getPointAtParam road-entity mid-param))
  (entmake (list
    '(0 . "CIRCLE")
    '(100 . "AcDbEntity")
    (cons 8 error-circle-layer)
    (cons 62 error-circle-color)
    '(100 . "AcDbCircle")
    (cons 10 mid-pt)
    (cons 40 error-circle-radius)
  ))
)

(defun helper-find-and-sort-intersections (road-entity start-pt / road-vla intersections-list current-dist-start other-vla int-points pt dist rel-dist abs-rel-dist)
  (setq road-vla (vlax-ename->vla-object road-entity))
  (setq current-dist-start (vlax-curve-getDistAtPoint road-entity start-pt))
  (if (not current-dist-start) (setq current-dist-start 0.0))
  (setq intersections-list '())
  (foreach other-entity global:all-roads
    (if (and (not (eq road-entity other-entity))
             (not (member other-entity global:visited-list)))
      (progn
        (setq other-vla (vlax-ename->vla-object other-entity))
        (setq int-points (vlax-invoke road-vla 'IntersectWith other-vla 0))
        (if int-points
          (while int-points
            (setq pt (list (car int-points) (cadr int-points) (caddr int-points)))
            (setq int-points (cdddr int-points))
            (if (vlax-curve-getDistAtPoint road-entity pt)
              (progn
                (setq dist (vlax-curve-getDistAtPoint road-entity pt))
                (setq abs-rel-dist (abs (- dist current-dist-start)))
                (if (> abs-rel-dist 0.01)
                  (setq intersections-list (cons (list abs-rel-dist pt other-entity) intersections-list))
                )
              )
            )
          )
        )
      )
    )
  )
  (setq intersections-list (vl-sort intersections-list '(lambda (a b) (< (car a) (car b)))))
  (mapcar '(lambda (x) (cons (cadr x) (caddr x))) intersections-list)
)

 

GLAVCVS Experienced

GLAVCVS

Posted
Posted (edited)

Hello.
May I make a suggestion?
Perhaps you could simplify the user prompts from this:


  (setq first-road (car (entsel "\nSelect the FIRST road (from your selection): ")))
  (setq start-point (getpoint "\nClick near the START point of the first road: "))

 

to a single prompt:


  (setq first-road (car (setq es (entsel "\nSelect the FIRST road near the START point (from your selection): ")))
            start-point (cadr es)
  )


Also, your code calculates the midpoint based on the number of vertices rather than on the actual distance along the road.
You might prefer to place the label at the geometric midpoint by replacing this:

  (setq mid-param (/ (vlax-curve-getEndParam road-entity) 2.0))

 

with this:

  (setq total-dist (vlax-curve-getDistAtParam road-entity (vlax-curve-getEndParam road-entity))
            mid-param (vlax-curve-getParamAtDist road-entity (/ total-dist 2.0))
  )

Edited by GLAVCVS
BIGAL Grand Master

BIGAL

Posted
Posted (edited)

Did not look to hard but an obvious one for me was.  

(setq road-text-layer "Road-Labels") ; The layer where the text numbers will go

If layer "Road=labels" does not exist then program will crash, IF does not exist so just "Make" the layer. In lots of code I am writing I will take advantage of a global defun that is in another preloaded lisp, it has a checklayer function.

 

This something like all you would need. 

(chklayer "Road-Label" 1 "Continous")
(setq road-text-layer "Road-Labels")

 

Agree with other post label at mid point, Using vertices can get be returned form a pline that is drawn in wrong direction than you think.

Yours 

(setq current-dist-start (vlax-curve-getDistAtPoint road-entity start-pt))

 

I have a swap or flip a pline so start direction is from end selected. But using mid solves this.

May not need this function if using mid. There is VL get coordinates that returns all the vertice XYZ.  

(defun helper-find-and-sort-intersections

(setq lst (vlax-safearray->list (vlax-variant-value (vla-get-coordinates obj))))

 

Also this for pline vertice points, thanks to lee--mac. 

(setq plent (entsel "\nPick rectang"))
(if plent (setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car plent))))))
(princ co-ord)

 

Just another idea when doing add more items to an existing drawing, do a "does the labels exist already" ? If so then get them all and find last label then add one to it. You have a layer name so can ssget MTEXT for that layer.

 

Just me I don't tend to do this, make a list of entities, then process that list. It's a personal preference 

(while (setq entity (ssname road-ss i))
        (setq global:all-roads (cons entity global:all-roads))
        (setq i (1+ i))
      )

I just act on the current entity returned by the while or a Repeat and do the labelling of that entity.

 

This is sort of double handling the SSGET if you use Pick PIck Pick method the selection set should be in the pick order 

(setq first-road (car (entsel "\nSelect the FIRST road (from your selection): ")))

Otherwise use a Pick and label method it will be fast. The label will appear as fast as you pick. Maybe even a dual method pick and window.

 

Having a bit of a look I think code can be shortened a lot.

 

Edited by BIGAL
BIGAL Grand Master

BIGAL

Posted
Posted

Had a play took a different tack, still needs some more improvements like do a search for all existing labels and return max number do that 1st. The angle returned at a pline point determines wether the label goes below or on top that needs to be looked also. But it does use a Mid point method. needs localising of variables etc. Call it version one.

  

; Label pline roads
; By CivilTechForce July 2026
; Modified by AlanH July 2026


;;; =========================================================================
;;; USER CONFIGURATION - EDIT THESE VARIABLES EASILY
;;; =========================================================================

;;; Check does layer exist
(defun chklay (layn color ltype / )
(command "-layer" "make" layn "C" color "" "LT" ltype "" "")
)

(defun alg-ang (obj pnt)
  (angle '(0. 0. 0.)
     (vlax-curve-getfirstderiv
       obj
       (vlax-curve-getparamatpoint
         obj
         pnt
       )
     )
  )
)

;;; MTEXT CREATION FUNCTION (WITH ROTATION & READABILITY LOGIC)

(defun action-label-road (road-entity number / ang readable-ang)
(setq ang (alg-ang obj mid-param))
  (if (and (> ang (/ pi 2.0)) (<= ang (* pi 1.5)))
    (setq readable-ang (+ ang pi)) ; Flip 180 degrees if necessary
    (setq readable-ang ang)         ; Keep original angle otherwise
  )
  (setq mid-param (polar mid-param (- (/ pi 2.0) ang) road-text-height))
  (entmake (list
    (cons 0 "MTEXT")
    (cons 100 "AcDbEntity")
    (cons 8 road-text-layer)   ; Applies your layer
    (cons 62 road-text-color)  ; Applies your color
    (cons 100 "AcDbMText")
    (cons 10 mid-param)        ; Places text at the middle of the road
    (cons 40 road-text-height) ; Applies your text size
    (cons 50 readable-ang)     ; <--- APPLIES CALCULATED READABLE ROTATION
    (cons 71 5)                  ; Forces "Middle Center" alignment
    (cons 1 (strcat global:road-prefix " " (itoa number))) ; Text content
    )
  )
  (setq global:road-counter (1+ global:road-counter))
  (princ)
)

;;; =========================================================================

(vl-load-com) ; Loads advanced geometry functions for handling polylines

(defun c:NumberRoads ( / road-ss user-prefix road-text-layer road-text-color road-default-prefix)
  (setq road-text-height 2.5)          ; How tall the road number text should be
  (chklay "Road-Labels" 1 "Continuous") ; Does layer exist check
  (setq road-text-layer "Road-Labels") ; The layer where the text numbers will go
  (setq road-text-color 2)             ; Color index for the text numbers (2 = Yellow)
  
  (setq road-default-prefix "Road")    ; The default name if you just press Enter
  
  (setq error-circle-radius 5.0)       ; How big the warning circles should be
  (setq error-circle-layer "Unnamed-Roads") ; Layer for roads that were skipped
  (setq error-circle-color 1)          ; Color for warning circles (1 = Red)

  (princ "\nSelect all polylines and lines that make up the road network: ")
  (setq road-ss (ssget '((0 . "LINE,*POLYLINE"))))
  
  (if road-ss
  (progn

  (setq global:road-counter (getint "\nEnter new Road profile number eg 1 "))
      
  (setq user-prefix (getstring t (strcat "\nEnter road prefix <" road-default-prefix ">: ")))
  (if (= user-prefix "")
    (setq global:road-prefix road-default-prefix)
    (setq global:road-prefix user-prefix)
  )
 
  (setq x 0)
  (while (< x (sslength road-ss))
    (setq road-entity (ssname road-ss x))
    (setq obj (vlax-ename->vla-object road-entity))
    (setq dist (/ (vlax-get obj 'length) 2.0))
    (setq mid-param (vlax-curve-getpointatdist obj dist))
    (setq lst2 '() angstep 0.785398163397448 ang2 0.0)
    (repeat 8
      (setq lst2 (cons (polar mid-param ang2 road-text-height) lst2))
      (setq lst2 (cons (last lst2) lst2))
      (setq ang2 (+ ang2 angstep))
    )
    (setq ss2 (ssget "F" lst2  (list (cons 0 "Mtext")(cons 8 road-text-layer))))
    (if ss2
      (princ "\npline already labelled")
      (action-label-road road-entity global:road-counter)
    )
    (setq x (1+ X))
  )

  ) ; progn ss
  (princ)
) ; if ss

(princ)
)

 

I am leaning towards making the input here much bigger rather than lots of setq's just set default values in the defun call. Or use a dcl to set values. 

(defun action-label-road (road-entity number / mid-param mid-pt deriv ang readable-ang)

(defun action-label-road (road-entity number road-text-layer road-text-color global:road-prefix) / mid-param mid-pt deriv ang readable-ang)

 

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...