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

;********** SETI_PL.LSP *****************************************
; Программа отрисовки сети из сопряженных отрезков
; с последующим объединением в полилинию.
; Автор Громов Владимир 2009 г.
; Макрос для загрузки:
; ^C^C(if (not C:СЕТИ_ПЛ) (load "seti_pl")) СЕТИ_ПЛ
;
(defun C:СЕТИ_ПЛ ( / echo rd pt1 pt2 pt3 ent1 ent2)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss (ssadd))
(if (null rds) (setq rds "150"))
(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)
(initget 7)
(setq pt3 (getpoint pt2 "\n Следующая точка: "))
(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 Ввести в командной строке СЕТИ_ПЛ")

;;;********** SETI.LSP ***********************************
;;; Программа отрисовки сети из сопряженных отрезков.
;;; Автор Громов В.В. 2009 г.
;;; Корректировка для опции Отмени (UNDO)
;;; Владимир Азарко (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 / echo rd pt1 pt2 ent1 ent2 U_M *error* old_FRD eLast ss)
;;;Функция seti - отрисовка сетей
;;; Аргумент toPline = t - собирать в полилинию
;;;          toPline = nil - нет
  (vl-load-com)
  ;;;Объявляем локальную ф-цию *error*
  (defun *error* (msg / image_set)
;;;Прерываем активную команду  
(while (> (getvar "CMDACTIVE") 0)(command))
(princ msg)
(setvar "FILLETRAD" old_FRD)
(setvar "USERS1" "")  ;;;Чистим переменные
(setvar "USERS2" "")  ;;;Чистим переменные
 (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 U_M (getvar "UNDOMARKS")) ;;;VVA Запоминаем счетчик отмен UNDO
(setq old_FRD  (getvar "FILLETRAD"))
(setvar "USERS1" "")  ;;;Чистим переменные
(setvar "USERS2" "")  ;;;Чистим переменные
(setq echo (getvar "CMDECHO"))
(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 (getint))(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 pt1 pt2)
      )
     ((= pt2 "Undo")
      (if (< U_M (getvar "UNDOMARKS")) ;;;Если есть что отменять
        (progn
       (command "_.UNDO" "_B")
       (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)
      )
    )
(setvar "CMDECHO" echo)
(setvar "FILLETRAD" old_FRD)
(princ)
)