---

;; ============================================================
;; NVK_COORDS.LSP  v3.7
;; Кодировка: ANSI (CP1251). Блокнот -> Сохранить как -> ANSI
;; Команда: NVKCOORD
;; ============================================================
(vl-load-com)

;; ==================== НАСТРОЙКИ ====================
(setq NVK-LAYER      "НВК_Координаты точек")
(setq NVK-BLOCK-NAME "НВК_Координаты")
(setq NVK-SEARCH-R   2.0)
(setq NVK-PT-DIAM    0.5)
(setq NVK-TXT-HEIGHT 1.0)
(setq NVK-TXT-OFFSET 0.8)
(setq NVK-IDW-K      2.0)
(setq NVK-ZERO-EPS   0.001)
(setq NVK-MAX-PTS    7)
(setq NVK-TEXT-STYLE "Arial")

;; ==================== ВСПОМОГАТЕЛЬНЫЕ ====================
(defun nvk:doc () (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun nvk:ms  () (vla-get-ModelSpace (nvk:doc)))
(defun nvk:p2d (p) (list (car p) (cadr p)))
(defun nvk:wcs (p) (trans p 1 0))   ; UCS -> WCS
(defun nvk:mcs (p) (trans p 0 1))   ; WCS -> UCS (для entmake)

(defun nvk:rtos2 (v / s)
  (setq s (vl-string-subst "," "." (rtos (abs v) 2 2)))
  (strcat (if (minusp v) "-" "+") s))

(defun nvk:fmt-x (v) (strcat "X= " (nvk:rtos2 v)))
(defun nvk:fmt-y (v) (strcat "Y= " (nvk:rtos2 v)))
(defun nvk:fmt-z (v) (strcat "Z= " (nvk:rtos2 v)))

;; Очистка от RTF/MTEXT кодов
(defun nvk:clean (s / i c res skip)
  (if (null s) (setq s ""))
  (setq res "" i 0 skip 0)
  (while (< i (strlen s))
    (setq c (substr s (1+ i) 1))
    (cond ((= c "{") (setq skip (1+ skip)))
          ((= c "}") (setq skip (max 0 (1- skip))))
          ((= skip 0) (setq res (strcat res c))))
    (setq i (1+ i)))
  (setq res (vl-string-subst "" "\\P" res))
  (setq res (vl-string-subst "" "\\p" res))
  (vl-string-trim " " res))

(defun nvk:numstr-p (s / t2)
  (and s (> (strlen s) 0)
       (progn (setq t2 (vl-string-trim " " (nvk:clean s)))
              (> (strlen t2) 0))
       (not (vl-catch-all-error-p
             (vl-catch-all-apply 'distof
               (list (vl-string-subst "." "," t2) 2))))))

(defun nvk:str->num (s)
  (distof (vl-string-subst "." "," (vl-string-trim " " (nvk:clean s))) 2))

(defun nvk:ensure-layer (/ lc lay)
  (setq lc (vla-get-Layers (nvk:doc)))
  (if (tblsearch "LAYER" NVK-LAYER)
    (setq lay (vla-Item lc NVK-LAYER))
    (setq lay (vla-Add lc NVK-LAYER)))
  (if (= (vla-get-Color lay) 7) (vla-put-Color lay 1)))

(defun nvk:ensure-style (/ sc sty)
  (setq sc (vla-get-TextStyles (nvk:doc)))
  (if (tblsearch "STYLE" NVK-TEXT-STYLE)
    (setq sty (vla-Item sc NVK-TEXT-STYLE))
    (setq sty (vla-Add sc NVK-TEXT-STYLE)))
  (vl-catch-all-apply 'vla-put-FontFile (list sty "arial.ttf")))

;; ==================== МАРКЕР ====================
(defun nvk:draw-marker (pwcs / r cx cy da rm i a1 a2 pm)
  ;; pwcs - точка в МСК (WCS)
  ;; Для entmake нужны координаты в текущей ПСК
  (setq pm (nvk:mcs pwcs)
        cx (car pm) cy (cadr pm)
        r  (/ NVK-PT-DIAM 2.0)
        da (/ (* 2.0 pi) 8.0)
        rm (* r 0.98) i 0)
  (entmake (list '(0 . "CIRCLE") (cons 8 NVK-LAYER)
                 '(62 . 256) '(6 . "BYLAYER")
                 (cons 10 (list cx cy 0.0)) (cons 40 r)))
  (repeat 8
    (setq a1 (* i da) a2 (* (1+ i) da) i (1+ i))
    (entmake (list '(0 . "SOLID") (cons 8 NVK-LAYER) '(62 . 256) '(6 . "BYLAYER")
                   (cons 10 (list (+ cx (* rm (cos a1))) (+ cy (* rm (sin a1))) 0.0))
                   (cons 11 (list (+ cx (* rm (cos a2))) (+ cy (* rm (sin a2))) 0.0))
                   (cons 12 (list cx cy 0.0))
                   (cons 13 (list cx cy 0.0))))))

;; ==================== MTEXT горизонтально в МСК ====================
;; group 11 = вектор X-направления текста В МСК
;; group 10 = точка вставки В МСК (WCS coords для entmake при extrusion 001)
;; ВАЖНО: при (210 . (0 0 1)) - стандартная экструзия МСК,
;;        group 10 и 11 задаются в МСК напрямую

(defun nvk:mtext-str (x y z)
  (if z
    (strcat (nvk:fmt-x y) "\\P" (nvk:fmt-y x) "\\P" (nvk:fmt-z z))
    (strcat (nvk:fmt-x y) "\\P" (nvk:fmt-y x))))

(defun nvk:add-mtext (pwcs x y z / ins en)
  ;; ins - точка над маркером В МСК
  (setq ins (list (car pwcs)
                  (+ (cadr pwcs) (/ NVK-PT-DIAM 2.0) NVK-TXT-OFFSET)
                  0.0))
  (setq en (entmakex (list
    (cons 0 "MTEXT")
    (cons 100 "AcDbEntity")
    (cons 8 NVK-LAYER)
    (cons 62 256)
    (cons 100 "AcDbMText")
    (cons 10 ins)                  ; вставка в МСК
    (cons 40 NVK-TXT-HEIGHT)
    (cons 41 0.0)
    (cons 71 1)
    (cons 72 5)
    (cons 1 (nvk:mtext-str x y z))
    (cons 7 NVK-TEXT-STYLE)
    (cons 210 '(0.0 0.0 1.0))     ; нормаль = ось Z МСК
    (cons 11 '(1.0 0.0 0.0))      ; X-вектор = горизонталь МСК
    (cons 90 3)
    (cons 45 1.1)
    (cons 63 256)
  )))
  en)

(defun nvk:update-mtext (en x y z / ed)
  (if (and en (entget en))
    (progn
      (setq ed (entget en))
      (setq ed (subst (cons 1 (nvk:mtext-str x y z)) (assoc 1 ed) ed))
      (entmod ed) (entupd en))))

;; ==================== БЛОК ====================
;; Минимальная структура ATTDEF без subclass - надёжнее работает

(defun nvk:make-block-def (/)
  (if (not (tblsearch "BLOCK" NVK-BLOCK-NAME))
    (progn
      (entmake (list '(0 . "BLOCK") (cons 2 NVK-BLOCK-NAME) '(70 . 0) '(10 0.0 0.0 0.0)))
      (foreach tag '("X_COORD" "Y_COORD" "Z_COORD")
        (entmake (list
          '(0 . "ATTDEF")
          (cons 8 NVK-LAYER)
          '(10 0.0 0.0 0.0)
          (cons 40 NVK-TXT-HEIGHT)
          '(1 . "")
          (cons 7 NVK-TEXT-STYLE)
          (cons 2 tag)
          (cons 3 tag)
          '(70 . 1)               ; невидимый
        )))
      (entmake '((0 . "ENDBLK"))))))

(defun nvk:insert-block (pwcs / br)
  ;; InsertBlock принимает точку в МСК
  (setq br (vla-InsertBlock (nvk:ms)
             (vlax-3d-point pwcs) NVK-BLOCK-NAME 1.0 1.0 1.0 0.0))
  (vla-put-Layer br NVK-LAYER)
  br)

(defun nvk:set-att (br tag val)
  (if (= :vlax-true (vla-get-HasAttributes br))
    (foreach a (vlax-safearray->list (vlax-variant-value (vla-GetAttributes br)))
      (if (= (strcase (vla-get-TagString a)) (strcase tag))
        (vla-put-TextString a val)))))

;; ==================== ПОИСК ОБЪЕКТОВ ====================
;; ssget "_X" с фильтром по пространству - работает на заблокированных слоях

(defun nvk:obj-pt (en / obj ip bb mn mx)
  (setq obj (vl-catch-all-apply 'vlax-ename->vla-object (list en)))
  (if (vl-catch-all-error-p obj) (setq obj nil))
  (if obj
    (cond
      ((vlax-property-available-p obj 'InsertionPoint)
       (trans (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint obj))) 0 0))
      ((and (vlax-method-applicable-p obj 'GetBoundingBox)
            (not (vl-catch-all-error-p
                  (vl-catch-all-apply 'vla-GetBoundingBox (list obj 'mn 'mx)))))
       (setq mn (vlax-safearray->list mn) mx (vlax-safearray->list mx))
       (mapcar '(lambda (a b) (/ (+ a b) 2.0)) mn mx))
      (t nil))
    nil))

(defun nvk:vals-from-en (en / obj nm s out z)
  (setq obj (vl-catch-all-apply 'vlax-ename->vla-object (list en)))
  (if (vl-catch-all-error-p obj) (setq obj nil))
  (setq out '())
  (if obj
    (progn
      (setq nm (vla-get-ObjectName obj))
      (cond
        ;; Блок с атрибутами
        ((and (= nm "AcDbBlockReference")
              (= :vlax-true (vla-get-HasAttributes obj)))
         (foreach a (vlax-safearray->list (vlax-variant-value (vla-GetAttributes obj)))
           (setq s (vla-get-TextString a))
           (if (nvk:numstr-p s)
             (setq out (cons (list (nvk:str->num s)
                               (strcat (vla-get-TagString a) "=" (nvk:clean s)))
                             out)))))
        ;; Текст / MTEXT
        ((member nm '("AcDbText" "AcDbMText"))
         (setq s (vla-get-TextString obj))
         (if (nvk:numstr-p s)
           (setq out (list (list (nvk:str->num s) (strcat "Текст=" (nvk:clean s)))))))
      )))
  out)

(defun nvk:pick-value (pick / tab ss i en p dist all cands msg idx)
  (setq tab  (getvar "CTAB")
        all  '())
  ;; ssget "_X" - работает на заблокированных слоях, фильтр по пространству
  (setq ss (ssget "_X" (list (cons 410 tab))))
  (if ss
    (progn
      (setq i 0)
      (repeat (sslength ss)
        (setq en (ssname ss i)
              p  (nvk:obj-pt en))
        (if p
          (progn
            (setq dist (distance (list (car pick) (cadr pick))
                                  (list (car p)   (cadr p))))
            (if (<= dist NVK-SEARCH-R)
              (foreach v (nvk:vals-from-en en)
                (setq all (cons (list dist (car v) (cadr v)) all))))))
        (setq i (1+ i)))))
  (setq all (vl-sort all '(lambda (a b) (< (car a) (car b)))))
  (cond
    ((null all) nil)
    ((= (length all) 1) (cadr (car all)))
    (t
     (setq msg "Найдено несколько значений:\n\n" idx 1)
     (foreach item all
       (setq msg (strcat msg (itoa idx) ". " (caddr item)
                         "  расст.=" (rtos (car item) 2 2) "\n")
             idx (1+ idx)))
     (alert msg)
     (initget 6)
     (setq idx (getint (strcat "\nНомер [1-" (itoa (length all)) "]: ")))
     (if (and idx (>= idx 1) (<= idx (length all)))
       (cadr (nth (1- idx) all)) nil))))

;; ==================== IDW ====================
(defun nvk:idw (base pts / num den d z)
  (setq num 0.0 den 0.0)
  (foreach p pts
    (setq d (distance (nvk:p2d base) (nvk:p2d p))
          z (caddr p))
    (if (< d NVK-ZERO-EPS)
      (progn (setq num z den 1.0) (setq pts nil))
      (progn (setq num (+ num (/ z (expt d NVK-IDW-K))))
             (setq den (+ den (/ 1.0 (expt d NVK-IDW-K)))))))
  (if (> den 0.0) (/ num den)))

;; ==================== ГЛАВНАЯ КОМАНДА ====================
(defun c:NVKCOORD (/ *error* olde olderr basew baseucs br mt-en pts done pick zval zw xw yw)
  (defun *error* (msg)
    (if olde   (setvar "CMDECHO"   olde))
    (if olderr (setvar "ERRNO"     0))
    (if (and msg (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nОшибка: " msg)))
    (princ))
  (setq olde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (nvk:ensure-layer)
  (nvk:ensure-style)
  (nvk:make-block-def)
  ;; Получаем точку в ПСК, конвертируем в МСК
  (setq baseucs (getpoint "\nУкажите базовую точку: "))
  (if baseucs
    (progn
      (setq basew  (nvk:wcs baseucs)   ; МСК (WCS)
            xw     (car  basew)
            yw     (cadr basew))
      (nvk:draw-marker basew)
      (setq br    (nvk:insert-block basew))
      (setq mt-en (nvk:add-mtext basew xw yw nil))
      (nvk:set-att br "X_COORD" (nvk:fmt-x yw))
      (nvk:set-att br "Y_COORD" (nvk:fmt-y xw))
      (nvk:set-att br "Z_COORD" "")
      (if (null mt-en) (princ "\n[НВК] Предупреждение: MTEXT не создан"))
      (if (null br)    (princ "\n[НВК] Предупреждение: блок не создан"))
      (setq pts '() done nil)
      (while (not done)
        (setq pick (getpoint "\nESC - завершить, укажите соседнюю точку: "))
        (cond
          ((null pick) (setq done T))
          (t
           (setq pick (nvk:wcs pick)   ; конвертируем в МСК
                 zval (nvk:pick-value pick))
           (cond
             ((null zval)
              (princ (strcat "\n[НВК] Не найдено в радиусе " (rtos NVK-SEARCH-R 2 1) " ед.")))
             (t
              (setq pts (append pts (list (list (car pick) (cadr pick) zval))))
              (princ (strcat "\n[НВК] Z=" (rtos zval 2 3) "  (точек: " (itoa (length pts)) ")"))
              (if (>= (length pts) 2)
                (progn
                  (setq zw (nvk:idw basew pts))
                  (nvk:update-mtext mt-en xw yw zw)
                  (nvk:set-att br "Z_COORD" (nvk:fmt-z zw))
                  (princ (strcat "  Z_IDW=" (rtos zw 2 3)))))
              (if (>= (length pts) NVK-MAX-PTS) (setq done T)))))))
      (if br (vla-Update br))))
  (setvar "CMDECHO" olde)
  (princ))

(princ "\nНВК_Координаты v3.7 загружена. Команда: NVKCOORD")
(princ)