Поиск блоков, совпадающих в плане

24.02.2025, 10:05

Задача такая: в чертеже имеется более 10 000 блоков "Picket". Некоторые из них наложены друг на друга в плане (по координатам X и Y, по координате Z могут совпадать, могут не совпадать). Надо найти совпадающие и отметить их в чертеже. Я в лоб написал лисп. С поставленной задачей справляется, но работает медленно. Может надо как-то по другому?

Код:

[Выделить все]

 (defun c:del_pk (/ ss n i k q p1 p2 dist)
 (setq ss (ssget "_X" '((0 . "INSERT") (2 . "PICKET"))))
 (setq n   (1- (sslength ss))
       i   0
       k   0
       q   0
       sss (ssadd)
 )
 (while (< i n)
  (setq p1 (reverse (cdr (reverse (cdr (assoc 10 (entget (ssname ss i))))))))
  (while (< k n)
   (setq p2  (reverse (cdr (reverse (cdr (assoc 10 (entget (ssname ss (setq k (1+ k)))))))))
         dist (distance pk1 pk2)
   )
   (if (< dist 0.1)
    (progn (setq q (1+ q))
           (entmakex (list (cons 0 "CIRCLE")
                           (cons 8 "0")
                           (cons 10 pk2)
                           (cons 40 15)
                           (cons 62 6)
                           (cons 370 50)
                     )
           )
    )
   )
  )
  (setq i (1+ i)
        k i
  )
 )
 (alert (strcat "Отмечено пикетов " (itoa q)))
)

На прилагаемом чертеже в красном квадрате отмечены красными кругами три совпадения.

Кулик Алексей aka kpblc · 05.03.2025, 09:37

Как минимум - в объявлении функции. "/" должен отделяться пробелами с обеих сторон.

1958 · 05.03.2025, 11:51

Цитата:

Сообщение от Кулик Алексей aka kpblc

"/" должен отделяться пробелами с обеих сторон.

Ну, да. Добавил пробел. (defun c:22 (/ selset source), ничего не изменилось. Error: слишком мало аргументов
Где в другом месте собака порылась.

===AAA=== · 05.03.2025, 15:42

А здесь две скобки зачем?

((lambda ...

Linkshunter · 05.03.2025, 16:33

Цитата:

Сообщение от 1958

Правильно. Это мне и надо - из группы совпадающих по координатам (с четом точности) блоков оставить один, остальные удалить. Какой оставить - роли не играет.

Стандартная команда "подчистить"+"быстрый выбор" и/или "фильтр"
***
если повернуть Ваш файл в 3д , сразу видно какие отметки вылетают из диапазона высот. Их можно удалить рамкой. Заодно будет понятно что блок собран "своеобразно" (отметка текста и отметка точки разнесены по оси Z)
***
еще вспомнил про _mapclean

Кулик Алексей aka kpblc · 05.03.2025, 16:39

Цитата:

Сообщение от ===AAA===

А здесь две скобки зачем?

((lambda ...

Для автоматического выполнения анонимной функции

----- добавлено через ~2 мин. -----
Тема плавно переходит в разряд дубля "Научите лиспу на примере..."

===AAA=== · 05.03.2025, 18:14

Цитата:

Error: слишком мало аргументов
Где ошибка? Сам додуматься не могу!

Здесь?

(trans (cdr (assoc 10 (entget x)) 1 0))

1958 · 05.03.2025, 18:39

Цитата:

Сообщение от Linkshunter

если повернуть Ваш файл в 3д , сразу видно какие отметки вылетают из диапазона высот.

Среди ~15-20тыс. отметок найти вылетающие из диапазона 0.1 м - это каким же глазастым надо быть?

Цитата:

Сообщение от Кулик Алексей aka kpblc

Тема плавно переходит в разряд дубля "Научите лиспу на примере..."

Согласен. Может вы, как модератор, перенесете её туда?

Цитата:

Сообщение от ===AAA===

Здесь?

(trans (cdr (assoc 10 (entget x)) 1 0))

Подправил, результат тот же.

Код:

[Выделить все]

 (trans (cdr (assoc 10 (entget x))) 1 0)

koMon · 05.03.2025, 20:22

Цитата:

Сообщение от 1958

результат тот же.

как mapcar может сработать если есть функция, ooooчень сомнительная и НЕТ списка? поэтому и аргументов не хватает. этот кусок лиспа просто шедеврален по своей бессвязности)
ведь очевидно, что должно быть как-то так

Код:

[Выделить все]

 
(if (setq insert_sset (ssget "_X" '((0 . "INSERT") (2 . "PICKET") (67 . 0))))
	(setq source (mapcar '(lambda (ename) (cons (mapcar '+ '(0 0) (trans (cdr (assoc 10 (entget ename))) 1 0)) ename))
			      (vl-remove-if 'listp (mapcar 'cadr (ssnamex insert_sset)))
		     )
	)
)

Кулик Алексей aka kpblc · 05.03.2025, 20:25

Offtop: Ну блин, я ж сразу сказал, что писал насухую, без проверок. ЕМНИП, вообще чуть ли не с телефона.

1958 · 05.03.2025, 21:20

Цитата:

Сообщение от koMon

должно быть как-то так

!!!

engngr · 05.03.2025, 23:36

Цитата:

Сообщение от 1958

10 000 блоков "Picket"

Цитата:

Сообщение от 1958

удалить дубликаты

Зачем так измываться над съемкой? цель какая?

1958 · 06.03.2025, 04:51

Цитата:

Сообщение от engngr

Зачем так измываться над съемкой? цель какая?

Мне часто приходится обрабатывать данные так называемой "Съемки". В свое время такие "съемки" сразу объявлялись браком. Теперь условия изменились, появились "специалисты", с гордостью нажимающие кнопки и объявляющие себя "геодезистами". Так вот, на предоставляемых ими "съемках" попадаются моменты, когда в одной точке наложены 2-5 пикетов. Если высоты этих пикетов отличаются незначительно, построение поверхности из 3д-граней вылетает. Ну, а если (бывает и такое) разброс высот достигает 10 м и более, то совсем швах. Так что цель одна - убрать лишнее.

1958 · 06.03.2025, 12:31

Строго не судите. Наверно, можно как-то оптимизировать. Может кто подскажет?

Код:

[Выделить все]

 (defun c:22 (/ insert_sset source pt_list ent i)
 (vl-load-com)
 (if (setq insert_sset (ssget "_X" '((0 . "INSERT") (2 . "PICKET") (67 . 0))))
  (progn (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
         (setq
          source (mapcar '(lambda (ename)
                           (cons (mapcar '+ '(0 0 0) (trans (cdr (assoc 10 (entget ename))) 1 0)) ename)
                          )
                         (vl-remove-if 'listp (mapcar 'cadr (ssnamex insert_sset)))
                 ) ;_ end of mapcar
         ) ;_ end of setq         
         (setq source (vl-sort source (function (lambda (a b) (< (cadr (nth 0 a)) (cadr (nth 0 b)))))))
         (setq source (vl-sort source (function (lambda (a b) (< (car (nth 0 a)) (car (nth 0 b)))))))
         (setq source (vl-sort source (function (lambda (a b) (< (last (nth 0 a)) (last (nth 0 b)))))))
         (while source
          (if (and (cdr source)
                   (equal (car (car source)) (car (cadr source)) 0.1)
                   (not (equal (car (car source)) (car (car pt_list)) 0.1))
              ) ;_ end of and
           (progn (setq pt_list (cons (car source) pt_list))) ;_ end of progn
          ) ;_ end of if
          (setq source (cdr source))
         ) ;_ end of while
         (vla-endundomark adoc)
  ) ;_ end of progn
 ) ;_ end of if
 (setq i 0)
 (if pt_list
  (while (< i (length pt_list))
   (setq ent (cdr (nth i pt_list)))
   (entdel ent)
   (setq i (1+ i))
  ) ;_ end of while
 ) ;_ end of if
) ;_ end of defun

----- добавлено через ~4 мин. -----

Цитата:

Сообщение от Кулик Алексей aka kpblc

Ну блин, я ж сразу сказал, что писал насухую, без проверок. ЕМНИП, вообще чуть ли не с телефона.

Алексей, самое главное, что вы указали нужное направление. А уж как я это попытался реализовать, тут вы ни причём.

koMon · 06.03.2025, 14:14

07 (cons (mapcar '+ '(0 0 0) (trans (cdr (assoc 10 (entget ename))) 1 0)) ename)
если нужны 3d координаты, то (mapcar '+ '(0 0 0)... не нужна, она ничего не изменит, в предыдущем варианте координаты с её помощью приводились к 2d
то есть должно стать
07 (cons (trans (cdr (assoc 10 (entget ename))) 1 0) ename)

1958 · 06.03.2025, 15:10

Цитата:

Сообщение от koMon

то есть должно стать
07 (cons (trans (cdr (assoc 10 (entget ename))) 1 0) ename)

Спасибо!

koMon · 07.03.2025, 09:50

Сергей812,
почему с вашим каждым приходом в тему, имеющую отношение только к лиспу мы всенепременно ежекаждый раз скатываемся в .net? это ведь какбэ совсем другое)))

----- добавлено через ~5 мин. -----
1958,
а как вообще нужно сравнивать блоки. по заголовку вроде как в плане, то есть 2d?

1958 · 07.03.2025, 10:34

Цитата:

Сообщение от koMon

а как вообще нужно сравнивать блоки. по заголовку вроде как в плане, то есть 2d?

Была задача найти дубли блоков и пометить их. Кулик Алексей aka kpblc написал прекрасный код. И подумал, что можно как-то этот код переделать для удаления лишних блоков, а маркировку оставить для блоков, совпадающих в плане, но отличающихся по высоте - тут выбор за пользователем, что оставить, что удалить.

koMon · 07.03.2025, 15:24

Цитата:

Сообщение от 1958

как-то этот код переделать для удаления лишних блоков

вот например можно так

Код:

[Выделить все]

 
(defun c:22 (/ c_list insert_sset index x_sorted_list)
	(setq c_list '(0 0))                                                                                    ;	будем использовать 2d координаты точек вставки блоков 
	(if (setq insert_sset (ssget "_x" '((0 . "INSERT") (2 . "PICKET") (67 . 0))) index 0)
		 (foreach point (setq x_sorted_list (vl-sort (mapcar '(lambda (ename) (cons (mapcar '+ c_list (cdr (assoc 10 (entget ename)))) ename))	 
	         						         		   		  (vl-remove-if 'listp (mapcar 'cadr (ssnamex insert_sset)))
	       	 								  	   	 )
			 								  	    '(lambda (pt1 pt2) (< (caar pt1) (caar pt2)))			;	сортируем список по взрастанию координаты x списка блоков
										    )
			 			)
		 				;	сравниваем каждый блок из отсортированного списка по x со следующим
						(if (and (< index (1- (length x_sorted_list)))
								 (< (distance (car point) (car (nth (1+ index) x_sorted_list))) 0.1)        ;	сравниваем расстояния между точками вставки блоков с заданным расстоянием 0.1
							)
	;						(entdel (cdr (nth (1+ index) x_sorted_list))) 									;	удаляем дубликаты
							(vla-put-color (vlax-ename->vla-object (cdr (nth (1+ index) x_sorted_list))) 1) ;	красим дубликаты в красный цвет
						)
						(setq index (1+ index))
		 )
	)
	(princ)
)

1958 · 07.03.2025, 19:27

Цитата:

Сообщение от koMon

вот например можно так

Спасибо, интересно. Но тут выделяются (маркируются) все дубли.
Я собрал вариант, где сначала удаляются дубли боков в пределах 0.1, а затем маркируются дубли блоков, совпадающих в плане, но с большим отлетом по высоте.

Код:

[Выделить все]

 (defun c:33 (/ i num)
 (setq num 0)
 (repeat 10 (TS_del_pk) (setq num (+ num i)))
 (if (> num 0)
  (alert (strcat "Удалено повторных отметок:   " (itoa num) " шт."))
  (alert "Повторных отметок нет")
 )
 (mark-dublicates-picket)
)

;;;https://forum.dwg.ru/showthread.php?t=173021
;;; Удаление дубликатов пикетов, отличающихся по координатам в пределах 0.1 м 
(defun TS_del_pk (/ insert_sset source pt_list ent)
 (vl-load-com)
 (if (setq insert_sset (ssget "_X" '((0 . "INSERT") (2 . "PICKET") (67 . 0))))
  (progn (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
         (setq source (mapcar '(lambda (ename) (cons (trans (cdr (assoc 10 (entget ename))) 1 0) ename))
                              (vl-remove-if 'listp (mapcar 'cadr (ssnamex insert_sset)))
                      ) ;_ end of mapcar
         ) ;_ end of setq         
         (setq source (vl-sort source (function (lambda (a b) (< (cadr (nth 0 a)) (cadr (nth 0 b)))))))
         (setq source (vl-sort source (function (lambda (a b) (< (car (nth 0 a)) (car (nth 0 b)))))))
         (setq source (vl-sort source (function (lambda (a b) (< (last (nth 0 a)) (last (nth 0 b)))))))
         (while source
          (if (and (cdr source)
                   (equal (car (car source)) (car (cadr source)) 0.1)
                   (not (equal (car (car source)) (car (car pt_list)) 0.1))
              ) ;_ end of and
           (progn (setq pt_list (cons (car source) pt_list))) ;_ end of progn
          ) ;_ end of if
          (setq source (cdr source))
         ) ;_ end of while
         (vla-endundomark adoc)
  ) ;_ end of progn
 ) ;_ end of if
 (setq i 0)
 (if pt_list
  (while (< i (length pt_list))
   (setq ent (cdr (nth i pt_list)))
   (entdel ent)
   (setq i (1+ i))
  ) ;_ end of while
 ) ;_ end of if
) ;_ end of defun

;;; Маркировка дубликатов пикетов
(defun mark-dublicates-picket
       (/ adoc selset block_def block_ref source_pt_list pt_list circle prec)
 (vl-load-com)
 (if (setq selset (ssget "_X" '((0 . "INSERT") (2 . "PICKET") (67 . 0))))
  (progn
   (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
   (setq source_pt_list
         (vl-sort
          (vl-sort (mapcar (function (lambda (x)
                                      (mapcar (function +)
                                              '(0. 0.)
                                              (trans (cdr (assoc 10 (entget x))) 1 0) ;_ end of trans
                                      ) ;_ end of mapcar
                                     ) ;_ end of lambda
                           ) ;_ end of function
                           ((lambda (/ tab item)
                             (repeat (setq tab  nil
                                           item (sslength selset)
                                     ) ;_ end setq
                              (setq tab (cons (ssname selset (setq item (1- item))) tab))
                             ) ;_ end of repeat
                            ) ;_ end of lambda
                           )
                   ) ;_ end of mapcar
                   (function (lambda (a b) (< (cadr a) (cadr b))))
          ) ;_ end of vl-sort
          (function (lambda (a b) (< (car a) (car b))) ;_ end of lambda
          ) ;_ end of function
         ) ;_ end of vl-sort
   ) ;_ end of setq
   (while source_pt_list
    (if (and (cdr source_pt_list)
             (equal (car source_pt_list) (cadr source_pt_list) 0.1)
             (not (equal (car source_pt_list) (car pt_list) 0.1)) ; Не уверен в этой строке.
        ) ;_ end of and
     (progn (setq pt_list (cons (car source_pt_list) pt_list))) ;_ end of progn
    ) ;_ end of if
    (setq source_pt_list (cdr source_pt_list))
   ) ;_ end of while
   (if pt_list
    (progn
     (setvar "clayer" "ИИ_ОТМЕТКА_025")
     (setq block_def (vla-add (vla-get-blocks adoc) (vlax-3d-point '(0. 0. 0.)) "*U"))
     (foreach pt pt_list
      (setq circle (vla-addcircle block_def (vlax-3d-point pt) 15.))
      (vla-put-color circle 6)
      (vla-put-Lineweight circle 100)
     ) ;_ end of foreach
     (setq block_ref (vla-insertblock (vla-get-modelspace adoc)
                                      (vlax-3d-point '(0. 0. 0.))
                                      (vla-get-name block_def)
                                      1.
                                      1.
                                      1.
                                      0.
                     ) ;_ end of vla-InsertBlock
     ) ;_ end of setq
     (vla-explode block_ref)
     (vla-erase block_ref)
     (alert
      (strcat
       "\nОтмечено отметок,\nсовпадающих в плане,\nно с разными высотами:\n\n                    "
       (itoa (length pt_list))
       " шт."
      )
     )
    ) ;_ end of progn
    (princ "\nNothing to mark")
   ) ;_ end of if
   (vla-endundomark adoc)
  ) ;_ end of progn
 ) ;_ end of if
 (princ)
) ;_ end of defun

repeat в 3-ей строке задан с параметром 10, т.к. максимум дублей в одной точке, которые я встречал, был равен 7.

АлексЮстасу · 15.03.2025, 16:18

Offtop:

Цитата:

Сообщение от 1958

Мне часто приходится обрабатывать данные так называемой "Съемки"... когда в одной точке наложены 2-5 пикетов

На случай, если кому-то нужно решить эту задачу и есть Map/Civil.
В них есть MAPCLEAN с возможностью находить накладывающиеся объекты - помечать их или удалять повторяющиеся. И не только блоки.
Работает очень быстро. И позволяет в разных вариантах-режимах находить-исправлять еще много что, находить-исправлять сразу различные случаи и т.д.
Почему Autodesk не включил этот CLEAN в базовый AutoCAD - необъяснимо. В MAPCLEAN нет ничего специального.
Кстати, примерно месяц назад в рассылках Autodesk говорилось о добавлении неких проверок в AutoCAD.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
LISP. Очистка рисунка от "пустых" блоков	Makswell	Готовые программы	15	26.10.2022 15:24
Какой язык перспективен для инженера-конструктора с условием	The_Mercy_Seat	Программирование	705	17.03.2021 14:19
Поиск блоков пересекающих полилинию	tujn08	Программирование	80	13.03.2019 00:08
Канализационный лоток на плане полов или на плане фундаментов?	Виталька Паустовский	Основания и фундаменты	3	09.12.2009 11:51
VBA: утечка памяти при вставке блоков	Mikha	Программирование	13	03.04.2009 09:18