;;; ==================================================================
;;;  TDT-IIC.LSP  -  cong dien tich va ghi dien tich vao tung hinh
;;;  Vien Tin hoc Xay dung (IIC) - Truong Dai hoc Xay dung Ha Noi
;;;  https://iic.huce.edu.vn  -  Tel: 0989 427 809
;;; ------------------------------------------------------------------
;;;  Sau lenh:
;;;    TDT     chon theo bat ky kieu nao roi cong dien tich cac hinh kin
;;;    TDTX    cong moi hinh kin trong ca ban ve, khong phai chon
;;;    TDTP    dien tich PHU THUC, phan chong nhau chi dem mot lan
;;;    TDTPX   dien tich phu thuc cua ca ban ve
;;;    GDT     chon nhieu hinh roi ghi con so vao giua tung hinh
;;;    GDTX    ghi con so vao moi hinh kin trong ca ban ve
;;;
;;;  Ten lenh da do truoc khi dat: tep bi danh acad.pgp cua ban 2027 co
;;;  387 ten tat, trong do DT la bi danh cua TEXT, AA cua AREA, AR cua
;;;  ARRAY. Dat trung nhung ten ay la lay mat mot lenh san co cua nguoi
;;;  dung. Sau ten tren deu con trong.
;;;
;;;  Phan chong nhau: lisp nao cong thang tung hinh cung dem hai lan
;;;  phan de. TDTP nhan ban cac hinh da chon, doi ban sao thanh REGION,
;;;  gop lai bang UNION roi do, xong xoa sach. BAN VE GOC KHONG DOI MOT
;;;  NET. Mang to khong doi thanh REGION duoc nen duoc bao tach rieng.
;;;
;;;  Con so in ra tinh bang MET VUONG. He so doi lay tu bien INSUNITS,
;;;  nen ban ve dung theo met khong con ra ket qua lech mot trieu lan.
;;;
;;;  Luu y ve so le: ham rtos cat sach so 0 thua khi bien DIMZIN bang 8,
;;;  nen nhan co the ra "9.6 m2" thay vi "9.60 m2". Do la DIMZIN cua ban
;;;  ve chu khong phai loi cua tep. Muon du hai so le thi dat DIMZIN ve
;;;  0 truoc khi chay.
;;;
;;;  Nap tep: go APPLOAD, chon tep nay, bam Load.
;;;  Tep luu bang ma UTF-8. Sua bang Notepad thi nho luu lai dung UTF-8.
;;; ==================================================================

(vl-load-com)

;;; ------------------------------------------------------------------
;;;  Phan chung
;;; ------------------------------------------------------------------

(defun iic-bang-ten ()
  (princ "\nLisp được lập trình bởi RDSIC - Viện Tin học Xây dựng")
  (princ "\nwebsite: https://iic.huce.edu.vn")
  (princ "\nTel: 0989 427 809")
  (princ)
)

;; Gop ca lenh vao MOT buoc undo. Dung danh dau cua ActiveX chu khong
;; dung (command "_.UNDO" ...): ban 2027 CAM goi (command) tu trong ham
;; bay loi *error*, con danh dau nay thi goi duoc o moi noi.
(defun iic-tai-lieu () (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun iic-mo-undo () (vla-StartUndoMark (iic-tai-lieu)) (princ))
(defun iic-dong-undo () (vla-EndUndoMark (iic-tai-lieu)) (princ))

(defun iic-cat-bien (ten)
  (mapcar (function (lambda (v) (cons v (getvar v)))) ten)
)
(defun iic-tra-bien (ban)
  (foreach c ban (setvar (car c) (cdr c)))
  (princ)
)

;;; ------------------------------------------------------------------
;;;  Don vi ban ve
;;; ------------------------------------------------------------------
;;  Con so doc ra tinh bang don vi ban ve BINH PHUONG. Ban ve nha o
;;  Viet Nam thuong dung theo milimet, nen mot met vuong bang mot trieu
;;  don vi. He so lay tu INSUNITS chu khong doan.

(defun iic-he-so (/ u)
  (setq u (getvar "insunits"))
  (cond ((= u 4) 1e-6) ((= u 5) 1e-4) ((= u 6) 1.0) (T 1e-6))
)

(defun iic-ten-don-vi (/ u)
  (setq u (getvar "insunits"))
  (cond ((= u 4) "milimét") ((= u 5) "xentimét") ((= u 6) "mét")
        (T "không khai báo, tạm coi là milimét"))
)

(defun iic-ra-m2 (s) (strcat (rtos (* s (iic-he-so)) 2 3) " m2"))

;;; ------------------------------------------------------------------
;;;  Hinh nao co dien tich
;;; ------------------------------------------------------------------
;;  Nhan moi loai hinh co dien tich chu khong rieng mang to: da tuyen
;;  kin, duong tron, elip, spline kin va region. Hinh CHUA khep kin thi
;;  bo qua va bao ro, chu khong khep ho roi tra mot con so sai.

(defun iic-loai (e) (cdr (assoc 0 (entget e))))

(defun iic-kin-p (e / o loai)
  (setq loai (iic-loai e) o (vlax-ename->vla-object e))
  (cond
    ((member loai (list "CIRCLE" "REGION" "HATCH")) T)
    ((member loai (list "ELLIPSE" "LWPOLYLINE" "POLYLINE" "SPLINE"))
     (and (vlax-property-available-p o "Closed")
          (= (vla-get-Closed o) :vlax-true)))
    (T nil)
  )
)

;; Dien tich cua mot hinh kin, hoac nil neu khong lay duoc.
(defun iic-dien-tich (e / r)
  (if (iic-kin-p e)
    (progn
      (setq r (vl-catch-all-apply (function vla-get-Area)
                                  (list (vlax-ename->vla-object e))))
      (if (vl-catch-all-error-p r) nil r)
    )
  )
)

;;; ------------------------------------------------------------------
;;;  Lay bo doi tuong
;;; ------------------------------------------------------------------

(defun iic-chon (nhac)
  (princ nhac)
  (ssget)
)

;; Moi doi tuong cua TAB dang mo, khong lay lan sang to giay khac.
(defun iic-chon-het ()
  (ssget "_X" (list (cons 410 (getvar "ctab"))))
)

;; Tach bo chon thanh (danh-sach-hinh-kin  so-hinh-bo-qua)
(defun iic-loc (bo / i e ds bo-qua)
  (setq i 0 ds (list) bo-qua 0)
  (if bo
    (while (< i (sslength bo))
      (setq e (ssname bo i))
      (if (iic-dien-tich e)
        (setq ds (cons e ds))
        (setq bo-qua (1+ bo-qua))
      )
      (setq i (1+ i))
    )
  )
  (list (reverse ds) bo-qua)
)

(defun iic-cong (ds / s)
  (setq s 0.0)
  (foreach e ds (setq s (+ s (iic-dien-tich e))))
  s
)

;;; ------------------------------------------------------------------
;;;  Lenh TDT va TDTX - tong cong don
;;; ------------------------------------------------------------------

(defun iic-tong (bo rong / goi ds bo-qua s)

  (if (null bo)
    (princ (if rong "\n  Bản vẽ không có hình nào."
                    "\n  Không chọn được hình nào."))
    (progn
      (setq goi (iic-loc bo) ds (car goi) bo-qua (cadr goi))
      (if (null ds)
        (princ (if rong "\n  Bản vẽ không có hình nào có diện tích."
                        "\n  Không chọn được hình nào có diện tích."))
        (progn
          (setq s (iic-cong ds))
          (princ (strcat "\n  Đơn vị bản vẽ: " (iic-ten-don-vi)))
          (princ (strcat "\n  Đã tính   : " (itoa (length ds))))
          (princ (strcat "\n  Đã bỏ qua : " (itoa bo-qua)
                         (if (> bo-qua 0) " hình KHÔNG khép kín" "")))
          (princ (strcat "\n  TỔNG DIỆN TÍCH: " (iic-ra-m2 s)))
          (princ "\n  Đây là tổng CỘNG DỒN. Hình nào chồng lên nhau thì phần chồng được cộng")
          (princ "\n  hai lần — dùng lệnh TDTP để lấy DIỆN TÍCH PHỦ THỰC.")
        )
      )
    )
  )
  (princ)
)

;;; ------------------------------------------------------------------
;;;  Lenh TDTP va TDTPX - dien tich phu thuc
;;; ------------------------------------------------------------------
;;  Cach lam: nhan ban cac hinh da chon, doi ban sao thanh REGION, gop
;;  bang UNION roi do, xong xoa sach. Ban ve goc khong doi mot net.

;; Goi lenh qua vl-cmdf chu khong qua command: command la DANG DAC BIET
;; chu khong phai ham, nen vl-catch-all-apply nem "bad order function:
;; COMMAND". vl-cmdf la ham that (do tren 2027: type tra ve SUBR).
;;
;; Doi mot danh sach ban sao thanh REGION va gop lai. Tra ve tong dien
;; tich cua phan gop, hoac nil neu khong gop duoc.
(defun iic-gop-vung (ds / ban sao bo g0 e tam s n)
  (setq ban (iic-cat-bien (list "delobj" "cmdecho" "peditaccept"))
        sao (list))
  (setvar "delobj" 3)
  (setvar "cmdecho" 0)
  ;; nhan ban tung hinh
  (foreach e ds
    (setq tam (vl-catch-all-apply (function vla-Copy)
                                  (list (vlax-ename->vla-object e))))
    (if (not (vl-catch-all-error-p tam))
      (setq sao (cons (vlax-vla-object->ename tam) sao))
    )
  )
  (if (null sao)
    (progn (iic-tra-bien ban) nil)
    (progn
      ;; doi ban sao thanh REGION
      (setq bo (ssadd))
      (foreach e sao (if (entget e) (ssadd e bo)))
      (setq g0 (entlast))
      (vl-catch-all-apply (function vl-cmdf) (list "_.REGION" bo ""))
      ;; nhat cac region vua sinh ra
      (setq bo (ssadd) e (entnext g0) n 0)
      (while e
        (if (= "REGION" (iic-loai e)) (progn (ssadd e bo) (setq n (1+ n))))
        (setq e (entnext e))
      )
      ;; xoa nhung ban sao chua thanh region duoc
      (foreach e sao (if (and (entget e) (/= "REGION" (iic-loai e))) (entdel e)))
      (if (= n 0)
        (progn (iic-tra-bien ban) nil)
        (progn
          (if (> n 1) (vl-catch-all-apply (function vl-cmdf) (list "_.UNION" bo "")))
          ;; do lai nhung region con song
          (setq s 0.0 e (entnext g0))
          (while e
            (if (and (entget e) (= "REGION" (iic-loai e)))
              (setq s (+ s (vla-get-Area (vlax-ename->vla-object e)))))
            (setq e (entnext e))
          )
          ;; xoa sach ban sao
          (setq e (entnext g0))
          (while e
            (if (entget e) (entdel e))
            (setq e (entnext e))
          )
          (iic-tra-bien ban)
          s
        )
      )
    )
  )
)

(defun iic-phu-thuc (bo rong / goi ds bo-qua to net s-don s-phu)

  (if (null bo)
    (princ (if rong "\n  Bản vẽ không có hình nào."
                    "\n  Không chọn được hình nào."))
    (progn
      (setq goi (iic-loc bo) ds (car goi) bo-qua (cadr goi))
      (if (null ds)
        (princ (if rong "\n  Bản vẽ không có hình nào có diện tích."
                        "\n  Không chọn được hình nào có diện tích."))
        (progn
          ;; tach mang to ra: chung khong doi thanh REGION duoc
          (setq to  (vl-remove-if-not (function (lambda (e) (= "HATCH" (iic-loai e)))) ds)
                net (vl-remove-if     (function (lambda (e) (= "HATCH" (iic-loai e)))) ds))
          (princ (strcat "\n  Đơn vị bản vẽ: " (iic-ten-don-vi)))
          (princ (strcat "\n  Đã tính   : " (itoa (length net))))
          (princ (strcat "\n  Đã bỏ qua : " (itoa bo-qua)
                         (if (> bo-qua 0) " hình KHÔNG khép kín" "")))
          (if (null net)
            (princ "\n  KHÔNG gộp được vì mảng tô không đổi thành REGION được, nên KHÔNG có diện tích phủ thực. Muốn cộng cả mảng tô thì dùng lệnh TDT.")
            (progn
              (iic-mo-undo)
              (setq s-don (iic-cong net)
                    s-phu (iic-gop-vung net))
              (iic-dong-undo)
              (if (null s-phu)
                (princ "\n  KHÔNG gộp được các hình này thành vùng. Dùng lệnh TDT để lấy tổng cộng dồn.")
                (progn
                  (princ (strcat "\n  Đã gộp    : " (itoa (length net))))
                  (princ (strcat "\n  Tổng cộng dồn     : " (iic-ra-m2 s-don)))
                  (princ (strcat "\n  DIỆN TÍCH PHỦ THỰC: " (iic-ra-m2 s-phu)))
                  (if (> (- s-don s-phu) (* 1e-6 (max s-don 1.0)))
                    (princ (strcat "\n  Phần chồng nhau   : " (iic-ra-m2 (- s-don s-phu))))
                    (princ "\n  (Không có hình nào chồng lên nhau.)")
                  )
                  (princ "\n  Bản vẽ gốc KHÔNG bị thay đổi: phép gộp làm trên bản sao rồi xoá đi.")
                )
              )
            )
          )
          (if to
            (progn
              (princ (strcat "\n  Ngoài ra có " (itoa (length to)) " mảng tô, tổng "
                             (iic-ra-m2 (iic-cong to))))
              (princ "\n  KHÔNG gộp được vì mảng tô không đổi thành REGION được, nên KHÔNG")
              (princ "\n  nằm trong ba con số trên. Muốn cộng cả mảng tô thì dùng lệnh TDT.")
            )
          )
        )
      )
    )
  )
  (princ)
)

;;; ------------------------------------------------------------------
;;;  Lenh GDT va GDTX - ghi dien tich vao giua tung hinh
;;; ------------------------------------------------------------------

;; Tam cua mot hinh. Duong tron lay thang tam; cac hinh khac lay TRONG
;; TAM tinh qua mot REGION tam thoi, vi tam khung bao cua phong hinh
;; chu L co the roi ra ngoai phong. Khong duoc thi danh lay tam khung.
(defun iic-tam-region (e / ban g0 tam sao vt kq)
  (setq ban (iic-cat-bien (list "delobj" "cmdecho")))
  (setvar "delobj" 3)
  (setvar "cmdecho" 0)
  (setq sao (vl-catch-all-apply (function vla-Copy)
                                (list (vlax-ename->vla-object e))))
  (if (vl-catch-all-error-p sao)
    (progn (iic-tra-bien ban) nil)
    (progn
      (setq g0 (entlast))
      (vl-catch-all-apply (function vl-cmdf)
        (list "_.REGION" (ssadd (vlax-vla-object->ename sao)) ""))
      (setq tam (entnext g0))
      (if (and tam (= "REGION" (iic-loai tam)))
        (progn
          (setq vt (vl-catch-all-apply (function vla-get-Centroid)
                                       (list (vlax-ename->vla-object tam))))
          (if (not (vl-catch-all-error-p vt))
            (setq kq (append (vlax-safearray->list (vlax-variant-value vt)) (list 0.0))))
        )
      )
      ;; xoa sach ban sao du thanh cong hay khong
      (setq tam (entnext g0))
      (while tam (if (entget tam) (entdel tam)) (setq tam (entnext tam)))
      (if (and (null kq) (entget (vlax-vla-object->ename sao)))
        (entdel (vlax-vla-object->ename sao)))
      (iic-tra-bien ban)
      kq
    )
  )
)

(defun iic-tam-khung (e / o g1 g2 r)
  (setq o (vlax-ename->vla-object e)
        r (vl-catch-all-apply (function vla-getBoundingBox)
                              (list o (quote g1) (quote g2))))
  (if (vl-catch-all-error-p r)
    nil
    (progn
      (setq g1 (vlax-safearray->list g1) g2 (vlax-safearray->list g2))
      (list (* 0.5 (+ (car g1) (car g2))) (* 0.5 (+ (cadr g1) (cadr g2))) 0.0)
    )
  )
)

(defun iic-tam-hinh (e)
  (cond
    ((= "CIRCLE" (iic-loai e)) (cdr (assoc 10 (entget e))))
    ((iic-tam-region e))
    ((iic-tam-khung e))
    (T nil)
  )
)

(defun iic-dt-ghi-nhan (bo rong / goi ds bo-qua cao n hut p noi)

  (if (null bo)
    (princ (if rong "\n  Bản vẽ không có hình nào."
                    "\n  Không chọn được hình nào."))
    (progn
      (setq goi (iic-loc bo) ds (car goi) bo-qua (cadr goi))
      (if (null ds)
        (princ (if rong "\n  Bản vẽ không có hình nào có diện tích."
                        "\n  Không chọn được hình nào có diện tích."))
        (progn
          (setq cao (getvar "textsize"))
          (if (<= cao 1e-8) (setq cao 2.5))
          (iic-mo-undo)
          (setq n 0 hut 0)
          (foreach e ds
            (setq p   (iic-tam-hinh e)
                  noi (strcat (rtos (* (iic-dien-tich e) (iic-he-so)) 2 2) " m2"))
            (if p
              (progn
                (entmake (list (cons 0 "TEXT") (cons 10 p) (cons 11 p)
                               (cons 40 cao) (cons 1 noi)
                               (cons 72 1) (cons 73 2)))
                (setq n (1+ n))
              )
              (setq hut (1+ hut))
            )
          )
          (iic-dong-undo)
          (princ (strcat "\n  Đơn vị bản vẽ: " (iic-ten-don-vi)))
          (princ (strcat "\n  Đã ghi nhãn cho " (itoa n) " hình kín."))
          (if (> hut 0)
            (princ (strcat "\n  Có " (itoa hut) " hình kín KHÔNG đặt được nhãn.")))
          (if (> bo-qua 0)
            (princ (strcat "\n  Đã bỏ qua " (itoa bo-qua) " hình KHÔNG khép kín.")))
        )
      )
    )
  )
  (princ)
)

;;; ------------------------------------------------------------------
;;;  Vo boc cua sau lenh
;;; ------------------------------------------------------------------

(defun iic-chay (ham rong nhac / *error* cu-error ban bo)
  (setq cu-error *error*
        ban      (iic-cat-bien (list "cmdecho" "delobj")))
  (defun *error* (m)
    (if (and m (/= m "Function cancelled") (/= m "quit / exit abort"))
      (princ (strcat "\nIIC lỗi: " m)))
    (iic-tra-bien ban)
    (iic-dong-undo)
    (setq *error* cu-error)
    (princ)
  )
  (iic-bang-ten)
  (setq bo (if rong (iic-chon-het) (iic-chon nhac)))
  (apply ham (list bo rong))
  (iic-tra-bien ban)
  (setq *error* cu-error)
  (princ)
)

(defun c:TDT ()
  (iic-chay (function iic-tong) nil
            "\nChọn đối tượng (bấm từng cái, kéo cửa sổ, kéo cắt ngang, WP, CP, F, ALL...): "))
(defun c:TDTX  () (iic-chay (function iic-tong) T nil))
(defun c:TDTP ()
  (iic-chay (function iic-phu-thuc) nil
            "\nChọn đối tượng (bấm từng cái, kéo cửa sổ, kéo cắt ngang, WP, CP, F, ALL...): "))
(defun c:TDTPX () (iic-chay (function iic-phu-thuc) T nil))
(defun c:GDT ()
  (iic-chay (function iic-dt-ghi-nhan) nil "\nChọn các hình cần ghi diện tích: "))
(defun c:GDTX  () (iic-chay (function iic-dt-ghi-nhan) T nil))

(princ "\nĐã nạp TDT-IIC. Lệnh: TDT, TDTX (tổng cộng dồn), TDTP, TDTPX (diện tích phủ thực), GDT, GDTX (ghi nhãn).")
(princ)