;;; TORVA LISP - Pipe Section (torva.kr/lisp.html)
;;; SQP : square/rectangular pipe section - type a size (150x150x6), pick centers, set the angle.
;;;       Outer + inner polyline and two diagonals (layer OPEN) per section, grouped
;;; CHP : circular pipe section - type a size (165.2x5), pick centers. Outer + inner circle, grouped
;;; Size: H x B x t (square, H runs along Y before rotation) / D x t (circular). ? lists sizes.
;;;   H x B or D alone shows the thicknesses for that size. Sizes not in the list are drawn as typed
;;; Built-in lists: KS D 3568 square pipes (30) / KS D 3566 circular pipes (29 diameters)
;;; Your own sizes: tv_pipe.txt on the support path, one per line "H B t" or "D t" (; = comment).
;;;   Those rows come before the built-in lists
;;; Layer OPEN is created if missing (color 1). Sections go on the current layer. Enter ends placing
;;; Drawing unit: mm

(vl-load-com)

(defun tv-ps-fmt (v) (if (equal v (fix v) 1e-9) (itoa (fix v)) (rtos v 2 1)))

;; (150 150 6) -> "150x150x6"
(defun tv-ps-name (v / s)
  (setq s (tv-ps-fmt (car v)))
  (foreach x (cdr v) (setq s (strcat s "x" (tv-ps-fmt x))))
  s
)

(defun tv-ps-row (v) (cons (tv-ps-name v) (mapcar 'float v)))

;; "150x150x6" -> (150.0 150.0 6.0); nil if any part is not a positive number
(defun tv-ps-nums (s / out tok c i v ok)
  (setq s (strcat s "x") tok "" ok T i 1)
  (while (<= i (strlen s))
    (setq c (substr s i 1))
    (if (= c "x")
      (progn
        (if (/= tok "")
          (if (and (setq v (distof tok 2)) (> v 0)) (setq out (cons v out)) (setq ok nil)))
        (setq tok ""))
      (setq tok (strcat tok c)))
    (setq i (1+ i)))
  (if ok (reverse out))
)

;; wall must fit: 2t < smallest of the other sizes
(defun tv-ps-ok (v) (< (* 2.0 (last v)) (apply 'min (reverse (cdr (reverse v))))))

;; built-in list: KS D 3568 square/rectangular pipes, H B t
(setq *TV-PS-SQ* (mapcar 'tv-ps-row '(
  (30 30 2.3) (40 40 2.3) (50 30 2.3) (50 50 2.3) (50 50 3.2) (60 30 2.3)
  (75 45 2.3) (75 45 3.2) (75 75 2.3) (75 75 3.2) (100 50 3.2) (100 100 3.2)
  (100 100 4.5) (100 100 6.0) (125 75 3.2) (125 125 4.5) (125 125 6.0) (150 100 4.5)
  (150 100 6.0) (150 150 4.5) (150 150 6.0) (200 100 4.5) (200 100 6.0) (200 150 6.0)
  (200 200 4.5) (200 200 6.0) (200 200 9.0) (200 200 12.0) (200 250 6.0) (200 250 12.0)
)))

;; built-in list: KS D 3566 circular pipes, D (t ...)
(setq *TV-PS-CH* (apply 'append (mapcar
  '(lambda (d ts) (mapcar '(lambda (x) (tv-ps-row (list d x))) ts))
  '(21.7 27.2 34.0 42.7 48.6 60.5 76.3 89.1 101.6 114.3
    139.8 165.2 190.7 216.3 267.4 318.5 355.6 406.4 457.2 500.0
    508.0 558.8 600.0 609.6 700.0 711.2 812.8 914.4 1016.0)
  '((2.0) (2.0 2.3) (2.3) (2.3 2.8)
    (2.3 2.8 3.2) (2.3 3.2 4.0) (2.8 3.2 4.0) (2.8 3.2 4.0)
    (3.2 4.0 5.0) (3.2 3.6 4.5 5.6) (3.6 4.0 4.5 6.0) (4.5 5.0 6.0 7.0)
    (4.5 5.0 6.0 7.0) (4.5 6.0 7.0 8.0) (6.0 7.0 8.0 9.0) (6.0 8.0 9.0)
    (6.3 8.0 9.0 12.0) (9.0 12.0 16.0 19.0) (9.0 12.0 16.0 19.0) (9.0 12.0 14.0)
    (9.0 12.0 14.0 16.0 19.0 22.0) (12.0 16.0 19.0 22.0) (9.0 12.0 16.0 19.0)
    (9.0 12.0 14.0 16.0 19.0)
    (9.0 12.0 14.0 16.0) (9.0 12.0 14.0 16.0 19.0 22.0) (9.0 12.0 16.0 19.0 22.0)
    (12.0 14.0 16.0 19.0 22.0) (12.0 14.0 16.0 19.0 22.0)))))

(if (null *TV-PS-SQ-LAST*) (setq *TV-PS-SQ-LAST* "150x150x6"))
(if (null *TV-PS-CH-LAST*) (setq *TV-PS-CH-LAST* "165.2x5"))
(if (null *TV-PS-ANG*) (setq *TV-PS-ANG* 0.0))

;; tv_pipe.txt -> 3 numbers = square, 2 numbers = circular; put ahead of the built-in lists
(defun tv-ps-load (/ f fh ln v sq ch)
  (if (setq f (findfile "tv_pipe.txt"))
    (progn
      (setq fh (open f "r"))
      (while (setq ln (read-line fh))
        (setq ln (vl-string-trim " \t" ln))
        (if (and (/= ln "") (/= (substr ln 1 1) ";")
                 (setq v (tv-ps-nums (vl-string-translate " \t,*X" "xxxxx" ln)))
                 (<= 2 (length v) 3) (tv-ps-ok v))
          (if (= (length v) 3) (setq sq (cons (tv-ps-row v) sq)) (setq ch (cons (tv-ps-row v) ch)))))
      (close fh)
      (setq *TV-PS-SQ* (append (reverse sq) *TV-PS-SQ*)
            *TV-PS-CH* (append (reverse ch) *TV-PS-CH*))
      (princ (strcat "\n" (itoa (+ (length sq) (length ch))) " sizes from " f))))
)
(tv-ps-load)

;; rows grouped by size without the wall: "  150x150    x 4.5 / 6"
(defun tv-ps-list (tbl / key cur line)
  (foreach row tbl
    (setq key (tv-ps-name (reverse (cdr (reverse (cdr row))))))
    (if (= key cur)
      (setq line (strcat line " / " (tv-ps-fmt (last row))))
      (progn
        (if line (princ line))
        (setq cur key line (strcat "\n  " (substr (strcat key "            ") 1 12) "x " (tv-ps-fmt (last row)))))))
  (if line (princ line))
)

;; typed size -> row, T when only the thickness list was shown, nil when no such size
(defun tv-ps-find (s tbl n / v name hit c)
  (setq s (vl-string-translate "*X, " "xxxx" (strcase (vl-string-trim " \t" s) T)))
  (while (and (> (strlen s) 0) (not (wcmatch (substr s 1 1) "#"))) (setq s (substr s 2)))
  (if (setq v (tv-ps-nums s))
    (progn
      (setq name (tv-ps-name v))
      (cond
        ((setq hit (assoc name tbl)) hit)
        ((and (= (length v) n) (tv-ps-ok v)) (tv-ps-row v))
        ((= (length v) (1- n))
         (foreach row tbl (if (wcmatch (car row) (strcat name "x*")) (setq c (cons row c))))
         (cond ((= (length c) 1) (car c))
               (c (tv-ps-list (reverse c)) T)))))
  )
)

;; size prompt; ? prints the list, Enter = last size
(defun tv-ps-ask (msg tbl n sym / s row)
  (while (null row)
    (setq s (getstring (strcat msg " [¸ñ·Ï(?)] <" (eval sym) ">: ")))
    (cond ((= s "") (setq s (eval sym))) ((= s "?") (tv-ps-list tbl) (setq s nil)))
    (if s
      (cond
        ((= (setq row (tv-ps-find s tbl n)) T) (setq row nil))
        ((null row) (princ (strcat "\nNo size " s ". Type ? for the list"))))))
  (set sym (car row))
  row
)

(defun tv-ps-layer ()
  (if (null (tblsearch "LAYER" "OPEN"))
    (entmake '((0 . "LAYER") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord")
               (2 . "OPEN") (70 . 0) (62 . 1) (6 . "Continuous"))))
)

;; UCS center c, angle a, local offset x y -> UCS point
(defun tv-ps-pt (c a x y)
  (list (+ (car c) (- (* x (cos a)) (* y (sin a))))
        (+ (cadr c) (* x (sin a)) (* y (cos a)))
        (caddr c))
)

;; closed rectangle w x h (half sizes) around c, in the UCS plane
(defun tv-ps-rect (c a w h z / ps)
  (setq ps (mapcar '(lambda (s) (trans (tv-ps-pt c a (* (car s) w) (* (cadr s) h)) 1 z))
                   '((-1 -1) (1 -1) (1 1) (-1 1))))
  (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
                         '(90 . 4) '(70 . 1) (cons 38 (caddr (car ps))) (cons 210 z))
                   (mapcar '(lambda (p) (list 10 (car p) (cadr p))) ps)))
  (entlast)
)

(defun tv-ps-diag (c a w h)
  (entmake (list '(0 . "LINE") '(8 . "OPEN")
                 (cons 10 (trans (tv-ps-pt c a (- w) (- h)) 1 0))
                 (cons 11 (trans (tv-ps-pt c a w h) 1 0))))
  (entlast)
)

;; square pipe at c, angle a -> list of the 4 entities
(defun tv-ps-sq-make (c a row / z h b tt)
  (setq z (trans '(0 0 1) 1 0 T)
        h (/ (nth 1 row) 2.0) b (/ (nth 2 row) 2.0) tt (nth 3 row))
  (list (tv-ps-rect c a b h z)
        (tv-ps-rect c a (- b tt) (- h tt) z)
        (tv-ps-diag c a (- b tt) (- h tt))
        (tv-ps-diag c a (- tt b) (- h tt)))
)

(defun tv-ps-circle (c r z)
  (entmake (list '(0 . "CIRCLE") (cons 10 (trans c 1 z)) (cons 40 r) (cons 210 z)))
  (entlast)
)

;; unnamed group so a click picks the whole section; skipped quietly where groups fail
(defun tv-ps-group (es / objs arr g)
  (setq objs (mapcar 'vlax-ename->vla-object es)
        g (vl-catch-all-apply 'vla-Add
            (list (vla-get-Groups (vla-get-ActiveDocument (vlax-get-acad-object))) "*")))
  (if (not (vl-catch-all-error-p g))
    (progn
      (setq arr (vlax-make-safearray vlax-vbObject (cons 0 (1- (length objs)))))
      (vlax-safearray-fill arr objs)
      (vl-catch-all-apply 'vla-AppendItems (list g arr))))
)

(defun tv-ps-done (ce old)
  (setvar "CMDECHO" ce)
  (setq *error* old)
  (princ)
)

(defun c:SQP (/ *error* old ce row pt es a n)
  (setq ce (getvar "CMDECHO") old *error* n 0)
  (defun *error* (msg)
    (command "_.UNDO" "_E")
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (tv-ps-done ce old))
  (setvar "CMDECHO" 0)
  (if (setq row (tv-ps-ask "\n°¢ÆÄÀÌÇÁ ±Ô°Ý H¡¿B¡¿t" *TV-PS-SQ* 3 '*TV-PS-SQ-LAST*))
    (progn
      (command "_.UNDO" "_BE")
      (tv-ps-layer)
      (while (setq pt (getpoint "\nÁß½ÉÁ¡: "))
        (setq es (tv-ps-sq-make pt *TV-PS-ANG* row)
              a (getangle pt (strcat "\nȸÀü °¢µµ <" (angtos *TV-PS-ANG*) ">: ")))
        (if (and a (not (equal a *TV-PS-ANG* 1e-9)))
          (progn (mapcar 'entdel es) (setq *TV-PS-ANG* a es (tv-ps-sq-make pt a row))))
        (tv-ps-group es)
        (setq n (1+ n)))
      (command "_.UNDO" "_E")
      (princ (strcat "\n" (itoa n) " square pipes placed: " (car row)))))
  (tv-ps-done ce old)
)

(defun c:CHP (/ *error* old ce row pt z n)
  (setq ce (getvar "CMDECHO") old *error* n 0)
  (defun *error* (msg)
    (command "_.UNDO" "_E")
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (tv-ps-done ce old))
  (setvar "CMDECHO" 0)
  (if (setq row (tv-ps-ask "\n¿øÇü°­°ü ±Ô°Ý D¡¿t" *TV-PS-CH* 2 '*TV-PS-CH-LAST*))
    (progn
      (command "_.UNDO" "_BE")
      (setq z (trans '(0 0 1) 1 0 T))
      (while (setq pt (getpoint "\nÁß½ÉÁ¡: "))
        (tv-ps-group (list (tv-ps-circle pt (/ (nth 1 row) 2.0) z)
                           (tv-ps-circle pt (- (/ (nth 1 row) 2.0) (nth 2 row)) z)))
        (setq n (1+ n)))
      (command "_.UNDO" "_E")
      (princ (strcat "\n" (itoa n) " circular pipes placed: D" (car row)))))
  (tv-ps-done ce old)
)

(princ "\nTORVA Pipe Section: SQP CHP | 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 ----