; Подсчет длины участка трассы, указываемой последовательными точками.
; Заказчик - отдел 10, май 2004г.
; Вызов: (dist_point nil) - подсчет длины трассы без создания доп. вспомогательного слоя и отрисовки линии
; (dist_point t) - создается, если отсутствует в базе рисунка слой "_Длина участков_", отрисовываетеся линия.
; По окончании работы команды возвращается исходный текущий слой и цвет.
; Имеется возможность отмены последнего шага внутри команды - опция undo.
; Справочно отображаются координаты введенных точек.
(defun dist_point (ttt / pt pt2 d tlayer ccol) ; ttt - признак необоходимости рисовать линию - T - рисовать, nil - не рисовать
(setvar "CMDECHO" 0)
(setq olderr *error*
*error* delle
)
; прочитать и запомнить текущий слой, цвет, потом восстановить
;
(if ttt ; нужно рисовать линию и настраивать цвета и слои
(progn (setq tlayer (getvar "CLAYER")) ; запомнить текущий слой
(setq ccol (getvar "CECOLOR")) ; запомнить текущий цвет
(if (not (tblsearch "LAYER" "_Длина участков_"))
(progn (command "_layer" "_m" "_Длина участков_" "_color" "1" "") ;создать слой
(command)
) ;_ end of progn
) ; if
; текущий слой
;
(command "_layer" "_set" "_Длина участков_")
(command)
(command "_-color" "_bylayer")
) ;_ end of progn
) ; IF ttt
(setq d 0
pt (list nil)
) ;_ end of setq
(initget 46)
(setq pt (cons (getpoint "\nПервая точка: ") pt))
(while (car pt)
(princ (car pt))
(initget 46 "Undo")
(setq pt2 (getpoint (car pt) "\nТочка [Undo]:"))
(cond
((or (equal pt2 "u") (equal pt2 "U") (equal pt2 "Undo"))
; шаг назад удалить первый элемент списка из списка и вычесть предыдущее расстояние из d
(progn (if (and (car pt) (cadr pt)) ; два значимых элемента в списке
(progn (setq d (- d (distance (car pt) (cadr pt))))
(if ttt
(entdel (entlast))
) ; удалить последний отрезок

  
  ; вычесть из длины последний участок
                 ) ; progn
               ) ; if
               (setq pt (cdr pt))
        ) ;_ end of progn
       )  
       ((not pt2) (setq pt (cons pt2 pt))) ; пустой ввод
        ((listp pt2) ; значимая точка
        (progn (setq d  (+ d (distance (car pt) pt2))
                     pt (cons pt2 pt)
               ) ;_ end of setq
               (if ttt ; нужно рисовать
                 (command "_line" (cadr pt) (car pt) "")
               ) ;_ end of if
        ) ;progn
       )
     ) ;_ end of cond
   ) ; восстановить начальный слой и цвет
   (if ttt
     (progn (command "_layer" "_set" tlayer) (command) (command "_-color" ccol))
   ) ;_ end of if
   (princ "*** Длина участка = ")
   (princ d)
   (princ)
) ;_ end of defun

(defun delle (s) ; Если встретилась ошибка (такая как CTRL-C)
     ; пока эта команда активна...
   (menucmd "S=S")
   (if (/= s "Функция прервана")
     (progn (princ (strcat "\nОшибка: " s)) (command "_layer" "_set" tlayer))
   ) ;_ end of if
   (setq *error* olderr) ; Восстановить старый обработчик *error*
   (princ)
) ;_ end of defun