;;; ---------------------------------------------------------------------------
;;; NumStamp.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; INCREMENTAL NUMBERING
;;;
;;; Place a sequence of numbered or lettered annotations by clicking, and each
;;; one steps on from the last. Grid references, door numbers, revision
;;; bubbles, setting-out points, drawing marks -- anything that needs a run of
;;; labels that count.
;;;
;;; The result can be single-line text, mtext, or an attributed block, and can
;;; be automatically enclosed in a circle, rectangle, slot or polygon drawn to
;;; fit it.
;;;
;;; ---------------------------------------------------------------------------
;;; THE CONTENT BUILDER
;;;
;;; This is what makes the program more than an auto-numberer. The label is
;;; assembled from COMPONENTS, each with its own rules, and the components are
;;; simply joined together to form the text.
;;;
;;; Each component has five settings:
;;;
;;;   TEXT       the starting value: "A", "001", "-", "GRID-", anything.
;;;   INCREMENT  how much to add each time. A numeric component adds the
;;;              number; an alphabetic one steps that many letters. Zero means
;;;              the component never changes -- which is how fixed prefixes
;;;              and separators are made.
;;;   FREQUENCY  how often to increment. 1 is every time; 3 is every third
;;;              label.
;;;   RESET TO   a value to jump back to.
;;;   RESET EVERY how often to do that.
;;;
;;; So a grid reference A1 through A9, then B1 through B9, is three
;;; components:
;;;
;;;   "A"  increment 1, frequency 9                (steps every ninth label)
;;;   "-"  increment 0                             (a fixed separator)
;;;   "1"  increment 1, frequency 1, reset to "1" every 9
;;;
;;; Leading zeros are preserved: a component starting at "001" counts 002,
;;; 003 ... 010, keeping its width. Decimals keep their precision, taking
;;; whichever of the value or the increment has more decimal places.
;;;
;;; Letters roll over like an odometer: Z becomes AA, AZ becomes BA, and z
;;; stays lower case throughout.
;;;
;;; ---------------------------------------------------------------------------
;;; PLACEMENT
;;;
;;; Three ways:
;;;
;;;   BY CLICKING   each click places one label and steps the counter. Live
;;;                 keys let you rotate, mirror, skip a number, or replace the
;;;                 text of something already in the drawing, without leaving
;;;                 the command.
;;;
;;;   ALONG A CURVE press C and pick any curve; the label then slides along it
;;;                 following the tangent, with an adjustable offset, and can
;;;                 be flipped to run perpendicular instead.
;;;
;;;   AS AN ARRAY   place a whole run at once between two points, or from a
;;;                 point along a spacing vector, aligned to that direction,
;;;                 perpendicular to it, or at a fixed angle.
;;;
;;; Clicking inside a table cell writes the label INTO the cell rather than
;;; drawing an object on top of it.
;;;
;;; DYNAMIC MODE shows the real label attached to the cursor as you move.
;;; The preview is a real object, which is why object snap is unavailable
;;; while it is on -- the placement is driven by raw cursor tracking.
;;;
;;; ---------------------------------------------------------------------------
;;; BORDERS
;;;
;;; A border is generated around each label from the text's actual measured
;;; extents, so it fits whatever the label turned out to be. Either offset
;;; from the text by a factor of its height, or at a fixed size regardless.
;;;
;;; A polygon border can be rotated half a segment with B, which is the
;;; difference between a hexagon standing on a point and one standing on a
;;; flat.
;;;
;;; ---------------------------------------------------------------------------
;;; SETTINGS
;;;
;;; Everything is remembered between sessions, and whole configurations can be
;;; saved and loaded by name -- so a project's numbering scheme can be set up
;;; once and recalled.
;;;
;;; ---------------------------------------------------------------------------
;;;   NUMSTAMP - place incrementally numbered annotation
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; NumStamp:FixDir / NumStamp:SavePath
;;;
;;; Where the settings file lives. The chain always succeeds, so nothing has
;;; to treat "nowhere to write" as a failure.
;;; ---------------------------------------------------------------------------

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

(defun NumStamp:SavePath ( / dir )
    (cond
        (   (and (setq dir (getvar 'roamablerootprefix))
                 (vl-file-directory-p (strcat (NumStamp:FixDir dir) "\\Support"))
            )
            (strcat (NumStamp:FixDir dir) "\\Support")
        )
        (   (setq dir (findfile "acad.pat"))
            (NumStamp:FixDir (vl-filename-directory dir))
        )
        (   (NumStamp:FixDir (vl-filename-directory (vl-filename-mktemp))))
    )
)

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

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

;;; ===========================================================================
;;; NUMSTAMP
;;; ===========================================================================

(defun c:NumStamp

    ( /
        *error* NS:Restore NS:ModeImage NS:ModeColour

        alignment attachment _alignment _attachment _blocks _layers _styles
        _scalevars scalevars

        acspc arr-end arr-qty arr-qty# arr-rot arr-rot# arr-typ arr-typ-fun
        arr-use arr-use-fun att-nme attrib attribs blk-itm blk-nme
        blk-scl blk-scl-fun blk-scl# block blocks bor bor-enc bor-enc-fun
        bor-lay bor-rot bor-shp bor-shp-fun bor-sid bor-sid# bor-typ bor-typ-fun
        cfg con-lst create-bor create-obj crv-off crv-per dclflag dcl dch deg
        des dyn-flg elst ent file fix-ed1 fix-ed1# fix-ed2 fix-ed2# g1 g2
        glb-cnt glb-cnt-str gr i msg msk-col msk-off msk-off# msk-trn
        msk-trn-fun msk-use msk-use-fun mtw mtx-bak nm oba obj obj-typ
        obj-typ-fun off-ed1 off-ed1# p1 p2 prop pt r1 style symlist table tile
        tmp tog-cnt txt-aln txt-bst txt-lay txt-rot txt-sty txt-sty-fun txt-sze
        txt-sze# v1 vallst varlst xa
    )

    ;; MODEMACRO is used as a live rotation readout on the status bar, and
    ;; DIMZIN affects how the counter formats numbers, so both are saved.
    (setq varlst '(dimzin modemacro cmdecho)
          vallst (mapcar 'getvar varlst)
    )

    ;;; -----------------------------------------------------------------------
    ;;; NS:Restore
    ;;;
    ;;; Removes the temporary mtext used for width measurement, deletes any
    ;;; preview objects left attached to the cursor, and restores the dialog
    ;;; and system variables.
    ;;; -----------------------------------------------------------------------

    (defun NS:Restore ( )
        (if (and (= 'ename (type mtw)) (entget mtw)) (entdel mtw))
        (if (= 'file (type file)) (close file))
        (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
        (if (and (= 'str (type dcl)) (findfile dcl)) (vl-file-delete dcl))
        (mapcar 'setvar varlst vallst)
        (princ)
    )

    (defun *error* ( msg )
        ;; The settings are saved even on an error, so adjustments made during
        ;; a run that ends badly are not thrown away.
        (if (and (= 1 dclflag) (= 'str (type cfg)) symlist)
            (NumStamp:WriteConfig cfg (mapcar 'car symlist))
        )
        ;; In dynamic mode the preview is a REAL object attached to the
        ;; cursor, so a cancel has to delete it or it is left in the drawing.
        (if (= "1" dyn-flg)
            (foreach x (list obj bor)
                (if (and (= 'vla-object (type x))
                         (not (vlax-erased-p x))
                         (vlax-write-enabled-p x)
                    )
                    (vl-catch-all-apply 'vla-delete (list x))
                )
            )
        )
        (NS:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** NUMSTAMP error: " msg " **"))
        )
        (princ)
    )

    (setvar 'cmdecho 0)

    (cond
        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
            (princ "\nThe current layer is locked.")
        )

        ;;  ---- build the dialog ------------------------------------------
        (   (not
                (and
                    (setq dcl (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open dcl "w"))
                    (progn
                        (foreach line (NumStamp:DialogText) (write-line line des))
                        (setq des (close des))
                        (< 0 (setq dch (load_dialog dcl)))
                    )
                )
            )
            (princ "\nUnable to create the dialog.")
        )

        (   t
            (setq cfg (strcat (NumStamp:SavePath) "\\YZ_NumStamp.cfg"))

            ;;; ---------------------------------------------------------------
            ;;; Every setting, paired with its default.
            ;;;
            ;;; The pairing does double duty: it supplies the defaults, and it
            ;;; tells the settings reader what TYPE each value should be, so a
            ;;; hand-edited or corrupted file cannot inject a string where a
            ;;; number is expected.
            ;;; ---------------------------------------------------------------

            (setq style (tblsearch "style" (getvar 'textstyle)))
            (setq symlist
                (list
                    (cons 'glb-cnt 1)                     ;; the running counter
                    (cons 'arr-use "0")                   ;; array mode on
                    (cons 'arr-qty "5")                   ;; items in the array
                    (cons 'arr-typ "arr-aln")             ;; array rotation mode
                    (cons 'arr-rot "0.0")                 ;; fixed array angle
                    (cons 'arr-end nil)                   ;; endpoint or vector
                    (cons 'crv-per (/ pi 2.0))            ;; curve: along or across
                    (cons 'crv-off 0.0)                   ;; curve offset factor
                    (cons 'txt-rot 0.0)                   ;; label rotation
                    (cons 'bor-rot nil)                   ;; polygon half-turn
                    (cons 'tog-cnt t)                     ;; counter enabled
                    (cons 'dyn-flg "0")                   ;; dynamic preview
                    (cons 'obj-typ "obj-txt")             ;; text, mtext or block
                    (cons 'blk-nme "")
                    (cons 'att-nme "")
                    (cons 'blk-scl "1.0")
                    (cons 'scl-var "0")                   ;; scale from a sysvar
                    (cons 'scl-pop "DIMSCALE")
                    (cons 'bor-enc "0")                   ;; draw a border
                    (cons 'bor-shp "0")                   ;; circle/rect/slot/polygon
                    (cons 'bor-sid "6")                   ;; polygon sides
                    (cons 'bor-lay (getvar 'clayer))
                    (cons 'bor-typ "bor-off")             ;; offset or fixed size
                    (cons 'off-ed1 "1.0")
                    (cons 'fix-ed1 "1.0")
                    (cons 'fix-ed2 "1.0")
                    (cons 'txt-lay (getvar 'clayer))
                    (cons 'txt-sty (getvar 'textstyle))
                    (cons 'txt-aln "Middle-Center")
                    (cons 'txt-bst "1")                   ;; take height from style
                    ;; Group 40 is the style's fixed height; zero means the
                    ;; style is variable-height and group 42 holds the last
                    ;; height used.
                    (cons 'txt-sze
                        (rtos (if (zerop (cdr (assoc 40 style)))
                                  (cdr (assoc 42 style))
                                  (cdr (assoc 40 style))))
                    )
                    (cons 'msk-use "0")                   ;; mtext background mask
                    (cons 'msk-off "1.5")
                    (cons 'msk-trn "0")                   ;; use drawing background
                    (cons 'msk-col '((62 . 1)))
                    ;; The default content: a letter, a separator, and a number
                    ;; that resets every ninth label -- A-1 through A-9, then
                    ;; B-1 and onward.
                    (cons 'con-lst
                       '(
                            ("A" "1" "9"  ""  "")
                            ("-" "0" "1"  ""  "")
                            ("1" "1" "1" "1" "9")
                        )
                    )
                )
            )
            (if (not (findfile cfg))
                (progn
                    (foreach pair symlist (set (car pair) (cdr pair)))
                    (NumStamp:WriteConfig cfg (mapcar 'car symlist))
                )
            )
            (NumStamp:ReadConfig cfg symlist)

            ;; The drawing's own layers, styles and attributed blocks.
            (setq _layers (NumStamp:TableItems "layer")
                  _styles (NumStamp:TableItems "style")
                  _blocks (NumStamp:BlockData)
            )

            ;; Justification names paired with the enum values they set. TEXT
            ;; and MTEXT use different enumerations with different names, so
            ;; both lists are needed.
            (setq alignment
                (list (cons "Left"          acalignmentleft)
                      (cons "Center"        acalignmentcenter)
                      (cons "Right"         acalignmentright)
                      (cons "Middle"        acalignmentmiddle)
                      (cons "Top-Left"      acalignmenttopleft)
                      (cons "Top-Center"    acalignmenttopcenter)
                      (cons "Top-Right"     acalignmenttopright)
                      (cons "Middle-Left"   acalignmentmiddleleft)
                      (cons "Middle-Center" acalignmentmiddlecenter)
                      (cons "Middle-Right"  acalignmentmiddleright)
                      (cons "Bottom-Left"   acalignmentbottomleft)
                      (cons "Bottom-Center" acalignmentbottomcenter)
                      (cons "Bottom-Right"  acalignmentbottomright)
                )
            )
            (setq attachment
                (list (cons "Top-Left"      acattachmentpointtopleft)
                      (cons "Top-Center"    acattachmentpointtopcenter)
                      (cons "Top-Right"     acattachmentpointtopright)
                      (cons "Middle-Left"   acattachmentpointmiddleleft)
                      (cons "Middle-Center" acattachmentpointmiddlecenter)
                      (cons "Middle-Right"  acattachmentpointmiddleright)
                      (cons "Bottom-Left"   acattachmentpointbottomleft)
                      (cons "Bottom-Center" acattachmentpointbottomcenter)
                      (cons "Bottom-Right"  acattachmentpointbottomright)
                )
            )
            (setq _alignment  (mapcar 'car alignment)
                  _attachment (mapcar 'car attachment)
            )

            ;; The scale system variables a block can take its scale from.
            ;; Only those that currently hold a positive value are offered.
            ;; CANNOSCALEVALUE is inverted because it holds the paper-to-model
            ;; ratio, and a block wants the model-to-paper one.
            (setq scalevars
                (vl-remove-if 'null
                    (mapcar
                       '(lambda ( var / val )
                            (if (and (setq val (getvar var)) (< 0.0 val))
                                (if (= "CANNOSCALEVALUE" (strcase var))
                                    (cons var (rtos (/ 1.0 val)))
                                    (cons var (rtos val))
                                )
                            )
                        )
                        (acad_strlsort
                           '("CANNOSCALEVALUE" "CELTSCALE" "DIMLFAC" "DIMSCALE"
                             "DIMTFAC" "DIMTXT" "HPSCALE" "LTSCALE"
                             "MLEADERSCALE" "MSOLESCALE" "TEXTSIZE"))
                    )
                )
            )
            (setq _scalevars (mapcar 'car scalevars))

            ;;; ---------------------------------------------------------------
            ;;; NS:ModeImage / NS:ModeColour
            ;;;
            ;;; DCL has no way to grey out an image button, so a disabled one
            ;;; is drawn as a flat background-coloured rectangle and then
            ;;; disabled. Without this the picker buttons look live even when
            ;;; they do nothing.
            ;;;
            ;;; -15 is the DCL code for the dialog background colour.
            ;;; ---------------------------------------------------------------

            (setq NS:ModeImage
                (lambda ( key mode )
                    (start_image key)
                    (fill_image 0 0 (dimx_tile key) (dimy_tile key)
                        (if (= 1 mode) -15 7))
                    (end_image)
                    (mode_tile key mode)
                )
            )
            (setq NS:ModeColour
                (lambda ( key col )
                    (start_image key)
                    (fill_image 0 0 (dimx_tile key) (dimy_tile key) col)
                    (end_image)
                    ;; A swatch showing nothing must not be clickable.
                    (mode_tile key (if (or (= 0 col) (= -15 col)) 1 0))
                )
            )

            ;;; ===============================================================
            ;;; The dialog loop.
            ;;;
            ;;; Several buttons close the dialog so the user can reach the
            ;;; drawing, then it reopens. The status code says which:
            ;;;   1 run   0 cancel   2 pick block   3 pick border size
            ;;;   4 pick text size   5 pick array angle   6 pick block scale
            ;;;   7 pick mask offset   8 configuration loaded
            ;;; ===============================================================

            (while (not (member dclflag '(1 0)))
                (if (not (new_dialog "numinc" dch))
                    (progn (princ "\nUnable to display the dialog.") (setq dclflag 0))
                    (progn
                        (set_tile "dcl" "Incremental Numbering")

                        ;; ---- content ---------------------------------------
                        (set_tile "con" (NumStamp:ContentString con-lst))
                        (action_tile "bld"
                            (vl-prin1-to-string
                               '(progn
                                    (setq con-lst (NumStamp:ContentBuilder dch con-lst))
                                    (set_tile "con" (NumStamp:ContentString con-lst))
                                )
                            )
                        )
                        (set_tile    "glb" (setq glb-cnt-str (itoa glb-cnt)))
                        (action_tile "glb" "(setq glb-cnt-str $value)")

                        ;; ---- dynamic mode ----------------------------------
                        (set_tile "dyn-flg" dyn-flg)
                        (action_tile "dyn-flg"
                            (vl-prin1-to-string
                               '(progn
                                    (setq dyn-flg $value)
                                    (if (= "1" dyn-flg)
                                        (alert (strcat
                                            "With dynamic mode on, object snap, snap tracking "
                                            "and ortho are unavailable while placing.\n\n"
                                            "That is a consequence of the raw cursor tracking "
                                            "the live preview depends on."))
                                    )
                                )
                            )
                        )

                        ;; ---- layer, style, justification -------------------
                        (NumStamp:FillList "txt-lay" _layers)
                        (set_tile "txt-lay"
                            (itoa (cond ((vl-position txt-lay _layers))
                                        ((vl-position (setq txt-lay (getvar 'clayer)) _layers))
                                        (0))))
                        (action_tile "txt-lay" "(setq txt-lay (nth (atoi $value) _layers))")

                        (NumStamp:FillList "txt-sty" _styles)
                        (set_tile "txt-sty"
                            (itoa (cond ((vl-position txt-sty _styles))
                                        ((vl-position (setq txt-sty (getvar 'textstyle)) _styles))
                                        (0))))
                        ;; A fixed-height style dictates the size, so the
                        ;; "use style height" tick is forced on and the size
                        ;; box greyed. A variable-height style frees both.
                        (setq txt-sty-fun
                            (lambda ( sty / h )
                                (if (zerop (setq h (cdr (assoc 40 (tblsearch "style" sty)))))
                                    (progn
                                        (set_tile  "txt-bst" (setq txt-bst "0"))
                                        (mode_tile "txt-bst" 1)
                                        (mode_tile "txt-sze" 0)
                                    )
                                    (progn
                                        (mode_tile "txt-bst" 0)
                                        (if (= "1" txt-bst)
                                            (set_tile "txt-sze" (setq txt-sze (rtos h)))
                                        )
                                    )
                                )
                            )
                        )
                        (txt-sty-fun txt-sty)
                        (action_tile "txt-sty"
                            "(txt-sty-fun (setq txt-sty (nth (atoi $value) _styles)))")

                        (NumStamp:FillList "txt-aln"
                            (if (= "obj-mtx" obj-typ) _attachment _alignment))
                        (set_tile "txt-aln"
                            (itoa (cond
                                (   (vl-position txt-aln
                                        (if (= "obj-mtx" obj-typ) _attachment _alignment)))
                                (   (setq txt-aln
                                        (car (if (= "obj-mtx" obj-typ) _attachment _alignment)))
                                    0
                                )
                            ))
                        )
                        (action_tile "txt-aln"
                            (vl-prin1-to-string
                               '(setq txt-aln
                                    (nth (atoi $value)
                                         (if (= "obj-mtx" obj-typ) _attachment _alignment)))
                            )
                        )

                        (set_tile    "txt-sze" txt-sze)
                        (action_tile "txt-sze" "(setq txt-sze $value)")
                        (mode_tile  "txt-sze" (atoi txt-bst))
                        (NS:ModeImage "txt-pik" (atoi txt-bst))
                        (action_tile "txt-bst"
                            (vl-prin1-to-string
                               '(progn
                                    (mode_tile   "txt-sze" (atoi (setq txt-bst $value)))
                                    (NS:ModeImage "txt-pik" (atoi txt-bst))
                                    (if (= "1" $value)
                                        (set_tile "txt-sze"
                                            (rtos (cdr (assoc 40 (tblsearch "style" txt-sty)))))
                                    )
                                )
                            )
                        )
                        (action_tile "txt-pik" "(done_dialog 4)")

                        ;; ---- background mask -------------------------------
                        (set_tile "msk-trn" msk-trn)
                        (setq msk-trn-fun
                            (lambda ( val )
                                ;; Using the drawing background means the
                                ;; explicit colour is irrelevant, so the
                                ;; swatch is blanked.
                                (if (= "1" val)
                                    (NS:ModeColour "msk-col" 0)
                                    (NS:ModeColour "msk-col" (cdr (assoc 62 msk-col)))
                                )
                            )
                        )
                        (msk-trn-fun msk-trn)
                        (action_tile "msk-trn" "(msk-trn-fun (setq msk-trn $value))")
                        (action_tile "msk-col"
                            (vl-prin1-to-string
                               '(
                                    (lambda ( / new )
                                        ;; The colour dialog is given whichever
                                        ;; of true colour, colour book or index
                                        ;; the stored colour actually uses.
                                        (if (setq new
                                                (acad_truecolordlg
                                                    (vl-some '(lambda ( c ) (assoc c msk-col))
                                                            '(430 420 62))
                                                    nil))
                                            (NS:ModeColour "msk-col"
                                                (cdr (assoc 62 (setq msk-col new))))
                                        )
                                    )
                                )
                            )
                        )
                        (set_tile    "msk-off" msk-off)
                        (action_tile "msk-off" "(setq msk-off $value)")
                        (action_tile "msk-pik" "(done_dialog 7)")

                        (set_tile "msk-use" msk-use)
                        (setq msk-use-fun
                            (lambda ( val )
                                (if (= "1" val)
                                    (progn
                                        (mode_tile    "msk-off" 0)
                                        (NS:ModeImage "msk-pik" 0)
                                        (mode_tile    "msk-trn" 0)
                                        (msk-trn-fun msk-trn)
                                    )
                                    (progn
                                        (mode_tile    "msk-off" 1)
                                        (NS:ModeImage "msk-pik" 1)
                                        (mode_tile    "msk-trn" 1)
                                        (NS:ModeColour "msk-col" -15)
                                    )
                                )
                            )
                        )
                        (msk-use-fun msk-use)
                        (action_tile "msk-use" "(msk-use-fun (setq msk-use $value))")

                        ;; ---- border ----------------------------------------
                        (set_tile "bor-enc" bor-enc)
                        (setq bor-enc-fun
                            (lambda ( val )
                                (if (= "1" val)
                                    (progn
                                        (foreach k '("bor-shp" "bor-lay" "bor-off" "bor-fix"
                                                     "bor-pik" "bor-ltx")
                                            (mode_tile k 0))
                                        ;; The side count only means anything
                                        ;; for a polygon.
                                        (mode_tile "bor-sid" (if (= "3" bor-shp) 0 1))
                                        ;; Offset mode uses one box; fixed mode
                                        ;; uses one or two depending on whether
                                        ;; the shape has separate width and
                                        ;; height.
                                        (if (= "bor-off" bor-typ)
                                            (mapcar 'mode_tile
                                                   '("off-ed1" "fix-ed1" "fix-txt" "fix-ed2")
                                                   '(0 1 1 1))
                                            (progn
                                                (mode_tile "off-ed1" 1)
                                                (mode_tile "fix-ed1" 0)
                                                (mapcar 'mode_tile '("fix-txt" "fix-ed2")
                                                    (if (member bor-shp '("1" "2")) '(0 0) '(1 1)))
                                            )
                                        )
                                    )
                                    (foreach k '("bor-shp" "bor-sid" "bor-lay" "bor-off"
                                                 "bor-fix" "off-ed1" "fix-ed1" "fix-ed2"
                                                 "bor-pik" "fix-txt" "bor-ltx")
                                        (mode_tile k 1))
                                )
                            )
                        )
                        (bor-enc-fun bor-enc)
                        (action_tile "bor-enc" "(bor-enc-fun (setq bor-enc $value))")

                        (NumStamp:FillList "bor-shp" '("Circle" "Rectangle" "Slot" "Polygon"))
                        (set_tile "bor-shp" bor-shp)
                        (setq bor-shp-fun
                            (lambda ( val )
                                (mapcar 'mode_tile '("bor-sid" "fix-txt" "fix-ed2")
                                    (if (= "bor-fix" bor-typ)
                                        (cond
                                            ;;  A circle has one dimension.
                                            (   (= "0" val)                '(1 1 1))
                                            ;;  Rectangle and slot have two.
                                            (   (member val '("1" "2"))    '(1 0 0))
                                            ;;  A polygon has a side count.
                                            (                              '(0 1 1))
                                        )
                                        (cond
                                            (   (member val '("0" "1" "2")) '(1 1 1))
                                            (                               '(0 1 1))
                                        )
                                    )
                                )
                            )
                        )
                        (bor-shp-fun bor-shp)
                        (action_tile "bor-shp" "(bor-shp-fun (setq bor-shp $value))")

                        (set_tile    "bor-sid" bor-sid)
                        (action_tile "bor-sid" "(setq bor-sid $value)")

                        (NumStamp:FillList "bor-lay" _layers)
                        (set_tile "bor-lay"
                            (itoa (cond ((vl-position bor-lay _layers))
                                        ((vl-position (setq bor-lay (getvar 'clayer)) _layers))
                                        (0))))
                        (action_tile "bor-lay" "(setq bor-lay (nth (atoi $value) _layers))")

                        (set_tile bor-typ "1")
                        (setq bor-typ-fun
                            (lambda ( typ )
                                (if (= "1" bor-enc)
                                    (if (= "bor-off" typ)
                                        (mapcar 'mode_tile
                                               '("off-ed1" "fix-ed1" "fix-ed2" "fix-txt")
                                               '(0 1 1 1))
                                        (progn
                                            (mode_tile "off-ed1" 1)
                                            (mode_tile "fix-ed1" 0)
                                            (if (member bor-shp '("1" "2"))
                                                (mapcar 'mode_tile '("fix-ed2" "fix-txt") '(0 0))
                                            )
                                        )
                                    )
                                )
                            )
                        )
                        (bor-typ-fun bor-typ)
                        (action_tile "bor-off" "(bor-typ-fun (setq bor-typ $key))")
                        (action_tile "bor-fix" "(bor-typ-fun (setq bor-typ $key))")

                        ;; The tile key and the variable name are the same
                        ;; string, so one loop fills all three boxes and builds
                        ;; their callbacks.
                        (foreach sym '(off-ed1 fix-ed1 fix-ed2)
                            (setq tile (strcase (vl-symbol-name sym) t))
                            (set_tile    tile (eval sym))
                            (action_tile tile (strcat "(setq " tile " $value)"))
                        )
                        (action_tile "bor-pik" "(done_dialog 3)")

                        ;; ---- array -----------------------------------------
                        (set_tile "arr-use" arr-use)
                        (setq arr-use-fun
                            (lambda ( val )
                                (if (= "1" val)
                                    (progn
                                        (foreach k '("arr-qty" "arr-aln" "arr-per" "arr-oth")
                                            (mode_tile k 0))
                                        ;; The angle box is only live for the
                                        ;; fixed-angle option.
                                        (mode_tile    "arr-rot" (if (= "arr-oth" arr-typ) 0 1))
                                        (NS:ModeImage "arr-pik" (if (= "arr-oth" arr-typ) 0 1))
                                    )
                                    (progn
                                        (foreach k '("arr-qty" "arr-aln" "arr-per"
                                                     "arr-oth" "arr-rot")
                                            (mode_tile k 1))
                                        (NS:ModeImage "arr-pik" 1)
                                    )
                                )
                            )
                        )
                        (arr-use-fun arr-use)
                        (action_tile "arr-use" "(arr-use-fun (setq arr-use $value))")

                        (set_tile    "arr-qty" arr-qty)
                        (action_tile "arr-qty" "(setq arr-qty $value)")

                        (set_tile arr-typ "1")
                        (setq arr-typ-fun
                            (lambda ( typ )
                                (foreach k '("arr-aln" "arr-per" "arr-oth")
                                    (if (/= typ k) (set_tile k "0")))
                                (mode_tile    "arr-rot" (if (= "arr-oth" arr-typ) 0 1))
                                (NS:ModeImage "arr-pik" (if (= "arr-oth" arr-typ) 0 1))
                            )
                        )
                        (foreach k '("arr-aln" "arr-per" "arr-oth")
                            (action_tile k "(arr-typ-fun (setq arr-typ $key))"))
                        (set_tile    "arr-rot" arr-rot)
                        (action_tile "arr-rot" "(setq arr-rot $value)")
                        (action_tile "arr-pik" "(done_dialog 5)")

                        ;; ---- block scale -----------------------------------
                        (set_tile    "blk-scl" blk-scl)
                        (action_tile "blk-scl" "(setq blk-scl $value)")
                        (NumStamp:FillList "scl-pop" _scalevars)
                        (set_tile "scl-pop"
                            (itoa (cond ((vl-position scl-pop _scalevars))
                                        ((setq scl-pop (car _scalevars)) 0))))
                        ;; Taking the scale from a system variable makes the
                        ;; typed value read-only and keeps it in step.
                        (setq blk-scl-fun
                            (lambda ( val )
                                (if (= "1" val)
                                    (progn
                                        (mode_tile    "blk-scl" 1)
                                        (mode_tile    "scl-pop" 0)
                                        (NS:ModeImage "scl-pik" 1)
                                        (set_tile "blk-scl"
                                            (setq blk-scl (cdr (assoc scl-pop scalevars))))
                                    )
                                    (progn
                                        (mode_tile    "blk-scl" 0)
                                        (mode_tile    "scl-pop" 1)
                                        (NS:ModeImage "scl-pik" 0)
                                    )
                                )
                            )
                        )
                        (blk-scl-fun scl-var)
                        (action_tile "scl-var" "(blk-scl-fun (setq scl-var $value))")
                        (action_tile "scl-pop"
                            (vl-prin1-to-string
                               '(set_tile "blk-scl"
                                    (setq blk-scl
                                        (cdr (assoc (setq scl-pop (nth (atoi $value) _scalevars))
                                                    scalevars))))
                            )
                        )
                        (action_tile "scl-pik" "(done_dialog 6)")

                        ;; ---- object type -----------------------------------
                        (if (and (= "obj-blk" obj-typ) (null _blocks))
                            (setq obj-typ "obj-txt")
                        )
                        (set_tile obj-typ "1")
                        ;; Switching type swaps whole panels: a block has a
                        ;; name, an attribute and a scale but no style,
                        ;; justification, border or mask; text and mtext are
                        ;; the reverse.
                        (setq obj-typ-fun
                            (lambda ( typ )
                                (if (= "obj-blk" typ)
                                    (progn
                                        (set_tile "lay-txt" "Block Layer: ")
                                        (foreach pair
                                           '(("blk-nme" 0) ("blk-txt" 0) ("att-txt" 0)
                                             ("att-nme" 0) ("scl-var" 0)
                                             ("sty-txt" 1) ("txt-sty" 1) ("aln-txt" 1)
                                             ("txt-aln" 1) ("txt-bst" 1) ("txt-sze" 1)
                                             ("bor-enc" 1) ("bor-shp" 1) ("bor-sid" 1)
                                             ("bor-ltx" 1) ("bor-lay" 1) ("bor-off" 1)
                                             ("bor-fix" 1) ("off-ed1" 1) ("fix-ed1" 1)
                                             ("fix-ed2" 1) ("bor-pik" 1) ("msk-use" 1)
                                             ("msk-off" 1) ("msk-trn" 1))
                                            (apply 'mode_tile pair)
                                        )
                                        (NS:ModeImage  "blk-pik" 0)
                                        (NS:ModeImage  "msk-pik" 1)
                                        (NS:ModeColour "msk-col" -15)
                                        (blk-scl-fun scl-var)
                                    )
                                    (progn
                                        (set_tile "lay-txt" "Text Layer: ")
                                        (foreach pair
                                           '(("blk-txt" 1) ("blk-nme" 1) ("att-txt" 1)
                                             ("att-nme" 1) ("blk-scl" 1) ("scl-var" 1)
                                             ("scl-pop" 1) ("sty-txt" 0) ("txt-sty" 0)
                                             ("aln-txt" 0) ("txt-aln" 0) ("bor-enc" 0))
                                            (apply 'mode_tile pair)
                                        )
                                        (NS:ModeImage "blk-pik" 1)
                                        (NS:ModeImage "scl-pik" 1)
                                        (bor-enc-fun bor-enc)
                                        (txt-sty-fun txt-sty)
                                        ;; Text and mtext use different
                                        ;; justification lists, so it is
                                        ;; rebuilt on every switch.
                                        (NumStamp:FillList "txt-aln"
                                            (if (= "obj-mtx" typ) _attachment _alignment))
                                        (set_tile "txt-aln"
                                            (itoa (cond
                                                (   (vl-position txt-aln
                                                        (if (= "obj-mtx" typ) _attachment _alignment)))
                                                (   (setq txt-aln
                                                        (car (if (= "obj-mtx" typ)
                                                                 _attachment _alignment)))
                                                    0
                                                )
                                            ))
                                        )
                                        ;; Only mtext supports a background mask.
                                        (if (= "obj-mtx" typ)
                                            (progn (mode_tile "msk-use" 0) (msk-use-fun msk-use))
                                            (progn (msk-use-fun "0") (mode_tile "msk-use" 1))
                                        )
                                    )
                                )
                            )
                        )
                        (obj-typ-fun obj-typ)
                        (foreach k '("obj-txt" "obj-mtx" "obj-blk")
                            (action_tile k "(obj-typ-fun (setq obj-typ $key))"))

                        (if _blocks
                            (progn
                                (NumStamp:FillList "blk-nme"
                                    (setq blocks (mapcar 'car _blocks)))
                                (set_tile "blk-nme"
                                    (setq block
                                        (itoa (cond ((vl-position blk-nme blocks))
                                                    ((setq blk-nme (car blocks)) 0)))))
                                (NumStamp:FillList "att-nme"
                                    (setq attribs (cdr (nth (atoi block) _blocks))))
                                (set_tile "att-nme"
                                    (setq attrib
                                        (itoa (cond ((vl-position att-nme attribs))
                                                    ((setq att-nme (car attribs)) 0)))))
                            )
                            ;; No attributed blocks in the drawing, so that
                            ;; option cannot be chosen.
                            (mode_tile "obj-blk" 1)
                        )
                        ;; Choosing a block reloads its own tag list.
                        (action_tile "blk-nme"
                            (vl-prin1-to-string
                               '(progn
                                    (setq blk-itm (nth (atoi (setq block $value)) _blocks)
                                          blk-nme (car blk-itm)
                                    )
                                    (NumStamp:FillList "att-nme" (setq attribs (cdr blk-itm)))
                                    (set_tile "att-nme"
                                        (setq attrib
                                            (itoa (cond ((vl-position att-nme attribs))
                                                        ((setq att-nme (car attribs)) 0)))))
                                )
                            )
                        )
                        (action_tile "blk-pik" "(done_dialog 2)")
                        (action_tile "att-nme"
                            "(setq attrib $value att-nme (nth (atoi $value) attribs))")

                        ;; ---- load and save whole configurations ------------
                        (action_tile "cfg-lod"
                            (vl-prin1-to-string
                               '(
                                    (lambda ( / dir name )
                                        (cond
                                            (   (null (setq name
                                                        (getfiled "Load NumStamp Configuration"
                                                            (if (and (setq dir (getenv "YZ\\NumStampCfg"))
                                                                     (setq dir (NumStamp:FixDir dir))
                                                                     (vl-file-directory-p dir))
                                                                (strcat dir "\\")
                                                                (getvar 'dwgprefix))
                                                            "cfg" 16))))
                                            (   (not (NumStamp:ReadConfig name symlist))
                                                (alert (strcat "That configuration could not be read:\n\n"
                                                               name))
                                            )
                                            ;; The dialog is closed and
                                            ;; reopened so every control picks
                                            ;; up the newly loaded values.
                                            (   (done_dialog 8))
                                        )
                                    )
                                )
                            )
                        )
                        (action_tile "cfg-sav"
                            (vl-prin1-to-string
                               '(
                                    (lambda ( / dir name )
                                        (cond
                                            (   (null (setq name
                                                        (getfiled "Save NumStamp Configuration As"
                                                            (if (and (setq dir (getenv "YZ\\NumStampCfg"))
                                                                     (setq dir (NumStamp:FixDir dir))
                                                                     (vl-file-directory-p dir))
                                                                (strcat dir "\\")
                                                                (getvar 'dwgprefix))
                                                            "cfg" 1))))
                                            (   (not (NumStamp:WriteConfig name (mapcar 'car symlist)))
                                                (alert (strcat "That configuration could not be written:\n\n"
                                                               name))
                                            )
                                            (   (setenv "YZ\\NumStampCfg"
                                                    (NumStamp:FixDir (vl-filename-directory name))))
                                        )
                                    )
                                )
                            )
                        )

                        ;;; -------------------------------------------------
                        ;;; OK: everything is validated here, before the
                        ;;; dialog closes, so a bad value can be corrected
                        ;;; without losing the rest of the setup. Each check
                        ;;; is guarded by the conditions that make the field
                        ;;; relevant at all -- a border size is not checked
                        ;;; when no border is being drawn.
                        ;;; -------------------------------------------------

                        (action_tile "accept"
                            (vl-prin1-to-string
                               '(progn
                                    (if (= "" txt-sze)     (setq txt-sze (rtos (getvar 'textsize))))
                                    (if (= "" glb-cnt-str) (setq glb-cnt-str "1"))
                                    (cond
                                        (   (/= 'int (type (read glb-cnt-str)))
                                            (alert "The counter must be a whole number.")
                                            (mode_tile "glb" 2)
                                        )
                                        (   (and (/= "obj-blk" obj-typ) (= "1" bor-enc)
                                                 (= "bor-off" bor-typ)
                                                 (not (setq off-ed1# (distof off-ed1))))
                                            (alert "The border offset must be a number.")
                                            (mode_tile "off-ed1" 2)
                                        )
                                        ;;  A factor below one would put the
                                        ;;  border inside the text.
                                        (   (and (/= "obj-blk" obj-typ) (= "1" bor-enc)
                                                 (= "bor-off" bor-typ) (< off-ed1# 1.0))
                                            (alert "The border offset factor must be at least one.")
                                            (mode_tile "off-ed1" 2)
                                        )
                                        (   (and (/= "obj-blk" obj-typ) (= "1" bor-enc)
                                                 (= "bor-fix" bor-typ)
                                                 (or (not (setq fix-ed1# (distof fix-ed1)))
                                                     (and (member bor-shp '("1" "2"))
                                                          (not (setq fix-ed2# (distof fix-ed2))))))
                                            (alert "The border size must be a number.")
                                            (mode_tile "fix-ed1" 2)
                                        )
                                        (   (and (/= "obj-blk" obj-typ) (= "1" bor-enc)
                                                 (= "bor-fix" bor-typ)
                                                 (or (<= fix-ed1# 0.0)
                                                     (and (member bor-shp '("1" "2"))
                                                          (<= fix-ed2# 0.0))))
                                            (alert "The border size must be greater than zero.")
                                            (mode_tile "fix-ed1" 2)
                                        )
                                        (   (and (= "1" arr-use)
                                                 (< (setq arr-qty# (atoi arr-qty)) 1))
                                            (alert "The array must contain at least one item.")
                                            (mode_tile "arr-qty" 2)
                                        )
                                        (   (and (= "1" arr-use) (= "arr-oth" arr-typ)
                                                 (not (setq arr-rot# (angtof arr-rot))))
                                            (alert "The array rotation must be a valid angle.")
                                            (mode_tile "arr-rot" 2)
                                        )
                                        (   (and (= "obj-mtx" obj-typ) (= "1" msk-use)
                                                 (not (setq msk-off# (distof msk-off))))
                                            (alert "The mask offset must be a number.")
                                            (mode_tile "msk-off" 2)
                                        )
                                        ;;  AutoCAD only accepts mask border
                                        ;;  factors between 1 and 5.
                                        (   (and (= "obj-mtx" obj-typ) (= "1" msk-use)
                                                 (or (< 5.0 msk-off#) (< msk-off# 1.0)))
                                            (alert "The mask offset must be between 1 and 5.")
                                            (mode_tile "msk-off" 2)
                                        )
                                        (   (and (= "obj-blk" obj-typ)
                                                 (not (setq blk-scl# (distof blk-scl))))
                                            (alert "The block scale must be a number.")
                                            (mode_tile "blk-scl" 2)
                                        )
                                        (   (and (= "obj-blk" obj-typ) (<= blk-scl# 0.0))
                                            (alert "The block scale must be greater than zero.")
                                            (mode_tile "blk-scl" 2)
                                        )
                                        (   (and (/= "obj-blk" obj-typ)
                                                 (not (setq txt-sze# (distof txt-sze))))
                                            (alert "The text height must be a number.")
                                            (if (= "0" txt-bst) (mode_tile "txt-sze" 2))
                                        )
                                        (   (and (/= "obj-blk" obj-typ) (<= txt-sze# 0.0))
                                            (alert "The text height must be greater than zero.")
                                            (if (= "0" txt-bst) (mode_tile "txt-sze" 2))
                                        )
                                        (   (and (/= "obj-blk" obj-typ) (= "1" bor-enc)
                                                 (= "3" bor-shp)
                                                 (< (setq bor-sid# (atoi bor-sid)) 3))
                                            (alert "A polygon needs at least three sides.")
                                            (mode_tile "bor-sid" 2)
                                        )
                                        (   (done_dialog 1))
                                    )
                                )
                            )
                        )
                        (action_tile "cancel" "(done_dialog 0)")
                        (setq dclflag (start_dialog))
                    )
                )

                ;;  ---- the pick-from-drawing detours ----
                (cond
                    (   (= 2 dclflag)
                        (while
                            (progn
                                (setvar 'errno 0)
                                (setq ent (car (entsel "\nSelect block: ")))
                                (cond
                                    (   (= 7 (getvar 'errno)) (princ "\nMissed, try again."))
                                    (   (= 'ename (type ent))
                                        (if (and (= "INSERT" (cdr (assoc 0 (setq elst (entget ent)))))
                                                 (= 1 (cdr (assoc 66 elst))))
                                            (progn
                                                (setq obj     (vlax-ename->vla-object ent)
                                                      blk-nme (if (vlax-property-available-p obj 'effectivename)
                                                                  (vla-get-effectivename obj)
                                                                  (vla-get-name obj))
                                                )
                                                nil
                                            )
                                            (princ "\nThat must be an attributed block.")
                                        )
                                    )
                                )
                            )
                        )
                    )
                    (   (= 3 dclflag)
                        (if (= "bor-off" bor-typ)
                            (progn
                                (while (and (progn (initget 6)
                                                   (setq tmp (getdist
                                                       (strcat "\nBorder offset factor <"
                                                               off-ed1 ">: "))))
                                            (< tmp 1.0))
                                    (princ "\nThe factor must be at least one."))
                                (if tmp (setq off-ed1 (rtos tmp)))
                            )
                            ;;  A circle and a polygon take a radius; a
                            ;;  rectangle and a slot take two corners.
                            (if (member bor-shp '("0" "3"))
                                (setq fix-ed1
                                    (cond ((setq tmp (getdist
                                              (strcat "\nBorder radius <" fix-ed1 ">: ")))
                                           (rtos tmp))
                                          (fix-ed1)))
                                (if (and (setq p1 (getpoint "\nSpecify first point: "))
                                         (setq p2 (getcorner p1 "\nSpecify opposite corner: ")))
                                    (setq fix-ed1 (rtos (abs (- (car  p2) (car  p1))))
                                          fix-ed2 (rtos (abs (- (cadr p2) (cadr p1))))
                                    )
                                )
                            )
                        )
                    )
                    (   (= 4 dclflag)
                        (initget 6)
                        (setq txt-sze (cond ((setq tmp (getdist
                                                (strcat "\nText size <" txt-sze ">: ")))
                                             (rtos tmp))
                                            (txt-sze)))
                    )
                    (   (= 5 dclflag)
                        (setq arr-rot (cond ((setq tmp (getangle
                                                (strcat "\nObject angle <" arr-rot ">: ")))
                                             (angtos tmp))
                                            (arr-rot)))
                    )
                    (   (= 6 dclflag)
                        (initget 6)
                        (setq blk-scl (cond ((setq tmp (getdist
                                                (strcat "\nBlock scale <" blk-scl ">: ")))
                                             (rtos tmp))
                                            (blk-scl)))
                    )
                    (   (= 7 dclflag)
                        (while (and (progn (initget 6)
                                           (setq tmp (getdist
                                               (strcat "\nMask offset factor <" msk-off ">: "))))
                                    (or (< 5.0 tmp) (< tmp 1.0)))
                            (princ "\nThe factor must be between 1 and 5."))
                        (if tmp (setq msk-off (rtos tmp)))
                    )
                    ;;  8 means a configuration was loaded; the loop simply
                    ;;  reopens the dialog with the new values.
                )
            )

            ;;; ===============================================================
            ;;;                  P L A C E   T H E   L A B E L S
            ;;; ===============================================================

            (if (/= 1 dclflag)
                (princ "\nCancelled.")
                (progn
                    ;; Every table in the current layout, so clicking inside a
                    ;; cell can write into it.
                    (if (setq tmp (ssget "_X"
                                      (list '(0 . "ACAD_TABLE")
                                            (if (= 1 (getvar 'cvport))
                                                (cons 410 (getvar 'ctab))
                                               '(410 . "Model")))))
                        (repeat (setq i (sslength tmp))
                            (setq table (cons (vlax-ename->vla-object
                                                  (ssname tmp (setq i (1- i)))) table))
                        )
                    )

                    (setq acspc (vlax-get-property (NumStamp:Doc)
                                    (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                          nm    (trans '(0.0 0.0 1.0) 1 0 t)
                          ;; The UCS X-axis angle. TEXT and blocks store their
                          ;; rotation relative to the world, so working in a
                          ;; rotated UCS needs this added back in; MTEXT does
                          ;; not, which is why it is applied selectively.
                          xa    (angle '(0.0 0.0 0.0) (trans (getvar 'ucsxdir) 0 nm t))
                    )

                    (if (/= "obj-blk" obj-typ)
                        (progn
                            ;; An annotative style's height is the PAPER
                            ;; height, so it is divided by the annotation
                            ;; scale to give the model height to create at.
                            (if (NumStamp:Annotative txt-sty)
                                (setq txt-sze# (/ txt-sze#
                                                  (cond ((getvar 'cannoscalevalue)) (1.0))))
                            )
                            (setq oba (cdr (assoc 50 (tblsearch "style" txt-sty))))
                        )
                    )

                    ;; Which property actually moves the object. Left-justified
                    ;; TEXT is positioned by its insertion point; anything else
                    ;; by its alignment point.
                    (setq prop
                        (if (and (= "obj-txt" obj-typ) (/= "Left" txt-aln))
                            'textalignmentpoint
                            'insertionpoint
                        )
                    )
                    (setq mtx-bak (if (= "1" msk-use) :vlax-true :vlax-false))

                    ;;; -----------------------------------------------------
                    ;;; create-obj
                    ;;;
                    ;;; Builds one label at a point. Chosen once, up front,
                    ;;; rather than tested inside the placement loop -- so the
                    ;;; loop stays the same whichever object type is in use.
                    ;;; -----------------------------------------------------

                    (setq create-obj
                        (cond
                            (   (= "obj-txt" obj-typ)
                                (lambda ( point string / o )
                                    (setq point (vlax-3d-point (trans point 1 0))
                                          o     (vla-addtext acspc string point txt-sze#)
                                    )
                                    (vla-put-stylename o txt-sty)
                                    (vla-put-layer     o txt-lay)
                                    (vla-put-alignment o (cdr (assoc txt-aln alignment)))
                                    ;; Setting the justification moves the
                                    ;; text, so the position is written again
                                    ;; afterwards through whichever property
                                    ;; now governs it.
                                    (if (= "Left" txt-aln)
                                        (vla-put-insertionpoint     o point)
                                        (vla-put-textalignmentpoint o point)
                                    )
                                    (vla-put-obliqueangle o oba)
                                    (vla-put-rotation     o (+ xa txt-rot))
                                    o
                                )
                            )
                            (   (= "obj-mtx" obj-typ)
                                (lambda ( point string / o )
                                    (setq point (vlax-3d-point (trans point 1 0)))
                                    ;; MText needs a defined width or it wraps;
                                    ;; the string is measured to find one.
                                    (setq o (vla-addmtext acspc point
                                                (NumStamp:MTextWidth string txt-sty txt-sze#)
                                                string))
                                    (vla-put-stylename o txt-sty)
                                    (vla-put-layer     o txt-lay)
                                    (vla-put-height    o txt-sze#)
                                    (vla-put-attachmentpoint o (cdr (assoc txt-aln attachment)))
                                    (vla-put-insertionpoint  o point)
                                    (vla-put-rotation  o txt-rot)
                                    ;; The mask colour and border factor have
                                    ;; no ActiveX properties, so they are
                                    ;; written straight into the entity data.
                                    ;; The old mask groups are stripped first
                                    ;; so a colour method left over from a
                                    ;; previous setting cannot survive.
                                    (if (= "1" msk-use)
                                        (entmod
                                            (append
                                                (vl-remove-if
                                                   '(lambda ( pair )
                                                        (member (car pair)
                                                               '(45 63 90 421 431 441)))
                                                    (entget (vlax-vla-object->ename o))
                                                )
                                                ;; 90: 1 = explicit colour,
                                                ;; 3 = use the drawing background.
                                                (if (= "1" msk-trn) '((90 . 3)) '((90 . 1)))
                                                (if (= "1" msk-trn)
                                                   '((63 . 256))
                                                    ;; The stored colour groups
                                                    ;; are shifted up by one to
                                                    ;; become the mask's own.
                                                    (mapcar '(lambda ( x )
                                                                 (cons (1+ (car x)) (cdr x)))
                                                            msk-col)
                                                )
                                                (list (cons 45 msk-off#) '(441 . 0))
                                            )
                                        )
                                    )
                                    (vla-put-backgroundfill o mtx-bak)
                                    o
                                )
                            )
                            (   t
                                (lambda ( point string / o )
                                    (setq point (vlax-3d-point (trans point 1 0))
                                          o (vla-insertblock acspc point blk-nme
                                                blk-scl# blk-scl# blk-scl# (+ xa txt-rot))
                                    )
                                    ;; vl-some stops at the matching tag rather
                                    ;; than walking every attribute.
                                    (vl-some
                                       '(lambda ( att )
                                            (if (= (strcase (vla-get-tagstring att)) att-nme)
                                                (null (vla-put-textstring att string))
                                            )
                                        )
                                        (vlax-invoke o 'getattributes)
                                    )
                                    (vla-put-layer o txt-lay)
                                    o
                                )
                            )
                        )
                    )

                    ;; The offset factor is relative to the text height, and
                    ;; one means "touching", so the actual gap is the height
                    ;; times the excess over one.
                    (if (and (/= "obj-blk" obj-typ) (= "1" bor-enc)
                             (= "bor-off" bor-typ) off-ed1#)
                        (setq off-ed1# (* txt-sze# (1- off-ed1#)))
                    )

                    (setq create-bor
                        (lambda ( o / b )
                            (setq b (vlax-ename->vla-object
                                        (NumStamp:TextBorder
                                            (vlax-vla-object->ename o) bor-shp
                                            (cond (off-ed1#) (0.0)) fix-ed1# fix-ed2# bor-sid#)))
                            (vla-put-layer b bor-lay)
                            ;; Half a segment turns a hexagon from standing on
                            ;; a point to standing on a flat.
                            (if (and (= "3" bor-shp) bor-rot)
                                (vla-rotate b (vlax-3d-point (NumStamp:Centroid b))
                                            (/ pi bor-sid#))
                            )
                            b
                        )
                    )

                    (setq glb-cnt (atoi glb-cnt-str))

                    (cond

                        ;;  ============ array placement ============
                        (   (= "1" arr-use)
                            (if (setq p1 (getpoint "\nSpecify array base point: "))
                                (progn
                                    ;; The second point is either where the
                                    ;; last item goes, or one spacing step --
                                    ;; switchable at the prompt, because both
                                    ;; are natural depending on the job.
                                    (while
                                        (progn
                                            (if arr-end
                                                (progn (initget "Spacing")
                                                       (setq p2 (getpoint
                                                           "\nSpecify array endpoint [Spacing]: " p1)))
                                                (progn (initget "Endpoint")
                                                       (setq p2 (getpoint
                                                           "\nSpecify array spacing vector [Endpoint]: " p1)))
                                            )
                                            (cond
                                                (   (null p2) nil)
                                                (   (= "Endpoint" p2) (setq arr-end t))
                                                (   (= "Spacing"  p2) (setq arr-end nil) t)
                                                (   (and (listp p2) (equal p1 p2 1e-8))
                                                    (princ "\nThe two points must be different.")
                                                )
                                            )
                                        )
                                    )
                                    ;; In endpoint mode the span is divided
                                    ;; between the gaps, which is one fewer
                                    ;; than the item count.
                                    (if (and arr-end (< 1 arr-qty#))
                                        (setq v1 (mapcar '(lambda ( a b )
                                                              (/ (- a b) (float (1- arr-qty#))))
                                                         p2 p1))
                                        (setq v1 (mapcar '- p2 p1))
                                    )
                                    (cond
                                        (   (= "arr-aln" arr-typ)
                                            (setq r1 (NumStamp:Readable (angle p1 p2))))
                                        (   (= "arr-per" arr-typ)
                                            (setq r1 (NumStamp:Readable
                                                         (+ (angle p1 p2) (/ pi 2.0)))))
                                        (   (setq r1 arr-rot#))
                                    )
                                    (if (/= "obj-mtx" obj-typ) (setq r1 (+ r1 xa)))
                                    (repeat arr-qty#
                                        (setq obj (create-obj p1 (NumStamp:ContentString con-lst)))
                                        (vla-put-rotation obj r1)
                                        (if (and (/= "obj-blk" obj-typ) (= "1" bor-enc))
                                            (create-bor obj))
                                        (setq glb-cnt (1+ glb-cnt)
                                              con-lst (NumStamp:Increment con-lst glb-cnt)
                                              p1      (mapcar '+ p1 v1)
                                        )
                                    )
                                    (princ (strcat "\n" (itoa arr-qty#) " labels placed."))
                                )
                            )
                        )

                        ;;  ============ dynamic placement ============
                        (   (= "1" dyn-flg)
                            ;; Wait for the first cursor move so the preview
                            ;; appears where the cursor already is rather than
                            ;; at the origin.
                            (while (/= 5 (car (setq gr (grread t 13 0)))))
                            (setq obj (create-obj (cadr gr) (NumStamp:ContentString con-lst)))
                            (if (and (/= "obj-blk" obj-typ) (= "1" bor-enc))
                                (setq bor (create-bor obj)))

                            (princ (setq msg (NumStamp:DragMessage obj-typ bor-enc bor-shp t)))
                            (NumStamp:ShowRotation txt-rot)

                            (while
                                (progn
                                    (setq gr (grread t 15 0)
                                          g1 (car  gr)
                                          g2 (cadr gr)
                                    )
                                    (cond
                                        ;;  ---- moved or clicked ----
                                        (   (member g1 '(3 5))
                                            (setq p1 (vlax-3d-point (trans g2 1 0)))
                                            ;; The border moves first, by the
                                            ;; same displacement, so it stays
                                            ;; registered with the text.
                                            (if bor (vla-move bor (vlax-get-property obj prop) p1))
                                            (vlax-put-property obj prop p1)
                                            (if (= 3 g1)
                                                (progn
                                                    ;; Landing in a table cell
                                                    ;; writes into the cell and
                                                    ;; the drawn objects are
                                                    ;; discarded.
                                                    (if (and table
                                                             (NumStamp:TextInCell table p1
                                                                 (NumStamp:ContentString con-lst)))
                                                        (progn
                                                            (vla-delete obj)
                                                            (if bor (vla-delete bor))
                                                        )
                                                    )
                                                    (if tog-cnt
                                                        (setq glb-cnt (1+ glb-cnt)
                                                              con-lst (NumStamp:Increment
                                                                          con-lst glb-cnt)))
                                                    (setq obj (create-obj g2
                                                                  (NumStamp:ContentString con-lst)))
                                                    (if (and (/= "obj-blk" obj-typ) (= "1" bor-enc))
                                                        (setq bor (create-bor obj)))
                                                    (redraw)
                                                )
                                            )
                                            t
                                        )
                                        ;;  ---- right-click: finish ----
                                        (   (= 25 g1)
                                            (vla-delete obj)
                                            (if bor (vla-delete bor))
                                            nil
                                        )
                                        (   (= 2 g1)
                                            (cond
                                                ;;  C: align along a curve.
                                                (   (member g2 '(67 99))
                                                    (vla-delete obj)
                                                    (if bor (vla-delete bor))
                                                    (while (setq ent (NumStamp:SelectIf
                                                                "\nSelect curve <exit>: "
                                                               '(lambda ( x )
                                                                    (not (vl-catch-all-error-p
                                                                        (vl-catch-all-apply
                                                                            'vlax-curve-getendparam
                                                                            (list x)))))
                                                                entsel))
                                                        (if (NumStamp:AlignToCurve
                                                                (setq obj (create-obj (cadr ent)
                                                                    (NumStamp:ContentString con-lst)))
                                                                prop (car ent)
                                                                (if (and (/= "obj-blk" obj-typ)
                                                                         (= "1" bor-enc))
                                                                    (setq bor (create-bor obj))))
                                                            (if tog-cnt
                                                                (setq glb-cnt (1+ glb-cnt)
                                                                      con-lst (NumStamp:Increment
                                                                                  con-lst glb-cnt)))
                                                            (progn
                                                                (vla-delete obj)
                                                                (if bor (vla-delete bor))
                                                            )
                                                        )
                                                    )
                                                    (setq obj (create-obj (cadr (grread t 13 0))
                                                                  (NumStamp:ContentString con-lst)))
                                                    (if (and (/= "obj-blk" obj-typ) (= "1" bor-enc))
                                                        (setq bor (create-bor obj)))
                                                    (princ msg)
                                                    t
                                                )
                                                ;;  < and >: nudge one degree.
                                                (   (member g2 '(44 46 60 62))
                                                    (setq deg (if (member g2 '(44 60))
                                                                  (/ pi 180.0) (/ pi -180.0))
                                                          txt-rot (+ txt-rot deg)
                                                    )
                                                    (NumStamp:ShowRotation txt-rot)
                                                    (vla-put-rotation obj
                                                        (+ (vla-get-rotation obj) deg))
                                                    (if bor (vla-rotate bor
                                                        (vlax-get-property obj prop) deg))
                                                    t
                                                )
                                                ;;  O: type an exact rotation.
                                                (   (member g2 '(79 111))
                                                    (setq txt-rot (NumStamp:AskRotation
                                                                      obj-typ txt-rot))
                                                    (NumStamp:ShowRotation txt-rot)
                                                    (NumStamp:SetRotation obj bor prop txt-rot
                                                                          obj-typ xa)
                                                    (princ msg)
                                                    t
                                                )
                                                ;;  T: pause or resume counting.
                                                (   (member g2 '(84 116))
                                                    (princ (if (setq tog-cnt (not tog-cnt))
                                                               "\n<Counter enabled>"
                                                               "\n<Counter disabled>"))
                                                    (princ msg)
                                                    t
                                                )
                                                ;;  I: skip a number without
                                                ;;  placing anything.
                                                (   (member g2 '(73 105))
                                                    (vla-delete obj)
                                                    (if bor (vla-delete bor))
                                                    (setq glb-cnt (1+ glb-cnt)
                                                          con-lst (NumStamp:Increment
                                                                      con-lst glb-cnt))
                                                    (setq obj (create-obj (cadr (grread t 13 0))
                                                                  (NumStamp:ContentString con-lst)))
                                                    (if (and (/= "obj-blk" obj-typ) (= "1" bor-enc))
                                                        (setq bor (create-bor obj)))
                                                    t
                                                )
                                                ;;  B: rotate a polygon border.
                                                (   (member g2 '(66 98))
                                                    (if (and (/= "obj-blk" obj-typ) (= "1" bor-enc)
                                                             (= "3" bor-shp) bor)
                                                        (progn
                                                            (setq bor-rot (not bor-rot))
                                                            (vla-rotate bor
                                                                (vlax-3d-point (NumStamp:Centroid bor))
                                                                (/ pi bor-sid#))
                                                        )
                                                        (princ (strcat "\nInvalid keypress." msg))
                                                    )
                                                    t
                                                )
                                                ;;  Tab: snap to the next
                                                ;;  quarter turn. Already on
                                                ;;  one, it moves to the next;
                                                ;;  otherwise it rounds to the
                                                ;;  nearest.
                                                (   (= 9 g2)
                                                    (setq txt-rot (rem (+ pi pi txt-rot) (+ pi pi)))
                                                    (if (vl-some
                                                            '(lambda ( a ) (equal txt-rot a 1e-6))
                                                             (list 0.0 (* pi 0.5) pi (* pi 1.5)))
                                                        (setq txt-rot (rem (+ txt-rot (/ pi 2.0))
                                                                           (+ pi pi)))
                                                        (setq txt-rot (NumStamp:RoundTo
                                                                          txt-rot (/ pi 2.0)))
                                                    )
                                                    (NumStamp:ShowRotation txt-rot)
                                                    (NumStamp:SetRotation obj bor prop txt-rot
                                                                          obj-typ xa)
                                                    t
                                                )
                                                ;;  M: mirror the angle.
                                                (   (member g2 '(77 109))
                                                    (setq txt-rot (rem (+ pi pi (- txt-rot))
                                                                       (+ pi pi)))
                                                    (NumStamp:ShowRotation txt-rot)
                                                    (NumStamp:SetRotation obj bor prop txt-rot
                                                                          obj-typ xa)
                                                    t
                                                )
                                                ;;  R: overwrite existing text
                                                ;;  rather than drawing new.
                                                (   (member g2 '(82 114))
                                                    (vla-delete obj)
                                                    (if bor (vla-delete bor))
                                                    (while (NumStamp:Replace
                                                               (NumStamp:ContentString con-lst))
                                                        (if tog-cnt
                                                            (setq glb-cnt (1+ glb-cnt)
                                                                  con-lst (NumStamp:Increment
                                                                              con-lst glb-cnt))))
                                                    (setq obj (create-obj (cadr (grread t 13 0))
                                                                  (NumStamp:ContentString con-lst)))
                                                    (if (and (/= "obj-blk" obj-typ) (= "1" bor-enc))
                                                        (setq bor (create-bor obj)))
                                                    (princ msg)
                                                    t
                                                )
                                                ;;  A: toggle the mask.
                                                (   (member g2 '(65 97))
                                                    (if (= "obj-mtx" obj-typ)
                                                        (progn
                                                            (vlax-put obj 'backgroundfill
                                                                (setq mtx-bak
                                                                    (~ (vlax-get obj 'backgroundfill))))
                                                            (princ (if (zerop mtx-bak)
                                                                       "\n<Background mask off>"
                                                                       "\n<Background mask on>"))
                                                        )
                                                        (princ "\nInvalid keypress.")
                                                    )
                                                    (princ msg)
                                                    t
                                                )
                                                ;;  Enter or Space: finish.
                                                (   (member g2 '(13 32))
                                                    (vla-delete obj)
                                                    (if bor (vla-delete bor))
                                                    nil
                                                )
                                                (   (princ (strcat "\nInvalid keypress." msg)) t)
                                            )
                                        )
                                        (   t
                                            (vla-delete obj)
                                            (if bor (vla-delete bor))
                                            nil
                                        )
                                    )
                                )
                            )
                        )

                        ;;  ============ ordinary click placement ============
                        (   t
                            (setq msg (NumStamp:DragMessage obj-typ bor-enc bor-shp nil))
                            (NumStamp:ShowRotation txt-rot)
                            (while
                                (progn
                                    (initget
                                        (strcat "Curve Replace rOtation Toggle Increment ROtate"
                                            (if (and (/= "obj-blk" obj-typ) (= "1" bor-enc)
                                                     (= "3" bor-shp))
                                                " Border" "")
                                            " Mirror"
                                            (if (= "obj-mtx" obj-typ) " bAckground" "")))
                                    (setq pt (getpoint msg))
                                    (cond
                                        (   (null pt) nil)
                                        (   (listp pt)
                                            (if (null (and table
                                                           (NumStamp:TextInCell table
                                                               (vlax-3d-point (trans pt 1 0))
                                                               (NumStamp:ContentString con-lst))))
                                                (progn
                                                    (setq obj (create-obj pt
                                                        (NumStamp:ContentString con-lst)))
                                                    (if (and (/= "obj-blk" obj-typ)
                                                             (= "1" bor-enc))
                                                        (setq bor (create-bor obj)))
                                                )
                                            )
                                            (if tog-cnt
                                                (setq glb-cnt (1+ glb-cnt)
                                                      con-lst (NumStamp:Increment con-lst glb-cnt)))
                                            t
                                        )
                                        (   (= "Curve" pt)
                                            (while (setq ent (NumStamp:SelectIf
                                                        "\nSelect curve <exit>: "
                                                       '(lambda ( x )
                                                            (not (vl-catch-all-error-p
                                                                (vl-catch-all-apply
                                                                    'vlax-curve-getendparam
                                                                    (list x)))))
                                                        entsel))
                                                (if (NumStamp:AlignToCurve
                                                        (setq obj (create-obj (cadr ent)
                                                            (NumStamp:ContentString con-lst)))
                                                        prop (car ent)
                                                        (if (and (/= "obj-blk" obj-typ)
                                                                 (= "1" bor-enc))
                                                            (setq bor (create-bor obj))))
                                                    (if tog-cnt
                                                        (setq glb-cnt (1+ glb-cnt)
                                                              con-lst (NumStamp:Increment
                                                                          con-lst glb-cnt)))
                                                    (progn
                                                        (vla-delete obj)
                                                        (if bor (vla-delete bor))
                                                    )
                                                )
                                            )
                                            t
                                        )
                                        (   (= "Replace" pt)
                                            (while (NumStamp:Replace
                                                       (NumStamp:ContentString con-lst))
                                                (if tog-cnt
                                                    (setq glb-cnt (1+ glb-cnt)
                                                          con-lst (NumStamp:Increment
                                                                      con-lst glb-cnt))))
                                            t
                                        )
                                        (   (= "rOtation" pt)
                                            (setq txt-rot (NumStamp:AskRotation obj-typ txt-rot))
                                            (NumStamp:ShowRotation txt-rot)
                                            t
                                        )
                                        (   (= "Toggle" pt)
                                            (princ (if (setq tog-cnt (not tog-cnt))
                                                       "\n<Counter enabled>"
                                                       "\n<Counter disabled>"))
                                            t
                                        )
                                        (   (= "Increment" pt)
                                            (setq glb-cnt (1+ glb-cnt)
                                                  con-lst (NumStamp:Increment con-lst glb-cnt))
                                            t
                                        )
                                        (   (= "Border" pt)
                                            (princ "\n<Border rotated>")
                                            (setq bor-rot (not bor-rot))
                                            t
                                        )
                                        (   (= "ROtate" pt)
                                            (setq txt-rot (rem (+ pi pi txt-rot) (+ pi pi)))
                                            (if (vl-some '(lambda ( a ) (equal txt-rot a 1e-6))
                                                          (list 0.0 (* pi 0.5) pi (* pi 1.5)))
                                                (setq txt-rot (rem (+ txt-rot (/ pi 2.0))
                                                                   (+ pi pi)))
                                                (setq txt-rot (NumStamp:RoundTo txt-rot (/ pi 2.0)))
                                            )
                                            (NumStamp:ShowRotation txt-rot)
                                            t
                                        )
                                        (   (= "Mirror" pt)
                                            (setq txt-rot (rem (+ pi pi (- txt-rot)) (+ pi pi)))
                                            (NumStamp:ShowRotation txt-rot)
                                            t
                                        )
                                        (   (= "bAckground" pt)
                                            (princ (if (zerop (setq mtx-bak (~ mtx-bak)))
                                                       "\n<Background mask off>"
                                                       "\n<Background mask on>"))
                                            t
                                        )
                                    )
                                )
                            )
                        )
                    )
                    (NumStamp:WriteConfig cfg (mapcar 'car symlist))
                )
            )
        )
    )

    (NS:Restore)
    (princ)
)

;;; ===========================================================================
;;;               T H E   I N C R E M E N T I N G   E N G I N E
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; NumStamp:ContentString
;;;
;;; Joins the components into the label. The whole content system reduces to
;;; this: the label is simply the components' current values concatenated.
;;; ---------------------------------------------------------------------------

(defun NumStamp:ContentString ( lst )
    (apply 'strcat (mapcar 'car lst))
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:Increment
;;;
;;; Steps every component on by one label.
;;;
;;; Each component is handled independently, and skipped entirely if any of
;;; these apply: its increment is not a number, its increment is zero (a fixed
;;; prefix or separator), its frequency is zero, or the count is not yet a
;;; multiple of its frequency.
;;;
;;; Whether it increments numerically or alphabetically is decided by whether
;;; the CURRENT VALUE parses as a number -- so "01" counts 02, 03, while "A"
;;; counts B, C.
;;;
;;; The reset is applied afterwards and independently, so a component can
;;; increment on one cycle and reset on another. That is what makes
;;; "1 through 9, then back to 1" work while the letter beside it advances.
;;;
;;;   lst - the component list
;;;   cnt - the current label number, counting from one
;;; ---------------------------------------------------------------------------

(defun NumStamp:Increment ( lst cnt )
    ;; The frequency test is a remainder, which wants a zero-based count --
    ;; otherwise the first label would already be a multiple of everything.
    (setq cnt (1- cnt))
    (mapcar
       '(lambda ( item / frq inc out rfq rst )
            (setq out
                (cond
                    (   (null (setq inc (distof (cadr item) 2)))  item)
                    (   (equal 0.0 inc 1e-8)                      item)
                    (   (zerop (setq frq (atoi (caddr item))))    item)
                    (   (< 0 (rem cnt frq))                       item)
                    ;;  A value that reads as a number counts numerically.
                    (   (distof (car item) 2)
                        (cons (NumStamp:IncNumber (car item) (cadr item)) (cdr item))
                    )
                    (   (cons (NumStamp:IncAlpha (car item) (fix (abs inc))) (cdr item)))
                )
            )
            (setq rst (cadddr item)
                  rfq (cadddr (cdr item))
            )
            (cond
                (   (or (null rfq) (= "" rfq)) out)
                (   (or (null rst) (= "" rst)) out)
                (   (zerop (setq rfq (atoi rfq))) out)
                (   (< 0 (rem cnt rfq)) out)
                (   (cons rst (cdr out)))
            )
        )
        lst
    )
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:IncNumber
;;;
;;; Adds a number to a numeric component, preserving its written form.
;;;
;;; Two things are preserved that a plain addition would destroy:
;;;
;;;   LEADING ZEROS. "001" plus 1 is "002", not "2". The original width is
;;;   measured and the result padded back out to it.
;;;
;;;   DECIMAL PLACES. The result takes whichever of the value or the increment
;;;   has more, so "1.0" plus "0.25" gives "1.25" and not "1.3".
;;;
;;; Minus signs are stripped before measuring and put back afterwards, so a
;;; negative value does not have its sign counted as a digit of width.
;;; ---------------------------------------------------------------------------

(defun NumStamp:IncNumber ( str inc / NS:Rtos NS:Places incd maxd num slen strd )

    ;; DIMZIN 0 keeps trailing zeros, which is what holds the precision.
    (defun NS:Rtos ( num prec / zin out )
        (setq zin (getvar 'dimzin))
        (setvar 'dimzin 0)
        (setq out (rtos num 2 prec))
        (setvar 'dimzin zin)
        out
    )

    (defun NS:Places ( str / pos )
        (if (setq pos (vl-string-position 46 str))
            (- (strlen str) pos 1)
            0
        )
    )

    (setq num (+ (distof str) (distof inc)))

    (if (minusp (distof str)) (setq str (substr str 2)))
    (if (minusp (distof inc)) (setq inc (substr inc 2)))

    (setq incd (NS:Places inc)
          strd (NS:Places str)
          maxd (max incd strd)
          slen (strlen str)
    )
    ;; If the increment introduces decimals the value did not have, the width
    ;; has to grow to accommodate them plus the point itself.
    (cond
        (   (and (< 0 strd) (< 0 incd)) (setq slen (+ (- slen strd) maxd)))
        (   (and (= 0 strd) (< 0 incd)) (setq slen (+ incd slen 1)))
    )

    (setq str (NS:Rtos num maxd))
    (if (minusp num) (setq str (substr str 2)))
    (while (< (strlen str) slen) (setq str (strcat "0" str)))
    (if (minusp num) (strcat "-" str) str)
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:IncAlpha
;;;
;;; Steps an alphabetic component, rolling over like an odometer: Z becomes
;;; AA, AZ becomes BA, and az becomes ba.
;;;
;;; The string is walked from the RIGHT, since that is the digit that changes
;;; fastest. Each character is converted to a position within its own
;;; alphabet -- digits 0-9, upper case A-Z, lower case a-z -- advanced, and
;;; the carry passed to the character on its left. Running off the left-hand
;;; end grows the string by one.
;;;
;;; Each character keeps its own case and kind, so a mixed component such as
;;; "A1" advances both parts in their own alphabets.
;;;
;;; The carry is reduced by one when it grows a new letter, because the new
;;; character starts at A rather than at the position before it -- which is
;;; the difference between AA and AB after Z.
;;; ---------------------------------------------------------------------------

(defun NumStamp:IncAlpha ( str inc / NS:Step chars )

    (defun NS:Step ( chars carry / c base size )
        (cond
            (   (cond
                    ;;  Digits.
                    (   (< 47 (setq c (car chars)) 58) (setq base 48 size 10))
                    ;;  Upper case.
                    (   (< 64 c 91)                    (setq base 65 size 26))
                    ;;  Lower case.
                    (   (< 96 c 123)                   (setq base 97 size 26))
                )
                (setq c     (+ (- c base) carry)
                      carry (/ c size)
                )
                (cons (+ base (rem c size))
                    (if (zerop carry)
                        (cdr chars)
                        (if (cdr chars)
                            (NS:Step (cdr chars) carry)
                            ;; Ran off the end: grow a new character. The
                            ;; carry is reduced for letters because the new
                            ;; one starts at A, not at A plus the carry.
                            (NS:Step (list base) (if (= 10 size) carry (1- carry)))
                        )
                    )
                )
            )
            ;;  Not a letter or digit -- a separator, say -- so it passes
            ;;  through unchanged and the carry moves on past it.
            (   (cons c
                    (if (cdr chars)
                        (NS:Step (cdr chars) carry)
                        (NS:Step '(65) (1- carry))
                    )
                )
            )
        )
    )

    (vl-list->string
        (reverse
            (if (setq chars (reverse (vl-string->list str)))
                (NS:Step chars inc)
                ;; An empty component starts at A.
                (NS:Step '(65) (1- inc))
            )
        )
    )
)

;;; ===========================================================================
;;;                    T H E   C O N T E N T   B U I L D E R
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; NumStamp:ContentBuilder
;;;
;;; The dialog that assembles the components. Returns the new component list,
;;; or the old one if cancelled.
;;;
;;; The live preview at the bottom shows what the next label will read, which
;;; is the quickest way to tell whether the components are right.
;;; ---------------------------------------------------------------------------

(defun NumStamp:ContentBuilder ( dch lst / add-fun tmp )
    (cond
        (   (not (new_dialog "build" dch))
            (princ "\nUnable to open the content builder.")
            lst
        )
        (   (progn
                (NumStamp:InitEntry)
                (NumStamp:ListToDcl "lst" (setq tmp lst))
                (set_tile "prv" (NumStamp:ContentString tmp))

                (setq add-fun
                    (lambda ( / item )
                        (if (setq item (NumStamp:ValidateComponent))
                            (progn
                                (NumStamp:ListToDcl "lst" (setq tmp (append tmp (list item))))
                                (set_tile "prv" (NumStamp:ContentString tmp))
                                (NumStamp:InitEntry)
                            )
                        )
                    )
                )
                (action_tile "add" "(add-fun)")
                ;; Pressing Enter in any field adds the component, so a whole
                ;; component can be typed without reaching for the mouse.
                (foreach k '("txt" "inc" "frq" "rst" "rfq")
                    (action_tile k "(if (= 1 $reason) (add-fun))"))

                (action_tile "clr"
                    (vl-prin1-to-string
                       '(progn
                            (NumStamp:ListToDcl "lst" (setq tmp nil))
                            (set_tile "prv" (NumStamp:ContentString tmp))
                        )
                    )
                )
                (action_tile "rem"
                    (vl-prin1-to-string
                       '(
                            (lambda ( / idx )
                                (if (setq idx (NumStamp:DclToIdx (get_tile "lst")))
                                    (progn
                                        (NumStamp:ListToDcl "lst"
                                            (setq tmp (NumStamp:RemoveNth idx tmp)))
                                        (set_tile "prv" (NumStamp:ContentString tmp))
                                    )
                                    (alert "Select one or more components to remove.")
                                )
                            )
                        )
                    )
                )
                ;;  $reason 4 is a double-click, which edits the component.
                (action_tile "lst"
                    (vl-prin1-to-string
                       '(
                            (lambda ( / idx )
                                (if (and (= 4 $reason)
                                         (setq idx (car (NumStamp:DclToIdx $value))))
                                    (progn
                                        (NumStamp:ListToDcl "lst"
                                            (setq tmp (NumStamp:SubstNth
                                                (NumStamp:EditComponent dch (nth idx tmp))
                                                idx tmp)))
                                        (set_tile "prv" (NumStamp:ContentString tmp))
                                        (mode_tile "txt" 2)
                                    )
                                )
                            )
                        )
                    )
                )

                ;; The four reorder buttons differ only in which function they
                ;; call, so their callbacks are generated rather than written
                ;; out four times. Each takes the index list and the component
                ;; list BY SYMBOL and updates both, so the highlight follows
                ;; the components it was on.
                (foreach k '("Top" "Up" "Down" "Bottom")
                    (action_tile (strcase k t)
                        (strcat
                            "((lambda ( / idx )"
                            " (if (setq idx (NumStamp:DclToIdx (get_tile \"lst\")))"
                            " (progn (NumStamp:Shift" k " 'idx 'tmp)"
                            " (NumStamp:ListToDcl \"lst\" tmp)"
                            " (set_tile \"lst\" (NumStamp:IdxToDcl idx))"
                            " (set_tile \"prv\" (NumStamp:ContentString tmp)))"
                            " (alert \"Select one or more components to move.\"))))"
                        )
                    )
                )
                (action_tile "sort"
                    (vl-prin1-to-string
                       '(
                            (lambda ( / idx )
                                (setq idx (NumStamp:DclToIdx (get_tile "lst")))
                                (NumStamp:SortComponents 'idx 'tmp)
                                (NumStamp:ListToDcl "lst" tmp)
                                (set_tile "lst" (NumStamp:IdxToDcl idx))
                                (set_tile "prv" (NumStamp:ContentString tmp))
                            )
                        )
                    )
                )
                ;; With a selection, only those components swap positions;
                ;; with none, the whole list reverses.
                (action_tile "reverse"
                    (vl-prin1-to-string
                       '(
                            (lambda ( / idx )
                                (if (setq idx (NumStamp:DclToIdx (get_tile "lst")))
                                    (progn
                                        (NumStamp:ReverseComponents 'idx 'tmp)
                                        (NumStamp:ListToDcl "lst" tmp)
                                        (set_tile "lst" (NumStamp:IdxToDcl idx))
                                    )
                                    (NumStamp:ListToDcl "lst" (setq tmp (reverse tmp)))
                                )
                                (set_tile "prv" (NumStamp:ContentString tmp))
                            )
                        )
                    )
                )
                (zerop (start_dialog))
            )
        )
        (   (setq lst tmp))
    )
    lst
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:EditComponent
;;;
;;; Edits one component, opened by double-clicking it.
;;; ---------------------------------------------------------------------------

(defun NumStamp:EditComponent ( dch lst / acc-fun )
    (if (not (new_dialog "edit" dch))
        (progn (princ "\nUnable to open the edit dialog.") lst)
        (progn
            (mapcar 'set_tile '("txt" "inc" "frq" "rst" "rfq") lst)
            (mode_tile "txt" 2)
            (setq acc-fun
                (lambda ( / item )
                    (if (setq item (NumStamp:ValidateComponent))
                        (progn (setq lst item) (done_dialog 1))
                    )
                )
            )
            (foreach k '("txt" "inc" "frq" "rst" "rfq")
                (action_tile k "(if (= 1 $reason) (acc-fun))"))
            (action_tile "accept" "(acc-fun)")
            (start_dialog)
            lst
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:ValidateComponent
;;;
;;; Reads and checks the five entry boxes. Returns the component, or nil.
;;;
;;; Blank increment and frequency default to sensible values rather than
;;; being rejected, since a fixed separator only needs its text filled in.
;;; A reset frequency without a reset value IS rejected, because it would
;;; silently do nothing.
;;; ---------------------------------------------------------------------------

(defun NumStamp:ValidateComponent ( / frq inc rfq rst str )
    (if (= "" (setq inc (get_tile "inc"))) (setq inc "0"))
    (if (= "" (setq frq (get_tile "frq"))) (setq frq "1"))
    (setq rst (get_tile "rst")
          rfq (get_tile "rfq")
    )
    (cond
        (   (= "" (setq str (get_tile "txt")))
            (alert "Enter the component text.")
            (mode_tile "txt" 2)
            nil
        )
        (   (not (distof inc 2))
            (alert "The increment must be a number.")
            (mode_tile "inc" 2)
            nil
        )
        (   (not (and (= 'int (type (read frq))) (< 0 (atoi frq))))
            (alert "The increment frequency must be a positive whole number.")
            (mode_tile "frq" 2)
            nil
        )
        (   (and (/= "" rfq)
                 (not (and (= 'int (type (read rfq))) (< 0 (atoi rfq)))))
            (alert (strcat "The reset frequency must be a positive whole number, "
                           "or blank if not used."))
            (mode_tile "rfq" 2)
            nil
        )
        (   (and (/= "" rfq) (= "" rst))
            (alert (strcat "A reset frequency was given but no reset value.\n\n"
                           "Enter the value the component should return to."))
            (mode_tile "rst" 2)
            nil
        )
        (   (list str inc frq rst rfq))
    )
)

(defun NumStamp:InitEntry ( )
    (set_tile  "txt"  "")
    (set_tile  "inc" "1")
    (set_tile  "frq" "1")
    (set_tile  "rst"  "")
    (set_tile  "rfq"  "")
    (mode_tile "txt"   2)
)

;;; ---------------------------------------------------------------------------
;;; List helpers for the component list.
;;;
;;; A multi-select list box reports its highlighted rows as a space-separated
;;; string of indices; wrapping it in brackets and reading it converts one
;;; way, printing a list and trimming the brackets converts back.
;;; ---------------------------------------------------------------------------

(defun NumStamp:ListToDcl ( key lst )
    (start_list key)
    (foreach item lst (add_list (NumStamp:Join item "\t")))
    (end_list)
)

(defun NumStamp:DclToIdx ( str ) (read (strcat "(" str ")")))

(defun NumStamp:IdxToDcl ( idx )
    (if idx (vl-string-trim "()" (vl-princ-to-string (vl-sort idx '<))) "")
)

(defun NumStamp:RemoveNth ( idxs lst / n )
    (setq n -1)
    (vl-remove-if '(lambda ( x ) (member (setq n (1+ n)) idxs)) lst)
)

(defun NumStamp:SubstNth ( new idx lst / n )
    (setq n -1)
    (mapcar '(lambda ( x ) (if (= idx (setq n (1+ n))) new x)) lst)
)

;;; ---------------------------------------------------------------------------
;;; The four reorder operations.
;;;
;;; Each takes the index list and the component list BY SYMBOL and updates
;;; both, because the caller needs the new positions as well as the new order
;;; -- that is what keeps the moved components highlighted so the buttons can
;;; be pressed repeatedly.
;;;
;;; Top and Bottom pull the selection out and put it back at one end, keeping
;;; the selection's own order. Up and Down walk the list swapping each
;;; selected item with its neighbour, decrementing the indices as they go so
;;; a block of adjacent items moves as a block rather than collapsing.
;;; ---------------------------------------------------------------------------

(defun NumStamp:ShiftTop ( idx-sym lst-sym / cnt idn pos sel rest )
    (setq pos -1 cnt 0)
    (setq rest
        (vl-remove-if
           '(lambda ( item )
                (if (member (setq pos (1+ pos)) (eval idx-sym))
                    (setq sel (cons item sel)
                          idn (cons cnt idn)
                          cnt (1+ cnt)
                    )
                )
            )
            (eval lst-sym)
        )
    )
    (set lst-sym (append (reverse sel) rest))
    (set idx-sym (reverse idn))
)

(defun NumStamp:ShiftBottom ( idx-sym lst-sym / cnt idn pos sel rest )
    (setq pos -1
          cnt (1- (length (eval lst-sym)))
    )
    (setq rest
        (vl-remove-if
           '(lambda ( item )
                (if (member (setq pos (1+ pos)) (eval idx-sym))
                    (setq sel (cons item sel)
                          idn (cons cnt idn)
                          cnt (1- cnt)
                    )
                )
            )
            (eval lst-sym)
        )
    )
    (set lst-sym (append rest (reverse sel)))
    (set idx-sym idn)
)

(defun NumStamp:ShiftUp ( idx-sym lst-sym / idn idx lst num out )
    (setq idx (eval idx-sym)
          lst (eval lst-sym)
          num 1
    )
    (while (and idx (cadr lst))
        (cond
            ;;  This position is selected: swap it with the one before.
            (   (= num (car idx))
                (setq out (cons (cadr lst) out)
                      lst (cons (car lst) (cddr lst))
                      idn (cons (1- num) idn)
                      idx (cdr idx)
                )
            )
            ;;  Already at the top of what remains: it stays put.
            (   (= (1- num) (car idx))
                (setq out (cons (car lst) out)
                      idn (cons (1- num) idn)
                      lst (cdr lst)
                      idx (cdr idx)
                )
            )
            (   (setq out (cons (car lst) out)
                      lst (cdr lst)
                )
            )
        )
        (setq num (1+ num))
    )
    (set idx-sym (reverse idn))
    (set lst-sym (append (reverse out) lst))
)

;;; Moving down is moving up in a reversed list, which is why the indices are
;;; mirrored and the walk runs backwards.
(defun NumStamp:ShiftDown ( idx-sym lst-sym / idn idx lst num out )
    (setq idx (reverse (eval idx-sym))
          lst (reverse (eval lst-sym))
          num (- (length lst) 2)
    )
    (while (and idx (cadr lst))
        (cond
            (   (= num (car idx))
                (setq out (cons (cadr lst) out)
                      lst (cons (car lst) (cddr lst))
                      idn (cons (1+ num) idn)
                      idx (cdr idx)
                )
            )
            (   (= (1+ num) (car idx))
                (setq out (cons (car lst) out)
                      idn (cons (1+ num) idn)
                      lst (cdr lst)
                      idx (cdr idx)
                )
            )
            (   (setq out (cons (car lst) out)
                      lst (cdr lst)
                )
            )
        )
        (setq num (1- num))
    )
    (set idx-sym idn)
    (set lst-sym (append (reverse lst) out))
)

(defun NumStamp:SortComponents ( idx-sym lst-sym / lst order )
    (setq lst   (eval lst-sym)
          order (vl-sort-i lst '(lambda ( a b ) (< (strcase (car a)) (strcase (car b)))))
    )
    (set lst-sym (mapcar '(lambda ( n ) (nth n lst)) order))
    (set idx-sym (mapcar '(lambda ( n ) (vl-position n order)) (eval idx-sym)))
)

;;; Reverses only the selected components, leaving them in the same POSITIONS
;;; but in the opposite order, and leaving everything else untouched.
(defun NumStamp:ReverseComponents ( idx-sym lst-sym / idx lst pos rev )
    (setq idx (eval idx-sym)
          lst (eval lst-sym)
          rev (reverse (vl-sort idx '<))
          pos -1
    )
    (set lst-sym
        (mapcar
           '(lambda ( item )
                (if (member (setq pos (1+ pos)) idx)
                    (setq item (nth (car rev) lst)
                          rev  (cdr rev)
                    )
                )
                item
            )
            lst
        )
    )
)

;;; ===========================================================================
;;;                        P L A C E M E N T   A I D S
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; NumStamp:AlignToCurve
;;;
;;; Slides the label along a curve, following the tangent, until it is
;;; clicked into place. Returns T if placed, nil if abandoned.
;;;
;;; The offset is stored as a FACTOR of the label's own size -- text height,
;;; or half a block's bounding box height -- so it stays proportionate
;;; whatever the label is.
;;;
;;;   obj - the label object
;;;   prp - which property moves it
;;;   ent - the curve
;;;   bor - the border object, or nil
;;; ---------------------------------------------------------------------------

(defun NumStamp:AlignToCurve ( obj prp ent bor / a1 fac ll msg mtx p1 placed g1 g2 gr ur xa )

    (setq fac
        (if (= "AcDbBlockReference" (vla-get-objectname obj))
            (progn
                (vla-getboundingbox obj 'll 'ur)
                (/ (- (cadr (vlax-safearray->list ur))
                      (cadr (vlax-safearray->list ll)))
                   2.0)
            )
            (vla-get-height obj)
        )
    )
    (setq mtx (= "AcDbMText" (vla-get-objectname obj)))
    (setq msg (princ (strcat "\nClick to place <exit>: [+/-] or [O]ffset, [P]erpendicular"
                             (if (and bor (= "3" bor-shp)) ", Rotate [B]order" "")
                             (if mtx ", B[a]ckground Mask" ""))))
    (setq xa (angle '(0.0 0.0 0.0)
                    (trans (getvar 'ucsxdir) 0 (trans '(0.0 0.0 1.0) 1 0 t))))

    (while
        (progn
            (setq gr (grread t 15 0)
                  g1 (car  gr)
                  g2 (cadr gr)
            )
            (cond
                (   (member g1 '(3 5))
                    ;; The closest point on the curve, and the direction from
                    ;; it to the cursor -- which is both the offset direction
                    ;; and, turned by the stored quarter-turn, the rotation.
                    (setq p1 (vlax-curve-getclosestpointto ent (setq g2 (trans g2 1 0)))
                          a1 (angle p1 g2)
                          p1 (vlax-3d-point (polar p1 a1 (* fac crv-off)))
                          a1 (NumStamp:Readable (+ a1 crv-per))
                    )
                    (if bor (vla-move bor (vlax-get-property obj prp) p1))
                    (vlax-put-property obj prp p1)
                    (if bor
                        (vla-rotate bor p1
                            (- a1 (if mtx (+ (vla-get-rotation obj) xa)
                                          (vla-get-rotation obj))))
                    )
                    (vla-put-rotation obj (if mtx (- a1 xa) a1))
                    (null (setq placed (= 3 g1)))
                )
                (   (= 25 g1) nil)
                (   (= 2 g1)
                    (cond
                        ;;  P: swap between running along the curve and
                        ;;  across it.
                        (   (member g2 '(80 112)) (setq crv-per (- (/ pi 2.0) crv-per)) t)
                        (   (member g2 '(45 95))  (setq crv-off (- crv-off 0.1)) t)
                        (   (member g2 '(43 61))  (setq crv-off (+ crv-off 0.1)) t)
                        (   (member g2 '(13 32))  nil)
                        (   (member g2 '(79 111))
                            (setq crv-off
                                (/ (cond ((getdist (strcat "\nOffset <"
                                                           (rtos (* fac crv-off)) ">: ")))
                                         ((* fac crv-off)))
                                   fac))
                            (princ msg)
                            t
                        )
                        (   (and (member g2 '(65 97)) mtx)
                            (vlax-put obj 'backgroundfill
                                (setq mtx-bak (~ (vlax-get obj 'backgroundfill))))
                            (princ (if (zerop mtx-bak) "\n<Background mask off>"
                                                       "\n<Background mask on>"))
                            (princ msg)
                            t
                        )
                        (   (member g2 '(66 98))
                            (if (and bor (= "3" bor-shp))
                                (progn
                                    (setq bor-rot (not bor-rot))
                                    (vla-rotate bor
                                        (vlax-3d-point (NumStamp:Centroid bor))
                                        (/ pi bor-sid#))
                                )
                                (princ (strcat "\nInvalid keypress." msg))
                            )
                            t
                        )
                        (   (princ (strcat "\nInvalid keypress." msg)) t)
                    )
                )
                (   t t)
            )
        )
    )
    (redraw)
    placed
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:Replace
;;;
;;; Writes the current label over the text of something already in the
;;; drawing, rather than creating a new object. Returns T if something was
;;; replaced.
;;;
;;; Every kind of annotation is handled: attributes, dimension overrides, text
;;; and mtext, multileader text, multileader block attributes, and ordinary
;;; block attributes. Where a block or multileader has several attributes, a
;;; list box asks which.
;;;
;;; nentsel is used so an attribute nested inside a block can be picked
;;; directly.
;;; ---------------------------------------------------------------------------

(defun NumStamp:Replace ( str / aid enx fun objs par rtn sel tmp )
    (while
        (progn
            (setvar 'errno 0)
            (setq sel (nentsel "\nSelect annotation to replace <exit>: "))
            (cond
                (   (= 7 (getvar 'errno)) (princ "\nMissed, try again."))
                (   (null sel) (setq rtn nil))
                (   (progn
                        (setq enx (entget (car sel))
                              par (cadddr sel)
                              objs nil
                              fun  nil
                              aid  nil
                              tmp  nil
                        )
                        (cond
                            (   (= "ATTRIB" (cdr (assoc 0 enx)))
                                (setq objs (list (vlax-ename->vla-object (car sel)))
                                      fun  vla-put-textstring)
                            )
                            ;;  A dimension's text lives on the dimension, not
                            ;;  on the mtext inside its block, so the parent is
                            ;;  used.
                            (   (and par (wcmatch (cdr (assoc 0 (entget (car par)))) "*DIMENSION"))
                                (setq objs (list (vlax-ename->vla-object (car par)))
                                      fun  vla-put-textoverride)
                            )
                            (   (wcmatch (cdr (assoc 0 enx)) "TEXT,MTEXT")
                                (setq objs (list (vlax-ename->vla-object (car sel)))
                                      fun  vla-put-textstring)
                            )
                            (   (= "MULTILEADER" (cdr (assoc 0 enx)))
                                (setq objs (list (vlax-ename->vla-object (car sel))))
                                (cond
                                    ;;  Block content: the attributes are
                                    ;;  addressed by the object ID of their
                                    ;;  DEFINITION, not as entities.
                                    (   (= acblockcontent (vla-get-contenttype (car objs)))
                                        (vlax-for sub
                                            (vla-item (vla-get-blocks (NumStamp:Doc))
                                                (vla-get-contentblockname (car objs)))
                                            (if (= "AcDbAttributeDefinition"
                                                   (vla-get-objectname sub))
                                                (setq tmp (cons sub tmp)
                                                      aid (cons (NumStamp:ObjectId sub) aid))
                                            )
                                        )
                                        (setq tmp (reverse tmp)
                                              aid (reverse aid)
                                        )
                                        (if (or (not (cdr aid))
                                                (setq aid (mapcar '(lambda ( n ) (nth n aid))
                                                    (NumStamp:ListBox "Select attributes"
                                                        (mapcar 'vla-get-tagstring tmp)))))
                                            (setq fun (NumStamp:SetBlockAttribute))
                                        )
                                        t
                                    )
                                    (   (= acmtextcontent (vla-get-contenttype (car objs)))
                                        (setq fun vla-put-textstring)
                                    )
                                    (   (princ "\nThat multileader has no editable text."))
                                )
                            )
                            (   (and par
                                     (= "INSERT" (cdr (assoc 0 (entget (last par)))))
                                     (setq objs (vlax-invoke
                                         (vlax-ename->vla-object (last par)) 'getattributes)))
                                (if (or (not (cdr objs))
                                        (setq objs (mapcar '(lambda ( n ) (nth n objs))
                                            (NumStamp:ListBox "Select attributes"
                                                (mapcar 'vla-get-tagstring objs)))))
                                    (setq fun vla-put-textstring)
                                )
                                t
                            )
                            (   (princ "\nThat object has no editable text."))
                        )
                        (not (and objs fun))
                    )
                    t
                )
                (   (vl-some '(lambda ( x ) (not (vlax-write-enabled-p x))) objs)
                    (princ "\nThat object is on a locked layer or is write-protected.")
                )
                (   (setq rtn t)
                    (if aid
                        (foreach id aid (fun (car objs) id str))
                        (foreach o objs (fun o str))
                    )
                    ;; A multileader or dimension has to be told to redraw its
                    ;; own block after the text inside it changes.
                    (if par (entupd (last par)))
                    nil
                )
            )
        )
    )
    rtn
)

;;; ---------------------------------------------------------------------------
;;; 64-bit safe accessors.
;;;
;;; On 64-bit AutoCAD an object ID does not fit in a 32-bit integer, so
;;; 32-suffixed variants were added that pass it as a string. Which exists
;;; depends on the release, so each is tested once and then cached.
;;; ---------------------------------------------------------------------------

(defun NumStamp:ObjectId ( obj )
    (if (vlax-property-available-p obj 'objectid32)
        (vla-get-objectid32 obj)
        (vla-get-objectid   obj)
    )
)

(defun NumStamp:SetBlockAttribute ( )
    (if (vlax-method-applicable-p (vlax-get-acad-object) 'setblockattributevalue32)
        (lambda ( obj id str ) (vla-setblockattributevalue32 obj id str))
        (lambda ( obj id str ) (vla-setblockattributevalue   obj id str))
    )
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:TextInCell
;;;
;;; If the point falls inside a table cell, writes the label into that cell
;;; and returns T. HitTest is a ray cast along the view direction, so it works
;;; in a rotated view as well as in plan.
;;; ---------------------------------------------------------------------------

(defun NumStamp:TextInCell ( tables pnt str / dir hit )
    (setq dir (vlax-3d-point (trans (getvar 'viewdir) 1 0)))
    (if (setq hit
            (vl-some
               '(lambda ( tab / row col )
                    (if (= :vlax-true (vla-hittest tab pnt dir 'row 'col))
                        (list tab row col)
                    )
                )
                tables
            )
        )
        ;; SetText returns nil on success, so the result is negated to give a
        ;; true "it went in the cell" answer.
        (not (apply 'vla-settext (append hit (list str))))
    )
)

;;; ---------------------------------------------------------------------------
;;; Rotation helpers.
;;;
;;; ShowRotation writes the current angle to the status line through
;;; MODEMACRO, which is the only way to keep a readout on screen during a
;;; grread loop. SetRotation turns the label and its border together, keeping
;;; the border registered.
;;; ---------------------------------------------------------------------------

(defun NumStamp:ShowRotation ( rot )
    (setvar 'modemacro
        (strcat "Rotation: "
                (rtos (rem (+ 360.0 (* 180.0 (/ rot pi))) 360) 2 2)
                (chr 186))     ;; the degree sign
    )
)

(defun NumStamp:SetRotation ( obj bor prop rot typ xa )
    (if bor
        ;; The border is rotated by the DIFFERENCE, since it is already at the
        ;; old angle. MText stores rotation without the UCS offset; text and
        ;; blocks store it with, hence the two cases.
        (vla-rotate bor (vlax-get-property obj prop)
            (- rot (if (= "obj-mtx" typ)
                       (vla-get-rotation obj)
                       (- (vla-get-rotation obj) xa))))
    )
    (vla-put-rotation obj (if (= "obj-mtx" typ) rot (+ rot xa)))
)

(defun NumStamp:AskRotation ( typ rot / new )
    (setq new (getangle (strcat "\nSpecify "
                    (cdr (assoc typ '(("obj-txt" . "text")
                                      ("obj-mtx" . "mtext")
                                      ("obj-blk" . "block"))))
                    " rotation <" (angtos rot) ">: ")))
    (cond (new) (rot))
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:DragMessage
;;;
;;; Builds the key list shown while placing. The border and mask keys only
;;; appear when they would do something.
;;; ---------------------------------------------------------------------------

(defun NumStamp:DragMessage ( typ enc shp dynamic )
    (strcat
        (if dynamic
            "\n[C]urve aligned, [R]eplace, r[O]tate, [<]/[>] nudge, [T]oggle count, [I]ncrement\n"
            "\nPick point or [C]urve aligned, [R]eplace, r[O]tation, [T]oggle count, [I]ncrement\n"
        )
        (if (and (/= "obj-blk" typ) (= "1" enc) (= "3" shp)) "Rotate [B]order, " "")
        "[Tab]/[RO]tate 90" (chr 186) ", [M]irror rotation"
        (if (= "obj-mtx" typ) ", b[A]ckground mask" "")
        (if dynamic " <Exit>" " <Exit>: ")
    )
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:SelectIf
;;;
;;; Repeats a selection prompt until something satisfying the test is picked,
;;; or the user presses Enter. ERRNO 7 means the pick found nothing at all,
;;; which deserves a different message from picking the wrong thing.
;;; ---------------------------------------------------------------------------

(defun NumStamp:SelectIf ( msg pred func / ent )
    (setq pred (eval pred))
    (while
        (progn
            (setvar 'errno 0)
            (setq ent (func msg))
            (cond
                (   (= 7 (getvar 'errno)) (princ "\nMissed, try again."))
                (   (null ent) nil)
                (   (not (pred (car ent)))
                    (princ "\nThat object cannot be used.")
                )
            )
        )
    )
    ent
)

;;; ===========================================================================
;;;                            G E O M E T R Y
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; NumStamp:TextBorder
;;;
;;; Draws the enclosure around a label and returns its entity name.
;;;
;;; Everything is built from the text's measured extents, so the border always
;;; fits the label whatever it turned out to be.
;;;
;;;   ent - the label entity
;;;   typ - "0" circle, "1" rectangle, "2" slot, "3" polygon
;;;   off - offset from the text
;;;   fx1 - fixed size, or nil to fit the text
;;;   fx2 - second fixed dimension, for rectangles and slots
;;;   sid - polygon side count
;;; ---------------------------------------------------------------------------

(defun NumStamp:TextBorder ( ent typ off fx1 fx2 sid / cen enx i inc lst mat pts rad rot vec )
    (setq enx (entget ent))
    (if (setq lst (NumStamp:TextBox enx off))
        (progn
            (setq cen (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car lst) (caddr lst))
                  ;; MText stores its angle as a direction vector in group 11;
                  ;; TEXT stores it as an angle in group 50.
                  rot (if (= "MTEXT" (cdr (assoc 0 enx)))
                          (angle '(0. 0. 0.)
                                 (trans (cdr (assoc 11 enx)) 0 (cdr (assoc 210 enx))))
                          (cdr (assoc 50 enx)))
            )
            (cond
                ;;  ---- circle ----
                ;;  Through the box corners, so the text is fully enclosed
                ;;  whatever its proportions.
                (   (= "0" typ)
                    (entmakex
                        (list '(0 . "CIRCLE")
                              (cons 10 cen)
                              (cons 40 (cond (fx1) ((distance cen (car lst)))))
                              (assoc 210 enx)))
                )
                ;;  ---- rectangle or slot ----
                (   (member typ '("1" "2"))
                    (if (and fx1 fx2)
                        ;; A fixed size is built square about the centre and
                        ;; then rotated to match the text, since the measured
                        ;; box cannot be used for its dimensions.
                        (progn
                            (setq fx1 (/ fx1 2.0)
                                  fx2 (/ fx2 2.0)
                                  mat (list (list (cos rot) (- (sin rot)) 0.0)
                                            (list (sin rot)    (cos rot)  0.0)
                                           '(0.0 0.0 1.0))
                            )
                            ;; Rotating about the centre rather than the origin
                            ;; means the offset has to be corrected for.
                            (setq vec (mapcar '- cen (NumStamp:MxV mat cen)))
                            (setq lst
                                (list
                                    (list (- (car cen) fx1) (- (cadr cen) fx2) (caddr cen))
                                    (list (+ (car cen) fx1) (- (cadr cen) fx2) (caddr cen))
                                    (list (+ (car cen) fx1) (+ (cadr cen) fx2) (caddr cen))
                                    (list (- (car cen) fx1) (+ (cadr cen) fx2) (caddr cen))
                                )
                            )
                            (entmakex
                                (append
                                   '((000 . "LWPOLYLINE") (100 . "AcDbEntity")
                                     (100 . "AcDbPolyline") (090 . 4) (070 . 1))
                                    (list (cons 38 (caddar lst)))
                                    (apply 'append
                                        (mapcar
                                           '(lambda ( p b )
                                                (list (cons 10 (mapcar '+ (NumStamp:MxV mat p) vec))
                                                      (cons 42 b)))
                                            lst
                                            ;; A slot is the same rectangle
                                            ;; with a half-circle bulge on the
                                            ;; two end edges.
                                            (if (= "1" typ) '(0.0 0.0 0.0 0.0)
                                                            '(0.0 1.0 0.0 1.0))
                                        )
                                    )
                                    (list (assoc 210 enx))
                                )
                            )
                        )
                        ;; Fitted to the text: the measured box IS the border.
                        (entmakex
                            (append
                               '((000 . "LWPOLYLINE") (100 . "AcDbEntity")
                                 (100 . "AcDbPolyline") (090 . 4) (070 . 1))
                                (list (cons 38 (caddar lst)))
                                (apply 'append
                                    (mapcar '(lambda ( p b ) (list (cons 10 p) (cons 42 b)))
                                            lst
                                            (if (= "1" typ) '(0.0 0.0 0.0 0.0)
                                                            '(0.0 1.0 0.0 1.0))))
                                (list (assoc 210 enx))
                            )
                        )
                    )
                )
                ;;  ---- polygon ----
                (   t
                    (setq inc (/ (+ pi pi) sid)
                          ;; Dividing by the cosine of half a segment gives the
                          ;; circumradius from the inradius, which is what puts
                          ;; the text inside the polygon rather than touching
                          ;; its corners.
                          rad (cond (fx1) ((/ (distance cen (car lst)) (cos (/ inc 2.0)))))
                          i   -1
                    )
                    ;; An odd number of sides looks wrong point-first, so it is
                    ;; turned a quarter to stand on a flat.
                    (if (= 1 (logand 1 sid)) (setq rot (+ rot (/ pi 2.))))
                    (repeat sid
                        (setq pts (cons (cons 10 (polar cen (+ rot (* (setq i (1+ i)) inc)) rad))
                                        pts))
                    )
                    (entmakex
                        (append
                            (list '(000 . "LWPOLYLINE") '(100 . "AcDbEntity")
                                  '(100 . "AcDbPolyline")
                                  (cons 90 (length pts)) '(070 . 1))
                            (list (cons 38 (caddar lst)))
                            (reverse pts)
                            (list (assoc 210 enx))
                        )
                    )
                )
            )
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:TextBox
;;;
;;; Returns the four corners of the offset box around a text object, in world
;;; coordinates, anticlockwise from lower left.
;;;
;;; TEXT is measured with the built-in textbox function, which accounts for
;;; style, width factor and obliquing. MTEXT has no equivalent, so the box is
;;; built from its stored width and height, positioned according to its
;;; attachment point -- which runs 1 to 9 from top-left to bottom-right.
;;;
;;; In both cases the box is then rotated to the text's angle and translated
;;; to its position.
;;; ---------------------------------------------------------------------------

(defun NumStamp:TextBox ( enx off / base box hgt jst nrm org rot wid )
    (if (setq box
            (cond
                (   (= "TEXT" (cdr (assoc 0 enx)))
                    (setq base (cdr (assoc 10 enx))
                          rot  (cdr (assoc 50 enx))
                          box  (textbox enx)
                    )
                    (list (list (- (caar  box) off) (- (cadar  box) off))
                          (list (+ (caadr box) off) (- (cadar  box) off))
                          (list (+ (caadr box) off) (+ (cadadr box) off))
                          (list (- (caar  box) off) (+ (cadadr box) off))
                    )
                )
                (   (= "MTEXT" (cdr (assoc 0 enx)))
                    (setq nrm  (cdr (assoc 210 enx))
                          base (trans (cdr (assoc 10 enx)) 0 nrm)
                          rot  (angle '(0.0 0.0 0.0) (trans (cdr (assoc 11 enx)) 0 nrm))
                          wid  (cdr (assoc 42 enx))
                          hgt  (cdr (assoc 43 enx))
                          jst  (cdr (assoc 71 enx))
                          org  (list
                                   (cond ((member jst '(2 5 8)) (/ wid -2.0))
                                         ((member jst '(3 6 9)) (- wid))
                                         (0.0))
                                   (cond ((member jst '(1 2 3)) (- hgt))
                                         ((member jst '(4 5 6)) (/ hgt -2.0))
                                         (0.0))
                               )
                    )
                    (list (list (- (car org)     off) (- (cadr org)     off))
                          (list (+ (car org) wid off) (- (cadr org)     off))
                          (list (+ (car org) wid off) (+ (cadr org) hgt off))
                          (list (- (car org)     off) (+ (cadr org) hgt off))
                    )
                )
            )
        )
        (   (lambda ( mat )
                (mapcar '(lambda ( p ) (mapcar '+ (NumStamp:MxV mat p) base)) box)
            )
            (list (list (cos rot) (sin (- rot)) 0.0)
                  (list (sin rot) (cos rot)     0.0)
                 '(0.0 0.0 1.0))
        )
    )
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:MTextWidth
;;;
;;; Returns the width to create an mtext at so its content stays on one line.
;;;
;;; A temporary mtext is created, measured through the same routine the
;;; borders use, and deleted. That is more reliable than the textbox function,
;;; which measures single-line text and gets mtext formatting codes wrong;
;;; textbox is kept only as a fallback.
;;;
;;; The result is padded by 2.5 per cent, because a width exactly equal to the
;;; content occasionally wraps anyway through rounding.
;;; ---------------------------------------------------------------------------

(defun NumStamp:MTextWidth ( str sty hgt / box fac tmp )
    (setq fac 1.025)
    (cond
        (   (setq tmp (entmakex
                (list '(000 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText")
                     '(10 0.0 0.0 0.0)
                      (cons 01 str) (cons 07 sty) (cons 40 hgt))))
            (setq box (NumStamp:TextBox (entget tmp) 0.0))
            (entdel tmp)
            (* fac (- (caadr box) (caar box)))
        )
        (   (   (lambda ( b ) (if b (* fac (- (caadr b) (caar b)))))
                (textbox (list (cons 01 str) (cons 40 hgt) (cons 07 sty)))
            )
        )
        (   0.0)
    )
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:Centroid
;;;
;;; The average of a closed polyline's vertices, which for a regular polygon
;;; is its centre -- the point a half-segment rotation must turn about.
;;; ---------------------------------------------------------------------------

(defun NumStamp:Centroid ( obj / NS:Pairs pts )
    (defun NS:Pairs ( lst )
        (if lst (cons (list (car lst) (cadr lst)) (NS:Pairs (cddr lst))))
    )
    (setq pts (NS:Pairs (vlax-get obj 'coordinates)))
    (   (lambda ( n ) (mapcar '/ (apply 'mapcar (cons '+ pts)) (list n n)))
        (float (length pts))
    )
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:Readable
;;;
;;; Adjusts an angle so text drawn at it always reads left to right. Anything
;;; landing in the left half of the circle is turned a further 180 degrees.
;;; ---------------------------------------------------------------------------

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

;;; ---------------------------------------------------------------------------
;;; NumStamp:RoundTo
;;;
;;; Rounds a to the nearest multiple of b. Adding half a step before
;;; truncating is what turns truncation into rounding; the sign test makes it
;;; work for negative angles too.
;;; ---------------------------------------------------------------------------

(defun NumStamp:RoundTo ( a b )
    (* b (fix (/ (+ a (* b (if (minusp a) -0.5 0.5))) b)))
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:MxV
;;;
;;; Multiplies a matrix by a vector: each row dotted with the vector.
;;; ---------------------------------------------------------------------------

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

;;; ===========================================================================
;;;                    D R A W I N G   I N F O R M A T I O N
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; NumStamp:TableItems
;;;
;;; Returns the names in a symbol table, excluding anonymous and
;;; xref-dependent entries -- and, for layers, locked ones, since nothing can
;;; be drawn on those.
;;; ---------------------------------------------------------------------------

(defun NumStamp:TableItems ( table / def out )
    (while (setq def (tblnext table (null def)))
        (if (not (or (wcmatch (cdr (assoc 2 def)) "`**,*|*")
                     (and (= "layer" (strcase table t))
                          (= 4 (logand 4 (cdr (assoc 70 def)))))))
            (setq out (cons (cdr (assoc 2 def)) out))
        )
    )
    (acad_strlsort out)
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:BlockData
;;;
;;; Returns every attributed block in the drawing paired with its tag list.
;;;
;;; Bit 2 of DXF 70 on the block record means the block has attributes. Blocks
;;; with no attribute definitions are excluded, since there would be nowhere
;;; to put the label.
;;; ---------------------------------------------------------------------------

(defun NumStamp:BlockData ( / def out tags )
    (while (setq def (tblnext "block" (null def)))
        (if (and (null (wcmatch (cdr (assoc 2 def)) "`**,*|*"))
                 (= 2 (logand 2 (cdr (assoc 70 def))))
                 (setq tags
                     (   (lambda ( ent / enx acc )
                             (while (setq ent (entnext ent))
                                 (if (= "ATTDEF" (cdr (assoc 0 (setq enx (entget ent)))))
                                     (setq acc (cons (strcase (cdr (assoc 2 enx))) acc))
                                 )
                             )
                             (vl-sort acc '<)
                         )
                         (tblobjname "block" (cdr (assoc 2 def)))
                     )
                 )
            )
            (setq out (cons (cons (cdr (assoc 2 def)) tags) out))
        )
    )
    (vl-sort out '(lambda ( a b ) (< (car a) (car b))))
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:Annotative
;;;
;;; Returns non-nil if a text style is annotative. There is no table flag for
;;; this: it is stored as extended data under "AcadAnnotative", where group
;;; 1070 holds 1 for annotative.
;;; ---------------------------------------------------------------------------

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

;;; ---------------------------------------------------------------------------
;;; NumStamp:ListBox
;;;
;;; A simple multi-select list, reusing the loaded dialog. Returns the chosen
;;; indices, or nil.
;;; ---------------------------------------------------------------------------

(defun NumStamp:ListBox ( msg lst / rtn )
    (if (or (null dch) (not (new_dialog "listbox" dch)))
        (progn (princ "\nUnable to open the selection list.") nil)
        (progn
            (set_tile "dcl" msg)
            (start_list "lst")
            (foreach x lst (add_list x))
            (end_list)
            (setq rtn (set_tile "lst" "0"))
            (action_tile "lst" "(setq rtn $value)")
            (if (= 1 (start_dialog)) (read (strcat "(" rtn ")")))
        )
    )
)

(defun NumStamp:FillList ( key lst )
    (start_list key)
    (foreach x lst (add_list x))
    (end_list)
)

(defun NumStamp:Join ( lst del )
    (if (cdr lst)
        (strcat (car lst) del (NumStamp:Join (cdr lst) del))
        (car lst)
    )
)

;;; ===========================================================================
;;;                            S E T T I N G S
;;; ===========================================================================

;;; ---------------------------------------------------------------------------
;;; NumStamp:ToString
;;;
;;; Converts a value to text for the settings file. Reals are written to
;;; fifteen places with DIMZIN suppressing trailing zeros, so the value comes
;;; back unchanged regardless of the drawing's precision setting.
;;; ---------------------------------------------------------------------------

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

(defun NumStamp:JoinCfg ( lst del )
    (if (cdr lst)
        (strcat (NumStamp:ToString (car lst)) del (NumStamp:JoinCfg (cdr lst) del))
        (NumStamp:ToString (car lst))
    )
)

;;; ---------------------------------------------------------------------------
;;; NumStamp:WriteConfig / NumStamp:ReadConfig
;;;
;;; Save and reload the settings.
;;;
;;; The format is one "name: value" line per setting, with list settings --
;;; the component list, the mask colour -- written as a braced block, one item
;;; per line. That keeps the file readable and hand-editable, which matters
;;; because whole configurations are meant to be shared.
;;;
;;; The reader is defensive in a way that matters here: every value is
;;; TYPE-CHECKED against the default before being accepted. A hand-edited file
;;; that puts a string where a number belongs falls back to the default rather
;;; than causing an error much later, somewhere unrelated.
;;; ---------------------------------------------------------------------------

(defun NumStamp:WriteConfig ( name syms / des )
    (if (setq des (open name "w"))
        (progn
            (foreach sym syms
                (if (= 'list (type (eval sym)))
                    (progn
                        (write-line (strcat (vl-symbol-name sym) ":{") des)
                        (foreach item (eval sym)
                            ;; A proper list is written as a bracketed row;
                            ;; a dotted pair is written as printed.
                            (if (and (= 'list (type item)) (vl-list-length item))
                                (write-line (strcat "(" (NumStamp:JoinCfg item "\t") ")") des)
                                (write-line (NumStamp:ToString item) des)
                            )
                        )
                        (write-line "}" des)
                    )
                    (write-line (strcat (vl-symbol-name sym) ":"
                                        (NumStamp:ToString (eval sym))) des)
                )
            )
            (close des)
            t
        )
    )
)

(defun NumStamp:ReadConfig ( name defs / chk des item key line pos sub val )
    (if (and (setq name (findfile name))
             (setq des  (open name "r"))
        )
        (progn
            (while (setq line (read-line des))
                (cond
                    ;;  Not a "name: value" line at all.
                    (   (not (setq pos (vl-string-position 58 line))))
                    (   (not (setq key (read (substr line 1 pos)))))
                    ;;  A name this program does not recognise is ignored,
                    ;;  which is what lets an older settings file load into a
                    ;;  newer version.
                    (   (not (setq chk (assoc key defs))))
                    ;;  A braced block: read until the closing brace.
                    (   (= "{" (setq val (vl-string-trim " \t\n" (substr line (+ 2 pos)))))
                        (while (and (setq item (read-line des))
                                    (setq item (vl-string-trim " \t\n" item))
                                    (/= "}" item))
                            (setq sub (cons (read item) sub))
                        )
                        (if (= 'list (type (cdr chk)))
                            (set key (reverse sub))
                            (set key (cdr chk))
                        )
                        (setq sub nil)
                    )
                    (   t
                        (setq val (read val))
                        ;; The type check: a value of the wrong kind is
                        ;; replaced by the default.
                        (if (= (type val) (type (cdr chk)))
                            (set key val)
                            (set key (cdr chk))
                        )
                    )
                )
            )
            (close des)
            t
        )
    )
)

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

;;; ---------------------------------------------------------------------------
;;; NumStamp:DialogText
;;;
;;; Returns the DCL as a list of lines. Kept in its own function so the main
;;; command reads as logic rather than as a wall of markup.
;;; ---------------------------------------------------------------------------

(defun NumStamp:DialogText ( )
   '(
        "e8  : edit_box   { edit_width =  8; fixed_width = true; alignment = left; }"
        "e12 : edit_box   { edit_width = 12; fixed_width = true; alignment = left; }"
        "e40 : edit_box   { edit_width = 40; fixed_width = true; alignment = left; }"
        "pop : popup_list { width = 24; fixed_width = true; alignment = left; }"
        "b12 : button     { width = 12; fixed_width = true; alignment = centered; }"
        "pik : image_button { width = 3.0; aspect_ratio = 1.0;"
        "                     fixed_width = true; fixed_height = true; color = 7; }"
        "col : image_button { width = 6.0; height = 1.4;"
        "                     fixed_width = true; fixed_height = true; color = 1; }"
        ""
        "numinc : dialog { key = \"dcl\";"
        "  spacer;"
        "  : boxed_column { label = \"Content\";"
        "    : row {"
        "      : e40 { key = \"con\"; label = \"Next label:\"; is_enabled = false; }"
        "      : b12 { key = \"bld\"; label = \"Build...\"; }"
        "    }"
        "    : row {"
        "      : e8 { key = \"glb\"; label = \"Counter starts at:\"; }"
        "      : toggle { key = \"dyn-flg\"; label = \"Dynamic preview\"; }"
        "    }"
        "    spacer;"
        "  }"
        "  : row {"
        "    : boxed_radio_column { label = \"Object\";"
        "      : radio_button { key = \"obj-txt\"; label = \"Text\"; }"
        "      : radio_button { key = \"obj-mtx\"; label = \"MText\"; }"
        "      : radio_button { key = \"obj-blk\"; label = \"Block\"; }"
        "      spacer;"
        "    }"
        "    : boxed_column { label = \"Block\";"
        "      : row {"
        "        : text { key = \"blk-txt\"; label = \"Name:\"; }"
        "        : pop  { key = \"blk-nme\"; }"
        "        : pik  { key = \"blk-pik\"; }"
        "      }"
        "      : row {"
        "        : text { key = \"att-txt\"; label = \"Tag:\"; }"
        "        : pop  { key = \"att-nme\"; }"
        "      }"
        "      : row {"
        "        : e12    { key = \"blk-scl\"; label = \"Scale:\"; }"
        "        : pik    { key = \"scl-pik\"; }"
        "        : toggle { key = \"scl-var\"; label = \"From:\"; }"
        "        : pop    { key = \"scl-pop\"; }"
        "      }"
        "      spacer;"
        "    }"
        "  }"
        "  : row {"
        "    : boxed_column { label = \"Formatting\";"
        "      : row { : text { key = \"lay-txt\"; label = \"Text Layer: \"; }"
        "              : pop  { key = \"txt-lay\"; } }"
        "      : row { : text { key = \"sty-txt\"; label = \"Style: \"; }"
        "              : pop  { key = \"txt-sty\"; } }"
        "      : row { : text { key = \"aln-txt\"; label = \"Justify: \"; }"
        "              : pop  { key = \"txt-aln\"; } }"
        "      : row {"
        "        : e12    { key = \"txt-sze\"; label = \"Height:\"; }"
        "        : pik    { key = \"txt-pik\"; }"
        "        : toggle { key = \"txt-bst\"; label = \"From style\"; }"
        "      }"
        "      : row {"
        "        : toggle { key = \"msk-use\"; label = \"Mask\"; }"
        "        : e12    { key = \"msk-off\"; label = \"Offset:\"; }"
        "        : pik    { key = \"msk-pik\"; }"
        "        : col    { key = \"msk-col\"; }"
        "        : toggle { key = \"msk-trn\"; label = \"Background\"; }"
        "      }"
        "      spacer;"
        "    }"
        "    : boxed_column { label = \"Border\";"
        "      : row {"
        "        : toggle { key = \"bor-enc\"; label = \"Enclose\"; }"
        "        : pop    { key = \"bor-shp\"; }"
        "        : e8     { key = \"bor-sid\"; label = \"Sides:\"; }"
        "      }"
        "      : row { : text { key = \"bor-ltx\"; label = \"Layer: \"; }"
        "              : pop  { key = \"bor-lay\"; } }"
        "      : radio_row {"
        "        : radio_button { key = \"bor-off\"; label = \"Offset\"; }"
        "        : radio_button { key = \"bor-fix\"; label = \"Fixed\"; }"
        "      }"
        "      : row {"
        "        : e8  { key = \"off-ed1\"; label = \"Factor:\"; }"
        "        : e8  { key = \"fix-ed1\"; label = \"Size:\"; }"
        "        : text { key = \"fix-txt\"; label = \"x\"; }"
        "        : e8  { key = \"fix-ed2\"; }"
        "        : pik { key = \"bor-pik\"; }"
        "      }"
        "      spacer;"
        "    }"
        "  }"
        "  : boxed_column { label = \"Array\";"
        "    : row {"
        "      : toggle { key = \"arr-use\"; label = \"Place as array\"; }"
        "      : e8     { key = \"arr-qty\"; label = \"Items:\"; }"
        "      : toggle { key = \"arr-aln\"; label = \"Aligned\"; }"
        "      : toggle { key = \"arr-per\"; label = \"Perpendicular\"; }"
        "      : toggle { key = \"arr-oth\"; label = \"Angle:\"; }"
        "      : e8     { key = \"arr-rot\"; }"
        "      : pik    { key = \"arr-pik\"; }"
        "    }"
        "    spacer;"
        "  }"
        "  spacer;"
        "  : row { alignment = centered; fixed_width = true;"
        "    : b12 { key = \"cfg-lod\"; label = \"Load...\"; }"
        "    : b12 { key = \"cfg-sav\"; label = \"Save...\"; }"
        "    : b12 { key = \"accept\"; label = \"OK\"; is_default = true; }"
        "    : b12 { key = \"cancel\"; label = \"Cancel\"; is_cancel = true; }"
        "  }"
        "}"
        ""
        "build : dialog { label = \"Content Builder\";"
        "  spacer;"
        "  : boxed_column { label = \"Component\";"
        "    : row {"
        "      : e12 { key = \"txt\"; label = \"Text:\"; }"
        "      : e8  { key = \"inc\"; label = \"Increment:\"; }"
        "      : e8  { key = \"frq\"; label = \"Every:\"; }"
        "      : e8  { key = \"rst\"; label = \"Reset to:\"; }"
        "      : e8  { key = \"rfq\"; label = \"Every:\"; }"
        "      : b12 { key = \"add\"; label = \"Add\"; }"
        "    }"
        "    spacer;"
        "  }"
        "  : row { : text { key = \"hd1\"; label = \"Text\"; }"
        "          : text { key = \"hd2\"; label = \"Increment\"; }"
        "          : text { key = \"hd3\"; label = \"Every\"; }"
        "          : text { key = \"hd4\"; label = \"Reset to\"; }"
        "          : text { key = \"hd5\"; label = \"Every\"; } }"
        "  : list_box { key = \"lst\"; width = 60; height = 10; fixed_width = true;"
        "               fixed_height = true; multiple_select = true;"
        "               tabs = \"14 26 36 48\"; }"
        "  : row { alignment = centered; fixed_width = true;"
        "    : b12 { key = \"top\";     label = \"Top\"; }"
        "    : b12 { key = \"up\";      label = \"Up\"; }"
        "    : b12 { key = \"down\";    label = \"Down\"; }"
        "    : b12 { key = \"bottom\";  label = \"Bottom\"; }"
        "    : b12 { key = \"sort\";    label = \"Sort\"; }"
        "    : b12 { key = \"reverse\"; label = \"Reverse\"; }"
        "    : b12 { key = \"rem\";     label = \"Remove\"; }"
        "    : b12 { key = \"clr\";     label = \"Clear\"; }"
        "  }"
        "  : e40 { key = \"prv\"; label = \"Preview:\"; is_enabled = false; }"
        "  : text { label = \"Double-click a component to edit it\"; alignment = centered; }"
        "  spacer; ok_cancel;"
        "}"
        ""
        "edit : dialog { label = \"Edit Component\";"
        "  spacer;"
        "  : e12 { key = \"txt\"; label = \"Text:\"; }"
        "  : e8  { key = \"inc\"; label = \"Increment:\"; }"
        "  : e8  { key = \"frq\"; label = \"Increment every:\"; }"
        "  : e8  { key = \"rst\"; label = \"Reset to:\"; }"
        "  : e8  { key = \"rfq\"; label = \"Reset every:\"; }"
        "  spacer; ok_cancel;"
        "}"
        ""
        "listbox : dialog { key = \"dcl\";"
        "  spacer;"
        "  : list_box { key = \"lst\"; width = 40; height = 12; fixed_width = true;"
        "               fixed_height = true; multiple_select = true; }"
        "  spacer; ok_cancel;"
        "}"
    )
)

(princ "\nNumStamp loaded. Type NUMSTAMP to place incrementally numbered annotation.")
(princ)

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