;;; ---------------------------------------------------------------------------
;;; StretchBoth.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Lengthens BOTH ends of lines, arcs and polylines by a given amount, in one
;;; operation.
;;;
;;; The LENGTHEN command extends one end at a time, and you have to pick the
;;; end you mean. This does both ends of every object in a selection at once -
;;; useful for extending a run of grid lines, section marks or setting-out
;;; lines past the geometry they refer to.
;;;
;;; The last distance used is remembered between AutoCAD sessions.
;;;
;;; WHAT EACH OBJECT TYPE NEEDS
;;;   LINE       - each endpoint is pushed outward along the line's own
;;;                direction by scaling the vector between the two ends.
;;;
;;;   ARC        - the start and end ANGLES are adjusted. The angular change is
;;;                the extension divided by the radius, which is simply the
;;;                definition of a radian - so the arc grows by exactly the
;;;                requested arc length at each end.
;;;
;;;   POLYLINE   - only the first and last segments change. A straight segment
;;;                is extended like a line; a curved one needs its BULGE
;;;                recomputed as well as its endpoint moved, or the arc's
;;;                curvature would change instead of its length.
;;;
;;; WHEN AN EXTENSION IS REFUSED
;;; Extending both ends of an arc far enough would make them meet and pass
;;; through each other, turning the arc inside out. Any end where that would
;;; happen is silently left alone rather than producing nonsense geometry.
;;;
;;; Closed objects are excluded by the selection filter - they have no ends.
;;;
;;;   STRETCHBOTH  - extend both ends of selected objects
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Environment key for the remembered distance.
(setq StretchBoth:Key "YZ\\stretchboth")

;; ---------------------------------------------------------------------------
;; StretchBoth:Doc  -  cached active document
;; ---------------------------------------------------------------------------
(defun StretchBoth:Doc nil
    (eval (list 'defun 'StretchBoth:Doc 'nil
                (vla-get-activedocument (vlax-get-acad-object))
          )
    )
    (StretchBoth:Doc)
)

;; ---------------------------------------------------------------------------
;; StretchBoth:Scale  -  multiply a vector by a scalar
;; ---------------------------------------------------------------------------
;; Namespaced; the original defined a bare global called "vxs".
;; ---------------------------------------------------------------------------
(defun StretchBoth:Scale ( v s )
    (mapcar (function (lambda ( n ) (* n s))) v)
)

;; ---------------------------------------------------------------------------
;; StretchBoth:BulgeCentre
;; ---------------------------------------------------------------------------
;; Returns the centre of the arc described by two vertices and a bulge.
;;
;; Bulge is the tangent of a quarter of the arc's included angle. From it, both
;; the direction to the centre and the radius follow directly - which is what
;; the two arguments to polar compute.
;; ---------------------------------------------------------------------------
(defun StretchBoth:BulgeCentre ( p1 p2 b )
    (polar p1
        (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b))))
        (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
    )
)

;; ---------------------------------------------------------------------------
;; StretchBoth:Vertices
;; ---------------------------------------------------------------------------
;; Returns an LWPolyline's vertices as sublists of their four defining groups:
;; 10 position, 40 start width, 41 end width, 42 bulge.
;; ---------------------------------------------------------------------------
(defun StretchBoth:Vertices ( enx )
    (if (setq enx (member (assoc 10 enx) enx))
        (cons (list (assoc 10 enx) (assoc 40 enx) (assoc 41 enx) (assoc 42 enx))
              (StretchBoth:Vertices (cdr enx))
        )
    )
)

;; ---------------------------------------------------------------------------
;; StretchBoth:ExtendEnd
;; ---------------------------------------------------------------------------
;; Extends the leading end of a vertex list, and returns the amended list.
;;
;; Applied twice by the caller - once forwards and once to the reversed list -
;; which is how both ends get treated by one piece of logic.
;;
;; STRAIGHT SEGMENT: the endpoint is moved out along the segment direction by
;; scaling the vector between the two vertices.
;;
;; CURVED SEGMENT: both the endpoint and the bulge must change.
;;   - the new point is found by rotating around the arc centre by
;;     extension / radius radians, that ratio being the angle subtended by an
;;     arc of that length
;;   - the new bulge is the tangent of the amended quarter-angle; extension /
;;     radius / 4 is the change to that quarter-angle
;;   - the sign of the existing bulge decides direction of travel, which is why
;;     the operators are chosen by minusp
;;
;; The length test refuses any extension that would carry the arc past a full
;; circle.
;;
;; lst  - [list] vertex sublists
;; ext  - [real] extension distance
;; back - [boolean] T when working on the reversed list, which changes which
;;        vertex carries the bulge and which way the arc runs
;; ---------------------------------------------------------------------------
(defun StretchBoth:ExtendEnd ( lst ext back / ang bul cen dis len pt1 pt2 pt3 rad )

    (setq pt1 (cdr (assoc 10 (car  lst)))
          pt2 (cdr (assoc 10 (cadr lst)))
          bul (cdr (assoc 42 (if back (cadr lst) (car lst))))
          dis (distance pt1 pt2)
    )

    (if (equal 0.0 bul 1e-8)

        ;; Straight segment.
        (if (not (equal 0.0 dis 1e-8))
            (setq dis (/ (+ dis ext) dis)
                  lst (cons (subst (cons 10 (mapcar '+ pt2 (StretchBoth:Scale (mapcar '- pt1 pt2) dis)))
                                   (assoc 10 (car lst))
                                   (car lst)
                            )
                            (cdr lst)
                      )
            )
        )

        ;; Curved segment.
        (progn
            (setq cen (if back
                          (StretchBoth:BulgeCentre pt2 pt1 bul)
                          (StretchBoth:BulgeCentre pt1 pt2 bul)
                      )
                  rad (/ (* dis (1+ (* bul bul))) 4 (abs bul))
                  len (abs (* 4 (atan bul) rad))
            )
            (if (< (+ len ext) (* rad 2 pi))
                (setq pt3 (polar cen
                              (if back
                                  ((if (minusp bul) - +) (angle cen pt1) (/ ext rad))
                                  ((if (minusp bul) + -) (angle cen pt1) (/ ext rad))
                              )
                              rad
                          )
                      ang ((if (minusp bul) - +) (atan bul) (/ ext rad 4.0))
                      lst
                          (if back
                              (vl-list*
                                  (subst (cons 10 pt3) (assoc 10 (car lst)) (car lst))
                                  (subst (cons 42 (/ (sin ang) (cos ang)))
                                         (assoc 42 (cadr lst))
                                         (cadr lst)
                                  )
                                  (cddr lst)
                              )
                              (cons
                                  (subst (cons 10 pt3)
                                         (assoc 10 (car lst))
                                         (subst (cons 42 (/ (sin ang) (cos ang)))
                                                (assoc 42 (car lst))
                                                (car lst)
                                         )
                                  )
                                  (cdr lst)
                              )
                          )
                )
            )
        )
    )
    lst
)

;; ---------------------------------------------------------------------------
;; StretchBoth:ExtendPoly
;; ---------------------------------------------------------------------------
;; Extends both ends of a polyline vertex list.
;;
;; Done by extending the leading end, reversing the list, extending the leading
;; end again, and reversing back - so one routine handles both ends.
;; ---------------------------------------------------------------------------
(defun StretchBoth:ExtendPoly ( lst ext )
    (reverse (StretchBoth:ExtendEnd (reverse (StretchBoth:ExtendEnd lst ext nil)) ext t))
)

;; ---------------------------------------------------------------------------
;; StretchBoth:Ssget
;; ---------------------------------------------------------------------------
;; ssget with a custom prompt, restoring NOMUTT to its captured value.
;; ---------------------------------------------------------------------------
(defun StretchBoth:Ssget ( msg arg / mutt sel )
    (princ msg)
    (setq mutt (getvar 'nomutt))
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt mutt)
    (if (not (vl-catch-all-error-p sel)) sel)
)

;; ---------------------------------------------------------------------------
;; c:STRETCHBOTH  -  main routine
;; ---------------------------------------------------------------------------
(defun c:STRETCHBOTH ( / *error* vars vals ext saved sel idx ent enx typ
                         pt1 pt2 dis rad an1 an2 lst count )

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

    (defun StretchBoth: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 )
        (StretchBoth:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** STRETCHBOTH error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    ;; Recover the remembered distance, if it is still valid.
    (if (and (setq saved (getenv StretchBoth:Key))
             (setq saved (distof saved))
             (< 0 saved)
        )
        (setq ext saved)
    )

    ;; initget 6 rejects zero and negative input.
    (initget 6)
    (if (and
            (setq ext
                (cond
                    ((getdist (strcat "\nSpecify extension"
                                      (if ext (strcat " <" (rtos ext) ">: ") ": ")
                              )
                     )
                    )
                    (ext)
                )
            )
            ;; The filter excludes closed objects, which have no ends. Bit 1 of
            ;; DXF 70 is the closed flag; for heavy polylines the mask 87 also
            ;; catches 3D polylines and meshes.
            (setq sel
                (StretchBoth:Ssget "\nSelect lines, arcs and polylines to extend: "
                   '(   "_:L"
                        (   (-4 . "<OR")
                                (0 . "LINE,ARC")
                                (-4 . "<AND")
                                    (0 . "LWPOLYLINE")
                                    (-4 . "<NOT") (-4 . "&=") (70 . 1) (-4 . "NOT>")
                                (-4 . "AND>")
                                (-4 . "<AND")
                                    (0 . "POLYLINE")
                                    (-4 . "<NOT") (-4 . "&=") (70 . 87) (-4 . "NOT>")
                                (-4 . "AND>")
                            (-4 . "OR>")
                        )
                    )
                )
            )
        )
        (progn
            (setenv StretchBoth:Key (rtos ext))
            ;; 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")
            (setq count 0)

            (repeat (setq idx (sslength sel))
                (setq ent (ssname sel (setq idx (1- idx)))
                      enx (entget ent)
                      typ (cdr (assoc 0 enx))
                )
                (cond

                    ;; -----------------------------------------------------
                    ;; LINE - scale the vector between the endpoints so each
                    ;; end moves outward by the extension.
                    ;; -----------------------------------------------------
                    (   (= "LINE" typ)
                        (setq pt1 (cdr (assoc 10 enx))
                              pt2 (cdr (assoc 11 enx))
                              dis (distance pt1 pt2)
                        )
                        (if (not (equal 0.0 dis 1e-8))
                            (progn
                                (setq dis (/ (+ dis ext) dis))
                                (entmod
                                    (subst
                                        (cons 10 (mapcar '+ pt2 (StretchBoth:Scale (mapcar '- pt1 pt2) dis)))
                                        (assoc 10 enx)
                                        (subst
                                            (cons 11 (mapcar '+ pt1 (StretchBoth:Scale (mapcar '- pt2 pt1) dis)))
                                            (assoc 11 enx)
                                            enx
                                        )
                                    )
                                )
                                (setq count (1+ count))
                            )
                        )
                    )

                    ;; -----------------------------------------------------
                    ;; ARC - widen the included angle at each end by
                    ;; extension / radius radians. Refused if that would take
                    ;; the arc past a full circle.
                    ;; -----------------------------------------------------
                    (   (= "ARC" typ)
                        (setq rad (cdr (assoc 40 enx))
                              an1 (cdr (assoc 50 enx))
                              an2 (cdr (assoc 51 enx))
                        )
                        (if (< (+ (* rad (rem (+ (- an2 an1) pi pi) (+ pi pi))) ext ext)
                               (* 2.0 rad pi)
                            )
                            (progn
                                (entmod
                                    (subst (cons 50 (- an1 (/ ext rad))) (assoc 50 enx)
                                        (subst (cons 51 (+ an2 (/ ext rad))) (assoc 51 enx) enx)
                                    )
                                )
                                (setq count (1+ count))
                            )
                        )
                    )

                    ;; -----------------------------------------------------
                    ;; LWPOLYLINE - rebuild the entity with amended end
                    ;; vertices, preserving the header and extrusion.
                    ;; -----------------------------------------------------
                    (   (= "LWPOLYLINE" typ)
                        (entmod
                            (append
                                (reverse (member (assoc 39 enx) (reverse enx)))
                                (apply 'append (StretchBoth:ExtendPoly (StretchBoth:Vertices enx) ext))
                                (list (assoc 210 enx))
                            )
                        )
                        (setq count (1+ count))
                    )

                    ;; -----------------------------------------------------
                    ;; POLYLINE (heavy) - its vertices are separate entities
                    ;; following the header, so they are collected by walking
                    ;; forward to SEQEND, amended, and written back one at a
                    ;; time. entupd then refreshes the parent.
                    ;; -----------------------------------------------------
                    (   (= "POLYLINE" typ)
                        (setq lst nil)
                        (while (/= "SEQEND" (cdr (assoc 0 enx)))
                            (setq ent (entnext ent)
                                  enx (entget  ent)
                                  lst (cons enx lst)
                            )
                        )
                        ;; cdr drops the SEQEND record itself.
                        (foreach vtx (StretchBoth:ExtendPoly (reverse (cdr lst)) ext)
                            (entmod vtx)
                        )
                        (entupd (cdr (assoc -2 enx)))
                        (setq count (1+ count))
                    )
                )
            )

            (princ (strcat "\n" (itoa count)
                           " object" (if (= 1 count) "" "s") " extended at both ends."
                   )
            )
        )
        (princ "\n*Cancelled*")
    )

    (StretchBoth:Restore)
    (princ)
)

(princ)