;;; TORVA LISP - Text Layer (torva.kr/lisp.html)
;;; TLY : texts whose content contains (or equals) a word go to layer <prefix><word>
;;;       Targets: preselected TEXT / MTEXT, otherwise every text in the current tab
;;;       MTEXT formatting codes are ignored when matching
;;;       A new layer gets a bright colour not yet used by other <prefix> layers.
;;;       An existing target layer keeps its colour and is turned on, thawed and unlocked
;;; Settings (type ` at the word prompt), kept until the drawing is closed:
;;;   match contains / exact (default contains) ¡¤ case ignore / match (default ignore)
;;;   object colour keep / ByLayer (default keep) ¡¤ layer prefix (default TXT-)
;;; Texts on locked layers are skipped. One U undoes the command

(vl-load-com)

;; *TV-TLY-EXACT* *TV-TLY-CASE* *TV-TLY-BYL* start as nil (contains ¡¤ ignore case ¡¤ keep colour)
(if (null *TV-TLY-PRE*) (setq *TV-TLY-PRE* "TXT-"))

;; drop MTEXT format codes (\A1; \H2x; \fArial|b0; { } \P)
(defun tv-tly-strip (s / i c n r)
  (setq n (strlen s) i 1 r "")
  (while (<= i n)
    (setq c (substr s i 1))
    (cond
      ((member c '("{" "}")) nil)
      ((= c "\\")
       (setq i (1+ i) c (substr s i 1))
       (cond
         ((member c '("\\" "{" "}")) (setq r (strcat r c)))
         ((member (strcase c) '("P" "X" "~")) (setq r (strcat r " ")))
         (T (while (and (<= i n) (/= (substr s i 1) ";")) (setq i (1+ i))))))
      (T (setq r (strcat r c))))
    (setq i (1+ i)))
  r)

;; text content, long MTEXT included (group 3 chunks + group 1)
(defun tv-tly-text (el / s)
  (setq s "")
  (foreach x el (if (= 3 (car x)) (setq s (strcat s (cdr x)))))
  (if (assoc 1 el) (setq s (strcat s (cdr (assoc 1 el)))))
  (tv-tly-strip s))

(defun tv-tly-match (txt key / a b)
  (if *TV-TLY-CASE* (setq a txt b key) (setq a (strcase txt) b (strcase key)))
  (if *TV-TLY-EXACT* (= a b) (if (vl-string-search b a) T nil)))

;; characters not allowed in layer names -> _
(defun tv-tly-safename (s / i c r)
  (setq i 1 r "")
  (while (<= i (strlen s))
    (setq c (substr s i 1) i (1+ i))
    (setq r (strcat r (if (vl-string-search c "<>/\\\":;?*|,=`") "_" c))))
  r)

;; first bright colour not used by layers starting with the prefix
(defun tv-tly-color (pre / e nm used cand)
  (setq e (tblnext "LAYER" T))
  (while e
    (setq nm (cdr (assoc 2 e)))
    (if (wcmatch (strcase nm) (strcat (strcase pre) "*"))
      (setq used (cons (abs (cdr (assoc 62 e))) used)))
    (setq e (tblnext "LAYER")))
  (setq cand (vl-remove-if '(lambda (c) (member c used)) '(1 2 3 4 6 5 30 40 50 90 130 150 170 190 210 230 20)))
  (if cand (car cand) 1))

;; create the layer, or turn on / thaw / unlock an existing one (colour kept)
(defun tv-tly-layer (nm / el)
  (if (tblsearch "LAYER" nm)
    (progn
      (setq el (entget (tblobjname "LAYER" nm)))
      (setq el (subst (cons 62 (abs (cdr (assoc 62 el)))) (assoc 62 el) el))
      (setq el (subst (cons 70 (logand (cdr (assoc 70 el)) -6)) (assoc 70 el) el))
      (entmod el))
    (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
                   (cons 2 nm) '(70 . 0) (cons 62 (tv-tly-color *TV-TLY-PRE*)) '(6 . "CONTINUOUS"))))
  nm)

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

(defun tv-tly-settings (/ k s)
  (initget "Contains Exact")
  (if (setq k (getkword (strcat "\nã´Â ¹æ½Ä [Æ÷ÇÔ(C)/Á¤È®(E)] <" (if *TV-TLY-EXACT* "Á¤È®" "Æ÷ÇÔ") ">: ")))
    (setq *TV-TLY-EXACT* (= k "Exact")))
  (initget "Ignore Match")
  (if (setq k (getkword (strcat "\n´ë¼Ò¹®ÀÚ [¹«½Ã(I)/±¸ºÐ(M)] <" (if *TV-TLY-CASE* "±¸ºÐ" "¹«½Ã") ">: ")))
    (setq *TV-TLY-CASE* (= k "Match")))
  (initget "Keep Bylayer")
  (if (setq k (getkword (strcat "\n°´Ã¼ »ö [À¯Áö(K)/ByLayer(B)] <" (if *TV-TLY-BYL* "ByLayer" "À¯Áö") ">: ")))
    (setq *TV-TLY-BYL* (= k "Bylayer")))
  (setq s (vl-string-trim " " (getstring T (strcat "\n·¹ÀÌ¾î ¾Õ ±ÛÀÚ <" *TV-TLY-PRE* ">: "))))
  (if (/= s "") (setq *TV-TLY-PRE* s)))

(defun c:TLY (/ *error* old doc um ss key in lay i el lst new cnt lck fail res)
  (setq old *error* doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (defun *error* (msg)
    (if um (vla-EndUndoMark doc))
    (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))

  (setq ss (cond ((ssget "_I" '((0 . "TEXT,MTEXT"))))
                 ((ssget "_X" (list '(0 . "TEXT,MTEXT") (cons 410 (getvar "CTAB")))))))
  (sssetfirst nil nil)
  (if (null ss)
    (princ "\nNo text in this tab")
    (progn
      (while (= (setq in (vl-string-trim " " (getstring T (strcat "\n·¹ÀÌ¾î ¹Ù²Ü ±ÛÀÚ [¼³Á¤(`)] (´ë»ó "
                                                     (itoa (sslength ss)) "°³): "))))
                "`")
        (tv-tly-settings))
      (if (/= in "")
        (progn
          (setq key in i 0 lst nil lck 0)
          (repeat (sslength ss)
            (setq el (entget (ssname ss i)) i (1+ i))
            (if (tv-tly-match (tv-tly-text el) key)
              (if (tv-tly-locked (cdr (assoc 8 el))) (setq lck (1+ lck)) (setq lst (cons el lst)))))
          (if lst
            (progn
              (vla-StartUndoMark doc)
              (setq um T cnt 0 fail 0
                    lay (tv-tly-layer (tv-tly-safename (strcat *TV-TLY-PRE* key))))
              (foreach el lst
                (setq new (subst (cons 8 lay) (assoc 8 el) el))
                (if *TV-TLY-BYL*
                  (setq new (vl-remove-if '(lambda (x) (member (car x) '(420 430)))
                              (if (assoc 62 new) (subst '(62 . 256) (assoc 62 new) new) new))))
                (setq res (vl-catch-all-apply 'entmod (list new)))
                (if (or (null res) (vl-catch-all-error-p res)) (setq fail (1+ fail)) (setq cnt (1+ cnt))))
              (vla-EndUndoMark doc)
              (setq um nil)
              (princ (strcat "\n" (itoa cnt) " texts -> layer " lay
                             " (color " (itoa (abs (cdr (assoc 62 (tblsearch "LAYER" lay))))) ")"))
              (if (> fail 0) (princ (strcat "\nNot changed " (itoa fail)))))
            (princ "\nNo text matched"))
          (if (> lck 0) (princ (strcat "\nLocked layer, skipped " (itoa lck))))))))
  (setq *error* old)
  (princ))

(princ "\nTORVA Text Layer: TLY | 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 ----