;;; TORVA LISP - Pile Cap Layout (torva.kr/lisp.html)
;;; PFD : pile type (PHC / Micro) -> pile count 1-12 -> a block with piles (circle, hatch, centre mark),
;;;       cap outline and dimensions. Click each cap centre and give a rotation -> block + PF<n> tag
;;; S at the count prompt changes D (pile diameter), P (pile spacing), E (edge distance) for that type
;;; Defaults: PHC D500 P1300 E650 / Micro D300 P1000 E500. Pile patterns for 1-12 are fixed, in units of P
;;; Block name carries the values (PF_N4_D500_P1300_E650) - other values make another block.
;;;   Purge the block to rebuild it after changing the dimension style or DIMSCALE
;;; Dimensions use the current dimension style; no dimension variable is changed.
;;;   Offsets 4 / 8 x DIMSCALE (400 / 800 at 1:100)
;;; Tag: pentagon radius 5 x DIMSCALE, text 3.5 x DIMSCALE, current text style, at the cap's lower right
;;; Layers (created if missing): PILE (piles, cap), PILE-PITCH (P/2 circles, not plotted), PILE-DIM, PILE-TAG
;;; Drawing unit: mm. Type, count, sizes and rotation are kept until the drawing closes

(vl-load-com)

(if (null *TV-PFD-TYPE*) (setq *TV-PFD-TYPE* "PHC"))
(if (null *TV-PFD-N*)    (setq *TV-PFD-N* 2))
(if (null *TV-PFD-ROT*)  (setq *TV-PFD-ROT* 0.0))
;; type -> D P E
(if (null *TV-PFD-SPEC*)
  (setq *TV-PFD-SPEC* '(("PHC" 500.0 1300.0 650.0) ("Micro" 300.0 1000.0 500.0))))

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

(defun tv-pfd-f (v) (if (equal v (fix v) 1e-6) (itoa (fix v)) (rtos v 2 1)))

(defun tv-pfd-tname (k) (if (= k "Micro") "¸¶ÀÌÅ©·Î" "PHC"))

;; pile centres in units of P, as drawn in practice (zigzag for 3, 5, 7, 8, 10, 11)
(defun tv-pfd-layout (n / z)
  (setq z (/ 600.0 1300.0))
  (cond
    ((= n 1)  '((0.0 0.0)))
    ((= n 2)  '((0.0 0.5) (0.0 -0.5)))
    ((= n 3)  (list (list 0.0 z) (list -0.5 (- z)) (list 0.5 (- z))))
    ((= n 4)  '((-0.5 0.5) (0.5 0.5) (-0.5 -0.5) (0.5 -0.5)))
    ((= n 5)  '((0.0 0.0) (-0.75 0.75) (0.75 0.75) (-0.75 -0.75) (0.75 -0.75)))
    ((= n 6)  '((-0.5 1.0) (0.5 1.0) (-0.5 0.0) (0.5 0.0) (-0.5 -1.0) (0.5 -1.0)))
    ((= n 7)  '((-0.5 0.9) (0.5 0.9) (-1.0 0.0) (0.0 0.0) (1.0 0.0) (-0.5 -0.9) (0.5 -0.9)))
    ((= n 8)  '((-1.0 0.9) (0.0 0.9) (1.0 0.9) (-0.5 0.0) (0.5 0.0) (-1.0 -0.9) (0.0 -0.9) (1.0 -0.9)))
    ((= n 9)  '((-1.0 1.0) (0.0 1.0) (1.0 1.0) (-1.0 0.0) (0.0 0.0) (1.0 0.0) (-1.0 -1.0) (0.0 -1.0) (1.0 -1.0)))
    ((= n 10) '((-1.0 0.9) (0.0 0.9) (1.0 0.9) (-1.5 0.0) (-0.5 0.0) (0.5 0.0) (1.5 0.0) (-1.0 -0.9) (0.0 -0.9) (1.0 -0.9)))
    ((= n 11) '((-1.5 0.9) (-0.5 0.9) (0.5 0.9) (1.5 0.9) (-1.0 0.0) (0.0 0.0) (1.0 0.0) (-1.5 -0.9) (-0.5 -0.9) (0.5 -0.9) (1.5 -0.9)))
    (T        '((-1.5 1.0) (-0.5 1.0) (0.5 1.0) (1.5 1.0) (-1.5 0.0) (-0.5 0.0) (0.5 0.0) (1.5 0.0) (-1.5 -1.0) (-0.5 -1.0) (0.5 -1.0) (1.5 -1.0))))
)

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

;; CENTER linetype if it can be loaded, else Continuous
(defun tv-pfd-lt (doc)
  (if (null (tblsearch "LTYPE" "CENTER"))
    (vl-catch-all-apply 'vla-Load
      (list (vla-get-Linetypes doc) "CENTER" (if (= 1 (getvar "MEASUREMENT")) "acadiso.lin" "acad.lin"))))
  (if (tblsearch "LTYPE" "CENTER") "CENTER" "Continuous"))

(defun tv-pfd-ent (dxf) (entmake dxf) (entlast))

(defun tv-pfd-arr (en / a)
  (setq a (vlax-make-safearray vlax-vbObject '(0 . 0)))
  (vlax-safearray-put-element a 0 (vlax-ename->vla-object en))
  a)

;; ANSI31 ring between the pile circle and the centre hole, in the current space
;; a failed hatch is deleted and the piles are kept without it
(defun tv-pfd-hatch (doc outer inner scl / sp h r)
  (setq sp (if (and (= 0 (getvar "TILEMODE")) (= 1 (getvar "CVPORT")))
             (vla-get-PaperSpace doc) (vla-get-ModelSpace doc)))
  (setq r (vl-catch-all-apply
            '(lambda ()
               (setq h (vla-AddHatch sp 1 "ANSI31" :vlax-false))
               (vla-put-Layer h "PILE") (vla-put-Color h 5) (vla-put-PatternScale h scl)
               (vla-AppendOuterLoop h (tv-pfd-arr outer))
               (vla-AppendInnerLoop h (tv-pfd-arr inner))
               (vla-Evaluate h)
               (vlax-vla-object->ename h))))
  (if (vl-catch-all-error-p r)
    (progn (if (= (type h) 'VLA-OBJECT) (vl-catch-all-apply 'vla-Delete (list h))) nil)
    r))

(defun tv-pfd-uniq (l / r)
  (foreach x (vl-sort l '<) (if (not (and r (equal x (car r) 1e-6))) (setq r (cons x r))))
  (reverse r))

;; aligned dimension on PILE-DIM, added to ss
(defun tv-pfd-dim (p1 p2 p3 ss / ed)
  (command "_.DIMALIGNED" "_non" p1 "_non" p2 "_non" p3)
  (setq ed (entget (entlast)))
  (entmod (subst '(8 . "PILE-DIM") (assoc 8 ed) ed))
  (ssadd (entlast) ss))

;; block at the WCS origin; call with the World UCS current
(defun tv-pfd-block (doc name pts box d p / ss lt cl x y c h hx dx dy i ds minx miny maxx maxy)
  (setq minx (nth 0 box) miny (nth 1 box) maxx (nth 2 box) maxy (nth 3 box)
        ds (tv-pfd-ds) lt (tv-pfd-lt doc) cl (* p (/ 450.0 1300.0)) ss (ssadd))
  (ssadd (tv-pfd-ent (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(8 . "PILE") '(62 . 151)
                           '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1)
                           (list 10 minx miny) (list 10 maxx miny) (list 10 maxx maxy) (list 10 minx maxy))) ss)
  (foreach pt pts
    (setq x (car pt) y (cadr pt))
    (ssadd (tv-pfd-ent (list '(0 . "CIRCLE") '(8 . "PILE-PITCH") (list 10 x y 0.0) (cons 40 (/ p 2.0)))) ss)
    (ssadd (tv-pfd-ent (list '(0 . "LINE") '(8 . "PILE") '(62 . 30) (cons 6 lt)
                             (list 10 (- x cl) y 0.0) (list 11 (+ x cl) y 0.0))) ss)
    (ssadd (tv-pfd-ent (list '(0 . "LINE") '(8 . "PILE") '(62 . 30) (cons 6 lt)
                             (list 10 x (- y cl) 0.0) (list 11 x (+ y cl) 0.0))) ss)
    (setq c (tv-pfd-ent (list '(0 . "CIRCLE") '(8 . "PILE") '(62 . 7) (list 10 x y 0.0) (cons 40 (/ d 2.0))))
          h (tv-pfd-ent (list '(0 . "CIRCLE") '(8 . "PILE") '(62 . 7) (list 10 x y 0.0) (cons 40 (/ d 16.0)))))
    (ssadd c ss) (ssadd h ss)
    (if (setq hx (tv-pfd-hatch doc c h (/ d 25.0))) (ssadd hx ss)))
  ;; chain + overall dimensions, top and left
  (setq dx (tv-pfd-uniq (append (list minx maxx) (mapcar 'car pts)))
        dy (tv-pfd-uniq (append (list miny maxy) (mapcar 'cadr pts))) i 0)
  (while (< i (1- (length dx)))
    (tv-pfd-dim (list (nth i dx) maxy) (list (nth (1+ i) dx) maxy) (list (nth i dx) (+ maxy (* 4 ds))) ss)
    (setq i (1+ i)))
  (tv-pfd-dim (list minx maxy) (list maxx maxy) (list minx (+ maxy (* 8 ds))) ss)
  (setq i 0)
  (while (< i (1- (length dy)))
    (tv-pfd-dim (list minx (nth i dy)) (list minx (nth (1+ i) dy)) (list (- minx (* 4 ds)) (nth i dy)) ss)
    (setq i (1+ i)))
  (tv-pfd-dim (list minx miny) (list minx maxy) (list (- minx (* 8 ds)) miny) ss)
  (command "_.-BLOCK" name "_non" '(0.0 0.0 0.0) ss "")
)

;; insert at a UCS point with a UCS angle, tag PF<n> beyond the cap's lower-right corner
(defun tv-pfd-place (name ins rot box n / ua ds w cs xs ys tc pl a e)
  (setq ua (angle '(0.0 0.0 0.0) (trans '(1.0 0.0 0.0) 1 0 T))
        ds (tv-pfd-ds) w (trans ins 1 0))
  (entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 w)
                 '(41 . 1.0) '(42 . 1.0) '(43 . 1.0) (cons 50 (+ rot ua))))
  (setq cs (mapcar '(lambda (q) (list (+ (car ins) (- (* (car q) (cos rot)) (* (cadr q) (sin rot))))
                                      (+ (cadr ins) (+ (* (car q) (sin rot)) (* (cadr q) (cos rot))))))
                   (list (list (nth 0 box) (nth 1 box)) (list (nth 2 box) (nth 1 box))
                         (list (nth 2 box) (nth 3 box)) (list (nth 0 box) (nth 3 box))))
        xs (apply 'max (mapcar 'car cs)) ys (apply 'min (mapcar 'cadr cs))
        tc (list (+ xs (* 8 ds)) (- ys (* 8 ds)) (caddr ins)) a (/ pi 2.0))
  (repeat 5
    (setq e (trans (polar tc a (* 5 ds)) 1 0)
          pl (cons (list 10 (car e) (cadr e)) pl) a (+ a (* 0.4 pi))))
  (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(8 . "PILE-TAG") '(62 . 7)
                         '(100 . "AcDbPolyline") '(90 . 5) '(70 . 1) (cons 38 (caddr (trans tc 1 0))))
                   (reverse pl)))
  (setq w (trans tc 1 0))
  (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(8 . "PILE-TAG") '(100 . "AcDbText")
                 (cons 10 w) (cons 11 w) (cons 40 (* 3.5 ds)) (cons 1 (strcat "PF" (itoa n)))
                 (cons 50 ua) (cons 7 (getvar "TEXTSTYLE")) '(72 . 1) '(73 . 2)))
)

(defun c:PFD (/ *error* old ce osm ucf ucsw doc k v n spec d p e pts box blk ins r cnt)
  (setq ce (getvar "CMDECHO") osm (getvar "OSMODE") ucf (getvar "UCSFOLLOW") old *error*
        doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (defun *error* (msg)
    (if ucsw (command "_.UCS" "_P"))
    (command "_.UNDO" "_E")
    (setvar "UCSFOLLOW" ucf) (setvar "OSMODE" osm) (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")

  (initget "PHC Micro")
  (if (setq k (getkword (strcat "\nÆÄÀÏ Á¾·ù [PHC(P)/¸¶ÀÌÅ©·Î(M)] <" (tv-pfd-tname *TV-PFD-TYPE*) ">: ")))
    (setq *TV-PFD-TYPE* k))

  ;; count; S = D P E of this type
  (while (null n)
    (setq spec (cdr (assoc *TV-PFD-TYPE* *TV-PFD-SPEC*)))
    (initget 6 "S")
    (setq v (getint (strcat "\nÆÄÀÏ º»¼ö (1~12) [Á¦¿ø(S)] <" (itoa *TV-PFD-N*) ", D" (tv-pfd-f (car spec))
                            " P" (tv-pfd-f (cadr spec)) " E" (tv-pfd-f (caddr spec)) ">: ")))
    (cond
      ((= v "S")
       (initget 6)
       (if (null (setq d (getdist (strcat "\nÆÄÀÏ Áö¸§ <" (tv-pfd-f (car spec)) ">: ")))) (setq d (car spec)))
       (initget 6)
       (if (null (setq p (getdist (strcat "\nÆÄÀÏ °£°Ý <" (tv-pfd-f (cadr spec)) ">: ")))) (setq p (cadr spec)))
       (initget 6)
       (if (null (setq e (getdist (strcat "\n¿¬´Ü °Å¸® <" (tv-pfd-f (caddr spec)) ">: ")))) (setq e (caddr spec)))
       (setq *TV-PFD-SPEC* (subst (list *TV-PFD-TYPE* d p e) (assoc *TV-PFD-TYPE* *TV-PFD-SPEC*) *TV-PFD-SPEC*)))
      ((null v) (setq n *TV-PFD-N*))
      ((> v 12) (princ "\nPile count 1 to 12"))
      (T (setq n v *TV-PFD-N* v))))

  (setq spec (cdr (assoc *TV-PFD-TYPE* *TV-PFD-SPEC*))
        d (car spec) p (cadr spec) e (caddr spec)
        pts (mapcar '(lambda (m) (list (* (car m) p) (* (cadr m) p))) (tv-pfd-layout n))
        box (list (- (apply 'min (mapcar 'car pts)) e) (- (apply 'min (mapcar 'cadr pts)) e)
                  (+ (apply 'max (mapcar 'car pts)) e) (+ (apply 'max (mapcar 'cadr pts)) e))
        blk (strcat "PF_N" (itoa n) "_D" (tv-pfd-f d) "_P" (tv-pfd-f p) "_E" (tv-pfd-f e)))
  (tv-pfd-layer "PILE" 7 1)
  (tv-pfd-layer "PILE-PITCH" 151 0)
  (tv-pfd-layer "PILE-DIM" 8 1)
  (tv-pfd-layer "PILE-TAG" 3 1)

  (if (null (tblsearch "BLOCK" blk))
    (progn
      (setvar "OSMODE" 0)
      (if (= 0 (getvar "WORLDUCS"))
        (progn (setvar "UCSFOLLOW" 0) (command "_.UCS" "_W") (setq ucsw T)))
      (tv-pfd-block doc blk pts box d p)
      (if ucsw (progn (command "_.UCS" "_P") (setq ucsw nil)))
      (setvar "UCSFOLLOW" ucf) (setvar "OSMODE" osm)))

  (setq cnt 0)
  (while (setq ins (getpoint "\n±âÃÊ Áß½É: "))
    (setq r (getorient ins (strcat "\nȸÀü °¢µµ <" (tv-pfd-f (/ (* *TV-PFD-ROT* 180.0) pi)) ">: ")))
    (if r (setq *TV-PFD-ROT* r) (setq r *TV-PFD-ROT*))
    (tv-pfd-place blk ins r box n)
    (setq cnt (1+ cnt)))

  (command "_.UNDO" "_E")
  (if (> cnt 0)
    (princ (strcat "\n" (itoa cnt) " pile caps PF" (itoa n) " placed (" *TV-PFD-TYPE*
                   " D" (tv-pfd-f d) " P" (tv-pfd-f p) " E" (tv-pfd-f e) ")")))
  (setvar "OSMODE" osm) (setvar "CMDECHO" ce)
  (setq *error* old)
  (princ)
)

(princ "\nTORVA Pile Cap: PFD | 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 ----