;;; TORVA LISP - Circle to Polygon (torva.kr/lisp.html)
;;; CPG : selected circles -> closed LWPOLYLINE with straight segments, circle deleted
;;;       (layer, color, linetype, lineweight kept). Pre-selected circles are used as is
;;; Vertex count per circle = pi / acos(1 - tol / r), clamped to min~max
;;; S before selection: chord tolerance (default 0.05 x DIMSCALE = 5 at 1:100), min / max vertices (8 / 24),
;;;   equal area (Y = polygon area equals circle area, N = inscribed). Values persist until the drawing closes
;;; Circles on locked layers are skipped

(vl-load-com)

(if (null *TV-CPG-MIN*) (setq *TV-CPG-MIN* 8))
(if (null *TV-CPG-MAX*) (setq *TV-CPG-MAX* 24))
(if (null *TV-CPG-EQ*) (setq *TV-CPG-EQ* T))

;; chord tolerance: user value, else 0.05 x DIMSCALE
(defun tv-cpg-tol ()
  (cond (*TV-CPG-TOL*)
        ((> (getvar "DIMSCALE") 0) (* 0.05 (getvar "DIMSCALE")))
        (0.05)))

(defun tv-cpg-now ()
  (strcat "¿ÀÂ÷ " (rtos (tv-cpg-tol) 2 2) ", ²ÀÁþÁ¡ " (itoa *TV-CPG-MIN*) "~" (itoa *TV-CPG-MAX*)
          ", µî¸éÀû " (if *TV-CPG-EQ* "Y" "N")))

;; vertex count for radius r (AutoLISP has no acos -> atan form)
(defun tv-cpg-nseg (r / d a n)
  (if (> r 1e-8)
    (progn
      (setq d (- 1.0 (/ (tv-cpg-tol) r)))
      (cond ((<= d -1.0) (setq n *TV-CPG-MIN*))
            ((<= (setq a (atan (sqrt (- 1.0 (* d d))) d)) 1e-9) (setq n *TV-CPG-MAX*))
            (T (setq n (fix (+ 0.9999 (/ pi a))))))
      (max *TV-CPG-MIN* (min *TV-CPG-MAX* n)))))

(defun tv-cpg-setting (/ v)
  (initget 6)
  (if (setq v (getdist (strcat "\nÇö ÃÖ´ë ¿ÀÂ÷ <" (rtos (tv-cpg-tol) 2 2) ">: "))) (setq *TV-CPG-TOL* v))
  (initget 6)
  (if (and (setq v (getint (strcat "\nÃÖ¼Ò ²ÀÁþÁ¡ ¼ö <" (itoa *TV-CPG-MIN*) ">: "))) (>= v 3)) (setq *TV-CPG-MIN* v))
  (initget 6)
  (if (setq v (getint (strcat "\nÃÖ´ë ²ÀÁþÁ¡ ¼ö <" (itoa *TV-CPG-MAX*) ">: "))) (setq *TV-CPG-MAX* v))
  (if (< *TV-CPG-MAX* *TV-CPG-MIN*) (setq *TV-CPG-MAX* *TV-CPG-MIN*))
  (initget "Y N")
  (setq v (getkword (strcat "\nµî¸éÀû º¸Á¤ [¿¹(Y)/¾Æ´Ï¿À(N)] <" (if *TV-CPG-EQ* "Y" "N") ">: ")))
  (cond ((= v "Y") (setq *TV-CPG-EQ* T)) ((= v "N") (setq *TV-CPG-EQ* nil))))

;; one circle -> closed polyline, circle deleted. Returns vertex count, nil = not made
;; no trans: center (10) and normal (210) are the circle's own OCS, the polyline uses the same OCS
(defun tv-cpg-make (e / d cen r n rp i pts)
  (setq d (entget e) cen (cdr (assoc 10 d)) r (cdr (assoc 40 d)))
  (if (setq n (tv-cpg-nseg r))
    (progn
      ;; equal area: grow the circumradius so polygon area = circle area
      (setq rp (if *TV-CPG-EQ* (* r (sqrt (/ (/ (* 2.0 pi) n) (sin (/ (* 2.0 pi) n))))) r) i 0)
      (repeat n
        (setq pts (cons (list 10 (+ (car cen) (* rp (cos (/ (* 2.0 pi i) n))))
                                 (+ (cadr cen) (* rp (sin (/ (* 2.0 pi i) n))))) pts)
              i (1+ i)))
      (if (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (assoc 8 d))
                           (vl-remove nil (list (assoc 6 d) (assoc 62 d) (assoc 370 d) (assoc 420 d)))
                           (list '(100 . "AcDbPolyline") (cons 90 n) '(70 . 1) (cons 38 (caddr cen)))
                           (reverse pts)
                           (list (cond ((assoc 210 d)) ('(210 0.0 0.0 1.0))))))
        (progn (entdel e) n)))))

(defun tv-cpg-locked (e)
  (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (cdr (assoc 8 (entget e)))))))))

(defun c:CPG (/ *error* old doc ss k i e v n sum skip)
  (setq old *error* doc (vla-get-ActiveDocument (vlax-get-acad-object)) n 0 sum 0 skip 0)
  (defun *error* (msg)
    (vla-EndUndoMark doc)
    (setq *error* old)
    (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\nError: " msg)))
    (princ))
  (setq ss (ssget "_I" '((0 . "CIRCLE"))))
  (sssetfirst nil nil)
  (if (null ss)
    (progn
      (setq k "S")
      (while k
        (initget "S")
        (if (setq k (getkword (strcat "\n¿ø ¼±Åà [¼³Á¤(S)] <" (tv-cpg-now) ">: "))) (tv-cpg-setting)))
      (princ "\n¿ø ¼±ÅÃ: ")
      (setq ss (ssget '((0 . "CIRCLE"))))))
  (if ss
    (progn
      (vla-StartUndoMark doc)
      (setq i 0)
      (repeat (sslength ss)
        (setq e (ssname ss i) i (1+ i))
        (cond ((tv-cpg-locked e) (setq skip (1+ skip)))
              ((setq v (tv-cpg-make e)) (setq n (1+ n) sum (+ sum v)))))
      (vla-EndUndoMark doc)
      (princ (strcat "\n" (itoa n) " circle(s) -> polygon, " (itoa sum) " vertices"
                     (if (> n 0) (strcat " (avg " (itoa (/ sum n)) ")") "")
                     (if (> skip 0) (strcat ", locked layer, skipped " (itoa skip)) "")))))
  (setq *error* old)
  (princ)
)

(princ "\nTORVA Circle to Polygon: CPG | 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 ----