;;; TORVA LISP - Wall Girder (torva.kr/lisp.html)
;;; WGD : start point, then draw the wall line as a polyline (normal PLINE prompts), Enter,
;;;       then click the side the girder goes -> girder band of the set width along the line.
;;;       Open line -> one closed polyline band. Closed line (C or last point on the first) -> two loops (outer + inner)
;;; Type a number at the start prompt to change the width (default 400, 0.4 in m drawings, kept until the drawing closes)
;;; Width is in drawing units. Repeats until Enter. Arcs in an open line become straight edges in the band
;;; Layer WALL-GIRDER (color 3, HIDDEN linetype), created if missing. U undoes one whole WGD run

(vl-load-com)

;; number for prompts: 2 decimals below 10 (m drawings), else whole
(defun tv-wgd-n (v) (rtos v 2 (if (< (abs v) 10) 2 0)))

(defun tv-wgd-verts (e / r)
  (foreach x (entget e) (if (= (car x) 10) (setq r (cons (cdr x) r))))
  (reverse r))

;; layer WALL-GIRDER (green, HIDDEN if it can be loaded) made current
(defun tv-wgd-layer (/ lin lt)
  (setq lt "Continuous")
  (cond
    ((tblsearch "LTYPE" "HIDDEN") (setq lt "HIDDEN"))
    ((and (setq lin (if (= (getvar "MEASUREMENT") 1)
                      (cond ((findfile "acadiso.lin")) ((findfile "acad.lin")))
                      (cond ((findfile "acad.lin")) ((findfile "acadiso.lin")))))
          (not (vl-catch-all-error-p
                 (vl-catch-all-apply 'vla-Load
                   (list (vla-get-Linetypes (vla-get-ActiveDocument (vlax-get-acad-object))) "HIDDEN" lin))))
          (tblsearch "LTYPE" "HIDDEN"))
     (setq lt "HIDDEN")))
  (if (null (tblsearch "LAYER" "WALL-GIRDER"))
    (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
                   '(2 . "WALL-GIRDER") '(70 . 0) '(62 . 3) (cons 6 lt))))
  (command "_.-LAYER" "_T" "WALL-GIRDER" "_ON" "WALL-GIRDER" "_U" "WALL-GIRDER" "_S" "WALL-GIRDER" ""))

;; one girder from start point p1. T when made
(defun tv-wgd-one (p1 / e0 e1 e2 obj c pd ed)
  (setq e0 (entlast))
  (setvar "CMDECHO" 1)
  (command "_.PLINE" "_non" p1)
  (while (= (logand (getvar "CMDACTIVE") 1) 1) (command pause))
  (setvar "CMDECHO" 0)
  (setq e1 (entlast))
  (cond
    ((equal e1 e0) nil)
    ((/= (cdr (assoc 0 (entget e1))) "LWPOLYLINE")
     (entdel e1) (princ "\nSet PLINETYPE to 2 (lightweight polyline)") nil)
    ((null (setq pd (getpoint "\n¿ù°Å´õ ¹æÇâ Ŭ¸¯: "))) (entdel e1) nil)
    (T
     (setq obj (vlax-ename->vla-object e1))
     ;; last point clicked on the first point -> close it
     (if (and (= (vla-get-Closed obj) :vlax-false)
              (equal (vlax-curve-getStartPoint e1) (vlax-curve-getEndPoint e1) (* *TV-WGD-W* 0.01)))
       (progn
         (setq c (vlax-get obj 'Coordinates))
         (if (> (length c) 6) (vlax-put obj 'Coordinates (reverse (cddr (reverse c)))))
         (vla-put-Closed obj :vlax-true)))
     (setq e0 (entlast))
     (command "_.OFFSET" *TV-WGD-W* e1 "_non" pd "")
     (setq e2 (entlast))
     (cond
       ((equal e2 e0) (entdel e1) (princ "\nCannot offset this line by the width") nil)
       ((= (vla-get-Closed obj) :vlax-true) T)
       (T
        (setq ed (entget e1))
        (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(8 . "WALL-GIRDER") '(100 . "AcDbPolyline")
                                (cons 90 (+ (length (tv-wgd-verts e1)) (length (tv-wgd-verts e2)))) '(70 . 1)
                                (assoc 38 ed))
                          (mapcar '(lambda (p) (cons 10 p)) (append (tv-wgd-verts e1) (reverse (tv-wgd-verts e2))))
                          (list (assoc 210 ed))))
        (entdel e1) (entdel e2)
        T)))))

(defun c:WGD (/ *error* old doc lay ce oe in v n loop)
  (setq old *error* doc (vla-get-ActiveDocument (vlax-get-acad-object)) n 0
        lay (getvar "CLAYER") ce (getvar "CMDECHO") oe (getvar "OFFSETERASE"))
  (defun *error* (msg)
    (while (> (getvar "CMDACTIVE") 0) (command))
    (setvar "CLAYER" lay) (if oe (setvar "OFFSETERASE" oe)) (setvar "CMDECHO" ce)
    (vla-EndUndoMark doc) (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))
  (vla-StartUndoMark doc)
  (setvar "CMDECHO" 0)
  (if oe (setvar "OFFSETERASE" 0))
  (if (null *TV-WGD-W*) (setq *TV-WGD-W* (if (= (getvar "INSUNITS") 6) 0.4 400.0)))
  (tv-wgd-layer)
  (setq loop T)
  (while loop
    (initget 128)
    (setq in (getpoint (strcat "\n¿ù°Å´õ ½ÃÀÛÁ¡ ¶Ç´Â Æø <" (tv-wgd-n *TV-WGD-W*) ">: ")))
    (cond
      ((null in) (setq loop nil))
      ((= (type in) 'STR)
       (if (and (setq v (distof in)) (> v 0))
         (setq *TV-WGD-W* v)
         (princ "\nWidth must be a positive number")))
      ((tv-wgd-one in)
       (setq n (1+ n))
       (princ (strcat "\nWall girder " (tv-wgd-n *TV-WGD-W*))))))
  (princ (strcat "\nDone: " (itoa n) " wall girders"))
  (setvar "CLAYER" lay) (if oe (setvar "OFFSETERASE" oe)) (setvar "CMDECHO" ce)
  (vla-EndUndoMark doc) (setq *error* old)
  (princ))

(princ "\nTORVA Wall Girder: WGD | 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 ----