;;; TORVA LISP - Section Mark (torva.kr/lisp.html)
;;; SMK : circle point -> cut end point -> view side -> section mark
;;;       (circle + letter, solid triangle, cut line, end flag) grouped on layer SECTION
;;; S (settings) before the first point: radius, next letter (A-Z, 1-9), sheet number under the letter
;;; Radius = 4.5 x DIMSCALE (450 at 1:100). Letter advances A -> B -> ... after each mark
;;; Text uses the current text style. Layer SECTION (color 3), created if missing

(vl-load-com)

(if (null *TV-SMK-CHAR*) (setq *TV-SMK-CHAR* 65))
(if (null *TV-SMK-REF*)  (setq *TV-SMK-REF* ""))
(setq *TV-SMK-TIP* 1.6)                 ; triangle tip distance / radius
(setq *TV-SMK-LAYER* "SECTION")

;; radius: user value, else 4.5 x DIMSCALE
(defun tv-smk-rad ()
  (cond (*TV-SMK-RAD*)
        ((> (getvar "DIMSCALE") 0) (* 4.5 (getvar "DIMSCALE")))
        (4.5)))

(defun c:SMK (/ *error* old os ce undo_on lay sty ss p1 p2 p3 ang_cut ang_view dist
                rad d g dl s0 a b ta segs blg txt_rot txt_str ref ent_bnd ent_h v s mkpl mktxt)
  (setq os (getvar "OSMODE") ce (getvar "CMDECHO") old *error*)
  (defun *error* (msg)
    (if undo_on (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)

  (setq lay *TV-SMK-LAYER* sty (getvar "TEXTSTYLE"))
  (if (null (tblsearch "LAYER" lay))
    (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
                   (cons 2 lay) '(70 . 0) '(62 . 3) '(6 . "Continuous"))))

  ;; polyline from UCS points, added to ss
  (setq mkpl
    (lambda (pts bls cls / dxf w)
      (setq dxf (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 8 lay)
                      '(100 . "AcDbPolyline") (cons 90 (length pts))
                      (cons 70 (if cls 1 0)) '(43 . 0.0)
                      (cons 38 (caddr (trans (car pts) 1 0)))))
      (mapcar '(lambda (p b)
                 (setq w   (trans p 1 0)
                       dxf (append dxf (list (cons 10 (list (car w) (cadr w))) (cons 42 b)))))
              pts bls)
      (entmake dxf)
      (ssadd (entlast) ss)
      (entlast)))
  ;; middle-centre text; width factor shrinks to fit wmax
  (setq mktxt
    (lambda (str pt h wmax / wf bx w wp)
      (setq wf (cdr (assoc 41 (tblsearch "STYLE" sty))))
      (if (and wmax (setq bx (textbox (list (cons 1 str) (cons 7 sty) (cons 40 h) (cons 41 wf)))))
        (progn
          (setq w (- (car (cadr bx)) (car (car bx))))
          (if (> w wmax) (setq wf (* wf (/ wmax w))))))
      (setq wp (trans pt 1 0))
      (entmake (list '(0 . "TEXT") (cons 8 lay) (cons 7 sty) (cons 10 wp) (cons 11 wp)
                     (cons 40 h) (cons 41 wf) (cons 50 txt_rot) (cons 1 str) '(72 . 1) '(73 . 2)))
      (ssadd (entlast) ss)))

  ;; first point; S = settings
  (while
    (progn
      (initget "S")
      (= "S" (setq p1 (getpoint (strcat "\n¿ø Á᫐ [¼³Á¤(S)] <" (chr *TV-SMK-CHAR*)
                                        (if (= *TV-SMK-REF* "") "" (strcat " / " *TV-SMK-REF*))
                                        ", R=" (rtos (tv-smk-rad) 2 0) ">: ")))))
    (initget 6)
    (if (setq v (getdist (strcat "\n¿ø ¹ÝÁö¸§ <" (rtos (tv-smk-rad) 2 0) ">: "))) (setq *TV-SMK-RAD* v))
    (setq s (strcase (getstring (strcat "\n´ÙÀ½ ¹®ÀÚ (A~Z, 1~9) <" (chr *TV-SMK-CHAR*) ">: "))))
    (if (and (= (strlen s) 1) (or (<= 65 (ascii s) 90) (<= 49 (ascii s) 57)))
      (setq *TV-SMK-CHAR* (ascii s)))
    (setq s (getstring T (strcat "\nµµ¸é¹øÈ£ (Áö¿ì±â .) <" (if (= *TV-SMK-REF* "") "¾øÀ½" *TV-SMK-REF*) ">: ")))
    (cond ((= s ".") (setq *TV-SMK-REF* ""))
          ((/= s "") (setq *TV-SMK-REF* s))))

  (if (and p1 (setq p2 (getpoint p1 "\nÀý´Ü¼± ³¡Á¡: ")))
    (progn
      (setvar "OSMODE" 0)
      (setq p3 (getpoint p1 "\nº¸´Â ¹æÇâ: "))
      (setq rad     (tv-smk-rad)
            d       (* rad (max *TV-SMK-TIP* 1.5))
            g       (* rad 0.3)
            dl      (* rad 0.5)
            ang_cut (angle p1 p2)
            dist    (distance p1 p2)
            txt_str (chr *TV-SMK-CHAR*)
            ref     *TV-SMK-REF*)
      (cond
        ((null p3) nil)
        ((<= dist (+ d rad)) (princ "\nCut line too short for the mark size"))
        (T
         (if (> (sin (- (angle p1 p3) ang_cut)) 0.0)
           (setq ang_view (+ ang_cut (/ pi 2.0)))
           (setq ang_view (- ang_cut (/ pi 2.0))))
         (setq blg (if (> (sin (- ang_view ang_cut)) 0.0) -1.0 1.0))
         ;; text follows the cut line, flipped when it would read upside down
         (setq ta ang_cut)
         (if (and (> ta (+ (* pi 0.5) 1e-6)) (<= ta (+ (* pi 1.5) 1e-6))) (setq ta (- ta pi)))
         (setq txt_rot (+ ta (angle '(0.0 0.0 0.0) (trans '(1.0 0.0 0.0) 1 0 T))))

         (command "_.UNDO" "_BE") (setq undo_on T)
         (setq ss (ssadd))

         ;; solid triangle minus the half circle on the view side
         (setq ent_bnd (mkpl (list (polar p1 (+ ang_cut pi) d)
                                   (polar p1 (+ ang_cut pi) rad)
                                   (polar p1 ang_cut rad)
                                   (polar p1 ang_cut d)
                                   (polar p1 ang_view d))
                             (list 0.0 blg 0.0 0.0 0.0) T))
         (command "_.-HATCH" "_P" "SOLID" "_S" ent_bnd "" "")
         (setq ent_h (entlast))
         (if (and (not (eq ent_h ent_bnd)) (= (cdr (assoc 0 (entget ent_h))) "HATCH"))
           (progn
             (entmod (subst (cons 8 lay) (assoc 8 (entget ent_h)) (entget ent_h)))
             (ssdel ent_bnd ss) (entdel ent_bnd) (ssadd ent_h ss))
           (princ "\nHatch failed - outline kept"))

         ;; circle + letter (+ sheet number below)
         (entmake (list '(0 . "CIRCLE") (cons 8 lay) (cons 10 (trans p1 1 0)) (cons 40 rad)))
         (ssadd (entlast) ss)
         (if (= ref "")
           (mktxt txt_str p1 (* rad 0.78) nil)
           (progn
             (mktxt txt_str (polar p1 ang_view (* rad 0.42)) (* rad 0.50) (* rad 1.2))
             (mktxt ref (polar p1 (+ ang_view pi) (* rad 0.45)) (* rad 0.34) (* rad 1.45))))

         ;; cut line: long lines get solid / dash dash / gap / dash dash / solid
         (setq s0 (if (= ref "") rad (- d))
               a  (max (* dist 0.10) (+ d (* rad 2.0)))
               b  (- dist (max (* dist 0.10) (* rad 2.0))))
         (if (and (> dist (* rad 10.0)) (> (- b a) (+ (* 4.0 (+ g dl)) rad)))
           (setq segs (list (list s0 a)
                            (list (+ a g) (+ a g dl))
                            (list (+ a g g dl) (+ a g g dl dl))
                            (list (- b g g dl dl) (- b g g dl))
                            (list (- b g dl) (- b g))
                            (list b dist)))
           (setq segs (list (list s0 dist))))
         (foreach seg segs
           (mkpl (list (polar p1 ang_cut (car seg)) (polar p1 ang_cut (cadr seg))) '(0.0 0.0) nil))

         ;; end flag (solid right triangle, R high x 0.33R)
         (entmake (list '(0 . "SOLID") (cons 8 lay)
                        (cons 10 (trans p2 1 0))
                        (cons 11 (trans (polar p2 ang_view rad) 1 0))
                        (cons 12 (trans (polar p2 (+ ang_cut pi) (* rad 0.33)) 1 0))
                        (cons 13 (trans (polar p2 (+ ang_cut pi) (* rad 0.33)) 1 0))))
         (ssadd (entlast) ss)

         (command "_.-GROUP" "_C" "*" "" ss "")
         (command "_.UNDO" "_E") (setq undo_on nil)

         ;; next letter (Z -> A, 9 -> 1)
         (setq *TV-SMK-CHAR* (1+ *TV-SMK-CHAR*))
         (cond ((= *TV-SMK-CHAR* 91) (setq *TV-SMK-CHAR* 65))
               ((= *TV-SMK-CHAR* 58) (setq *TV-SMK-CHAR* 49)))
         (princ (strcat "\nSection " txt_str (if (= ref "") "" (strcat " / " ref)) " placed"))))))

  (setvar "OSMODE" os) (setvar "CMDECHO" ce)
  (setq *error* old)
  (princ)
)

(princ "\nTORVA Section Mark: SMK | 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 ----