;;; ---------------------------------------------------------------------------
;;; CountArray.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Arrays objects while INCREMENTING any numbers in their text.
;;;
;;; Draw one parking bay labelled "BAY 01", array it fifteen times, and you get
;;; BAY 02 through BAY 16 - not fifteen copies of BAY 01. The same applies to
;;; grid references, pile numbers, column marks, drainage manholes, anything
;;; that runs in sequence.
;;;
;;; COMMANDS
;;;   COUNTARRAY      - standard. Fast, no preview.
;;;   COUNTARRAYLIVE  - dynamic. Shows the array updating as you drag, but is
;;;                     noticeably slower because it rebuilds every copy on
;;;                     every mouse movement. Fine for a handful of objects,
;;;                     painful for hundreds.
;;;
;;; HOW TO USE
;;;   1. Give the increment (1 is the default, and is remembered between
;;;      sessions; -1 counts down; 0.5 works too).
;;;   2. Select the objects to array - anything except viewports.
;;;   3. Pick a base point, then a second point defining the ARRAY VECTOR.
;;;      That vector sets both the direction AND the spacing: a shorter vector
;;;      produces a denser array.
;;;   4. Drag to set how far the array runs.
;;;
;;; WHAT GETS INCREMENTED
;;; Text, MText, attribute definitions, multileaders, dimension override text,
;;; and the attributes inside arrayed blocks.
;;;
;;; Every number found anywhere in the text is incremented, and the rest of the
;;; string is left alone - so "BAY 01 OF 20" increments both figures. Leading
;;; zeros are preserved, so "007" becomes "008" rather than "8", but only where
;;; the original actually had them.
;;;
;;; A NOTE ON THE ROUNDING
;;; DIMZIN is forced to 0 during the operation and restored afterwards. Without
;;; that, repeatedly adding a value accumulates floating-point drift, and an
;;; array counting up in ones starts producing 44.0000001 somewhere in the
;;; forties.
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Environment key for the remembered increment.
(setq CountArray:Key "YZ\\countarray")

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

;; ---------------------------------------------------------------------------
;; CountArray:NumToString
;; ---------------------------------------------------------------------------
;; Converts a number to a string without trailing zeros or precision loss.
;;
;; A whole number is returned with no decimal part at all. Anything else is
;; formatted to fifteen decimal places with DIMZIN 8, which suppresses trailing
;; zeros - so 0.5 comes back as "0.5" rather than "0.500000000000000".
;; ---------------------------------------------------------------------------
(defun CountArray:NumToString ( x / dim rtn )
    (if (equal x (atof (rtos x 2 0)) 1e-8)
        (rtos x 2 0)
        (progn
            (setq dim (getvar 'dimzin))
            (setvar 'dimzin 8)
            (setq rtn (vl-catch-all-apply 'rtos (list x 2 15)))
            (setvar 'dimzin dim)
            (if (not (vl-catch-all-error-p rtn)) rtn)
        )
    )
)

;; ---------------------------------------------------------------------------
;; CountArray:DecimalPlaces
;; ---------------------------------------------------------------------------
;; Returns how many digits follow the decimal point in a numeric string.
;; ---------------------------------------------------------------------------
(defun CountArray:DecimalPlaces ( str / pos )
    (if (setq pos (vl-string-position 46 str))
        (- (strlen str) pos 1)
        0
    )
)

;; ---------------------------------------------------------------------------
;; CountArray:Split
;; ---------------------------------------------------------------------------
;; Character-level worker for CountArray:SplitString below.
;;
;; It walks the character codes of a string and inserts quote-space-quote
;; sequences at every boundary between numeric and non-numeric text, building
;; up the text of a LISP list expression. flg tracks whether the previous
;; character was part of a number.
;;
;; Character codes used: 34 is a double quote, 40 an opening bracket, 41 a
;; closing bracket, 46 a full stop, 92 a backslash, and 48-57 the digits.
;;
;; Quotes and backslashes in the source text are escaped with a preceding
;; backslash - without that, text containing either would produce a malformed
;; expression and crash the read, which is exactly the bug version 1.8 of the
;; original was released to fix.
;;
;; A full stop only counts as part of a number when it sits between digits, so
;; a sentence's final full stop does not merge into the number before it.
;; ---------------------------------------------------------------------------
(defun CountArray:Split ( lst flg )
    (cond
        (   (null lst)
           '(34 41)                                     ; close the final string and the list
        )
        (   (member (car lst) '(34 92))                  ; a quote or backslash
            (if flg
                (vl-list* 34 32 34 92 (car lst) (CountArray:Split (cdr lst) nil))
                (vl-list* 92 (car lst) (CountArray:Split (cdr lst) flg))
            )
        )
        (   (or (< 47 (car lst) 58)                      ; a digit
                (and (= 46 (car lst)) flg (< 47 (cadr lst) 58))  ; a decimal point within a number
            )
            (if flg
                (vl-list* (car lst) (CountArray:Split (cdr lst) flg))
                (vl-list* 34 32 34 (car lst) (CountArray:Split (cdr lst) t))
            )
        )
        (   flg                                          ; first non-digit after a number
            (vl-list* 34 32 34 (car lst) (CountArray:Split (cdr lst) nil))
        )
        (   (vl-list* (car lst) (CountArray:Split (cdr lst) nil)))
    )
)

;; ---------------------------------------------------------------------------
;; CountArray:SplitString
;; ---------------------------------------------------------------------------
;; Splits a string into alternating numeric and non-numeric pieces.
;;
;;     "BAY 01 OF 20"  ->  ("BAY " "01" " OF " "20")
;;
;; The technique is to construct the TEXT of a LISP list of strings and then
;; read it - which is far faster than assembling the list character by
;; character, and is the reason this routine stays responsive in dynamic mode
;; where the whole array is rebuilt on every mouse movement.
;; ---------------------------------------------------------------------------
(defun CountArray:SplitString ( str / lst )
    (setq lst (vl-string->list str))
    (read (vl-list->string (vl-list* 40 34 (CountArray:Split lst (< 47 (car lst) 58)))))
)

;; ---------------------------------------------------------------------------
;; CountArray:Increment
;; ---------------------------------------------------------------------------
;; Adds inc to a numeric string, preserving its formatting. Non-numeric strings
;; are returned untouched, which is what lets this be applied blindly to every
;; piece of a split string.
;;
;; The result keeps the greater of the source's and the increment's decimal
;; places, so adding 0.5 to "1" gives "1.5" rather than "2".
;;
;; Leading zeros are restored only when the ORIGINAL had them - so "007" plus
;; one gives "008", while "7" plus one gives "8". The width to pad to accounts
;; for any decimal places gained along the way.
;; ---------------------------------------------------------------------------
(defun CountArray:Increment ( str inc / dci dcs len num rtn )
    (if (distof str 2)
        (progn
            (setq num (+ (distof str) inc)
                  inc (CountArray:NumToString inc)
                  ;; Signs are stripped for the digit counting and reapplied at
                  ;; the end, so a minus does not distort the widths.
                  str (vl-string-left-trim "-" str)
                  inc (vl-string-left-trim "-" inc)
                  dci (CountArray:DecimalPlaces inc)
                  dcs (CountArray:DecimalPlaces str)
                  rtn (rtos (abs num) 2 (max dci dcs))
            )
            (if (= 48 (ascii str))          ; original began with "0"
                (progn
                    (setq len (strlen str))
                    (cond
                        ((< 0 dcs) (setq len (+ (- len dcs) (max dci dcs))))
                        ((< 0 dci) (setq len (+ dci len 1)))
                    )
                    (repeat (- len (strlen rtn))
                        (setq rtn (strcat "0" rtn))
                    )
                )
            )
            (if (minusp num) (strcat "-" rtn) rtn)
        )
        str
    )
)

;; ---------------------------------------------------------------------------
;; CountArray:Collect
;; ---------------------------------------------------------------------------
;; Converts a selection set into the working structure:
;;
;;     ( (object (property piece piece ...) ...) ... )
;;
;; Each object is paired with the text properties that should be incremented,
;; each already split into its numeric and non-numeric pieces. Doing the split
;; ONCE here rather than per copy is what makes the array fast.
;;
;; Which property carries the text depends on the object:
;;   Text, MText, MLeader          textstring
;;   Dimensions                    textoverride
;;   Attribute definitions         tagstring, promptstring and textstring
;;   Attributed blocks             the textstring of each attribute
;; ---------------------------------------------------------------------------
(defun CountArray:Collect ( sel / idx lst obj obn )
    (if sel
        (repeat (setq idx (sslength sel))
            (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                  obn (vla-get-objectname obj)
            )
            (if (and (= "AcDbBlockReference" obn)
                     (= :vlax-true (vla-get-hasattributes obj))
                )
                (setq lst
                    (cons
                        (cons obj
                            (mapcar
                                (function
                                    (lambda ( a )
                                        (vl-list* 'textstring
                                                  (CountArray:SplitString (vla-get-textstring a))
                                        )
                                    )
                                )
                                (vlax-invoke obj 'getattributes)
                            )
                        )
                        lst
                    )
                )
                (setq lst
                    (cons
                        (cons obj
                            (mapcar
                                (function
                                    (lambda ( p )
                                        (vl-list* p (CountArray:SplitString (vlax-get-property obj p)))
                                    )
                                )
                                (cond
                                    ((wcmatch obn "AcDb*Text,AcDbMLeader") '(textstring))
                                    ((wcmatch obn "AcDb*Dimension")        '(textoverride))
                                    ((= "AcDbAttributeDefinition" obn)     '(tagstring promptstring textstring))
                                )
                            )
                        )
                        lst
                    )
                )
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; CountArray:Build
;; ---------------------------------------------------------------------------
;; Creates the array and returns the list of objects created - which the caller
;; needs so the dynamic preview can delete them before drawing the next frame.
;;
;; Each copy is moved by the vector times its ordinal, and its text pieces are
;; incremented by the increment times the same ordinal - so copy 5 is five
;; steps away and five increments on, rather than each copy being derived from
;; the last. That avoids compounding any error.
;;
;; The attribute write is caught, because an attribute on a locked layer will
;; refuse it and should cost only that attribute.
;;
;; lst - [list] the structure from CountArray:Collect
;; vec - [list] displacement per step, in WCS
;; qty - [int]  number of copies
;; inc - [real] increment per step
;; ---------------------------------------------------------------------------
(defun CountArray:Build ( lst vec qty inc / cnt obj created origin )
    (setq origin (vlax-3D-point 0 0)
          cnt    1
    )
    (repeat qty
        (foreach itm lst
            (setq obj     (vla-copy (car itm))
                  created (cons obj created)
            )
            (vla-move obj origin (vlax-3D-point (mapcar '* vec (list cnt cnt cnt))))

            (if (= "AcDbBlockReference" (vla-get-objectname obj))
                ;; Blocks: walk the copy's attributes alongside the recorded
                ;; piece lists, which are in the same order.
                (mapcar
                    (function
                        (lambda ( att prp )
                            (vl-catch-all-apply 'vlax-put-property
                                (list att (car prp)
                                    (apply 'strcat
                                        (mapcar (function (lambda ( x ) (CountArray:Increment x (* cnt inc))))
                                                (cdr prp)
                                        )
                                    )
                                )
                            )
                        )
                    )
                    (vlax-invoke obj 'getattributes)
                    (cdr itm)
                )
                ;; Everything else: write each recorded property directly.
                (foreach prp (cdr itm)
                    (vlax-put-property obj (car prp)
                        (apply 'strcat
                            (mapcar (function (lambda ( x ) (CountArray:Increment x (* cnt inc))))
                                    (cdr prp)
                            )
                        )
                    )
                )
            )
        )
        (setq cnt (1+ cnt))
    )
    created
)

;; ---------------------------------------------------------------------------
;; CountArray:Run
;; ---------------------------------------------------------------------------
;; Shared implementation for both commands.
;;
;; dyn - [boolean] T for the live dragging preview
;; ---------------------------------------------------------------------------
(defun CountArray:Run ( dyn / *error* vars vals inc tmp lst bpt ept vxu vxw dis qty created )

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

    (defun CountArray:Restore ( )
        ;; Any preview copies still on screen must go, or an interrupted drag
        ;; leaves a ghost array behind in the drawing.
        (foreach obj created
            (if (and (= 'vla-object (type obj))
                     (not (vlax-erased-p obj))
                     (vlax-write-enabled-p obj)
                )
                (vla-delete obj)
            )
        )
        (redraw)
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (command "_.UNDO" "_End")
            (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        )
        (princ)
    )

    (defun *error* ( msg )
        (CountArray:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** COUNTARRAY error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    ;; Recover the remembered increment, defaulting to 1.
    (if (not (and (setq inc (getenv CountArray:Key)) (setq inc (distof inc))))
        (setq inc 1)
    )
    (if (setq tmp (getreal (strcat "\nSpecify increment <" (CountArray:NumToString inc) ">: ")))
        (setenv CountArray:Key (CountArray:NumToString (setq inc tmp)))
    )

    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler
    ;; unless the routine says up front that it will use one. Restore does,
    ;; to close this undo group. The declaring call is absent on older
    ;; releases, so it is wrapped rather than tested for.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    ;; DIMZIN 0 prevents accumulated rounding drift - see the header.
    (setvar 'dimzin 0)

    (cond
        (   (not
                (and
                    (progn (princ "\nSelect objects to array: ")
                           (setq lst (CountArray:Collect (ssget "_:L" '((0 . "~VIEWPORT")))))
                    )
                    (setq bpt (getpoint "\nSpecify base point: "))
                    (progn
                        ;; The vector must have length, or the array would stack
                        ;; every copy on the original.
                        (while (and (setq vxu (getpoint bpt "\nSpecify array vector (sets direction and spacing): "))
                                    (equal bpt vxu 1e-8)
                               )
                            (princ "\nThe vector must have a length - try again.")
                        )
                        vxu
                    )
                    (setq vxu (mapcar '- vxu bpt)
                          ;; The trailing t makes this a DISPLACEMENT rather
                          ;; than a point, so it is rotated by the UCS but not
                          ;; translated by its origin.
                          vxw (trans vxu 1 0 t)
                          dis (distance '(0.0 0.0 0.0) vxw)
                    )
                )
            )
            (princ "\n*Cancelled*")
        )

        ;; -------------------------------------------------------------------
        ;; Dynamic mode. grread returns 5 on mouse movement; each frame the
        ;; previous copies are deleted and the array rebuilt at the new count.
        ;; A rubber-band line is drawn to show the array axis.
        ;; -------------------------------------------------------------------
        (   dyn
            (princ "\nSpecify array end point: ")
            (while (= 5 (car (setq ept (grread t 13 0))))
                (redraw)
                (foreach obj created (vla-delete obj))
                ;; Project the cursor displacement onto the array vector and
                ;; divide by its length - that ratio is the number of steps.
                (setq qty     (/ (caddr (trans (mapcar '- (cadr ept) bpt) 1 vxw t)) dis)
                      created (CountArray:Build lst
                                  (mapcar (if (minusp qty) '- '+) vxw)
                                  (abs (fix qty))
                                  inc
                              )
                )
                (grvecs (list -3 bpt (mapcar (function (lambda ( a b ) (+ (* a qty) b))) vxu bpt)))
            )
            (princ (strcat "\n" (itoa (abs (fix qty))) " copies arrayed."))
            ;; Cleared so Restore does not delete the finished array.
            (setq created nil)
        )

        ;; -------------------------------------------------------------------
        ;; Standard mode - one point, one build.
        ;; -------------------------------------------------------------------
        (   (setq ept (getpoint bpt "\nSpecify array end point: "))
            (setq qty (fix (/ (caddr (trans (mapcar '- ept bpt) 1 vxw t)) dis)))
            (CountArray:Build lst
                (mapcar (if (minusp qty) '- '+) vxw)
                (abs qty)
                inc
            )
            (princ (strcat "\n" (itoa (abs qty)) " copies arrayed."))
        )

        (   t
            (princ "\n*Cancelled*")
        )
    )

    (CountArray:Restore)
    (princ)
)

;; ---------------------------------------------------------------------------
;; Command wrappers
;; ---------------------------------------------------------------------------
(defun c:COUNTARRAY     nil (CountArray:Run nil))   ; fast, no preview
(defun c:COUNTARRAYLIVE nil (CountArray:Run   t))   ; live dragging preview

(princ)