;;; ---------------------------------------------------------------------------
;;; ValueTally.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Counts how many times each distinct attribute VALUE appears, and builds the
;;; result as an AutoCAD table.
;;;
;;; Where TAGTOTAL adds numbers up, this counts occurrences - so it answers
;;; "how many of each type?" rather than "what do they come to?". Point it at a
;;; drawing full of door blocks with a TYPE attribute and you get a door
;;; schedule: FD30 x 14, FD60 x 3, and so on.
;;;
;;; Select the blocks, choose which tags to count from a filtered list, pick a
;;; point, and the table appears sorted alphabetically by value.
;;;
;;; PRESETTING THE TAGS
;;; ValueTally:Tags below can be filled in to skip the selection dialog
;;; entirely - useful for a command you run repeatedly on the same kind of
;;; block. Entries are case-insensitive and may use wildcards, so "DOOR*"
;;; matches DOOR_TYPE and DOOR_REF alike. Leave it empty to always be asked.
;;;
;;; ValueTally:Title and ValueTally:Headings control the table's appearance;
;;; set the headings to a single-element list to omit the heading row.
;;;
;;; Only the current space is counted - model space when in model space, the
;;; active sheet when in paper space.
;;;
;;;   VALUETALLY  - count attribute values into a table
;;; ---------------------------------------------------------------------------

(vl-load-com)

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

(setq ValueTally:Title    "")                  ; table title, "" for none
(setq ValueTally:Headings '("Value" "Count"))  ; column headings
(setq ValueTally:Tags     '())                 ; preset tags, may use wildcards

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

;; ---------------------------------------------------------------------------
;; ValueTally:Increment
;; ---------------------------------------------------------------------------
;; Increments a key's count in an association list, adding it at 1 if absent.
;; ---------------------------------------------------------------------------
(defun ValueTally:Increment ( key lst / itm )
    (if (setq itm (assoc key lst))
        (subst (cons key (1+ (cdr itm))) itm lst)
        (cons  (cons key 1) lst)
    )
)

;; ---------------------------------------------------------------------------
;; ValueTally:Annotative
;; ---------------------------------------------------------------------------
;; True if the named text style is annotative. The flag lives in the style's
;; extended data under "AcadAnnotative", as group 1070 with value 1.
;; ---------------------------------------------------------------------------
(defun ValueTally:Annotative ( sty )
    (and (setq sty (tblobjname "style" sty))
         (setq sty (cadr (assoc -3 (entget sty '("acadannotative")))))
         (= 1 (cdr (assoc 1070 (reverse sty))))
    )
)

;; ---------------------------------------------------------------------------
;; ValueTally:CellWidth
;; ---------------------------------------------------------------------------
;; Returns the width a string needs in a table cell, including padding.
;;
;; A string containing a FIELD cannot be measured directly - the expression is
;; far longer than the value it displays, and measuring it would produce an
;; absurdly wide column. A temporary TEXT object is created holding it, which
;; forces evaluation, and the RESULT is measured instead.
;; ---------------------------------------------------------------------------
(defun ValueTally:CellWidth ( str hgt sty / box obj tmp )
    (if (and (wcmatch str "*%<*>%*")
             (setq tmp (entmakex
                           (list '(00 . "TEXT")
                                 '(10 0.0 0.0 0.0)
                                  (cons 01 str)
                                  (cons 40 hgt)
                                  (cons 07 sty)
                           )
                       )
             )
        )
        (progn
            (setq obj (vlax-ename->vla-object tmp))
            (vla-put-textstring obj "")
            (vla-put-textstring obj str)
            (setq str (vla-get-textstring obj))
            (entdel tmp)
        )
    )
    (if (setq box (textbox (list (cons 01 str) (cons 40 hgt) (cons 07 sty))))
        (+ (* 2.5 hgt) (- (caadr box) (caar box)))
        0.0
    )
)

;; ---------------------------------------------------------------------------
;; ValueTally:AddTable
;; ---------------------------------------------------------------------------
;; Builds a table at the given point from a matrix of cell strings.
;;
;; Column widths come from the widest entry in each column, so the table fits
;; its content. Regeneration is suppressed while cells are filled - a table
;; regenerating after every cell is dramatically slower on a long schedule.
;;
;; spc - [vla-object] model or paper space
;; ins - [list] WCS insertion point
;; ttl - [str] title, or nil
;; lst - [list] rows of cell strings
;; eqc - [boolean] T to force equal column widths
;; ---------------------------------------------------------------------------
(defun ValueTally:AddTable ( spc ins ttl lst eqc / dif hgt i j obj stn sty wid )

    (setq sty
        (vlax-ename->vla-object
            (cdr (assoc -1
                (dictsearch
                    (cdr (assoc -1 (dictsearch (namedobjdict) "acad_tablestyle")))
                    (getvar 'ctablestyle)
                )
            ))
        )
    )
    (setq hgt (vla-gettextheight sty acdatarow)
          stn (vla-gettextstyle  sty acdatarow)
    )

    ;; An annotative style reports its PLOTTED height, so divide through by the
    ;; annotation scale to get the model-space height.
    (if (ValueTally:Annotative stn)
        (setq hgt (/ hgt (cond ((getvar 'cannoscalevalue)) (1.0))))
    )

    ;; Transposing the matrix groups cells by column rather than by row.
    (setq wid
        (mapcar
            (function
                (lambda ( col )
                    (apply 'max
                        (mapcar (function (lambda ( str ) (ValueTally:CellWidth str hgt stn))) col)
                    )
                )
            )
            (apply 'mapcar (cons 'list lst))
        )
    )

    (if (and ttl
             (< 0.0 (setq dif (/ (- (ValueTally:CellWidth ttl hgt stn) (apply '+ wid))
                                 (length wid)
                              )
                    )
             )
        )
        (setq wid (mapcar (function (lambda ( x ) (+ x dif))) wid))
    )

    (setq obj
        (vla-addtable spc
            (vlax-3D-point ins)
            (1+ (length lst))
            (length (car lst))
            (* 2.0 hgt)
            (if eqc
                (apply 'max wid)
                (/ (apply '+ wid) (float (length (car lst))))
            )
        )
    )

    (vla-put-regeneratetablesuppressed obj :vlax-true)
    (vla-put-stylename obj (getvar 'ctablestyle))

    (setq i -1)
    (if (null eqc)
        (foreach col wid
            (vla-setcolumnwidth obj (setq i (1+ i)) col)
        )
    )

    ;; A table is created with a title row; with no title that row is deleted
    ;; and the data starts one row higher.
    (if ttl
        (progn (vla-settext obj 0 0 ttl) (setq i 1))
        (progn (vla-deleterows obj 0 1)  (setq i 0))
    )

    (foreach row lst
        (setq j 0)
        (foreach val row
            (vla-settext obj i j val)
            (setq j (1+ j))
        )
        (setq i (1+ i))
    )

    (vla-put-regeneratetablesuppressed obj :vlax-false)
    obj
)

;; ---------------------------------------------------------------------------
;; ValueTally:FilterListBox
;; ---------------------------------------------------------------------------
;; Multi-select list with a filter box. Returns the chosen strings, or nil.
;;
;; The filter action is stored as a quoted expression converted to a string,
;; which is how a multi-statement action is attached to a tile. On each change
;; it rebuilds the list from matching entries and works out where the previous
;; selections have moved to, so the selection survives filtering.
;;
;; The dialog name "valuetally" must match between the DCL and new_dialog.
;;
;; Note the original left its filter variable undeclared, leaking it globally;
;; it is localised here.
;; ---------------------------------------------------------------------------
(defun ValueTally:FilterListBox ( msg lst mtp / ValueTally:AddList dch dcl des rtn sel tmp flt )

    (defun ValueTally:AddList ( key lst )
        (start_list key)
        (foreach x lst (add_list x))
        (end_list)
        lst
    )

    (if (and
            (setq dcl (vl-filename-mktemp nil nil ".dcl"))
            (setq des (open dcl "w"))
            (write-line
                (strcat
                    "valuetally : dialog { label = \"" msg "\"; spacer;"
                    ": list_box { key = \"lst\"; width = 50; fixed_width = true; height = 15; "
                    "fixed_height = true; allow_accept = true; "
                    "multiple_select = " (if mtp "true" "false") "; }"
                    ": edit_box { key = \"flt\"; width = 50; fixed_width = true; label = \"Filter:\"; }"
                    "spacer; ok_cancel; }"
                )
                des
            )
            (not (close des))
            (< 0 (setq dch (load_dialog dcl)))
            (new_dialog "valuetally" dch)
        )
        (progn
            (ValueTally:AddList "lst" (setq tmp lst))
            (set_tile "lst" (setq rtn "0"))
            (set_tile "flt" "*")
            (action_tile "lst" "(setq rtn $value)")
            (action_tile "flt"
                (vl-prin1-to-string
                   '(progn
                        (setq flt (strcat "*" (strcase $value) "*")
                              sel (mapcar (function (lambda ( n ) (nth n tmp)))
                                          (read (strcat "(" rtn ")"))
                              )
                        )
                        (ValueTally:AddList "lst"
                            (setq tmp (vl-remove-if-not
                                          (function (lambda ( x ) (wcmatch (strcase x) flt)))
                                          lst
                                      )
                            )
                        )
                        (set_tile "lst"
                            (setq rtn
                                (vl-string-trim "()"
                                    (vl-princ-to-string
                                        (cond
                                            ((vl-sort (vl-remove nil
                                                          (mapcar (function (lambda ( x ) (vl-position x tmp))) sel))
                                                     '<))
                                            ('(0))
                                        )
                                    )
                                )
                            )
                        )
                    )
                )
            )
            (setq rtn
                (if (= 1 (start_dialog))
                    (mapcar (function (lambda ( x ) (nth x tmp))) (read (strcat "(" rtn ")")))
                )
            )
        )
    )

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

;; ---------------------------------------------------------------------------
;; c:VALUETALLY  -  main routine
;; ---------------------------------------------------------------------------
;; Note the original defined its error handler inside the working function
;; without declaring it local, leaving it installed globally afterwards. It is
;; properly localised here.
;; ---------------------------------------------------------------------------
(defun c:VALUETALLY ( / *error* vars vals tgs psp spc sel idx att atx
                        collect lst tags counts ins )

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

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

    (setvar "CMDECHO" 0)

    (setq tgs (mapcar 'strcase ValueTally:Tags)
          psp (= 1 (getvar 'cvport))
          spc (vlax-get-property (ValueTally:Doc) (if psp 'paperspace 'modelspace))
    )

    (cond
        (   (not (vlax-method-applicable-p spc 'addtable))
            (princ "\nTable objects are not supported on this CAD platform.")
        )

        ;; (66 . 1) restricts to blocks that actually carry attributes.
        (   (not (setq sel
                     (ssget (list '(000 . "INSERT")
                                  '(066 . 1)
                                   (if psp (cons 410 (getvar 'ctab)) '(410 . "Model"))
                            )
                     )
                 )
            )
            (princ "\nNothing selected.")
        )

        (   (progn
                ;; -------------------------------------------------------
                ;; Two different collectors, chosen once rather than tested
                ;; per attribute: with preset tags only matching ones are
                ;; kept, otherwise everything is kept AND the distinct tag
                ;; names are gathered for the selection dialog.
                ;; -------------------------------------------------------
                (setq collect
                    (if tgs
                        (function
                            (lambda ( tag val )
                                (if (vl-some (function (lambda ( x ) (wcmatch tag x))) tgs)
                                    (setq lst (cons (cons tag val) lst))
                                )
                            )
                        )
                        (function
                            (lambda ( tag val )
                                (if (not (member tag tags))
                                    (setq tags (cons tag tags))
                                )
                                (setq lst (cons (cons tag val) lst))
                            )
                        )
                    )
                )

                ;; Attributes follow their block reference as sub-entities, so
                ;; walking forward with entnext visits each in turn.
                (repeat (setq idx (sslength sel))
                    (setq idx (1- idx)
                          att (entnext (ssname sel idx))
                          atx (entget att)
                    )
                    (while (= "ATTRIB" (cdr (assoc 0 atx)))
                        (apply collect (list (strcase (cdr (assoc 2 atx))) (cdr (assoc 1 atx))))
                        (setq att (entnext att)
                              atx (entget  att)
                        )
                    )
                )
                (null lst)
            )
            (princ "\nNo attributes matching the criteria were found.")
        )

        ;; Ask which tags to count - but only when tags were not preset AND
        ;; more than one tag was found. A single tag needs no dialog.
        (   (not (or tgs
                     (null (cdr tags))
                     (and (setq tgs (ValueTally:FilterListBox "Select Attributes to Count"
                                        (acad_strlsort tags) t))
                          (setq lst (vl-remove-if-not
                                        (function (lambda ( x ) (member (car x) tgs)))
                                        lst
                                    )
                          )
                     )
                 )
            )
            (princ "\n*Cancelled*")
        )

        (   (progn
                ;; Count occurrences of each VALUE, discarding which tag it
                ;; came from - so the same value under two chosen tags is
                ;; counted together, which is what a schedule wants.
                (foreach itm lst
                    (setq counts (ValueTally:Increment (cdr itm) counts))
                )
                (setq counts
                    (vl-sort (mapcar (function (lambda ( x ) (list (car x) (itoa (cdr x))))) counts)
                             (function (lambda ( a b ) (< (strcase (car a)) (strcase (car b)))))
                    )
                )
                ;; The heading row is only added when two headings are given.
                (if (cdr ValueTally:Headings)
                    (setq counts (cons (list (car ValueTally:Headings) (cadr ValueTally:Headings))
                                       counts
                                 )
                    )
                )
                (setq ins (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")
            (ValueTally:AddTable spc (trans ins 1 0)
                (if (and ValueTally:Title (/= "" ValueTally:Title)) ValueTally:Title)
                counts
                nil
            )
            (princ (strcat "\nTable created with "
                           (itoa (if (cdr ValueTally:Headings) (1- (length counts)) (length counts)))
                           " distinct values."
                   )
            )
        )

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

    (ValueTally:Restore)
    (princ)
)

(princ)