[АлексЮстасу]

Не встречалась ли программка, котрая находила бы все пустые контуры ? Т.е. такие контуры, в которых нет других замкнутых полилиний. Контуры чаще всего имеют признак Closed, но не всегда. И чаще всего состоят из одной полилинии, но могут состоять и из нескольких или даже из отрезков.

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

[VVA]

Писал для этой темы пару лиспов. Там требовалось находить полилинии, которые внутри себя не содержат текст
Для примера 2 команды
Test1 - меняет слой полилиний, не содержащих внутри себя текст на NO-HAVE-TEXT
Test2 - штрихует такие полилинии

Код:

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

(vl-load-com)
(defun C:TEST1 ( / ss textlist pllist)
  ;;;Move polyline to layer NO-HAVE-TEXT
(setq ss (ssget "_X" (list '(0 . "TEXT")(cons 410 (getvar "CTAB")))))
(setq textlist (pickset-to-list ss)) ;_List of text
(setq ss (ssget "_X" (list '(0 . "LWPOLYLINE")(cons 410 (getvar "CTAB")))))
(setq pllist (pickset-to-list ss));_list of boundary
(foreach pl (vl-remove-if-not '(lambda(x)(Is-none-text-inside-polyline x textlist)) pllist)
  (entmod (subst (cons 8 "NO-HAVE-TEXT")(assoc 8 (entget pl))(entget pl)))
  )
  )

(defun C:TEST2 ( / ss textlist pllist)
  ;;;Add hatch
(setq ss (ssget "_X" (list '(0 . "TEXT")(cons 410 (getvar "CTAB")))))
(setq textlist (pickset-to-list ss)) ;_List of text
(setq ss (ssget "_X" (list '(0 . "LWPOLYLINE")(cons 410 (getvar "CTAB")))))
(setq pllist (pickset-to-list ss));_list of boundary
(foreach pl (vl-remove-if-not '(lambda(x)(Is-none-text-inside-polyline x textlist)) pllist)
   ;; Pat - pattern
 ;; L - list point
 ;; A - angle hatch
 ;; N - name pattern
 ;; S - scale
  (entmakex-hatch
    (list(massoc 10 (entget pl))) ;_list point
    0                       ;_Angle hatch
    "ANSI31"                ;_Name Pattern
    1                       ;_Scale
    )
    )
  )


(defun Is-none-text-inside-polyline ( polyline textlist / boundary Flag)
  ;;;Return T if polyline not have text inside
  (setq boundary (massoc 10 (entget polyline)))
  (setq Flag t) ;_polyline not have text inside
  (foreach text textlist
    (if (and Flag (In_Figure (cdr(assoc 10 (entget text))) boundary))
      (setq Flag nil);_polyline have text inside
      )
    )
   Flag
;;; Old version
;;;(apply 'and
;;;(mapcar '(lambda ( text )
;;;             (if (In_Figure (cdr(assoc 10 (entget text))) boundary)
;;;               nil
;;;               polyline
;;;               )
;;;             )
;;;          textlist
;;;          )
;;;         )
  )
       
(defun massoc (key alist) 
(mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist)))
(defun pickset-to-list (ss / item lst)
       (repeat (setq item (sslength ss)) ;_ end setq
         (setq lst (cons (ssname ss (setq item (1- item))) lst))
         ) ;_ end repeat

  lst
  ) ;_ end of defun 

(defun entmakex-hatch (L a n s)
;; By ElpanovEvgeniy
;; L - list of list point
;; A - angle hatch
;; N - name pattern
;; S - scale
;; returne - hatch ename
(entmakex
  (apply
   'append
   (list
    (list '(0 . "HATCH")
          '(100 . "AcDbEntity")
          '(410 . "Model")
          '(100 . "AcDbHatch")
          '(10 0.0 0.0 0.0)
          '(210 0.0 0.0 1.0)
          (cons 2 n)
          (if (= n "SOLID")
           '(70 . 1)
           '(70 . 0)
          ) ;_  if
          '(71 . 0)
          (cons 91 (length l))
    ) ;_  list
    (apply 'append
           (mapcar '(lambda (a)
                     (apply 'append
                            (list (list '(92 . 7) '(72 . 0) '(73 . 1) (cons 93 (length a)))
                                  (mapcar '(lambda (b) (cons 10 b)) a)
                                  '((97 . 0))
                            ) ;_  list
                     ) ;_  apply
                    ) ;_  lambda
                   l
           ) ;_  mapcar
    ) ;_  apply
    (list '(75 . 0)
          '(76 . 1)
          (cons 52 a)
          (cons 41 s)
          '(77 . 0)
          '(78 . 1)
          (cons 53 a)
          '(43 . 0.)
          '(44 . 0.)
          '(45 . 1.)
          '(46 . 1.)
          '(79 . 0)
          '(47 . 1.)
          '(98 . 2)
          '(10 0. 0. 0.0)
          '(10 0. 0. 0.0)
          '(451 . 0)
          '(460 . 0.0)
          '(461 . 0.0)
          '(452 . 1)
          '(462 . 1.0)
          '(453 . 2)
          '(463 . 0.0)
          '(463 . 1.0)
          '(470 . "LINEAR")
    ) ;_  list
   ) ;_  list
  ) ;_  apply
) ;_  entmakex
) ;_  defun

(defun In_Figure (Point Boundary / FarPoint Check)
 ;_Проверяет Boundary на условие car и last одна и та же точка
      (if (not (equal (car Boundary) (last Boundary) 1e-6))
        (setq Boundary (append Boundary (list (car Boundary))))
      ) ;_ end of if
      (setq FarPoint (cons (+ (apply 'max (mapcar 'car Boundary)) 1.0)
                           (cdr Point)
                     ) ;_ end of cons
      ) ;_ end of setq
      (or
        (not
          (zerop
            (rem
              (length
                (vl-remove
                  nil
                  (mapcar
                    (function
                      (lambda (p1 p2) (inters Point FarPoint p1 p2))
                    ) ;_ end of function
                    Boundary
                    (cdr Boundary)
                  ) ;_ end of mapcar
                ) ;_ end of vl-remove
              ) ;_ end of length
              2
            ) ;_ end of rem
          ) ;_ end of zerop
        ) ;_ end of not
        (vl-some (function (lambda (x) x))
                 (mapcar
                   (function (lambda (p1 p2)
                               (or Check
                                   (if (equal (+ (distance Point p1)
                                                 (distance Point p2)
                                              ) ;_ end of +
                                              (distance p1 p2)
                                              1e-3
                                       ) ;_ end of equal
                                     (setq Check t)
                                     nil
                                   ) ;_ end of if
                               ) ;_ end of or
                             ) ;_ end of lambda
                   ) ;_ end of function
                   Boundary
                   (cdr Boundary)

                 ) ;_ end of mapcar
        ) ;_ end of vl-some
      ) ;_ end of or
    )

[АлексЮстасу]

Сообщение от VVA Писал для этой темы пару лиспов. Там требовалось находить полилинии, которые внутри себя не содержат текст

Очень "тепло"
Но странно, что в исходном файле программы как-то срабатывали, а в части файла, сделанной для теста - никакой реакции вообще.

[VVA]

Сообщение от АлексЮстасу Но странно, что в исходном файле программы как-то срабатывали, а в части файла, сделанной для теста - никакой реакции вообще.

Ну так там у тебя нет текстов
Вот вариант для контуров

Код:

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

 
(vl-load-com)
(defun C:TEST1 (/ ss pointlist pllist)
;;;Move polyline to layer NO-HAVE-TEXT
  (setq
    ss (ssget (list '(0 . "LWPOLYLINE") (cons 410 (getvar "CTAB")))
       ) ;_ end of ssget
  ) ;_ end of setq
  (setq pointlist (apply 'append
                         (mapcar '(lambda (x) (massoc 10 (entget x)))
                                 (setq pllist (pickset-to-list ss))
                         ) ;_ end of mapcar
                  ) ;_ end of apply
  ) ;_List of text
  (foreach pl (vl-remove-if
                '(lambda (x) (Is-point-inside-polyline x pointlist))
                (vl-remove-if-not 'Is-closest-polyline pllist)
              ) ;_ end of vl-remove-if
    (entmod (subst (cons 8 "NO-HAVE-TEXT")
                   (assoc 8 (entget pl))
                   (entget pl)
            ) ;_ end of subst
    ) ;_ end of entmod
  ) ;_ end of foreach
) ;_ end of defun

(defun C:TEST2 (/ ss pointlist pllist n)
;;;Add hatch
  (setq
    ss (ssget (list '(0 . "LWPOLYLINE") (cons 410 (getvar "CTAB")))
       ) ;_ end of ssget
  ) ;_ end of setq
  (setq pointlist (apply 'append
                         (mapcar '(lambda (x) (massoc 10 (entget x)))
                                 (setq pllist (pickset-to-list ss))
                         ) ;_ end of mapcar
                  ) ;_ end of apply
  ) ;_List of text
  (foreach pl (vl-remove-if
                '(lambda (x) (Is-point-inside-polyline x pointlist))
                (vl-remove-if-not 'Is-closest-polyline pllist)
              ) ;_ end of vl-remove-if
    ;; Pat - pattern
    ;; L - list point
    ;; A - angle hatch
    ;; N - name pattern
    ;; S - scale
    (entmakex-hatch
      (list (massoc 10 (entget pl))) ;_list point
      0 ;_Angle hatch
      "ANSI31" ;_Name Pattern
      1 ;_Scale
    ) ;_ end of entmakex-hatch
  ) ;_ end of foreach
) ;_ end of defun
(defun Is-closest-polyline (polyline / lst)
  (or
    (= 1 (logand 1 (cdr (assoc 70 (entget polyline)))))
    (equal
      (car (setq lst (massoc 10 (entget polyline))))
      (last lst)
      1e-6
    ) ;_ end of equal
  ) ;_ end of or
) ;_ end of defun
(defun Is-point-inside-polyline (polyline pointlist / boundary Flag)
;;;Return T if polyline not have text inside
  (setq boundary (massoc 10 (entget polyline)))
  (grtext -1
          (strcat "*** Check polyline *** "
                  (cdr (assoc 5 (entget polyline)))
          ) ;_ end of strcat
  ) ;_ end of grtext
  (foreach pt boundary
    (setq pointlist
           (vl-remove-if '(lambda (x) (equal pt x 1e-6)) pointlist)
    ) ;_ end of setq
  ) ;_ end of foreach
  (setq Flag nil) ;_polyline not have text inside
  (foreach pt pointlist
    (if (and (not Flag) (In_Figure_only pt boundary))
      (setq Flag t
            PPT pt
      ) ;_polyline have text inside
    ) ;_ end of if
  ) ;_ end of foreach
  Flag
) ;_ end of defun

(defun massoc (key alist)
  (mapcar 'cdr
          (vl-remove-if-not
            (function (lambda (x) (= key (car x))))
            alist
          ) ;_ end of vl-remove-if-not
  ) ;_ end of mapcar
) ;_ end of defun
(defun pickset-to-list (ss / item lst)
  (repeat (setq item (sslength ss)) ;_ end setq
    (setq lst (cons (ssname ss (setq item (1- item))) lst))
  ) ;_ end repeat

  lst
) ;_ end of defun 

(defun entmakex-hatch (L a n s)
  ;; By ElpanovEvgeniy
  ;; L - list of list point
  ;; A - angle hatch
  ;; N - name pattern
  ;; S - scale
  ;; returne - hatch ename
  (entmakex
    (apply
      'append
      (list
        (list '(0 . "HATCH")
              '(100 . "AcDbEntity")
              '(410 . "Model")
              '(100 . "AcDbHatch")
              '(10 0.0 0.0 0.0)
              '(210 0.0 0.0 1.0)
              (cons 2 n)
              (if (= n "SOLID")
                '(70 . 1)
                '(70 . 0)
              ) ;_  if
              '(71 . 0)
              (cons 91 (length l))
        ) ;_  list
        (apply
          'append
          (mapcar '(lambda (a)
                     (apply 'append
                            (list (list '(92 . 7)
                                        '(72 . 0)
                                        '(73 . 1)
                                        (cons 93 (length a))
                                  ) ;_ end of list
                                  (mapcar '(lambda (b) (cons 10 b)) a)
                                  '((97 . 0))
                            ) ;_  list
                     ) ;_  apply
                   ) ;_  lambda
                  l
          ) ;_  mapcar
        ) ;_  apply
        (list '(75 . 0)
              '(76 . 1)
              (cons 52 a)
              (cons 41 s)
              '(77 . 0)
              '(78 . 1)
              (cons 53 a)
              '(43 . 0.)
              '(44 . 0.)
              '(45 . 1.)
              '(46 . 1.)
              '(79 . 0)
              '(47 . 1.)
              '(98 . 2)
              '(10 0. 0. 0.0)
              '(10 0. 0. 0.0)
              '(451 . 0)
              '(460 . 0.0)
              '(461 . 0.0)
              '(452 . 1)
              '(462 . 1.0)
              '(453 . 2)
              '(463 . 0.0)
              '(463 . 1.0)
              '(470 . "LINEAR")
        ) ;_  list
      ) ;_  list
    ) ;_  apply
  ) ;_  entmakex
) ;_  defun

(defun In_Figure_only (Point Boundary / FarPoint Check)
 ;_Проверяет Boundary на условие car и last одна и та же точка
  (if (not (equal (car Boundary) (last Boundary) 1e-6))
    (setq Boundary (append Boundary (list (car Boundary))))
  ) ;_ end of if
  (setq FarPoint (cons (+ (apply 'max (mapcar 'car Boundary)) 1.0)
                       (cdr Point)
                 ) ;_ end of cons
  ) ;_ end of setq
  (not
    (zerop
      (rem
        (length
          (vl-remove
            nil
            (mapcar
              (function
                (lambda (p1 p2) (inters Point FarPoint p1 p2))
              ) ;_ end of function
              Boundary
              (cdr Boundary)
            ) ;_ end of mapcar
          ) ;_ end of vl-remove
        ) ;_ end of length
        2
      ) ;_ end of rem
    ) ;_ end of zerop
  ) ;_ end of not
) ;_ end of defun
(defun In_Figure (Point Boundary / FarPoint Check)
 ;_Проверяет Boundary на условие car и last одна и та же точка
  (if (not (equal (car Boundary) (last Boundary) 1e-6))
    (setq Boundary (append Boundary (list (car Boundary))))
  ) ;_ end of if
  (setq FarPoint (cons (+ (apply 'max (mapcar 'car Boundary)) 1.0)
                       (cdr Point)
                 ) ;_ end of cons
  ) ;_ end of setq
  (or
    (not
      (zerop
        (rem
          (length
            (vl-remove
              nil
              (mapcar
                (function
                  (lambda (p1 p2) (inters Point FarPoint p1 p2))
                ) ;_ end of function
                Boundary
                (cdr Boundary)
              ) ;_ end of mapcar
            ) ;_ end of vl-remove
          ) ;_ end of length
          2
        ) ;_ end of rem
      ) ;_ end of zerop
    ) ;_ end of not
    (vl-some (function (lambda (x) x))
             (mapcar
               (function (lambda (p1 p2)
                           (or Check
                               (if (equal (+ (distance Point p1)
                                             (distance Point p2)
                                          ) ;_ end of +
                                          (distance p1 p2)
                                          1e-3
                                   ) ;_ end of equal
                                 (setq Check t)
                                 nil
                               ) ;_ end of if
                           ) ;_ end of or
                         ) ;_ end of lambda
               ) ;_ end of function
               Boundary
               (cdr Boundary)

             ) ;_ end of mapcar
    ) ;_ end of vl-some
  ) ;_ end of or
) ;_ end of defun

Test1 - меняет слой полилиний, не содержащих внутри себя контуров на NO-HAVE-TEXT
Test2 - штрихует такие полилинии
Ограничения:
1. В качестве контуров рассматриваются замкнутые LW полилинии
- включен флаг замкнутости (Closed)
- совпадает начальная/конечная точка (точность 1e-6)
2. Рассматриваются 2D точки (не учитывается уровень полилиний)
3. Полилинии - выпуклые многоугольники (без самопересечений)
Пример для тестирования можно взять в #3

Сообщение от АлексЮстасу но могут состоять и из нескольких или даже из отрезков.

Это другой вопрос. Для этого есть pedit

Сообщение от АлексЮстасу но могут состоять и из нескольких или даже из отрезков

[АлексЮстасу]

Сообщение от VVA Ну так там у тебя нет текстов Ограничения: 1. В качестве контуров рассматриваются замкнутые LW полилинии - включен флаг замкнутости (Closed) - совпадает начальная/конечная точка (точность 1e-6) 2. Рассматриваются 2D точки (не учитывается уровень полилиний) 3. Полилинии - выпуклые многоугольники (без самопересечений) Пример для тестирования можно взять в #3 Это другой вопрос. Для этого есть pedit

Не сразу заметил приложенный выше последний код
Практически то, что нужно! Очень хорошо, что нет тупой привязки к признаку замкнутости Closed.

По поводу pedit мы уже параллельно обсуждали - из-за того, что в ней используется режим multiple, pedit сшивает не то, что нужно. В том числе и линии с разной высотой.

Можно сделать версию программы, которая находила бы не просто пустые контуры, а внутри которых нет блоков? По аналогии с самой первой, которая проверяет наличие текстов? Но на основе последней программы. Т.е. найти сначала контуры, внутри которых нет других контуров, и уже из них выбрать те, в которых нет блоков. Иначе возникает избыток найденных контуров из-за возможной их вложенности.