;;; TORVA LISP - Column Size (torva.kr/lisp.html)
;;; CSZ : type width x height, select rectangles (closed 4-vertex polylines: columns, footings)
;;;       -> each is resized about its centre. Width = side closest to the UCS X axis. Rotated OK
;;; Lines and polylines touching the old faces (beam edges, walls) are stretched or trimmed to the new faces.
;;; Lines fully inside the new rectangle are erased. Centre-line layers (*TV-CSZ-SKIP*) are left alone.
;;; Neighbours on locked layers are unlocked for the change and locked again. Rectangles on locked layers are skipped.
;;; Neighbours are searched on screen around each rectangle - zoom so the area is visible.
;;; Default 600 x 600, last value kept until the drawing is closed. U undoes one selection.

(vl-load-com)

(if (null *TV-CSZ-W*) (setq *TV-CSZ-W* 600.0))
(if (null *TV-CSZ-H*) (setq *TV-CSZ-H* 600.0))
(setq *TV-CSZ-SKIP* "*CEN*,*CENTER*,*Áß½É*,G-CL,AXIS")

;; drawing scale factor for tolerances (1:100 mm drawing -> 100)
(defun tv-csz-ds () (if (> (getvar "DIMSCALE") 0) (getvar "DIMSCALE") 1.0))

;; T if the layer exists and is locked
(defun tv-csz-locked (lay / d)
  (setq d (tblsearch "LAYER" lay))
  (and d (= 4 (logand 4 (cdr (assoc 70 d))))))

;; unlock a locked layer for the change, remember it in *TV-CSZ-UNLOCKED*
(defun tv-csz-unlock (lay)
  (if (tv-csz-locked lay)
    (progn
      (vla-put-Lock (vla-Item (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))) lay) :vlax-false)
      (if (not (member lay *TV-CSZ-UNLOCKED*)) (setq *TV-CSZ-UNLOCKED* (cons lay *TV-CSZ-UNLOCKED*)))))
  T)

;; lock again what tv-csz-unlock opened
(defun tv-csz-relock (/ lays)
  (setq lays (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))))
  (foreach lay *TV-CSZ-UNLOCKED*
    (vl-catch-all-apply 'vla-put-Lock (list (vla-Item lays lay) :vlax-true)))
  (setq *TV-CSZ-UNLOCKED* nil))

;; world point -> local (x y) of the rectangle
(defun tv-csz-loc (pt cx cy c s / dx dy)
  (setq dx (- (car pt) cx) dy (- (cadr pt) cy))
  (list (+ (* dx c) (* dy s)) (- (* dy c) (* dx s))))

;; local (x y) -> world point
(defun tv-csz-wld (x y cx cy c s)
  (list (+ cx (- (* x c) (* y s))) (+ cy (+ (* x s) (* y c)))))

(defun tv-csz-inside (pt cx cy c s hx hy tol / l)
  (setq l (tv-csz-loc pt cx cy c s))
  (and (<= (abs (car l)) (+ hx tol)) (<= (abs (cadr l)) (+ hy tol))))

(defun tv-csz-on-edge (pt pts / i p1 p2 res)
  (setq i 0)
  (while (< i 4)
    (setq p1 (nth i pts) p2 (nth (rem (1+ i) 4) pts) i (1+ i))
    (if (equal (distance p1 p2) (+ (distance pt p1) (distance pt p2)) 1e-4) (setq res T)))
  res)

;; nearest point on the new rectangle along the line from base through dir (same direction only)
(defun tv-csz-ray (base dir pts / i p1 p2 q d best dmin)
  (setq i 0 dmin 1e300)
  (if (> (distance base dir) 1e-4)
    (while (< i 4)
      (setq p1 (nth i pts) p2 (nth (rem (1+ i) 4) pts) i (1+ i))
      (if (and (setq q (inters base dir p1 p2 nil))
               (equal (distance p1 p2) (+ (distance q p1) (distance q p2)) 1e-4)
               (> (+ (* (- (car q) (car base)) (- (car dir) (car base)))
                     (* (- (cadr q) (cadr base)) (- (cadr dir) (cadr base)))) 0.0)
               (< (setq d (distance base q)) dmin))
        (setq dmin d best q))))
  best)

;; polyline vertex on an old face line -> same spot on the new face, nil if unchanged
(defun tv-csz-vtx (pt cx cy c s ohx ohy nhx nhy tol / l x y)
  (setq l (tv-csz-loc pt cx cy c s) x (car l) y (cadr l))
  (cond ((<= (abs (- x ohx)) tol) (setq x nhx))
        ((<= (abs (+ x ohx)) tol) (setq x (- nhx))))
  (cond ((<= (abs (- y ohy)) tol) (setq y nhy))
        ((<= (abs (+ y ohy)) tol) (setq y (- nhy))))
  (if (or (not (equal x (car l) 1e-4)) (not (equal y (cadr l) 1e-4)))
    (tv-csz-wld x y cx cy c s)))

;; resize one rectangle to nw x nh and fix its neighbours; T when done
(defun tv-csz-set (en nw nh / ed pts cx cy ux a0 a1 aw c s l ohx ohy nhx nhy tol npts out xs ys m
                      ss k adj aed typ lay p1 p2 q1 q2 mod nv)
  (setq ed (entget en))
  (foreach x ed (if (= (car x) 10) (setq pts (cons (cdr x) pts))))
  (setq pts (reverse pts))
  (if (and (= (length pts) 4)
           (not (vl-some '(lambda (x) (and (= (car x) 42) (/= (cdr x) 0.0))) ed)))
    (progn
      (setq cx (/ (apply '+ (mapcar 'car pts)) 4.0) cy (/ (apply '+ (mapcar 'cadr pts)) 4.0)
            ux (angle '(0 0) (trans '(1 0 0) 1 0 T))                  ; UCS X in world
            a0 (angle (nth 0 pts) (nth 1 pts)) a1 (angle (nth 1 pts) (nth 2 pts))
            aw (if (> (abs (cos (- a0 ux))) (abs (cos (- a1 ux)))) a0 a1)
            c (cos aw) s (sin aw)
            l (tv-csz-loc (car pts) cx cy c s) ohx (abs (car l)) ohy (abs (cadr l))
            nhx (/ nw 2.0) nhy (/ nh 2.0)
            tol (max (* 0.03 (max ohx ohy)) (* 0.08 (tv-csz-ds))))     ; 8 at 1:100
      ;; the rectangle itself
      (foreach p pts
        (setq l (tv-csz-loc p cx cy c s)
              npts (cons (tv-csz-wld (if (> (car l) 0) nhx (- nhx)) (if (> (cadr l) 0) nhy (- nhy)) cx cy c s) npts)))
      (setq npts (reverse npts) k 0)
      (foreach x ed
        (if (= (car x) 10)
          (setq out (cons (cons 10 (nth k npts)) out) k (1+ k))
          (setq out (cons x out))))
      (entmod (reverse out))
      ;; neighbours: lines and polylines crossing a box around old and new outline
      (setq xs (mapcar 'car (append pts npts)) ys (mapcar 'cadr (append pts npts))
            m (max (* 5.0 (tv-csz-ds)) (min (* 30.0 (tv-csz-ds)) (* 1.2 (max nw nh)))))
      (setq ss (ssget "_CP"
                 (mapcar '(lambda (p) (trans p 0 1))
                   (list (list (- (apply 'min xs) m) (- (apply 'min ys) m))
                         (list (+ (apply 'max xs) m) (- (apply 'min ys) m))
                         (list (+ (apply 'max xs) m) (+ (apply 'max ys) m))
                         (list (- (apply 'min xs) m) (+ (apply 'max ys) m))))
                 (list '(0 . "LINE,LWPOLYLINE") '(-4 . "<NOT") (cons 8 *TV-CSZ-SKIP*) '(-4 . "NOT>"))))
      (setq k 0)
      (if ss
        (repeat (sslength ss)
          (setq adj (ssname ss k) k (1+ k))
          (if (not (eq adj en))
            (progn
              (setq aed (entget adj) typ (cdr (assoc 0 aed)) lay (cdr (assoc 8 aed)))
              (tv-csz-unlock lay)
              (cond
                ((= typ "LINE")
                 (setq p1 (cdr (assoc 10 aed)) p2 (cdr (assoc 11 aed)) q1 nil q2 nil)
                 (if (and (tv-csz-inside p1 cx cy c s nhx nhy tol) (tv-csz-inside p2 cx cy c s nhx nhy tol))
                   (entdel adj)
                   (progn
                     (if (or (tv-csz-inside p1 cx cy c s nhx nhy tol) (tv-csz-on-edge p1 pts)) (setq q1 (tv-csz-ray p2 p1 npts)))
                     (if (or (tv-csz-inside p2 cx cy c s nhx nhy tol) (tv-csz-on-edge p2 pts)) (setq q2 (tv-csz-ray p1 p2 npts)))
                     (if q1 (setq aed (subst (cons 10 (list (car q1) (cadr q1) (caddr p1))) (assoc 10 aed) aed)))
                     (if q2 (setq aed (subst (cons 11 (list (car q2) (cadr q2) (caddr p2))) (assoc 11 aed) aed)))
                     (if (or q1 q2) (vl-catch-all-apply 'entmod (list aed))))))
                ((= typ "LWPOLYLINE")
                 (setq mod nil out nil)
                 (foreach x aed
                   (if (and (= (car x) 10) (setq nv (tv-csz-vtx (cdr x) cx cy c s ohx ohy nhx nhy tol)))
                     (setq out (cons (cons 10 nv) out) mod T)
                     (setq out (cons x out))))
                 (if mod (vl-catch-all-apply 'entmod (list (reverse out))))))))))
      T)))

(defun c:CSZ (/ *error* old ce doc nw nh ss i en k skip lk tot)
  (setq ce (getvar "CMDECHO") old *error* doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (defun *error* (msg)
    (tv-csz-relock)
    (setvar "CMDECHO" ce) (vla-EndUndoMark doc) (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))
  (setvar "CMDECHO" 0)
  (setq nw (getdist (strcat "\n°¡·Î <" (rtos *TV-CSZ-W* 2 0) ">: ")))
  (if (and nw (> nw 0))
    (progn
      (setq nh (getdist (strcat "\n¼¼·Î <" (rtos nw 2 0) ">: ")))
      (if (not (and nh (> nh 0))) (setq nh nw))
      (setq *TV-CSZ-W* nw *TV-CSZ-H* nh))
    (setq nw *TV-CSZ-W* nh *TV-CSZ-H*))
  (setq tot 0)
  (princ "\n±âµÕ ¼±Åà (¿£ÅÍ = ³¡): ")
  (while (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&") (70 . 1))))
    (vla-StartUndoMark doc)                                   ; one U per selection
    (setq i 0 k 0 skip 0 lk 0)
    (repeat (sslength ss)
      (setq en (ssname ss i) i (1+ i))
      (cond ((tv-csz-locked (cdr (assoc 8 (entget en)))) (setq lk (1+ lk)))
            ((tv-csz-set en nw nh) (setq k (1+ k)))
            (T (setq skip (1+ skip)))))
    (tv-csz-relock)
    (vla-EndUndoMark doc)
    (setq tot (+ tot k))
    (if (> lk 0) (princ (strcat "\nLocked layer, skipped " (itoa lk))))
    (if (> skip 0) (princ (strcat "\nArc segments, skipped " (itoa skip))))
    (princ (strcat "\n" (itoa k) " set to " (rtos nw 2 0) "x" (rtos nh 2 0) ". ±âµÕ ¼±Åà (¿£ÅÍ = ³¡): ")))
  (princ (strcat "\nDone: " (itoa tot) " set to " (rtos nw 2 0) "x" (rtos nh 2 0)))
  (setvar "CMDECHO" ce) (setq *error* old)
  (princ))

(princ "\nTORVA Column Size: CSZ | 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 ----