;;; ---------------------------------------------------------------------------
;;; WidthTrace.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Converts a WIDE polyline into a closed outline of its own edges.
;;;
;;; A polyline with width is drawn as a thick line, but it is still stored as a
;;; single centreline with width values. Anything that needs the real shape -
;;; hatching the road surface, exporting the kerb face, trimming to the edge of
;;; a duct - needs that thickness expressed as actual geometry.
;;;
;;; This traces the visible edges and creates a genuine closed polyline around
;;; them, handling varying width along the run.
;;;
;;; COMMANDS
;;;   WIDTHTRACE      - outline one polyline
;;;   WIDTHTRACEMANY  - outline a whole selection
;;;
;;; RESTRICTION: STRAIGHT SEGMENTS ONLY
;;; The selection filter deliberately rejects any polyline containing a bulged
;;; (arc) segment. The edge of a variable-width arc is not itself an arc - it is
;;; a spiral - so it cannot be represented by polyline geometry without
;;; approximation. Rather than silently producing subtly wrong output, such
;;; polylines simply cannot be selected.
;;;
;;; HOW THE OUTLINE IS BUILT
;;;   1. For each segment, compute the unit normal - the direction square to it.
;;;   2. Offset the segment's two endpoints along that normal by half the width
;;;      at each end. Done once with plus and once with minus, this yields the
;;;      left and right edge lines of that segment.
;;;   3. Where two consecutive segments meet, intersect their edge lines. The
;;;      intersection is the true mitred corner of the outline.
;;;   4. Join the left edge run to the reversed right edge run to close the loop.
;;;
;;; An OPEN source polyline yields one closed outline; a CLOSED source yields
;;; two - an outer and an inner, since the shape is then a ring.
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Rejects polylines with any bulged vertex - see the restriction note above.
(setq WidthTrace:Filter
   '((0 . "LWPOLYLINE") (-4 . "<NOT") (-4 . "<>") (42 . 0.0) (-4 . "NOT>"))
)

;; ---------------------------------------------------------------------------
;; WidthTrace:Vertices
;; ---------------------------------------------------------------------------
;; Returns the polyline's vertices as (point startWidth endWidth) triples.
;; ---------------------------------------------------------------------------
(defun WidthTrace:Vertices ( enx )
    (if (setq enx (member (assoc 10 enx) enx))
        (cons
            (list (cdr (assoc 10 enx)) (cdr (assoc 40 enx)) (cdr (assoc 41 enx)))
            (WidthTrace:Vertices (cdr enx))
        )
    )
)

;; ---------------------------------------------------------------------------
;; WidthTrace:UnitNormal
;; ---------------------------------------------------------------------------
;; Returns the unit vector square to the direction from pt1 to pt2.
;;
;; Rotating a vector 90 degrees in the plane is simply (x y) -> (-y x); the
;; result is then divided by its own length to make it unit. A zero-length
;; segment - two coincident vertices, which do occur in imported data - would
;; divide by zero, so that case returns a zero vector and the segment
;; contributes nothing rather than crashing the outline.
;; ---------------------------------------------------------------------------
(defun WidthTrace:UnitNormal ( pt1 pt2 / vec len )
    (setq vec (mapcar '- pt1 pt2)
          vec (list (- (cadr vec)) (car vec) 0.0)
          len (distance '(0.0 0.0) vec)
    )
    (if (equal 0.0 len 1e-14)
        (list 0.0 0.0 0.0)
        (mapcar '/ vec (list len len len))
    )
)

;; ---------------------------------------------------------------------------
;; WidthTrace:SegmentEdges
;; ---------------------------------------------------------------------------
;; Returns the two edge lines of one segment as:
;;
;;     ( (leftStart leftEnd) (rightStart rightEnd) )
;;
;; Each endpoint is displaced along the segment normal by HALF the width at
;; that end - half, because the stored width spans the full thickness and the
;; centreline runs down the middle of it. Using the start width at the first
;; vertex and the end width at the second is what makes a tapering segment
;; produce correctly tapering edges.
;;
;; va, vb - [list] the two vertex triples (point startWidth endWidth)
;; ---------------------------------------------------------------------------
(defun WidthTrace:SegmentEdges ( va vb / normal )
    (setq normal (WidthTrace:UnitNormal (car va) (car vb)))
    (mapcar
        (function
            (lambda ( op )
                ;; One edge line per side: displace vertex a by the start width
                ;; and vertex b by the end width, both taken from segment a.
                (mapcar
                    (function
                        (lambda ( vertex width )
                            (mapcar op
                                    (car vertex)
                                    (mapcar (function (lambda ( n ) (* n (/ width 2.0))))
                                            normal
                                    )
                            )
                        )
                    )
                    (list va vb)
                    (cdr va)
                )
            )
        )
        (list + -)
    )
)

;; ---------------------------------------------------------------------------
;; WidthTrace:Corners
;; ---------------------------------------------------------------------------
;; Given two consecutive segments' edge pairs, returns the mitred corner points
;; where their left edges meet and where their right edges meet.
;;
;; The nil final argument to inters extends both lines infinitely, so the
;; intersection is found even when the mitre point lies beyond the physical end
;; of either edge - which is exactly what happens on the outside of any bend.
;;
;; Returns nil for a pair whose edges are parallel, in which case there is no
;; corner to insert and the run simply continues straight.
;; ---------------------------------------------------------------------------
(defun WidthTrace:Corners ( edgesA edgesB / found )
    (setq found
        (apply 'append
            (mapcar
                (function
                    (lambda ( edge1 edge2 / hit )
                        (if (setq hit (inters (car edge1) (cadr edge1)
                                              (car edge2) (cadr edge2)
                                              nil
                                      )
                            )
                            (list hit)
                        )
                    )
                )
                edgesA edgesB
            )
        )
    )
    (if found (list found))
)

;; ---------------------------------------------------------------------------
;; WidthTrace:Outline
;; ---------------------------------------------------------------------------
;; Creates the outline polyline(s) for one wide polyline and returns their
;; entity names.
;;
;; ent - [ename] the source LWPolyline
;; ---------------------------------------------------------------------------
(defun WidthTrace:Outline ( ent / enx verts closed pairs edges corners
                                  lefts rights header )

    (setq enx    (entget ent)
          verts  (WidthTrace:Vertices enx)
          closed (= 1 (logand 1 (cdr (assoc 70 enx))))
    )

    ;; -----------------------------------------------------------------------
    ;; Pair up consecutive vertices into segments. A closed polyline has one
    ;; extra segment joining its last vertex back to its first, which is why
    ;; the two lists are wrapped round for the closed case.
    ;; -----------------------------------------------------------------------
    (setq pairs
        (if closed
            (list (cons (last verts) verts)
                  (append verts (list (car verts)))
            )
            (list verts (cdr verts))
        )
    )

    ;; Edge lines for every segment.
    (setq edges (apply 'mapcar (cons 'WidthTrace:SegmentEdges pairs)))

    ;; Mitred corners between each consecutive pair of segments.
    (setq corners
        (apply 'append
            (mapcar 'WidthTrace:Corners edges (cdr edges))
        )
    )

    ;; -----------------------------------------------------------------------
    ;; An OPEN polyline has two ends that no corner calculation reaches, since
    ;; there is no following segment to intersect with. The very first segment's
    ;; starting edge points and the very last segment's ending edge points are
    ;; therefore added explicitly to cap the outline.
    ;; -----------------------------------------------------------------------
    (setq corners
        (if closed
            corners
            (append (list (mapcar 'car  (car  edges)))
                    corners
                    (list (mapcar 'cadr (last edges)))
            )
        )
    )

    (setq lefts  (mapcar 'car  corners)
          rights (reverse (mapcar 'cadr corners))
    )

    ;; -----------------------------------------------------------------------
    ;; Assemble the loops.
    ;;
    ;; OPEN source: one loop, running out along the left edge and back along
    ;; the reversed right edge. The equality tests drop a duplicated point where
    ;; the two runs meet at each cap, which would otherwise leave a zero-length
    ;; segment in the result.
    ;;
    ;; CLOSED source: two separate loops - the outer and inner edges of the ring.
    ;; -----------------------------------------------------------------------
    (setq corners
        (if closed
            (list lefts rights)
            (list
                (append
                    (if (equal (car lefts) (last rights) 1e-8) (cdr lefts)  lefts)
                    (if (equal (car rights) (last lefts) 1e-8) (cdr rights) rights)
                )
            )
        )
    )

    ;; -----------------------------------------------------------------------
    ;; Build each loop as a new closed polyline, inheriting the source's layer,
    ;; colour and other header properties.
    ;;
    ;; Three groups are overridden:
    ;;   43 - constant width, forced to 0 so the outline itself is hairline
    ;;   70 - closed flag forced on
    ;;   90 - vertex count, set per loop
    ;; -----------------------------------------------------------------------
    (setq header (reverse (member (assoc 39 enx) (reverse enx))))

    (mapcar
        (function
            (lambda ( loop )
                (entmakex
                    (append
                        (subst (cons 43 0.0) (assoc 43 enx)
                            (subst (cons 70 (logior 1 (cdr (assoc 70 enx)))) (assoc 70 enx)
                                (subst (cons 90 (length loop)) (assoc 90 enx)
                                       header
                                )
                            )
                        )
                        (mapcar (function (lambda ( p ) (cons 10 p))) loop)
                        (list (assoc 210 enx))
                    )
                )
            )
        )
        corners
    )
)

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

;; ---------------------------------------------------------------------------
;; c:WIDTHTRACE  -  outline a single polyline
;; ---------------------------------------------------------------------------
(defun c:WIDTHTRACE ( / *error* vars vals sel ent )

    (setq vars '("CMDECHO")
          vals (mapcar 'getvar vars)
    )

    (defun *error* ( msg )
        (WidthTrace:Restore vars vals)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** WIDTHTRACE error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler
    ;; unless the routine says up front that it will use one. Restore does,
    ;; to close this undo group. The declaring call is absent on older
    ;; releases, so it is wrapped rather than tested for.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    ;; "_+.:E:S:L" is single-pick, one object, excluding locked layers.
    (princ "\nSelect a wide polyline (no arc segments): ")
    (if (setq sel (ssget "_+.:E:S:L" WidthTrace:Filter))
        (progn
            (setq ent (ssname sel 0))
            (WidthTrace:Outline ent)
            (initget "Yes No")
            (if (/= "No" (getkword "\nDelete the original? [Yes/No] <Yes>: "))
                (entdel ent)
            )
            (princ "\nOutline created.")
        )
        (princ "\nNothing suitable selected.")
    )

    (WidthTrace:Restore vars vals)
    (princ)
)

;; ---------------------------------------------------------------------------
;; c:WIDTHTRACEMANY  -  outline a whole selection
;; ---------------------------------------------------------------------------
;; Note that the original left the entity variable undeclared in its multiple
;; selection command, leaking it globally on every run. It is localised here.
;; ---------------------------------------------------------------------------
(defun c:WIDTHTRACEMANY ( / *error* vars vals sel del idx ent count )

    (setq vars '("CMDECHO")
          vals (mapcar 'getvar vars)
    )

    (defun *error* ( msg )
        (WidthTrace:Restore vars vals)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** WIDTHTRACEMANY error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler
    ;; unless the routine says up front that it will use one. Restore does,
    ;; to close this undo group. The declaring call is absent on older
    ;; releases, so it is wrapped rather than tested for.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    (princ "\nSelect wide polylines (no arc segments): ")
    (if (setq sel (ssget "_:L" WidthTrace:Filter))
        (progn
            ;; Asked once for the whole selection, not once per object.
            (initget "Yes No")
            (setq del   (/= "No" (getkword "\nDelete the originals? [Yes/No] <Yes>: "))
                  count 0
            )
            (repeat (setq idx (sslength sel))
                (setq ent (ssname sel (setq idx (1- idx))))
                (WidthTrace:Outline ent)
                (if del (entdel ent))
                (setq count (1+ count))
            )
            (princ (strcat "\n" (itoa count)
                           " polyline" (if (= 1 count) "" "s") " outlined."
                   )
            )
        )
        (princ "\nNothing suitable selected.")
    )

    (WidthTrace:Restore vars vals)
    (princ)
)

(princ)