Лисп присадки мебельной фурнитуры

Скулачёв А. · 19.08.2008, 21:02

Сочинил Лисп для присадки мебельной фурнитуры. Серьёзно экономит моё время. Хочу услышать мнение знатаков по вопросу оптимизации алгоритма. Файл примера во вложении присаживается за 2,5 минуты. Нормально конечно, но хочется быстрее.

Код:

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

					
;Программа присадки фурнитуры
					;Автор Скулачёв Андрей 2008год
(defun C:lom (/ v1 v2 v3 v4 v5 i j)
  (SETVAR "CMDECHO" 0)			; Отключение эха команд.
  (SETVAR "BLIPMODE" 0)			; Отключение изображения маркера.
  (setq v1 (ssget "_X" (list (cons 0 "3DSOLID"))))
					;создание набора Панелей из примитивов типа 3DSOLID
  (setq v2 (ssget "_X" (list (cons 0 "INSERT"))))
					;создание набора фурнитуры из примитивов типа INSERT
  (if v2
    (progn
      (setq v3 (sslength v2))		;вычисление длины набора
      (setq i 0)			;переменная цикла
      (repeat v3			;цикл взрывания блоков
	(command "_.EXPLODE" (ssname v2 i))
					;поочерёдно взрывается каждый блок из набора v2
	(setq i (1+ i))			;переход к следующему элементу набора
      )					;конец цикла
      (setq v2 (ssget "_X" (list (cons 0 "3DSOLID"))))
					;создание набора из всех примитивов типа 3DSOLID
      (setq v3 (sslength v1))		;вычисление длины набора
      (setq i 0)			;переменная цикла
      (repeat v3			;цикл вычитания Панелей из общего набора, остаётся набор Фурнитуры.
	(setq v2 (ssdel (ssname v1 i) v2))
					;удаление из общего набора 3DSLOID набора Панелей
	(setq i (1+ i))			;переход к следующему элементу набора
      )					;конец цикла
      (setq v3 (sslength v1)
	    v4 (sslength v2)
      )					;вычисление длины набора
      (setq v5 (ssadd))			;создание нового пустого набора куда будет копироваться набор Фурнитуры
      (setq i 0
	    j 0
      )					;переменные цикла
      (repeat v3			;внешний цикл равен количеству панелей
	(repeat	v4			;внутренний цикл равен количесту фурнитуры
	  (command "._COPY"
		   (ssname v2 j)
		   ""
		   (list 0.0 0.0)
		   (list 0.0 0.0)
	  )				;копирование набора Фурнитуры
	  (ssadd (entlast) v5)		;добавление только-что скопированного элемента набора v2 в созданный ранее пустой набор v5
	  (setq j (1+ j))		;переход к следующему элементу набора v2
	)				;конец внутреннего цикла
	(command "_.SUBTRACT" (ssname v1 i) "" v5 "")
					;вычитание из элемента набора Панелей копии набора Фурнитуры
	(setq i (1+ i))			;переход к следующему элементу набора Панелей
	(setq j 0)			;обнуление переменной
	(setq v5 (ssadd))		;создание нового пустого набора куда будет копироваться набор Фурнитуры
      )					;конец внешнего цикла
    )					;конец progn
    (print "Набор фурнитуры не сформерован")
  )					;конец if
  (princ)
)

Дима_ · 19.08.2008, 21:34

Если хочеться побыстрее - то отказ от командных методов, то есть либо DXF либо VLA - в первом случае размер кода выростет соответсвенно производительности, про второй не знаю, в моем представлении код выростет не очень сильно, но будет побыстрее - насколько не знаю.

Кулик Алексей aka kpblc · 19.08.2008, 23:09

Помимо этого: не возвращаются значения системных переменных; нет обработчика ошибок; нет меток начала и конца отмены.
Если честно, я бы задумался о том, чтобы помещать, например, панели на один слой, фурнитуру - на другой. И формировать запросы соответственно с фильтрацией по слоям. Постарался бы не использовать _.explode - нет в ней такой уж сильной необходимости, как мне кажется...

Скулачёв А. · 19.08.2008, 23:21

Нет, _.explode нужен, так как мне удобно работать с блоками в 3D. Насчёт обработчиков ошибок, точек отката, это всё понятно. Интерисует алгоритм и скорость работы. Если я установлю точку отката это повысит производительность?

Кулик Алексей aka kpblc · 20.08.2008, 00:00

А не надо работать с блоками в 3Д и при этом их разбивать

Вот код получения vla-указателей на элементы, входящие в блок:

Код:

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

(defun get-block-cont (ent / res)
                      ;|
*    Получение списка элементов, входящих в обычный блок
*    Параметры вызова:
	ent	указатель на вхождение блока или описание блока.
		Допустимые значения:
		 ename
		 vla-object
		 string (расценивается как имя блока)
*    Примеры вызова:
(get-block-cont (car (entsel "\nУкажи блок ")))
|;
  (vl-load-com)
  (cond
    ((and (= (type ent) 'ename)
          (= (cdr (assoc 0 (entget ent))) "INSERT")
          ) ;_ end of and
     (setq res
            (get-block-cont
              (vla-item
                (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
                (cdr (assoc 2 (entget ent)))
                ) ;_ end of vla-item
              ) ;_ end of get-block-cont
           ) ;_ end of setq
     )
    ((and (= (type ent) 'str)
          (tblobjname "block" ent)
          ) ;_ end of and
     (setq
       res
        (get-block-cont
          (vla-item
            (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
            ent
            ) ;_ end of vla-item
          ) ;_ end of get-block-cont
       ) ;_ end of setq
     )
    ((and (= (type ent) 'vla-object)
          (= (vla-get-objectname ent) "AcDbBlockReference")
          ) ;_ end of and
     (setq res (get-block-cont
                 (vla-item (vla-get-activedocument (vlax-get-acad-object))
                           (vla-get-name ent)
                           ) ;_ end of vla-item
                 ) ;_ end of get-block-cont
           ) ;_ end of setq
     )
    ((and (= (type ent) 'vla-object)
          (= (vla-get-objectname ent) "AcDbBlockTableRecord")
          ) ;_ end of and
     (vlax-for sub ent
       (setq res (cons sub res))
       ) ;_ end of vlax-for
     (setq res (reverse res))
     )
    ) ;_ end of cond
  res
  ) ;_ end of defun

Скулачёв А. · 20.08.2008, 00:16

Ненадо ничего указывать, всё должно быть на автомате. А при таком способе возможно вычесть из 3D Панели блок, а сформировать список фурнитуры с признаком по слою? Повтаряю, нужен быстрый алгоритм. А чем так плох _.explode ? У меня это очень быстро происходит. Раз и всё взорвалось

Дима_ · 20.08.2008, 00:25

Цитата:

Сообщение от Скулачёв А.

А чем так плох _.explode ? У меня это очень быстро происходит. Раз и всё взорвалось

Тем и плох, что медленный, попробуй вместо него процедурку свою написать - сразу быстрее будет, ведь по сути command эмулирует юзера.

Кулик Алексей aka kpblc · 20.08.2008, 00:25

А кто тебе мешает получать набор, и потом уже из набора (без разбития) получать указатели? Это раз. Второе. Выполнение _.explode приводит к образованию новых примитивов и выделению под них хендлов (количество которых хотя и велико, но не бесконечно).

Скулачёв А. · 20.08.2008, 09:18

Основную работу делает команда _.SUBTRACT потеря времени происходит в формирование копии набора через команду _.COPY По сравнению с этим всё остальное просто ерунда и ни стоит того, чтобы над этим думать.

Кулик Алексей aka kpblc · 20.08.2008, 09:29

А, до меня только что "дошло". Я пас

Дима_ · 20.08.2008, 11:43

Ну давай попробуем хотябы COPY убрать:

Код:

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

;Программа присадки фурнитуры
					;Автор Скулачёв Андрей 2008год
(defun C:lom (/ v1 v2 v3 v4 v5 i j)
  (SETVAR "CMDECHO" 0)			; Отключение эха команд.
  (SETVAR "BLIPMODE" 0)			; Отключение изображения маркера.
  (setq v1 (ssget "_X" (list (cons 0 "3DSOLID"))))
					;создание набора Панелей из примитивов типа 3DSOLID
  (setq v2 (ssget "_X" (list (cons 0 "INSERT"))))
					;создание набора фурнитуры из примитивов типа INSERT
  (if v2
    (progn
      (setq v3 (sslength v2))		;вычисление длины набора
      (setq i 0)			;переменная цикла
      (repeat v3			;цикл взрывания блоков
	(command "_.EXPLODE" (ssname v2 i))
					;поочерёдно взрывается каждый блок из набора v2
	(setq i (1+ i))			;переход к следующему элементу набора
      )					;конец цикла
      (setq v2 (ssget "_X" (list (cons 0 "3DSOLID"))))
					;создание набора из всех примитивов типа 3DSOLID
      (setq v3 (sslength v1))		;вычисление длины набора
      (setq i 0)			;переменная цикла
      (repeat v3			;цикл вычитания Панелей из общего набора, остаётся набор Фурнитуры.
	(setq v2 (ssdel (ssname v1 i) v2))
					;удаление из общего набора 3DSLOID набора Панелей
	(setq i (1+ i))			;переход к следующему элементу набора
      )					;конец цикла
      (setq v3 (sslength v1)
	    v4 (sslength v2)
      )					;вычисление длины набора
      (setq v5 (ssadd))			;создание нового пустого набора куда будет копироваться набор Фурнитуры
      (setq i 0
	    j 0
      )					;переменные цикла
      (repeat v3			;внешний цикл равен количеству панелей
	(repeat	v4			;внутренний цикл равен количесту фурнитуры
;	  (command "._COPY"
;		   (ssname v2 j)
;		   ""
;		   (list 0.0 0.0)
;		   (list 0.0 0.0)
;	  )				;копирование набора Фурнитуры
;	  (ssadd (entlast) v5)		;добавление только-что скопированного элемента 	
(ssadd (dxfcopy (ssname v2 j)) v5); **** то же самое через dxf

;набора v2 в созданный ранее пустой набор v5
	  (setq j (1+ j))		;переход к следующему элементу набора v2
	)				;конец внутреннего цикла
	(command "_.SUBTRACT" (ssname v1 i) "" v5 "")
					;вычитание из элемента набора Панелей копии набора Фурнитуры
	(setq i (1+ i))			;переход к следующему элементу набора Панелей
	(setq j 0)			;обнуление переменной
	(setq v5 (ssadd))		;создание нового пустого набора куда будет копироваться набор Фурнитуры
      )					;конец внешнего цикла
    )					;конец progn
    (print "Набор фурнитуры не сформерован")
  )					;конец if
  (princ)
)

(defun dxfcopy (obj); создает копию объекта obj
(entmakex (cdr (entget obj)))
);end of dxfcopy

Скулачёв А. · 20.08.2008, 12:29

Цитата:

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

Ну давай попробуем хотябы COPY убрать:

При работе выдаёт ошибку ; error: bad argument type: lentityp nil

Дима_ · 20.08.2008, 12:53

Очень странно, у меня работает, попробуй замени:
(ssadd (dxfcopy (ssname v2 j)) v5)
на
(ssadd (entmakex (cdr (entget (ssname v2 j)))) v5)
а функцию dxfcopy убрать - хотя если и так не работает???
Вторым этапом - замена subtracta - тут боюсь не осилить будет, надо у знатоков vla спросить.

Скулачёв А. · 20.08.2008, 13:02

Цитата:

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

Очень странно, у меня работает, попробуй замени:
(ssadd (dxfcopy (ssname v2 j)) v5)
на
(ssadd (entmakex (cdr (entget (ssname v2 j)))) v5)
а функцию dxfcopy убрать - хотя если и так не работает???
Вторым этапом - замена subtracta - тут боюсь не осилить будет, надо у знатоков vla спросить.

Я скопировал твой предыдущий код и запустил, сначала всё работало, но где-то на второй минуте вылезла эта ошибка. А ты код до конца прогнал?

Дима_ · 20.08.2008, 13:12

на твоей тумбе нет - я нетерпеливый, нарисовал из нескольких простых примитивов и блоков - отработало. Скорее всего на вход каким-то образом nil попадает - так что как вариант:
(if (ssname v2 j)
(ssadd (entmakex (cdr (entget (ssname v2 j)))) v5)
)

Скулачёв А. · 20.08.2008, 13:17

Цитата:

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

Очень странно, у меня работает, попробуй замени:
(ssadd (dxfcopy (ssname v2 j)) v5)
на
(ssadd (entmakex (cdr (entget (ssname v2 j)))) v5)
а функцию dxfcopy убрать - хотя если и так не работает???
Вторым этапом - замена subtracta - тут боюсь не осилить будет, надо у знатоков vla спросить.

Работает, но на 1 мин и 10 сек медленнее.

Дима_ · 20.08.2008, 13:31

Проверь еще раз - может компьютер паралельно чем нибудь занят был, только что сравнивал
(repeat 1000 (entmakex (cdr (entget (entlast)))))
и
(repeat 1000 (command "_copy" (entlast) "" '(0 0) '(0 0)))
разница почти в 1,5 раза в пользу первого.
p.s. - не по поводу ускорения - а зачем ты блоки взрываешь а потом копируешь, может лучше наоборот сделать, тогда у тебя на выходе блоки останутся?

Скулачёв А. · 20.08.2008, 13:47

Цитата:

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

Проверь еще раз - может компьютер паралельно чем нибудь занят был, только что сравнивал
(repeat 1000 (entmakex (cdr (entget (entlast)))))
и
(repeat 1000 (command "_copy" (entlast) "" '(0 0) '(0 0)))
разница почти в 1,5 раза в пользу первого.
p.s. - не по поводу ускорения - а зачем ты блоки взрываешь а потом копируешь, может лучше наоборот сделать, тогда у тебя на выходе блоки останутся?

Тоесть копировать блоки, а потом разбивать? Я разбиваю блоки чтобы потом подсчитать количество фурнитуры. Фурнитура отсортирована по слоям. У меня есть файл .txt с зарезевированными названиями слоёв. Вообщем пишу для себя программу для работы. Имеющийся мебельный софт меня не устраивает.

Кулик Алексей aka kpblc · 20.08.2008, 13:59

Если у кого хватит терпения разобраться и попробовать добить:

Код:

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

(defun place-fitting (/                     *error*
                      adoc                  _dwgru-conv-pickset-to-list
                      fun_layer-status-save fun_get-block-cont
                      fun_layer-status-restore
                      fun_check-point-in-box
                      layer_status_lst      panels
                      lst                   fittings
                      pan_min               pan_max
                      pan_box
                      )

  (defun fun_get-block-cont (ent / res)
                            ;|
*    Получение списка элементов, входящих в обычный блок
*    Параметры вызова:
	ent	указатель на вхождение блока или описание блока.
		Допустимые значения:
		 ename
		 vla-object
		 string (расценивается как имя блока)
*    Примеры вызова:
(get-block-cont (car (entsel "\nУкажи блок ")))
|;
    (vl-load-com)
    (cond
      ((and (= (type ent) 'ename)
            (= (cdr (assoc 0 (entget ent))) "INSERT")
            ) ;_ end of and
       (setq res
              (fun_get-block-cont
                (vla-item
                  (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
                  (cdr (assoc 2 (entget ent)))
                  ) ;_ end of vla-item
                ) ;_ end of get-block-cont
             ) ;_ end of setq
       )
      ((and (= (type ent) 'str)
            (tblobjname "block" ent)
            ) ;_ end of and
       (setq
         res
          (fun_get-block-cont
            (vla-item
              (vla-get-blocks adoc)
              ent
              ) ;_ end of vla-item
            ) ;_ end of get-block-cont
         ) ;_ end of setq
       )
      ((and (= (type ent) 'vla-object)
            (= (vla-get-objectname ent) "AcDbBlockReference")
            ) ;_ end of and
       (setq res (fun_get-block-cont
                   (vla-item (vla-get-blocks adoc) (vla-get-name ent))
                   ) ;_ end of fun_get-block-cont
             ) ;_ end of setq
       )
      ((and (= (type ent) 'vla-object)
            (= (vla-get-objectname ent) "AcDbBlockTableRecord")
            ) ;_ end of and
       (vlax-for sub ent
         (setq res (cons sub res))
         ) ;_ end of vlax-for
       (setq res (reverse res))
       )
      ) ;_ end of cond
    res
    ) ;_ end of defun

  (defun fun_check-point-in-box (point min-point max-point / box)
    (or (and (>= (car point) (car min-point))
             (<= (car point) (car max-point))
             ) ;_ end of and
        (and (>= (cadr point) (cadr min-point))
             (<= (cadr point) (cadr max-point))
             ) ;_ end of and
        (and (>= (caddr point) (caddr min-point))
             (<= (caddr point) (caddr max-point))
             ) ;_ end of and
        ) ;_ end of or
    ) ;_ end of defun

  (defun _dwgru-conv-pickset-to-list (value / tab item)
    (repeat (setq tab  nil
                  item (sslength value)
                  ) ;_ end setq
      (setq tab (cons (ssname value (setq item (1- item))) tab))
      ) ;_ end repeat
    ) ;_ end defun

  (defun fun_layer-status-save (/ res)
    (vlax-for item (vla-get-layers adoc)
      (setq res (cons (list item
                            (cons "freeze" (vla-get-freeze item))
                            (cons "lock" (vla-get-lock item))
                            ) ;_ end of list
                      res
                      ) ;_ end of cons
            ) ;_ end of setq
      (foreach prop (list (cons "lock" :vlax-false)
                          (cons "freeze" :vlax-false)
                          ) ;_ end of list
        (vl-catch-all-apply
          '(lambda ()
             (vlax-put-property item (car prop) (cdr prop))
             ) ;_ end of lambda
          ) ;_ end of vl-catch-all-apply
        ) ;_ end of foreach
      ) ;_ end of vlax-for
    res
    ) ;_ end of defun

  (defun fun_layer-status-restore (lst)
    (foreach item lst
      (foreach prop (cdr item)
        (vl-catch-all-apply
          '(lambda ()
             (vlax-put-property (car item) (car prop) (cdr prop))
             ) ;_ end of lambda
          ) ;_ end of vl-catch-all-apply
        ) ;_ end of foreach
      ) ;_ end of foreach
    ) ;_ end of defun

  (defun *error* (msg)
    (fun_layer-status-restore layer_status_lst)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-startundomark
  (setq layer_status_lst (fun_layer-status-save))
  (if (and (setq panels (_dwgru-conv-pickset-to-list
                          (ssget "_X" '((0 . "3DSOLID")))
                          ) ;_ end of _dwgru-conv-pickset-to-list
                 ) ;_ end of setq
           (setq fittings (_dwgru-conv-pickset-to-list
                            (ssget "_X" '((0 . "INSERT")))
                            ) ;_ end of _dwgru-conv-pickset-to-list
                 ) ;_ end of setq
           ) ;_ end of and
    (progn
      (setq panels   (mapcar 'vlax-ename->vla-object panels)
            fittings (mapcar 'vlax-ename->vla-object fittings)
            ) ;_ end of setq
      (foreach ent panels
        (vla-getboundingbox ent 'pan_min 'pan_max)
        (setq pan_min (vlax-safearray->list pan_min)
              pan_max (vlax-safearray->list pan_max)
              ) ;_ end of setq
        (foreach item ;fittings
                      (vl-remove-if
                        (function
                          (lambda (x / minp maxp x1 y1 z1 x2 y2 z2)
                            (and (= (vla-get-objectname x) "AcDb3dSolid")
                                 ((lambda ()
                                    (vla-getboundingbox x 'minp 'maxp)
                                    (setq minp (vlax-safearray->list minp)
                                          maxp (vlax-safearray->list maxp)
                                          x1   (car minp)
                                          y1   (cadr minp)
                                          z1   (caddr minp)
                                          x2   (car maxp)
                                          y2   (cadr maxp)
                                          z2   (caddr maxp)
                                          ) ;_ end of setq
                                    (or (fun_check-point-in-box
                                          (list x1 y1 z1)
                                          pan_min
                                          pan_max
                                          ) ;_ end of fun_check-point-in-box
                                        (fun_check-point-in-box
                                          (list x2 y1 z1)
                                          pan_min
                                          pan_max
                                          ) ;_ end of fun_check-point-in-box
                                        (fun_check-point-in-box
                                          (list x2 y2 z1)
                                          pan_min
                                          pan_max
                                          ) ;_ end of fun_check-point-in-box
                                        (fun_check-point-in-box
                                          (list x1 y2 z1)
                                          pan_min
                                          pan_max
                                          ) ;_ end of fun_check-point-in-box
                                        (fun_check-point-in-box
                                          (list x1 y1 z2)
                                          pan_min
                                          pan_max
                                          ) ;_ end of fun_check-point-in-box
                                        (fun_check-point-in-box
                                          (list x2 y1 z2)
                                          pan_min
                                          pan_max
                                          ) ;_ end of fun_check-point-in-box
                                        (fun_check-point-in-box
                                          (list x2 y2 z2)
                                          pan_min
                                          pan_max
                                          ) ;_ end of fun_check-point-in-box
                                        (fun_check-point-in-box
                                          (list x1 y2 z2)
                                          pan_min
                                          pan_max
                                          ) ;_ end of fun_check-point-in-box
                                        ) ;_ end of or
                                    ) ;_ end of lambda
                                  )
                                 ) ;_ end of and
                            ) ;_ end of lambda
                          ) ;_ end of function
                        fittings
                        ) ;_ end of vl-remove-if-not
          (vla-highlight item :vlax-true)
          (foreach copied
                          ((lambda (/ res sub_lst orig ins)
                             (setq sub_lst (vl-remove-if-not
                                             '(lambda (x)
                                                (= (vla-get-objectname x) "AcDb3dSolid")
                                                ) ;_ end of lambda
                                             (fun_get-block-cont item)
                                             ) ;_ end of vl-remove-if-not
                                   orig    (vla-get-origin
                                             (vla-item (vla-get-blocks adoc)
                                                       (vla-get-name item)
                                                       ) ;_ end of vla-item
                                             ) ;_ end of vla-get-Origin
                                   res     (vla-copyobjects
                                             adoc
                                             (vlax-make-variant
                                               (vlax-safearray-fill
                                                 (vlax-make-safearray
                                                   vlax-vbobject
                                                   (cons 0 (1- (length sub_lst)))
                                                   ) ;_ end of vlax-make-safearray
                                                 sub_lst
                                                 ) ;_ end of vlax-safearray-fill
                                               ) ;_ end of vlax-make-variant
                                             (vla-get-modelspace adoc)
                                             ) ;_ end of vla-CopyObjects
                                   ) ;_ end of setq
                             ;; Здесь надо прописывать vla-move, потом vla-rotate и vla-TransformBy
                             ;; На это головы не хватило :(
                             res
                             ) ;_ end of lambda
                           )
            (vla-boolean ent acsubtraction copied)
            ) ;_ end of foreach
          ) ;_ end of foreach
        ) ;_ end of foreach
      ) ;_ end of progn
    ) ;_ end of if
  (fun_layer-status-restore layer_status_lst)
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

Подчеркиваю - код не рабочий!

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Лисп =выноска+поле	Pave1	LISP	56	29.06.2021 12:18
Интересно где работают ЛИСП программисты?	dextron3	LISP	114	17.12.2017 13:53
Ищу библиотеку мебельной фурнитуры	dek	Поиск литературы, чертежей, моделей и прочих материалов	0	07.08.2008 16:50
Лисп для копирования данных нескольких мтекстов по принципу расположения.	Red Nova	LISP	14	18.06.2008 22:08
Нужен лисп (пронизыватель лайаутов)	dextron3	LISP	91	25.07.2007 07:37