;;; TORVA LISP - Purlin Direction Mark (torva.kr/lisp.html)
;;; PRD : insertion point -> quarter-circle mark with purlin lines at the purlin spacing (block on layer PURLIN)
;;;       drag to set the purlin direction -> leader start (Nearest snap) -> bend point (Enter = straight) -> text point
;;;       -> dot leader on layer LEADER + text "<size>@<spacing>" on layer PURLIN-TEXT
;;; Options at the insertion point: N purlin size (default LC-120x60x20x3.2), D spacing (default 800, drawing units),
;;;       R mark radius (default 35 x DIMSCALE = 3500 at 1:100)
;;; Text height 3.5 x DIMSCALE, dot and text gap 1.5 x DIMSCALE. Current text style
;;; Values are kept until the drawing closes. Layers are created if missing. Works in any UCS. U undoes one run

(vl-load-com)

(if (null *TV-PRD-SPEC*) (setq *TV-PRD-SPEC* "LC-120x60x20x3.2"))
(if (null *TV-PRD-SPC*) (setq *TV-PRD-SPC* 800.0))

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

;; mark radius: user value, else 35 x DIMSCALE
(defun tv-prd-r () (cond (*TV-PRD-R*) ((* 35.0 (tv-prd-ds)))))

;; number without trailing zeros: 800.0 -> "800", 0.75 -> "0.75"
(defun tv-prd-num (v / s)
  (setq s (rtos v 2 3))
  (if (vl-string-search "." s)
    (setq s (vl-string-right-trim "." (vl-string-right-trim "0" s))))
  s)

(defun tv-prd-label () (strcat *TV-PRD-SPEC* "@" (tv-prd-num *TV-PRD-SPC*)))

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

;; block per radius and spacing, reused when it exists. Frame on layer 0 (takes the insert layer), purlin lines color 4
(defun tv-prd-block (r spc / name x)
  (setq name (strcat "TV-PURLIN-" (tv-prd-num r) "-" (tv-prd-num spc)))
  (if (null (tblsearch "BLOCK" name))
    (progn
      (entmake (list '(0 . "BLOCK") (cons 2 name) '(70 . 0) '(10 0.0 0.0 0.0)))
      (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(8 . "0") '(100 . "AcDbPolyline") '(90 . 3) '(70 . 1)
                     '(10 0.0 0.0) (list 10 r 0.0) (cons 42 (/ (sin (/ pi 8.0)) (cos (/ pi 8.0)))) (list 10 0.0 r)))
      (setq x spc)
      (while (< x r)
        (entmake (list '(0 . "LINE") '(8 . "0") '(62 . 4) (list 10 x 0.0 0.0) (list 11 x (sqrt (- (* r r) (* x x))) 0.0)))
        (setq x (+ x spc)))
      (entmake '((0 . "ENDBLK")))))
  name)

;; insertion point; N / D / R change settings, Enter = nil
(defun tv-prd-start (/ p v)
  (setq p "N")
  (while (= (type p) 'STR)
    (initget "N D R")
    (setq p (getpoint (strcat "\n»ðÀÔ À§Ä¡ [±Ô°Ý(N)/°£°Ý(D)/Å©±â(R)] <" (tv-prd-label) ", R" (tv-prd-num (tv-prd-r)) ">: ")))
    (cond
      ((= p "N")
       (setq v (getstring T (strcat "\nÆÛ¸° ±Ô°Ý <" *TV-PRD-SPEC* ">: ")))
       (if (/= v "") (setq *TV-PRD-SPEC* v)))
      ((= p "D")
       (initget 6)
       (if (setq v (getdist (strcat "\nÆÛ¸° °£°Ý <" (tv-prd-num *TV-PRD-SPC*) ">: "))) (setq *TV-PRD-SPC* v)))
      ((= p "R")
       (initget 6)
       (if (setq v (getdist (strcat "\n±âÈ£ Å©±â <" (tv-prd-num (tv-prd-r)) ">: "))) (setq *TV-PRD-R* v)))))
  p)

(defun c:PRD (/ *error* old ce os pt r blk ds lp1 lp2 lp3 nrm ua z left tp e)
  (setq ce (getvar "CMDECHO") os (getvar "OSMODE") old *error*)
  (defun *error* (msg)
    (command "_.UNDO" "_E")
    (setvar "OSMODE" os)
    (setvar "CMDECHO" ce)
    (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))
  (setvar "CMDECHO" 0)
  (command "_.UNDO" "_BE")
  (setq pt (tv-prd-start) r (tv-prd-r) ds (tv-prd-ds))
  (cond
    ((null pt))
    ((> (/ r *TV-PRD-SPC*) 200) (princ "\nSpacing too small for the mark size"))
    (t
     (tv-prd-layer "PURLIN" 7)
     (tv-prd-layer "LEADER" 7)
     (tv-prd-layer "PURLIN-TEXT" 7)
     (setq blk (tv-prd-block r *TV-PRD-SPC*))
     (setvar "OSMODE" 0)
     (princ "\nÆÛ¸° ¹æÇâ: ")
     (command "_.-INSERT" blk pt "1" "1" pause)
     (setq e (entget (entlast)))
     (entmod (subst '(8 . "PURLIN") (assoc 8 e) e))
     ;; leader
     (setvar "OSMODE" 512)
     (setq lp1 (getpoint "\nÁö½Ã¼± ½ÃÀÛÁ¡: "))
     (setvar "OSMODE" os)
     (if lp1
       (progn
         (initget 128)
         (setq lp2 (getpoint lp1 "\n²ªÀÓÁ¡ <Á÷¼±>: "))
         (if (not (listp lp2)) (setq lp2 nil))
         (setq lp3 (getpoint (cond (lp2) (lp1)) "\n±ÛÀÚ À§Ä¡: "))
         (if lp3
           (progn
             ;; points are UCS; entities take OCS of the UCS normal
             (setq nrm (trans '(0.0 0.0 1.0) 1 0 T)
                   ua (angle '(0.0 0.0 0.0) (trans '(1.0 0.0 0.0) 1 nrm T))
                   z (caddr (trans lp1 1 nrm))
                   left (< (car lp3) (car (cond (lp2) (lp1)))))
             (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(8 . "LEADER") '(100 . "AcDbPolyline")
                                    (cons 90 (if lp2 3 2)) '(70 . 0) (cons 38 z))
                              (mapcar '(lambda (q) (setq q (trans q 1 nrm)) (list 10 (car q) (cadr q)))
                                      (if lp2 (list lp1 lp2 lp3) (list lp1 lp3)))
                              (list (cons 210 nrm))))
             ;; dot = closed 2-vertex polyline with bulge 1 and full width
             (setq tp (trans lp1 1 nrm))
             (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(8 . "LEADER") '(100 . "AcDbPolyline")
                            '(90 . 2) '(70 . 1) (cons 43 (* 0.75 ds)) (cons 38 z)
                            (list 10 (- (car tp) (* 0.375 ds)) (cadr tp)) '(42 . 1.0)
                            (list 10 (+ (car tp) (* 0.375 ds)) (cadr tp)) '(42 . 1.0)
                            (cons 210 nrm)))
             (setq tp (trans (list (+ (car lp3) (if left (* -1.5 ds) (* 1.5 ds))) (cadr lp3) (caddr lp3)) 1 nrm))
             (entmake (list '(0 . "TEXT") '(8 . "PURLIN-TEXT")
                            (cons 10 tp) (cons 11 tp) (cons 40 (* 3.5 ds)) (cons 1 (tv-prd-label))
                            (cons 50 ua) (cons 7 (getvar "TEXTSTYLE")) (cons 72 (if left 2 0)) '(73 . 2) (cons 210 nrm)))))))
     (princ (strcat "\nPurlin " (tv-prd-label) " R" (tv-prd-num r)))))
  (command "_.UNDO" "_E")
  (setvar "OSMODE" os)
  (setvar "CMDECHO" ce)
  (setq *error* old)
  (princ))

(princ "\nTORVA Purlin Direction Mark: PRD | 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 ----