;;; ---------------------------------------------------------------------------
;;; RunLength.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Measures the distance ALONG a chain of connected objects between two points.
;;;
;;; Select a run of connected lines, arcs and polylines - a pipe route, a kerb
;;; line, a cable run - then pick two points anywhere on it. The result is the
;;; true travelled distance following the geometry, not the straight-line
;;; distance between the picks.
;;;
;;; The two points may sit on different objects with any number of objects
;;; between them, or on the same object. The selection may contain several
;;; separate chains; if the two picks land on different chains, you are told so
;;; rather than being given a meaningless number.
;;;
;;; HOW IT WORKS
;;;   1. The selection is sorted into chain order - the objects are put into the
;;;      sequence you would walk them, each one flipped if necessary so its
;;;      start point meets the previous object's end point.
;;;   2. The chain is then searched for the object carrying the first pick, and
;;;      the remainder searched for the one carrying the second.
;;;   3. The total is the part-length of the first object from the pick to its
;;;      far end, plus the full length of every object in between, plus the
;;;      part-length of the last object up to the second pick.
;;;
;;; If the search for the second point finds nothing in the remainder of the
;;; chain, the two picks are not connected - which is exactly how the "not on
;;; the same chain" case is detected.
;;;
;;; Closed objects are excluded: a circle or closed polyline has no free ends,
;;; so it can neither join a chain nor be traversed through.
;;;
;;; The result honours the drawing's LUNITS and LUPREC settings.
;;;
;;;   RUNLENGTH  - measure along a chain between two points
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Tolerance for treating two endpoints as joined.
(setq RunLength:Tolerance 1e-8)

;; Tolerance for deciding a picked point lies on an object. Far looser than the
;; endpoint tolerance, because this one has to forgive an imprecise mouse click.
(setq RunLength:PickTolerance 1e-3)

;; ---------------------------------------------------------------------------
;; Selection filter - open curves only, confined to the current space.
;; ---------------------------------------------------------------------------
(setq RunLength:Filter
    (list
       '(-4 . "<OR")
           '(0 . "LINE,ARC")
           '(-4 . "<AND")
               '(0 . "LWPOLYLINE,SPLINE")
               '(-4 . "<NOT") '(-4 . "&=") '(70 . 1) '(-4 . "NOT>")
           '(-4 . "AND>")
           '(-4 . "<AND")
               '(0 . "POLYLINE")
               '(-4 . "<NOT") '(-4 . "&") '(70 . 89) '(-4 . "NOT>")
           '(-4 . "AND>")
           '(-4 . "<AND")
               '(0 . "ELLIPSE")
               '(-4 . "<OR")
                   '(-4 . "<>") '(41 . 0.0)
                   '(-4 . "<>")  (cons 42 (+ pi pi))
               '(-4 . "OR>")
           '(-4 . "AND>")
       '(-4 . "OR>")
        (if (= 1 (getvar 'cvport))
            (cons 410 (getvar 'ctab))
           '(410 . "Model")
        )
    )
)

;; ---------------------------------------------------------------------------
;; RunLength:SortChain
;; ---------------------------------------------------------------------------
;; Returns the selection ordered into chain sequence, as a list of triples:
;;
;;     (startPoint entityName endPoint)
;;
;; Each triple is oriented so that its start point is the end nearer the head
;; of the chain - a triple whose stored direction runs the wrong way is simply
;; reversed, which is why the whole list can then be walked in one direction.
;;
;; The algorithm starts from an arbitrary object and grows in BOTH directions
;; at once, tracking the two live ends of the chain. Each sweep tries every
;; remaining object against those two ends in all four possible orientations:
;;
;;     its start meets the head    -> prepend, reversed
;;     its start meets the tail    -> append
;;     its end   meets the head    -> prepend
;;     its end   meets the tail    -> append, reversed
;;
;; Objects that match nothing this sweep are held over for the next. When a
;; full sweep adds nothing, the chain has stopped growing and is returned.
;; ---------------------------------------------------------------------------
(defun RunLength:SortChain ( sel / idx ent pool ends chain leftover matched itm )

    ;; Reduce the selection to triples once, up front.
    (repeat (setq idx (sslength sel))
        (setq ent  (ssname sel (setq idx (1- idx)))
              pool (cons (list (vlax-curve-getstartpoint ent)
                               ent
                               (vlax-curve-getendpoint ent)
                         )
                         pool
                   )
        )
    )

    ;; Seed the chain with the first object; its two ends become the live ends.
    (setq ends  (list (caar pool) (caddar pool))
          chain (list (car pool))
          pool  (cdr pool)
    )

    (while
        (progn
            (setq leftover nil
                  matched  nil
            )
            (foreach itm pool
                (cond
                    (   (equal (car itm) (car ends) RunLength:Tolerance)
                        (setq ends    (cons (caddr itm) (cdr ends))
                              chain   (cons (reverse itm) chain)
                              matched t
                        )
                    )
                    (   (equal (car itm) (cadr ends) RunLength:Tolerance)
                        (setq ends    (list (car ends) (caddr itm))
                              chain   (append chain (list itm))
                              matched t
                        )
                    )
                    (   (equal (caddr itm) (car ends) RunLength:Tolerance)
                        (setq ends    (cons (car itm) (cdr ends))
                              chain   (cons itm chain)
                              matched t
                        )
                    )
                    (   (equal (caddr itm) (cadr ends) RunLength:Tolerance)
                        (setq ends    (list (car ends) (car itm))
                              chain   (append chain (list (reverse itm)))
                              matched t
                        )
                    )
                    (   (setq leftover (cons itm leftover)))
                )
            )
            (setq pool leftover)
            matched
        )
    )
    chain
)

;; ---------------------------------------------------------------------------
;; c:RUNLENGTH  -  main routine
;; ---------------------------------------------------------------------------
(defun c:RUNLENGTH ( / *error* sel pt1 pt2 chain fromFirst toSecond len itm )

    ;; Read-only: nothing is created or modified, so no sysvars are captured
    ;; and no undo group is opened.
    (defun *error* ( msg )
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** RUNLENGTH error: " msg " **"))
        )
        (princ)
    )

    (if (and (progn (princ "\nSelect the chain of objects: ")
                    (setq sel (ssget RunLength:Filter))
             )
             (setq pt1 (getpoint "\nSpecify first point: "))
             (setq pt2 (getpoint pt1 "\nSpecify second point: "))
        )
        (progn
            (setq chain (RunLength:SortChain sel))

            ;; ---------------------------------------------------------------
            ;; Find the object carrying the first pick. Either pick may be the
            ;; one encountered first when walking the chain, so both are tested
            ;; and the pair is swapped if pt2 turned up first - after which pt1
            ;; is always the earlier of the two along the chain.
            ;;
            ;; Both points are also snapped exactly onto their objects here, so
            ;; the arithmetic below works from true on-curve positions rather
            ;; than from wherever the mouse actually landed.
            ;; ---------------------------------------------------------------
            (if (and
                    (setq fromFirst
                        (vl-member-if
                            (function
                                (lambda ( itm / hit )
                                    (cond
                                        (   (equal pt1
                                                   (setq hit (vlax-curve-getclosestpointto (cadr itm) pt1))
                                                   RunLength:PickTolerance
                                            )
                                            (setq pt1 hit)
                                        )
                                        (   (equal pt2
                                                   (setq hit (vlax-curve-getclosestpointto (cadr itm) pt2))
                                                   RunLength:PickTolerance
                                            )
                                            (mapcar 'set '(pt1 pt2) (list hit pt1))
                                        )
                                    )
                                )
                            )
                            chain
                        )
                    )
                    ;; Search only the REMAINDER of the chain for the second
                    ;; point. Reversing it means the search runs back from the
                    ;; far end, so the result's head is the object carrying pt2.
                    (setq toSecond
                        (vl-member-if
                            (function
                                (lambda ( itm / hit )
                                    (if (equal pt2
                                               (setq hit (vlax-curve-getclosestpointto (cadr itm) pt2))
                                               RunLength:PickTolerance
                                        )
                                        (setq pt2 hit)
                                    )
                                )
                            )
                            (reverse fromFirst)
                        )
                    )
                )
                (progn
                    (if (cdr toSecond)

                        ;; The picks are on DIFFERENT objects. Take the part of
                        ;; the first object from pt1 to its far end, plus the
                        ;; part of the last object from its near end to pt2.
                        (setq len
                            (+ (abs (- (vlax-curve-getdistatpoint (cadar fromFirst) pt1)
                                       (vlax-curve-getdistatpoint (cadar fromFirst) (caddar fromFirst))
                                    )
                               )
                               (abs (- (vlax-curve-getdistatpoint (cadar toSecond) pt2)
                                       (vlax-curve-getdistatpoint (cadar toSecond) (caar toSecond))
                                    )
                               )
                            )
                        )

                        ;; Both picks are on the SAME object - simply the
                        ;; difference between their distances along it.
                        (setq len
                            (abs (- (vlax-curve-getdistatpoint (cadar toSecond) pt1)
                                    (vlax-curve-getdistatpoint (cadar toSecond) pt2)
                                 )
                            )
                        )
                    )

                    ;; Add the full length of every object lying wholly between
                    ;; the two end objects.
                    (foreach itm (cdr (reverse (cdr toSecond)))
                        (setq len
                            (+ len
                               (vlax-curve-getdistatparam (cadr itm)
                                   (vlax-curve-getendparam (cadr itm))
                               )
                            )
                        )
                    )

                    (princ (strcat "\nLength along the chain: " (rtos len)))
                )
                (princ "\nThose two points do not lie on the same chain of objects.")
            )
        )
        (princ "\n*Cancelled*")
    )

    (princ)
)

(princ)