;;; ---------------------------------------------------------------------------
;;; Chainage.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; CHAINAGE AND RUNNING DISTANCE ALONG A LINE
;;;
;;; PURPOSE
;;;   Labels how far along you are at every vertex of a polyline - the running
;;;   distance from the start, written beside each point. Roads, drains, kerb
;;;   lines, fences, cable routes, section lines: anything measured from one end.
;;;
;;;   Three ways of writing it:
;;;     Distance   a plain running length - 0, 12.5, 31.75
;;;     Station    the surveyor's form - 0+000, 1+250.000 - metric, in thousands
;;;     Imperial   the same idea in hundreds of feet - 0+00, 12+50.00
;;;
;;;   A starting chainage can be given, so a length picked up part way along a
;;;   route can be labelled with its true position rather than starting at zero.
;;;
;;; ARC SEGMENTS ARE MEASURED PROPERLY
;;;   The original added up straight-line distances between vertices. On a
;;;   polyline with any curve in it that is measuring the chord rather than the
;;;   arc, and every label after the first bend is short - increasingly so.
;;;
;;;   Distances now come from the curve itself through VLAX-CURVE-GETDISTATPARAM,
;;;   which asks AutoCAD how far along the object a point actually is. It follows
;;;   bulges exactly, and it works the same way on a line, an arc, a spline or an
;;;   ellipse, so all of those can be labelled too.
;;;
;;; WHAT WAS FIXED
;;;   - It only accepted a heavy POLYLINE. Every polyline AutoCAD has drawn by
;;;     default since Release 14 is an LWPOLYLINE, a different object type
;;;     altogether, and the routine rejected every one of them. Its own header
;;;     admitted this: "Does not work with lightweight polylines". In practice
;;;     that meant it worked on almost nothing.
;;;   - Pressing Enter rather than picking gave an endless loop. ENTSEL returns
;;;     nil, the test saw nil and asked again, and there was no way out but ESC.
;;;   - The first TEXT call was written (command "text" ...) with no underscore,
;;;     so it failed on any non-English AutoCAD. The second one, six lines later,
;;;     had the underscore.
;;;   - Five variables were global - the saved error handler and all four saved
;;;     system variables - despite a careful list of locals on every function.
;;;   - Its error handler ran (command) twice and then an UNDO, which from
;;;     AutoCAD 2015 is refused outright unless the routine declares it will do
;;;     so beforehand. The error handler failed while handling the error.
;;;   - Closed polylines lost their last segment, because the run stopped at the
;;;     final vertex without coming back to the start.
;;;
;;;   CHAINAGE  - label running distance along a line
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; FORMATTING
;;; ---------------------------------------------------------------------------

;;; A distance written as a station: the whole number of intervals, a plus, then
;;; the remainder padded to the width of the interval. 1250 with an interval of
;;; 1000 becomes 1+250.000.
(defun Chainage:Station ( d interval prec / sign whole rem s pad want )
    ;; A chainage running back before the start is unusual but legitimate, and
    ;; truncation toward zero would otherwise put the sign in the wrong place.
    (setq sign (if (< d 0.0) "-" "")
          d    (abs d))

    (setq whole (fix (/ d interval))
          rem   (- d (* whole interval))
          s     (rtos rem 2 prec)
          ;; The remainder has to fill the interval's width or the reading is
          ;; out by a factor of ten: fifty metres in a thousand-metre station is
          ;; 0+050, not 0+50. The width is the digits in the interval less one,
          ;; because the remainder can never reach the interval itself - 1000
          ;; allows 0 to 999, which is three digits.
          pad   (max 1 (1- (strlen (itoa (fix interval)))))
          want  (if (> prec 0) (+ pad 1 prec) pad))

    (while (< (strlen s) want) (setq s (strcat "0" s)))
    (strcat sign (itoa whole) "+" s)
)

(defun Chainage:Label ( d mode prec )
    (cond ((= mode "Station")  (Chainage:Station d 1000.0 prec))
          ((= mode "Imperial") (Chainage:Station d 100.0 prec))
          (t (rtos d 2 prec)))
)

;;; ---------------------------------------------------------------------------
;;; GEOMETRY
;;; ---------------------------------------------------------------------------

;;; The parameter of every vertex, first to last. For a polyline the vertices
;;; sit at whole-numbered parameters, so this is simply 0 up to the end. For a
;;; spline or an ellipse there are no vertices as such, and the curve is divided
;;; into equal steps instead.
(defun Chainage:Params ( obj kind steps / endp out i )
    (setq endp (vlax-curve-getEndParam obj) out nil)
    (if (member kind '("LWPOLYLINE" "POLYLINE" "LINE"))
        (progn
            (setq i 0)
            (while (<= i endp) (setq out (cons i out) i (1+ i))))
        (progn
            (setq i 0)
            (while (<= i steps)
                (setq out (cons (* endp (/ (float i) steps)) out) i (1+ i)))))
    (reverse out)
)

;;; The direction of the curve at a parameter, used to lay the text along it.
(defun Chainage:Angle ( obj p / d )
    (setq d (vlax-curve-getFirstDeriv obj p))
    (if (and d (not (equal 0.0 (distance '(0 0 0) d) 1e-10)))
        (angle '(0 0 0) d)
        0.0)
)

(defun Chainage:Layer ( name colour )
    (if (not (tblsearch "LAYER" name))
        (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord")
                       '(100 . "AcDbLayerTableRecord") (cons 2 name)
                       '(70 . 0) (cons 62 colour) '(6 . "Continuous"))))
    name
)

;;; Text placed with its bottom centre on the point, which keeps the label
;;; clear of the line it belongs to. Group 72 of 1 and 73 of 3 is bottom
;;; centre, and both group 10 and group 11 must carry the point when the
;;; justification is anything but the default.
(defun Chainage:Text ( pt hgt rot txt layer )
    (entmake (list '(0 . "TEXT") (cons 8 layer)
                   (cons 10 pt) (cons 11 pt) (cons 40 hgt) (cons 1 txt)
                   (cons 50 rot) '(72 . 1) '(73 . 3)))
)

(defun Chainage:Tick ( pt ang len layer )
    (entmake (list '(0 . "LINE") (cons 8 layer)
                   (cons 10 (polar pt (+ ang (/ pi 2.0)) (/ len 2.0)))
                   (cons 11 (polar pt (- ang (/ pi 2.0)) (/ len 2.0)))))
)

;;; ---------------------------------------------------------------------------
;;; MAIN COMMAND
;;; ---------------------------------------------------------------------------

(defun c:CHAINAGE ( / *error* vars vals sel ent kind obj mode prec hgt start
                      along ticks lay params p pt d rot n txt v total )

    (setq vars '("CMDECHO" "BLIPMODE" "OSMODE" "CLAYER")
          vals (mapcar 'getvar vars))

    (defun Chainage:Restore ( )
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl))) (command "_.UNDO" "_End"))
        (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        (princ)
    )

    (defun *error* ( msg )
        (Chainage:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** CHAINAGE error: " msg " **")))
        (princ)
    )

    (setvar "CMDECHO" 0)
    (setvar "BLIPMODE" 0)
    (setvar "OSMODE" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler unless
    ;; the routine says up front that it will use one.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    ;; --- pick the line ------------------------------------------------------
    ;; Enter gives up rather than asking again forever.
    (setq ent nil)
    (while (and (null ent)
                (setq sel (entsel "\nLine to label <Enter to give up>: ")))
        (setq kind (cdr (assoc 0 (entget (car sel)))))
        (if (member kind '("LWPOLYLINE" "POLYLINE" "LINE" "ARC" "SPLINE" "ELLIPSE"))
            (setq ent (car sel))
            (princ (strcat "\n  A " kind
                           " has no length to run along. Try a polyline."))))

    (if (null ent)
        (princ "\nCancelled.")
        (progn
            (setq obj   (vlax-ename->vla-object ent)
                  total (vlax-curve-getDistAtParam obj
                            (vlax-curve-getEndParam obj)))

            (princ (strcat "\n" kind ", total length " (rtos total 2 3) "."))

            ;; --- how to write it --------------------------------------------
            (initget "Distance Station Imperial")
            (setq mode (getkword
                "\nLabel as [Distance/Station/Imperial] <Distance>: "))
            (if (null mode) (setq mode "Distance"))

            (initget 4)
            (setq prec (getint (strcat "\nDecimal places <"
                                       (if (= mode "Distance") "2" "3") ">: ")))
            (if (null prec) (setq prec (if (= mode "Distance") 2 3)))

            (initget 4)
            (setq start (getdist "\nChainage at the start <0>: "))
            (if (null start) (setq start 0.0))

            ;; --- how it should look -----------------------------------------
            (setq hgt (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))))
            (if (or (null hgt) (<= hgt 0.0))
                (progn
                    (initget 6)
                    (setq hgt (getdist "\nText height: ")))
                (progn
                    (initget 6)
                    (setq v (getdist (strcat "\nText height <" (rtos hgt 2 3) ">: ")))
                    (if v (setq hgt v))))

            (initget "Along Horizontal")
            (setq along (/= "Horizontal" (getkword
                "\nText direction [Along/Horizontal] <Along>: ")))

            (initget "Yes No")
            (setq ticks (= "Yes" (getkword
                "\nDraw a tick at each point [Yes/No] <No>: ")))

            ;; --- label it ----------------------------------------------------
            (setq lay    (Chainage:Layer "Chainage" 3)
                  params (Chainage:Params obj kind 20)
                  n      0)

            (foreach p params
                (setq pt  (vlax-curve-getPointAtParam obj p)
                      d   (+ start (vlax-curve-getDistAtParam obj p))
                      rot (if along (Chainage:Angle obj p) 0.0)
                      txt (Chainage:Label d mode prec))

                ;; Keep the text the right way up. Past vertical it would read
                ;; upside down, so it is turned through half a circle - which
                ;; leaves it on the other side of the line, reading correctly.
                (if (and along (> (abs rot) (/ pi 2.0)) (< (abs rot) (* 1.5 pi)))
                    (setq rot (+ rot pi)))

                (if ticks (Chainage:Tick pt (Chainage:Angle obj p) (* hgt 1.5) lay))
                (Chainage:Text (polar pt (+ rot (/ pi 2.0)) (* hgt 0.4))
                               hgt rot txt lay)
                (setq n (1+ n)))

            (princ (strcat "\n" (itoa n) " label"
                           (if (= n 1) "" "s") " placed on layer Chainage, "
                           (Chainage:Label start mode prec) " to "
                           (Chainage:Label (+ start total) mode prec) "."))
        )
    )

    (Chainage:Restore)
    (princ)
)

(princ)