;;; ---------------------------------------------------------------------------
;;; CurveHug.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Drags a selection of objects along a curve, keeping them aligned to it, and
;;; drops them where you click.
;;;
;;; Select anything - a symbol, a block, a group of geometry - then pick a
;;; curve. The objects follow the cursor along that curve, rotating to stay
;;; square to it as it bends, with live control over offset and rotation. Click
;;; to place.
;;;
;;; This is how you put manhole symbols along a drain run, tree symbols along a
;;; boundary, or arrows along a curved route, without rotating each one by hand.
;;;
;;; LIVE CONTROLS WHILE DRAGGING
;;;   + or =    move further from the curve
;;;   - or _    move closer, and past it to the other side
;;;   < or ,    rotate 45 degrees anticlockwise
;;;   > or .    rotate 45 degrees clockwise
;;;   O         type an exact offset
;;;   R         type an exact rotation
;;;   M         toggle Multiple mode - stay in the command and keep placing
;;;   ENTER, SPACE, E, or right-click   finish
;;;
;;; Offset and rotation persist for the whole AutoCAD session, so a run of
;;; symbols placed one after another keeps a consistent stand-off.
;;;
;;; The curve may be nested inside a block or xref to any depth. When it is, a
;;; temporary top-level copy is made to align against and removed afterwards -
;;; the nested original is never touched.
;;;
;;; HOW THE PREVIEW IS DONE
;;; The selected objects are gathered into a temporary block, and it is that
;;; single block reference which is dragged. Moving one object is far faster
;;; than moving fifty, which is what keeps the drag smooth. On placement the
;;; block is exploded back into its constituent objects and the temporary
;;; definition purged, so nothing of the mechanism is left in the drawing.
;;;
;;;   CURVEHUG  - align and place objects along a curve
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; SESSION SETTINGS
;;;
;;; Global by necessity - they persist between runs so a series of placements
;;; keeps the same stand-off and orientation.
;;;
;;; The offset is stored as a FRACTION of the objects' own half-height rather
;;; than as an absolute distance, so one setting looks right whatever size the
;;; symbol is.
;;; ---------------------------------------------------------------------------
(if (null *CurveHug:Offset*)   (setq *CurveHug:Offset*   0.0))
(if (null *CurveHug:Rotation*) (setq *CurveHug:Rotation* 0.0))
(if (null *CurveHug:Multiple*) (setq *CurveHug:Multiple* nil))

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

;;; ---------------------------------------------------------------------------
;;; MATRIX HELPERS - namespaced, since the originals were bare globals named
;;; trp, mxm and mxv.
;;; ---------------------------------------------------------------------------

(defun CurveHug:Transpose ( m )
    (apply 'mapcar (cons 'list m))
)

(defun CurveHug:MxV ( m v )
    (mapcar (function (lambda ( row ) (apply '+ (mapcar '* row v)))) m)
)

(defun CurveHug:MxM ( m n )
    (   (lambda ( a ) (mapcar (function (lambda ( row ) (CurveHug:MxV a row))) m))
        (CurveHug:Transpose n)
    )
)

;; Drops the Z ordinate - the alignment arithmetic works in the curve's plane.
(defun CurveHug:Flat ( p ) (list (car p) (cadr p)))

;; ---------------------------------------------------------------------------
;; CurveHug:LayerLocked
;; ---------------------------------------------------------------------------
;; True if the named layer is locked. Bit 4 of a layer record's DXF 70.
;; ---------------------------------------------------------------------------
(defun CurveHug:LayerLocked ( lay / def )
    (and (setq def (tblsearch "layer" lay))
         (= 4 (logand 4 (cdr (assoc 70 def))))
    )
)

;; ---------------------------------------------------------------------------
;; CurveHug:MakeTemp
;; ---------------------------------------------------------------------------
;; Creates a neutral top-level copy of an entity from its DXF data.
;;
;; Two categories are stripped: the identity and property groups, replaced with
;; neutral values, since this copy exists only to be measured against and is
;; deleted afterwards; and any pair whose VALUE is an entity name, because
;; those point at objects inside the block that do not exist at the top level
;; and would make entmakex fail.
;; ---------------------------------------------------------------------------
(defun CurveHug:MakeTemp ( enx )
    (entmakex
        (append
            (vl-remove-if
                (function
                    (lambda ( x )
                        (or (member (car x) '(005 006 008 039 048 062 102 370))
                            (= 'ename (type (cdr x)))
                        )
                    )
                )
                enx
            )
           '(
                (006 . "CONTINUOUS")
                (008 . "0")
                (039 . 0.0)
                (048 . 1.0)
                (062 . 7)
                (370 . 0)
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; CurveHug:CopyNested
;; ---------------------------------------------------------------------------
;; Recreates a nested curve at the top level, positioned where it appears, and
;; returns its entity name.
;;
;; This is necessary because vlax-curve queries cannot be made against an
;; object inside a block reference - the geometry there is stored in the
;; block's own coordinates, not the drawing's.
;;
;; A polyline flagged with DXF 66 has its vertices as separate sub-entities, so
;; those are walked and recreated too, terminating at the SEQEND. In that case
;; the entity returned is the SEQEND's owner, which is the rebuilt polyline.
;;
;; The matrix supplied by nentselp is then applied to move the copy into the
;; position the nested original appears at.
;;
;; ent - [ename] the nested entity
;; mat - [list] the nesting transformation from nentselp
;; ---------------------------------------------------------------------------
(defun CurveHug:CopyNested ( ent mat / enx tmp )
    (if (= 1 (cdr (assoc 66 (setq enx (entget ent)))))
        (progn
            (CurveHug:MakeTemp enx)
            (setq ent (entnext ent)
                  enx (entget  ent)
            )
            (while (/= "SEQEND" (cdr (assoc 0 enx)))
                (CurveHug:MakeTemp enx)
                (setq ent (entnext ent)
                      enx (entget  ent)
                )
            )
            (setq tmp (cdr (assoc 330 (entget (CurveHug:MakeTemp enx)))))
        )
        (setq tmp (CurveHug:MakeTemp enx))
    )
    (if tmp
        (vla-transformby (vlax-ename->vla-object tmp) (vlax-tmatrix mat))
    )
    tmp
)

;; ---------------------------------------------------------------------------
;; CurveHug:Ssget
;; ---------------------------------------------------------------------------
;; ssget with a custom prompt, restoring NOMUTT to its captured value.
;; ---------------------------------------------------------------------------
(defun CurveHug: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:CURVEHUG  -  main routine
;; ---------------------------------------------------------------------------
(defun c:CURVEHUG ( / *error* vars vals bb1 bb2 blk bnm bpt def dis ent fac
                      gr1 gr2 idx inc llp lst mat msg obj ocs oss pi2
                      pt1 pt2 pt3 pt4 sel tma tmp trm urp uxa vec )

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

    ;; -----------------------------------------------------------------------
    ;; Cleanup has a lot to undo, because the preview machinery creates several
    ;; temporary things: a recreated nested curve, a temporary block definition,
    ;; its inserted reference, and copies of the selected objects. Every one
    ;; must go on every exit path, or an interrupted drag leaves debris behind.
    ;; -----------------------------------------------------------------------
    (defun CurveHug:Cleanup ( )
        (if (and (= 'list (type trm)) (= 'ename (type ent)) (entget ent))
            (entdel ent)
        )
        (if (and (= 'vla-object (type blk)) (not (vlax-erased-p blk)))
            (vl-catch-all-apply 'vla-delete (list blk))
        )
        (if (and (= 'vla-object (type def)) (not (vlax-erased-p def)))
            (vl-catch-all-apply 'vla-delete (list def))
        )
        (foreach obj lst
            (if (and (= 'vla-object (type obj)) (not (vlax-erased-p obj)))
                (vl-catch-all-apply 'vla-delete (list obj))
            )
        )
        (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 )
        (CurveHug:Cleanup)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** CURVEHUG 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")

    (cond
        ;; Layer 0 must be unlocked because the temporary block reference is
        ;; created on it; the current layer because the placed objects land
        ;; there. Checked before any work is done.
        (   (or (CurveHug:LayerLocked (getvar 'clayer))
                (CurveHug:LayerLocked "0")
            )
            (princ "\nThe current layer or layer \"0\" is locked - unlock both before using this.")
        )

        (   (null (setq oss (CurveHug:Ssget "\nSelect objects to align: "
                                           '("_:L" ((0 . "~VIEWPORT"))))))
            (princ "\n*Cancelled*")
        )

        (   (progn
                (setq bpt (getpoint "\nSpecify base point <centre of selection>: "))

                ;; Re-prompt until a curve is picked. The VERTEX test allows a
                ;; polyline to be picked on one of its vertices, which is a
                ;; sub-entity rather than a curve in its own right.
                (while
                    (progn
                        (setvar 'errno 0)
                        (setq sel (nentselp "\nSelect the curve to align to <exit>: "))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\nMissed, try again.")
                            )
                            (   (= 'ename (type (car sel)))
                                (if (not
                                        (or (= "VERTEX" (cdr (assoc 0 (entget (car sel)))))
                                            (not (vl-catch-all-error-p
                                                     (vl-catch-all-apply 'vlax-curve-getendparam (list (car sel)))
                                                 )
                                            )
                                        )
                                    )
                                    (princ "\nThat object is not a curve.")
                                )
                            )
                        )
                    )
                )

                ;; Wait for the mouse to move, so the first frame has a real
                ;; cursor position to work from rather than the click point.
                (while (/= 5 (car (setq pt1 (grread t 13 1)))))
                (null sel)
            )
            (princ "\n*Cancelled*")
        )

        ;; Resolve the curve: a nested one is recreated at the top level, a
        ;; picked vertex resolves to its owning polyline, otherwise it is used
        ;; directly.
        (   (not (or (and (setq trm (caddr sel))
                          (setq ent (CurveHug:CopyNested (car sel) trm))
                     )
                     (and (= "VERTEX" (cdr (assoc 0 (entget (car sel)))))
                          (setq ent (cdr (assoc 330 (entget (car sel)))))
                     )
                     (setq ent (car sel))
                 )
            )
            (princ "\nThe nested curve could not be recreated.")
        )

        (   (progn
                ;; -------------------------------------------------------
                ;; Build a transformation into a working coordinate system
                ;; aligned with the current UCS. Copies of the selected
                ;; objects are transformed into it and measured there, so
                ;; the bounding box is taken in the plane the user is
                ;; actually working in rather than in world coordinates.
                ;;
                ;; The copies are made invisible while being measured so
                ;; they do not flicker on screen.
                ;; -------------------------------------------------------
                (setq ocs (trans '(0 0 1) 1 0 t)
                      uxa (angle '(0.0 0.0) (trans (getvar 'ucsxdir) 0 ocs t))
                      mat (CurveHug:MxM
                              (list (list (cos uxa)     (sin uxa) 0.0)
                                    (list (- (sin uxa)) (cos uxa) 0.0)
                                   '(0.0 0.0 1.0)
                              )
                              (mapcar (function (lambda ( a ) (trans a ocs 0 t)))
                                     '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
                              )
                          )
                      vec (mapcar '- (CurveHug:MxV mat (trans '(0.0 0.0 0.0) ocs 0)))
                      tma (vlax-tmatrix
                              (append (mapcar 'append mat (mapcar 'list vec))
                                     '((0.0 0.0 0.0 1.0))
                              )
                          )
                )

                (repeat (setq idx (sslength oss))
                    (setq idx (1- idx)
                          obj (vla-copy (vlax-ename->vla-object (ssname oss idx)))
                          lst (cons obj lst)
                    )
                    (vla-transformby obj tma)
                    (if (and (vlax-method-applicable-p obj 'getboundingbox)
                             (not (vl-catch-all-error-p
                                      (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))
                                  )
                             )
                        )
                        (setq bb1 (cons (vlax-safearray->list llp) bb1)
                              bb2 (cons (vlax-safearray->list urp) bb2)
                        )
                    )
                    (vla-put-visible obj :vlax-false)
                )
                (not (and bb1 bb2))
            )
            (CurveHug:Cleanup)
            (princ "\nCould not measure the selection - nothing to align.")
        )

        (   t
            (setq bb1 (apply 'mapcar (cons 'min bb1))
                  bb2 (apply 'mapcar (cons 'max bb2))
                  ;; Base point: the user's, transformed into the working
                  ;; system, or the centre of the bounding box by default.
                  bpt (cond (bpt (mapcar '+ (CurveHug:MxV mat (trans bpt 1 0)) vec))
                            ((mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) bb1 bb2))
                      )
                  ;; Half the height, which is the unit the offset is measured
                  ;; in - so one offset setting suits any symbol size.
                  fac (/ (- (cadr bb2) (cadr bb1)) 2.0)
                  pi2 (/ pi -2.0)
                  inc 0
            )

            ;; A zero-height selection - a horizontal line, say - would make
            ;; the offset arithmetic divide by zero. Fall back to half the
            ;; width, or to 1.0 if the selection has no extent at all. This is
            ;; the fix version 1.6 of the original was released for.
            (if (equal 0.0 fac 1e-8)
                (if (equal bb1 bb2 1e-8)
                    (setq fac 1.0)
                    (setq fac (/ (- (car bb2) (car bb1)) 2.0))
                )
            )

            ;; A block name not already in the drawing.
            (while (tblsearch "block" (setq bnm (strcat "$curvehug" (itoa (setq inc (1+ inc)))))))

            (foreach obj lst (vla-put-visible obj :vlax-true))

            ;; Gather the copies into a temporary block definition, based at
            ;; the chosen base point, then discard the loose copies.
            (vla-copyobjects (CurveHug:Doc)
                (vlax-make-variant
                    (vlax-safearray-fill
                        (vlax-make-safearray vlax-vbobject (cons 0 (1- (length lst))))
                        lst
                    )
                )
                (setq def (vla-add (vla-get-blocks (CurveHug:Doc)) (vlax-3D-point bpt) bnm))
            )
            (foreach obj lst (vla-delete obj))
            (setq lst nil)

            (setq blk
                (vla-insertblock
                    (vlax-get-property (CurveHug:Doc)
                        (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)
                    )
                    (vlax-3D-point (trans (cadr pt1) 1 0))
                    bnm 1.0 1.0 1.0 0.0
                )
            )
            (vla-put-layer  blk "0")
            (vla-put-normal blk (vlax-3D-point ocs))

            (setq msg (princ "\n[+/-] offset | [</>] rotate | [O]ffset | [R]otation | [M]ultiple | <[E]xit>: "))

            ;; ---------------------------------------------------------------
            ;; Drag loop.
            ;; ---------------------------------------------------------------
            (while
                (progn
                    (setq gr1 (grread t 15 0)
                          gr2 (cadr gr1)
                          gr1 (car  gr1)
                    )
                    (cond

                        ;; Mouse moved (5) or clicked (3).
                        (   (member gr1 '(3 5))
                            ;; Project the cursor onto the curve; the direction
                            ;; from that point to the cursor is the offset
                            ;; direction, and the angle between them is the
                            ;; rotation the objects must take to stay square.
                            (setq pt2 (trans gr2 1 0)
                                  pt1 (vlax-curve-getclosestpointtoprojection ent pt2 ocs)
                                  pt3 (CurveHug:Flat (trans pt1 0 ocs))
                                  pt4 (CurveHug:Flat (trans pt2 0 ocs))
                            )
                            ;; With the cursor exactly on the curve there is no
                            ;; direction to work from, so the last position is
                            ;; kept rather than jumping.
                            (if (not (equal pt3 pt4 1e-8))
                                (progn
                                    (setq dis (/ (* fac *CurveHug:Offset*) (distance pt3 pt4)))
                                    (vla-put-insertionpoint blk
                                        (vlax-3D-point
                                            (trans
                                                (append
                                                    (mapcar (function (lambda ( a b ) (+ a (* (- b a) dis)))) pt3 pt4)
                                                    (list (caddr (trans pt1 0 ocs)))
                                                )
                                                ocs 0
                                            )
                                        )
                                    )
                                    ;; The -pi/2 turns "facing the cursor" into
                                    ;; "square to the curve".
                                    (vla-put-rotation blk
                                        (+ (angle (trans pt1 0 ocs) (trans gr2 1 ocs))
                                           *CurveHug:Rotation*
                                           pi2
                                        )
                                    )
                                )
                            )
                            (cond
                                ;; Movement: keep going.
                                (   (= 5 gr1))
                                ;; Click: explode the block into real objects.
                                ;; Multiple mode keeps the loop running so more
                                ;; copies can be placed.
                                (   (progn (vla-explode blk) *CurveHug:Multiple*))
                            )
                        )

                        ;; A keypress.
                        (   (= 2 gr1)
                            (cond
                                ((member gr2 '(043 061))            ; + or =
                                 (setq *CurveHug:Offset* (+ *CurveHug:Offset* 0.1))
                                )
                                ((member gr2 '(045 095))            ; - or _
                                 (setq *CurveHug:Offset* (- *CurveHug:Offset* 0.1))
                                )
                                ((member gr2 '(044 060))            ; , or <
                                 (setq *CurveHug:Rotation* (+ *CurveHug:Rotation* (/ pi 4.0)))
                                )
                                ((member gr2 '(046 062))            ; . or >
                                 (setq *CurveHug:Rotation* (- *CurveHug:Rotation* (/ pi 4.0)))
                                )
                                ((member gr2 '(013 032 069 101))    ; Enter, space, E, e
                                 nil
                                )
                                ((member gr2 '(082 114))            ; R or r
                                 (if (setq tmp (getangle (strcat "\nSpecify rotation <"
                                                                 (angtos *CurveHug:Rotation*) ">: ")))
                                     (setq *CurveHug:Rotation* tmp)
                                 )
                                 (princ msg)
                                )
                                ((member gr2 '(079 111))            ; O or o
                                 ;; Entered as a real distance, stored as the
                                 ;; fraction of half-height the routine works in.
                                 (if (setq tmp (getdist (strcat "\nSpecify offset <"
                                                                (rtos (* fac *CurveHug:Offset*)) ">: ")))
                                     (setq *CurveHug:Offset* (/ tmp fac))
                                 )
                                 (princ msg)
                                )
                                ((member gr2 '(077 109))            ; M or m
                                 (if (setq *CurveHug:Multiple* (not *CurveHug:Multiple*))
                                     (princ "\n<Multiple mode on>")
                                     (princ "\n<Multiple mode off>")
                                 )
                                 (princ msg)
                                )
                                (t t)
                            )
                        )

                        ;; Right-click or the equivalent: finish.
                        (   (member gr1 '(011 025)) nil)

                        (   t t)
                    )
                )
            )

            ;; Remove the preview machinery. The block reference still on
            ;; screen at this moment was never placed, so deleting it is what
            ;; stops an unwanted extra copy being left behind - the fix version
            ;; 1.7 of the original was released for.
            (if trm (entdel ent))
            (vla-delete blk)
            (vla-delete def)
            (setq blk nil def nil ent nil trm nil)

            (princ "\nDone.")
        )
    )

    (CurveHug:Cleanup)
    (princ)
)

(princ)