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

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)))
)

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

kp+ · 24.02.2025, 10:49

Не особо вникал, но многократное обращение к набору в двух циклах не добавляет производительности. Работа с наборами почему-то тормозная. Лучше один раз преобразовать набор в список, и дальше работать с ним.
Файл не смотрел, но если пикетов сотни, то операций сравнения из-за вложенности цикла будут десятки и сотни тысяч, и желательно, чтоб они выполнялись не так затратно, как операции с наборами.
Можно, конечно, как-то сократить перебор, например, один раз отсортировать список блоков-пикетов собственно по пикетажу, а затем пройтись по списку, и для каждого блока проверить двух-трех "соседей" справа и слева, а не всех, как у вас. И отметить, если соседство оказалось слишком близкое. Но для этого понадобятся многие vl-функции. Вы ими не пользуетесь по каким-то значимым причинам, например, из-за того что в клонах акада с ними плохо? Или как?

Кулик Алексей aka kpblc · 24.02.2025, 11:16

Я бы получил точки вставки блоков, преобразовал их в двумерные точки и работал уже с этим.
Плюс - отсортировать точки по вертикали и горизонтали. Может, это поможет быстрее обрабатывать. Хотя 15000 точек сравнить...

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

Код:

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

 (vl-load-com)

(defun c:mark-dublicates-picket (/ adoc selset block_def block_ref source_pt_list pt_list circle)
  (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) 1e-1)
                 (not (equal (car source_pt_list) (car pt_list) 1e-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
          (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 1)
          ) ;_ 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)
          (princ (strcat "\n" (itoa (LENGTH pt_list)) " duplicates marked"))
        ) ;_ end of progn
        (princ "\nNothing to mark")
      ) ;_ end of if
      (vla-endundomark adoc)
    ) ;_ end of progn
  ) ;_ end of if
  (princ)
) ;_ end of defun

1958 · 24.02.2025, 11:31

Цитата:

Сообщение от kp+

отсортировать список блоков-пикетов собственно по пикетажу

Блоки-пикеты в данном случае это не пикеты по трассе, а отметки земли (топографическая съемка).
Алексей, Вы Гений! Мой лисп обрабатывал этот чертеж ~5 минут, ваш код справился за 0.5 секунды! Спасибо!

Кулик Алексей aka kpblc · 24.02.2025, 11:35

Результаты-то совпадают?

1958 · 24.02.2025, 11:39

Цитата:

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

Как вариант:

Наберусь наглости и попрошу переделать код под следующую задачу:
Удалить дубликаты блоков с допуском 0.05, т.е отличающиеся по X, Y, Z =< 0.05.

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

Цитата:

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

Результаты-то совпадают?

Да!

Кулик Алексей aka kpblc · 24.02.2025, 11:57

Ну уж это-то мог бы и сам )

Код:

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

 (vl-load-com)

(defun c:mark-dublicates-picket (/ adoc selset block_def block_ref source_pt_list pt_list circle prec)

  (if (setq selset (ssget "_X" '((0 . "INSERT") (2 . "PICKET") (67 . 0))))
    (progn
      (if (/= (type (setq prec (vl-catch-all-apply
                                 (function (lambda ()
                                             (getdist "\nEnter precision <0.1> : ")
                                           ) ;_ end of lambda
                                 ) ;_ end of function
                               ) ;_ end of vl-catch-all-apply
                    ) ;_ end of setq
              ) ;_ end of type
              'real
          ) ;_ end of /=
        (setq prec 0.1)
      ) ;_ end of if

      (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) prec)
               (not (equal (car source_pt_list) (car pt_list) prec)) ; Не уверен в этой строке.
          ) ;_ 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
          (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 1)
          ) ;_ 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)
          (princ (strcat "\n" (itoa (length pt_list)) " duplicates marked"))
        ) ;_ end of progn
        (princ "\nNothing to mark")
      ) ;_ end of if
      (vla-endundomark adoc)
    ) ;_ end of progn
  ) ;_ end of if
  (princ)
) ;_ end of defun

1958 · 24.02.2025, 12:19

Цитата:

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

Ну уж это-то мог бы и сам )

Мне в прошедший четверг стукнуло 67 и думалка уже плохо думает.

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

Кулик Алексей aka kpblc · 24.02.2025, 12:27

Э, не, удалять - самостоятельно. Критериев удаления может быть овердофига, так что - ручками )

1958 · 24.02.2025, 15:32

Цитата:

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

Э, не, удалять - самостоятельно.

Так правильно? Вроде работает.

Код:

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

 (defun c:del-dublicates-picket
       (/ adoc selset block_def block_ref source_pt_list pt_list circle prec p1 p2 ss1)
 (vl-load-com)
 (if (setq selset (ssget "_X" '((0 . "INSERT") (2 . "PICKET") (67 . 0))))
  (progn
   (if (/= (type
            (setq prec (vl-catch-all-apply (function (lambda () (getdist "\nEnter precision <0.1> : ")) ;_ end of lambda
                                           ) ;_ end of function
                       ) ;_ end of vl-catch-all-apply
            ) ;_ end of setq
           ) ;_ end of type
           'real
       ) ;_ end of /=
    (setq prec 0.1)
   ) ;_ end of if
   (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. 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) prec)
             (not (equal (car source_pt_list) (car pt_list) prec)) ; ?? ?????? ? ???? ??????.
        ) ;_ 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 (foreach pt pt_list
            (setq p1 (mapcar '+ pt (list prec prec))
                  p2 (mapcar '- pt (list prec prec))
            )
            (setq ss1 (ssget "_C" p1 p2 '((0 . "INSERT") (2 . "PICKET"))))
           )
           (repeat (1- (sslength ss1)) (entdel (ssname ss1 0)))
    )
   )
   (vla-endundomark adoc)
  ) ;_ end of progn
 ) ;_ end of if
 (princ)
) ;_ end of defun

Кулик Алексей aka kpblc · 24.02.2025, 15:36

Не советую использовать ssget с ключами такого типа - может быть непредсказуемый результат. Да и удалять ты собираешься все блоки, не оставляя ничего. Ты уверен в этом?

----- добавлено через ~2 мин. -----
И сравниваешь ты трехмерные точки если что.

----- добавлено через ~4 мин. -----
Писать код сейчас не буду, голова в другой задаче. А так - я б тогда собирал не только точки, но и указатели на примитивы. По типу
(setq source (mapcar '(lambda(x) (cons (mapcar '+ '(0. 0.) (trans (cdr(assoc 10 (entget x)) 1 0)) x)
((lambda (/ tab item)
(repeat (setq tab nil
item (sslength selset))
(setq tab (cons (ssname selset (setq item (1- item))) tab))
)))

Пишу насухую, так что могут быть ошибки

1958 · 24.02.2025, 15:59

Цитата:

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

Так правильно? Вроде работает.

Не фига! Удаляются только дубликаты из одной группы. Если есть другие группы дублей, они не обрабатываются.

Цитата:

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

Да и удалять ты собираешься все блоки, не оставляя ничего.

Удаляются выбранные блоки за исключение одного:

Код:

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

 (repeat (1- (sslength ss1)) (entdel (ssname ss1 0)))

Кулик Алексей aka kpblc · 24.02.2025, 16:03

Я имел в виду "все дубликаты".

1958 · 24.02.2025, 18:25

Цитата:

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

Я имел в виду "все дубликаты".

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

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

Цитата:

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

И сравниваешь ты трехмерные точки

Да. Сравнивать надо трехмерные и удалить дубли. А те, которые совпадают в плане, но отличаются по высоте, отлично обрабатывает ваш код из сообщения #3 mark-dublicates-picket

Кулик Алексей aka kpblc · 24.02.2025, 19:19

М-да. Просто прочитывая тему...

Цитата:

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

Некоторые из них наложены друг на друга в плане (по координатам X и Y, по координате Z могут совпадать, могут не совпадать). Надо найти совпадающие и отметить их в чертеже

Цитата:

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

удалить дубликаты, а не маркировать их

Цитата:

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

Сравнивать надо трехмерные и удалить дубли

Как-то все пошло в разнос.

zvezdochiot · 24.02.2025, 19:55

Цитата:

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

Это мне и надо...

А cldups.lsp из G-Tools не подходит?

1958 · 24.02.2025, 21:02

Цитата:

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

А cldups.lsp из G-Tools не подходит?

Спасибо, посмотрел. Нет, не то.

Цитата:

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

М-да. Просто прочитывая тему...

Цитата:

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

Как-то все пошло в разнос.

А в чем разнос?
Изначально была задача найти и обозначить дубликаты блоков на плоскости. Ваш код с этим справляется отлично!
Захотелось дедушке на основе этого кода добиться удаления трехмерных дубликатов.

Просто вторая задача у меня уже была решена (но работает медленно), был затык с поиском дубликатов без учета координаты Z, чтобы можно было вручную выбрать и удалить блоки с явно неправильными Z. Таких блоков немного - max.1% от общего количества.

Кулик Алексей aka kpblc · 24.02.2025, 21:38

Сорян, но примерную логику я расписал, на сегодня я все

1958 · 26.02.2025, 14:01

Цитата:

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

Захотелось дедушке на основе этого кода добиться удаления трехмерных дубликатов.

Да уж! Плохой из меня Данила-мастер, не выходит каменный цветок.

Цитата:

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

примерную логику я расписал

Я в этой логике не то, что запутался, я в ней вообще ничего не понял.

1958 · 05.03.2025, 08:59

Цитата:

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

А так - я б тогда собирал не только точки, но и указатели на примитивы. По типу
(setq source (mapcar '(lambda(x) (cons (mapcar '+ '(0. 0.) (trans (cdr(assoc 10 (entget x)) 1 0)) x)
((lambda (/ tab item)
(repeat (setq tab nil
item (sslength selset))
(setq tab (cons (ssname selset (setq item (1- item))) tab))
)))

Пишу насухую, так что могут быть ошибки

Неделю уже бьюсь, но стена не прошибается.

Код:

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

 (defun c:22 (/selset source)
 (vl-load-com)
 (if (setq selset (ssget "_X" '((0 . "INSERT") (2 . "PICKET") (67 . 0))))
  (setq source (mapcar '(lambda (x)
                         (cons (mapcar '+ '(0. 0.) (trans (cdr (assoc 10 (entget x)) 1 0)) x)
                               ((lambda (/ tab item)
                                 (repeat (setq tab  nil
                                               item (sslength selset)
                                         )
                                  (setq tab (cons (ssname selset (setq item (1- item))) tab))
                                 )
                                )
                               )
                         )
                        )
               )
  )
 )
 (alert (vl-prin1-to-string source))
)

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

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
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