[posetitel]

Добрый день!
Есть ли такой лисп, который показывает количество пересечений отрезков, полилиний друг с другом (отрезок с отрезком, отрезок с полилинией, полилиния с полилинией)?
В основном сумму длин все ищут, а вот пересечений вроде никто не выкладывал еще.

[trir]

на лисп'е это делать - плохая идея

[maratovich]

Сделать можно всё что угодно, но на это нужно затратить много времени...
1. Приложите файл примера.
2. Опишите точно что вам нужно.
3. Приложите Ваш код и укажите где у вас появляются проблемы. Ветка создана для помощи по доработке кода.
4. Если у Вас нет кода, но Вам это очень надо, то в ветке "Поиск исполнителей" вам смогут помочь.
Offtop: (рассуждайте логично - если к вам подойдёт дядя с улицы и попросит сделать его работу просто так, вы будете это делать ?)

[trir]

или можно взять мой код и немножко его допилить

[posetitel]

в кодах ничего не понимаю, могу только скопировать, подгрузить лисп и запустить код. если можно иначе как-то, то тоже хорошо, я просто не знаком с иными методами.
задача для понимания весьма простая - есть горизонтальные и вертикальные отрезки и полилинии, нужно пересчитать сколько раз они пересекаются, дальше это будет количество вязок арматуры, например, и задание смежникам.
(вариант умножить одно на другое в ручную не предлагать, не прокатит)

[VVA]

Сообщение от posetitel нужно пересчитать сколько раз они пересекаются, дальше это будет количество вязок арматуры, например, и задание смежникам.

Другой вариант. Расстановка в пересечения отрезков и полилиний блоков с именем "Вязка арматуры". Подсчет блоков - выдача заданий смежникам
Lisp. Расстановка блоков на пересечении линий.
Insert block at intersection
Insert Blocks on intersection lines then break/trim

[posetitel]

первая ссылка - оно.
спасибо.
предполагал, что задача вполне тривиальная и часто требующаяся, только вот поиск так и не дал результата.

[rebus]

Вариант 1:

Код:

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

 ; -*- coding: cp1251-dos -*-

(defun C:count-intersections (/ e en i sel lst lst2 cnt tm)
  ; Get selection
  (setq sel (ssget))
  ; Convert selection set to list and filter
  (setq i 0 lst '())
  (repeat (sslength sel)
          (setq e (ssname sel i))
          (setq en (cdr (assoc 0 (entget e))))
          (if (member en '("LWPOLYLINE" "LINE"))
              (setq lst (cons (vlax-ename->vla-object e)
                              lst)))
          (setq i (1+ i)))
  ; Count intersections
  (setq cnt 0)
  (while lst (setq en (car lst)
                   lst2 (cdr lst))
         (foreach i lst2 (setq tm (vlax-variant-value (vla-intersectwith en i acExtendNone)))
                  (setq e (vlax-safearray-get-u-bound tm 1))
                  (if (>= e 0)
                      (setq cnt (+ cnt (/ (1+ e)
                                          3)))))
         (setq lst (cdr lst)))
  (princ "Найдено пересечений: ")
  (princ cnt)
  (princ))

Вариант 2:

Код:

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

 ; -*- coding: cp1251-dos -*-

(defun C:count-intersections (/ e e2 i sel lst lst2 cnt tm)
  ; Select LINEs and LWPOLYLINEs only
  (setq sel (ssget '((-4 . "<OR")
                     (0 . "LINE")
                     (0 . "LWPOLYLINE")
                     (-4 . "OR>"))))
  ; Convert selection set to list
  (setq i 0 lst '())
  (repeat (sslength sel)
          (setq lst (cons (vlax-ename->vla-object (ssname sel i))))
          (setq i (1+ i)))
  ; Count intersections
  (setq cnt 0)
  (while lst (setq e2 (car lst)
                   lst2 (cdr lst))
         (foreach i lst2 (setq tm (vlax-variant-value (vla-intersectwith e2 i acExtendNone)))
                  (setq e (vlax-safearray-get-u-bound tm 1))
                  (if (>= e 0)
                      (setq cnt (+ cnt (/ (1+ e)
                                          3)))))
         (setq lst (cdr lst)))
  (princ "Найдено пересечений: ")
  (princ cnt)
  (princ))

Не знаю, какой лучше. Работают одинаково, разница в том, что второй вариант подавляет выбор примитивов кроме отрезков и полилиний.

[posetitel]

rebus, спасибо

[posetitel]

VVA, а можно доработать лисп по второй ссылке (вот он)

(defun c:sbx ( / ) (progn (setq ent (car (entsel "\nSelect main line: "))) (if ent (progn (princ "\nSelect crossing line(s): ") (if (setq ss (ssget)) (progn (setq count 0 obj (vlax-ename->vla-object ent) pointlist nil ) (repeat (sslength ss) (setq xent (ssname ss count) xobj (vlax-ename->vla-object xent) ) (if (setq int (vla-IntersectWith obj xobj acExtendNone)) (progn (setq int (vlax-safearray->list (vlax-variant-value int)) pointlist (append pointlist (list int)) ) ) ) (setq count (1+ count)) ) (if (null (tblobjname "BLOCK" "SBblock")) (progn (entmake (list (cons 0 "BLOCK") (cons 2 "SBblock") (cons 70 0) (list 10 0.0 0.0 0.0))) (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (8 . "0") (100 . "AcDbPolyline") (90 . 2) (70 . 1) (43 . 1.0) (38 . 0.0) (39 . 0.0) (10 2.5 0.0) (40 . 1.0) (41 . 1.0) (42 . 1.0) (91 . 0) (10 -2.5 0.0) (40 . 1.0) (41 . 1.0) (42 . 1.0) (91 . 0) (210 0.0 0.0 1.0) ) ) (setq blockname (entmake '((0 . "ENDBLK")))) ) ) (foreach pt_nth pointlist (entmake (append '((0 . "INSERT") (100 . "AcDbEntity") (8 . "0") (100 . "AcDbBlockReference") (2 . "SBblock")) (list (cons 10 pt_nth)) '((41 . 1.0) (42 . 1.0) (43 . 1.0) (50 . 0.0) (70 . 0) (71 . 0) (44 . 0.0) (45 . 0.0) (210 0.0 0.0 1.0)) ) ) ) ) ) ) ) ) (princ) )

чтобы перед вставкой необходимо было ввести имя вставляемого блока и блок вставлялся в слой пересекаемых основную линий

[VVA]

posetitel, Можно

Код:

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

(defun c:sbx (/ ent ss count xobj pointlist int blockname blk)
(vl-load-com)
  (if (and
        (setq blk (mydcl "Select block" (acad_strlsort (tablelist "BLOCK"))))
        (setq ent (car (entsel "\nSelect main line: ")))
        )
    (progn
      (princ "\nSelect crossing line(s): ")
      (if (setq ss (ssget))
        (progn
          (setq count     0
                obj       (vlax-ename->vla-object ent)
                pointlist nil
          ) ;_ end of setq
          (repeat (sslength ss)
            (setq xent (ssname ss count)
                  xobj (vlax-ename->vla-object xent)
            ) ;_ end of setq
            (if (setq int (vla-intersectwith obj xobj acextendnone))
              (progn
                (setq int (vlax-safearray->list (vlax-variant-value int))
                      pointlist (append
                                  pointlist
                                  (list (list int (vla-get-layer xobj)))
                                ) ;_ end of append
                ) ;_ end of setq
              ) ;_ end of progn
            ) ;_ end of if
            (setq count (1+ count))
          ) ;_ end of repeat
        ) ;_ end of progn
      ) ;_ end of if
      (foreach pt_nth pointlist
        (entmake (append
                   '((0 . "INSERT") (100 . "AcDbEntity"))
                   (list (cons 8 (cadr pt_nth)))
                   (list (cons 100 "AcDbBlockReference"))
                   (list (cons 2 blk))
                   (list (cons 10 (car pt_nth)))
                   '((41 . 1.0)
                     (42 . 1.0)
                     (43 . 1.0)
                     (50 . 0.0)
                     (70 . 0)
                     (71 . 0)
                     (44 . 0.0)
                     (45 . 0.0)
                     (210 0.0 0.0 1.0)
                    )
                 ) ;_ end of append
        ) ;_ end of entmake
      ) ;_ end of foreach
    ) ;_ end of progn
  ) ;_ end of if
  (princ)
) ;_ end of defun
(defun mydcl (zagl info-list / fl ret dcl_id)
;;;Use
;;;(mydcl "Test" '("1" "2" "3" "4"))
  (vl-load-com)
  (if (null zagl)
    (setq zagl "Выбор")
  ) ;_ end of if
  (setq fl (vl-filename-mktemp "mip" nil ".dcl"))
  (setq ret (open fl "w"))
  (mapcar
    '(lambda (x) (write-line x ret))
    (list "mip_msg : dialog { "
          (strcat "label=\"" zagl "\";")
          " :list_box {"
          "alignment=top ;"
          "width=51 ;"
          "allow_accept = true;"
          "tabs = \"16 32\";"
          "tab_truncate = true;"
          (if (> (length info-list) 26)
            "height= 26 ;"
            (strcat "height= " (itoa (+ 3 (length info-list))) ";")
          ) ;_ end of if
          "is_tab_stop = false ;"
          "key = \"info\";}"
          "ok_cancel;}"
    ) ;_ end of list
  ) ;_ end of mapcar
  (setq ret (close ret))
  (if (and (not (minusp (setq dcl_id (load_dialog fl))))
           (new_dialog "mip_msg" dcl_id)
      ) ;_ end of and
    (progn
      (start_list "info")
      (mapcar 'add_list info-list)
      (end_list)
      (set_tile "info" "0")
      (setq ret (car info-list))
      (action_tile
        "info"
        "(setq ret (nth (atoi $value) info-list))"
      ) ;_ end of action_tile
      (action_tile
        "cancel"
        "(progn(setq ret nil)(done_dialog 0))"
      ) ;_ end of action_tile
      (action_tile "accept" "(done_dialog 1)")
      (start_dialog)
    ) ;_ end of progn
  ) ;_ end of if
  (unload_dialog dcl_id)
  (vl-file-delete fl)
  ret
) ;_ end of defun
;;;================================================================================
;;;Written By Michael Puckett. 
;;;Список элементов символьных таблиц АвтоКАДа 
;;; - s- имя таблицы
;;;Пример - список всех слоев - (setq all_layers (tablelist "LAYER"))
;;;(setq all_layers (tablelist "LAYER"))
;;;Start Coding Here 
(defun tablelist (s / d r)
  (while (setq d (tblnext s (null d)))
    (setq r (cons (cdr (assoc 2 d)) r))
  ) ;_ while
) ;_ defun

[posetitel]

большое человеческое спасибо