;;; ---------------------------------------------------------------------------
;;; SerialTag.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; INCREMENTING NUMBER AND LETTER TAGS
;;;
;;; PURPOSE
;;;   Places a running sequence of labels - 1, 2, 3 or A, B, C or GL-1, GL-2 -
;;;   one at each point you pick, optionally enclosed in a circle or a hexagon.
;;;   Grid references, door numbers, item marks, revision letters, detail keys:
;;;   anything that counts up as you go round the drawing.
;;;
;;; HOW IT WORKS
;;;   1. You set the sequence up once - what kind of counter, where it starts,
;;;      how much it steps, any prefix or suffix, and whether each tag is
;;;      enclosed. Then you pick points and it places them, counting as it goes,
;;;      until you press Enter.
;;;
;;;   2. Three counter styles:
;;;
;;;        Number    whole numbers, stepping by any whole amount
;;;        Decimal   real numbers, stepping by any amount, to 3 places
;;;        Letter    A, B, C ... and correctly on past Z into AA, AB, AC
;;;
;;;      That last point matters. The routine this replaces stopped dead at Z
;;;      and reset to A, which silently produced two tags called A on the same
;;;      drawing once you passed twenty-six.
;;;
;;;   3. Prefix and suffix are plain text wrapped round the counter, so "GL-",
;;;      counter, "" gives GL-1, GL-2, GL-3, and "", counter, " TYP" gives
;;;      1 TYP, 2 TYP.
;;;
;;;   4. The enclosure grows with the label. A single digit gets a small circle,
;;;      three digits or a long prefix gets a bigger one, so the text never
;;;      touches the ring.
;;;
;;; THE SEQUENCE CARRIES ON
;;;   Where the counter got to is remembered, so you can stop, do something else
;;;   and start again where you left off. The next run offers the number after
;;;   the last one placed.
;;;
;;; SIZE
;;;   Text height is DIMTXT times DIMSCALE, unless the current text style has a
;;;   fixed height, in which case the style wins. The enclosure is proportional
;;;   to that, so the whole tag scales together.
;;;
;;;   SERIALTAG  - place an incrementing sequence of tags
;;; ---------------------------------------------------------------------------

;;; ---------------------------------------------------------------------------
;;; SESSION MEMORY
;;; ---------------------------------------------------------------------------

(if (null *SerialTag:Prefs*)
    (setq *SerialTag:Prefs*
        (list (cons "STYLE"  "Number")   ; Number | Decimal | Letter
              (cons "START"  1)          ; whole-number start, or letter index
              (cons "RSTART" 1.0)        ; decimal start
              (cons "STEP"   1)          ; whole-number step
              (cons "RSTEP"  1.0)        ; decimal step
              (cons "PREFIX" "")
              (cons "SUFFIX" "")
              (cons "ENCLOSE" "None")    ; None | Circle | Hexagon
        )
    )
)

(defun SerialTag:Get ( key ) (cdr (assoc key *SerialTag:Prefs*)))

(defun SerialTag:Put ( key val )
    (setq *SerialTag:Prefs*
        (cons (cons key val)
              (vl-remove-if '(lambda (p) (= (car p) key)) *SerialTag:Prefs*)))
    val
)

;;; ---------------------------------------------------------------------------
;;; LETTER SEQUENCES
;;;
;;; Spreadsheet-column counting: A to Z, then AA to AZ, then BA and so on, with
;;; no ceiling. This is base-26 arithmetic with one wrinkle - there is no digit
;;; for zero, so A is 1 rather than 0 and every division has to step back by one
;;; before taking the remainder. That single (1- n) is what separates correct
;;; A/B/.../Z/AA counting from the naive version that produces A, B, ... Z, BA.
;;; ---------------------------------------------------------------------------

;;; Zero-based index to letters: 0 -> "A", 25 -> "Z", 26 -> "AA".
(defun SerialTag:ToLetters ( n / s )
    (setq s "" n (1+ n))
    (while (> n 0)
        (setq n (1- n)
              s (strcat (chr (+ 65 (rem n 26))) s)
              n (/ n 26)))
    s
)

;;; Letters back to a zero-based index. Returns nil for anything that is not
;;; purely alphabetic, so the caller can reject it rather than tag the drawing
;;; with something meaningless.
(defun SerialTag:FromLetters ( s / n i c ok )
    (setq s (strcase s) n 0 i 1 ok (> (strlen s) 0))
    (while (and ok (<= i (strlen s)))
        (setq c (ascii (substr s i 1)))
        (if (and (>= c 65) (<= c 90))
            (setq n (+ (* n 26) (- c 64)))
            (setq ok nil))
        (setq i (1+ i)))
    (if ok (1- n))
)

;;; ---------------------------------------------------------------------------
;;; BUILDING THE LABEL
;;;
;;; Returns the full text for the tag at position `step` in the sequence, where
;;; step 0 is the first one placed.
;;; ---------------------------------------------------------------------------

(defun SerialTag:Label ( step / core )
    (setq core
        (cond
            ((= (SerialTag:Get "STYLE") "Letter")
             (SerialTag:ToLetters (+ (SerialTag:Get "START")
                                     (* step (SerialTag:Get "STEP")))))

            ((= (SerialTag:Get "STYLE") "Decimal")
             (rtos (+ (SerialTag:Get "RSTART")
                      (* step (SerialTag:Get "RSTEP"))) 2 3))

            ;; ITOA, not RTOS - the counter is a whole number and must print as
            ;; one. The original passed the raw integer straight into the entity
            ;; definition, where DXF group 1 requires a string; that failed to
            ;; create the text at all whenever no prefix or suffix was set.
            (t (itoa (+ (SerialTag:Get "START")
                        (* step (SerialTag:Get "STEP")))))
        )
    )
    (strcat (SerialTag:Get "PREFIX") core (SerialTag:Get "SUFFIX"))
)

;;; ---------------------------------------------------------------------------
;;; DRAWING
;;; ---------------------------------------------------------------------------

;;; Text height in drawing units, honouring a fixed-height text style.
(defun SerialTag:Height ( / styleH h )
    (setq styleH (cdr (assoc 40 (tblsearch "style" (getvar "TEXTSTYLE")))))
    (if (and styleH (> styleH 0.0))
        styleH
        (progn
            (setq h (* (getvar "DIMTXT") (getvar "DIMSCALE")))
            (if (> h 0.0) h 0.18)))
)

;;; Middle-centred text, built directly rather than through the TEXT command so
;;; it cannot be disturbed by a running osnap or a fixed-height style prompting
;;; differently.
(defun SerialTag:Text ( pt height s )
    (entmake
        (list (cons 0 "TEXT") (cons 100 "AcDbEntity")
              (cons 8 (getvar "CLAYER"))
              (cons 100 "AcDbText")
              (cons 10 pt) (cons 40 height) (cons 1 s)
              (cons 7 (getvar "TEXTSTYLE"))
              (cons 72 1) (cons 11 pt)          ; horizontally centred
              (cons 100 "AcDbText") (cons 73 2) ; vertically middle
        ))
)

;;; Enclosure radius, grown to suit the length of the label so a three-digit
;;; number or a prefixed one is not cramped inside a ring sized for "1".
(defun SerialTag:Radius ( height s )
    (max (* height 1.4)
         (* height (+ 1.0 (* 0.3 (strlen s)))))
)

(defun SerialTag:Enclose ( pt height s kind / r )
    (setq r (SerialTag:Radius height s))
    (cond
        ((= kind "Circle")
         (entmake (list (cons 0 "CIRCLE") (cons 100 "AcDbEntity")
                        (cons 8 (getvar "CLAYER"))
                        (cons 100 "AcDbCircle")
                        (cons 10 pt) (cons 40 r))))
        ((= kind "Hexagon")
         ;; POLYGON has no ENTMAKE equivalent, so the command is used - but with
         ;; the circumscribed option so the hexagon encloses the same radius the
         ;; circle would, and the two enclosures come out visually consistent.
         (command "_.POLYGON" 6 pt "_C" (polar pt 0.0 r)))
    )
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; SETTINGS
;;; ---------------------------------------------------------------------------

;;; A one-line summary of the sequence, shown at the option prompt so the state
;;; is always visible without having to step through every setting to check it.
(defun SerialTag:Summary ( )
    (strcat (SerialTag:Get "STYLE")
            ", next " (SerialTag:Label 0)
            ", step "
            (if (= (SerialTag:Get "STYLE") "Decimal")
                (rtos (SerialTag:Get "RSTEP") 2 3)
                (itoa (SerialTag:Get "STEP")))
            (if (= (SerialTag:Get "ENCLOSE") "None")
                ""
                (strcat ", in a " (strcase (SerialTag:Get "ENCLOSE") t))))
)

;;; ---------------------------------------------------------------------------
;;; MAIN COMMAND
;;; ---------------------------------------------------------------------------

(defun c:SERIALTAG ( / *error* vars vals opt v s height step pt label done )

    (setq vars '("CMDECHO" "OSMODE" "BLIPMODE" "CLAYER")
          vals (mapcar 'getvar vars))

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

    ;; Settings loop. Everything stays adjustable until Place is chosen, so a
    ;; wrong start value costs one more pass round rather than an undo.
    (setq done nil)
    (while (not done)
        (initget "Style Start Increment Prefix Suffix Enclosure Place")
        (setq opt (getkword
                      (strcat "\n" (SerialTag:Summary)
                              "\n[Style/Start/Increment/Prefix/Suffix/Enclosure/Place] <Place>: ")))
        (if (null opt) (setq opt "Place"))

        (cond
            ((= opt "Style")
             (initget "Number Decimal Letter")
             (if (setq v (getkword "\nCounter [Number/Decimal/Letter]: "))
                 (SerialTag:Put "STYLE" v)))

            ((= opt "Start")
             (cond
                 ((= (SerialTag:Get "STYLE") "Letter")
                  (setq s (getstring (strcat "\nStart at letter <"
                                             (SerialTag:ToLetters (SerialTag:Get "START"))
                                             ">: ")))
                  (if (/= s "")
                      (if (setq v (SerialTag:FromLetters s))
                          (SerialTag:Put "START" v)
                          (princ "\nLetters only - keeping the previous setting."))))

                 ((= (SerialTag:Get "STYLE") "Decimal")
                  (initget 4)
                  (if (setq v (getreal (strcat "\nStart at <"
                                               (rtos (SerialTag:Get "RSTART") 2 3) ">: ")))
                      (SerialTag:Put "RSTART" v)))

                 (t
                  (initget 4)
                  (if (setq v (getint (strcat "\nStart at <"
                                              (itoa (SerialTag:Get "START")) ">: ")))
                      (SerialTag:Put "START" v)))))

            ((= opt "Increment")
             (if (= (SerialTag:Get "STYLE") "Decimal")
                 (progn
                     (initget 2)
                     (if (setq v (getreal (strcat "\nStep by <"
                                                  (rtos (SerialTag:Get "RSTEP") 2 3) ">: ")))
                         (SerialTag:Put "RSTEP" v)))
                 (progn
                     ;; A step of zero would stamp the same tag at every point,
                     ;; which is never what anyone means by an incrementing tag.
                     (initget 2)
                     (if (setq v (getint (strcat "\nStep by <"
                                                 (itoa (SerialTag:Get "STEP")) ">: ")))
                         (SerialTag:Put "STEP" v)))))

            ((= opt "Prefix")
             (setq s (getstring t (strcat "\nPrefix text <"
                                          (if (= (SerialTag:Get "PREFIX") "")
                                              "none" (SerialTag:Get "PREFIX"))
                                          ">, or . for none: ")))
             (cond ((= s ".") (SerialTag:Put "PREFIX" ""))
                   ((/= s "") (SerialTag:Put "PREFIX" s))))

            ((= opt "Suffix")
             (setq s (getstring t (strcat "\nSuffix text <"
                                          (if (= (SerialTag:Get "SUFFIX") "")
                                              "none" (SerialTag:Get "SUFFIX"))
                                          ">, or . for none: ")))
             (cond ((= s ".") (SerialTag:Put "SUFFIX" ""))
                   ((/= s "") (SerialTag:Put "SUFFIX" s))))

            ((= opt "Enclosure")
             (initget "None Circle Hexagon")
             (if (setq v (getkword "\nEnclose each tag in [None/Circle/Hexagon]: "))
                 (SerialTag:Put "ENCLOSE" v)))

            ((= opt "Place") (setq done t))
        )
    )

    ;; --- placement ----------------------------------------------------------
    (setq height (SerialTag:Height)
          step   0)
    (setvar "BLIPMODE" 0)

    (while (setq pt (getpoint (strcat "\nPlace " (SerialTag:Label step)
                                      " <Enter to finish>: ")))
        (setvar "OSMODE" 0)
        (setq label (SerialTag:Label step))
        (SerialTag:Text pt height label)
        (if (/= (SerialTag:Get "ENCLOSE") "None")
            (SerialTag:Enclose pt height label (SerialTag:Get "ENCLOSE")))
        (setq step (1+ step))
        (setvar "OSMODE" (nth (vl-position "OSMODE" vars) vals))
    )

    ;; Carry the sequence forward so the next run picks up where this one
    ;; stopped rather than starting over.
    (if (> step 0)
        (progn
            (if (= (SerialTag:Get "STYLE") "Decimal")
                (SerialTag:Put "RSTART" (+ (SerialTag:Get "RSTART")
                                           (* step (SerialTag:Get "RSTEP"))))
                (SerialTag:Put "START"  (+ (SerialTag:Get "START")
                                           (* step (SerialTag:Get "STEP")))))
            (princ (strcat "\n" (itoa step) " tag(s) placed. Next is "
                           (SerialTag:Label 0) "."))))

    (SerialTag:Restore)
    (princ)
)

(princ)