;============================================================
; THONGKEBANG_ALL.lsp
; Lenh: THONGKEBANG
; Chuc nang: Tu dong thong ke tat ca TEXT / MTEXT / ATTRIBUTE / TEXT trong BLOCK
;           Bo qua DIMENSION va bo qua text chi la so kich thuoc.
; Tac gia: ChatGPT
;============================================================

(vl-load-com)

;---------------- CAI DAT ----------------
; T = bo qua layer co ten chua DIM / DIMENSION / KICH THUOC
; Neu file cua ban de tag M1, CC7.1 tren layer co chu DIM thi doi thanh nil.
(setq *THB_SKIP_DIM_LAYER* T)

; T = bo qua text chi co so, dau cham, dau phay, dau cong/tru, ky hieu do dai
; Dung de tranh dem cac dim da bi explode thanh TEXT nhu 500, 700, 900...
(setq *THB_SKIP_NUMBER_ONLY* T)

; Chieu cao chu mac dinh trong bang ket qua
(setq *THB_TEXT_HEIGHT* 2.5)

; Do sau quet text trong block long nhau
(setq *THB_BLOCK_DEPTH* 4)

;---------------- HAM TIEN ICH ----------------
(defun thb:replace-all (s old new / p)
  (if (not s) (setq s ""))
  (while (setq p (vl-string-search old s))
    (setq s (strcat (substr s 1 p) new (substr s (+ p (strlen old) 1))))
  )
  s
)

(defun thb:trim (s)
  (vl-string-trim " \t\r\n" s)
)

(defun thb:clean-mtext (s / r)
  (setq r (vl-princ-to-string s))
  ; doi cac ma xuong dong/khoang trang cua MTEXT thanh khoang trang
  (setq r (thb:replace-all r "\\P" " "))
  (setq r (thb:replace-all r "\\p" " "))
  (setq r (thb:replace-all r "\\~" " "))
  ; doi ky hieu AutoCAD pho bien, tranh dem nham %%C50 thanh ma co chu C
  (setq r (strcase r))
  (setq r (thb:replace-all r "%%C" "Ø"))
  (setq r (thb:replace-all r "%%D" "°"))
  (setq r (thb:replace-all r "%%P" "±"))
  ; bo mot so ky tu dinh dang MTEXT
  (setq r (thb:replace-all r "{" ""))
  (setq r (thb:replace-all r "}" ""))
  (setq r (thb:replace-all r "\\L" ""))
  (setq r (thb:replace-all r "\\O" ""))
  (setq r (thb:replace-all r "\\K" ""))
  (setq r (thb:replace-all r "\\l" ""))
  (setq r (thb:replace-all r "\\o" ""))
  (setq r (thb:replace-all r "\\k" ""))
  (thb:trim r)
)

(defun thb:normalize (s / r)
  (setq r (thb:clean-mtext s))
  ; bo khoang trang trong ma, vi nhieu ban ve co the viet M 1 thanh M1
  (setq r (thb:replace-all r " " ""))
  (setq r (thb:replace-all r "\t" ""))
  (thb:trim r)
)

(defun thb:has-letter-p (s / i c ok)
  (setq i 1 ok nil)
  (while (and (<= i (strlen s)) (not ok))
    (setq c (ascii (substr s i 1)))
    (if (or (and (>= c 65) (<= c 90)) (and (>= c 97) (<= c 122)))
      (setq ok T)
    )
    (setq i (1+ i))
  )
  ok
)

(defun thb:valid-key-p (s)
  (and s
       (/= s "")
       ; bo qua text chi la so/dim. Tat ca ma nhu M1, M2, CC7.1 deu co chu.
       (or (not *THB_SKIP_NUMBER_ONLY*) (thb:has-letter-p s))
  )
)

(defun thb:dim-layer-p (lay)
  (and lay
       *THB_SKIP_DIM_LAYER*
       (wcmatch (strcase lay) "*DIM*,*DIMENSION*,*KICH*THUOC*,*KÍCH*THƯỚC*")
  )
)

(defun thb:skip-ent-p (edata / typ lay)
  (setq typ (cdr (assoc 0 edata)))
  (setq lay (cdr (assoc 8 edata)))
  (or (= typ "DIMENSION")
      (thb:dim-layer-p lay)
  )
)

(defun thb:skip-vla-p (obj / on lay res)
  (setq on (vl-catch-all-apply 'vla-get-ObjectName (list obj)))
  (if (vl-catch-all-error-p on) (setq on ""))
  (setq lay (vl-catch-all-apply 'vla-get-Layer (list obj)))
  (if (vl-catch-all-error-p lay) (setq lay nil))
  (or (wcmatch on "*Dimension*")
      (thb:dim-layer-p lay)
  )
)

(defun thb:add-count (key counts / a)
  (if (setq a (assoc key counts))
    (subst (cons key (1+ (cdr a))) a counts)
    (cons (cons key 1) counts)
  )
)

(defun thb:count-raw-text (raw counts / key)
  (setq key (thb:normalize raw))
  (if (thb:valid-key-p key)
    (thb:add-count key counts)
    counts
  )
)

(defun thb:block-name (obj / n)
  (setq n (vl-catch-all-apply 'vla-get-EffectiveName (list obj)))
  (if (vl-catch-all-error-p n)
    (setq n (vl-catch-all-apply 'vla-get-Name (list obj)))
  )
  (if (vl-catch-all-error-p n) nil n)
)

(defun thb:get-attrs (obj / atts res a txt)
  (setq res nil)
  (setq atts (vl-catch-all-apply 'vlax-invoke (list obj 'GetAttributes)))
  (if (not (vl-catch-all-error-p atts))
    (foreach a atts
      (if (not (thb:skip-vla-p a))
        (progn
          (setq txt (vl-catch-all-apply 'vla-get-TextString (list a)))
          (if (not (vl-catch-all-error-p txt))
            (setq res (cons txt res))
          )
        )
      )
    )
  )
  res
)

(defun thb:get-block-texts (br depth seen / name doc blks blk res obj on txt nested)
  (setq res nil)
  (if (and br (< depth *THB_BLOCK_DEPTH*))
    (progn
      (setq name (thb:block-name br))
      ; Bo qua block anonymous, thuong la block cua DIM/HATCH hoac block tam.
      ; Dynamic block co EffectiveName nen van quet duoc.
      (if (and name (/= (substr name 1 1) "*") (not (member (strcase name) seen)))
        (progn
          (setq doc  (vla-get-ActiveDocument (vlax-get-acad-object)))
          (setq blks (vla-get-Blocks doc))
          (setq blk (vl-catch-all-apply 'vla-item (list blks name)))
          (if (not (vl-catch-all-error-p blk))
            (progn
              (vlax-for obj blk
                (if (not (thb:skip-vla-p obj))
                  (progn
                    (setq on (vl-catch-all-apply 'vla-get-ObjectName (list obj)))
                    (if (vl-catch-all-error-p on) (setq on ""))
                    (cond
                      ((= on "AcDbText")
                       (setq txt (vl-catch-all-apply 'vla-get-TextString (list obj)))
                       (if (not (vl-catch-all-error-p txt)) (setq res (cons txt res)))
                      )
                      ((= on "AcDbMText")
                       (setq txt (vl-catch-all-apply 'vla-get-TextString (list obj)))
                       (if (not (vl-catch-all-error-p txt)) (setq res (cons txt res)))
                      )
                      ((= on "AcDbBlockReference")
                       (setq nested (thb:get-block-texts obj (1+ depth) (cons (strcase name) seen)))
                       (if nested (setq res (append nested res)))
                      )
                    )
                  )
                )
              )
            )
          )
        )
      )
    )
  )
  res
)

(defun thb:get-texts-from-entity (en / ed typ obj txt res)
  (setq res nil)
  (setq ed (entget en))
  (if (not (thb:skip-ent-p ed))
    (progn
      (setq typ (cdr (assoc 0 ed)))
      (cond
        ((= typ "TEXT")
         (setq txt (cdr (assoc 1 ed)))
         (if txt (setq res (cons txt res)))
        )
        ((= typ "MTEXT")
         (setq txt (cdr (assoc 1 ed)))
         (if txt (setq res (cons txt res)))
        )
        ((= typ "ATTRIB")
         (setq txt (cdr (assoc 1 ed)))
         (if txt (setq res (cons txt res)))
        )
        ((= typ "INSERT")
         (setq obj (vlax-ename->vla-object en))
         ; Dem attribute thuc te trong block
         (setq res (append (thb:get-attrs obj) res))
         ; Dem TEXT/MTEXT co dinh nam ben trong block
         (setq res (append (thb:get-block-texts obj 0 nil) res))
        )
      )
    )
  )
  res
)

(defun thb:line (p1 p2)
  (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "0")))
)

(defun thb:text (pt h str)
  (entmakex
    (list
      '(0 . "TEXT")
      (cons 8 "0")
      (cons 10 pt)
      (cons 40 h)
      (cons 1 str)
      (cons 7 (getvar "TEXTSTYLE"))
      (cons 50 0.0)
      (cons 72 0)
      (cons 73 0)
    )
  )
)

(defun thb:max-len (lst / m)
  (setq m 0)
  (foreach x lst
    (if (> (strlen (car x)) m) (setq m (strlen (car x))))
  )
  m
)

(defun thb:draw-table (pt rows h / x y z rowH col1 col2 w total nrows i yrow maxlen)
  (setq x (car pt))
  (setq y (cadr pt))
  (setq z (if (caddr pt) (caddr pt) 0.0))
  (setq rowH (* h 2.2))
  (setq maxlen (max 8 (thb:max-len rows)))
  (setq col1 (max (* h 12.0) (* h 0.9 (+ maxlen 4))))
  (setq col2 (max (* h 10.0) (* h 8.0)))
  (setq w (+ col1 col2))
  (setq total 0)
  (foreach r rows (setq total (+ total (cdr r))))
  (setq nrows (+ 2 (length rows))) ; header + data + tong

  ; ke khung bang
  (setq i 0)
  (while (<= i nrows)
    (setq yrow (- y (* i rowH)))
    (thb:line (list x yrow z) (list (+ x w) yrow z))
    (setq i (1+ i))
  )
  (foreach xx (list x (+ x col1) (+ x w))
    (thb:line (list xx y z) (list xx (- y (* nrows rowH)) z))
  )

  ; header
  (thb:text (list (+ x (* h 0.8)) (- y (* rowH 0.70)) z) h "KY HIEU")
  (thb:text (list (+ x col1 (* h 0.8)) (- y (* rowH 0.70)) z) h "SO LUONG")

  ; data
  (setq i 1)
  (foreach r rows
    (setq yrow (- y (* i rowH)))
    (thb:text (list (+ x (* h 0.8)) (- yrow (* rowH 0.70)) z) h (car r))
    (thb:text (list (+ x col1 (* h 0.8)) (- yrow (* rowH 0.70)) z) h (itoa (cdr r)))
    (setq i (1+ i))
  )

  ; tong
  (setq yrow (- y (* i rowH)))
  (thb:text (list (+ x (* h 0.8)) (- yrow (* rowH 0.70)) z) h "TONG")
  (thb:text (list (+ x col1 (* h 0.8)) (- yrow (* rowH 0.70)) z) h (itoa total))
)

(defun thb:make-report (ss / i en texts oneText counts rows pt h)
  (setq counts nil)
  (setq i 0)
  (while (< i (sslength ss))
    (setq en (ssname ss i))
    (setq texts (thb:get-texts-from-entity en))
    (foreach oneText texts
      (setq counts (thb:count-raw-text oneText counts))
    )
    (setq i (1+ i))
  )
  (setq rows (vl-sort counts '(lambda (a b) (< (car a) (car b)))))
  (if rows
    (progn
      (setq pt (getpoint "\nChon diem dat bang thong ke: "))
      (if pt
        (progn
          (setq h (getreal (strcat "\nNhap chieu cao chu <" (rtos *THB_TEXT_HEIGHT* 2 2) ">: ")))
          (if (not h) (setq h *THB_TEXT_HEIGHT*))
          (thb:draw-table pt rows h)
          (princ (strcat "\nDa thong ke " (itoa (length rows)) " loai ky hieu. Tong so: " (itoa (apply '+ (mapcar 'cdr rows))) "."))
        )
      )
    )
    (princ "\nKhong tim thay ky hieu nao. Luu y: Lisp dang bo qua DIM va text chi co so.")
  )
  (princ)
)

;---------------- LENH CHINH ----------------
(defun C:THONGKEBANG (/ ss)
  (princ "\nTHONGKEBANG - Thong ke tat ca ky tu/text, bo qua DIM va text so kich thuoc.")
  (princ "\nQuet chon vung can thong ke: ")
  ; Chon TEXT/MTEXT/INSERT. Khong chon DIMENSION nen dim goc se bi bo qua.
  (setq ss (ssget '((0 . "TEXT,MTEXT,ATTRIB,INSERT"))))
  (if ss
    (thb:make-report ss)
    (princ "\nKhong co doi tuong nao duoc chon.")
  )
  (princ)
)

(princ "\nDa nap THONGKEBANG_FIX.lsp. Go lenh THONGKEBANG de thong ke.")
(princ)