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

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: слишком мало аргументов
Где ошибка? Сам додуматься не могу!

Кулик Алексей 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.

engngr · 17.03.2025, 01:23

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