;;; ---------------------------------------------------------------------------
;;; StateTally.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Counts blocks - and, crucially, breaks DYNAMIC blocks down by VISIBILITY
;;; STATE rather than lumping them together under one name.
;;;
;;; This is what makes it different from an ordinary block count. A single
;;; dynamic block definition called DOOR might appear in the drawing as single
;;; doors, double doors and fire doors, all sharing one block name. A plain
;;; count reports "DOOR ... 47" and tells you nothing useful. This reports:
;;;
;;;     DOOR ................................. 47
;;;        Single .............................. 31
;;;        Double .............................. 12
;;;        Fire ................................. 4
;;;
;;; which is a schedule you can actually order from.
;;;
;;; Standard blocks and xrefs are counted normally. Only dynamic blocks that
;;; genuinely have a Visibility Parameter get the breakdown.
;;;
;;; Results print to the text window and can be written to a TXT or CSV file,
;;; created alongside the drawing and named after it. The file is opened
;;; automatically once written.
;;;
;;; Only the CURRENT layout is counted - model space when in model space, the
;;; active sheet when in paper space.
;;;
;;;   STATETALLY  - count blocks by name and visibility state
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Width of the printed report, in characters.
(setq StateTally:Width 46)

;; ---------------------------------------------------------------------------
;; StateTally:PadBetween
;; ---------------------------------------------------------------------------
;; Returns two strings joined by enough repetitions of a padding character to
;; reach a total width - producing the dot-leader effect that makes a column of
;; counts readable.
;; ---------------------------------------------------------------------------
(defun StateTally:PadBetween ( s1 s2 ch ln )
    (   (lambda ( pad left right )
            (repeat (- ln (length left) (length right))
                (setq right (cons pad right))
            )
            (vl-list->string (append left right))
        )
        (ascii ch)
        (vl-string->list s1)
        (vl-string->list s2)
    )
)

;; ---------------------------------------------------------------------------
;; StateTally:Increment
;; ---------------------------------------------------------------------------
;; Increments a count in a nested association list, creating missing levels.
;;
;; key arrives as either ("BLOCKNAME") for a plain block or ("BLOCKNAME"
;; "StateName") for a dynamic one, so the same function builds both the flat
;; and the two-level structures.
;; ---------------------------------------------------------------------------
(defun StateTally:Increment ( key lst / itm )
    (if key
        (if (setq itm (assoc (car key) lst))
            (subst (cons (car key) (StateTally:Increment (cdr key) (cdr itm))) itm lst)
            (cons  (cons (car key) (StateTally:Increment (cdr key) nil)) lst)
        )
        (if lst (list (1+ (car lst))) '(1))
    )
)

;; ---------------------------------------------------------------------------
;; StateTally:BlockName
;; ---------------------------------------------------------------------------
;; Returns a block reference's EFFECTIVE name.
;;
;; This matters for dynamic blocks: once a dynamic block has been modified from
;; its default state, AutoCAD stores it under an anonymous name like "*U27".
;; The effective name is the real one the user knows it by. Without this, a
;; drawing full of customised dynamic blocks would report dozens of meaningless
;; *U names.
;;
;; The property test runs once, then this function replaces itself.
;; ---------------------------------------------------------------------------
(defun StateTally:BlockName ( obj )
    (if (vlax-property-available-p obj 'effectivename)
        (defun StateTally:BlockName ( obj ) (vla-get-effectivename obj))
        (defun StateTally:BlockName ( obj ) (vla-get-name obj))
    )
    (StateTally:BlockName obj)
)

;; ---------------------------------------------------------------------------
;; StateTally:VisParameterName
;; ---------------------------------------------------------------------------
;; Returns the name of a dynamic block's Visibility Parameter, or nil if it has
;; none.
;;
;; There is no direct property for this, so it has to be dug out of the block
;; DEFINITION rather than the reference: from the block definition's extension
;; dictionary, into its ACAD_ENHANCEDBLOCK entry, and then through that for a
;; BLOCKVISIBILITYPARAMETER object. Its DXF group 301 holds the name.
;;
;; The name is needed because a dynamic block can carry many properties, and
;; the visibility one has no fixed name - it is whatever the block's author
;; called it.
;; ---------------------------------------------------------------------------
(defun StateTally:VisParameterName ( blk / vis )
    (if (and (vlax-property-available-p blk 'effectivename)
             (setq blk (vla-item (vla-get-blocks (vla-get-document blk))
                                 (vla-get-effectivename blk)
                       )
             )
             (= :vlax-true (vla-get-hasextensiondictionary blk))
             (setq vis
                 (vl-some
                     (function
                         (lambda ( pair )
                             (if (and (= 360 (car pair))
                                      (= "BLOCKVISIBILITYPARAMETER"
                                         (cdr (assoc 0 (entget (cdr pair))))
                                      )
                                 )
                                 (cdr pair)
                             )
                         )
                     )
                     (dictsearch
                         (vlax-vla-object->ename (vla-getextensiondictionary blk))
                         "ACAD_ENHANCEDBLOCK"
                     )
                 )
             )
        )
        (cdr (assoc 301 (entget vis)))
    )
)

;; ---------------------------------------------------------------------------
;; StateTally:UniqueFilename
;; ---------------------------------------------------------------------------
;; Returns a filename that does not yet exist, adding (1), (2) ... as needed so
;; an existing report is never silently overwritten.
;; ---------------------------------------------------------------------------
(defun StateTally:UniqueFilename ( path ext / name idx )
    (if (findfile (setq name (strcat path ext)))
        (progn
            (setq idx 1)
            (while (findfile (setq name (strcat path "(" (itoa (setq idx (1+ idx))) ")" ext))))
        )
    )
    name
)

;; ---------------------------------------------------------------------------
;; c:STATETALLY  -  main routine
;; ---------------------------------------------------------------------------
(defun c:STATETALLY ( / *error* vars vals all sel idx obj name vis states lst
                        out file des delim total )

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

    (defun StateTally:Restore ( )
        ;; A report file left open would stay locked for the session.
        (if (= 'file (type des))
            (close des)
        )
        ;; NOMUTT is restored to its CAPTURED value. The original reset it to a
        ;; hard-coded 0, which would silently clobber a non-default setting.
        (mapcar 'setvar vars vals)
        (princ)
    )

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

    (setvar "CMDECHO" 0)

    (cond
        ;; Gather every block in the current space first - this is the default
        ;; if the user simply presses Enter at the selection prompt.
        (   (null
                (setq all
                    (ssget "_X"
                        (list '(0 . "INSERT")
                              (if (= 1 (getvar 'cvport))
                                  (cons 410 (getvar 'ctab))
                                 '(410 . "Model")
                              )
                        )
                    )
                )
            )
            (princ "\nNo blocks found in the current layout.")
        )

        (   (progn
                ;; NOMUTT suppresses the built-in selection chatter so the
                ;; custom "<all>" prompt is the only thing shown.
                (setvar 'nomutt 1)
                (princ "\nSelect blocks to count <all>: ")
                (setq sel
                    (cond
                        ((null (setq sel (vl-catch-all-apply 'ssget '(((0 . "INSERT")))))) all)
                        ((null (vl-catch-all-error-p sel)) sel)
                    )
                )
                (setvar 'nomutt (cadr vals))
                sel
            )

            ;; ---------------------------------------------------------------
            ;; Tally. For each block, the key is its name alone, or its name
            ;; plus visibility state when it has one.
            ;;
            ;; The visibility parameter NAME is cached per block name in states,
            ;; because looking it up means walking the block definition's
            ;; dictionaries - far too slow to repeat for every one of several
            ;; thousand references.
            ;; ---------------------------------------------------------------
            (repeat (setq idx (sslength sel))
                (setq obj  (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                      name (StateTally:BlockName obj)
                )
                (setq lst
                    (StateTally:Increment
                        (cons name
                            (if (and
                                    (setq vis
                                        (cdr
                                            (cond
                                                ((assoc name states))
                                                ((car (setq states
                                                          (cons (cons name (StateTally:VisParameterName obj))
                                                                states
                                                          )
                                                      )
                                                 )
                                                )
                                            )
                                        )
                                    )
                                    ;; Read the current value of that parameter
                                    ;; on this particular reference.
                                    (setq vis
                                        (vl-some
                                            (function
                                                (lambda ( x )
                                                    (if (= vis (vla-get-propertyname x))
                                                        (vlax-get x 'value)
                                                    )
                                                )
                                            )
                                            (vlax-invoke obj 'getdynamicblockproperties)
                                        )
                                    )
                                )
                                (list vis)
                            )
                        )
                        lst
                    )
                )
            )

            ;; ---------------------------------------------------------------
            ;; Print the report. A cadr that is a LIST means this entry has
            ;; visibility sub-counts; a plain number means it does not.
            ;; ---------------------------------------------------------------
            (princ (StateTally:PadBetween "\n" "" "=" StateTally:Width))
            (princ (StateTally:PadBetween "\n Block" "Count" "." StateTally:Width))
            (princ (StateTally:PadBetween "\n" "" "=" StateTally:Width))

            (setq total 0)
            (foreach blk (setq lst (vl-sort lst (function (lambda ( a b ) (< (car a) (car b))))))
                (cond
                    (   (listp (cadr blk))
                        (setq total (+ total (apply '+ (mapcar 'cadr (cdr blk)))))
                        (princ (StateTally:PadBetween (strcat "\n " (car blk))
                                                      (itoa (apply '+ (mapcar 'cadr (cdr blk))))
                                                      "." StateTally:Width))
                        (foreach vis (cdr blk)
                            (princ (StateTally:PadBetween (strcat "\n    " (car vis))
                                                          (itoa (cadr vis))
                                                          "." StateTally:Width))
                        )
                    )
                    (   (setq total (+ total (cadr blk)))
                        (princ (StateTally:PadBetween (strcat "\n " (car blk))
                                                      (itoa (cadr blk))
                                                      "." StateTally:Width))
                    )
                )
                (princ (StateTally:PadBetween "\n" "" "-" StateTally:Width))
            )
            (princ (StateTally:PadBetween "\n TOTAL" (itoa total) "." StateTally:Width))
            (princ (StateTally:PadBetween "\r" "" "=" StateTally:Width))
            (textpage)

            ;; ---------------------------------------------------------------
            ;; Optional file output.
            ;; ---------------------------------------------------------------
            (initget "TXT CSV")
            (if (and (setq out (getkword "\nOutput results to [TXT/CSV] <exit>: "))
                     (setq file (StateTally:UniqueFilename
                                    (strcat (getvar 'dwgprefix)
                                            (vl-filename-base (getvar 'dwgname))
                                    )
                                    (strcat "." (strcase out t))
                                )
                     )
                )
                (if (setq des (open file "w"))
                    (progn
                        ;; Tab for TXT so it lines up in a text editor, comma
                        ;; for CSV so a spreadsheet parses it.
                        (setq delim (if (= "TXT" out) "\t" ","))
                        (write-line (strcat "Block" delim delim "Count") des)
                        (foreach blk lst
                            (cond
                                (   (listp (cadr blk))
                                    (write-line (strcat (car blk) delim delim
                                                        (itoa (apply '+ (mapcar 'cadr (cdr blk)))))
                                                des)
                                    (foreach vis (cdr blk)
                                        (write-line (strcat delim (car vis) delim (itoa (cadr vis))) des)
                                    )
                                )
                                (   (write-line (strcat (car blk) delim delim (itoa (cadr blk))) des))
                            )
                        )
                        (close des)
                        (setq des nil)
                        (startapp "explorer" file)
                        (princ (strcat "\nReport written to " file))
                    )
                    (princ (strcat "\nUnable to open \"" file "\" for writing."))
                )
            )
            (graphscr)
        )
    )

    (StateTally:Restore)
    (princ)
)

(princ)