;;; TORVA LISP - Pile Centre Points (torva.kr/lisp.html)
;;; PCP : select pile cap blocks -> a POINT at every pile centre on layer PILE-CENTER (color 2, created if missing)
;;;       Pile = circle inside the block definition. Circles on PILE-PITCH or Defpoints (spacing check circles) are not piles
;;;       Circles sharing a centre (pile + centre hole) give one point. Insert point, rotation, scale and base point applied
;;; Point style is set so the points show: PDMODE 34 (circle + cross), PDSIZE = largest pile diameter found.
;;;   These two stay set on purpose - change them back with PTYPE if needed
;;; Works with the PFD (Pile Cap Layout) blocks. Nested blocks are not searched. U undoes one run

(vl-load-com)

;; pile circles of a block definition -> ((x y r) ...), one per centre, largest radius kept
(defun tv-pcp-piles (name / e d c r hit out)
  (setq e (tblobjname "BLOCK" name))
  (while (setq e (entnext e))
    (setq d (entget e))
    (if (and (= (cdr (assoc 0 d)) "CIRCLE")
             (not (member (strcase (cdr (assoc 8 d))) '("PILE-PITCH" "DEFPOINTS"))))
      (progn
        (setq c (cdr (assoc 10 d)) r (cdr (assoc 40 d)) hit nil)
        (foreach q out
          (if (equal (list (car q) (cadr q)) (list (car c) (cadr c)) 0.1) (setq hit q)))
        (cond ((null hit) (setq out (cons (list (car c) (cadr c) r) out)))
              ((> r (caddr hit)) (setq out (subst (list (car c) (cadr c) r) hit out)))))))
  out)

(defun c:PCP (/ *error* old ce ss i d bd base ip nrm a sx sy piles x y n nb skip size)
  (setq ce (getvar "CMDECHO") old *error*)
  (defun *error* (msg)
    (command "_.UNDO" "_E")
    (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")
  (princ "\nÆÄÀϱâÃÊ ºí·Ï ¼±ÅÃ: ")
  ;; points are added, the selected blocks are not changed -> blocks on locked layers are fine
  (if (setq ss (ssget '((0 . "INSERT"))))
    (progn
      (if (null (tblsearch "LAYER" "PILE-CENTER"))
        (entmake '((0 . "LAYER") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord")
                   (2 . "PILE-CENTER") (70 . 0) (62 . 2) (6 . "Continuous"))))
      (setq i 0 n 0 nb 0 skip 0 size 0.0)
      (repeat (sslength ss)
        (setq d (entget (ssname ss i)) i (1+ i)
              bd (entget (tblobjname "BLOCK" (cdr (assoc 2 d))))
              base (cdr (assoc 10 bd))
              ip (cdr (assoc 10 d)) nrm (cdr (assoc 210 d)) a (cdr (assoc 50 d))
              sx (cond ((cdr (assoc 41 d))) (1.0)) sy (cond ((cdr (assoc 42 d))) (1.0))
              piles (tv-pcp-piles (cdr (assoc 2 d))))
        (if piles
          (progn
            (setq nb (1+ nb))
            ;; block -> insert OCS (base, scale, rotation, insert point) -> WCS
            (foreach q piles
              (setq x (* sx (- (car q) (car base))) y (* sy (- (cadr q) (cadr base))))
              (entmake (list '(0 . "POINT") '(8 . "PILE-CENTER")
                             (cons 10 (trans (list (+ (car ip) (- (* x (cos a)) (* y (sin a))))
                                                   (+ (cadr ip) (+ (* x (sin a)) (* y (cos a))))
                                                   (caddr ip))
                                             nrm 0))))
              (setq n (1+ n) size (max size (* 2.0 (caddr q) (max (abs sx) (abs sy)))))))
          (setq skip (1+ skip))))
      (if (> n 0)
        (progn (setvar "PDMODE" 34) (setvar "PDSIZE" size)))
      (princ (strcat "\n" (itoa n) " pile centres on layer PILE-CENTER from " (itoa nb) " blocks"
                     (if (> skip 0) (strcat ", " (itoa skip) " blocks without circles skipped") "")))))
  (command "_.UNDO" "_E")
  (setvar "CMDECHO" ce)
  (setq *error* old)
  (princ))

(princ "\nTORVA Pile Centre Points: PCP | 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 ----