;;; TORVA LISP - Coordinate Align (torva.kr/lisp.html)
;;; CRD : select lines / polylines -> end points snapped to a grid (UCS), Z = 0
;;;   lines within the angle tolerance of horizontal / vertical become exactly horizontal / vertical
;;;   other lines keep their direction as far as the grid allows (end points rounded)
;;;   polylines: every vertex rounded, arcs kept, not exploded
;;; Options before selecting (Enter = select):
;;;   U grid unit (default 10, drawing units)  A angle tolerance in degrees (default 5, 0 = off)
;;;   R reference objects: end points within the snap distance move onto them first (this run only)
;;; Values persist until the drawing closes. Objects on locked layers are not selected

(vl-load-com)

(if (null *TV-CRD-UNIT*) (setq *TV-CRD-UNIT* 10.0))
(if (null *TV-CRD-ANG*) (setq *TV-CRD-ANG* 5.0))

(defun tv-crd-round (x u)
  (* u (fix (if (< x 0.0) (- (/ x u) 0.5) (+ (/ x u) 0.5)))))

(defun tv-crd-grid (p u)
  (list (tv-crd-round (car p) u) (tv-crd-round (cadr p) u) 0.0))

;; WCS point -> nearest point on a reference object within dist (WCS), else the point itself
(defun tv-crd-snap (p refs self dist / best d q)
  (setq best p)
  (foreach o refs
    (if (and (not (eq o self))
             (setq q (vl-catch-all-apply 'vlax-curve-getClosestPointTo (list o p)))
             (not (vl-catch-all-error-p q))
             (< (setq d (distance p q)) dist))
      (setq best q dist d)))
  best)

;; LINE: snap (WCS) -> UCS -> straighten or round -> back to WCS. T if changed
(defun tv-crd-line (en refs dist / ed a b deg tol u m)
  (setq ed (entget en) u *TV-CRD-UNIT* tol *TV-CRD-ANG*
        a (trans (tv-crd-snap (cdr (assoc 10 ed)) refs en dist) 0 1)
        b (trans (tv-crd-snap (cdr (assoc 11 ed)) refs en dist) 0 1)
        deg (rem (* (angle a b) (/ 180.0 pi)) 180.0))
  (cond
    ((and (> tol 0) (or (<= deg tol) (>= deg (- 180.0 tol))))          ; near horizontal
     (setq m (tv-crd-round (/ (+ (cadr a) (cadr b)) 2.0) u)
           a (list (tv-crd-round (car a) u) m 0.0) b (list (tv-crd-round (car b) u) m 0.0)))
    ((and (> tol 0) (<= (abs (- deg 90.0)) tol))                        ; near vertical
     (setq m (tv-crd-round (/ (+ (car a) (car b)) 2.0) u)
           a (list m (tv-crd-round (cadr a) u) 0.0) b (list m (tv-crd-round (cadr b) u) 0.0)))
    (t (setq a (tv-crd-grid a u) b (tv-crd-grid b u))))
  (setq a (trans a 1 0) b (trans b 1 0))
  (if (and (> (distance a b) 1e-9)
           (not (and (equal a (cdr (assoc 10 ed)) 1e-9) (equal b (cdr (assoc 11 ed)) 1e-9))))
    (progn (entmod (subst (cons 11 b) (assoc 11 ed) (subst (cons 10 a) (assoc 10 ed) ed))) T)))

;; LWPOLYLINE: each vertex OCS -> WCS snap -> UCS grid -> OCS. T if changed
(defun tv-crd-pline (en refs dist / ed z out p q chg)
  (setq ed (entget en) z (cond ((cdr (assoc 38 ed))) (0.0)))
  (foreach g ed
    (if (= (car g) 10)
      (progn
        (setq p (trans (list (cadr g) (caddr g) z) en 0)
              q (trans (tv-crd-grid (trans (tv-crd-snap p refs en dist) 0 1) *TV-CRD-UNIT*) 1 en)
              q (list 10 (car q) (cadr q)))
        (if (not (equal g q 1e-9)) (setq chg T))
        (setq out (cons q out)))
      (setq out (cons g out))))
  ;; UCS Z = 0 plane -> elevation of the polyline in its own OCS
  (setq out (subst (cons 38 (caddr (trans '(0 0 0) 1 en))) (assoc 38 out) (reverse out)))
  (if chg (progn (entmod out) T)))

(defun c:CRD (/ *error* old doc k v rs refs dist ss i en n)
  (setq old *error* doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (defun *error* (msg)
    (vla-EndUndoMark doc)
    (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))
  (setq k T)
  (while k
    (initget "U A R")
    (setq k (getkword (strcat "\n¼± Á¤¸® [´ÜÀ§(U)/°¢µµ(A)/±âÁØ(R)] <´ÜÀ§ " (rtos *TV-CRD-UNIT* 2 2) ", °¢µµ " (rtos *TV-CRD-ANG* 2 1)
                              (if refs (strcat ", ±âÁØ " (itoa (length refs))) ", ±âÁØ ¾øÀ½") ">: ")))
    (cond
      ((= k "U") (if (setq v (getdist (strcat "\n´ÜÀ§ <" (rtos *TV-CRD-UNIT* 2 2) ">: "))) (setq *TV-CRD-UNIT* v)))
      ((= k "A") (if (setq v (getreal (strcat "\nÇã¿ë °¢µµ <" (rtos *TV-CRD-ANG* 2 1) ">: "))) (setq *TV-CRD-ANG* (abs v))))
      ((= k "R")
       (princ "\n±âÁØ °´Ã¼: ")
       (setq refs nil)
       (if (setq rs (ssget '((0 . "LINE,LWPOLYLINE,ARC,CIRCLE,XLINE,RAY,SPLINE,ELLIPSE"))))
         (repeat (setq i (sslength rs)) (setq refs (cons (ssname rs (setq i (1- i))) refs))))
       (if refs
         (if (setq v (getdist (strcat "\nºÙÀÏ °Å¸® <" (rtos (if dist dist (* 10 *TV-CRD-UNIT*)) 2 2) ">: ")))
           (setq dist v)
           (if (null dist) (setq dist (* 10 *TV-CRD-UNIT*))))))
    )
  )
  (if (null dist) (setq dist 0.0))
  (if (<= *TV-CRD-UNIT* 0) (setq *TV-CRD-UNIT* 10.0))
  (princ "\nÁ¤¸®ÇÒ ¼±: ")
  (if (setq ss (ssget "_:L" '((0 . "LINE,LWPOLYLINE"))))
    (progn
      (vla-StartUndoMark doc)
      (setq i 0 n 0)
      (repeat (sslength ss)
        (setq en (ssname ss i) i (1+ i))
        (if (if (= (cdr (assoc 0 (entget en))) "LINE") (tv-crd-line en refs dist) (tv-crd-pline en refs dist))
          (setq n (1+ n))))
      (vla-EndUndoMark doc)
      (princ (strcat "\n" (itoa n) " of " (itoa (sslength ss)) " aligned to " (rtos *TV-CRD-UNIT* 2 2)))))
  (setq *error* old)
  (princ)
)

(princ "\nTORVA Coordinate Align: CRD | 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 ----