[v1talka]

Здравствуйте! Очень нужна помощь с написанием программы на AutoLISP. Условие: квадрантное представление окружности. То есть, пользователь должен выбрать окружность, которая будет представлена в виде квадратиков с точностью (количеством квадратиков), которую введет пользователь. Алгоритм выполнения представляю почти досконально, проблема только с реализацией этого на AutoLISP, который до этого не использовал. Буду очень благодарен, если кто согласится помочь.

[v1talka]

спасибо. отлично. проблема только в реализации по-прежнему

[Елпанов Евгений]

Сообщение от v1talka спасибо. отлично. проблема только в реализации по-прежнему

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

[gomer]

если алгоритм есть пиши блок-схему, выкладывай... код написать - 5 минут делов

[Дима_]

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

[v1talka]

Сообщение от Дима_ Я если честно так и не понял, что нужно заполнить круг "квадратиками" или прорисовать их по контуру

по алгоритму построения октантного дерева - нужно заполнить, но там по-другому это происходит. не важно в общем по контуру или заполнять

[Li6-D]

Простой и надежный квадратно-гнездовой способ:

Код:

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

 (defun c:test (/ c label-cell Li6-D r p d v dlim vp vd l n nn)
;Покрытие окружности ячейками квадратной сетки
  (prompt "Укажите круг: ")
  (or  (setq с (ssget "_:S" '((0 . "CIRCLE")))) (quit))
  (defun label-cell (sq f color)
    (cond 
      ((= f "квадрат")
        (grvecs (list color (car sq) (caddr sq) (caddr sq) (cadr sq)
                            (cadr sq) (cadddr sq) (cadddr sq) (car sq)))
      )
      ((= f "крест") (grvecs (cons color sq)))
  ) )
  (defun Li6-D (p / sq) ;c r v dlim label-cell - глобальные переменные
    (setq sq (mapcar '(lambda (a) (mapcar '+ a p)) v)
          p (vl-sort (mapcar '(lambda (a) (cons (distance a c) a)) sq)
             '(lambda (a b) (< (car a) (car b)))
    )       )
    (if (< (caar p) r (car (last p))) (label-cell sq "крест" 1) ;красные кресты
      (and
        (< r (caar p) dlim)
        (inters (cdar p) (cdadr p)
          (setq p (polar c (+ (angle (cdar p) (cdadr p)) (* 0.5 Pi)) r))
          (mapcar '(lambda (a b) (+ a a (- b))) c p)
        )
        (label-cell sq "квадрат" 2) ;желтые квадраты
  ) ) )
  (initget 33)
  (setq c (entget (ssname с 0))
        r (cdr (assoc 40 c))
        c (cdr (assoc 10 c))
        p (getpoint c "\nУкажите узел сетки: ")
  )
  (initget 33)
  (setq v (getpoint p "\nУкажите соседний узел сетки: ")
        d (distance p v)
        dlim (sqrt (+ (* r r) (* 0.25 d d)))
        v (mapcar '- v p)
        v (list
           '(0 0) (list (- (car v) (cadr v)) (+ (car v) (cadr v)))
            v (list (- (cadr v)) (car v))
  )       )
  (setq vp (mapcar '- p c) vd (caddr v))
  (repeat 2
    (setq l (/ (apply '+ (mapcar '* vp vd)) d)
          n (1+ (fix (/ (+ r l) d)))
          p (mapcar '(lambda (a b) (- a (* b n))) p vd)
          nn (cons (+ n (fix (/ (- r l) d)) 1) nn)
          vd (last v)
  ) )
  (repeat (cadr nn)
    (setq n p)
    (repeat (car nn) (Li6-D n) (setq n (mapcar '+ n vd)))
    (setq p (mapcar '+ p (caddr v)))
  )
  (princ)
)

А что если воспользоваться захватом объектов секущим квадратом: ssget "_F" ...?

[v1talka]

спасибо! похоже, но не совсем то, что нужно

[sbi]

Сообщение от v1talka спасибо! похоже, но не совсем то, что нужно

А что надо, можете объяснить?

[v1talka]

Сообщение от sbi А что надо, можете объяснить?

как мог пытался объяснить раньше в теме. скинул ссылки Вам в ЛС

[Li6-D]

Наконец-то понял вроде бы. Эта демострашка работает не только с окружностью, а с любыми объектами. Лишь бы они были видны на экране. Квадратики, в которые попали (не попали) кусочки объекта, рисуются временными векторами красного (желтого) цвета и исчезают при регенерации:

Код:

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

 (defun C:test (/ msq n sq pN sq0 CpN)
  (defun msq (sq p)
  ;;Функция msq для перемещения квадрата, задаваемого списком его вершин sq.
  ;;Второй аргумент p - точка, задающая вектор перемещения от точки '(0 0 0).
  ;;Функция возвращает список перемещенных точек sq.
    (mapcar '(lambda (a) (mapcar '+ a p)) sq)
  )
  ;Интерактивное изображение квадратной рамки поиска.
  ;Пользователь задает центр и середину стороны квадрата
  (vl-cmdf "_.POLYGON" "4" (getpoint "\nЦентр поиска: ") "_c" "\\")
  (initget 7)
  ;Задаваемое пользователем число покрывающих ячеек-квадратов делится на 2,
  ;при этом в алгоритме реально получается от 0.5*n до n ячеек (изредка - чуть больше n)
  (setq n (/ (getreal "\nНаибольшее число покрывающих ячеек: ") 2))
  ;Формирование списка вершин рамки поиска
  (foreach p (entget (setq sq (entlast)))
    (if (= (car p) 10) (setq pN (cons (cdr p) pN))))
  ;Удаление примитива рамки поиска
  (entdel sq)
  ;Формирование базового квадрата - исходный квадрат перемещается так,
  ;чтобы его первая точка ушла в '(0 0 0).
  ;Одновременно формируется начальный список точек pN.
  ;Каждая точка p этого списка соответствует квадрату с вершиной в p.
  ;Сначала в список вносится только одна точка - первая точка рамки поиска.
  (setq sq (msq pN (mapcar '- (car (setq pN (list (car pN)))))))
  (while (< (length pN) n) ;выход из цикла по превышению заданного числа квадратов
    ;Уменьшение базового квадрата в 2 раза
    (setq sq (mapcar '(lambda (p) (mapcar '(lambda (a) (/ a 2.)) p)) sq))
    (while pN ;перебор всех элементов списка pN пока он не кончится (см. ниже)
      ;Формирование квадрата из базового, перемещенного в текущую точку списка pN.
      ;В каждой из 4-х точек нового квадрата строится квадрату и с помощью функции
      ;выбора объектов ssget с опцией "_CP" (выбор секущим многоугольником) определяется
      ;есть ли в этих квадратах объекты чертежа. При наличии объектов начальная точка p
      ;квадрата добавляется в список CpN для формирования впоследствии нового списка pN.
      ;Кроме того, данный квадрат с помощью функции grdraw изображается временными
      ;векторами красного цвета
      (foreach p (msq sq (car pN))
        (if (apply 'ssget (list "_CP" (setq sq0 (msq sq p))))
          (setq CpN (cons p CpN))
          ;Изображение временными векторами желтого цвета пустых ячеек
          (foreach a (reverse sq0) (grdraw p (setq p a) 2))
      ) )
      (setq pN (cdr pN)) ;Удаление первого элемента из списка pN
    )
    (setq pN CpN CpN nil) ;Формирование нового списка pN и опустошение списка CpN
    ;Изображение временными векторами красного цвета непустых ячеек
    (foreach p pN (foreach a (reverse (msq sq p)) (grdraw p (setq p a) 1)))
    ;Вывод для пользователя текущих результатов (количество красных квадратов)
    (princ "\nТекущее число ячеек: ") (princ (length pN))
    (princ ". Нажмите любую клавишу для продолжения...") (grread)
  )
  (princ)
)

[v1talka]

спасибо большое. вроде почти то, что нужно. отображается правда только один квадратик + вроде больше 128 точность не выполняется. просто пропадает квадратик.

[Li6-D]

Сообщение от v1talka спасибо большое. вроде почти то, что нужно. отображается правда только один квадратик + вроде больше 128 точность не выполняется. просто пропадает квадратик.

Сначала задай квадратную зону и введи ограничение на число красных квадратиков (я вводил до 25000). А дальше нарисуется до 4-х квадратов, любуешься и жмешь ввод, на следующем шаге появится до 16-ти и т.д. пока не будет превышен порог (иногда может нарисоваться чуть больше). Объектов на чертеж программа не добавляет. Если сдвинуться по экрану - квадратики пропадут и можно показать преподавателю новую демонстрацию

[v1talka]

так и делал сразу. в первый раз появлялся 1 квадрат, а не 4 и т.д.

[Li6-D]

В первый раз пользователь задает квадратную рамку поиска объектов, которая рисуется белым цветом, а впоследствии стирается. Затем этот квадрат делится на 4 равные части и проверяется в каких квадратах есть объекты. Если объекты найдены, то соответствующий квадрат изображается красным цветом. На первом шаге может получиться от 0 (в зоне поиска не было видимых объектов) до 4 красных квадратов. Затем каждый из красных квадратов делится еще на 4 части и снова проверяется наличие видимых объектов в этих более мелких квадратах. Не пустые квадраты изображаются красным цветом, а пустые исчезают. Должна получится картинка подобно этой (3055 красных квадратов):

[v1talka]

всё так и делал. в AutoCAD 2012 неправильно работало, в 2005 версии всё отлично. спасибо огромное за помощь

[v1talka]

Еще вопрос: может ли функция ssget или её аналог как-нибудь работать в невидимой области чертежа?

[Nata1]

Интересная программа. А можно сделать так, чтобы красные квадратики не исчезали при регенерации? Тогда можно было бы распечатать прямо из Автокада.

[Li6-D]

Сообщение от Nata1 Интересная программа. А можно сделать так, чтобы красные квадратики не исчезали при регенерации? Тогда можно было бы распечатать прямо из Автокада.

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

Код:

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

 (defun C:test1 (/ msq p0 sq pN sq0 CpN)
  (defun msq (sq p) (mapcar '(lambda (a) (mapcar '+ a p)) sq))
  (vl-cmdf "_.POLYGON" "4" (setq p0 (getpoint "\nЦентр поиска: ")) "_c" "\\")
  (initget 7)
  (foreach p (entget (setq sq (entlast)))
    (if (= (car p) 10) (setq pN (cons (cdr p) pN))))
  (entdel sq)
  (setq sq (msq pN (mapcar '- (car (setq pN (list (car pN)))))))
  (while
    (progn
      (setq sq (mapcar '(lambda (p) (mapcar '(lambda (a) (/ a 2.)) p)) sq))
      (while pN
        (foreach p (msq sq (car pN))
          (if (apply 'ssget (list "_CP" (setq sq0 (msq sq p))))
            (setq CpN (cons p CpN))
            (foreach a (reverse sq0) (grdraw p (setq p a) 2))
        ) )
        (setq pN (cdr pN))
      )
      (setq pN CpN CpN nil)
      (foreach p pN (foreach a (reverse (msq sq p)) (grdraw p (setq p a) 1)))
      (princ "\nТекущее число ячеек: ") (princ (length pN))
      (initget "Yes No")
      (/= (getkword "\nПродолжить аппроксимацию объектов квадратами? [Yes/No] <Yes>: ") "No")
  ) )
  (initget "Yes No")
  (if (/= (getkword "\nСохранить в чертеже красную аппроксимирующую сетку? [Yes/No] <Yes>: ") "No")
    (progn
      (redraw)
      (entmake (list '(0 . "BLOCK") '(2 . "*Unnn") (setq p0 (cons 10 p0)) '(70 . 1)))
      (foreach p pN
        (foreach a (reverse (msq sq p))
          (entmake (list '(0 . "LINE") (cons 10 p) (cons 11 (setq p a)) '(62 . 1)))
      ) )
      (entmake (list '(0 . "INSERT") (cons 2 (entmake '((0 . "ENDBLK")))) p0))
  ) )
  (princ)
)

И напоминаю, что в связи с использованием ssget, процесс аппроксимации происходит только в видимой области и гаснет в невидимой

[Nata1]

Li6-D, спасибо! Попробовала в 2004 автокаде, все прекрасно работает!

[san3k]

Li6-D, скажите пожалуйста,а можно ли сделать так,чтобы квадратики не исчезали при сдвиге картинки?? И ещё как удалить квадраты,не пренадлежащие фигуре?