;;; TORVA LISP - Drawing Diet (torva.kr/lisp.html)
;;; DIET : AUDIT (fix errors) -> PURGE registered apps -> PURGE zero-length geometry
;;;        -> PURGE all, repeated until nothing more goes (max 5 rounds)
;;; Option O before start: also OVERKILL (merges overlapping objects - changes the drawing, off by default)
;;; Layers, hatches, xref / image definitions and the scale list are never touched
;;; Size on disk drops after you save. One U undoes the whole run

(vl-load-com)

(defun tv-dwg-diet-ms () (getvar "MILLISECS"))

;; run a command, then cancel anything still waiting for input (option not in this CAD version)
(defun tv-dwg-diet-cmd (args)
  (vl-catch-all-apply 'vl-cmdf args)
  (while (> (getvar "CMDACTIVE") 0) (command))
  (princ))

;; named items: table records + common dictionaries
(defun tv-dwg-diet-names (/ n e d o)
  (setq n 0)
  (foreach tb '("LAYER" "LTYPE" "STYLE" "BLOCK" "DIMSTYLE" "UCS" "VIEW" "VPORT" "APPID")
    (setq e (tblnext tb T))
    (while e (setq n (1+ n) e (tblnext tb))))
  (foreach dn '("ACAD_MLINESTYLE" "ACAD_TABLESTYLE" "ACAD_MATERIAL" "ACAD_MLEADERSTYLE" "ACAD_GROUP")
    (if (setq d (dictsearch (namedobjdict) dn))
      (progn (setq d (cdr (assoc -1 d)) o (dictnext d T))
             (while o (setq n (1+ n) o (dictnext d))))))
  n)

(defun tv-dwg-diet-objs (/ ss) (if (setq ss (ssget "_X")) (sslength ss) 0))

(defun c:DIET (/ *error* svl old doc ok ovk t0 n0 n1 o0 o1 c0 c1 i nAec ss)
  (setq svl '("CMDECHO" "EXPERT")
        old (mapcar 'getvar svl)
        doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (defun *error* (msg)
    (mapcar 'setvar svl old)
    (vla-EndUndoMark doc)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))

  (setq ok T ovk nil)
  (while (= ok T)
    (initget "Overkill")
    (setq ok (getkword (strcat "\nµµ¸é Á¤¸® ½ÃÀÛ [°ãÄ£ °´Ã¼ ÇÕÄ¡±â(O)] <" (if ovk "ÇÕÄ¡±â ÄÔ" "ÇÕÄ¡±â ²û") ">: ")))
    (if (= ok "Overkill") (setq ovk (not ovk) ok T)))

  (vla-StartUndoMark doc)
  (mapcar 'setvar svl '(0 5))
  (setq t0 (tv-dwg-diet-ms) n0 (tv-dwg-diet-names) o0 (tv-dwg-diet-objs))

  (setq nAec 0)
  (if (setq ss (ssget "_X" '((-4 . "<OR") (0 . "AEC*") (0 . "ACAD_PROXY_ENTITY") (-4 . "OR>"))))
    (setq nAec (sslength ss)))
  (if (> nAec 0) (princ (strcat "\n  Proxy / AEC objects: " (itoa nAec) " (left as is)")))

  (princ "\n  Audit") (tv-dwg-diet-cmd '("_.AUDIT" "_Y"))

  (if (and ovk (setq ss (ssget "_X" '((-4 . "<NOT") (0 . "ATTDEF") (-4 . "NOT>")))))
    (progn (princ "\n  Overkill") (tv-dwg-diet-cmd (list "_.-OVERKILL" ss "" ""))))

  (princ "\n  Purge registered apps") (tv-dwg-diet-cmd '("_.-PURGE" "_R" "*" "_N"))
  (princ "\n  Purge zero-length geometry") (tv-dwg-diet-cmd '("_.-PURGE" "_Z"))

  (setq c0 (tv-dwg-diet-names) i 0)
  (while (< i 5)
    (tv-dwg-diet-cmd '("_.-PURGE" "_A" "*" "_N"))
    (setq i (1+ i) c1 (tv-dwg-diet-names))
    (if (= c1 c0) (setq i 99) (setq c0 c1)))
  (princ "\n  Purge all")

  (setq n1 (tv-dwg-diet-names) o1 (tv-dwg-diet-objs))
  (mapcar 'setvar svl old)
  (vla-EndUndoMark doc)
  (princ (strcat "\nDIET: names " (itoa n0) " -> " (itoa n1)
                 ", objects " (itoa o0) " -> " (itoa o1)
                 ", " (rtos (/ (- (tv-dwg-diet-ms) t0) 1000.0) 2 1) " s - save to shrink"))
  (princ))

(princ "\nTORVA Drawing Diet: DIET | torva.kr")
(princ)

;;; ---- TVKEY: change a shortcut - shared by every TORVA LISP (torva.kr/lisp.html) ----
;;; TVKEY -> command -> new shortcut. The original command keeps working
;;; Shortcuts are saved on this PC as TORVA-KEYS and restored whenever a TORVA LISP loads
;;; (Every TORVA LISP carries this block; loading several just redefines the same functions)

;; "A1=PY;B2=CN;" -> (("A1" . "PY") ("B2" . "CN"))
(defun tv-key-list (/ s i out)
  (setq s (cond ((getenv "TORVA-KEYS")) ("")) out nil)
  (while (setq i (vl-string-search ";" s))
    (setq out (cons (substr s 1 i) out) s (substr s (+ i 2))))
  (if (/= s "") (setq out (cons s out)))
  (vl-remove nil
    (mapcar '(lambda (x / j) (if (setq j (vl-string-search "=" x)) (cons (substr x 1 j) (substr x (+ j 2)))))
            (reverse out))))

(defun tv-key-save (lst)
  (setenv "TORVA-KEYS" (apply 'strcat (mapcar '(lambda (p) (strcat (car p) "=" (cdr p) ";")) lst))))

;; is cmd a loaded LISP command
(defun tv-key-cmd-p (cmd)
  (member (type (eval (read (strcat "C:" cmd)))) '(SUBR USUBR EXRXSUBR)))

(defun tv-key-def (key cmd)
  (eval (list 'defun (read (strcat "C:" key)) '() (list (read (strcat "C:" cmd))) '(princ))))

;; is key an alias in acad.pgp ("L,   *LINE")
(defun tv-key-pgp-p (key / f h l hit)
  (if (setq f (findfile "acad.pgp"))
    (progn
      (setq h (open f "r"))
      (while (and (not hit) (setq l (read-line h)))
        (if (and (not (wcmatch l ";*")) (wcmatch (strcase l) (strcat key ",*"))) (setq hit T)))
      (close h)))
  hit)

;; reason the key cannot be used, nil if fine
(defun tv-key-bad (key lst)
  (cond
    ((not (vl-every '(lambda (c) (or (<= 48 c 57) (<= 65 c 90))) (vl-string->list key))) "¿µ¹®¡¤¼ýÀÚ¸¸")
    ((getcname key) "AutoCAD ¸í·É À̸§")
    ((tv-key-pgp-p key) "acad.pgp º°Äª°ú °°À½")
    ((and (tv-key-cmd-p key) (not (assoc key lst))) "ÀÌ¹Ì ÀÖ´Â ¸®½À ¸í·É")))

;; "My shortcuts" lines at the end of the file: (tv-my-key "A1" "BN"). Bad key -> reason only
(defun tv-my-key (key cmd / why)
  (setq key (strcase key) cmd (strcase cmd))
  (cond ((not (tv-key-cmd-p cmd)))
        ((setq why (tv-key-bad key (list (cons key cmd)))) (princ (strcat "\nShortcut " key ": " why)))
        (T (tv-key-def key cmd))))

(defun c:TVKEY (/ cmd key lst why)
  (setq lst (tv-key-list)
        cmd (strcase (getstring "\n´ÜÃàÅ°¸¦ ºÙÀÏ ¸í·É [¸ñ·Ï(?)]: ")))
  (cond
    ((= cmd ""))
    ((= cmd "?")
     (if lst
       (foreach p lst (princ (strcat "\n  " (car p) " = " (cdr p))))
       (princ "\nNo shortcuts set")))
    ((not (tv-key-cmd-p cmd)) (princ (strcat "\n" cmd " is not a loaded LISP command")))
    (T
     (setq key (strcase (getstring (strcat "\n" cmd " ÀÇ »õ ´ÜÃàÅ° [Áö¿ì±â(-)]: "))))
     (cond
       ((= key ""))
       ((= key "-")
        (foreach p lst
          (if (= (cdr p) cmd) (set (read (strcat "C:" (car p))) nil)))
        (tv-key-save (vl-remove-if '(lambda (p) (= (cdr p) cmd)) lst))
        (princ (strcat "\nShortcut for " cmd " removed")))
       ((= key cmd))
       ((setq why (tv-key-bad key lst)) (princ (strcat "\n" key ": " why)))
       (T
        (tv-key-save (cons (cons key cmd) (vl-remove-if '(lambda (p) (= (car p) key)) lst)))
        (tv-key-def key cmd)
        (princ (strcat "\n" key " now runs " cmd))))))
  (princ))

;; on load: restore saved shortcuts whose command is loaded
(foreach p (tv-key-list)
  (if (tv-key-cmd-p (cdr p)) (tv-key-def (car p) (cdr p))))
(princ "\nTVKEY: change a shortcut | torva.kr")
(princ)

;;; ---- My shortcuts: lines set at torva.kr download land below. Edit or add lines to change them ----