Как получить точки пересечения двух полилиний?

Mozgunov · 14.07.2009, 22:27

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

Дима_ · 15.07.2009, 00:10

Держи:

Код:

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

(defun intersect (obj1 obj2 / tmp x y)
(setq tmp 
(vlax-variant-value (apply 'vla-intersectwith
(reverse (cons acExtendNone (mapcar 'vlax-ename->vla-object (list obj1 obj2)))))))
(if (> (vlax-safearray-get-u-bound tmp 1) 0)
(vl-remove nil (mapcar '(lambda (z / ret) 
(if y (setq ret (list x y z) x nil y nil) (if x (setq y z) (setq x z))) ret) 
(vlax-safearray->list tmp)))
);end of if
);end of intersect

пример: (intersect (entlast) (entnext))

Юта · 15.07.2009, 09:31

А как получить точки пересечения одной полилинии, указанной юзером (находящейся неважно в каком слое) и других линий (полилиний), находящихся в слое "triangulate"?

Кулик Алексей aka kpblc · 15.07.2009, 09:50

Код:

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

(defun get-intersections (/                              _kpblc-list-dublicates-remove  _kpblc-conv-selset-to-ename
                          _kpblc-conv-list-to-3dpoints   _kpblc-conv-ent-to-ename       _kpblc-conv-ent-to-vla
                          _kpblc-conv-vla-to-list        selset1                        selset2
                          )

  (defun _kpblc-list-dublicates-remove (lst / result)
                                       ;|
*    Функция исключения дубликатов элементов списка 
*    Параметры вызова:
*	lst	обрабатываемый список
*    Возвращаемое значение: список без дубликатов соседних элементов
*    Примеры вызова:
(_kpblc-list-dublicates-remove '((0.0 0.0 0.0) (10.0 0.0 0.0) (10.0 0.0 0.0) (0.0 0.0 0.0)) nil)
((0.0 0.0 0.0) (10.0 0.0 0.0) (0.0 0.0 0.0))
|;
    (foreach x lst
      (if (not (member x result))
        (setq result (cons x result))
        ) ;_ end of if
      ) ;_ end of foreach
    (reverse result)
    ) ;_ end of defun

  (defun _kpblc-conv-selset-to-ename (selset / tab item)
                                     ;|
*    Преобразование набора, полученного через ssget, в список ename-представлени
* примитивов.
*    Параметры вызова:
	selset	набор примитивов
*    Примеры вызова:
(_kpblc-conv-selset-to-ename (ssget))
|;
    (cond
      ((not selset) nil)
      ((= (type selset) 'pickset)
       (repeat (setq tab  nil
                     item (sslength selset)
                     ) ;_ end setq
         (setq tab (cons (ssname selset (setq item (1- item))) tab))
         ) ;_ end repeat
       )
      ((= (type selset) 'vla-object)
       (_kpblc-conv-vla-to-list selset)
       )
      ((listp selset) selset)
      ) ;_ end of cond
    ) ;_ end of defun

  (defun _kpblc-conv-list-to-3dpoints (lst / res)
                                      ;|
*    Функция конвертации списка чисел в список 3-мерных точек.
*    Параметры вызова:
*	lst	список чисел
*    Примеры вызова:
(_kpblc-conv-list-to-3dpoints '(1 2 3 4 5 6)) ;-> ((1 2 3) (4 5 6))
(_kpblc-conv-list-to-3dpoints '(1 2 3 4 5))   ;-> ((1 2 3) (4 5 0.))
|;
    (cond
      ((not lst)
       nil
       )
      (t
       (setq res (cons (list (car lst)
                             (if (cadr lst)
                               (cadr lst)
                               0.
                               ) ;_ end of if
                             (if (caddr lst)
                               (caddr lst)
                               0.
                               ) ;_ end of if
                             ) ;_ end of list
                       (_kpblc-conv-list-to-3dpoints (cdddr lst))
                       ) ;_ end of cons
             ) ;_ end of setq
       )
      ) ;_ end of cond
    res
    ) ;_ end of defun

  (defun _kpblc-conv-ent-to-ename (ent_value /)
                                  ;|
*    Функция преобразования полученного значения в ename
*    Параметры вызова:
*	ent_value	значение, которое надо преобразовать в примитив. Может
*			быть именем примитива, vla-указателем или просто
*			списком.
*			Если не принадлежит ни одному из указанных типов,
*			возвращается nil
*    Примеры вызова:
(_kpblc-conv-ent-to-ename (entlast))
(_kpblc-conv-ent-to-ename (vlax-ename->vla-object (entlast)))
|;
    (cond
      ((= (type ent_value) 'vla-object)
       (vlax-vla-object->ename ent_value)
       )
      ((= (type ent_value) 'ename) ent_value)
      ((= (type ent_value) 'str) (handent ent_value))
      ((= (type ent_value) 'list) (cdr (assoc -1 ent_value)))
      (t nil)
      ) ;_ end of cond
    ) ;_ end of defun

  (defun _kpblc-conv-ent-to-vla (ent_value / res)
                                ;|
*    Функция преобразования полученного значения в vla-указатель.
*    Параметры вызова:
*	ent_value	значение, которое надо преобразовать в указатель. Может
*			быть именем примитива, vla-указателем или просто
*			списком.
*			Если не принадлежит ни одному из указанных типов,
*			возвращается nil
*    Примеры вызова:
(_kpblc-conv-ent-to-vla (entlast))
(_kpblc-conv-ent-to-vla (vlax-ename->vla-object (entlast)))
|;
    (cond
      ((= (type ent_value) 'vla-object) ent_value)
      ((= (type ent_value) 'ename) (vlax-ename->vla-object ent_value))
      ((setq res (_kpblc-conv-ent-to-ename ent_value))
       (vlax-ename->vla-object res)
       )
      ) ;_ end of cond
    ) ;_ end of defun

  (defun _kpblc-conv-vla-to-list (value / res)
                                 ;|
*    Преобразовывает vlax-variant или vlax-safearray в список.
|;
    (cond
      ((listp value)
       (mapcar '_kpblc-conv-vla-to-list value)
       )
      ((= (type value) 'variant)
       (_kpblc-conv-vla-to-list (vlax-variant-value value))
       )
      ((= (type value) 'safearray)
       (if (>= (vlax-safearray-get-u-bound value 1) 0)
         (_kpblc-conv-vla-to-list (vlax-safearray->list value))
         ) ;_ end of if
       )
      ((and (member (type value) (list 'ename 'str 'vla-object))
            (setq value (_kpblc-conv-ent-to-vla value))
            (and (= (type value) 'vla-object)
                 (vlax-property-available-p value 'count)
                 ) ;_ end of and
            ) ;_ end of and
       (vlax-for sub (_kpblc-conv-ent-to-vla value)
         (setq res (cons sub res))
         ) ;_ end of vlax-for
       )
      (t value)
      ) ;_ end of cond
    ) ;_ end of defun

  (if (and (= (type (setq selset1 (vl-catch-all-apply
                                    (function
                                      (lambda ()
                                        (ssget)
                                        ) ;_ end of lambda
                                      ) ;_ end of function
                                    ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              'pickset
              ) ;_ end of =
           (= (type (setq selset2 (vl-catch-all-apply
                                    (function
                                      (lambda ()
                                        (ssget)
                                        ) ;_ end of lambda
                                      ) ;_ end of function
                                    ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              'pickset
              ) ;_ end of =
           ) ;_ end of and
    (progn
      (foreach item (mapcar (function vlax-ename->vla-object) (_kpblc-conv-selset-to-ename selset1))
        (foreach sub (mapcar (function vlax-ename->vla-object) (_kpblc-conv-selset-to-ename selset2))
          (setq res (append res
                            (_kpblc-conv-list-to-3dpoints
                              (_kpblc-conv-vla-to-list
                                (vla-intersectwith item sub acextendnone)
                                ) ;_ end of _kpblc-conv-vla-to-list
                              ) ;_ end of _kpblc-conv-list-to-3dpoints
                            ) ;_ end of append
                ) ;_ end of setq
          ) ;_ end of foreach
        ) ;_ end of foreach
      ) ;_ end of progn
    ) ;_ end of if
  (_kpblc-list-dublicates-remove res)
  ) ;_ end of defun

Юта · 15.07.2009, 09:55

Спасибо! Буду пробовать.
Поражаюсь быстроте написания кода!!!
___
Проверила. Не работает

после указания полилинии программа выдает "nil"

Victor · 15.07.2009, 10:11

У неё же там не полилинии а фэйсы какие-то.
А потом она скажет точки надо бы по высоте проинтерполировать.
А потом скажет а нехило бы их подписать текстами.

Кулик Алексей aka kpblc · 15.07.2009, 10:16

Юта, я проверял на полилиниях, гарантированно пересекающихся. Работало. Короче, образец в студию.
Victor, а такие "хотелки" уже, как говорится, "за отдельную плату"

Юта · 15.07.2009, 10:29

В файле по точкам, имеющим разную высоту (имитирующим съемку рельефа) построены типа триангуляционные линии (желтым цветом).
Надо проставить точки на пересечениях этих линий и одной из линий белого цвета, по моему выбору. Причем эти точки должны иметь координату Z такую же, как на линиях "triangulate" в местах пересечения.

Victor, у блондинок не фейсы, а формы. Это раз.
Во-вторых, интерполировать не надо, уже есть программка, спасибо гуру от автокада.
И в-третьих, а что, "жаба давит" поделиться кодом, если просят?
(прошу принять эти претензии с улыбкой. Типа я совсем не обиделась).

Кулик Алексей aka kpblc · 15.07.2009, 10:33

Код проверяет истинное, а не "кажущееся" пересечение. У тебя в файле полилинии лежат на разных уровнях - вот и все. При таких условиях надо предварительно "плющить" чертеж (кстати, для какой системы координат?), вычислять точки пересечений, потом вычислять ближайшую проекцию этой точки на нужную (кстати, как ее определить?) полилинию/кривую и добавлять в результат. Долго, муторно, и без гарантий корректности работы. Подобное я как-то делал на cadtutor.net, но искать и модифицировать сейчас нет возможности.

Юта · 15.07.2009, 10:39

Но вручную-то точки ставятся без проблем. И на нужную высоту.

Кулик Алексей aka kpblc · 15.07.2009, 10:50

Прааально. В режиме "кажущегося пересечения".

Victor · 15.07.2009, 11:11

Э-ээ. Я как бы не о ваших формах а о вашем файле "Котлован". Там не полилинии а 3D face.

Дима_ · 15.07.2009, 11:14

То Юта, что-бы сделать то что Вы хотите, надо - написать процедуру нахождения кажущегося пересечения двух линий (аналог inters), но с учетом вектора просмотра, ну или хотя-бы по вектору '(0 0 1) - то есть ограничиться просмотром сверху в мировой системе координат - что вобщем не сложно. После нахождения этой точки ее еще надо спроецировать на линию, пот тем-же вектором просмотра - что тоже в общем не сложно в случае с просмотром сверху '(0 0 1) и плоским рассположением координат линии (z pt1 = z pt2), но с произвольным углом как просмотра, так и линии в пространстве "процедурка" в принципе не очень большая - но на все проверки день убить надо, а так как еще ясно, что после этого еще что-то понадобиться - возиться с этим просто лень. Хотели-же в паралельном посте изучать лисп - вот отличный пример, заодно и пространственное мышление оживите, ну а если, что конкретное не получаеться, либо не понятно как делать - то сюда - подскажем.

Юта · 15.07.2009, 11:22

Victor, да поняла я всё. Просто скаламбурила.
Дима_, Кулик Алексей, спасибо за разъяснение. Видимо придется потренироваться в создании 3D модели. Такие коды пока мне не под силу.

Дима_ · 15.07.2009, 11:35

Вам понадобяться (как минимум) разобраться с dxf кодами полилиний и 3d face и понять принцип работы (inters...) и (trans...), да и вобще что такое единичный вектор направления.

Mozgunov · 15.07.2009, 22:13

Алексей, Дмитрий Спасибо за коды. Дмитрий не получилось воспользоваться кодом. Что я неправильно делаю?

Код:

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

(defun intersect (obj1 obj2 / tmp x y)
(setq tmp 
(vlax-variant-value (apply 'vla-intersectwith
(reverse (cons acExtendNone (mapcar 'vlax-ename->vla-object (list obj1 obj2)))))))
(if (> (vlax-safearray-get-u-bound tmp 1) 0)
(vl-remove nil (mapcar '(lambda (z / ret) 
(if y (setq ret (list x y z) x nil y nil) (if x (setq y z) (setq x z))) ret) 
(vlax-safearray->list tmp)))
);end of if
);end of intersect

(setq obj1 (entsel "Укажите объект") )
(setq obj2 (entsel "Укажите объект") )

(intersect (obj1) (obj2))

скобочки убрал всё равно не помогает ( (obj1) (obj2)

VVA · 15.07.2009, 22:26

Mozgunov,

Код:

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

(setq obj1 (car(entsel "Укажите объект")))
(setq obj2 (car(entsel "Укажите объект")))
(intersect obj1 obj2)

*Добавлено*
Здесь найдешь очень много полезных функций.
В том числе и

Цитата:

VxGetInters - Returns all intersection points between two objects
VxGetBlockInters-Returns all intersection points between a block and an object

Mozgunov · 15.07.2009, 22:54

VVA, попробовал сделать так как вы говорите, всё равно не работает:no function definition: nil

Дима_ · 15.07.2009, 22:57

попробуй вести перед запуском (vl-load-com)
p.s. Да и вообще отучайтесь в лиспе от лишних переменных

Код:

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

(intersect (car (entsel)) (car (entsel)))

Mozgunov · 15.07.2009, 23:03

Код:

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

(vl-load-com)
(defun intersect (obj1 obj2 / tmp x y)
(setq tmp 
(vlax-variant-value (apply 'vla-intersectwith
(reverse (cons acExtendNone (mapcar 'vlax-ename->vla-object (list obj1 obj2)))))))
(if (> (vlax-safearray-get-u-bound tmp 1) 0)
(vl-remove nil (mapcar '(lambda (z / ret) 
(if y (setq ret (list x y z) x nil y nil) (if x (setq y z) (setq x z))) ret) 
(vlax-safearray->list tmp)))
);end of if
);end of intersect

(setq obj1 (car(entsel "Укажите объект")))
(setq obj2 (car(entsel "Укажите объект")))
(intersect obj1 obj2)

Всё равно не получается.

Кулик Алексей aka kpblc · 15.07.2009, 23:07

Mozgunov, а запрашиваемые объекты точно пересекаются?

Дима_ · 15.07.2009, 23:11

после неудачного результата что выдает каманда (list obj1 obj2)
to крыс - если не пересекаються должно вернуть nil

Mozgunov · 15.07.2009, 23:14

Да. Точно пересекаются.
_______________________

Дима_ Выдаёт (<Имя объекта: 7efab390> <Имя объекта: 7efab410>), но ошибки нет уже.

Листинг команд:

Код:

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

Команда: *Прервано*
Команда: *Прервано*
Команда: appload poliline.lsp успешно загружено.
Команда: Укажите объектУкажите объект
Команда:
Команда: (list obj1 obj2)
(<Имя объекта: 7efab410> <Имя объекта: 7efab390>)

Дима_ · 15.07.2009, 23:29

Так работает или нет? У меня с твоим файлом работает. что возращает (type intersect)

Mozgunov · 15.07.2009, 23:39

Выполняется функция но ничего не возвращает. Перезапустил autocad попробовал снова. Вот что получилось:

Код:

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

Команда: appload
poliline.lsp успешно загружено.
Команда: Укажите объектУкажите объект
Команда:
Команда: (type intersect)
SUBR
Команда: !obj1
<Имя объекта: 7efab410>
Команда: !obj2
<Имя объекта: 7efab390>

Извиняюсь за запудривание мозгов

Всё работает! Спасибо большое! :

Цитата:

Команда: (intersect obj1 obj2)
((1583.41 1028.29 0.0) (1943.99 1020.82 0.0) (2259.39 1245.07 0.0))

Дима_ · 15.07.2009, 23:43

приведи лог (intersect obj1 obj2)
p.s. напиши в чем проблема была - вдруг не ты один такой - чтоб другие тоже знали.

Mozgunov · 15.07.2009, 23:53

Проблема в том что я не умею пользоваться функциями

Если вызывать функцию (intersect obj1 obj2) то возвращается три списка (точки пересечения полилиний)
Я делал так:

Код:

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

(vl-load-com)
(defun intersect (obj1 obj2 / tmp x y)
(setq tmp 
(vlax-variant-value (apply 'vla-intersectwith
(reverse (cons acExtendNone (mapcar 'vlax-ename->vla-object (list obj1 obj2)))))))
(if (> (vlax-safearray-get-u-bound tmp 1) 0)
(vl-remove nil (mapcar '(lambda (z / ret) 
(if y (setq ret (list x y z) x nil y nil) (if x (setq y z) (setq x z))) ret) 
(vlax-safearray->list tmp)))
);end of if
);end of intersect

(setq obj1 (car(entsel "Укажите объект")))
(setq obj2 (car(entsel "Укажите объект")))

(setq rez (intersect obj1 obj2) )

Потом проверял переменную !rez и получал значение nil. Почему в неё не помещается результат выполнения функции?

VVA · 16.07.2009, 09:30

удалено

Дима_ · 16.07.2009, 13:05

(intersect) возращает nil если объекты не пересекаються, (что возращает команда (setq rez (Intersect obj1 obj2)), то и лежит в rez. Проверить можно, например (list rez).

Mozgunov · 17.07.2009, 01:26

Дима_, Всё работает прекрасно!!! Я проверел вызывав функцию через командную строку () . Я про то, что в том виде в котором я записал скрипт последний результат вычисления это не присваивание переменной rez списка, а что-то другое, вообщем мне ещё разбираться и разбираться, даже с вашей вункцией.... А так всё работает! Большое спасибо за грамотный и своевременный ответ!

Малявка · 17.07.2009, 08:11

У меня вот такой код работает (взято отсюда же, с форума):

Код:

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

;Определение точек пересечения двух примитивов

(defun c:int (/ adoc ent1 ent2 int_lst res _kpblc-conv-list-to-3dpoints)

  (defun _kpblc-conv-list-to-3dpoints (lst / res)
                                      ;|
*    Функция конвертации списка чисел в список 3-мерных точек.
*    Параметры вызова:
*	lst	список чисел
*    Примеры вызова:
(_kpblc-conv-list-to-3dpoints '(1 2 3 4 5 6)) ;-> ((1 2 3) (4 5 6))
(_kpblc-conv-list-to-3dpoints '(1 2 3 4 5))   ;-> ((1 2 3) (4 5 0.))
|;
    (cond
      ((not lst)
       nil
       )
      (t
       (setq res (cons (list (car lst)
                             (if (cadr lst)
                               (cadr lst)
                               0.
                               ) ;_ end of if
                             (if (caddr lst)
                               (caddr lst)
                               0.
                               ) ;_ end of if
                             ) ;_ end of list
                       (_kpblc-conv-list-to-3dpoints (cdddr lst))
                       ) ;_ end of cons
             ) ;_ end of setq
       )
      ) ;_ end of cond
    res
    ) ;_ end of defun

  (vl-load-com)
  (if (and (not (vl-catch-all-error-p
                  (vl-catch-all-apply
                    '(lambda ()
                       (setq ent1
                              (car
                                (entsel
                                  "\nУкажите примитив 1 (кроме блока и внешней ссылки) <Отмена> : "
                                  ) ;_ end of entsel
                                ) ;_ end of car
                             ) ;_ end of setq
                       ) ;_ end of lambda
                    ) ;_ end of vl-catch-all-apply
                  ) ;_ end of vl-catch-all-error-p
                ) ;_ end of not
           ent1
           (not (member (cdr (assoc 0 (entget ent1))) '("INSERT")))
           (not (vl-catch-all-error-p
                  (vl-catch-all-apply
                    '(lambda ()
                       (setq ent2
                              (car
                                (entsel
                                  "\nУкажите примитив 2 (кроме блока и внешней ссылки) <Отмена> : "
                                  ) ;_ end of entsel
                                ) ;_ end of car
                             ) ;_ end of setq
                       ) ;_ end of lambda
                    ) ;_ end of vl-catch-all-apply
                  ) ;_ end of vl-catch-all-error-p
                ) ;_ end of not
           ent2
           (not (member (cdr (assoc 0 (entget ent2))) '("INSERT")))
           ) ;_ end of and
    (progn
      (if (> (vlax-safearray-get-u-bound
               (setq int_lst (vlax-variant-value
                               (vla-intersectwith
                                 (vlax-ename->vla-object ent1)
                                 (vlax-ename->vla-object ent2)
                                 acextendnone
                                 ) ;_ end of vla-IntersectWith
                               ) ;_ end of vlax-variant-value
                     ) ;_ end of setq
               1
               ) ;_ end of vlax-safearray-get-u-bound
             ) ;_ end of >
        (setq res (_kpblc-conv-list-to-3dpoints (vlax-safearray->list int_lst)))
        ) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  res
  ) ;_ end of defun

С полилиниями работает на ура.

aburvalg · 28.05.2012, 15:37

Цитата:

Сообщение от Дима_

Держи:

Код:

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

(defun intersect (obj1 obj2 / tmp x y)
(setq tmp 
(vlax-variant-value (apply 'vla-intersectwith
(reverse (cons acExtendNone (mapcar 'vlax-ename->vla-object (list obj1 obj2)))))))
(if (> (vlax-safearray-get-u-bound tmp 1) 0)
(vl-remove nil (mapcar '(lambda (z / ret) 
(if y (setq ret (list x y z) x nil y nil) (if x (setq y z) (setq x z))) ret) 
(vlax-safearray->list tmp)))
);end of if
);end of intersect

пример: (intersect (entlast) (entnext))

спасибо большое. замечательно всё работает.

АлексЮстасу · 14.06.2013, 17:33

А если не двух полилиний, а множества полилиний, у которых нужно найти точки пересечения?
В идеале получить либо множество примитивов-точек в точках пересечений, либо вставить блоки в них. Список координат этих точек тоже неплохо.
Offtop: Мне мерещится, что нечто подобное я на форуме уже видел, но найти пока не получается.

VVA · 16.06.2013, 17:31

АлексЮстасу, Уточни задачу. Есть набор, состоящий из полилиний. Нужно найти точки пересечения полилиний каждой с каждой? И просто вывести список всех возможных точек? Если несколько полилиний пересекаются в одной точке, то в результирующем списке точка пересечения должна присутствовать только один раз или нет?

АлексЮстасу · 16.06.2013, 21:22

Цитата:

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

АлексЮстасу, Уточни задачу. Есть набор, состоящий из полилиний. Нужно найти точки пересечения полилиний каждой с каждой? И просто вывести список всех возможных точек? Если несколько полилиний пересекаются в одной точке в результирующем списке точка пересечения должна присутствовать только один раз или нет?

Да, все именно так. Или не список координат точек, а сразу примитивы-точки или указанные блоки по одной штуке на одно пересечение, вне зависимости от числа пересекающихся в любой из точек линий.

Дима_ · 16.06.2013, 22:50

не проверяя как-то так -

Код:

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

 (defun all-pt (lst)
  ((lambda (frec) (apply 'append (frec lst)))
   (lambda (lst)
      (if (cdr lst)
	      (cons (apply 'append (mapcar '(lambda (x) (intersect (car lst) x)) (cdr lst)))
		        (frec (cdr lst)))))))

запустить - что-то вроде (all-pt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget)))))

VVA · 17.06.2013, 01:07

3 команды: POLYBLOCK и POLYPOINT и POLYPOINTVX . Об описании блока и режиме отображения точек нужно позаботиться заранее и самостоятельно
Использовал ф-цию all-pt из поста выше. Она рекурсивная. Надеюсь, количество обрабатываемых полилиний будет в разумных для нее (рекурсии) пределах
Отличие POLYPOINT от POLYPOINTVX. POLYPOINT - ставит точки во всех пересечениях полилиний
POLYPOINTVX - не ставит точки в точках общих вершин выбранных полилиний (см. пост #40)

Код:

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

;;Для изменения имени блока ищем строчку ниже
;;  (setq blk "BLK") ;_имя блока для вставки
;;Отличие POLYPOINT от POLYPOINTVX. POLYPOINT - ставит точки во всех пересечениях полилиний
;; POLYPOINTVX - не ставит точки в точках общих вершин выбранных полилиний
;;опубликовано - https://forum.dwg.ru/showpost.php?p=1108065&postcount=37

(vl-load-com)
(defun all-pt (lst)
  ((lambda (frec) (apply 'append (frec lst)))
    (lambda (lst)
      (if (cdr lst)
        (cons
          (apply 'append
                 (mapcar '(lambda (x) (intersect (car lst) x)) (cdr lst))
          ) ;_ end of apply
          (frec (cdr lst))
        ) ;_ end of cons
      ) ;_ end of if
    ) ;_ end of lambda
  )
) ;_ end of defun
(defun intersect (obj1 obj2 / tmp x y)
  (setq tmp
         (vlax-variant-value
           (apply 'vla-intersectwith
                  (reverse
                    (cons acextendnone
                          (mapcar 'vlax-ename->vla-object (list obj1 obj2))
                    ) ;_ end of cons
                  ) ;_ end of reverse
           ) ;_ end of apply
         ) ;_ end of vlax-variant-value
  ) ;_ end of setq
  (if (> (vlax-safearray-get-u-bound tmp 1) 0)
    (vl-remove nil
               (mapcar '(lambda (z / ret)
                          (if y
                            (setq ret (list x y z)
                                  x   nil
                                  y   nil
                            ) ;_ end of setq
                            (if x
                              (setq y z)
                              (setq x z)
                            ) ;_ end of if
                          ) ;_ end of if
                          ret
                        ) ;_ end of lambda
                       (vlax-safearray->list tmp)
               ) ;_ end of mapcar
    ) ;_ end of vl-remove
  )                                               ;end of if
)                                                 ;end of intersect
(defun mip_MakeUniqueMembersOfList (lst / OutList head)
;;;Удаляет одинаковые (дубликаты) элементы из списка
;;; На основе http://www.theswamp.org/index.php?topic=19128.0
;;; Изменено для сравнения вещественных чисел (equal ... 1e-6)

  (while lst
    (setq head    (car lst)
          OutList (cons head OutList)
          lst     (vl-remove-if '(lambda (pt) (equal pt head 1e-6)) (cdr lst))
    ) ;_ end of setq
  ) ;_ end of while
  (reverse OutList)
) ;_ end of defun
(defun Insert (pt Nme)
  (entmakex (list (cons 0 "INSERT")
                  (cons 2 Nme)
                  (cons 10 pt)
            ) ;_ end of list
  ) ;_ end of entmakex
) ;_ end of defun
(defun Point (pt)
  (entmakex (list (cons 0 "POINT")
                  (cons 10 pt)
            ) ;_ end of list
  ) ;_ end of entmakex
) ;_ end of defun

(defun C:POLYPOINT ()
  (mapcar
    '(lambda (pt)
       (point pt)
     ) ;_ end of lambda
    (mip_MakeUniqueMembersOfList
      (all-pt
        (vl-remove-if
          'listp
          (mapcar
            'cadr
            (ssnamex
              (ssget '((0 . "*POLYLINE")
                      )
              ) ;_ end of ssget
            ) ;_ end of ssnamex
          ) ;_ end of mapcar
        ) ;_ end of vl-remove-if
      ) ;_ end of all-pt
    ) ;_ end of mip_MakeUniqueMembersOfList
  ) ;_ end of mapcar
  (princ)
) ;_ end of defun
(defun C:POLYPOINTVX (/ lst plst)
  (setq lst (vl-remove-if
              'listp
              (mapcar
                'cadr
                (ssnamex
                  (ssget '((0 . "*POLYLINE")
                          )
                  ) ;_ end of ssget
                ) ;_ end of ssnamex
              ) ;_ end of mapcar
            ) ;_ end of vl-remove-if
  ) ;_ end of setq
  (setq plst (mapcar '(lambda (e) (polycoord e)) lst))
  (setq lst (all-pt lst))
  (mapcar
    '(lambda (pt)
       (if pt
         (point pt)
       ) ;_ end of if
     ) ;_ end of lambda
    (mip_MakeUniqueMembersOfList
      (mapcar
        '(lambda (p f)
           (if f
             nil
             p
           ) ;_ end of if
         ) ;_ end of lambda
        lst
        (mapcar
          '(lambda (l1) (apply 'and l1))
          (mapcar
            '(lambda (pt)
               (mapcar
                 '(lambda (x)
                    (vl-remove-if-not '(lambda (a) (equal a pt 1e-6)) x)
                  ) ;_ end of lambda
                 plst
               ) ;_ end of mapcar
             ) ;_ end of lambda
            lst
          ) ;_ end of mapcar
        ) ;_ end of mapcar
      ) ;_ end of mapcar

    ) ;_ end of mip_MakeUniqueMembersOfList
  ) ;_ end of mapcar
  (princ)
) ;_ end of defun
(defun polycoord (en / i l)
  (setq en (vlax-ename->vla-object en))
  (repeat (setq i (fix (1+ (vlax-curve-getendparam en))))
    (setq l
           (cons (trans (vlax-curve-getpointatparam en (setq i (1- i))) 0 1)
                 l
           ) ;_ end of cons
    ) ;_ end of setq
  ) ;_ end of repeat
  l
) ;_ end of defun
(defun C:POLYBLOCK (/ blk)
  (setq blk "BLK") ;_имя блока для вставки
  (mapcar
    '(lambda (pt)
       (Insert pt blk)
     ) ;_ end of lambda
    (mip_MakeUniqueMembersOfList
      (all-pt
        (vl-remove-if
          'listp
          (mapcar
            'cadr
            (ssnamex
              (ssget '((0 . "*POLYLINE")
                      )
              ) ;_ end of ssget
            ) ;_ end of ssnamex
          ) ;_ end of mapcar
        ) ;_ end of vl-remove-if
      ) ;_ end of all-pt
    ) ;_ end of mip_MakeUniqueMembersOfList
  ) ;_ end of mapcar
  (princ)
) ;_ end of defun
(princ "\ntype POLYBLOCK, POLYPOINT or POLYPOINTVX")
(princ)

АлексЮстасу · 17.06.2013, 02:04

Цитата:

Сообщение от Дима_

не проверяя как-то так -
Код:
запустить - что-то вроде (all-pt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget)))))

Цитата:

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

2 команды: POLYBLOCK и POLYPOINT. Об описании блока и режиме отображения точек нужно позаботиться заранее и самостоятельно
Использовал ф-цию all-pt из поста выше. Она рекурсивная. Надеюсь, количество обрабатываемых полилиний будет в разумных для нее (рекурсии) пределах

Спасибо!
Пардон за невежество, это лисп?
И как указать, что именно этот блок (если их в файле несколько описано разных)?
Сейчас POLYBLOCK отвечает:

Цитата:

Команда: POLYBLOCK
Выберите объекты: Противоположный угол: найдено: 5
Выберите объекты:
(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)

А POLYPOINT исправно наставила точек.

VVA · 17.06.2013, 11:11

АлексЮстасу,
Добавил в #37 указание в начало кода.

Vict0r · 30.08.2023, 12:43

Цитата:

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

2 команды: POLYBLOCK и POLYPOINT.

Можете как-то поправить, чтобы "point" не ставились в точках общих вершин выбранных полилиний? Только если хотя бы у одной их проверяемых в месте пересечения нет вершины?

VVA · 31.08.2023, 17:17

Удалено. не так понял

----- добавлено через ~59 мин. -----
Обновил пост #37. Добавил команду POLYPOINTVX

Vict0r · 01.09.2023, 18:07

Цитата:

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

Удалено. не так понял

----- добавлено через ~59 мин. -----
Обновил пост #37. Добавил команду POLYPOINTVX

Спасибо за оперативную помощь!
Протестил POLYPOINTVX, работает только если выбранных линий две,
если больше, то работает с 3-й и остальными линиями как POLYPOINT,
в желтом круге не должно быть точки:

VVA · 03.09.2023, 09:38

Да, удаляются точки общие для всех выбранных полилиний. Пока не могу придумать алгоритм для для общих точек 2х и более полилиний

14.07.2009, 22:27		#1
Как получить точки пересечения двух полилиний? Mozgunov Начинающий проектировщик Санкт-Петербург Регистрация: 07.02.2008 Сообщений: 443 Как при помощи автолиспа получить массив точек пересечения двух полилиний? Собственно заголовок и являяется вопросом. Подскажите хотя бы напрвление в котором нужно искать. Спасибо!
Просмотров: 13183

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Тела пересекаются, как нарисовать контур пересечения	BM60	AutoCAD	12	08.09.2008 11:09
координаты вершин выбранной полилинии на VB? как получить	ssv22	Программирование	5	17.07.2008 00:01
как получить путь к сетевому текстовому файлу	Victorovich	Программирование	3	30.06.2008 15:47
Объединение двух 3D полилиний	Рyslan	AutoCAD	12	22.05.2008 13:14

Опции темы	Поиск в этой теме
	Поиск в этой теме: Расширенный поиск