;;; TORVA LISP - Text Align (torva.kr/lisp.html)
;;; TXC : select table lines + texts -> each text moves to the center of its cell (nearest lines L/R/T/B), justify MC
;;; TXL : select texts -> equal line spacing downward from the top text (Y only)
;;; Line spacing default = 8 x DIMSCALE (800 at 1:100). Entered value is kept until the drawing closes
;;; Cell detection band = 0.1 x DIMSCALE - only lines crossing the text center count as cell walls

(vl-load-com)

(defun tv-ta-ds ()
  (if (> (getvar "DIMSCALE") 0) (getvar "DIMSCALE") 1.0))

(defun tv-ta-doc () (vla-get-ActiveDocument (vlax-get-acad-object)))

;; T if the entity's layer is locked
(defun tv-ta-locked (en / d)
  (setq d (tblsearch "LAYER" (cdr (assoc 8 (entget en)))))
  (and d (= 4 (logand 4 (cdr (assoc 70 d))))))

;; LINE / LWPOLYLINE -> list of segments ((p1 p2) ...)
(defun tv-ta-segs (ed / typ pts j out)
  (setq typ (cdr (assoc 0 ed)))
  (cond
    ((= typ "LINE") (list (list (cdr (assoc 10 ed)) (cdr (assoc 11 ed)))))
    ((= typ "LWPOLYLINE")
     (foreach x ed (if (= (car x) 10) (setq pts (cons (cdr x) pts))))
     (setq pts (reverse pts))
     (if (= 1 (logand 1 (cdr (assoc 70 ed)))) (setq pts (append pts (list (car pts)))))
     (setq j 0)
     (while (< j (1- (length pts)))
       (setq out (cons (list (nth j pts) (nth (1+ j) pts)) out) j (1+ j)))
     out)))

(defun c:TXC (/ *error* old ce doc ss i en ed obj segs txts mn mx tx ty tol
                p1 p2 ax ay lx rx ty2 by dl dr dt db cx cy n)
  (setq ce (getvar "CMDECHO") old *error* doc (tv-ta-doc))
  (defun *error* (msg)
    (setvar "CMDECHO" ce) (setq *error* old) (vla-EndUndoMark doc)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))
  (vla-StartUndoMark doc)
  (setvar "CMDECHO" 0)
  (princ "\nÇ¥ ¼±°ú ±ÛÀÚ ¼±ÅÃ: ")
  (if (setq ss (ssget '((0 . "TEXT,MTEXT,LINE,LWPOLYLINE"))))
    (progn
      (setq i 0 n 0 tol (* 0.1 (tv-ta-ds)))
      (repeat (sslength ss)
        (setq en (ssname ss i) ed (entget en) i (1+ i))
        (if (wcmatch (cdr (assoc 0 ed)) "TEXT,MTEXT")
          (if (not (tv-ta-locked en)) (setq txts (cons en txts)))
          (setq segs (append (tv-ta-segs ed) segs))))
      (foreach en txts
        (setq obj (vlax-ename->vla-object en))
        (vla-GetBoundingBox obj 'mn 'mx)
        (setq mn (vlax-safearray->list mn) mx (vlax-safearray->list mx)
              tx (/ (+ (car mn) (car mx)) 2.0) ty (/ (+ (cadr mn) (cadr mx)) 2.0)
              lx nil rx nil ty2 nil by nil dl 1e99 dr 1e99 dt 1e99 db 1e99)
        ;; nearest vertical line on each side, nearest horizontal line above/below - through the text center
        (foreach sg segs
          (setq p1 (car sg) p2 (cadr sg))
          (if (< (abs (- (car p1) (car p2))) 1e-4)
            (progn
              (setq ax (/ (+ (car p1) (car p2)) 2.0))
              (if (and (<= (min (cadr p1) (cadr p2)) (+ ty tol)) (>= (max (cadr p1) (cadr p2)) (- ty tol)))
                (cond ((and (< ax tx) (< (- tx ax) dl)) (setq dl (- tx ax) lx ax))
                      ((and (> ax tx) (< (- ax tx) dr)) (setq dr (- ax tx) rx ax))))))
          (if (< (abs (- (cadr p1) (cadr p2))) 1e-4)
            (progn
              (setq ay (/ (+ (cadr p1) (cadr p2)) 2.0))
              (if (and (<= (min (car p1) (car p2)) (+ tx tol)) (>= (max (car p1) (car p2)) (- tx tol)))
                (cond ((and (> ay ty) (< (- ay ty) dt)) (setq dt (- ay ty) ty2 ay))
                      ((and (< ay ty) (< (- ty ay) db)) (setq db (- ty ay) by ay)))))))
        (setq cx (if (and lx rx) (/ (+ lx rx) 2.0) tx)
              cy (if (and ty2 by) (/ (+ ty2 by) 2.0) ty))
        (if (= (cdr (assoc 0 (entget en))) "TEXT")
          (progn (vla-put-Alignment obj 10) (vla-put-TextAlignmentPoint obj (vlax-3d-point cx cy 0.0)))
          (progn (vla-put-AttachmentPoint obj 5) (vla-put-InsertionPoint obj (vlax-3d-point cx cy 0.0))))
        (setq n (1+ n)))
      (princ (strcat "\n" (itoa n) " texts centered")))
    (princ "\nNothing selected"))
  (setvar "CMDECHO" ce) (setq *error* old) (vla-EndUndoMark doc)
  (princ))

(defun c:TXL (/ *error* old ce doc ss i en obj lst d pt al y0 k ty dy n)
  (setq ce (getvar "CMDECHO") old *error* doc (tv-ta-doc))
  (defun *error* (msg)
    (setvar "CMDECHO" ce) (setq *error* old) (vla-EndUndoMark doc)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))
  (vla-StartUndoMark doc)
  (setvar "CMDECHO" 0)
  (if (null *TV-TA-GAP*) (setq *TV-TA-GAP* (* 8.0 (tv-ta-ds))))
  (if (setq d (getdist (strcat "\nÁÙ °£°Ý <" (rtos *TV-TA-GAP* 2 0) ">: "))) (setq *TV-TA-GAP* d))
  (princ "\n±ÛÀÚ ¼±ÅÃ: ")
  (if (setq ss (ssget '((0 . "TEXT,MTEXT"))))
    (progn
      (setq i 0)
      (repeat (sslength ss)
        (setq en (ssname ss i) i (1+ i))
        (if (not (tv-ta-locked en))
          (progn
            (setq obj (vlax-ename->vla-object en))
            ;; reference point: left-justified TEXT = insertion, other TEXT = alignment point, MTEXT = insertion
            (if (= (vla-get-ObjectName obj) "AcDbText")
              (progn (setq al (vla-get-Alignment obj))
                     (setq pt (if (member al '(0 3 5)) (vlax-get obj 'InsertionPoint) (vlax-get obj 'TextAlignmentPoint))))
              (setq pt (vlax-get obj 'InsertionPoint)))
            (setq lst (cons (list obj (cadr pt)) lst)))))
      ;; top to bottom, the top text stays
      (setq lst (vl-sort lst '(lambda (a b) (> (cadr a) (cadr b)))) y0 (cadr (car lst)) k 0 n 0)
      (foreach e lst
        (setq ty (- y0 (* k *TV-TA-GAP*)) dy (- ty (cadr e)) k (1+ k))
        (if (not (equal dy 0.0 1e-6))
          (progn (vla-Move (car e) (vlax-3d-point '(0.0 0.0 0.0)) (vlax-3d-point (list 0.0 dy 0.0))) (setq n (1+ n)))))
      (princ (strcat "\n" (itoa (length lst)) " texts, " (itoa n) " moved")))
    (princ "\nNothing selected"))
  (setvar "CMDECHO" ce) (setq *error* old) (vla-EndUndoMark doc)
  (princ))

(princ "\nTORVA Text Align: TXC / TXL | 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 ----