Разбивочный чертеж (Страница 3 из 3)

;;;Igor Kireev (Donhuan) 07.2008. Для caduser.ru.
;;;mail: igkiv@tut.by
;;;Вызов функции: geo_angle.
;;;Глобальные переменные:
;;;*mspace* - указатель на пространство модели
;;;*fuzz* - точность сравнения точек
;;;*scale_l* - масштабный коэффициент длины линий
;;;*text_h* - высота текста
;;;*step_line* - величина отступа текста от линии
;;;*prec* - точность отображения координат при выводе в файл
;;;*mode* - режим отображения координат при выводе в файл
;;;*azimut_flag* - флаг режима азимут
(vl-load-com)
(setq *fuzz* 0.01
      *scale_l* 1.0
      *text_h* 3.0
      *step_line* 1.0
      *prec* 3
      *mode* 2
      *azimut_flag* "No"
)
(setq *mspace* (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
;ж****************************************
;главная функция
(defun c:geo_angle (/ select)
  (if (vl-catch-all-error-p
    (vl-catch-all-apply
      'ga:input_data))
    (progn
      (mapcar '(lambda(x)(vla-Highlight x :vlax-false)) (mapcar 'vlax-ename->vla-object select))
      (print "Выполнение функции прервано.")
  ))
  (princ)
)
;*****************************************
;*****************************************
;функция ввода данных
;;;list_line - список линий вида '(((x y) (x y)) ...)
;;;list_graph - вычисленный граф от начальной точки вида '((a (b nil) (c (d nil)) ...) (f nil) ...), где а,b... - линии '((x y) (x y))
;;;prev_angle - предыдущий угол для режима азимут
(defun ga:input_data (/ f_line start_point zero_angle prev_angle list_line list_graph d_file start_line var_)
  (setq d_file (open (getfiled "Файл результата" "" "xls" 1) "w"))
  (write-line "Начальная точка (x)\tНачальная точка (y)\tКонечная точка (x)\tКонечная точка (y)\tДлина\tУгол относительно оси x\tВычисленный угол" d_file)
  (princ "\nУкажите линии:")
  (setq select (vl-remove-if 'listp (mapcar (function cadr) (ssnamex (ssget '((0 . "LINE")))))))
  (mapcar '(lambda (x) (vla-Highlight x :vlax-true)) (mapcar 'vlax-ename->vla-object select)); подсветка списка
  (princ "\nУкажите начальную линию:")
  (while
    (vl-catch-all-error-p
      (setq f_line
        (vl-catch-all-apply
          'ssname (list (ssget "_:S") 0))))
  )
  (setq start_point (getpoint "Укажите точку схождения (начальную точку хода):"))
  (princ "\nИспользовать режим азимутов [Yes,No] < ")
  (princ *azimut_flag*)
  (princ ">: ")
  (initget 6 "Да Нет Yes No _Yes No Yes No")
  (setq *azimut_flag* (if (not (setq var_ (getkword))) (princ *azimut_flag*) var_))
  (princ "\nВведите масштабный коэффициент для длины линий < ")
  (princ *scale_l*)
  (princ " >: ")
  (initget 6)
  (setq *scale_l* (if (not (setq var_ (getreal))) (princ *scale_l*) var_))
  (princ "\nВведите величину высоты текста < ")
  (princ *text_h*)
  (princ " >: ")
  (initget 6)
  (setq *text_h* (if (not (setq var_ (getreal))) (princ *text_h*) var_))
  (princ "\nВведите величину смещения между текстом и линией < ")
  (princ *step_line*)
  (princ " >: ")
  (initget 6)
  (setq *step_line* (if (not (setq var_ (getreal))) (princ *step_line*) var_))
  (setq start_line ((lambda (x y) (if (equal start_point x *fuzz*) (list x y) (list y x)))
                   (cdr (assoc 10 (entget f_line))) (cdr (assoc 11 (entget f_line)))))
  (setq zero_angle (angle (car start_line) (cadr start_line))); вычисление нулевого угла
  (setq prev_angle 0)
  (setq list_line (mapcar '(lambda (x) (list (vlax-safearray->list (vlax-variant-value (vla-get-StartPoint x))); получение списка координат линий
                                 (vlax-safearray->list (vlax-variant-value (vla-get-endPoint x))))) (mapcar 'vlax-ename->vla-object select)))
  (setq list_graph (ga:make_graph list_line (list start_point))); формирование графа
  (close d_file)
  (mapcar '(lambda(x) (vla-Highlight x :vlax-false)) (mapcar 'vlax-ename->vla-object select))
)
;******************************************
;******************************************
; функция расчета параметров и вывода результатов в файл и в текст
;;;line_coor - линия для обработки '((x y) (x y))
;;;prev_point - начальная точка предыдущей линии для режима азимут
(defun ga:angle_text_draw (line_coor prev_point / real_angle angle_line angle_line_d center_line vla_name_text)
  (if (= *azimut_flag* "Yes")
    (progn
      (if prev_point
        (setq zero_angle (angle (car line_coor) prev_point))
      )
      (setq real_angle (angle (car line_coor) (cadr line_coor))); реальный угол линии
      (setq angle_line ((lambda (x y) (cond
                    ((< x 0) (+ (- y (+ x y)) prev_angle))
                    ((= x 0) (+ 0 prev_angle))
                        (t (+ (- y x) prev_angle))
                      )) (- real_angle zero_angle) (+ pi pi)))
      (if (> angle_line (+ pi pi)) (setq angle_line (- angle_line (+ pi pi))))
      (setq prev_angle angle_line)
      (setq angle_line (angtos angle_line 1 4)); вычисленный угол
    )
    (progn
      (setq real_angle (angle (car line_coor) (cadr line_coor))); реальный угол линии
      (setq angle_line ((lambda (x y) (cond
                    ((> x y) (- y (- x y)))
                        ((< x 0) (- y (+ x y)))
                    ((= x 0) 0)
                        (t (- y x))
                      )) (- real_angle zero_angle) (+ pi pi)))
      (setq angle_line (angtos angle_line 1 4)); вычисленный угол
    )
  )
  (setq angle_line_d ((lambda (x) (strcat (substr angle_line 1 x) "%%d" (substr angle_line (+ 2 x)))) (vl-string-search "d" angle_line))); замена символа градуса
  (setq center_line (polar (car line_coor) real_angle (/ (distance (car line_coor) (cadr line_coor)) 2)))
  (setq vla_name_text (vla-addtext *mspace* (rtos (* *scale_l* (distance (car line_coor) (cadr line_coor))) 2 3) (vlax-3d-point center_line) *text_h*)); вывод текста
  (ga:rotate_text vla_name_text center_line 13 (list line_coor real_angle))
  (setq vla_name_text (vla-addtext *mspace* angle_line_d (vlax-3d-point center_line) *text_h*)); вывод текста
  (ga:rotate_text vla_name_text center_line 7 (list line_coor real_angle))
  (write-line (strcat (rtos (caar line_coor) *mode* *prec*) "\t"
              (rtos (cadar line_coor) *mode* *prec*) "\t"
              (rtos (caadr line_coor) *mode* *prec*) "\t"
              (rtos (cadadr line_coor) *mode* *prec*) "\t"
              (rtos (* *scale_l* (distance (car line_coor) (cadr line_coor))) *mode* *prec*) "\t"
              (angtos real_angle 1 4) "\t"
              angle_line)
  d_file)
)
;******************************************
;******************************************
; функция поворота текста вдоль линии
;;;x - параметр вида '(((x y) (x y)) угол)
(defun ga:rotate_text (vla_name_text center_line alignment x / tng_angle half_line gippot)
    (setq half_line (/ (distance (caar x) (cadar x)) 2)); половина линии между старт и конец
    (setq gippot (sqrt (+ (expt *step_line* 2) (expt half_line 2))))
    (setq tng_angle (atan *step_line* half_line)); угол для смещения текста от линии (предотвращение сливания с линией)
    (vlax-put-property vla_name_text "Alignment" alignment)
    ((lambda (point); поворот текста
       (vla-rotate vla_name_text (vlax-3d-point center_line) (car point))
       (vlax-put-property vla_name_text "TextAlignmentPoint" (cadr point)))
      (if (and (<= (cadr x) (* pi 1.5)) (> (cadr x) (/ pi 2)))
        (progn
          (list (+ (cadr x) pi)
            (if (= alignment acAlignmentTopCenter)
              (vlax-3d-point (polar (caar x) (+ (cadr x) tng_angle) gippot))
              (vlax-3d-point (polar (caar x) (- (cadr x) tng_angle) gippot))
            )))
        (progn
          (list (cadr x)
            (if (= alignment acAlignmentTopCenter)
              (vlax-3d-point (polar (caar x) (- (cadr x) tng_angle) gippot))
              (vlax-3d-point (polar (caar x) (+ (cadr x) tng_angle) gippot))
    )))))
  (vla-put-color vla_name_text 253); задание цвета текста
)
;******************************************
;******************************************
; формирование графа с вызовом функций вывода значений
;;;list_line_r - список линий '(((x y) (x y)) ...)
;;;list_point - список точек '((x y) ...)
(defun ga:make_graph (list_line_r list_point /)
  ((lambda (x y z)
    (cond
      ((null list_line_r) nil)
      ((and (or (equal x y *fuzz*) (equal x z *fuzz*))
        (not (or (ga:member y (cdr list_point))
             (ga:member z (cdr list_point)))))
       (cons ((lambda (next_line)
        (ga:angle_text_draw next_line (cadr list_point)); отрисовка текста
        (list next_line (ga:make_graph list_line (cons (cadr next_line) list_point)))) (if (equal x y *fuzz*) (list y z) (list z y)))
                    (ga:make_graph (cdr list_line_r) list_point)))
      (t (ga:make_graph (cdr list_line_r) list_point))
    )
  ) (car list_point) (caar list_line_r) (cadar list_line_r))
)
;**************************************************
;**************************************************
; функция-аналог member для точек с использованием точности при сравнении
(defun ga:member (m_element m_list /)
  (cond
    ((null m_list) nil)
    ((equal m_element (car m_list) *fuzz*) t)
    (t (ga:member m_element (cdr m_list)))
  )
)
;**************************************************
(princ "\nЗапуск программы: geo_angle.")