;;; TORVA LISP - Footing Rebar Leader (torva.kr/lisp.html)
;;; FRL : footing type -> center point -> rebar lines, leaders and rebar text around the center
;;;   1 top = bottom   : X and Y bars, one leader D19@200(T&B)
;;;   2 top <> bottom  : X and Y bars, T and B leaders for each direction
;;;   3 circular       : bars clipped to a circle, one leader D19@200(T&B)
;;; Bottom bars and the circular outline use the HIDDEN linetype (loaded if missing, else continuous)
;;; Sizes follow DIMSCALE (text 3.5 x DIMSCALE = 350 at 1:100, bar length 60 x DIMSCALE). The type is remembered
;;; Layers REBAR (color 150) for bars, REBAR-TEXT (color 7) for leaders and text, created if missing. Text uses the current text style

(vl-load-com)

(if (null *TV-FRL-TYPE*) (setq *TV-FRL-TYPE* "1"))

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

(defun tv-frl-layer (name color)
  (if (null (tblsearch "LAYER" name))
    (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
                   (cons 2 name) '(70 . 0) (cons 62 color) '(6 . "Continuous")))))

;; bar line with width w between two UCS points
(defun tv-frl-bar (a b w) (command "_.PLINE" a "_W" w w b ""))

;; thin leader through UCS points
(defun tv-frl-lead (pts) (command "_.PLINE" (car pts) "_W" 0.0 0.0) (foreach p (cdr pts) (command p)) (command ""))

;; middle-left text in the current style; a fixed-height style skips the height prompt
(defun tv-frl-text (p h s / st)
  (setq st (tblsearch "STYLE" (getvar "TEXTSTYLE")))
  (if (and st (> (cdr (assoc 40 st)) 0.0))
    (command "_.TEXT" "_J" "_ML" p 0.0 s)
    (command "_.TEXT" "_J" "_ML" p h 0.0 s)))

(defun c:FRL (/ *error* old os la ce clt ccol pw doc lt k pc u cx cy L d w h g p0 p1 p2 px py n i dx)
  (setq os (getvar "OSMODE") la (getvar "CLAYER") ce (getvar "CMDECHO") clt (getvar "CELTYPE")
        ccol (getvar "CECOLOR") pw (getvar "PLINEWID") old *error*
        doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (defun *error* (msg)
    (setvar "OSMODE" os) (setvar "CLAYER" la) (setvar "CMDECHO" ce)
    (setvar "CELTYPE" clt) (setvar "CECOLOR" ccol) (setvar "PLINEWID" pw)
    (vla-EndUndoMark doc)
    (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))
  (setvar "CMDECHO" 0)
  (vla-StartUndoMark doc)

  (initget "1 2 3")
  (if (setq k (getkword (strcat "\n±âÃÊ Çü½Ä [1 »óÇϺΠ°°À½ / 2 »óÇϺΠ´Ù¸§ / 3 ¿øÇü] <" *TV-FRL-TYPE* ">: ")))
    (setq *TV-FRL-TYPE* k))

  (if (setq pc (getpoint "\n±âÃÊ Áß½É: "))
    (progn
      (tv-frl-layer "REBAR" 150)
      (tv-frl-layer "REBAR-TEXT" 7)
      ;; HIDDEN from the linetype file; continuous if it cannot be loaded
      (if (not (tblsearch "LTYPE" "HIDDEN"))
        (vl-catch-all-apply 'vla-load (list (vla-get-Linetypes doc) "HIDDEN"
                                            (if (= (getvar "MEASUREMENT") 1) "acadiso.lin" "acad.lin"))))
      (setq lt (if (tblsearch "LTYPE" "HIDDEN") "HIDDEN" "BYLAYER"))
      ;; u = DIMSCALE: every size below is its 1:100 mm value / 100
      (setq u (tv-frl-ds) cx (car pc) cy (cadr pc)
            L (* 30.0 u) d (* 2.5 u) w (* 0.3 u) h (* 3.5 u) g (* 0.5 u))
      (setvar "OSMODE" 0)
      (setvar "CELTYPE" "BYLAYER")
      (setvar "CLAYER" "REBAR")
      (setvar "CECOLOR" "BYLAYER")
      (if (/= *TV-FRL-TYPE* "3")
        (progn
          ;; X bars top / bottom (bottom hidden), then Y bars
          (tv-frl-bar (list (- cx L) (+ cy d)) (list (+ cx L) (+ cy d)) w)
          (tv-frl-bar (list (- cx L) (- cy d)) (list (+ cx L) (- cy d)) w)
          (command "_.CHPROP" (entlast) "" "_LT" lt "")
          (tv-frl-bar (list (- cx d) (- cy L)) (list (- cx d) (+ cy L)) w)
          (tv-frl-bar (list (+ cx d) (- cy L)) (list (+ cx d) (+ cy L)) w)
          (command "_.CHPROP" (entlast) "" "_LT" lt ""))
        (progn
          ;; circular: 6 bars each way at 5 x DIMSCALE, clipped to radius 20 x DIMSCALE
          (setq n 0)
          (while (< n 6)
            (setq i (* (- n 2.5) 5.0 u) dx (sqrt (- (* 400.0 u u) (* i i))))
            (tv-frl-bar (list (- cx dx) (+ cy i)) (list (+ cx dx) (+ cy i)) w)
            (tv-frl-bar (list (+ cx i) (- cy dx)) (list (+ cx i) (+ cy dx)) w)
            (setq n (1+ n)))))
      (setvar "CLAYER" "REBAR-TEXT")
      (if (= *TV-FRL-TYPE* "3")
        (progn
          (command "_.CIRCLE" pc (* 20.0 u))
          (command "_.CHPROP" (entlast) "" "_LT" lt "")))
      (if (= *TV-FRL-TYPE* "2")
        (progn
          ;; X bars: dots on both bars, riser up, T shelf at 12 and B shelf at 6
          (setvar "CECOLOR" "6")
          (setq px (+ cx (* 8.0 u)))
          (command "_.CIRCLE" (list px (+ cy d)) (* 0.75 u))
          (command "_.CIRCLE" (list px (- cy d)) (* 0.75 u))
          (setq p1 (list (+ px (* 12.0 u)) (+ cy d (* 12.0 u))) p2 (list (+ px (* 12.0 u)) (+ cy d (* 6.0 u))))
          (tv-frl-lead (list (list px (- cy d)) (list px (+ cy d (* 12.0 u))) p1))
          (tv-frl-lead (list (list px (+ cy d (* 6.0 u))) p2))
          (setvar "CECOLOR" "BYLAYER")
          (tv-frl-text (polar p1 0.0 g) h "D19@200(T)")
          (tv-frl-text (polar p2 0.0 g) h "D19@200(B)")
          ;; Y bars: dots on both bars, run right, B step down
          (setvar "CECOLOR" "6")
          (setq py (- cy (* 8.0 u)))
          (command "_.CIRCLE" (list (- cx d) py) (* 0.75 u))
          (command "_.CIRCLE" (list (+ cx d) py) (* 0.75 u))
          (setq p1 (list (+ cx d (* 18.0 u)) py) p2 (list (+ cx d (* 18.0 u)) (- py (* 6.0 u))))
          (tv-frl-lead (list (list (- cx d) py) p1))
          (tv-frl-lead (list (list (+ cx d (* 6.0 u)) py) (list (+ cx d (* 6.0 u)) (- py (* 6.0 u))) p2))
          (setvar "CECOLOR" "BYLAYER")
          (tv-frl-text (polar p1 0.0 g) h "D19@200(T)")
          (tv-frl-text (polar p2 0.0 g) h "D19@200(B)"))
        (progn
          ;; ring at the center, 45 deg leader, shelf, one label
          (setvar "CECOLOR" "6")
          (command "_.CIRCLE" pc (* 4.5 u))
          (setq p0 (polar pc (/ pi 4.0) (* 4.5 u)) p1 (polar p0 (/ pi 4.0) (* 12.0 u)) p2 (polar p1 0.0 (* 15.0 u)))
          (tv-frl-lead (list p0 p1 p2))
          (setvar "CECOLOR" "BYLAYER")
          (tv-frl-text (polar p2 0.0 g) h "D19@200(T&B)")))
      (princ (strcat "\nFooting rebar drawn (type " *TV-FRL-TYPE* ", layers REBAR / REBAR-TEXT)"))))
  (setvar "OSMODE" os) (setvar "CLAYER" la) (setvar "CMDECHO" ce)
  (setvar "CELTYPE" clt) (setvar "CECOLOR" ccol) (setvar "PLINEWID" pw)
  (vla-EndUndoMark doc)
  (setq *error* old)
  (princ)
)

(princ "\nTORVA Footing Rebar Leader: FRL | 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 ----