;;COUNT.LSP   Copyright 1991   Tony Tanzillo   All Rights Reserved.
;;-----------------------------------------------------------------
;;    Author: Tony Tanzillo,
;;            Design Automation Consulting
;;
;;    Permission to use, copy, modify, and distribute this software
;;    for any purpose and without fee is hereby granted, provided
;;    that the above copyright notice appears in all copies and
;;    that both that copyright notice and the limited warranty and
;;    restricted rights notice below appear in all copies and all
;;    supporting documentation, and that there is no charge or fee
;;    charged in return for distribution or duplication.
;;
;;    This SOFTWARE and documentation are provided with RESTRICTED
;;    RIGHTS.
;;
;;    Use, duplication, or disclosure by the Government is subject
;;    to restrictions as set forth in subparagraph (c)(1)(ii) of
;;    the Rights in Technical Data and Computer Software clause at
;;    DFARS 252.227-7013 or subparagraphs (c)(1) and (2) of the
;;    Commercial Computer Software Restricted Rights at 48 CFR
;;    52.227-19, as applicable. The manufacturer of this SOFTWARE
;;    is Tony Tanzillo, Design Automation Consulting.
;;
;;    NO WARRANTY
;;
;;    ANY USE OF THIS SOFTWARE IS AT YOUR OWN RISK. THE SOFTWARE
;;    IS PROVIDED FOR USE "AS IS" AND WITHOUT WARRANTY OF ANY KIND.
;;    TO THE MAXIMUM EXTENT PERMITTED BY APPLICABLE LAW, THE AUTHOR
;;    DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING, BUT
;;    NOT LIMITED TO, IMPLIED WARRANTIES OF MERCHANTABILITY AND
;;    FITNESS FOR A PARTICULAR PURPOSE, WITH REGARD TO THE SOFTWARE.
;;
;;    NO LIABILITY FOR CONSEQUENTIAL DAMAGES. TO THE MAXIMUM
;;    EXTENT PERMITTED BY APPLICABLE LAW, IN NO EVENT SHALL
;;    THE AUTHOR OR ITS SUPPLIERS BE LIABLE FOR ANY SPECIAL,
;;    INCIDENTAL, INDIRECT, OR CONSEQUENTIAL DAMAGES WHATSOEVER
;;    (INCLUDING, WITHOUT LIMITATION, DAMAGES FOR LOSS OF
;;    BUSINESS PROFITS, BUSINESS INTERRUPTION, LOSS OF BUSINESS
;;    INFORMATION, OR ANY OTHER PECUNIARY LOSS) ARISING OUT OF
;;    THE USE OF OR INABILITY TO USE THE SOFTWARE PRODUCT, EVEN
;;    IF THE AUTHOR HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
;;    DAMAGES.  BECAUSE SOME JURISDICTIONS DO NOT ALLOW EXCLUSION
;;    OR LIMITATION OF LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL
;;    DAMAGES, THE ABOVE LIMITATION MAY NOT APPLY TO YOU.

; Adds the COUNT command to AutoCAD, which counts, itemizes, and displays
; in tabular form, the number of insertions of each block in the selected
; objects, or the entire drawing.
;
; Add to ACAD.LSP, or load with (load"count")
;
; First implemented in May of 1990.
;
; Revision history:
;
; 07/25/2002:  Added wildcard block name selection filtering
;
; 10/13/1991:  General revisions for R11:
;
;              1.  Now ignores anonymous blocks and Xrefs.
;
;              2.  Added console/screen paging, pauses listing
;                  at each screen-full and waits for a keypress.
;
;    Notes on console paging:
;
;      1.  To disable console paging, add the following to COUNT.LSP:
;
;              (setq *cpage-disable* t)
;
;      2.  The number of physical console lines defaults to 25.  This
;          can be overridden by adding the following to COUNT.LSP
;
;              (setq *console-lines* <num> )
;
;          Where <num> is the integer number of physical screen lines.
;
;      3.  The screen-clear function defaults to (textpage) under R11,
;          and (textscr) under R10 (no screen-clearing is performed),
;          but it can be redefined by assigning a function that is to
;          be called to do a screen-clear to the symbol *clear-screen*.
;
;          The following example can be used with R10 if ANSI.SYS or
;          any compatible console-driver is installed, to clear the
;          display on each screen-page:
;
;               (defun *clear-screen* ()
;                  (textscr)
;                  (princ "\e[2J")
;                  nil
;               )
;
; Program listing:

 (defun C:COUNT ( / blocks ss pat)
    (setq pat (getstring t "\nBlock name specification <*>: "))
    (if (eq pat "") (setq pat "*"))
    (princ "\nPress <CR> to select entire drawing or,")
    (cond
       (  (not (setq ss (cond ((ssget (list '(0 . "INSERT") (cons 2 pat))))
                              (t (ssget "x" (list '(0 . "INSERT") (cons 2 pat)))))))
          (princ "\nNo matching block insertions found."))
       (t (princ "\nCounting block insertions...\n")
          (  (lambda (i)
                (repeat i (count_block (ssname ss (setq i (1- i))))))
             (sslength ss))
          (cond
             (  (not blocks)
                (princ "\nNo block insertions found."))
             (t (table-print blocks "Block" "Count" "-" 8 "." nil 'itoa)))))
    (princ)
 )

 (defun table-print (alist title1 title2 headsub coltab padchr
                     car-form cdr-form / maxlen maxline padstr )
    (setq car-form (cond (car-form) (t '(lambda (x) x)))
          cdr-form (cond (cdr-form) (t '(lambda (x) x))))
    (setq maxlen
       (mapcar
         '(lambda (pair)
             (cons (strlen (car pair))
                   (strlen (cdr pair))))
          (setq alist
             (mapcar
               '(lambda (pair)
                   (cons (apply car-form (list (car pair)))
                         (apply cdr-form (list (cdr pair)))))
                alist ))))
    (setq maxlen  (+ -2 (apply 'max (mapcar 'car maxlen))
                        (apply 'max (mapcar 'cdr maxlen)))
          maxline (+ maxlen coltab)
          padstr  (repl padchr 70))

    (cprinc-init)
    (cprinc (strcat title1 " "
                    (ctab (cons title1 title2)
                          maxline
                          (repl " " 70))
                    " " title2))
    (cprinc (repl headsub (+ maxline 2)))
    (mapcar
      '(lambda (pair)
          (cprinc (strcat (car pair) " "
                          (ctab pair maxline padstr) " "
                          (cdr pair))))
       alist )
 )

 (defun repl (chr len / res)
    (apply 'strcat (repeat len (setq res (cons chr res))))
 )

 (defun ctab (pair max padstr)
    (substr padstr 1 (- max (strlen (car pair) (cdr pair))))
 )

 (defun cdr++ (key alist)
    (  (lambda (x)
          (cond (x (subst (cons (car x) (1+ (cdr x))) x alist))
                (t (cons (cons key 1) alist))))
       (assoc key alist))
 )

 (defun get (k l) (cdr (assoc k l)))

 (defun entgetf (k e)
    (  (lambda (l)
          (mapcar '(lambda (x) (cdr (assoc x l))) k))
       (entget e))
 )

 (defun count_block (ename)
    (apply
      '(lambda (etype name)
          (cond
             (  (and (eq "INSERT" etype)
                     (or (assoc name blocks)
                         (zerop (logand 45 (get 70 (tblsearch "block" name)))))
                (setq blocks (cdr++ name blocks))))) nil)
       (entgetf '(0 2) ename))
 )

 (defun cprinc-init ()
    (setq *console-lines* (cond (*console-lines*) (t 25))
          *cprinc-msg* (cond (*cprinc-msg*) (t "--- Press any key ---"))
          *cprinc-rubout*
          (cond (  (or textpage *clear-screen*) "")
                (t (strcat "\r" (repl " " (strlen *cprinc-msg*)) "\r")))
          *cprinc-line* -1)
    (cond (textpage (textpage))
          (*clear-screen* (*clear-screen*))
          (t (textscr) (terpri)))
 )

 (defun cprinc-page ()
    (princ *cprinc-msg*)
    (grread)
    (cond (textpage (textpage))
          (*clear-screen* (*clear-screen*))
          (t (textscr)))
    (princ *cprinc-rubout*)
    (setq *cprinc-line* 0)
 )

 (defun cprinc (s)
    (cond (  *cpage-disable*)
          (  (not *cprinc-line*)
             (cprinc-init))
          (  (eq (setq *cprinc-line* (1+ *cprinc-line*))
                 (1- *console-lines*))
             (cprinc-page)))
    (write-line s)
 )

; ############################ eof COUNT.LSP ################################

(princ "\nC:COUNT loaded.  Start command with COUNT. ")
(princ)