| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Готовые программы > LISP. Отрисовка произвольной трассы из отрезков и дуг.

LISP. Отрисовка произвольной трассы из отрезков и дуг.

Ответ
Поиск в этой теме
Непрочитано 16.02.2009, 08:40
LISP. Отрисовка произвольной трассы из отрезков и дуг.
Profan
 
Москва
Регистрация: 25.12.2005
Сообщений: 13,627

Программа может заменить стандартную команду "_Line" ("Отрезок")
Код:
[Выделить все]
 
;********** SETI.LSP ***********************************
; Программа отрисовки сети из сопряженных отрезков.
; Автор Громов В.В. 2009 г.
; Макрос для загрузки:
; ^C^C(if (not C:СЕТИ) (load "seti")) СЕТИ
;
(defun C:СЕТИ ( / echo rd pt1 pt2 pt3 ent1 ent2)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(if (null rds) (setq rds "0"))
(princ (strcat "\n Радиус сопряжения <" rds ">: "))
(setq rd (getint))
(if (= rd nil) (setq rd (atoi rds)) (setq rds (itoa rd)))
(vl-cmdf "_FILLET" "_r" rd)
(initget 7)
(setq pt1 (getpoint "\n Начальная точка: "))
(initget 7)
(setq pt2 (getpoint pt1 "\n Вторая точка: "))
(vl-cmdf "_LINE" pt1 pt2 "")
(setq ent1 (entlast))
(setq pt3 (getpoint pt2 "\n Следующая точка <Enter-Конец>: "))
(if pt3
(progn
(vl-cmdf "_LINE" pt2 pt3 "")
(setq ent2 (entlast))
(vl-cmdf "_fillet" ent1 ent2)
(while pt3
   (setq pt2 pt3)
   (setq ent1 ent2)
   (setq pt3 (getpoint pt2 "\n Следующая точка <Enter-Конец> "))
   (if pt3
       (progn
       (vl-cmdf "_LINE" pt2 pt3 "")
       (setq ent2 (entlast))
       (vl-cmdf "_fillet" ent1 ent2)
       )
       (princ "\n Конец.")
   )
)
)
)
(setvar "CMDECHO" echo)
(princ)
)
(princ "\n Ввести в командной строке СЕТИ")
Вариант с преобразованием отрезков и дуг в полилинию.

Код:
[Выделить все]
 
;********** SETI_PL.LSP *****************************************
; Программа отрисовки сети из сопряженных отрезков 
; с последующим объединением в полилинию.
; Автор Громов Владимир 2009 г.
; Макрос для загрузки:
; ^C^C(if (not C:СЕТИ_ПЛ) (load "seti_pl")) СЕТИ_ПЛ
;
(defun C:СЕТИ_ПЛ ( / echo rd pt1 pt2 pt3 ent1 ent2 ss dlina)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss (ssadd))
(if (null rds) (setq rds "0"))
(princ (strcat "\n Радиус сопряжения <" rds ">: "))
(setq rd (getint))
(if (= rd nil) (setq rd (atoi rds)) (setq rds (itoa rd)))
(vl-cmdf "_FILLET" "_r" rd)
(initget 7)
(setq pt1 (getpoint "\n Начальная точка: "))
(initget 7)
(setq pt2 (getpoint pt1 "\n Вторая точка: "))
(vl-cmdf "_LINE" pt1 pt2 "")
(setq ent1 (entlast))
(ssadd ent1 ss)
(setq pt3 (getpoint pt2 "\n Следующая точка <Enter-Конец>: "))
(if pt3
(progn
(vl-cmdf "_LINE" pt2 pt3 "")
(setq ent2 (entlast))
(ssadd ent2 ss)
(vl-cmdf "_fillet" ent1 ent2)
(ssadd (entlast) ss)
(while pt3
   (setq pt2 pt3)
   (setq ent1 ent2)
   (setq pt3 (getpoint pt2 "\n Следующая точка <Enter-Конец> "))
   (if pt3
       (progn
       (vl-cmdf "_LINE" pt2 pt3 "")
       (setq ent2 (entlast))
       (ssadd ent2 ss)
       (vl-cmdf "_fillet" ent1 ent2)
       (ssadd (entlast) ss)
       )
       (princ "\n Конец.")
   )
)
)
)
(vl-cmdf "_PEDIT" "_m" ss "" "_yes" "_join" "" "")
(vl-load-com)
(setq dlina (vlax-get-property (vlax-ename->vla-object (entlast)) 'length))
(princ "\n Длина трассы = ") (princ dlina)
(setvar "CMDECHO" echo)
(princ)
)
(princ "\n Ввести в командной строке СЕТИ_ПЛ")

Последний раз редактировалось Profan, 17.02.2009 в 06:16.
Просмотров: 16496
 
Непрочитано 20.02.2009, 14:50
#21
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Версия с восстановлением переменных USER*, отменой результатов команды за 1 раз
Код:
[Выделить все]
;;;********** SETI.LSP *********************************** 
;;; Программа отрисовки сети из сопряженных отрезков. 
;;; Автор Громов В.В. 2009 г. 
;;; Корректировка для опции Отмени (UNDO)
;;; 20.02.2009 Восстановление переменных, отмена команды за 1 раз
;;; Владимир Азарко (VVA) 
;;; Макрос для загрузки: 
;;; ^C^C(if (not C:СЕТИ)(load "seti"));СЕТИ; 
;;; ^C^C(if (not C:СЕТИ_ПЛ)(load "seti"));СЕТИ_ПЛ; 
;;; 

(defun C:СЕТИ_ПЛ ()(seti t)) 
(defun C:СЕТИ ()(seti nil)) 
(princ "\n Ввести в командной строке СЕТИ_ПЛ или СЕТИ") 
(defun seti ( toPline / rd pt1 pt2 ent1 ent2 U_M *error* eLast ss usr_list) 
;;;Функция seti - отрисовка сетей 
;;; Аргумент toPline = t - собирать в полилинию 
;;;          toPline = nil - нет 
  (vl-load-com) 
  ;;;Объявляем локальную ф-цию *error* 
  (defun *error* (msg / image_set) 
;;;Прерываем активную команду   
(while (> (getvar "CMDACTIVE") 0)(command)) 
(princ msg) 
(mapcar '(lambda(x)(setvar (car x)(cdr x))) usr_list)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))    
(princ) 
  )
;;;Проверяем установки UNDO и устанавливает All control 
  (setq U_M (getvar "UNDOCTL")) 
  (cond 
    ((= (logand U_M 1) 0)(command "_.UNDO" "_All"))  ;;; Отключено UNDO 
    ((= (logand U_M 3) 3)(command "_.UNDO" "_Control" "_All")) ;;; Разрешена отмена одной операции 
    (t nil) 
  ) ;_ end of cond
(setq usr_list  (mapcar '(lambda(x)(cons x (getvar x))) '("USERR1" "USERR2" "USERS1" "USERS2" "FILLETRAD" "CMDECHO")))
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
;(setq U_M (getvar "UNDOMARKS")) ;;;VVA Запоминаем счетчик отмен UNDO
(setq U_M 0) ;;;VVA Устанавливаем счетчик отмен UNDO  
(setvar "USERS1" "")  ;;;Чистим переменные 
(setvar "USERS2" "")  ;;;Чистим переменные 
(setvar "CMDECHO" 0) 
(if toPline   
;;; Запоминаем в eLast последний примитив 
(if (null(setq eLast (entlast))) 
    (progn (entmake '((0 . "point") (10 0.0 0.0 0.0))) 
       (setq eLast (entlast))(entdel eLast))) 
  ) 
(if (not(numberp *RDS*))(setq *RDS* (getvar "FILLETRAD"))) 
(princ "\n Радиус сопряжения <")(princ  *RDS*)(princ ">: ") 
(if (setq rd (getdist))(setq *RDS* rd)(setq rd *RDS*)) 
(setvar "FILLETRAD" rd)   
(initget 7) 
(setq pt1 (getpoint "\n Начальная точка: ")) 
(initget "Отмени Undo _Undo Undo") 
(while (setq pt2 (getpoint pt1 "\nСледующая точка [Отмени] <выход>: ")) 
  (cond 
     ((listp pt2) ;_Указана точка 
      ;;;Запоминаем в переменных USERR1 и USERR2 X и Y указанной точки 
      ;;;в мировых координатах. Это позволит пользователю прозрачно менять ПСК 
      (setvar "USERR1" (car (trans pt1 1 0))) ;;;Запоминаем X точки pt1 в МСК 
      (setvar "USERR2" (cadr (trans pt1 1 0)));;;Запоминаем Y точки pt1 в МСК 
      (command "_.UNDO" "_M")                 ;;;Ставим метку UNDO 
      (command "_.LINE" "_none" pt1 "_none" pt2 "") 
      (setvar "USERS1" (getvar "USERS2"))  ;;;Перемещаем метку 2-го примитива в 1-й 
      (setvar "USERS2" (cdr(assoc 5 (entget (entlast))))) ;;Метка последнего примитива 
      (if (and (setq ent1 (handent (getvar "USERS1")))  ;;; Примитив существует 
               (setq ent2 (handent (getvar "USERS2")))  ;;; Примитив существует 
               (entget ent1)  ;;; Примитив не удален 
               (entget ent2)  ;;; Примитив не удален 
               ) 
        (vl-cmdf "_.FILLET"  ent1 ent2) 

        ;;;Сопрягаем 
        )
      (setq U_M (1+ U_M)) ;;;VVA
      (setq pt1 pt2) 
      ) 
     ((= pt2 "Undo") 
      (if (> U_M 0) ;;;Если есть что отменять 
        (progn 
       (command "_.UNDO" "_B")
       (setq U_M (1- U_M)) ;;;VVA
       (setq pt1 (list (getvar "USERR1") (getvar "USERR2"))) 
           (setvar "LASTPOINT" (setq pt1 (trans pt1 0 1))) 
          ) 
        (alert "Отменять больше нечего") 
        ) 
      ) 
     (t nil) 
     ) 
(initget "Отмени Undo _Undo Undo") 
) 
  ;;;Нужно собрать все в полилинию 
  (if (and toPline eLast) 
    (progn 
     (setq ss (ssadd)) 
     (while (setq  eLast (entnext  eLast))(ssadd  eLast ss)) 
     (if (= (sslength ss) 0)(setq ss nil)) ;;; Пустой набор 
     (if ss ;;;что-то есть 
       (if (and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1)) 
         (vl-cmdf "_pedit" "_Multiple" ss "" "_Join" 0 "") 
         (vl-cmdf "_pedit" "_Multiple" ss "" "_Y" "_Join" 0 "") 
         ) 
       ) 
     (setq ss nil) 
      ) 
    )
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(mapcar '(lambda(x)(setvar (car x)(cdr x))) usr_list)
(princ) 
)
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 21.02.2009, 19:41
#22
Red Nova

ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Регистрация: 23.10.2007
Торонто
Сообщений: 1,980
Отправить сообщение для Red Nova с помощью Skype™


VVA, Некоторые пожелания.
1. При запросе радиуса сопряжения можно добавить возможность указания радиуса курсором, сейчас можно только в ком строку вводить.
2. Если выйти из сети_пл нажатием escape, то полилиния не создастся.
3. Предположим полилиния или цепь из линий уже существуют. Было бы полезным иметь возможность обработать и уже существующие примитивы.
4. Что если нужно закрыть рисуемую полилинию (close), но так чтобы начало с концом опять таки замкнулись образуя округление? Такая функция была бы также весьма кстати.

Что-то фонтазия моя разгулялась.
__________________
Блог

Последний раз редактировалось Red Nova, 21.02.2009 в 19:54.
Red Nova вне форума  
 
Автор темы   Непрочитано 21.02.2009, 20:51
#23
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,627


Red Nova, попробуй вот такую программу (типа шутки):
Код:
[Выделить все]
 
((defun C:ПСЕТЬ ( / echo rd)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 1)
(if (not(numberp *RDS*))(setq *RDS* (getvar "FILLETRAD")))
(princ "\n Радиус сопряжения или указать 2 точки <")(princ  *RDS*)(princ ">: ")
(if (setq rd (getdist))(setq *RDS* rd)(setq rd *RDS*))
(setvar "FILLETRAD" rd)
(vl-cmdf "_PLINE")
(while (/= (logand (getvar "cmdactive") 31) 0)
(command pause)
)
(vl-cmdf "_FILLET" "_p" (entlast))
(setvar "CMDECHO" echo)
(princ)
)

Последний раз редактировалось Profan, 21.02.2009 в 21:13.
Profan вне форума  
 
Непрочитано 22.02.2009, 10:35
#24
Громов Владимир

Инженер
 
Регистрация: 24.05.2008
г. Москва
Сообщений: 13


Вот еще вариант программы:
Код:
[Выделить все]
 
;;;********** SETI.LSP *********************************** 
;;; Программа отрисовки сети из сопряженных отрезков. 
;;; Автор Владимир Громов (Profan) 2009 г. 
;;;-------------------------------------------
;;; Корректировка для опции Отмени (UNDO)
;;; 20.02.2009 Восстановление переменных, отмена команды за 1 раз.
;;; Владимир Азарко (VVA) 
;;;-------------------------------------------
;;; 22.02.2009
;;; Добавлена простановка длин линейных сегментов на непечатаемом слое
;;; текущим текстовым стилем.
;;; Владимир Громов (Profan)
;;;-------------------------------------------
;;; Макрос для загрузки: 
;;; ^C^C(if (not C:СЕТИ)(load "seti"));СЕТИ; 
;;; ^C^C(if (not C:СЕТИ_ПЛ)(load "seti"));СЕТИ_ПЛ; 
;;; 
(defun C:СЕТИ_ПЛ ()(seti t)) 
(defun C:СЕТИ ()(seti nil)) 
(princ "\n Ввести в командной строке СЕТИ_ПЛ или СЕТИ") 
(defun seti ( toPline / rd pt1 pt2 ent1 ent2 U_M *error* eLast ss usr_list
                        lay dlina ugol lay_dlina kod40) 
;;;Функция seti - отрисовка сетей 
;;; Аргумент toPline = t - собирать в полилинию 
;;;          toPline = nil - нет 
  (vl-load-com) 
  ;;;Объявляем локальную ф-цию *error* 
  (defun *error* (msg / image_set kod40) 
;;;Прерываем активную команду   
(while (> (getvar "CMDACTIVE") 0)(command)) 
;(princ msg) 
(princ "\n *Работа программы отменена пользователем.*")
(setq kod40 (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))))
      (if (= kod40 0)
      (vl-cmdf "_TEXT" "0,0" "" "0" "1")
      (vl-cmdf "_TEXT" "0,0" "0" "1")
      )
(entdel (entlast))
(mapcar '(lambda(x)(setvar (car x)(cdr x))) usr_list)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))    
(princ) 
  )
;;;Проверяем установки UNDO и устанавливает All control 
  (setq U_M (getvar "UNDOCTL")) 
  (cond 
    ((= (logand U_M 1) 0)(command "_.UNDO" "_All"))  ;;; Отключено UNDO 
    ((= (logand U_M 3) 3)(command "_.UNDO" "_Control" "_All")) ;;; Разрешена отмена одной операции 
    (t nil) 
  ) ;_ end of cond
(setq usr_list  (mapcar '(lambda(x)(cons x (getvar x))) '("USERR1" "USERR2" "USERS1" "USERS2" 
"CLAYER" "CMDECHO")))
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
;(setq U_M (getvar "UNDOMARKS")) ;;;VVA Запоминаем счетчик отмен UNDO
(setq U_M 0) ;;;VVA Устанавливаем счетчик отмен UNDO  
(setvar "USERS1" "")  ;;;Чистим переменные 
(setvar "USERS2" "")  ;;;Чистим переменные 
(setvar "CMDECHO" 0) 
(if toPline   
;;; Запоминаем в eLast последний примитив 
(if (null(setq eLast (entlast))) 
    (progn (entmake '((0 . "point") (10 0.0 0.0 0.0))) 
       (setq eLast (entlast))(entdel eLast))) 
  ) 
(princ " Текущий радиус сопряжения = ") (princ (getvar "FILLETRAD"))  
(initget 7 "Р") 
(setq pt1 (getpoint "\n Начальная точка или [Радиус]: ")) 
(if (= pt1 "Р")
    (progn
    (princ " Радиус сопряжения <") (princ (getvar "FILLETRAD")) (princ "> или указать 2 точки: ")
    (initget 5)
    (setq rd (getdist))
    (setvar "FILLETRAD" rd) 
    (setq pt1 (getpoint "\n Начальная точка: ")) 
    )
)
(initget "Отмени Undo _Undo Undo") 
(while (setq pt2 (getpoint pt1 "\n Следующая точка [Отмени] <Enter-Выход>: ")) 
  (cond 
     ((listp pt2) ;_Указана точка 
      ;;;Запоминаем в переменных USERR1 и USERR2 X и Y указанной точки 
      ;;;в мировых координатах. Это позволит пользователю прозрачно менять ПСК 
      (setvar "USERR1" (car (trans pt1 1 0))) ;;;Запоминаем X точки pt1 в МСК 
      (setvar "USERR2" (cadr (trans pt1 1 0)));;;Запоминаем Y точки pt1 в МСК 
      (command "_.UNDO" "_M")                 ;;;Ставим метку UNDO 
      (command "_.LINE" "_none" pt1 "_none" pt2 "")
      (setq lay (vlax-get-property (vlax-ename->vla-object (entlast)) 'layer))
      (setq dlina (/ (vlax-get-property (vlax-ename->vla-object (entlast)) 'length) 1000)) ; в метрах
;      (setq dlina (vlax-get-property (vlax-ename->vla-object (entlast)) 'length))
      (setq ugol (vlax-get-property (vlax-ename->vla-object (entlast)) 'angle))
      (setq ugol (* (/ 180 pi) ugol))
      (setq lay_dlina (strcat lay "_длина"))
      (vl-cmdf "_-LAYER" "_m" lay_dlina "_c" "1" "" "_p" "_no" "" "")
 
      (setvar "USERS1" (getvar "USERS2"))  ;;;Перемещаем метку 2-го примитива в 1-й 
      (setvar "USERS2" (cdr(assoc 5 (entget (entlast))))) ;;Метка последнего примитива
      (setq kod40 (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))))
      (if (= kod40 0)
      (vl-cmdf "_TEXT" "_m2p" pt1 pt2 "" ugol (rtos dlina 2 0))
      (vl-cmdf "_TEXT" "_m2p" pt1 pt2 ugol (rtos dlina 2 0))
      )
      (setvar "CLAYER" lay)
      (if (and (setq ent1 (handent (getvar "USERS1")))  ;;; Примитив существует 
               (setq ent2 (handent (getvar "USERS2")))  ;;; Примитив существует 
               (entget ent1)  ;;; Примитив не удален 
               (entget ent2)  ;;; Примитив не удален 
               ) 
        (vl-cmdf "_.FILLET"  ent1 ent2) 
        ;;;Сопрягаем 
        )
      (setq U_M (1+ U_M)) ;;;VVA
      (setq pt1 pt2) 
      ) 
     ((= pt2 "Undo") 
      (if (> U_M 0) ;;;Если есть что отменять 
        (progn 
       (command "_.UNDO" "_B")
       (setq U_M (1- U_M)) ;;;VVA
       (setq pt1 (list (getvar "USERR1") (getvar "USERR2"))) 
           (setvar "LASTPOINT" (setq pt1 (trans pt1 0 1))) 
          ) 
        (alert "Отменять больше нечего") 
        ) 
      ) 
     (t nil) 
     ) 
(initget "Отмени Undo _Undo Undo") 
) 
  ;;;Нужно собрать все в полилинию 
  (if (and toPline eLast) 
    (progn 
     (setq ss (ssadd)) 
     (while (setq  eLast (entnext  eLast))(ssadd  eLast ss)) 
     (if (= (sslength ss) 0)(setq ss nil)) ;;; Пустой набор 
     (if ss ;;;что-то есть 
       (if (and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1)) 
         (vl-cmdf "_pedit" "_Multiple" ss "" "_Join" 0 "") 
         (vl-cmdf "_pedit" "_Multiple" ss "" "_Y" "_Join" 0 "") 
         ) 
       ) 
     (setq ss nil) 
      ) 
    )
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(mapcar '(lambda(x)(setvar (car x)(cdr x))) usr_list)
(vl-cmdf "_TEXT" "0,0" "" "0" "1")
(entdel (entlast))
(princ) 
)
VVA, не понятно мне наличие имени переменной image_set в функции *error*. Откуда она взялась? И можно ли убрать возможность "прозрачно менять ПСК"?
Громов Владимир вне форума  
 
Непрочитано 22.02.2009, 18:46
#25
Red Nova

ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Регистрация: 23.10.2007
Торонто
Сообщений: 1,980
Отправить сообщение для Red Nova с помощью Skype™


Profan,
Close и ввод радиуса - самое то, но, конечно же, вариант округления real time от VVA куда эффектнее.
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 22.02.2009, 20:02
#26
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,627


Цитата:
...но, конечно же, вариант округления real time от VVA куда эффектнее.
Какое еще округление?
Если ты про сопряжение, то посмотри, с чего тема начиналась.
И вообще, первую программу я сочинил в таком виде (сопряженные отрезки) именно из-за эффектности отрисовки. Если бы конечной целью было бы просто получение трассы из отрезков и дуг, то ничего проще не было бы расчленить полилинию, полученную в программе, приведенную в сообщении 23 и все. Ведь даже возможность отмены отрисованных сегментов уже присутствует в команде "_PLINE". Странно, что никто не предложил такой простой способ - фактически решение обратной задачи.

Последний раз редактировалось Profan, 22.02.2009 в 21:28.
Profan вне форума  
 
Непрочитано 22.02.2009, 23:29
#27
Red Nova

ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Регистрация: 23.10.2007
Торонто
Сообщений: 1,980
Отправить сообщение для Red Nova с помощью Skype™


Цитата:
Какое еще округление?
Если ты про сопряжение, ...
Да простит меня препод начерталки за сие недоумение.
Цитата:
Если бы конечной целью было бы просто получение трассы из отрезков и дуг, то ничего проще не было бы расчленить полилинию, полученную в программе, приведенную в сообщении 23 и все.
Дык ясен перец. Эдакую прожку и я осилил бы написать (уроки от VVA все же не прошли даром). Но этот простой вариант с #23 имеет свои маленькие плюсы. И было бы неплохо перенять их и добавить в "правильный" вариант.
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 23.02.2009, 07:21
#28
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,627


Red Nova, я раньше написал, что программа была написана по просьбе слаботочников. Я предлагал им сразу оперировать полилинией при отрисовке трасс сетей. Но... не работают они с полилинией. Поэтому дополнительная возможность превращения массива отрезков и дуг в полилинию является факультативной. Однако, чувствую я, что им придется перейти на полилинию, когда я вплотную приступлю к составлению программ для проектирования телевизионного кабельного вещания с учетом затухания сигнала в кабеле в зависимости от длины кабеля. Задача, как видишь, специализированная. Если же тебе хочется приспособить данные программы для своих нужд, то, может, стоит создать соответствующую тему со своими пожеланиями. Хотя, можно ведь замкнуть и выполнить сопряжение первого и последнего сегментов получившейся полилинии вручную после выхода из программы. Можно, конечно, и здесь переделать программу, но у меня была цель сделать программу с минимальным количеством запросов и в последнем варианте дополнительные запросы вообще отсутствуют, если радиус сопряжения устраивает проектировщика. Именно из-за этого я убрал возвращение переменной FILLETRAD к начальному состоянию. Есть еще пока не проявившаяся проблема. У слаботочников может быть много линий связи, а слой для простановки длины сегментов образуется добавлением суффикса "_длина" к соответствующему имени слоя. Получается, например, такое имя слоя: "СС_пожар_длина". Так вот, боюсь, что слаботочникам может не понравится нагромождение новых слоев и придется программу как-то корректировать. Но в направлении удобства именно слаботочников, а не универсализации программы для любых нужд. Но это мои предпочтения, если VVA или другие товарищи пойдут тебе навстречу - ничего плохого не случится.
Profan вне форума  
 
Непрочитано 23.02.2009, 08:23
#29
Red Nova

ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Регистрация: 23.10.2007
Торонто
Сообщений: 1,980
Отправить сообщение для Red Nova с помощью Skype™


Цитата:
Если же тебе хочется приспособить данные программы для своих нужд, то, может, стоит создать соответствующую тему со своими пожеланиями
Ухожу ухожу
................
Offtop: И все таки она вертится
__________________
Блог
Red Nova вне форума  
 
Непрочитано 23.02.2009, 13:45
#30
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Начнем не по порядку
Цитата:
VVA, не понятно мне наличие имени переменной image_set в функции *error*. Откуда она взялась? И можно ли убрать возможность "прозрачно менять ПСК"?
1. image_set. когда копировал с другого места забыл убрать
2. прозрачно менять ПСК. Нужно. Пользователь прозрачно менять не сможет. Прозрачно менять сможешь ты, если захочешь.
Цитата:
VVA, Некоторые пожелания.
1. При запросе радиуса сопряжения можно добавить возможность указания радиуса курсором, сейчас можно только в ком строку вводить.
2. Если выйти из сети_пл нажатием escape, то полилиния не создастся.
3. Предположим полилиния или цепь из линий уже существуют. Было бы полезным иметь возможность обработать и уже существующие примитивы.
4. Что если нужно закрыть рисуемую полилинию (close), но так чтобы начало с концом опять таки замкнулись образуя округление? Такая функция была бы также весьма кстати.
1. Это было уже в коде из #21
2. Решено. Выделено красным.
3. Pedit с опцией "Join" и Fillet с опцией "Polyline"
4. Добавлена.
Код:
[Выделить все]
;;;********** SETI.LSP *********************************** 
;;; Программа отрисовки сети из сопряженных отрезков. 
;;; Автор Громов В.В. 2009 г. 
;;; Корректировка для опции Отмени (UNDO)
;;; 20.02.2009 Восстановление переменных, отмена команды за 1 раз
;;; Владимир Азарко (VVA) 
;;; Макрос для загрузки: 
;;; ^C^C(if (not C:СЕТИ)(load "seti"));СЕТИ; 
;;; ^C^C(if (not C:СЕТИ_ПЛ)(load "seti"));СЕТИ_ПЛ; 
;;; 
(defun C:СЕТИ_ПЛ () (seti t))
(defun C:СЕТИ () (seti nil))
(princ "\n Ввести в командной строке СЕТИ_ПЛ или СЕТИ")
(defun seti (toPline / rd pt1 pt2 ent1 ent2 U_M *error* eLast ss
      usr_list pts)
;;;Функция seti - отрисовка сетей 
;;; Аргумент toPline = t - собирать в полилинию 
;;;          toPline = nil - нет 
  (vl-load-com)
;;;Объявляем локальную ф-цию *error* 
  (defun *error* (msg)
;;;Прерываем активную команду   
    (while (> (getvar "CMDACTIVE") 0) (command))
    (princ msg)
    (mapcar '(lambda (x) (setvar (car x) (cdr x))) usr_list)
    (vla-EndUndoMark
      (vla-get-activedocument (vlax-get-acad-object))
    )
    (princ)
  )
;;;Проверяем установки UNDO и устанавливает All control 
  (setq U_M (getvar "UNDOCTL"))
  (cond
    ((= (logand U_M 1) 0) ;_ Отключено UNDO
     (command "_.UNDO" "_All")
     )
    ((= (logand U_M 3) 3) ;_ Разрешена отмена одной операции
     (command "_.UNDO" "_Control" "_All") 
     )
    (t nil)
  ) ;_ end of cond
  (setq usr_list (mapcar '(lambda (x) (cons x (getvar x)))
    '("USERR1"  "USERR2"      "USERS1"
      "USERS2"  "FILLETRAD"   "CMDECHO"
     )
   )
  )
  (vla-StartUndoMark
    (vla-get-activedocument (vlax-get-acad-object))
  )
  (setq U_M 0) ;_VVA Устанавливаем счетчик отмен UNDO  
  (setvar "USERS1" "") ;_Чистим переменные 
  (setvar "USERS2" "") ;_Чистим переменные 
  (setvar "CMDECHO" 0)
  (if toPline
;;; Запоминаем в eLast последний примитив 
    (if (null (setq eLast (entlast)))
      (progn (entmake '((0 . "point") (10 0.0 0.0 0.0)))
      (setq eLast (entlast))
      (entdel eLast)
      )
    )
  )
  (if (not (numberp *RDS*))
    (setq *RDS* (getvar "FILLETRAD"))
  )
  (setvar "FILLETRAD" *RDS*)
;;;Ставим ловушку на случай нажатия ESC
  (VL-CATCH-ALL-APPLY
    '(LAMBDA () ;_---> Начало
       (initget 7)
       (setq pt1 (getpoint "\n Начальная точка: "))
       (setq pts pt1)
       (initget "Замкни Радиус Отмени Undo _Close R Undo Undo")
       (while
  (and pts
       (or (princ "\nРадиус <") (princ *RDS*) (princ "> ") t)
       (setq
  pt2 (getpoint
        pt1
        "Следующая точка [Радиус/Замкни/Отмени] <выход>: "
      )
       )
  )
   (if (= pt2 "Close") ;_Выбрана опция замкни
     (progn
       (setq pt2 pts ;_ Начало в pt2
      pts nil ;_ pts в nil чтобы прервать цикл
       )
     )
   )
   (cond
     ((= pt2 "R") ;_ Выбрана опция радиус
      (princ "\n Радиус сопряжения <")
      (princ *RDS*)
      (princ ">: ")
      (if (setq rd (getdist))
        (setq *RDS* rd)
        (setq rd *RDS*)
      )
      (setvar "FILLETRAD" rd)
     )
     ((listp pt2) ;_Указана точка 
;;;Запоминаем в переменных USERR1 и USERR2 X и Y указанной точки 
;;;в мировых координатах.
      (setvar "USERR1" (car (trans pt1 1 0))) ;_Запоминаем X точки pt1 в МСК 
      (setvar "USERR2" (cadr (trans pt1 1 0)));_Запоминаем Y точки pt1 в МСК 
      (command "_.UNDO" "_M") ;_Ставим метку UNDO 
      (command "_.LINE" "_none" pt1 "_none" pt2 "")
      (setvar "USERS1" (getvar "USERS2")) ;_Перемещаем метку 2-го примитива в 1-й 
      (setvar "USERS2" (cdr (assoc 5 (entget (entlast))))) ;_Метка последнего примитива 
      (if (and (setq ent1 (handent (getvar "USERS1"))) ;_ Примитив существует 
        (setq ent2 (handent (getvar "USERS2"))) ;_ Примитив существует 
        (entget ent1) ;_ Примитив не удален 
        (entget ent2) ;_ Примитив не удален 
   )
        (vl-cmdf "_.FILLET" ent1 ent2) ;_Сопрягаем 
      )
      (setq U_M (1+ U_M))
      (setq pt1 pt2)
     )
     ((= pt2 "Undo")
      (if (> U_M 0) ;_ Если есть что отменять 
        (progn
   (command "_.UNDO" "_B")
   (setq U_M (1- U_M))
   (setq pt1 (list (getvar "USERR1") (getvar "USERR2")))
   (setvar "LASTPOINT" (setq pt1 (trans pt1 0 1)))
        )
        (alert "Отменять больше нечего")
      )
     )
     (t nil)
   )
   (initget "Замкни Радиус Отмени Undo _Close R Undo Undo")
       )
     )
  ) ;_<--- Конец
;;;Нужно собрать все в полилинию 
  (if (and toPline eLast)
    (progn
      (setq ss (ssadd))
      (while (setq eLast (entnext eLast)) (ssadd eLast ss))
      (if (= (sslength ss) 0);_ Пустой набор 
 (setq ss nil)
      )
      (if ss  ;_ что-то есть 
 (if (and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1))
   (vl-cmdf "_pedit" "_Multiple" ss "" "_Join" 0 "")
   (vl-cmdf "_pedit" "_Multiple" ss "" "_Y" "_Join" 0 "")
 )
      )
      (setq ss nil)
    )
  )
  (vla-EndUndoMark
    (vla-get-activedocument (vlax-get-acad-object))
  )
  (mapcar '(lambda (x) (setvar (car x) (cdr x))) usr_list)
  (princ)
)
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 23.02.2009, 17:52
#31
Red Nova

ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Регистрация: 23.10.2007
Торонто
Сообщений: 1,980
Отправить сообщение для Red Nova с помощью Skype™


VVA,
У меня пока нормально не работает, возможно это из за русских терминов [Радиус/Замкни/Отмени], такое у меня частенько бывает. Радиус не вводится теперь ни с клавы ни с экрана, замыкание тоже не реагирует. На сколько я понял радиус должен вводится выбором в подменю. По моему субъективному мнению вариант когда радиус запрашивался в начале удобнее.
Offtop: Profan, что-то не получается покинуть твою тему
__________________
Блог
Red Nova вне форума  
 
Автор темы   Непрочитано 07.02.2010, 21:17
#32
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,627


Вариант с преобразованием отрезков и дуг в отдельные сегменты полилиний
Код:
[Выделить все]
 
;********** SETI_PL.LSP *****************************************
; Программа отрисовки сети из сопряженных отрезков 
; с последующим преобразованием в отдельные сегменты полилиний.
; Автор Громов Владимир aka Profan 2010 г.
; Макрос для загрузки:
; ^C^C(if (not C:СЕТИ_ПЛ) (load "seti_pl")) СЕТИ_ПЛ
;
(defun C:СЕТИ_ПЛ ( / echo rd pt1 pt2 pt3 ent1 ent2 ss wdt1 wdt)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss (ssadd))
(if (null rds) (setq rds "0"))
(princ (strcat "\n Радиус сопряжения <" rds ">: "))
(setq rd (getint))
(if (= rd nil) (setq rd (atoi rds)) (setq rds (itoa rd)))
(vl-cmdf "_FILLET" "_r" rd)
(initget 7)
(setq pt1 (getpoint "\n Начальная точка: "))
(initget 7)
(setq pt2 (getpoint pt1 "\n Вторая точка: "))
(vl-cmdf "_LINE" pt1 pt2 "")
(setq ent1 (entlast))
(ssadd ent1 ss)
(setq pt3 (getpoint pt2 "\n Следующая точка <Enter-Конец>: "))
(if pt3
(progn
(vl-cmdf "_LINE" pt2 pt3 "")
(setq ent2 (entlast))
(ssadd ent2 ss)
(vl-cmdf "_fillet" ent1 ent2)
(ssadd (entlast) ss)
(while pt3
   (setq pt2 pt3)
   (setq ent1 ent2)
   (setq pt3 (getpoint pt2 "\n Следующая точка <Enter-Конец> "))
   (if pt3
       (progn
       (vl-cmdf "_LINE" pt2 pt3 "")
       (setq ent2 (entlast))
       (ssadd ent2 ss)
       (vl-cmdf "_fillet" ent1 ent2)
       (ssadd (entlast) ss)
       )
       (princ "\n Конец.")
   )
)
)
)
(setq wdt1 (getvar "PLINEWID"))
      (princ "\n Ширина сегментов полилинии <") (princ wdt1) (princ ">: ")
      (setq wdt (getreal))
      (if (= wdt nil) (setq wdt wdt1))
(cond
((= (getvar "PEDITACCEPT") 0) (vl-cmdf "_PEDIT" "_m" ss "" "_yes" "_w" wdt ""))
((= (getvar "PEDITACCEPT") 1) (vl-cmdf "_PEDIT" "_m" ss "" "_w" wdt ""))
)
(setvar "CMDECHO" echo)
(princ)
)
(princ "\n Ввести в командной строке СЕТИ_ПЛ")

Последний раз редактировалось Profan, 08.02.2010 в 09:23.
Profan вне форума  
 
Непрочитано 07.02.2010, 23:55
#33
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


peditaccept не проверяешь...
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 08.02.2010, 05:10
#34
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,627


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
peditaccept не проверяешь...
А зачем ее проверять, если отрисовка изначально выполняется исключительно отрезками?
Хотя, ты прав. У продвинутых пользователей, таких, как Vova, например, peditaccept вполне может оказаться равной 1 (для упрощения макросов). Это в моей конторе пользователи могут даже не подозревать о такой переменной. Подправлю.

Последний раз редактировалось Profan, 08.02.2010 в 05:39.
Profan вне форума  
 
Непрочитано 22.10.2010, 23:19
#35
Basawur

Konstrukteur
 
Регистрация: 28.09.2008
Europa
Сообщений: 20
<phrase 1=


Очень даже не плохо!
Лично мне больше глянулся вариант от VVA пост #21.
Ещё бы "Подобие" и "Замкнуть" как-нибудь прикрутить, было бы симпатичнее.
Basawur вне форума  
 
Непрочитано 10.01.2011, 20:18
#36
Jonas

конструктор машиностроитель
 
Регистрация: 14.05.2007
Новосибирск
Сообщений: 893


Уважаемые аксакалы. Программа заинтересовала возможностью отрисовки траектории для последующего выдавливания при 3Д моделировании. В машиностроении нет длинных трасс (во всяком случае в моей практике), но приходиться моделировать линии гидропривода, пневмопривода и электрооборудования. Для этого лучше подходит отриовка с созданием полилинии но есть проблема, при отрисовке по всем осям x,y и z, в конце операции исчезает часть трассы.

Нельзя ли как то это исправить?
И еще нельзя ли в процессе отрисовки менять радиус сопряжения?
Jonas вне форума  
 
Непрочитано 17.07.2011, 08:05
#37
LastGraff


 
Регистрация: 13.07.2011
Томск
Сообщений: 81


Сенкс, очень помогло...
LastGraff вне форума  
 
Непрочитано 02.08.2011, 14:00
#38
ivsib


 
Регистрация: 29.07.2011
Сообщений: 2


Уважаемые разработчики мегакласных штук а нельзя ли к этому лиспу добавить несколько функций.
Хотелось бы чтобы в конце итоговая полилиния оффсетилась (_offset) на определенное расстояние и разбивалась на отрезки (_explode). А исходная полилиния удалялась.
Ради этого даже начал изучать LISP. И уже получилось сделать подобие и удалить исходную полилинию, но разбить подобную полилинию на отрезки никак не могу.
Помогите пожалуйста.
Заранее спасибо!
ivsib вне форума  
 
Непрочитано 02.08.2011, 14:10
#39
Nike

Шаражпроектхалтурмонтаж
 
Регистрация: 29.10.2004
Талды-Париж
Сообщений: 5,989


Цитата:
Сообщение от ivsib Посмотреть сообщение
но разбить подобную полилинию на отрезки никак не могу.
(command "_explode" "_l")
Nike вне форума  
 
Непрочитано 02.08.2011, 14:23
#40
ivsib


 
Регистрация: 29.07.2011
Сообщений: 2


Так не получается или я куда то не туда добавляю команду
Приведу текст лиспа. Красным выделено то что я добавил.
Если без строки (command "_explode" "_L") то работает

Код:
[Выделить все]
;;;********** SETI.LSP ***********************************
;;; Программа отрисовки сети из сопряженных отрезков.
;;; Автор Громов В.В. 2009 г.
;;; Корректировка для опции Отмени (UNDO)
;;; 20.02.2009 Восстановление переменных, отмена команды за 1 раз
;;; Владимир Азарко (VVA)
;;; Макрос для загрузки:
;;; ^C^C(if (not C:СЕТИ)(load "seti"));СЕТИ;
;;; ^C^C(if (not C:СЕТИ_ПЛ)(load "seti"));СЕТИ_ПЛ;
;;;

(defun C:СЕТИ_ПЛ ()(seti t))
(defun C:СЕТИ ()(seti nil))
(princ "\n Ввести в командной строке СЕТИ_ПЛ или СЕТИ")
(defun seti ( toPline / rd pt1 pt2 ent1 ent2 U_M *error* eLast ss usr_list)
;;;Функция seti - отрисовка сетей
;;; Аргумент toPline = t - собирать в полилинию
;;;          toPline = nil - нет
  (vl-load-com)
  ;;;Объявляем локальную ф-цию *error*
  (defun *error* (msg / image_set)
;;;Прерываем активную команду  
(while (> (getvar "CMDACTIVE") 0)(command))
(princ msg)
(mapcar '(lambda(x)(setvar (car x)(cdr x))) usr_list)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))    
(princ)
  )
;;;Проверяем установки UNDO и устанавливает All control
  (setq U_M (getvar "UNDOCTL"))
  (cond
    ((= (logand U_M 1) 0)(command "_.UNDO" "_All"))  ;;; Отключено UNDO
    ((= (logand U_M 3) 3)(command "_.UNDO" "_Control" "_All")) ;;; Разрешена отмена одной операции
    (t nil)
  ) ;_ end of cond
(setq usr_list  (mapcar '(lambda(x)(cons x (getvar x))) '("USERR1" "USERR2" "USERS1" "USERS2" "FILLETRAD" "CMDECHO")))
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
;(setq U_M (getvar "UNDOMARKS")) ;;;VVA Запоминаем счетчик отмен UNDO
(setq U_M 0) ;;;VVA Устанавливаем счетчик отмен UNDO  
(setvar "USERS1" "")  ;;;Чистим переменные
(setvar "USERS2" "")  ;;;Чистим переменные
(setvar "CMDECHO" 0)
(if toPline  
;;; Запоминаем в eLast последний примитив
(if (null(setq eLast (entlast)))
    (progn (entmake '((0 . "point") (10 0.0 0.0 0.0)))
       (setq eLast (entlast))(entdel eLast)))
  )
(if (not(numberp *RDS*))(setq *RDS* (getvar "FILLETRAD")))
(princ "\n Радиус сопряжения <")(princ  *RDS*)(princ ">: ")
(if (setq rd (getdist))(setq *RDS* rd)(setq rd *RDS*))
(setvar "FILLETRAD" rd)  
(initget 7)
(setq pt1 (getpoint "\n Начальная точка: "))
(initget "Отмени Undo _Undo Undo")
(while (setq pt2 (getpoint pt1 "\nСледующая точка [Отмени] <выход>: "))
  (cond
     ((listp pt2) ;_Указана точка
      ;;;Запоминаем в переменных USERR1 и USERR2 X и Y указанной точки
      ;;;в мировых координатах. Это позволит пользователю прозрачно менять ПСК
      (setvar "USERR1" (car (trans pt1 1 0))) ;;;Запоминаем X точки pt1 в МСК
      (setvar "USERR2" (cadr (trans pt1 1 0)));;;Запоминаем Y точки pt1 в МСК
      (command "_.UNDO" "_M")                 ;;;Ставим метку UNDO
      (command "_.LINE" "_none" pt1 "_none" pt2 "")
      (setvar "USERS1" (getvar "USERS2"))  ;;;Перемещаем метку 2-го примитива в 1-й
      (setvar "USERS2" (cdr(assoc 5 (entget (entlast))))) ;;Метка последнего примитива
      (if (and (setq ent1 (handent (getvar "USERS1")))  ;;; Примитив существует
               (setq ent2 (handent (getvar "USERS2")))  ;;; Примитив существует
               (entget ent1)  ;;; Примитив не удален
               (entget ent2)  ;;; Примитив не удален
               )
        (vl-cmdf "_.FILLET"  ent1 ent2)

        ;;;Сопрягаем
        )
      (setq U_M (1+ U_M)) ;;;VVA
      (setq pt1 pt2)
      )
     ((= pt2 "Undo")
      (if (> U_M 0) ;;;Если есть что отменять
        (progn
       (command "_.UNDO" "_B")
       (setq U_M (1- U_M)) ;;;VVA
       (setq pt1 (list (getvar "USERR1") (getvar "USERR2")))
           (setvar "LASTPOINT" (setq pt1 (trans pt1 0 1)))
          )
        (alert "Отменять больше нечего")
        )
      )
     (t nil)
     )
(initget "Отмени Undo _Undo Undo")
)
  ;;;Нужно собрать все в полилинию
  (if (and toPline eLast)
    (progn
     (setq ss (ssadd))
     (while (setq  eLast (entnext  eLast))(ssadd  eLast ss))
     (if (= (sslength ss) 0)(setq ss nil)) ;;; Пустой набор
     (if ss ;;;что-то есть
       (if (and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1))
         (vl-cmdf "_pedit" "_Multiple" ss "" "_Join" 0 "")
         (vl-cmdf "_pedit" "_Multiple" ss "" "_Y" "_Join" 0 "")
         )
       )
(command "_offset" 90 (entlast))
(entdel (entlast))
(command "_explode" "_L")
     (setq ss nil)
      )
    )
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(mapcar '(lambda(x)(setvar (car x)(cdr x))) usr_list)
(princ)
)

Последний раз редактировалось ivsib, 02.08.2011 в 14:33.
ivsib вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Готовые программы > LISP. Отрисовка произвольной трассы из отрезков и дуг.

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Нужен LISP для суммы длин отрезков линни ilka_t LISP 219 10.09.2019 10:22
Lisp (отрисовка колонны) не работает dextron3 LISP 5 26.07.2008 20:14