;;; ---------------------------------------------------------------------------
;;; TrackText.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; SLIDE TEXT ALONG A CURVE, ALIGNED TO IT
;;;
;;; Pick a piece of text (or type a new one), pick a curve, and the text
;;; follows your cursor along that curve -- always the right distance from
;;; it, always turned to match the curve's direction at that exact point,
;;; always the right way up.
;;;
;;; This is the pipe label that has to sit above the pipe and run with it,
;;; the road name along a bend, the contour value on a contour, the flow
;;; arrow annotation on a duct. Placing one by hand means MOVE, then ROTATE
;;; with a reference angle picked off two points on the curve, then nudging
;;; it clear -- and doing it again every time the curve is edited.
;;;
;;; Anything the curve functions understand works as a track: lines, arcs,
;;; circles, ellipses, splines, polylines, and xlines. The curve may be
;;; nested inside a block or an xref.
;;;
;;; ---------------------------------------------------------------------------
;;; HOW IT WORKS
;;;
;;; The command runs inside a grread loop, so the text updates continuously
;;; as the mouse moves without the command ending.
;;;
;;; On every mouse move:
;;;   1. The closest point on the curve to the cursor is found.
;;;   2. The text is placed on the line from that point towards the cursor,
;;;      at a fixed distance -- the offset factor multiplied by the text
;;;      height. Because the offset is a MULTIPLE of the height rather than
;;;      an absolute distance, it looks identical at any drawing scale.
;;;   3. The text is rotated to the direction from the curve to the cursor,
;;;      less ninety degrees, which lines it up along the curve rather than
;;;      across it.
;;;
;;; Step 2 is what makes the behaviour feel right: the cursor chooses WHERE
;;; along the curve and WHICH SIDE, but never how far away. Wave the mouse
;;; from one side of a pipe to the other and the label flips across, keeping
;;; its clearance.
;;;
;;; ---------------------------------------------------------------------------
;;; READABILITY
;;;
;;; Text aligned to a curve is upside-down for half of that curve. With
;;; readability on -- the default -- any angle that would put the text
;;; between 90 and 270 degrees is rotated a further 180, so it always reads
;;; left to right. Press Y to switch it off when you want the text to follow
;;; the curve literally.
;;;
;;; ---------------------------------------------------------------------------
;;; NESTED CURVES
;;;
;;; The curve functions cannot measure an object inside a block reference,
;;; because its coordinates are in the block's own space rather than the
;;; drawing's.
;;;
;;; When a nested curve is picked, TrackText reads the transformation matrix
;;; that nentselp returns, rebuilds a temporary copy of the curve in world
;;; coordinates, and tracks along that. The copy is stripped of its layer,
;;; colour, linetype and lineweight so it cannot disturb anything, and it is
;;; deleted when the command finishes -- including if the command errors.
;;;
;;; A polyline vertex needs special handling: picking one returns the vertex
;;; rather than the polyline, so the vertex's owner is used instead.
;;;
;;; ---------------------------------------------------------------------------
;;; MULTIPLE TEXT MODE
;;;
;;; With multiple text mode on, every click drops a copy and immediately
;;; starts tracking another one, so a whole run of labels along a pipe is a
;;; series of clicks. The trailing uncommitted copy is removed when you
;;; press Enter.
;;;
;;; ---------------------------------------------------------------------------
;;; CONTROLS
;;;
;;;   move mouse   slide the text along the curve
;;;   click        place it (and start another, in multiple text mode)
;;;   + or =       increase the offset from the curve
;;;   - or _       decrease it
;;;   O            type an exact offset distance
;;;   < or ,       rotate 45 degrees anticlockwise
;;;   > or .       rotate 45 degrees clockwise
;;;   R            type an exact rotation
;;;   Y            toggle readability
;;;   B            toggle the mtext background mask
;;;   Enter/Space/E   finish, discarding the text still being tracked
;;;   Esc          cancel
;;;
;;; ---------------------------------------------------------------------------
;;;   TRACKTEXT - slide text along a curve
;;;   TRACKSET  - settings for new text: type, justification, offset,
;;;               rotation, readability, background mask, multiple mode,
;;;               and whether to copy the selected text rather than move it
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; TrackText:Doc
;;;
;;; Returns the active document, caching itself after the first call.
;;; ---------------------------------------------------------------------------

(defun TrackText:Doc nil
    (eval (list 'defun 'TrackText:Doc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (TrackText:Doc)
)

;;; ---------------------------------------------------------------------------
;;; TrackText:StartUndo / TrackText:EndUndo
;;;
;;; Undo group control. EndUndo loops on bit 8 of UNDOCTL, so a group left
;;; open by an interrupted operation is also closed.
;;; ---------------------------------------------------------------------------

(defun TrackText:EndUndo ( )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark (TrackText:Doc))
    )
    (princ)
)

(defun TrackText:StartUndo ( )
    (TrackText:EndUndo)
    (vla-startundomark (TrackText:Doc))
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; TrackText:FixDir / TrackText:SavePath
;;;
;;; Where the settings file lives. The AutoCAD Support folder is preferred
;;; because it is per-user and roams with the profile; the temporary folder
;;; is the fallback, and always exists.
;;; ---------------------------------------------------------------------------

(defun TrackText:FixDir ( dir )
    (vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir))
)

(defun TrackText:SavePath ( / dir )
    (if (and (setq dir (getvar 'roamablerootprefix))
             (vl-file-directory-p (strcat (TrackText:FixDir dir) "\\Support"))
        )
        (strcat (TrackText:FixDir dir) "\\Support")
        (TrackText:FixDir (getvar 'tempprefix))
    )
)

;;; ===========================================================================
;;; TRACKTEXT
;;; ===========================================================================

(defun c:TrackText

    ( /
        *error* TrackText:Discard
        ang cfg copy defs dis ent enx gr1 gr2 hgt jus mask maskoff mat
        msg mult nrm off prop props pt1 pt2 read rot sel str sym tmp txt
        typ txx uxa vals vars
    )

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

    ;;; -----------------------------------------------------------------------
    ;;; TrackText:Discard
    ;;;
    ;;; Undoes whatever the tracking has done so far.
    ;;;
    ;;; There are two cases, and which applies is decided by whether a
    ;;; property snapshot was taken:
    ;;;
    ;;;   * props holds a snapshot -- the text existed before the command
    ;;;     started, so it is restored to exactly where and how it was.
    ;;;   * props is nil -- the text was created by this command (typed new,
    ;;;     copied, or the trailing copy in multiple text mode), so it is
    ;;;     deleted.
    ;;;
    ;;; The temporary world-space copy of a nested curve is removed here too.
    ;;;
    ;;; This is called both by the error handler AND by the normal Enter key,
    ;;; because "finish" and "cancel" want exactly the same clean-up of the
    ;;; text still being tracked.
    ;;; -----------------------------------------------------------------------

    (defun TrackText:Discard ( )
        (if (and (= 'vla-object (type txt))
                 (not (vlax-erased-p txt))
                 (vlax-write-enabled-p txt)
            )
            (if (= 'list (type props))
                (foreach pair props
                    (if (vlax-property-available-p txt (car pair) t)
                        (vl-catch-all-apply 'vlax-put-property (cons txt pair))
                    )
                )
                (vl-catch-all-apply 'vla-delete (list txt))
            )
        )
        ;; mat being a list means a temporary copy was made for a nested curve.
        (if (and (= 'list (type mat)) (= 'ename (type ent)) (entget ent))
            (entdel ent)
        )
        (princ)
    )

    (defun *error* ( msg )
        ;; The settings are saved even on an error, so a run that ends badly
        ;; does not throw away adjustments made during it.
        (if (and (= 'list (type defs)) (= 'str (type cfg)) (findfile cfg))
            (TrackText:WriteConfig cfg (mapcar 'eval (mapcar 'car defs)))
        )
        (TrackText:Discard)
        (TrackText:EndUndo)
        (mapcar 'setvar vars vals)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** TRACKTEXT error: " msg " **"))
        )
        (princ)
    )

    ;;; =======================================================================
    ;;;                       M A I N   R O U T I N E
    ;;; =======================================================================

    (setvar 'cmdecho 0)
    (TrackText:StartUndo)

    (cond
        ;;  New text is created on the current layer, and a nested curve is
        ;;  temporarily rebuilt on layer 0. Either being locked would make
        ;;  the command fail part-way, so both are checked up front.
        (   (or (TrackText:LayerLocked (getvar 'clayer))
                (TrackText:LayerLocked "0")
            )
            (princ "\nThe current layer or layer \"0\" is locked.")
        )

        ;;  ---- load the settings -------------------------------------------
        (   (progn
                ;; The defaults, paired with the symbols they are stored in.
                ;; One list drives the file format, the dialog, and the
                ;; type-checking below.
                (setq defs
                   '(
                        (typ     . "txt")             ;; new text object type
                        (jus     . "Middle-Center")   ;; new text justification
                        (off     . 1.0)               ;; offset, as a multiple of text height
                        (rot     . 0.0)               ;; extra rotation, radians
                        (read    . t)                 ;; keep the text readable
                        (mask    . nil)               ;; mtext background mask
                        (maskoff . 1.1)               ;; mask border factor
                        (mult    . nil)               ;; multiple text mode
                        (copy    . nil)               ;; copy the selected text rather than move it
                    )
                )
                (setq cfg (strcat (TrackText:SavePath) "\\YZ_TrackText.cfg"))

                (if (not (findfile cfg))
                    (TrackText:WriteConfig cfg (mapcar 'cdr defs))
                )
                (TrackText:ReadConfig cfg (setq sym (mapcar 'car defs)))

                ;; Anything that came back as the wrong data type is reset to
                ;; its default. A hand-edited or truncated settings file would
                ;; otherwise cause a failure much later, somewhere unrelated.
                ;; Symbols and nils are exempt because a nil default is
                ;; indistinguishable from an unset value.
                (foreach pair defs
                    (if (not (or (= (type (eval (car pair))) (type (cdr pair)))
                                 (member (type (cdr pair)) '(sym nil))
                            )
                        )
                        (set (car pair) (cdr pair))
                    )
                )

                ;; ---- choose the text --------------------------------------
                (while
                    (progn
                        (setvar 'errno 0)
                        (initget "New Settings Exit")
                        (princ (strcat "\nAlign copy: " (if copy "Yes" "No")
                                       " | Multiple text mode: " (if mult "On" "Off")))
                        (setq sel (entsel "\nSelect text to align [New/Settings] <Exit>: "))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\nMissed, try again.")
                            )
                            (   (= 'list (type sel))
                                (setq ent (car sel)
                                      enx (entget ent)
                                )
                                (cond
                                    (   (not (wcmatch (cdr (assoc 0 enx)) "TEXT,MTEXT"))
                                        (princ "\nThat must be text or mtext.")
                                    )
                                    (   (TrackText:LayerLocked (cdr (assoc 8 enx)))
                                        (princ "\nThat object is on a locked layer.")
                                    )
                                    (   t
                                        ;; Snapshot the properties now, so a
                                        ;; cancel can put the text back
                                        ;; exactly as it was.
                                        (setq txt   (vlax-ename->vla-object ent)
                                              props (TrackText:Snapshot txt)
                                        )
                                        nil
                                    )
                                )
                            )
                            (   (= "Exit" sel) nil)
                            (   (= "Settings" sel)
                                (mapcar 'set sym (TrackText:Settings (mapcar 'eval sym)))
                            )
                            (   (= "New" sel)
                                ;; Keep asking while the typed string is blank.
                                (= "" (vl-string-trim " \t\n"
                                          (setq str (getstring t "\nSpecify text <Select>: "))))
                            )
                        )
                    )
                )
                ;; Nothing to work with: neither an existing object nor a
                ;; non-blank new string.
                (not (or (= 'vla-object (type txt))
                         (and (= 'str (type str)) (/= "" (vl-string-trim " \t\n" str)))
                    )
                )
            )
            (TrackText:WriteConfig cfg (mapcar 'eval sym))
            (princ "\nCancelled.")
        )

        ;;  ---- choose the curve --------------------------------------------
        ;;  nentselp rather than entsel, so a curve nested inside a block or
        ;;  xref can be picked. It also returns the transformation matrix that
        ;;  the nested case needs.
        (   (progn
                (while
                    (progn
                        (setvar 'errno 0)
                        (setq sel (nentselp "\nSelect curve to align text to <Exit>: "))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\nMissed, try again.")
                            )
                            (   (= 'ename (type (car sel)))
                                ;; A vertex is accepted because its owning
                                ;; polyline is what will actually be used.
                                ;; Everything else must answer to the curve
                                ;; functions, which getEndParam tests for
                                ;; without needing a list of valid types.
                                (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 cannot be used as a track.")
                                )
                            )
                        )
                    )
                )
                (null sel)
            )
            (princ "\nCancelled.")
        )

        ;;  ---- resolve the curve to something measurable -------------------
        (   (not
                (or
                    ;; Nested: rebuild it in world coordinates.
                    (and (setq mat (caddr sel))
                         (setq ent (TrackText:CopyNested (car sel) mat))
                    )
                    ;; A polyline vertex: use its owner, group 330.
                    (and (= "VERTEX" (cdr (assoc 0 (entget (car sel)))))
                         (setq ent (cdr (assoc 330 (entget (car sel)))))
                    )
                    ;; Ordinary top-level curve.
                    (setq ent (car sel))
                )
            )
            (princ "\nUnable to rebuild the nested curve.")
        )

        (   t
            ;; ---- get the text object ready -------------------------------
            (cond
                ;;  An existing object being moved: nothing to do.
                (   (and txt (not copy)))

                ;;  An existing object being copied: work on the copy, and
                ;;  clear the snapshot so a cancel deletes the copy rather
                ;;  than restoring the original.
                (   (and txt copy)
                    (setq txt   (vla-copy txt)
                          props nil
                    )
                )

                ;;  A new single-line TEXT.
                (   (= "txt" typ)
                    (setq txt
                        (vla-addtext
                            (vlax-get-property (TrackText:Doc)
                                (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                            str
                            (vlax-3d-point (trans (cadr sel) 1 0))
                            (TrackText:StyleHeight (getvar 'textstyle))
                        )
                    )
                    (vla-put-alignment txt
                        (eval (cadr (assoc jus
                           '(
                                ("Left"          acalignmentleft)
                                ("Center"        acalignmentcenter)
                                ("Right"         acalignmentright)
                                ("Middle"        acalignmentmiddle)
                                ("Top-Left"      acalignmenttopleft)
                                ("Top-Center"    acalignmenttopcenter)
                                ("Top-Right"     acalignmenttopright)
                                ("Middle-Left"   acalignmentmiddleleft)
                                ("Middle-Center" acalignmentmiddlecenter)
                                ("Middle-Right"  acalignmentmiddleright)
                                ("Bottom-Left"   acalignmentbottomleft)
                                ("Bottom-Center" acalignmentbottomcenter)
                                ("Bottom-Right"  acalignmentbottomright)
                            )
                        )))
                    )
                )

                ;;  A new MTEXT.
                (   t
                    (setq txt
                        (vla-addmtext
                            (vlax-get-property (TrackText:Doc)
                                (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                            (vlax-3d-point (trans (cadr sel) 1 0))
                            ;; MText needs a defined width. Measuring the
                            ;; string with textbox and using that width stops
                            ;; the text wrapping onto a second line -- a full
                            ;; stop is appended first so a trailing space is
                            ;; measured rather than ignored.
                            (   (lambda ( box ) (- (caadr box) (caar box)))
                                (textbox
                                    (list
                                        (cons 01 (strcat str "."))
                                        (cons 40 (TrackText:StyleHeight (getvar 'textstyle)))
                                        (cons 07 (getvar 'textstyle))
                                    )
                                )
                            )
                            str
                        )
                    )
                    (vla-put-attachmentpoint txt
                        (eval (cadr (assoc jus
                           '(
                                ("Top-Left"      acattachmentpointtopleft)
                                ("Top-Center"    acattachmentpointtopcenter)
                                ("Top-Right"     acattachmentpointtopright)
                                ("Middle-Left"   acattachmentpointmiddleleft)
                                ("Middle-Center" acattachmentpointmiddlecenter)
                                ("Middle-Right"  acattachmentpointmiddleright)
                                ("Bottom-Left"   acattachmentpointbottomleft)
                                ("Bottom-Center" acattachmentpointbottomcenter)
                                ("Bottom-Right"  acattachmentpointbottomright)
                            )
                        )))
                    )
                    (vla-put-height txt (TrackText:StyleHeight (getvar 'textstyle)))

                    ;; The background mask border factor has no ActiveX
                    ;; property, so it is written straight into DXF group 45.
                    (if mask
                        (progn
                            (vla-put-backgroundfill txt :vlax-true)
                            (setq txx (entget (vlax-vla-object->ename txt)))
                            (if (assoc 45 txx)
                                (entmod (subst (cons 45 maskoff) (assoc 45 txx) txx))
                                (entmod (append txx (list (cons 45 maskoff))))
                            )
                        )
                    )
                )
            )

            ;; ---- work out what drives the text's position ----------------
            ;; Left-justified TEXT is positioned by its InsertionPoint;
            ;; every other justification, and all MText, by the alignment
            ;; point. Writing the wrong one moves nothing.
            (if (and (= "AcDbText" (vla-get-objectname txt))
                     (/= acalignmentleft (vla-get-alignment txt))
                )
                (setq prop 'textalignmentpoint)
                (setq prop 'insertionpoint)
            )

            (setq hgt (vla-get-height txt)
                  nrm (trans '(0.0 0.0 1.0) 1 0 t)
                  ;; TEXT stores its rotation relative to its own extrusion
                  ;; plane, so working in a rotated UCS needs the UCS X-axis
                  ;; angle added back in. MText does not, hence the zero.
                  uxa (if (= "AcDbText" (vla-get-objectname txt))
                          (angle '(0.0 0.0 0.0) (trans (getvar 'ucsxdir) 0 nrm t))
                          0.0
                      )
                  msg (strcat
                          "\n[+/-] or [O]ffset | [</>] or [R]otation | Readabilit[y]"
                          (if (= "AcDbMText" (vla-get-objectname txt))
                              " | [B]ackground mask"
                              ""
                          )
                          " | <[E]xit>: "
                      )
            )
            (princ msg)

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

                        ;;  ---- mouse moved, or clicked ----
                        (   (or (= 5 gr1) (= 3 gr1))
                            (setq pt2 (trans gr2 1 0)
                                  pt1 (vlax-curve-getclosestpointto ent pt2)
                            )
                            ;; With the cursor exactly on the curve the
                            ;; direction is undefined and the division below
                            ;; would fail, so that frame is simply skipped.
                            (if (not (equal pt1 pt2 1e-8))
                                (progn
                                    ;; dis is the fraction along the vector
                                    ;; from curve to cursor that puts the text
                                    ;; at exactly (height x factor) away.
                                    (setq dis (/ (* hgt off) (distance pt1 pt2))
                                          ;; Less ninety degrees turns the
                                          ;; text from pointing away from the
                                          ;; curve to running along it.
                                          ang (+ (angle (trans pt1 0 1) gr2)
                                                 uxa rot (/ pi -2.0))
                                    )
                                    (vlax-put-property txt prop
                                        (vlax-3d-point
                                            (mapcar '(lambda ( a b ) (+ a (* (- b a) dis)))
                                                    pt1 pt2)
                                        )
                                    )
                                    (vla-put-rotation txt
                                        (if read (TrackText:Readable ang) ang)
                                    )
                                )
                            )
                            (cond
                                ;;  Just a move: keep going.
                                (   (= 5 gr1) t)
                                ;;  A click in multiple text mode: the current
                                ;;  text is committed where it stands and a
                                ;;  fresh copy starts tracking. Clearing the
                                ;;  snapshot means the copy, not the original,
                                ;;  is what a later cancel discards.
                                (   mult
                                    (setq txt   (vla-copy txt)
                                          props nil
                                    )
                                    t
                                )
                                ;;  A click in single mode ends the command,
                                ;;  leaving the text where it is.
                            )
                        )

                        ;;  ---- a key was pressed ----
                        (   (= 2 gr1)
                            (cond
                                (   (member gr2 '(043 061))          ;; + =
                                    (setq off (+ off 0.1))
                                )
                                (   (member gr2 '(045 095))          ;; - _
                                    (setq off (- off 0.1))
                                )
                                (   (member gr2 '(044 060))          ;; , <
                                    (setq rot (+ rot (/ pi 4.0)))
                                )
                                (   (member gr2 '(046 062))          ;; . >
                                    (setq rot (- rot (/ pi 4.0)))
                                )
                                ;;  Enter, Space or E: finish. The text still
                                ;;  being tracked is discarded, which in
                                ;;  single mode returns the original to where
                                ;;  it started and in multiple mode removes
                                ;;  the trailing copy.
                                (   (member gr2 '(013 032 069 101))
                                    (TrackText:Discard)
                                    nil
                                )
                                (   (member gr2 '(089 121))          ;; Y
                                    (princ
                                        (if (setq read (not read))
                                            "\n<Text readability on>"
                                            "\n<Text readability off>"
                                        )
                                    )
                                    (princ msg)
                                )
                                (   (member gr2 '(066 098))          ;; B
                                    (if (= "AcDbMText" (vla-get-objectname txt))
                                        (progn
                                            ;; BackgroundFill reads as 0 or
                                            ;; -1; the bitwise complement
                                            ;; flips between them.
                                            (vlax-put txt 'backgroundfill
                                                (~ (vlax-get txt 'backgroundfill)))
                                            (princ
                                                (if (setq mask (= -1 (vlax-get txt 'backgroundfill)))
                                                    "\n<Background mask on>"
                                                    "\n<Background mask off>"
                                                )
                                            )
                                        )
                                        (princ "\nA background mask is only available on mtext.")
                                    )
                                    (princ msg)
                                )
                                (   (member gr2 '(082 114))          ;; R
                                    (if (setq tmp (getangle (strcat "\nSpecify rotation <"
                                                                    (angtos rot) ">: ")))
                                        (setq rot tmp)
                                    )
                                    (princ msg)
                                )
                                (   (member gr2 '(079 111))          ;; O
                                    (if (setq tmp (getdist (strcat "\nSpecify offset <"
                                                                   (rtos (* hgt off)) ">: ")))
                                        ;; Stored as a factor of the text
                                        ;; height, so it survives a change of
                                        ;; text size.
                                        (setq off (/ tmp hgt))
                                    )
                                    (princ msg)
                                )
                                (   t t)
                            )
                        )

                        ;;  ---- right-click or menu pick: cancel ----
                        (   (member gr1 '(11 25))
                            (TrackText:Discard)
                            nil
                        )

                        (   t t)
                    )
                )
            )

            ;; The temporary world-space copy of a nested curve has served
            ;; its purpose.
            (if mat (entdel ent))
            (TrackText:WriteConfig cfg (mapcar 'eval sym))
        )
    )

    (TrackText:EndUndo)
    (mapcar 'setvar vars vals)
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; TrackText:Readable
;;;
;;; Returns an angle adjusted so text drawn at it always reads left to right.
;;;
;;; The angle is first normalised into the range 0 to 2*pi. Anything landing
;;; in the left half of the circle -- between 90 and 270 degrees -- would put
;;; the text upside down, so 180 degrees is added and the test repeated. It
;;; recurses rather than looping because the addition can itself push the
;;; angle back out of range.
;;; ---------------------------------------------------------------------------

(defun TrackText:Readable ( a )
    (   (lambda ( a )
            (if (and (< (* pi 0.5) a) (<= a (* pi 1.5)))
                (TrackText:Readable (+ a pi))
                a
            )
        )
        (rem (+ a pi pi) (+ pi pi))
    )
)

;;; ---------------------------------------------------------------------------
;;; TrackText:StyleHeight
;;;
;;; Returns the height new text should be created at, for a given text style.
;;;
;;; A style with a fixed height reports it in DXF group 40. A height of zero
;;; means the style is variable-height, and the drawing's TEXTSIZE is used
;;; instead.
;;;
;;; An annotative style needs a further correction: its stored height is the
;;; PAPER height, so it is divided by the current annotation scale to give
;;; the model-space height the object must actually be created at.
;;; ---------------------------------------------------------------------------

(defun TrackText:StyleHeight ( sty / hgt )
    (if (zerop (setq hgt (cdr (assoc 40 (tblsearch "style" sty)))))
        (setq hgt (getvar 'textsize))
    )
    (if (TrackText:Annotative sty)
        (/ hgt (cond ((getvar 'cannoscalevalue)) (1.0)))
        hgt
    )
)

;;; ---------------------------------------------------------------------------
;;; TrackText:Annotative
;;;
;;; Returns non-nil if a text style is annotative.
;;;
;;; There is no system variable or table flag for this: the property is
;;; stored as extended entity data under the "AcadAnnotative" application,
;;; where group 1070 holds 1 for annotative and 0 for not. The data is read
;;; reversed because the flag is the last 1070 in the group.
;;; ---------------------------------------------------------------------------

(defun TrackText:Annotative ( sty )
    (and (setq sty (tblobjname "style" sty))
         (setq sty (cadr (assoc -3 (entget sty '("AcadAnnotative")))))
         (= 1 (cdr (assoc 1070 (reverse sty))))
    )
)

;;; ---------------------------------------------------------------------------
;;; TrackText:CopyNested
;;;
;;; Rebuilds a curve that lives inside a block reference as a temporary
;;; top-level object in world coordinates, and returns its entity name.
;;;
;;; This is necessary because the vlax-curve functions measure an object in
;;; the coordinate system it is stored in. For a nested object that is the
;;; block definition's own space, so distances and points would come back in
;;; the wrong place and at the wrong scale.
;;;
;;; nentselp supplies the 4x3 transformation matrix from that space to the
;;; world, which is applied to the rebuilt copy with TransformBy.
;;;
;;; An old-style POLYLINE is a chain of entities -- the header, one VERTEX
;;; per point, and a SEQEND -- and every one must be recreated in order for
;;; the result to be a valid polyline. Group 66 set to 1 on the header is
;;; what marks that chain as present.
;;;
;;;   ent - the nested entity name
;;;   mat - the transformation matrix from nentselp
;;; ---------------------------------------------------------------------------

(defun TrackText:CopyNested ( ent mat / enx new )
    (if (= 1 (cdr (assoc 66 (setq enx (entget ent)))))
        (progn
            ;; The header, then every vertex, then the SEQEND. The entity
            ;; name of the whole polyline is the SEQEND's owner.
            (TrackText:Remake enx)
            (setq ent (entnext ent)
                  enx (entget  ent)
            )
            (while (/= "SEQEND" (cdr (assoc 0 enx)))
                (TrackText:Remake enx)
                (setq ent (entnext ent)
                      enx (entget  ent)
                )
            )
            (setq new (cdr (assoc 330 (entget (TrackText:Remake enx)))))
        )
        (setq new (TrackText:Remake enx))
    )
    (if new
        (vla-transformby (vlax-ename->vla-object new) (vlax-tmatrix mat))
    )
    new
)

;;; ---------------------------------------------------------------------------
;;; TrackText:Remake
;;;
;;; Creates a copy of an entity from its data list, stripped of everything
;;; that could disturb the drawing.
;;;
;;; Removed and replaced with neutral values: handle, linetype, layer,
;;; thickness, linetype scale, colour, application-defined groups, and
;;; lineweight. Any group whose value is an entity name is dropped as well,
;;; since it would point at something in the block rather than in the copy.
;;;
;;; The result is an invisible-in-practice object on layer 0 that exists only
;;; long enough to be measured, and is deleted when the command ends.
;;; ---------------------------------------------------------------------------

(defun TrackText:Remake ( enx )
    (entmakex
        (append
            (vl-remove-if
               '(lambda ( pair )
                    (or (member (car pair) '(005 006 008 039 048 062 102 370))
                        (= 'ename (type (cdr pair)))
                    )
                )
                enx
            )
           '(
                (006 . "CONTINUOUS")
                (008 . "0")
                (039 . 0.0)
                (048 . 1.0)
                (062 . 7)
                (370 . 0)
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; TrackText:Snapshot
;;;
;;; Records the properties needed to put a text object back exactly as it
;;; was: both possible position properties, the background fill state, and
;;; the rotation.
;;;
;;; Properties the object does not have are omitted rather than recorded as
;;; nil, so restoring never tries to write something meaningless.
;;; ---------------------------------------------------------------------------

(defun TrackText:Snapshot ( obj )
    (vl-remove nil
        (mapcar
           '(lambda ( prp )
                (if (vlax-property-available-p obj prp t)
                    (list prp (vlax-get-property obj prp))
                )
            )
           '(insertionpoint textalignmentpoint backgroundfill rotation)
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; TrackText:LayerLocked
;;;
;;; Returns non-nil if the named layer is locked. Bit 4 of DXF group 70 on
;;; the layer table record is the lock flag.
;;; ---------------------------------------------------------------------------

(defun TrackText:LayerLocked ( lay / def )
    (and (setq def (tblsearch "layer" lay))
         (= 4 (logand 4 (cdr (assoc 70 def))))
    )
)

;;; ===========================================================================
;;;                       S E T T I N G S   D I A L O G
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; TRACKSET / TrackText:Settings
;;;
;;; Sets everything that applies to newly created text, plus the two mode
;;; switches. Values are validated before the dialog closes, so a mistake can
;;; be corrected without losing everything else that was set.
;;;
;;;   lst - current values, in the order
;;;         (type justification offset rotation readable mask maskoffset
;;;          multiple copy)
;;;
;;; Returns the same list, updated if OK was pressed and unchanged otherwise.
;;; ---------------------------------------------------------------------------

(defun c:TrackSet ( / cfg defs sym )
    (setq defs
       '(
            (typ     . "txt")
            (jus     . "Middle-Center")
            (off     . 1.0)
            (rot     . 0.0)
            (read    . t)
            (mask    . nil)
            (maskoff . 1.1)
            (mult    . nil)
            (copy    . nil)
        )
    )
    (setq cfg (strcat (TrackText:SavePath) "\\YZ_TrackText.cfg")
          sym (mapcar 'car defs)
    )
    (if (not (findfile cfg))
        (TrackText:WriteConfig cfg (mapcar 'cdr defs))
    )
    (TrackText:ReadConfig cfg sym)
    (foreach pair defs
        (if (not (or (= (type (eval (car pair))) (type (cdr pair)))
                     (member (type (cdr pair)) '(sym nil))))
            (set (car pair) (cdr pair))
        )
    )
    (mapcar 'set sym (TrackText:Settings (mapcar 'eval sym)))
    (TrackText:WriteConfig cfg (mapcar 'eval sym))
    (princ "\nTrackText settings saved.")
    (princ)
)

(defun TrackText:Settings

    ( lst /
        *error* TrackText:SetType TrackText:SetMask
        copy dch dcl des just jus mask maskoff maskstr mult off offstr
        read rot rotstr typ
    )

    (defun *error* ( msg )
        (if (= 'file (type des)) (close des))
        (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
        (if (and (= 'str (type dcl)) (findfile dcl)) (vl-file-delete dcl))
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** TRACKSET error: " msg " **"))
        )
        (princ)
    )

    (cond
        ;;  The dialog is written to a uniquely named temporary file, loaded,
        ;;  and deleted afterwards, so nothing is left behind and two AutoCAD
        ;;  sessions cannot collide over it.
        (   (not
                (and
                    (setq dcl (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open dcl "w"))
                    (progn
                        (foreach line
                           '(
                                "edt : edit_box { edit_width = 8; edit_limit = 10; alignment = left; }"
                                "but : button   { width = 10; fixed_width = true; }"
                                ""
                                "atc : dialog"
                                "{"
                                "    label = \"TrackText Settings\";"
                                "    width = 30;"
                                "    spacer;"
                                "    : text { label = \"Object type for new text:\"; }"
                                "    : radio_row"
                                "    {"
                                "        alignment = centered; fixed_width = true;"
                                "        : radio_button { key = \"txt\"; label = \"Text\";  }"
                                "        : radio_button { key = \"mtx\"; label = \"MText\"; }"
                                "    }"
                                "    spacer;"
                                "    : text { label = \"Justification for new text:\"; }"
                                "    : popup_list { key = \"jus\"; }"
                                "    spacer;"
                                "    : edt { key = \"off\"; label = \"Offset Factor:\"; }"
                                "    : edt { key = \"rot\"; label = \"Text Rotation:\"; }"
                                "    spacer;"
                                "    : toggle { key = \"red\"; label = \"Retain text readability\"; }"
                                "    : toggle { key = \"bak\"; label = \"MText background mask\"; }"
                                "    : edt    { key = \"bof\"; label = \"Mask Offset:\"; }"
                                "    spacer;"
                                "    : toggle { key = \"mtp\"; label = \"Multiple text mode\"; }"
                                "    : toggle { key = \"cpy\"; label = \"Copy selected text\"; }"
                                "    spacer;"
                                "    : row"
                                "    {"
                                "        alignment = centered; fixed_width = true;"
                                "        : but { key = \"accept\"; label = \"OK\";     is_default = true; }"
                                "        : but { key = \"cancel\"; label = \"Cancel\"; is_cancel  = true; }"
                                "    }"
                                "}"
                            )
                            (write-line line des)
                        )
                        (setq des (close des))
                        (< 0 (setq dch (load_dialog dcl)))
                    )
                    (new_dialog "atc" dch)
                )
            )
            (princ "\nUnable to create the settings dialog.")
        )

        (   t
            (mapcar 'set '(typ jus off rot read mask maskoff mult copy) lst)

            ;;; ---------------------------------------------------------------
            ;;; TrackText:SetType
            ;;;
            ;;; Called when the object type changes, and once at the start.
            ;;;
            ;;; TEXT and MTEXT support different justifications -- Left,
            ;;; Center, Right and Middle exist only for TEXT -- so the list is
            ;;; rebuilt each time. The current justification is kept if it is
            ;;; still valid, and falls back to the first entry if not.
            ;;;
            ;;; The mask controls are only meaningful for MText, so they are
            ;;; greyed out otherwise.
            ;;; ---------------------------------------------------------------

            (defun TrackText:SetType ( val )
                (setq typ  val
                      just (TrackText:JustList typ)
                )
                (set_tile "jus"
                    (itoa (cond ((vl-position jus just)) ((setq jus (car just)) 0)))
                )
                (if (= "mtx" typ)
                    (progn
                        (mode_tile "bak" 0)
                        (mode_tile "bof" (if mask 0 1))
                    )
                    (progn
                        (mode_tile "bak" 1)
                        (mode_tile "bof" 1)
                    )
                )
                (princ)
            )

            ;;; ---------------------------------------------------------------
            ;;; TrackText:SetMask
            ;;;
            ;;; The mask offset only applies when the mask is on, so its box
            ;;; follows the toggle.
            ;;; ---------------------------------------------------------------

            (defun TrackText:SetMask ( val )
                (mode_tile "bof" (if (setq mask (= "1" val)) 0 1))
                (princ)
            )

            (set_tile typ "1")
            (TrackText:SetType typ)
            (action_tile "jus" "(setq jus (nth (atoi $value) just))")
            (action_tile "txt" "(TrackText:SetType $key)")
            (action_tile "mtx" "(TrackText:SetType $key)")

            ;; The numeric fields are held as STRINGS while the dialog is
            ;; open and only converted when OK is pressed. Converting on every
            ;; keystroke would reject a half-typed number.
            (set_tile    "off" (setq offstr (rtos off)))
            (action_tile "off" "(setq offstr $value)")

            (set_tile    "rot" (setq rotstr (angtos rot)))
            (action_tile "rot" "(setq rotstr $value)")

            (set_tile    "bof" (setq maskstr (rtos maskoff)))
            (action_tile "bof" "(setq maskstr $value)")

            (set_tile "bak" (if mask "1" "0"))
            (TrackText:SetMask (if mask "1" "0"))
            (action_tile "bak" "(TrackText:SetMask $value)")

            ;; The tile key and the variable name are the same string for
            ;; these three, so one loop both fills the tile and builds its
            ;; callback.
            (mapcar
               '(lambda ( key val )
                    (set_tile key (if val "1" "0"))
                )
               '("red" "mtp" "cpy")
                (list read mult copy)
            )
            (action_tile "red" "(setq read (= \"1\" $value))")
            (action_tile "mtp" "(setq mult (= \"1\" $value))")
            (action_tile "cpy" "(setq copy (= \"1\" $value))")

            ;; Validation happens here rather than after the dialog closes, so
            ;; the offending field can be highlighted and corrected in place.
            (action_tile "accept"
                (vl-prin1-to-string
                   '(cond
                        (   (not (distof offstr))
                            (alert "The offset factor must be a number.")
                            (mode_tile "off" 2)
                        )
                        (   (not (angtof rotstr))
                            (alert "The text rotation must be a valid angle.")
                            (mode_tile "rot" 2)
                        )
                        ;;  AutoCAD only accepts mask border factors from 1 to 5.
                        (   (not (and (distof maskstr) (<= 1.0 (distof maskstr) 5.0)))
                            (alert "The mask offset must be a number between 1 and 5.")
                            (mode_tile "bof" 2)
                        )
                        (   (setq off     (distof offstr)
                                  rot     (angtof rotstr)
                                  maskoff (distof maskstr)
                            )
                            (done_dialog 1)
                        )
                    )
                )
            )
            (action_tile "cancel" "(done_dialog 0)")

            (if (= 1 (start_dialog))
                (setq lst (list typ jus off rot read mask maskoff mult copy))
            )
        )
    )

    (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
    (if (and (= 'str (type dcl)) (findfile dcl)) (vl-file-delete dcl))
    lst
)

;;; ---------------------------------------------------------------------------
;;; TrackText:JustList
;;;
;;; Fills the justification popup list and returns its contents, so the
;;; caller can convert between the selected index and the name.
;;;
;;; TEXT has four justifications that MText does not: Left, Center, Right and
;;; Middle. The nine grid positions are common to both.
;;; ---------------------------------------------------------------------------

(defun TrackText:JustList ( typ / lst )
    (setq lst
        (append
            (if (= "txt" typ) '("Left" "Center" "Right" "Middle"))
           '(
                "Top-Left"    "Top-Center"    "Top-Right"
                "Middle-Left" "Middle-Center" "Middle-Right"
                "Bottom-Left" "Bottom-Center" "Bottom-Right"
            )
        )
    )
    (start_list "jus")
    (foreach itm lst (add_list itm))
    (end_list)
    lst
)

;;; ---------------------------------------------------------------------------
;;; TrackText:WriteConfig / TrackText:ReadConfig
;;;
;;; Save and reload the settings, one value per line.
;;;
;;; Values are written in printed form and read back with read, which
;;; round-trips strings, numbers, T and nil faithfully. Reals are written to
;;; eight decimal places with DIMZIN set to suppress trailing zeros, so the
;;; drawing's current precision setting cannot alter the value that is
;;; stored.
;;;
;;; The read is forgiving: a short or hand-edited file leaves the remaining
;;; settings untouched rather than raising an error.
;;; ---------------------------------------------------------------------------

(defun TrackText:WriteConfig ( cfg lst / TrackText:ToString des )

    (defun TrackText:ToString ( x / zin )
        (cond
            (   (= 'int (type x)) (itoa x))
            (   (= 'real (type x))
                (setq zin (getvar 'dimzin))
                (setvar 'dimzin 8)
                (setq x (rtos x 2 8))
                (setvar 'dimzin zin)
                x
            )
            (   (vl-prin1-to-string x))
        )
    )

    (if (setq des (open cfg "w"))
        (progn
            (foreach x lst (write-line (TrackText:ToString x) des))
            (close des)
            t
        )
        (princ "\nUnable to write the settings file - defaults will be used.")
    )
)

(defun TrackText:ReadConfig ( cfg syms / des line )
    (if (and (setq cfg (findfile cfg))
             (setq des (open cfg "r"))
        )
        (progn
            (foreach sym syms
                (if (setq line (read-line des))
                    (   (lambda ( val )
                            (if (not (vl-catch-all-error-p val)) (set sym val))
                        )
                        (vl-catch-all-apply 'read (list line))
                    )
                )
            )
            (close des)
            t
        )
    )
)

(princ "\nTrackText loaded. TRACKTEXT to align text to a curve, TRACKSET for options.")
(princ)

;;; ---------------------------------------------------------------------------
;;; End of file
;;; ---------------------------------------------------------------------------