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

Mozgunov · 14.07.2009, 22:27

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

Кулик Алексей 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" не ставились в точках общих вершин выбранных полилиний? Только если хотя бы у одной их проверяемых в месте пересечения нет вершины?

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Тела пересекаются, как нарисовать контур пересечения	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

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