;;; TORVA LISP - Detail Zoom (torva.kr/lisp.html)
;;; DTL : circle the source area -> circle the detail place -> scaled copy trimmed to the circle
;;; Scale = detail radius / source radius. Blocks in the copy are exploded, the source is untouched
;;; Layer DETAIL (color 4), created if missing. Tangent lines HIDDEN2 (acad.lin)
;;; Trim uses Express Tools EXTRIM when present, else TRIM with a fence

(vl-load-com)

(setq *TV-DTL-LAYER* "DETAIL")

(defun tv-dtl-acos (x)
  (cond ((>= x 1.0) 0.0)
        ((<= x -1.0) pi)
        (t (atan (sqrt (- 1.0 (* x x))) x))))

;; draw a circle with the user, move it to layer DETAIL; returns (ename center radius)
(defun tv-dtl-circle (msg / e)
  (princ msg)
  (setq e (entlast))
  (setvar "CMDECHO" 1)
  (command "_.CIRCLE" pause pause)
  (setvar "CMDECHO" 0)
  (if (not (eq e (entlast)))
    (progn
      (setq e (entlast))
      (command "_.CHPROP" e "" "_LA" *TV-DTL-LAYER* "_C" "_BYLAYER" "_LT" "_BYLAYER" "")
      (list e (cdr (assoc 10 (entget e))) (cdr (assoc 40 (entget e)))))))

(defun c:DTL (/ *error* old doc osm ce qa tm c1 c2 p1 p2 r1 r2 pts a ss d da ac lt last new bl i e)
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
        osm (getvar "OSMODE") ce (getvar "CMDECHO") qa (getvar "QAFLAGS") tm (getvar "TRIMEXTENDMODE")
        old *error*)
  (defun *error* (msg)
    (setvar "OSMODE" osm) (setvar "CMDECHO" ce) (setvar "QAFLAGS" qa)
    (if tm (setvar "TRIMEXTENDMODE" tm))
    (vla-EndUndoMark doc)
    (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*,*EXIT*")) (princ (strcat "\nError: " msg)))
    (princ))
  (vla-StartUndoMark doc)
  (setvar "CMDECHO" 0)
  (if (null (tblsearch "LAYER" *TV-DTL-LAYER*))
    (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
                   (cons 2 *TV-DTL-LAYER*) '(70 . 0) '(62 . 4) '(6 . "Continuous"))))
  (if (null (tblsearch "LTYPE" "HIDDEN2"))
    (vl-catch-all-apply 'vla-load (list (vla-get-Linetypes doc) "HIDDEN2" "acad.lin")))
  (setq lt (if (tblsearch "LTYPE" "HIDDEN2") '(6 . "HIDDEN2") '(6 . "BYLAYER")))

  (if (and (setq c1 (tv-dtl-circle "\nÈ®´ëÇÒ ¹üÀ§ (Áß½ÉÁ¡, Å©±â): "))
           (setq p1 (cadr c1) r1 (caddr c1)
                 a 0.0)
           (progn
             ;; objects touching the source circle (36-gon crossing polygon)
             (repeat 36 (setq pts (cons (polar p1 a r1) pts) a (+ a (/ pi 18.0))))
             (setq ss (ssget "_CP" pts))
             (if ss (ssdel (car c1) ss))
             T)
           (setq c2 (tv-dtl-circle "\nÈ®´ëµµ ÀÚ¸® (Áß½ÉÁ¡, Å©±â): ")))
    (progn
      (setq p2 (cadr c2) r2 (caddr c2) d (distance p1 p2))
      ;; outer tangent lines between the two circles
      (if (> d (abs (- r1 r2)))
        (progn
          (setq ac (angle p1 p2) da (tv-dtl-acos (/ (- r1 r2) d)))
          (foreach s (list da (- da))
            (entmake (list '(0 . "LINE") (cons 8 *TV-DTL-LAYER*) '(62 . 7) lt
                           (cons 10 (polar p1 (+ ac s) r1)) (cons 11 (polar p2 (+ ac s) r2)))))))
      (if ss
        (progn
          (setq last (entlast) new (ssadd) bl (ssadd))
          (setvar "OSMODE" 0)
          (command "_.COPY" ss "" "_non" p1 "_non" p2)
          (while (setq last (entnext last)) (ssadd last new))
          (if (> (sslength new) 0) (command "_.SCALE" new "" "_non" p2 (/ r2 r1)))
          (command "_.ZOOM" "_C" p2 (* r2 4.0))
          ;; explode copied blocks so they can be trimmed
          (setq i 0)
          (repeat (sslength new)
            (setq e (ssname new i) i (1+ i))
            (if (= (cdr (assoc 0 (entget e))) "INSERT") (ssadd e bl)))
          (if (> (sslength bl) 0)
            (progn (setvar "QAFLAGS" 1) (vl-cmdf "_.EXPLODE" bl "") (setvar "QAFLAGS" qa)))
          ;; trim everything outside the detail circle
          (if (and (null etrim) (findfile "extrim.lsp")) (vl-catch-all-apply 'load (list "extrim.lsp")))
          (if etrim
            (etrim (car c2) (polar p2 0.0 (* r2 1.5)))
            (progn
              (if tm (setvar "TRIMEXTENDMODE" 0))
              (command "_.TRIM" (car c2) "" "_F")
              (setq a 0.0)
              (repeat 73 (command "_non" (polar p2 a (* r2 1.02))) (setq a (+ a (/ pi 36.0))))
              (command "" "")
              (if tm (setvar "TRIMEXTENDMODE" tm))))
          (command "_.ZOOM" "_P")))
      (princ (strcat "\nDetail zoom x" (rtos (/ r2 r1) 2 2)))))

  (setvar "OSMODE" osm) (setvar "CMDECHO" ce) (setvar "QAFLAGS" qa)
  (vla-EndUndoMark doc)
  (setq *error* old)
  (princ)
)

(princ "\nTORVA Detail Zoom: DTL | 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 ----