;;; BoreholeSymbols - AutoCAD / AutoCAD LT 2024+ for Windows.
;;; SSX: place; SSC: change shape; SSM: move text/frame; SSF: fit.
;;; Geometry uses local block units; 100% places the outermost symbol point 2 drawing units from center.
;;; Literal RGB white fills, not viewport-dependent ACI 7.

;; Remember the LSP folder while AutoCAD is loading the file so the
;; companion DCL can be found even when that folder is not on the Support
;; File Search Path.
(if (/= (type *bm-lsp-dir*) 'STR) (setq *bm-lsp-dir* nil))
(if (and (= (type *load-truename*) 'STR)
         (/= *load-truename* ""))
  (setq *bm-lsp-dir* (vl-filename-directory *load-truename*)))

(defun bm:make (data)
  (if (not (entmake data)) (progn (princ "\nCannot create symbol entity.") (exit))))
(defun bm:lock (e / o r)
  ;; Keep the attribute draggable.  The object reactor moves the frame
  ;; together with it, so text and border stay as one visual unit.
  (if (and e (entget e) (/= (getenv "ACCORECONSOLE") "Y"))
    (progn
      (vl-load-com)
      (setq o (vl-catch-all-apply 'vlax-ename->vla-object (list e)))
      (if (and (not (vl-catch-all-error-p o)) o
               (vlax-property-available-p o 'LockPosition T))
        (setq r (vl-catch-all-apply 'vla-put-LockPosition (list o :vlax-false))))))
  e)
(defun bm:base (kind color)
  (append (list (cons 0 kind) '(8 . "0")) color))
(defun bm:solid (a b c color)
  (bm:make (append (bm:base "SOLID" color)
    (list (cons 10 a) (cons 11 b) (cons 12 c) (cons 13 c)))))
(defun bm:sector (r a b color / i n p q)
  ;; Filled sectors are made from SOLIDs.  Forty-eight segments keep the
  ;; printed circle smooth while avoiding hundreds of internal grips.
  (setq n (max 1 (fix (+ 0.5 (* 48.0 (/ (- b a) (* 2.0 pi)))))) i 0)
  (repeat n
    (setq p (polar '(0.0 0.0 0.0) (+ a (* (- b a) (/ (float i) n))) r)
          q (polar '(0.0 0.0 0.0) (+ a (* (- b a) (/ (float (1+ i)) n))) r))
    (bm:solid '(0.0 0.0 0.0) p q color)
    (setq i (1+ i))))
(defun bm:disk (r color) (bm:sector r 0.0 (* 2.0 pi) color))
(defun bm:poly (pts color /)
  (bm:make (append (bm:base "LWPOLYLINE" color)
    (list '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
      (cons 90 (length pts)) '(70 . 1))
    (mapcar '(lambda (p) (cons 10 (list (car p) (cadr p)))) pts))))
(defun bm:circle (r color)
  (bm:make (append (bm:base "CIRCLE" color)
    (list '(10 0.0 0.0 0.0) (cons 40 r)))))
(defun bm:fillpoly (pts color / i)
  (setq i 1)
  (repeat (- (length pts) 2)
    (bm:solid (car pts) (nth i pts) (nth (1+ i) pts) color)
    (setq i (1+ i))))
(defun bm:rect (x y w h)
  (list (list x y 0.0) (list (+ x w) y 0.0)
    (list (+ x w) (+ y h) 0.0) (list x (+ y h) 0.0)))
(defun bm:guide-layer (/)
  ;; A visible construction edge around the white backplate, omitted from plots.
  (if (not (tblsearch "LAYER" "BHS_GUIDE_NOPLOT"))
    (progn
      (bm:make '((0 . "LAYER") (100 . "AcDbSymbolTableRecord")
        (100 . "AcDbLayerTableRecord") (2 . "BHS_GUIDE_NOPLOT")
        (70 . 0) (62 . 8) (6 . "Continuous")))
      ;; LT ignores DXF 290 in entmake/entmod; use its layer command once.
      (command-s "_.-LAYER" "_Plot" "_No" "BHS_GUIDE_NOPLOT" "")))
  "BHS_GUIDE_NOPLOT")
(defun bm:guide-poly (pts /)
  (bm:make (append
    (list '(0 . "LWPOLYLINE") '(8 . "BHS_GUIDE_NOPLOT") '(62 . 8)
      '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
      (cons 90 (length pts)) '(70 . 1))
    (mapcar '(lambda (p) (cons 10 (list (car p) (cadr p)))) pts))))
(defun bm:guide-circle (r /)
  (bm:make (list '(0 . "CIRCLE") '(8 . "BHS_GUIDE_NOPLOT") '(62 . 8)
    '(10 0.0 0.0 0.0) (cons 40 r))))
(defun bm:shape-extent (typ)
  ;; Farthest point of the gray backplate, including polygon corners.
  (cond
    ((member typ '(1 5)) 4.95)
    ((member typ '(2 6)) 4.7)
    ((= typ 3) 4.925)
    ((= typ 4) (sqrt (+ (* 5.85 5.85) (* 3.45 3.45))))
    ((= typ 7) (* 4.95 (sqrt 2.0)))
    ((= typ 8) 5.85)
    (T 4.95)))
(defun bm:percent-scale (pct)
  ;; All smart blocks use radius 2 at 100%; geometry is normalized to 4.95.
  (* (/ pct 100.0) (/ 2.0 4.95)))
(defun bm:style ()
  (if (not (tblsearch "STYLE" "BMS_ARIAL"))
    (bm:make '((0 . "STYLE") (100 . "AcDbSymbolTableRecord")
      (100 . "AcDbTextStyleTableRecord") (2 . "BMS_ARIAL") (70 . 0)
      (40 . 0.0) (41 . 1.0) (50 . 0.0) (71 . 0) (42 . 5.5)
      (3 . "arial.ttf") (4 . ""))))
  "BMS_ARIAL")
(defun bm:metrics (label / box lo hi)
  (setq box (textbox (list '(0 . "TEXT") (cons 1 label) '(40 . 5.5)
    (cons 7 (bm:style)) '(41 . 0.8))) lo (car box) hi (cadr box))
  ;; (frame-width insertion-point); use actual font extents, including bearings.
  (list (max 8.0 (+ 1.6 (- (car hi) (car lo))))
    (list (- (/ (+ (car lo) (car hi)) 2.0))
      (- 9.6 (/ (+ (cadr lo) (cadr hi)) 2.0)) 0.0)))
(defun bm:label-width (label / box)
  (setq box (textbox (list '(0 . "TEXT") (cons 1 label) '(40 . 5.5)
    (cons 7 (bm:style)) '(41 . 1.0))))
  ;; Reduce the former 3-unit horizontal padding by 70 percent.
  (max 2.0 (+ 0.9 (- (caadr box) (caar box)))))
(defun bm:position-local (position label / side)
  ;; Keep the text mask close to the symbol without touching it.
  (setq side (+ 5.2 (* 0.5 (bm:label-width label))))
  (cond
    ((= position "right") (list side 0.0 0.0))
    ((= position "down") '(0.0 -8.0 0.0))
    ((= position "left") (list (- side) 0.0 0.0))
    (T '(0.0 8.0 0.0))))
(defun bm:shape-name (typ)
  (cond ((= typ 1) "QUARTER_DOUBLE_RING")
    ((= typ 2) "QUARTER_SINGLE_RING")
    ((= typ 3) "HOLLOW_RING")
    ((= typ 4) "TRIANGLE")
    ((= typ 5) "DOT_DOUBLE_RING")
    ((= typ 6) "DOT_SINGLE_RING")
    ((= typ 7) "SQUARE")
    ((= typ 8) "DIAMOND")))
(defun bm:type-from-name (name)
  (cond ((wcmatch name "BMS_QUARTER_DOUBLE_RING*") 1)
    ((wcmatch name "BHS_QUARTER_DOUBLE_RING*") 1)
    ((wcmatch name "BHS_QUARTER_SINGLE_RING*") 2)
    ((wcmatch name "BHS_HOLLOW_RING*") 3)
    ((wcmatch name "BHS_TRIANGLE*") 4)
    ((wcmatch name "BHS_DOT_DOUBLE_RING*") 5)
    ((wcmatch name "BHS_DOT_SINGLE_RING*") 6)
    ((wcmatch name "BHS_SQUARE*") 7)
    ((wcmatch name "BHS_DIAMOND*") 8)
    ((wcmatch name "BMS_QUARTER_SINGLE_RING*") 2)
    ((wcmatch name "BMS_HOLLOW_RING*") 3)
    ((wcmatch name "BMS_TRIANGLE*") 4)
    ((wcmatch name "BMS_DOT_DOUBLE_RING*") 5)
    ((wcmatch name "BMS_DOT_SINGLE_RING*") 6)
    ((wcmatch name "BMS_SQUARE*") 7)
    ((wcmatch name "BMS_DIAMOND*") 8)
    ;; Compatibility with blocks made by the first version.
    ((wcmatch name "BMS_1_*") 1) ((wcmatch name "BMS_2_*") 2)
    ((wcmatch name "BMS_3_*") 3) ((wcmatch name "BMS_4_*") 4)
    ((wcmatch name "BMS_5_*") 5) ((wcmatch name "BMS_6_*") 6)
    ((wcmatch name "BMS_7_*") 7) ((wcmatch name "BMS_8_*") 8)))
(defun bm:prompt-type (/ name)
  (princ "\nAvailable shapes:")
  (princ "\n  1  QuarterDoubleRing  - quartered circle, double ring")
  (princ "\n  2  QuarterSingleRing  - quartered circle, single ring")
  (princ "\n  3  HollowRing         - hollow ring")
  (princ "\n  4  Triangle            - filled triangle")
  (princ "\n  5  DotDoubleRing      - filled dot, double ring")
  (princ "\n  6  DotSingleRing      - filled dot, single ring")
  (princ "\n  7  Square              - filled square")
  (princ "\n  8  Diamond             - filled diamond")
  (initget "1 2 3 4 5 6 7 8 QuarterDoubleRing QuarterSingleRing HollowRing Triangle DotDoubleRing DotSingleRing Square Diamond")
  (setq name (getkword "\nSelect a shape from the list: "))
  (if name (setq name (strcase name)))
  (cond ((or (= name "2") (= name "QUARTERSINGLERING")) 2)
    ((or (= name "3") (= name "HOLLOWRING")) 3)
    ((or (= name "4") (= name "TRIANGLE")) 4)
    ((or (= name "5") (= name "DOTDOUBLERING")) 5)
    ((or (= name "6") (= name "DOTSINGLERING")) 6)
    ((or (= name "7") (= name "SQUARE")) 7)
    ((or (= name "8") (= name "DIAMOND")) 8)
    (T 1)))
(defun bm:write-dcl (/ p f lines)
  ;; A fallback copy makes SS work even when the LSP folder is not yet on
  ;; AutoCAD's Support File Search Path.
  (setq p (strcat (getenv "TEMP") "\\BoreholeSymbols.dcl")
    lines '(
      "bms_main : dialog {"
      "  label = \"BH-maker ver1.23\";"
      "  : row {"
      "  : boxed_column { label = \"Operation\"; : radio_column { key = \"op\";"
      "    : radio_button { key = \"place\"; label = \"Place new symbol\"; value = \"1\"; }"
      "    : radio_button { key = \"convert\"; label = \"Convert selected symbol\"; }"
      "    : radio_button { key = \"edit\"; label = \"Edit text\"; }"
      "    : radio_button { key = \"fit\"; label = \"Fit text background\"; } } }"
      "  : boxed_column { label = \"Text place\"; : radio_column { key = \"position\";"
      "    : radio_button { key = \"up\"; label = \"U\"; }"
      "    : radio_button { key = \"right\"; label = \"R\"; }"
      "    : radio_button { key = \"down\"; label = \"D\"; }"
      "    : radio_button { key = \"left\"; label = \"L\"; }"
      "    : radio_button { key = \"custom\"; label = \"Mouse\"; } } }"
      "  }"
      "  : boxed_column { label = \"Shape (click an icon)\";"
      "    : row { fixed_width = true; alignment = centered;"
      "      : image_button { key = \"shape1\"; width = 6; height = 3.0; fixed_width = true; fixed_height = true; }"
      "      : image_button { key = \"shape2\"; width = 6; height = 3.0; fixed_width = true; fixed_height = true; }"
      "      : image_button { key = \"shape3\"; width = 6; height = 3.0; fixed_width = true; fixed_height = true; }"
      "      : image_button { key = \"shape4\"; width = 6; height = 3.0; fixed_width = true; fixed_height = true; } }"
      "    : row { fixed_width = true; alignment = centered;"
      "      : image_button { key = \"shape5\"; width = 6; height = 3.0; fixed_width = true; fixed_height = true; }"
      "      : image_button { key = \"shape6\"; width = 6; height = 3.0; fixed_width = true; fixed_height = true; }"
      "      : image_button { key = \"shape7\"; width = 6; height = 3.0; fixed_width = true; fixed_height = true; }"
      "      : image_button { key = \"shape8\"; width = 6; height = 3.0; fixed_width = true; fixed_height = true; } } }"
      "  : boxed_column { label = \"Place options\";"
      "    : edit_box { key = \"name\"; label = \"Name:\"; edit_width = 24; value = \"MW2\"; }"
      "    : toggle { key = \"auto_name\"; label = \"Automatic numbering (shapes 1 and 2)\"; value = \"0\"; }"
      "    : popup_list { key = \"auto_format\"; label = \"Shape 1 format:\"; width = 22; }"
      "    : text { label = \"Shape 2 uses BH? automatically\"; }"
      "    : edit_box { key = \"scale\"; label = \"Size %:\"; edit_width = 10; value = \"100\"; }"
      "    : row { fixed_width = true; alignment = left;"
      "      : button { key = \"color\"; label = \"Choose color...\"; width = 24; fixed_width = true; }"
      "      : image { key = \"color_swatch\"; width = 2.8; height = 1.4; fixed_width = true; fixed_height = true; color = blue; } } }"
      "  : boxed_column { label = \"Elevation\";"
      "    : toggle { key = \"elev_show\"; label = \"Show elevation\"; value = \"0\"; }"
      "    : edit_box { key = \"elev_suffix\"; label = \"Suffix (all blocks):\"; edit_width = 12; value = \"m\"; } }"
      "  spacer; ok_cancel;"
      "}"))
  (if (setq f (open p "w"))
    (progn (foreach line lines (write-line line f)) (close f) p)))
(defun bm:dcl-path ()
  ;; Always generate this version's dialog so an older companion DCL cannot
  ;; silently hide new controls when the user loads only the versioned LSP.
  (bm:write-dcl))
(defun bm:dcl-snapshot ()
  (setq *bm-dialog-name* (get_tile "name")
    *bm-dialog-scale* (get_tile "scale")
    *bm-dialog-auto-name* (get_tile "auto_name")
    *bm-dialog-auto-format* (get_tile "auto_format")
    *bm-dialog-elev-show* (get_tile "elev_show")
    *bm-dialog-suffix* (get_tile "elev_suffix")))
(defun bm:dcl-auto-name ()
  (setq *bm-dialog-auto-name* (get_tile "auto_name"))
  (mode_tile "name" (if (and (= *bm-dialog-op* "place")
                              (= *bm-dialog-auto-name* "1")) 1 0))
  (mode_tile "auto_format" (if (and (= *bm-dialog-op* "place")
                                     (= *bm-dialog-auto-name* "1")) 0 1)))
(defun bm:dcl-operation (op / text-enabled elev-enabled place-enabled)
  (setq *bm-dialog-op* op
    text-enabled (= op "edit")
    elev-enabled (member op '("place" "edit"))
    place-enabled (= op "place"))
  (if (not text-enabled)
    (progn
      (setq *bm-dialog-position* "keep")
      (foreach key '("up" "right" "down" "left" "custom")
        (set_tile key "0"))))
  (foreach key '("up" "right" "down" "left" "custom")
    (mode_tile key (if text-enabled 0 1)))
  (mode_tile "elev_show" (if elev-enabled 0 1))
  (mode_tile "auto_name" (if place-enabled 0 1))
  (bm:dcl-auto-name))
(defun bm:dcl-elevation-toggle ()
  (setq *bm-dialog-elev-touched* T))
(defun bm:dcl-color ()
  ;; Close DCL before opening AutoCAD's palette; nested modal dialogs can
  ;; appear unresponsive in AutoCAD LT.
  (bm:dcl-snapshot)
  (setq *bm-dialog-color-picked* T)
  (done_dialog 2))
(defun bm:choose-color (color / initial)
  ;; acad_truecolordlg takes one dotted pair, while its result (and the
  ;; dialog state) is a list of one or more dotted pairs.
  (setq initial
    (if (and color (listp color) (listp (car color)))
      (last color)
      (if (and (listp color) (member (car color) '(62 420 430)))
        color '(62 . 5))))
  (acad_truecolordlg initial nil))
(defun bm:dcl-swatch (color / aci w h)
  ;; DCL images use ACI colors.  True-color selections also return the
  ;; nearest ACI value in group 62, which is used for the preview.
  (setq aci (cdr (assoc 62 color)))
  (if (or (not (numberp aci)) (< aci 1) (> aci 255))
    (setq aci 5))
  (setq w (dimx_tile "color_swatch") h (dimy_tile "color_swatch"))
  (if (and (numberp w) (numberp h) (> w 0) (> h 0))
    (progn
      (start_image "color_swatch")
      (fill_image 0 0 w h aci)
      (end_image)))
  aci)
(defun bm:img-circle (cx cy r ink / dy outer inner span)
  ;; Draw continuous horizontal spans.  Short vector segments leave visible
  ;; gaps when a small DCL image rounds their endpoints to screen pixels.
  (setq dy (- r))
  (while (<= dy r)
    (setq outer (fix (sqrt (max 0 (- (* r r) (* dy dy)))))
      inner (if (<= (abs dy) (1- r))
        (fix (sqrt (max 0 (- (* (1- r) (1- r)) (* dy dy)))))
        -1))
    (if (< inner 0)
      (fill_image (- cx outer) (+ cy dy) (1+ (* 2 outer)) 1 ink)
      (progn
        (setq span (- outer inner))
        (if (> span 0)
          (progn
            (fill_image (- cx outer) (+ cy dy) span 1 ink)
            (fill_image (+ cx inner 1) (+ cy dy) span 1 ink)))))
    (setq dy (1+ dy))))
(defun bm:img-disk (cx cy r ink / dy half)
  (setq dy (- r))
  (while (<= dy r)
    (setq half (fix (sqrt (max 0 (- (* r r) (* dy dy))))))
    (fill_image (- cx half) (+ cy dy) (1+ (* 2 half)) 1 ink)
    (setq dy (1+ dy))))
(defun bm:img-quarter (cx cy r ink / dy half)
  (setq dy (- r))
  (while (<= dy r)
    (setq half (fix (sqrt (max 0 (- (* r r) (* dy dy))))))
    (if (< dy 0)
      (fill_image cx (+ cy dy) (1+ half) 1 ink)
      (fill_image (- cx half) (+ cy dy) (1+ half) 1 ink))
    (setq dy (1+ dy))))
(defun bm:dcl-draw-shape (typ / key w h cx cy r inner dy half edge selected)
  (setq key (strcat "shape" (itoa typ))
    w (dimx_tile key) h (dimy_tile key))
  (if (and (numberp w) (numberp h) (> w 12) (> h 12))
    (progn
      (setq cx (fix (/ w 2.0)) cy (fix (/ h 2.0))
        r (max 5 (fix (* 0.32 (min w h))))
        inner (max 3 (fix (* r 0.58)))
        selected (= (atoi *bm-dialog-shape*) (1- typ)))
      (start_image key)
      (fill_image 0 0 w h -15)
      (cond
        ((member typ '(1 2))
          (if (= typ 2) (setq inner (max 3 (fix (* r 0.78)))))
          (bm:img-quarter cx cy inner 5)
          (bm:img-circle cx cy inner 5)
          (if (= typ 1)
            (progn
              (setq edge (max (+ inner 2) (fix (* r 0.8))))
              (bm:img-circle cx cy edge 5)))
          (bm:img-circle cx cy
            (if (= typ 1)
              (max (1+ edge) (fix (* r 0.9)))
              (max (1+ inner) (fix (* r 0.89)))) -18))
        ((= typ 3)
          (bm:img-disk cx cy (fix (* r 0.85)) 5)
          (bm:img-disk cx cy (max 2 (fix (* r 0.47))) -15)
          (bm:img-circle cx cy
            (max (1+ (fix (* r 0.85))) (fix (* r 0.925))) -18))
        ((= typ 4)
          (setq dy (- r))
          (while (<= dy r)
            (setq half (fix (* r (/ (float (+ dy r)) (* 2.0 r)))))
            (fill_image (- cx half) (+ cy dy) (1+ (* 2 half)) 1 5)
            (setq dy (1+ dy))))
        ((= typ 5)
          (bm:img-circle cx cy (fix (* r 0.84)) 5)
          (bm:img-disk cx cy (fix (* r 0.63)) 5)
          (bm:img-circle cx cy
            (max (1+ (fix (* r 0.84))) (fix (* r 0.92))) -18))
        ((= typ 6)
          (bm:img-disk cx cy (fix (* r 0.76)) 5)
          (bm:img-circle cx cy
            (max (1+ (fix (* r 0.76))) (fix (* r 0.88))) -18))
        ((= typ 7)
          (setq edge (max 2 (fix (* r 0.50))))
          (fill_image (- cx r) (- cy r) (1+ (* 2 r)) (1+ (* 2 r)) 5)
          (fill_image (- cx edge) (- cy edge)
            (1+ (* 2 edge)) (1+ (* 2 edge)) -15))
        ((= typ 8)
          (setq dy (- r))
          (while (<= dy r)
            (setq half (- r (abs dy)))
            (fill_image (- cx half) (+ cy dy) (1+ (* 2 half)) 1 5)
            (setq dy (1+ dy)))))
      (setq edge (if selected 5 -18))
      (vector_image 1 1 (- w 2) 1 edge)
      (vector_image (- w 2) 1 (- w 2) (- h 2) edge)
      (vector_image (- w 2) (- h 2) 1 (- h 2) edge)
      (vector_image 1 (- h 2) 1 1 edge)
      (if selected
        (progn
          (vector_image 2 2 (- w 3) 2 edge)
          (vector_image (- w 3) 2 (- w 3) (- h 3) edge)
          (vector_image (- w 3) (- h 3) 2 (- h 3) edge)
          (vector_image 2 (- h 3) 2 2 edge)))
      (end_image))))
(defun bm:dcl-draw-shapes (/ i)
  (setq i 1)
  (repeat 8
    (bm:dcl-draw-shape i)
    (setq i (1+ i))))
(defun bm:dcl-select-shape (typ)
  (setq *bm-dialog-shape* (itoa (1- typ)))
  (if (= (get_tile "auto_name") "1")
    (cond
      ((= typ 2) (set_tile "auto_format" "2"))
      ((and (= typ 1) (= (get_tile "auto_format") "2"))
        (set_tile "auto_format" "0"))))
  (bm:dcl-draw-shapes))
(defun bm:dcl-accept ()
  (bm:dcl-snapshot)
  (setq *bm-dialog-result*
    (list *bm-dialog-op*
      (1+ (atoi *bm-dialog-shape*))
      *bm-dialog-name*
      (atof *bm-dialog-scale*)
      *bm-dialog-color*
      (if (= *bm-dialog-op* "edit") *bm-dialog-position* "keep")
      *bm-dialog-elev-show*
      *bm-dialog-suffix*
      *bm-dialog-elev-touched*
      *bm-dialog-auto-name*
      *bm-dialog-auto-format*))
  (done_dialog 1))
(defun bm:show-dialog (/ path id status chosen)
  (setq *bm-dialog-result* nil *bm-dialog-op* "place"
    *bm-dialog-position* "keep"
    *bm-dialog-color-picked* nil
    *bm-dialog-color* '((62 . 5))
    *bm-dialog-shape* "0" *bm-dialog-name* "MW2"
    *bm-dialog-scale* "100"
    *bm-dialog-auto-name* "0" *bm-dialog-auto-format* "0"
    *bm-dialog-elev-show* "0"
    *bm-dialog-suffix* (bm:current-suffix)
    *bm-dialog-elev-touched* nil)
  (if (and (setq path (bm:dcl-path)) (> (setq id (load_dialog path)) 0))
    (progn
      (setq status 2)
      (while (= status 2)
        (if (new_dialog "bms_main" id)
          (progn
      (bm:dcl-draw-shapes)
      (set_tile "name" *bm-dialog-name*)
      (set_tile "scale" *bm-dialog-scale*)
      (start_list "auto_format")
      (add_list "MW?  (example: MW1)")
      (add_list "BH?(MW)  (example: BH1(MW))")
      (add_list "BH?  (shape 2)")
      (end_list)
      (set_tile "auto_name" *bm-dialog-auto-name*)
      (set_tile "auto_format" *bm-dialog-auto-format*)
      (set_tile "elev_show" *bm-dialog-elev-show*)
      (set_tile "elev_suffix" *bm-dialog-suffix*)
      (bm:dcl-swatch *bm-dialog-color*)
      (set_tile *bm-dialog-op* "1")
      (if (/= *bm-dialog-position* "keep")
        (set_tile *bm-dialog-position* "1"))
      (bm:dcl-operation *bm-dialog-op*)
      (bm:dcl-auto-name)
      (action_tile "place" "(bm:dcl-operation \"place\")")
      (action_tile "convert" "(bm:dcl-operation \"convert\")")
      (action_tile "edit" "(bm:dcl-operation \"edit\")")
      (action_tile "fit" "(bm:dcl-operation \"fit\")")
      (action_tile "shape1" "(bm:dcl-select-shape 1)")
      (action_tile "shape2" "(bm:dcl-select-shape 2)")
      (action_tile "shape3" "(bm:dcl-select-shape 3)")
      (action_tile "shape4" "(bm:dcl-select-shape 4)")
      (action_tile "shape5" "(bm:dcl-select-shape 5)")
      (action_tile "shape6" "(bm:dcl-select-shape 6)")
      (action_tile "shape7" "(bm:dcl-select-shape 7)")
      (action_tile "shape8" "(bm:dcl-select-shape 8)")
      (action_tile "auto_name" "(bm:dcl-auto-name)")
      (action_tile "up" "(setq *bm-dialog-position* \"up\")")
      (action_tile "right" "(setq *bm-dialog-position* \"right\")")
      (action_tile "down" "(setq *bm-dialog-position* \"down\")")
      (action_tile "left" "(setq *bm-dialog-position* \"left\")")
      (action_tile "custom" "(setq *bm-dialog-position* \"custom\")")
      (action_tile "elev_show" "(bm:dcl-elevation-toggle)")
      (action_tile "color" "(bm:dcl-color)")
      (action_tile "accept" "(bm:dcl-accept)")
      (action_tile "cancel" "(done_dialog 0)")
      (setq status (start_dialog)))
          (setq status 0))
        (if (= status 2)
          (progn
            (setq chosen (bm:choose-color *bm-dialog-color*))
            (if chosen (setq *bm-dialog-color* chosen)))))
      (unload_dialog id)
      (if (= status 1) *bm-dialog-result*))
    (princ "\nBoreholeSymbols.dcl was not found beside the LSP or on the Support Path.")))
(defun bm:next-label (label / i code digits next)
  (setq i (strlen label))
  (while (and (> i 0)
              (setq code (ascii (substr label i 1)))
              (<= 48 code) (<= code 57))
    (setq i (1- i)))
  (if (= i (strlen label))
    label
    (progn
      (setq digits (substr label (1+ i))
        next (itoa (1+ (atoi digits))))
      (while (< (strlen next) (strlen digits))
        (setq next (strcat "0" next)))
      (strcat (substr label 1 i) next))))
(defun bm:auto-format (typ format)
  (cond
    ((= typ 2) "BH?")
    ((= format "1") "BH?(MW)")
    (T "MW?")))
(defun bm:auto-label (format number)
  (vl-string-subst (itoa number) "?" format))
(defun bm:prompt-start-number (format / number)
  (initget 6)
  (setq number (getint (strcat "\nStart number for " format ": ")))
  number)
(defun bm:prompt-elevation (label previous / answer)
  ;; Without the T argument, Space or Enter submits the prompt.  A blank
  ;; response keeps the previous height; the first height is required.
  (if (null previous) (setq previous ""))
  (if (= previous "")
    (progn
      (while (= previous "")
        (setq answer (getstring (strcat "\nElevation for " label ": ")))
        (if (and answer (/= answer ""))
          (setq previous answer)
          (princ "\nEnter the first elevation value.")))
      previous)
    (progn
      (setq answer (getstring
        (strcat "\nElevation for " label " <" previous "> [Space=keep]: ")))
      (if (and answer (/= answer "")) answer previous))))
(defun bm:place (typ label pct color position elevation suffix auto-format next-number / pt name sc local e p2)
  (if (= label "") (setq label "MW2"))
  (if (or (null pct) (<= pct 0.0)) (setq pct 100.0))
  (if color
    (progn
      (setq sc (bm:percent-scale pct))
      (while (setq pt (getpoint
        (strcat "\nClick center for " label "; Enter to finish: ")))
        (if elevation
          (setq elevation (bm:prompt-elevation label elevation)))
        (setq local (bm:position-local position label))
        (setq name (bm:smart-definition typ label local elevation suffix))
        (setq e (bm:text-insert name pt sc color))
        (bm:set-elevation-data e elevation suffix)
        (if (= position "custom")
          (progn
            (setq p2 (getpoint
                (trans (bm:smart-world e local) 0 1)
                "\nClick text center; Enter keeps it above: "))
            (if p2
              (bm:smart-update e typ label
                (bm:smart-local e (trans p2 1 0))))))
        (if auto-format
          (progn
            (setq next-number (1+ next-number)
              label (bm:auto-label auto-format next-number)))
          (setq label (bm:next-label label)))))))
(defun bm:convert (typ / ss i e)
  (princ "\nSelect BMS symbols to convert: ")
  (if (setq ss (ssget '((0 . "INSERT"))))
    (progn (setq i 0)
      (repeat (sslength ss)
        (setq e (ssname ss i) i (1+ i))
        (if (bm:valid e) (bm:change-shape e typ))))
    (princ "\nNo objects selected."))
  (princ))
(defun bm:definition (typ label color / white gray ink name n met w pts inner base guide-r)
  (if (null color) (setq color '((420 . 3104293))))
  ;; White is the fill/clear background; every visible stroke uses the
  ;; selected object color so plotted output matches the on-screen symbol.
  (setq white '((420 . 16777215)) gray color ink color
    n 1 base (strcat "BMS_" (bm:shape-name typ)) name (strcat base "_1")
    guide-r (cond
      ((member typ '(1 5)) 4.95)
      ((member typ '(2 6)) 4.7)
      ((= typ 3) 4.925)))
  (bm:guide-layer)
  (while (tblsearch "BLOCK" name)
    (setq n (1+ n) name (strcat base "_" (itoa n))))
  (if label (setq met (bm:metrics label) w (car met)))
  (bm:make (list '(0 . "BLOCK") (cons 2 name)
    (cons 70 (if label 2 0)) '(10 0.0 0.0 0.0)))
  ;; The white backplate follows the outline of each shape.
  (cond
    ((member typ '(1 2 3 5 6)) (bm:disk guide-r white))
    ((= typ 4) (bm:fillpoly
      '((-5.85 -3.45 0.0) (5.85 -3.45 0.0) (0.0 5.85 0.0)) white))
    ((= typ 7) (bm:fillpoly (bm:rect -4.95 -4.95 9.9 9.9) white))
    ((= typ 8) (bm:fillpoly
      '((0.0 -5.85 0.0) (5.85 0.0 0.0) (0.0 5.85 0.0) (-5.85 0.0 0.0)) white)))
  (cond
    ((member typ '(1 2 3 5 6))
      ;; The outer gray guide is the third circle; avoid another ink ring there.
      (if (= typ 5) (bm:circle 4.3 ink))
      (if (= typ 1) (bm:circle 4.3 gray))
      (cond
        ((member typ '(1 2))
          (bm:sector (if (= typ 1) 3.2 3.8) 0.0 (/ pi 2.0) ink)
          (bm:sector (if (= typ 1) 3.2 3.8) pi (* 1.5 pi) ink)
          (bm:circle (if (= typ 1) 3.2 3.8) gray))
        ((= typ 3) (bm:disk 4.25 ink) (bm:disk 2.4 white))
        ((= typ 5) (bm:disk 3.2 ink))
        ((= typ 6) (bm:disk 3.8 ink))))
    ((= typ 4)
      (setq pts '((-5.5 -3.2 0.0) (5.5 -3.2 0.0) (0.0 5.5 0.0))
            inner '((-4.35 -2.55 0.0) (4.35 -2.55 0.0) (0.0 4.4 0.0)))
      (bm:fillpoly pts white) (bm:poly pts gray) (bm:fillpoly inner ink))
    ((= typ 7)
      (bm:fillpoly (bm:rect -4.3 -4.3 8.6 8.6) ink)
      (bm:fillpoly (bm:rect -2.4 -2.4 4.8 4.8) white))
    ((= typ 8)
      (setq pts '((0.0 -5.5 0.0) (5.5 0.0 0.0) (0.0 5.5 0.0) (-5.5 0.0 0.0))
            inner '((0.0 -3.8 0.0) (3.8 0.0 0.0) (0.0 3.8 0.0) (-3.8 0.0 0.0)))
      (bm:fillpoly pts white) (bm:poly pts gray) (bm:fillpoly inner ink)))
  ;; The non-plot gray edge follows the backplate, not a box around a circle.
  (cond
    ((member typ '(1 2 3 5 6)) (bm:guide-circle guide-r))
    ((= typ 4) (bm:guide-poly
      '((-5.85 -3.45 0.0) (5.85 -3.45 0.0) (0.0 5.85 0.0))))
    ((= typ 7) (bm:guide-poly (bm:rect -4.95 -4.95 9.9 9.9)))
    ((= typ 8) (bm:guide-poly
      '((0.0 -5.85 0.0) (5.85 0.0 0.0) (0.0 5.85 0.0) (-5.85 0.0 0.0)))))
  (if label
    (progn
      (setq pts (bm:rect (- (/ w 2.0)) 5.8 w 7.6))
      (bm:fillpoly pts white)
      (bm:make (append (bm:base "ATTDEF" ink)
        (list (cons 10 (cadr met)) '(40 . 5.5) (cons 1 label)
          '(2 . "NAME") '(3 . "Point name") '(70 . 0)
          '(41 . 0.8) '(72 . 1) '(74 . 2) (cons 11 (cadr met))
          '(280 . 1) (cons 7 (bm:style)))))))
  (bm:make '((0 . "ENDBLK")))
  name)
(defun bm:position (local d / p x y rot)
  (setq p (cdr (assoc 10 d)) x (* (car local) (cdr (assoc 41 d)))
    y (* (cadr local) (cdr (assoc 42 d))) rot (cdr (assoc 50 d)))
  (list (+ (car p) (- (* x (cos rot)) (* y (sin rot))))
    (+ (cadr p) (* x (sin rot)) (* y (cos rot))) (caddr p)))
(defun bm:text-definition (label color / name n width)
  ;; Standalone MTEXT block; the white mask belongs to the text itself.
  (if (null color) (setq color '((62 . 5))))
  (setq n 1 name "BMT_TEXT_1")
  (while (tblsearch "BLOCK" name)
    (setq n (1+ n) name (strcat "BMT_TEXT_" (itoa n))))
  (setq width (bm:label-width label))
  (bm:make (list '(0 . "BLOCK") (cons 2 name) '(70 . 0) '(10 0.0 0.0 0.0)))
  (bm:make (append (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(8 . "0")) color
    (list '(100 . "AcDbMText") '(10 0.0 0.0 0.0) '(40 . 5.5)
      (cons 41 width) '(71 . 5) (cons 1 label) (cons 7 (bm:style))
      '(90 . 1) '(63 . 7) '(421 . 16777215) '(45 . 1.045))))
  (bm:make '((0 . "ENDBLK"))) name)
(defun bm:elevation-data (e / x app)
  (if (and e (setq x (assoc -3 (entget e '("BH_MAKER"))))
           (setq app (assoc "BH_MAKER" (cdr x))))
    (list (cdr (nth 1 app)) (cdr (nth 2 app)))))
(defun bm:set-elevation-data (e raw suffix / d)
  (if (and e (entget e))
    (progn
      (if (not (tblsearch "APPID" "BH_MAKER")) (regapp "BH_MAKER"))
      (setq d (vl-remove-if '(lambda (x) (= (car x) -3))
        (entget e '("BH_MAKER"))))
      (entmod (append d (list (list -3
        (list "BH_MAKER" (cons 1000 (if raw raw ""))
          (cons 1000 suffix))))))
      (entupd e)))
  e)
(defun bm:current-suffix (/ ss i datum)
  (if (= (type *bm-elevation-suffix*) 'STR)
    *bm-elevation-suffix*
    (progn
      (setq *bm-elevation-suffix* "m")
      (if (setq ss (ssget "_X" '((0 . "INSERT") (2 . "BHS_*"))))
        (progn (setq i 0)
          (while (and (< i (sslength ss)) (not datum))
            (setq datum (bm:elevation-data (ssname ss i)) i (1+ i)))
          (if (and datum (= (type (cadr datum)) 'STR))
            (setq *bm-elevation-suffix* (cadr datum)))))
      *bm-elevation-suffix*)))
(defun bm:update-global-suffix (suffix / ss i e md data)
  (setq *bm-elevation-suffix* suffix)
  (if (setq ss (ssget "_X" '((0 . "INSERT") (2 . "BHS_*"))))
    (progn (setq i 0)
      (repeat (sslength ss)
        (setq e (ssname ss i) i (1+ i)
          data (bm:elevation-data e))
        (if data
          (progn
            (bm:set-elevation-data e (car data) suffix)
            (if (and (/= (car data) "") (setq md (bm:smart-text e)))
              (bm:smart-update e
                (bm:type-from-name (cdr (assoc 2 (entget e))))
                (cdr (assoc 1 md)) (cdr (assoc 10 md)))))))))
  suffix)
(defun bm:elevation-local (local / x y)
  (setq x (car local) y (cadr local))
  (if (and (< (abs x) 1e-6) (< y 0.0))
    (list x (- y 7.2) 0.0)
    (list x (+ y 7.2) 0.0)))
(defun bm:smart-definition (typ label local elevation suffix / geom name base n width x y dist ux uy edge enddist elabel geom-scale)
  ;; One outer block: nested symbol geometry plus centered MTEXT/mask.
  ;; ByBlock ink lets the reference color control both text and symbol.
  (setq geom (bm:definition typ nil '((62 . 0)))
    base (strcat "BHS_" (bm:shape-name typ))
    n 1 name (strcat base "_1"))
  (while (tblsearch "BLOCK" name)
    (setq n (1+ n) name (strcat base "_" (itoa n))))
  (setq width (bm:label-width label)
    geom-scale (/ 4.95 (bm:shape-extent typ)))
  (bm:make (list '(0 . "BLOCK") (cons 2 name) '(70 . 0) '(10 0.0 0.0 0.0)))
  (bm:make (append (bm:base "INSERT" '((62 . 0)))
    (list (cons 2 geom) '(10 0.0 0.0 0.0)
      (cons 41 geom-scale) (cons 42 geom-scale) (cons 43 geom-scale))))
  ;; Only oblique text locations need a leader.  Stop at the mask edge.
  (setq x (car local) y (cadr local))
  (if (and (> (abs x) 1e-6) (> (abs y) 1e-6))
    (progn
      (setq dist (sqrt (+ (* x x) (* y y)))
        ux (/ x dist) uy (/ y dist)
        edge (min (/ (* width 0.575) (abs ux))
          (/ 4.0 (abs uy)))
        enddist (- dist edge 0.2))
      (if (> enddist 5.3)
        (bm:make (append (bm:base "LINE" '((62 . 0)))
          (list (cons 10 (list (* 5.2 ux) (* 5.2 uy) 0.0))
            (cons 11 (list (* enddist ux) (* enddist uy) 0.0))))))))
  (bm:make (append (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(8 . "0") '(62 . 0))
    (list '(100 . "AcDbMText") (cons 10 local) '(40 . 5.5)
      (cons 41 width) '(71 . 5) (cons 1 label) (cons 7 (bm:style))
      '(90 . 1) '(63 . 7) '(421 . 16777215) '(45 . 1.045))))
  (if (and elevation (/= elevation ""))
    (progn
      (setq elabel (strcat elevation suffix))
      (bm:make (append (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(8 . "0") '(62 . 0))
        (list '(100 . "AcDbMText") (cons 10 (bm:elevation-local local))
          '(40 . 5.5) (cons 41 (bm:label-width elabel)) '(71 . 5)
          (cons 1 elabel) (cons 7 (bm:style))
          '(90 . 1) '(63 . 7) '(421 . 16777215) '(45 . 1.045))))))
  (bm:make '((0 . "ENDBLK"))) name)
(defun bm:smart-p (e / d)
  (and e (setq d (entget e)) (= (cdr (assoc 0 d)) "INSERT")
    (wcmatch (cdr (assoc 2 d)) "BHS_*")))
(defun bm:smart-text (e / b n d result)
  (if (and (bm:smart-p e)
           (setq b (tblobjname "BLOCK" (cdr (assoc 2 (entget e))))))
    (while (and (not result) (setq n (entnext b)))
      (setq b n d (entget n))
      (if (= (cdr (assoc 0 d)) "MTEXT") (setq result d))))
  result)
(defun bm:smart-update (e typ label local / d name elevation)
  (if (and (bm:smart-p e) (setq d (entget e)))
    (progn
      (setq elevation (bm:elevation-data e)
        name (bm:smart-definition typ label local (car elevation) (cadr elevation)))
      (entmod (subst (cons 2 name) (assoc 2 d) d))
      (entupd e)))
  e)
(defun bm:smart-world (e local / d ins sc rot x y)
  (setq d (entget e) ins (trans (cdr (assoc 10 d)) e 0)
    sc (cdr (assoc 41 d)) rot (cdr (assoc 50 d))
    x (* sc (car local)) y (* sc (cadr local)))
  (list (+ (car ins) (- (* x (cos rot)) (* y (sin rot))))
    (+ (cadr ins) (* x (sin rot)) (* y (cos rot))) (caddr ins)))
(defun bm:smart-local (e world / d ins sc rot x y)
  (setq d (entget e) ins (trans (cdr (assoc 10 d)) e 0)
    sc (cdr (assoc 41 d)) rot (cdr (assoc 50 d))
    x (- (car world) (car ins)) y (- (cadr world) (cadr ins)))
  (list (/ (+ (* x (cos rot)) (* y (sin rot))) sc)
    (/ (+ (* (- x) (sin rot)) (* y (cos rot))) sc) 0.0))
(defun bm:style-one (e sc color / d)
  (if (and (bm:smart-p e) (setq d (entget e)))
    (progn
      (setq d (vl-remove-if
        '(lambda (x) (member (car x) '(62 420 430))) d))
      (setq d (append d color))
      (setq d (bm:dxf-set 41 sc d)
        d (bm:dxf-set 42 sc d)
        d (bm:dxf-set 43 sc d))
      (entmod d) (entupd e)))
  e)
(defun bm:style-selected (pct color / ss i e sc)
  (setq sc (bm:percent-scale (if (and pct (> pct 0.0)) pct 100.0)))
  (princ "\nSelect BH-maker blocks to recolor and resize: ")
  (if (setq ss (ssget '((0 . "INSERT") (2 . "BHS_*"))))
    (progn
      (setq i 0)
      (repeat (sslength ss)
        (setq e (ssname ss i) i (1+ i))
        (bm:style-one e sc color))))
  (princ))
(defun bm:bring-front (e / result)
  ;; Draw order applies to the entire INSERT in its current model/paper space.
  (if (and e (entget e))
    (progn
      (setq result (vl-catch-all-apply 'command-s
        (list "_.DRAWORDER" e "" "_Front")))
      (if (vl-catch-all-error-p result)
        (princ (strcat "\nCould not bring block to front: "
          (vl-catch-all-error-message result))))))
  e)
(defun bm:text-insert (name pt scale color / normal rot d)
  (setq normal (trans '(0.0 0.0 1.0) 1 0 T)
    rot (angle '(0.0 0.0 0.0) (trans '(1.0 0.0 0.0) 1 normal T))
    d (append (list '(0 . "INSERT") (cons 8 (getvar "CLAYER"))
      (cons 2 name) (cons 10 (trans pt 1 normal))
      (cons 41 scale) (cons 42 scale) (cons 43 scale)
      (cons 50 rot) (cons 210 normal)) color))
  (bm:make d)
  (bm:bring-front (entlast)))
(defun c:SST (/ label pct color pt name)
  (setq label (getstring T "\nText <MW2>: "))
  (if (= label "") (setq label "MW2"))
  (initget 6) (setq pct (getreal "\nSize percent <100>: "))
  (if (null pct) (setq pct 100.0))
  (setq color (acad_truecolordlg '(62 . 5) nil))
  (if (setq pt (getpoint "\nClick text center: "))
    (progn (setq name (bm:text-definition label color))
      (bm:text-insert name pt (/ pct 100.0) color)))
  (princ))
(defun bm:insert (name label pt scale color / normal rot d e a)
  (setq normal (trans '(0.0 0.0 1.0) 1 0 T)
    rot (angle '(0.0 0.0 0.0) (trans '(1.0 0.0 0.0) 1 normal T))
    d (append (list '(0 . "INSERT") (cons 8 (getvar "CLAYER"))
      (cons 2 name) '(66 . 1) (cons 10 (trans pt 1 normal))
      (cons 41 scale) (cons 42 scale) (cons 43 scale)
      (cons 50 rot) (cons 210 normal)) color))
  (bm:make d)
  (bm:make (append (bm:base "ATTRIB" color)
    (list (cons 10 (bm:position (cadr (bm:metrics label)) d))
      (cons 40 (* 5.5 scale)) (cons 1 label) '(2 . "NAME") '(70 . 0)
      '(41 . 0.8) '(72 . 1) '(74 . 2)
      (cons 11 (bm:position (cadr (bm:metrics label)) d))
      '(280 . 1) (cons 7 (bm:style)) (cons 50 rot) (cons 210 normal))))
  (bm:make '((0 . "SEQEND")))
  ;; entlast returns the parent INSERT after its attribute sequence closes.
  (setq e (entlast) a (entnext e))
  (if a
    (progn
      (bm:lock a)
      ;; New inserts become mouse-draggable immediately; APPLOAD also
      ;; attaches reactors to symbols already present in the drawing.
      (if (/= (getenv "ACCORECONSOLE") "Y")
        (bm:attach-attribute-reactor e))))
  e)
(defun bm:attribute (e / a)
  (setq a (entnext e))
  (if (and a (= "ATTRIB" (cdr (assoc 0 (entget a))))) a))
(defun bm:valid (e / d)
  (and e (setq d (entget e)) (= (cdr (assoc 0 d)) "INSERT")
    (bm:type-from-name (cdr (assoc 2 d)))))
(defun bm:detach-reactor (e / keep r dat)
  ;; Block redefinition can invalidate an Attribute reactor in AutoCAD LT.
  ;; Remove the reactor for this insert before changing its block name.
  (if *bm-attr-reactors*
    (progn
      (foreach r *bm-attr-reactors*
        (setq dat (vl-catch-all-apply 'vlr-data (list r)))
        (if (and (not (vl-catch-all-error-p dat)) (= (car dat) e))
          (vl-catch-all-apply 'vlr-remove (list r))
          (setq keep (cons r keep))))
      (setq *bm-attr-reactors* (reverse keep))))
  e)
(defun bm:dxf-set (code val d)
  (if (assoc code d)
    (subst (cons code val) (assoc code d) d)
    (append d (list (cons code val)))))
(defun bm:fit (e label / d a ad name)
  (setq d (entget e) a (bm:attribute e))
  (if a
    (progn
      (bm:detach-reactor e)
      ;; A new definition keeps copied references independent.
      (setq name (bm:definition (bm:type-from-name (cdr (assoc 2 d))) label
        (if (assoc 420 d) (list (assoc 420 d)) (list (assoc 62 d))))
        ad (entget a))
      (setq *bm-reactor-busy* T)
      (entmod (subst (cons 2 name) (assoc 2 d) d))
      (setq ad (subst (cons 1 label) (assoc 1 ad) ad)
        ad (subst (cons 10 (bm:position (cadr (bm:metrics label)) d)) (assoc 10 ad) ad))
      (setq ad (bm:dxf-set 11 (bm:position (cadr (bm:metrics label)) d) ad)
        ad (bm:dxf-set 72 1 ad) ad (bm:dxf-set 74 2 ad))
      (entmod ad) (entupd e) (setq *bm-reactor-busy* nil)
      (if (/= (getenv "ACCORECONSOLE") "Y") (bm:attach-attribute-reactor e)))))
(defun bm:change-shape (e typ / d a ad label color name)
  (if (bm:smart-p e)
    (progn
      (setq ad (bm:smart-text e))
      (if ad (bm:smart-update e typ (cdr (assoc 1 ad)) (cdr (assoc 10 ad)))))
    (if (and (bm:valid e) (setq d (entget e)))
    (progn
      (setq a (bm:attribute e)
        label (if a (cdr (assoc 1 (entget a))))
        color (if (assoc 420 d) (list (assoc 420 d))
          (if (assoc 62 d) (list (assoc 62 d)) '((420 . 3104293))))
        name (bm:definition typ label color))
      (if a (bm:detach-reactor e))
      (entmod (subst (cons 2 name) (assoc 2 d) d))
      (if a
        (progn
          (setq ad (entget a)
            ad (subst (cons 10 (bm:position (cadr (bm:metrics label)) d))
              (assoc 10 ad) ad))
          (setq ad (bm:dxf-set 11 (bm:position (cadr (bm:metrics label)) d) ad)
            ad (bm:dxf-set 72 1 ad) ad (bm:dxf-set 74 2 ad))
          (entmod ad)))
      (entupd e))))
  e)
(defun bm:shift-point (p dx dy)
  (list (+ (car p) dx) (+ (cadr p) dy) (if (caddr p) (caddr p) 0.0)))
(defun bm:frame-entity-p (d / typ p ok)
  (setq typ (cdr (assoc 0 d)) ok nil)
  (cond ((= typ "ATTDEF") (setq ok T))
    ((= typ "LWPOLYLINE")
      (foreach x d (if (and (= (car x) 10) (> (cadr (cdr x)) 5.55)) (setq ok T))))
    ((= typ "SOLID")
      (foreach x d (if (and (member (car x) '(10 11 12 13))
                            (> (cadr (cdr x)) 5.55)) (setq ok T)))))
  ok)
(defun bm:shift-definition-frame (name dx dy / b n d out)
  (setq b (tblobjname "BLOCK" name))
  (while (setq b (entnext b))
    (setq d (entget b))
    (if (bm:frame-entity-p d)
      (progn
        (setq out
          (mapcar '(lambda (x)
            (if (and (member (car x) '(10 11 12 13)) (listp (cdr x)))
              (cons (car x) (bm:shift-point (cdr x) dx dy)) x)) d))
        (entmod out))))
  (entupd (tblobjname "BLOCK" name)) name)
(defun bm:shift-frame-world (e vx vy / d a label typ color rot sc dx dy name)
  ;; Shift only the frame geometry.  This is safe to call from an
  ;; attribute reactor because it does not modify the reactor owner.
  (if (and (bm:valid e) (setq d (entget e)) (setq a (bm:attribute e)))
    (progn
      (setq label (cdr (assoc 1 (entget a)))
        typ (bm:type-from-name (cdr (assoc 2 d)))
        color (if (assoc 420 d) (list (assoc 420 d))
          (if (assoc 62 d) (list (assoc 62 d)) '((420 . 3104293))))
        rot (cdr (assoc 50 d)) sc (cdr (assoc 41 d))
        dx (/ (+ (* vx (cos rot)) (* vy (sin rot))) sc)
        dy (/ (+ (* (- vx) (sin rot)) (* vy (cos rot))) sc)
        name (bm:definition typ label color))
      (bm:shift-definition-frame name dx dy)
      (entmod (subst (cons 2 name) (assoc 2 d) d))
      (entupd e)
      (list dx dy))))
(defun bm:move-frame (e v1 v2 / d a label result vx vy dx dy ad)
  (if (and (bm:valid e) (setq d (entget e)) (setq a (bm:attribute e)))
    (progn
      (setq label (cdr (assoc 1 (entget a)))
        vx (- (car v2) (car v1)) vy (- (cadr v2) (cadr v1))
        result (bm:shift-frame-world e vx vy))
      (if result
        (progn
          (setq dx (car result) dy (cadr result) ad (entget a)
            ad (subst (cons 10 (bm:position
              (bm:shift-point (cadr (bm:metrics label)) dx dy) d))
              (assoc 10 ad) ad))
          (setq *bm-reactor-busy* T)
          (entmod ad) (bm:lock a) (entupd e)
          (setq *bm-reactor-busy* nil)))))
  e)
(defun c:SSX (/ *error* typ label pct pt color name)
  (defun *error* (msg) (if (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*")) (princ (strcat "\n" msg))) (princ))
  (princ "\nChoose a shape by number (1-8) or full shape name.")
  (setq typ (bm:prompt-type))
  (setq label (getstring T "\nName <MW2>: "))
  (if (= label "") (setq label "MW2"))
  (initget 6) (setq pct (getreal "\nSize percent (100=outer radius 2 drawing units) <100>: "))
  (if (null pct) (setq pct 100.0))
  ;; Start the color dialog on the AutoCAD Index tab (ACI blue default).
  (setq color (acad_truecolordlg '(62 . 5) nil))
  (bm:place typ label pct color "up" nil (bm:current-suffix) nil nil)
  (princ))
(defun c:BMSYM () (c:SSX))
(defun c:SSC (/ ss typ name i e)
  (setq typ (bm:prompt-type))
  (bm:convert typ))
(defun c:SS (/ choice op typ label pct color position picked elevation suffix
               auto-name auto-format start-number)
  ;; Single remembered command: choose the operation and shape by mouse.
  (if (setq choice (bm:show-dialog))
    (progn
      (setq op (car choice) typ (cadr choice) label (nth 2 choice)
        pct (nth 3 choice) color (nth 4 choice)
        position (nth 5 choice)
        elevation (if (= (nth 6 choice) "1") "")
        suffix (nth 7 choice)
        auto-name (nth 9 choice)
        auto-format (nth 10 choice))
      (if (/= suffix (bm:current-suffix))
        (bm:update-global-suffix suffix))
      (if (and (= op "place")
               (not *bm-dialog-color-picked*))
        (progn
          (setq picked (bm:choose-color '((62 . 5))))
          (if picked (setq color picked))))
      (cond
        ((= op "place")
          (if (and (= auto-name "1") (member typ '(1 2)))
            (progn
              (setq auto-format (bm:auto-format typ auto-format)
                start-number (bm:prompt-start-number auto-format))
              (if start-number
                (bm:place typ (bm:auto-label auto-format start-number)
                  pct color position elevation suffix auto-format start-number)))
            (bm:place typ label pct color position elevation suffix nil nil)))
        ((= op "convert") (bm:convert typ))
        ((= op "edit")
          (bm:edit-text position (nth 6 choice) "" (nth 8 choice) suffix))
        ((= op "fit") (c:BMFIT))))
    (princ "\nOperation cancelled."))
  (princ))
(defun c:BMS () (c:SS))
(defun bm:frame-local-center (name / b d mnx mxx mny mxy p)
  ;; Read the actual frame rectangle so SSM also works after a previous
  ;; frame move.  The lower shape LWPOLYLINEs are ignored by the y test.
  (setq b (tblobjname "BLOCK" name))
  (while (setq b (entnext b))
    (setq d (entget b))
    (if (and (= (cdr (assoc 0 d)) "LWPOLYLINE") (bm:frame-entity-p d))
      (foreach x d
        (if (= (car x) 10)
          (progn
            (setq p (cdr x))
            (if (or (null mnx) (< (car p) mnx)) (setq mnx (car p)))
            (if (or (null mxx) (> (car p) mxx)) (setq mxx (car p)))
            (if (or (null mny) (< (cadr p) mny)) (setq mny (cadr p)))
            (if (or (null mxy) (> (cadr p) mxy)) (setq mxy (cadr p))))))))
  (if mnx
    (list (/ (+ mnx mxx) 2.0) (/ (+ mny mxy) 2.0) 0.0)
    '(0.0 9.6 0.0)))
(defun bm:frame-center (e / d)
  (setq d (entget e))
  (bm:position (bm:frame-local-center (cdr (assoc 2 d))) d))
(defun bm:on-attribute-modified (owner reactor params / *error* a data e old new vx vy)
  ;; Dragging the attribute grip moves the frame by the same WCS vector.
  ;; Reactor data stores the last known attribute position.
  (defun *error* (msg) (setq *bm-reactor-busy* nil) (princ))
  (if (and owner reactor (not *bm-reactor-busy*))
    (progn
      (setq a (vl-catch-all-apply 'vlax-vla-object->ename (list owner))
        data (vlr-data reactor) e (car data) old (cadr data)
        new (if (and a (not (vl-catch-all-error-p a)))
          (cdr (assoc 10 (entget a)))))
      (if (and e old new (> (distance old new) 1e-8) (bm:valid e))
        (progn
          (setq vx (- (car new) (car old)) vy (- (cadr new) (cadr old))
            *bm-reactor-busy* T)
          (bm:shift-frame-world e vx vy)
          (setq *bm-reactor-busy* nil)
          (vlr-data-set reactor (list e new)))))
  reactor))
(defun bm:attach-attribute-reactor (e / a o r old)
  (if (and (/= (getenv "ACCORECONSOLE") "Y") (bm:valid e) (setq a (bm:attribute e))
           (setq o (vl-catch-all-apply 'vlax-ename->vla-object (list a)))
           (not (vl-catch-all-error-p o)))
    (progn
      (bm:lock a)
      (setq old (cdr (assoc 10 (entget a)))
        r (vl-catch-all-apply 'vlr-object-reactor
          (list (list o) (list e old)
            '((:vlr-modified . bm:on-attribute-modified))))
        )
      (if (and r (not (vl-catch-all-error-p r)))
        (progn (if (not *bm-attr-reactors*) (setq *bm-attr-reactors* nil))
          (setq *bm-attr-reactors* (cons r *bm-attr-reactors*)))))
  e))
(defun bm:install-attribute-reactors (/ ss i e)
  ;; Reloading the LSP must not attach a second callback to the same
  ;; attribute; duplicate callbacks would move the frame twice.
  (if (and (/= (getenv "ACCORECONSOLE") "Y") *bm-attr-reactors*)
    (progn
      (foreach r *bm-attr-reactors*
        (vl-catch-all-apply 'vlr-remove (list r)))
      (setq *bm-attr-reactors* nil)))
  (if (not *bm-attr-reactors*) (setq *bm-attr-reactors* nil))
  (if (setq ss (ssget "_X" '((0 . "INSERT") (2 . "BMS_*"))))
    (progn (setq i 0)
      (repeat (sslength ss)
        (setq e (ssname ss i) i (1+ i))
        (if (bm:valid e) (bm:attach-attribute-reactor e)))))
  (princ))
(defun bm:move-text (position / e md p2 local)
  (setq e (car (entsel "\nSelect BH-maker block: ")))
  (if (and (bm:smart-p e) (setq md (bm:smart-text e)))
    (progn
      (if (member position '("up" "right" "down" "left"))
        (setq local (bm:position-local position (cdr (assoc 1 md))))
        (progn
          (setq p2 (getpoint
            (trans (bm:smart-world e (cdr (assoc 10 md))) 0 1)
            "\nClick new text center (symbol stays fixed): "))
          (if p2 (setq local (bm:smart-local e (trans p2 1 0))))))
      (if local
        (bm:smart-update e
          (bm:type-from-name (cdr (assoc 2 (entget e))))
          (cdr (assoc 1 md)) local)))
    (princ "\nSelect a BH-maker smart block."))
  (princ))
(defun c:SSM () (bm:move-text "custom"))
(defun bm:edit-text (position show elevation touched suffix / *error* e a d label name color local p2 oldraw)
  (defun *error* (msg) (princ (strcat "\n" msg)) (princ))
  (setq e (car (entsel "\nSelect text/background block: ")))
  (cond
    ((bm:smart-p e)
      (setq d (bm:smart-text e))
      (setq label (getstring T (strcat "\nNew name <" (cdr (assoc 1 d)) ">: ")))
      (if (or (null label) (= label ""))
        (setq label (cdr (assoc 1 d))))
      (setq local (cdr (assoc 10 d)))
      (cond
        ((= position "custom")
          (setq p2 (getpoint (trans (bm:smart-world e local) 0 1)
            "\nClick new text center; Enter keeps current: "))
          (if p2 (setq local (bm:smart-local e (trans p2 1 0)))))
        ((/= position "keep")
          (setq local (bm:position-local position label))))
      (if touched
        (progn
          (setq oldraw (car (bm:elevation-data e)))
          (if (= show "1")
            (progn
              (setq elevation (bm:prompt-elevation label
                (if (and oldraw (/= oldraw "")) oldraw "")))
              (bm:set-elevation-data e elevation suffix))
            (bm:set-elevation-data e "" suffix))))
      (bm:smart-update e
        (bm:type-from-name (cdr (assoc 2 (entget e))))
        label local))
    ((and e (setq d (entget e))
          (wcmatch (cdr (assoc 2 d)) "BMT_TEXT_*"))
      (setq a (entnext (tblobjname "BLOCK" (cdr (assoc 2 d)))))
      (setq label (getstring T (strcat "\nNew name <" (cdr (assoc 1 (entget a))) ">: ")))
      (if (/= label "")
        (progn
          (setq color (if (assoc 420 d) (list (assoc 420 d))
            (if (assoc 62 d) (list (assoc 62 d)) '((62 . 5)))))
          (setq name (bm:text-definition label color))
          (entmod (subst (cons 2 name) (assoc 2 d) d))
          (entupd e))))
    ((and (bm:valid e) (setq a (bm:attribute e)))
      (setq label (getstring T (strcat "\nNew name <" (cdr (assoc 1 (entget a))) ">: ")))
      (if (/= label "") (bm:fit e label)))
    (T (princ "\nSelect a BH-maker text block.")))
  (princ))
(defun c:BMEDIT () (bm:edit-text "keep" "0" "" nil (bm:current-suffix)))
(defun c:BMFIT (/ ss i e a md)
  (princ "\nSelect BH-maker blocks to fit text backgrounds: ")
  (if (setq ss (ssget '((0 . "INSERT"))))
    (progn (setq i 0)
      (repeat (sslength ss)
        (setq e (ssname ss i) i (1+ i))
        (cond
          ((and (bm:smart-p e) (setq md (bm:smart-text e)))
            (bm:smart-update e
              (bm:type-from-name (cdr (assoc 2 (entget e))))
              (cdr (assoc 1 md)) (cdr (assoc 10 md))))
          ((and (bm:valid e) (setq a (bm:attribute e)))
            (bm:fit e (cdr (assoc 1 (entget a)))))))))
  (princ))
(defun c:SSF () (c:BMFIT))
;; Older reactors are removed on reload; smart blocks need none.
(if *bm-attr-reactors*
  (progn
    (foreach r *bm-attr-reactors* (vl-catch-all-apply 'vlr-remove (list r)))
    (setq *bm-attr-reactors* nil)))
;; Hide grips of nested SOLID pieces.  Otherwise AutoCAD displays one grip
;; for every segment used to approximate a filled circle.  The block keeps
;; its single main grip; SSM remains available for precise text/frame moves.
(if (numberp (getvar "GRIPBLOCK")) (setvar "GRIPBLOCK" 0))
(princ "\nBH-maker ver1.23 loaded | SS = smart block menu")
(princ)