;;; ---------------------------------------------------------------------------
;;; StringTally.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Counts how many times each distinct piece of text appears in a selection,
;;; and builds the result as a real AutoCAD TABLE object in the drawing.
;;;
;;; Select everything annotated and you get a schedule: each unique string, and
;;; how many of them there are. Useful for counting door types, drainage
;;; symbols, fitting references - anything identified by its label rather than
;;; by its block name.
;;;
;;; WHAT IT READS
;;;   TEXT and MTEXT     - their content
;;;   MULTILEADER        - its text content, DXF group 304
;;;   DIMENSION          - only where the text has been manually overridden,
;;;                        since a measured dimension is not a label
;;;   Attributed blocks  - every attribute value, summed across the block
;;;
;;; MText content longer than 250 characters is split by AutoCAD across several
;;; DXF entries, so groups 1 and 3 are concatenated to recover the whole string.
;;;
;;; The table uses the current table style and is sized from that style's own
;;; text height, so it matches the rest of the drawing's tables. Annotative
;;; text styles are handled by dividing through by the current annotation
;;; scale.
;;;
;;;   STRINGTALLY  - count text occurrences into a table
;;; ---------------------------------------------------------------------------

(vl-load-com)

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

;; ---------------------------------------------------------------------------
;; StringTally:Increment
;; ---------------------------------------------------------------------------
;; Increments the count for a key in an association list, adding it at 1 if not
;; already present.
;; ---------------------------------------------------------------------------
(defun StringTally:Increment ( key alist / pair )
    (if (setq pair (assoc key alist))
        (subst (list key (1+ (cadr pair))) pair alist)
        (cons  (list key 1) alist)
    )
)

;; ---------------------------------------------------------------------------
;; StringTally:TextOf
;; ---------------------------------------------------------------------------
;; Returns the full text content of an entity.
;;
;; Groups 1 and 3 are both collected and concatenated in order. Group 1 holds
;; the text, but MText longer than 250 characters is stored as a series of
;; group 3 entries with the remainder in group 1 - so reading only group 1
;; would truncate long strings and count them as identical when they are not.
;; ---------------------------------------------------------------------------
(defun StringTally:TextOf ( ent / result )
    (setq result "")
    (foreach pair (entget ent)
        (if (member (car pair) '(1 3))
            (setq result (strcat result (cdr pair)))
        )
    )
    result
)

;; ---------------------------------------------------------------------------
;; StringTally:Attributes
;; ---------------------------------------------------------------------------
;; Adds every attribute value of a block reference to the tally.
;;
;; Attributes follow their block reference in the database as sub-entities,
;; terminated by a SEQEND marker - so walking forward with entnext until SEQEND
;; is reached visits exactly the attributes of that block.
;; ---------------------------------------------------------------------------
(defun StringTally:Attributes ( ent alist )
    (while (/= "SEQEND" (cdr (assoc 0 (entget (setq ent (entnext ent))))))
        (setq alist (StringTally:Increment (StringTally:TextOf ent) alist))
    )
    alist
)

;; ---------------------------------------------------------------------------
;; StringTally:IsAnnotative
;; ---------------------------------------------------------------------------
;; True if the named text style is annotative.
;;
;; The flag is not a plain property - it lives in the style's extended data
;; under the "AcadAnnotative" application name, as group 1070 with value 1.
;; ---------------------------------------------------------------------------
(defun StringTally:IsAnnotative ( style / object xdata )
    (and (setq object (tblobjname "STYLE" style))
         (setq xdata  (cadr (assoc -3 (entget object '("AcadAnnotative")))))
         (= 1 (cdr (assoc 1070 (reverse xdata))))
    )
)

;; ---------------------------------------------------------------------------
;; StringTally:AddTable
;; ---------------------------------------------------------------------------
;; Creates a table object at pt, populated with the title and data supplied.
;;
;; Sizing:
;;   Row height is twice the style's text height, which is the usual
;;   proportion for a legible table.
;;
;;   Column width is 0.8 of the text height multiplied by the longest string
;;   the table must hold, so the widest entry fits without wrapping. The title
;;   is divided by the column count first, since it spans them all.
;;
;;   For an annotative style, the height is divided by the current annotation
;;   scale, because an annotative style reports its PLOTTED height rather than
;;   its model-space height - without this the table comes out at the wrong
;;   size in any drawing not at 1:1.
;;
;; space - [vla-object] model or paper space
;; pt    - [list] insertion point, WCS
;; title - [str] table title
;; data  - [list] list of rows, each a list of cell strings
;; ---------------------------------------------------------------------------
(defun StringTally:AddTable ( space pt title data / style height rowheight colwidth table row col )

    (setq style
        (vla-item
            (vla-item (vla-get-dictionaries (vla-get-document space)) "ACAD_TABLESTYLE")
            (getvar 'CTABLESTYLE)
        )
    )
    (setq height (vla-gettextheight style acdatarow))

    ;; Undo annotative scaling, if the data row style is annotative.
    (setq rowheight
        (* 2.0
           (/ height
              (if (StringTally:IsAnnotative (vla-gettextstyle style acdatarow))
                  (cond ((getvar 'CANNOSCALEVALUE)) (1.0))
                  1.0
              )
           )
        )
    )

    (setq colwidth
        (* 0.8 rowheight
           (apply 'max
               (cons (/ (strlen title) (length (car data)))
                     (mapcar 'strlen (apply 'append data))
               )
           )
        )
    )

    (setq table (vla-AddTable space (vlax-3D-point pt)
                              (1+ (length data)) (length (car data))
                              rowheight colwidth
                )
    )
    (vla-put-StyleName table (getvar 'CTABLESTYLE))
    (vla-SetText table 0 0 title)

    ;; Row 0 is the title, so data starts at row 1.
    (setq row 0)
    (foreach rowdata data
        (setq row (1+ row)
              col -1
        )
        (foreach cell rowdata
            (vla-SetText table row (setq col (1+ col)) cell)
        )
    )
    table
)

;; ---------------------------------------------------------------------------
;; c:STRINGTALLY  -  main routine
;; ---------------------------------------------------------------------------
(defun c:STRINGTALLY ( / *error* vars vals space sel idx ent typ alist pt )

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

    (defun StringTally:Restore ( )
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (command "_.UNDO" "_End")
            (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        )
        (princ)
    )

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

    (setvar "CMDECHO" 0)
    (setq space (vlax-get-property (StringTally:Doc)
                    (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)
                )
    )

    (cond
        ;; The table has to be created on the current layer, so a locked one
        ;; would fail - checked up front rather than after the counting work.
        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'CLAYER))))))
            (princ "\nThe current layer is locked - unlock it before running this.")
        )

        (   (not (vlax-method-applicable-p space 'AddTable))
            (princ "\nTable objects are not available in this AutoCAD version.")
        )

        (   (and
                ;; The filter reads as: text, mtext or multileader, OR an
                ;; attributed block, OR a dimension whose group 1 is non-empty
                ;; - i.e. one with overridden text.
                (setq sel
                    (ssget
                       '(
                            (-4 . "<OR")
                                (0 . "TEXT,MTEXT,MULTILEADER")
                                (-4 . "<AND") (0 . "INSERT") (66 . 1) (-4 . "AND>")
                                (-4 . "<AND") (0 . "*DIMENSION") (1 . "*?*") (-4 . "AND>")
                            (-4 . "OR>")
                        )
                    )
                )
                (progn
                    (repeat (setq idx (sslength sel))
                        (setq ent (ssname sel (setq idx (1- idx)))
                              typ (cdr (assoc 0 (entget ent)))
                        )
                        (setq alist
                            (cond
                                ((= "INSERT" typ)
                                 (StringTally:Attributes ent alist)
                                )
                                ((= "MULTILEADER" typ)
                                 (StringTally:Increment (cdr (assoc 304 (entget ent))) alist)
                                )
                                ((wcmatch typ "*DIMENSION")
                                 (StringTally:Increment (cdr (assoc 1 (entget ent))) alist)
                                )
                                ((StringTally:Increment (StringTally:TextOf ent) alist))
                            )
                        )
                    )
                    alist
                )
                (setq pt (getpoint "\nSpecify point for the table: "))
            )
            ;; 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")
            (StringTally:AddTable space (trans pt 1 0) "String Count"
                (cons (list "String" "Instances")
                      (vl-sort
                          (mapcar (function (lambda ( x ) (list (car x) (itoa (cadr x))))) alist)
                          (function (lambda ( a b ) (< (car a) (car b))))
                      )
                )
            )
            (princ (strcat "\n" (itoa (length alist))
                           " distinct string" (if (= 1 (length alist)) "" "s")
                           " tallied from " (itoa (sslength sel)) " objects."
                   )
            )
        )

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

    (StringTally:Restore)
    (princ)
)

(princ)