;;; ==================================================================
;;;  SC1-IIC.LSP  -  scale mot chieu: phong theo phuong X hoac Y rieng
;;;  Vien Tin hoc Xay dung (IIC) - Truong Dai hoc Xay dung Ha Noi
;;;  https://iic.huce.edu.vn  -  Tel: 0989 427 809
;;; ------------------------------------------------------------------
;;;  Hai lenh:
;;;    SC1     chon doi tuong roi phong theo MOT phuong
;;;    SC1X    nhu tren nhung giu ket qua thanh mot the block, khong no
;;;
;;;  Vi sao can tep nay: lenh SCALE san co chi hoi DUNG MOT he so nen
;;;  luon phong deu hai phuong. Lenh STRETCH khong thay the duoc vi no
;;;  chi doi cho cac dinh nam trong khung chon: duong tron van la duong
;;;  tron, dong chu van nguyen be rong, the block van nguyen he so.
;;;
;;;  Cach lam: dua phan da chon vao mot dinh nghia block tam, chen lai
;;;  voi he so X khac he so Y, roi no ra. Day cung la cach cac tep lisp
;;;  dang luu hanh tren mang van dung.
;;;
;;;  BON DIEU CAN BIET TRUOC KHI CHAY - cac tep tren mang khong noi:
;;;    1. Duong tron se thanh ELIP. Khong tranh duoc: mot duong tron bi
;;;       keo mot phuong thi dung la elip.
;;;    2. Dong chu bi keo theo, chu gay ra hoac beo ra. Muon giu chu
;;;       dung co thi tach chu ra khoi vung chon truoc khi chay.
;;;    3. Duong da tuyen (LWPOLYLINE, POLYLINE) co the vo thanh tung
;;;       doan LINE rieng sau khi no.
;;;    4. Duong kich thuoc (DIMENSION) khong nen dua vao: no ra la mat
;;;       tinh lien ket, con so khong tu cap nhat nua.
;;;  Sau khi chay, lenh IN ra bang doi chieu so luong tung loai doi
;;;  tuong truoc va sau, de khong ai phai doan.
;;;
;;;  Dinh nghia block tam duoc XOA ngay sau khi xong. Nhieu tep tren
;;;  mang de lai block ten "vkc_temp" nam mai trong ban ve.
;;;
;;;  Ca lenh gop vao MOT buoc undo: bam U mot lan la ve nguyen trang.
;;;
;;;  Ten lenh da do truoc khi dat: tep bi danh acad.pgp cua ban 2027
;;;  khong co SC1 lan SC1X. SC la bi danh cua SCALE, S la cua STRETCH.
;;;
;;;  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)
)

;; Ten block tam chua ton tai trong ban ve.
(defun iic-ten-tam (/ i ten)
  (setq i 1
        ten "IIC-SC1-1")
  (while (tblsearch "block" ten)
    (setq i (1+ i)
          ten (strcat "IIC-SC1-" (itoa i))))
  ten
)

;; Dem so doi tuong theo tung loai trong mot bo chon.
(defun iic-dem-loai (ss / i e ten bang o)
  (setq i 0 bang nil)
  (while (< i (sslength ss))
    (setq e (ssname ss i)
          ten (cdr (assoc 0 (entget e)))
          o (assoc ten bang))
    (if o
      (setq bang (subst (cons ten (1+ (cdr o))) o bang))
      (setq bang (cons (cons ten 1) bang)))
    (setq i (1+ i)))
  (vl-sort bang (function (lambda (a b) (< (car a) (car b)))))
)

;; Xoa mot dinh nghia block neu khong con the nao dung toi.
(defun iic-xoa-block (ten / bl)
  (if (tblsearch "block" ten)
    (progn
      (setq bl (vl-catch-all-apply
                 (function (lambda ()
                   (vla-Item (vla-get-Blocks (iic-tai-lieu)) ten)))))
      (if (not (vl-catch-all-error-p bl))
        (vl-catch-all-apply (function (lambda () (vla-Delete bl)))))))
  (princ)
)

;;; ------------------------------------------------------------------
;;;  Ruot lenh
;;; ------------------------------------------------------------------

(defun iic-sc1 (no / *error* cu-error ban ss p0 phuong hs cach d1 d2
                     ten e ss2 truoc sau i)
  (setq cu-error *error*
        ban (iic-cat-bien (list "cmdecho" "osmode" "attreq" "attdia" "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)

  (princ "\nChọn các đối tượng cần phóng theo một phương: ")
  (setq ss (ssget))
  (if (null ss)
    (progn (princ "\n  Chưa chọn được đối tượng nào.")
           (setq *error* cu-error)
           (princ))
    (progn
      (setq truoc (iic-dem-loai ss))
      (setq p0 (getpoint "\nChọn điểm gốc (điểm đứng yên khi phóng): "))
      (if (null p0)
        (progn (princ "\n  Chưa chọn điểm gốc.")
               (setq *error* cu-error)
               (princ))
        (progn
          (initget "X Y")
          (setq phuong (getkword "\nPhóng theo phương nào? [X/Y] <X>: "))
          (if (null phuong) (setq phuong "X"))

          (initget "Hai")
          (setq cach (getkword "\nKhai bằng hệ số hay bằng hai chiều dài? [Hệ số/Hai chiều dài] <Hệ số>: "))
          (if (= cach "Hai")
            (progn
              (setq d1 (getdist p0 "\nChiều dài HIỆN CÓ theo phương đó: "))
              (setq d2 (getdist p0 "\nChiều dài MUỐN CÓ: "))
              (if (and d1 d2 (> d1 1e-9))
                (setq hs (/ d2 d1))
                (setq hs nil)))
            (setq hs (getreal "\nHệ số phóng theo phương đó <2>: ")))
          (if (null hs) (setq hs 2.0))

          (if (< (abs hs) 1e-9)
            (progn (princ "\n  Hệ số bằng 0 thì hình biến mất, nên dừng ở đây.")
                   (iic-tra-bien ban)
                   (setq *error* cu-error)
                   (princ))
            (progn
              (iic-mo-undo)
              (setvar "cmdecho" 0)
              (setvar "osmode" 0)
              (setvar "attreq" 0)
              (setvar "attdia" 0)
              (setq ten (iic-ten-tam))
              (command "_.-BLOCK" ten p0 ss "")
              (if (= phuong "X")
                (command "_.-INSERT" ten p0 hs 1.0 0)
                (command "_.-INSERT" ten p0 1.0 hs 0))
              (setq e (entlast))
              (if no
                (progn
                  (command "_.EXPLODE" e)
                  (setq ss2 (ssget "_P")))
                (setq ss2 (ssadd e (ssadd))))
              (iic-xoa-block ten)
              (setvar "cmdecho" 1)
              (iic-dong-undo)
              (iic-tra-bien ban)

              (princ (strcat "\n  Đã phóng theo phương " phuong
                             " với hệ số " (rtos hs 2 4) "."))
              (if no
                (progn
                  (setq sau (if ss2 (iic-dem-loai ss2) nil))
                  (princ "\n  Số đối tượng theo loại, trước và sau:")
                  (foreach c truoc
                    (princ (strcat "\n     " (car c) " : " (itoa (cdr c)) " -> "
                                   (itoa (cond ((assoc (car c) sau)
                                                (cdr (assoc (car c) sau)))
                                               (T 0))))))
                  (foreach c sau
                    (if (not (assoc (car c) truoc))
                      (princ (strcat "\n     " (car c) " : 0 -> " (itoa (cdr c))
                                     "   (mới sinh ra)"))))
                  (princ "\n  Đường tròn hoá elip và đa tuyến vỡ thành đoạn thẳng là bình thường:")
                  (princ "\n  một hình tròn bị kéo một phương thì đúng là elip.")
                )
                (princ "\n  Kết quả giữ nguyên dạng một thẻ block, sửa lại hệ số bất cứ lúc nào trong bảng Properties.")
              )
              (princ "\n  Bấm U một lần là về nguyên trạng.")
              (setq *error* cu-error)
              (princ)
            )
          )
        )
      )
    )
  )
)

(defun c:SC1  () (iic-sc1 T))
(defun c:SC1X () (iic-sc1 nil))
(defun c:SC1IIC  () (iic-sc1 T))
(defun c:SC1XIIC () (iic-sc1 nil))

(princ "\nĐã nạp SC1-IIC. Lệnh: SC1 (phóng một phương rồi nổ ra hình thường), SC1X (giữ thành block để sửa lại hệ số).")
(princ)