;;; TORVA LISP - XCLIP Explode (torva.kr/lisp.html)
;;; CXP : explode the selected block references. For a clipped block (XCLIP on), pieces lying
;;;       wholly outside the clip boundary are deleted, so the drawing looks the same as before
;;;       Pieces crossing the boundary are kept whole (not trimmed). A polygon clip is tested by its bounding box
;;;       Nested blocks exploded on later levels keep the outer clip boundary
;;; Settings (Enter at the selection prompt), kept until the drawing is closed:
;;;   margin - grows (+) or shrinks (-) the boundary, drawing units (default 0)
;;;   depth  - levels of nested blocks to explode (default 1)
;;; Skipped: xrefs, blocks on locked layers, inverted clips, blocks that cannot be exploded
;;; One U undoes the command

(vl-load-com)

(if (null *TV-CXP-PAD*) (setq *TV-CXP-PAD* 0.0))
(if (null *TV-CXP-DEPTH*) (setq *TV-CXP-DEPTH* 1))

(defun tv-cxp-num (x) (rtos x 2 (if (equal x (fix x) 1e-9) 0 2)))

;; SPATIAL filter of a clipped block, or nil
(defun tv-cxp-filter (ed / x f)
  (and (setq x (cdr (assoc 360 ed)))
       (setq f (dictsearch x "ACAD_FILTER"))
       (dictsearch (cdr (assoc -1 f)) "SPATIAL")))

;; T if the clip carries the inverted-clip record (then the block is left alone)
(defun tv-cxp-inverted (sp / x r)
  (and (setq x (cdr (assoc 360 sp)))
       (setq r (dictsearch x "ACAD_XREC_ROUNDTRIP"))
       (vl-some '(lambda (g) (and (= 'STR (type (cdr g))) (wcmatch (strcase (cdr g)) "*INVERTEDCLIP*"))) r)))

;; clip boundary box (xmin ymin xmax ymax) in WCS, or nil when there is no active clip
(defun tv-cxp-box (ed sp / pts ins bp sx sy ang)
  (if (and sp (/= 0 (cdr (assoc 71 sp)))
           (setq pts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) sp))))
    (progn
      (setq ins (cdr (assoc 10 ed))
            bp  (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 ed)))))
            sx  (cond ((cdr (assoc 41 ed))) (1.0))
            sy  (cond ((cdr (assoc 42 ed))) (1.0))
            ang (cond ((cdr (assoc 50 ed))) (0.0)))
      (setq pts (mapcar '(lambda (p / x y)
                           (setq x (* sx (- (car p) (car bp))) y (* sy (- (cadr p) (cadr bp))))
                           (list (+ (car ins) (- (* x (cos ang)) (* y (sin ang))))
                                 (+ (cadr ins) (* x (sin ang)) (* y (cos ang)))))
                        pts))
      (list (- (apply 'min (mapcar 'car pts)) *TV-CXP-PAD*) (- (apply 'min (mapcar 'cadr pts)) *TV-CXP-PAD*)
            (+ (apply 'max (mapcar 'car pts)) *TV-CXP-PAD*) (+ (apply 'max (mapcar 'cadr pts)) *TV-CXP-PAD*)))))

;; overlap of two boxes (either may be nil)
(defun tv-cxp-and (a b)
  (cond ((null a) b) ((null b) a)
        (T (list (max (car a) (car b)) (max (cadr a) (cadr b))
                 (min (caddr a) (caddr b)) (min (cadddr a) (cadddr b))))))

;; T if the entity lies wholly outside the box. Plain 2D geometry from entget, the rest by bounding box
(defun tv-cxp-outside (e ed bx / typ pl c r mn mx)
  (setq typ (cdr (assoc 0 ed)))
  (if (or (null (assoc 210 ed)) (equal (cdr (assoc 210 ed)) '(0.0 0.0 1.0) 1e-9))
    (cond
      ((= typ "LINE") (setq pl (list (cdr (assoc 10 ed)) (cdr (assoc 11 ed)))))
      ((or (member typ '("POINT" "SOLID" "3DFACE"))
           (and (= typ "LWPOLYLINE") (not (vl-some '(lambda (x) (and (= 42 (car x)) (/= 0.0 (cdr x)))) ed))))
       (setq pl (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) ed))))
      ((member typ '("CIRCLE" "ARC"))
       (setq c (cdr (assoc 10 ed)) r (cdr (assoc 40 ed))
             pl (list (list (- (car c) r) (- (cadr c) r)) (list (+ (car c) r) (+ (cadr c) r)))))))
  (if pl
    (setq mn (list (apply 'min (mapcar 'car pl)) (apply 'min (mapcar 'cadr pl)))
          mx (list (apply 'max (mapcar 'car pl)) (apply 'max (mapcar 'cadr pl))))
    (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-GetBoundingBox (list (vlax-ename->vla-object e) 'mn 'mx)))
      (setq mn nil)
      (setq mn (vlax-safearray->list mn) mx (vlax-safearray->list mx))))
  (and mn (or (< (car mx) (car bx)) (< (cadr mx) (cadr bx)) (> (car mn) (caddr bx)) (> (cadr mn) (cadddr bx)))))

(defun tv-cxp-locked (lay / d)
  (and (setq d (tblsearch "LAYER" lay)) (= 4 (logand 4 (cdr (assoc 70 d))))))

(defun tv-cxp-xref (bn / d)
  (and (setq d (tblsearch "BLOCK" bn)) (= 4 (logand 4 (cdr (assoc 70 d))))))

(defun c:CXP (/ *error* old hl doc um ss inp i lst nxt it ent ed sp bx res e d pass n0 nexp ndel nskip nlck ncur t0)
  (setq old *error* hl (getvar "HIGHLIGHT") doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (defun *error* (msg)
    (setvar "HIGHLIGHT" hl)
    (if um (vla-EndUndoMark doc))
    (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))

  (prompt (strcat "\nºÐÇØÇÒ ºí·Ï ¼±Åà (¿£ÅÍ = ¼³Á¤, ¿©À¯ " (tv-cxp-num *TV-CXP-PAD*) " / Áßø " (itoa *TV-CXP-DEPTH*) "´Ü): "))
  (if (null (setq ss (ssget '((0 . "INSERT")))))
    (progn
      (if (setq inp (getdist (strcat "\n°æ°è ¿©À¯ <" (tv-cxp-num *TV-CXP-PAD*) ">: "))) (setq *TV-CXP-PAD* inp))
      (initget 6)
      (if (setq inp (getint (strcat "\nÁßø ºÐÇØ ´Ü¼ö <" (itoa *TV-CXP-DEPTH*) ">: "))) (setq *TV-CXP-DEPTH* inp))
      (prompt "\nºÐÇØÇÒ ºí·Ï ¼±ÅÃ: ")
      (setq ss (ssget '((0 . "INSERT"))))))

  (if ss
    (progn
      (vla-StartUndoMark doc)
      (setq um T)
      (setvar "HIGHLIGHT" 0)
      (setq t0 (getvar "MILLISECS") i 0 lst nil nexp 0 ndel 0 nskip 0 nlck 0 ncur 0 pass 0)
      (repeat (sslength ss) (setq lst (cons (cons (ssname ss i) nil) lst) i (1+ i)))
      (setq n0 (length lst))
      (while (and lst (< pass *TV-CXP-DEPTH*))
        (setq pass (1+ pass) nxt nil)
        (foreach it lst
          (setq ent (car it))
          (if (setq ed (entget ent))
            (cond
              ((tv-cxp-xref (cdr (assoc 2 ed))) (setq nskip (1+ nskip)))
              ((tv-cxp-locked (cdr (assoc 8 ed))) (setq nlck (1+ nlck)))
              ((and (setq sp (tv-cxp-filter ed)) (tv-cxp-inverted sp)) (setq nskip (1+ nskip)))
              (T
               (setq bx (tv-cxp-and (cdr it) (tv-cxp-box ed sp))
                     res (vl-catch-all-apply 'vla-Explode (list (vlax-ename->vla-object ent))))
               (if (vl-catch-all-error-p res)
                 (setq nskip (1+ nskip))
                 (progn
                   (entdel ent)
                   (setq nexp (1+ nexp))
                   (if (or bx (< pass *TV-CXP-DEPTH*))
                     (foreach o (vlax-safearray->list (vlax-variant-value res))
                       (setq e (vlax-vla-object->ename o) d (entget e))
                       (cond ((and bx (tv-cxp-outside e d bx)) (entdel e) (setq ndel (1+ ndel)))
                             ((= "INSERT" (cdr (assoc 0 d))) (setq nxt (cons (cons e bx) nxt))))))))
               (setq ncur (1+ ncur))
               (if (= 0 (rem ncur 25)) (princ (strcat "\r  " (itoa ncur) " / " (itoa n0) "     ")))))))
        (setq lst nxt))
      (setvar "HIGHLIGHT" hl)
      (vla-EndUndoMark doc)
      (setq um nil)
      (princ (strcat "\nExploded " (itoa nexp) ", deleted outside clip " (itoa ndel)
                     ", skipped " (itoa nskip) ", " (rtos (/ (- (getvar "MILLISECS") t0) 1000.0) 2 1) " s"))
      (if (> nlck 0) (princ (strcat "\nLocked layer, skipped " (itoa nlck))))))
  (setq *error* old)
  (princ))

(princ "\nTORVA XCLIP Explode: CXP | 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 ----