[trushev]

Программа с открытым кодом на autolisp'е, предназначена для оформления поперечных профилей железнодорожных путей.
Выполняет заполнение проектных граф отметок и расстояний, надпись заложений откосов и уклонов спланированной поверхности. Настраивается на любой масштаб исходного поперечника.

Прошу извинить за инженерный стиль и прочие плюхи, которые покоробят професионалов. Я инженер, жизнь заставила в прошлом веке переболеть autolisp'ом.

Перед пуском программы в файле поперечника необходимо выполнить ряд условий:
1. Проектный поперечный профиль должен быть построен с применением объектной привязки в мировой системе координат;
2. Смасштабировать исходный поперечник до масштаба 1:1000 (1:1 в метрах или в 1-ом мм - 1 м);
3. Координаты У должна соответствовать отметкам поперечника, x - сумме расстояний от оси поперечника
(отрицательной - влево и положительной - вправо). Рекомендую использовать перенос всего поперечника с базовой точкой
ближайшего правого перелома существующей поверхности в точку с координатами X - расстояние от оси, Y - высотная отметка.;

4. В файле программы присвоить переменным mb и xx значения соответствующие исходному масштабу поперечника и требемой точности выписки расстояний.


Установка режимов работы

имя значение переменной при исходном масштабе поперечника
переменной 1:50 1:100 1:150 1:200 1:400 1:500 1:1000 1:2413

mb 50.0 100.0 150.0 200.0 400.0 500.0 1000.0 2413.0

Выписка расстояний на поперечнике при значении переменной:
xx "0.01" - с точностью до 0.01 м
"0.1" - с точностью до 0.1 м

За все годы эксплуатации мне в голову так и не пришло другого приемлемого и простого способа установки режимов работы. Не довелось выполнить проверку работы программы на отрицательных отметках.
Функцию vl-catch-all-apply мне помог встроить професиональный програмист. Ее работу я до конца так и не понял.

После запуска, на запрос программы, в произвольном порядке выполняется выбор проектных ординат поперечника.

Прилагаю lisp настроенный на поперечник масштаба 1:100 с выпиской расстояний до 0.01 м и пример поперечника, где соблюдены все 3 условия.

Код:

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

 ;
;      Программа оформления - надписи на поперечных профилях проектных данных:
;                                   -  отметок,
;                                   -  расстояний,
;                                   -  заложений откосов, 
;                                   -  уклонов
;
;   История:    1998 г начальная версия для ACAD R12 под MS-DOS 6.22
;               2001 г перекодирована под windos
;               2007 г дополнена распознаванием заложений откосов и уклонов
;               2013 г дополнена распознаванием ординат полилиний
;               2014 г повышена устойчивость к непредсказуемым действиям пользователя
;
;  Программа работает:  - в мировой системе координат
;                       - при масштабе поперечника 1:1000 (1:1 в метрах или в 1-ом мм - 1 м)
;                          (необходимо смасштабировать исходный поперечник
;                           до масштаба 1:1000 и установить соответствующие
;                           значение переменной mb)
;                       - система высот и расстояний должна соответствовать системе координат
;                         (координата У должна соответствовать отметкам поперечника)
;                       - файл программы и файлы поперечных профилей должны размещаться
;                         в одном каталоге (директории, папке) и каталог должен быть текущим
;                       - проектный поперечный профиль должен быть построен с применением
;                         объектной привязки
;
;     Переменные mb и xx позволяют выполнить дополнительные настройки программы
;
;            mb - подстраивает размещение вычисленных значений под 
;                 исходный масштаб поперечника
;
;            xx - управляет точностью выписки вычисленных расстояний в графе расстояния
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;                                                                                    ;;;;
;;;;             Установка режимов работы                                               ;;;;
;;;;                                                                                    ;;;;
;;;;      имя                значение переменной при исходном масштабе поперечника      ;;;;
;;;;  переменной         1:50   1:100   1:150   1:200   1:400  1:500   1:1000   1:2413  ;;;;
;;;;                                                                                    ;;;;
;;;;      mb             50.0   100.0   150.0   200.0   400.0  500.0   1000.0   2413.0  ;;;;
;;;;                                                                                    ;;;;
;;;;                     Выписка расстояний на поперечнике при значении переменной:     ;;;;
;;;;      xx                "0.01" - с точностью до 0.01 м                              ;;;;
;;;;                        "0.1"  - с точностью до 0.1 м                               ;;;;
;;;;                                                                                    ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                                                                       ;;;;
;                                                                                       ;;;;
(defun C:otm (/ sp old nabor n m spx name mb tip
                xy1 xy2 x hy x0 dx ddx xx sph h0
             )
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;   Установка режимов работы
;
    (setq mb 100.0   ;подстраивает размещение вычисленных значений под исходный масштаб поперечника
          xx "0.01"  ;управляет точностью выписки вычисленных расстояний в графе расстояния
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
           n 'nil
           y 't
    )
;;;;                                                                                    ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
      ;
(if (= (getvar "worlducs") 1)
      ;
      ;текущая система координат совпадает с мировой
      ;
    (progn
        ;
    (alert "Укажите вертикальные ординаты проектного поперечника")
      ;
      ;Для дам
      ;
    ;(alert "Здравствуй СОЛНЫШКО!!!\n\nУкажите вертикальные ординаты проектного поперечника")
        ;
        ;Создание набора отрезков
        ;
    (while (not nabor)
                     ;
                     ;Контроль правильности сделанного выбора
                     ;
           (setq nabor (vl-catch-all-apply 'ssget '() ;защита от Esc
                       )
           )
           (if nabor
               (if (= (type nabor) 'pickset)
                     ;
                     ;Тип переменной nabor pickset (набор)
                     ;
                   (progn
                   (setq n (sslength nabor) ; количество объектов в наборе
                         m 0                ;номер первого притива в наборе
                       spx 'nil             ;список координат X соответствующих отметок
                       sph 'nil             ;список отметок
                   )
                   (while (and n (< m n));пока не достигнут номер последнего примитива
                          (setq name (ssname nabor m)   ;имя примитива с номером m
                                  sp (entget name)      ;список данных о примитиве
                                 tip (cdr (assoc 0 sp)) ;тип примитива
                          )
                          (if (= tip "LINE");выбран отрезок
                              (setq xy1 (cdr (assoc 10 sp));координаты начала отрезка
                                    xy2 (cdr (assoc 11 sp));координаты конца отрезка
                                      x (car xy1)
                                      h (max (cadr xy1) (cadr xy2)) ;отметка (координата Y верха ординаты поперечника)
                                      y (min (cadr xy1) (cadr xy2)) ;координата Y низа ординаты поперечника
                                      m (1+ m)
                                    spx (cons (rtos (+ 4500.0 x) 2 3) spx);список Х увеличенных на 4500
                                    sph (cons (list x h y) sph)           ;список X, Y и высотных отметок
                              )
                                ;
                                ;ИНАЧЕ
                                ;
                              (if (and (= tip "LWPOLYLINE")     ;выбрана компактная полилиния
                                       (= (cdr (assoc 90 sp)) 2);с двумя вершинами
                                  );and
                                  (progn
                                  (setq xy1 'nil)
                                       ;
                                       ;выборка из списка SP кривизны сегментов
                                       ;
                                  (foreach k sp
                                           (if (= (car k) 42)
                                               (setq xy1 (cons (cdr k) xy1))
                                           );if (= (car k) 42)
                                  );foreach k sp
                                  (if (= (car xy1) (cadr xy1) 0.0) ;Для прямолинейных сегментов
                                      (progn
                                      (setq xy1 'nil)
                                          ;
                                          ;выборка из списка SP координат вершин
                                          ;
                                      (foreach k sp
                                               (if (= (car k) 10)
                                                   (setq xy1 (cons (cdr k) xy1))
                                               );if (= (car k) 10)
                                      );foreach k sp
                                      (setq xy2 (car xy1) ;координаты начала полилинии
                                            xy1 (cadr xy1);координаты конца полилинии
                                              x (car xy1)
                                              h (max (cadr xy1) (cadr xy2)) ;отметка (координата Y верха ординаты поперечника)
                                              y (min (cadr xy1) (cadr xy2)) ;координата Y низа ординаты поперечника
                                              m (1+ m)
                                            spx (cons (rtos (+ 4500.0 x) 2 3) spx);список Х увеличенных на 4500
                                            sph (cons (list x h y) sph)           ;список X, Y и высотных отметок
                                      )
                                      );progn
                                        ;
                                        ;ИНАЧЕ
                                        ;
                                      (progn
                                      (redraw name 3)
                                      (alert (strcat "Проектные ординаты поперечника должны быть отрезками."
                                                     "\n\nПреобразуйте выделенную линию ординаты в отрезок."
                                             )
                                      )
                                      (setq n 'nil)
                                      );progn
                                  );if (= (car xy1) (cadr xy1) 0.0)
                                  );progn
                                    ;
                                    ;ИНАЧЕ
                                    ;
                                  (progn
                                  (redraw name 3)
                                  (alert (strcat "Проектные ординаты поперечника должны быть отрезками."
                                                 "\n\nПреобразуйте выделенную линию ординаты в отрезок."
                                         )
                                  )
                                  (setq n 'nil)
                                  );progn
                              );if (and (= tip "LWPOLYLINE")
                          );if
                   );while
                   );progn
                       ;
                       ;ИНАЧЕ
                       ;
                   (progn
                   (alert "ВЫПОЛНЕНО НЕКОРРЕКТНОЕ ДЕЙСТВИЕ!!!\n\nЗавершение программы.\nДля продолжения работы перезапустите программу.")
                   (setq y 'nil)
                   );progn
               );if (= (type nabor) 'pickset)
                 ;
                 ;ИНАЧЕ
                 ;
               (progn
               (alert "НИЧЕГО НЕ ВЫБРАНО!!!\n\nУкажите вертикальные ординаты проектного поперечника")
               );progn
           );if nabor
    );while (not nabor)
      ;
    );progn
      ;
      ;Иначе 0 - текущая система координат НЕ совпадает с мировой
      ;
    (alert "ВНИМАНИЕ!!!\n\nУстановите мировую систему координат!")
);if (= (getvar "worlducs") 1)
;
;
;
(if n
    (progn
      ;
      ;Сохранение действующих значений системных переменных и присвоение требуемых
      ;
    (setq sp (list "7" 0 0 0 1)
         old 'nil
          mb (* mb 0.01)
    )
    (foreach k '("cecolor"    ; цвет                        "7" - черный (белый)
                 "autosnap"   ; маркер автопривязки          0  - выключен
                 "cmdecho"    ; текст в командной строке     0  - выключен
                 "osmode"     ; режим объектной привязки     0  - ничего
                 "dimzin"     ; подавление незначищих нулей  1  - не подавляются
                 "textstyle"  ; текстовый стиль
                )
            (setq old (cons (getvar k) old))
            (if (car sp)
                (progn
                (setvar k (car sp))
                (setq sp (cdr sp))
                );progn
            );if (car sp)
    );foreach k
    (setq old (reverse old))
        ;
        ;
        ;Установка шрифта
        ;
    (command "_.-style" 
             "stnd"     ;имя стиля
             "txt.shx"  ;имя файла шрифта
             "0.0"      ;высота текста:              0.0 - с запросом высоты текста
             "1"        ;степень сжатия:             сужение < нормальная < растяжение
             "0"        ;угол наклона символов:      + - вправо, - - влево
             "_n"       ;писать текст справа налево: "_y" - да, "_n" - нет
             "_n"       ;перевернутый текст:         "_y" - да, "_n" - нет
             "_n"       ;выводить текст вертикально: "_y" - да, "_n" - нет
    )
             ;
             ;Надпись отметок и вычерчивание вертикальных линий в графе проектных расстояний
             ;
    (foreach k sph  ;список ((list x h y) ... (list x h y))
           (command "_.text" "_j" "_ml" (list (car k) (- (caddr k) (* 1.35 mb))) (rtos (*  0.2 mb) 2 2) "90"
                            (rtos (cadr k) 2 2)
                     ;
                     ;Отрисовка отрезка
                     ;
                    "_.line" (list (car k) (- (caddr k) (* 1.5 mb))) (list (car k) (- (caddr k) (* 2.0 mb))) ""
           )
    );foreach k sph
             ;
    (setq spx (acad_strlsort spx) ;сортировка Х по возрастанию
           x0 (- (atof (car spx)) 4500.0)
           sp 'nil
            n 'nil
           dx sph
    )
         ;
         ;Ранжировка отметок поперечника из списка SPH в соответствии со списком SPX
         ;
    (foreach k spx
             (setq x (atof (rtos (- (atof k) 4500.0) 2 3)))
             (while (car dx)
                    (if (= x (atof (rtos (caar dx) 2 3)))
                        (setq sp (cons (car dx) sp))
                          ;ИНАЧЕ
                        (setq n (cons (car dx) n))
                    );if (= x (atof (rtos (caar dx) 2 3)))
                    (setq dx (cdr dx))
             );while (/= x (atof (rtos (caar dx) 2 3)))
             (setq dx (reverse n)
                    n 'nil
             )
    );foreach spx
        ;
        ;На выходе в переменной SP отсортированный по убыванию X список SPH,
        ;            список первых членов подсписков списка SPH
        ;
        ;
    (setq sph (reverse sp) ;список SP отсортированный по возрастанию X
           h0 (cadar sph)  ;первая отметка из списка SPH
          spx (cdr spx)
          sph (cdr sph)
          ddx 0.0          ;накопитель ошибки по длине (по dx)
    )
         ;
         ;Надпись нулевой ординаты
         ;
    ;(command "_.text" "_j" "_ml" (list -0.4 (+ y (* 0.5 mb)))
    ;                 (rtos (*  0.25 mb) 2 2) "90" "Ось трассы"
    ;)
         ;
         ;Выполнение надписей расстояний, заложений откосов и уклонов
         ;
    (while (car spx);пока в списке spx имеются члены
           (setq x (- (atof (car spx)) 4500.0)  ;следующая координата X
                 h (cadar sph)                  ;следующая отметка
                dx (if (= xx "0.01")
                       (rtos (abs (- x x0)) 2 2);расстояние между смежными точками до 0.01 м
                        ;ИНАЧЕ расстояние между смежными точками до 0.1 м
                       (strcat (rtos (abs (- x x0)) 2 1) "0")
                   );if
               ddx (+ ddx (- (abs (- x x0)) (atof dx)))
                sp (/ (- h h0) (abs (- x x0)))  ;уклон между смежными точками
                    ;
                    ;Определение значения надписи заложения или уклона
                    ;
                    ; При значениях уклона +/- 0.03 устанавливается заложение откоса
                    ;
                 n (cond ((equal (abs sp) 10.00 0.03) "0.1")
                         ((equal (abs sp) 5.00 0.03) "0.2")
                         ((equal (abs sp) 2.00 0.03) "0.5")
                         ((equal (abs sp) 1.33 0.03) "0.75")
                         ((equal (abs sp) 1.00 0.03) "1")
                         ((equal (abs sp) 0.80 0.03) "1.25")
                         ((equal (abs sp) 0.67 0.03) "1.5")
                         ((equal (abs sp) 0.57 0.03) "1.75")
                         ((equal (abs sp) 0.50 0.03) "2")
                         ((equal (abs sp) 0.40 0.03) "2.5")
                         ((equal (abs sp) 0.33 0.03) "3")
                    ;;;;;;;
                    ; При значениях уклона +/- 0.004 устанавливается уклон
                    ;;;;;;;
                         ((equal (abs sp) 0.08 0.004) "0.08")
                         ((equal (abs sp) 0.07 0.004) "0.07")
                         ((equal (abs sp) 0.06 0.004) "0.06")
                         ((equal (abs sp) 0.05 0.004) "0.05")
                         ((equal (abs sp) 0.04 0.004) "0.04")
                         ((equal (abs sp) 0.03 0.004) "0.03")
                         ((equal (abs sp) 0.02 0.004) "0.02")
                         ((equal (abs sp) 0.01 0.004) "0.01")
                    ;;;;;;;
                    ;В иных случаях
                    ;;;;;;;
                         ((/= sp "s") nil)
                   );cond
           )
            ;
            ;Контроль и корректировка расстояния 
            ; при округлении расстояний до 0.1 м
            ;
           (if (= xx "0.1")
               (while (> (abs ddx) 0.06)
                      (if (> ddx 0.0)
                          (setq dx (strcat (rtos (- (atof dx) 0.1) 2 1) "0")
                               ddx (- ddx 0.1)
                          )
                           ;ИНАЧЕ
                          (setq dx (strcat (rtos (+ (atof dx) 0.1) 2 1) "0")
                               ddx (+ ddx 0.1)
                          )
                      );if (> ddx 0.0)
               );while (> (abs ddx) 0.06)
           );if (= xx "0.1")
            ;
            ;Надпись расстояний
            ;
           (if (< (atof dx) (* 0.80 mb))
             ;При расстоянии менее 0.80 м
               (command "_.text" "_j"
                              ;  "_mr" ;право
                                "_mc"  ;центр
                               ; (list (/ (+ x x0) 2.0) (- y (* 2.1 mb)));для вертикального размещения расстояния
                                (list (/ (+ x x0) 2.0) (- y (* 2.2 mb))) ;для горизонтального размещения расстояния
                                (rtos (*  0.2 mb) 2 2)
                              ;  "90" ;вертикально
                                "0"   ;горизонтально
                                dx
               )
             ;При расстоянии 0.80 м и более
               (command "_.text" "_j" "_mc" (list (/ (+ x x0) 2.0) (- y (* 1.75 mb)))
                                (rtos (*  0.2 mb) 2 2) "0" dx
               )
           );if
           (cond ((and n (> (abs sp) 0.29) (< (abs sp) 10.04))
                   ;
                   ;Надпись заложений откоса
                   ;
                      ;
                      ;Вычисление точки вставки и угла наклона текста
                      ;
                  (setq xy1 (list (* 0.5 (+ x x0)) (* 0.5 (+ h h0))) ;координаты точки середины откоса
                         x0 (atan -1.0 (atof n))                     ;угол заложения откоса в радианах
                          n (list n (rtos (/ (* -180.0 x0) pi) 2 2)) ;список (величина_заложения угол)
                  )
                  (if (< sp 0.0)
                      (setq x0 (- x0)                                        ;угол заложения откоса в радианах
                             n (list (car n) (rtos (/ (* -180.0 x0) pi) 2 2));список (величина_заложения угол)
                      )
                  );if (< sp 0.0)
                  (setq h0 (+ (cadr xy1) (* 0.2 mb (cos x0)));Координата Y точки вставки текста величины заложения
                        x0 (+ (car xy1) (* 0.2 mb (sin x0))) ;Координата X точки вставки текста величины заложения
                       xy1 (list x0 h0) ;Координаты точки вставки текста величины заложения (в 2-х мм от поверхности откоса)
                  )
                      ;
                      ;Выполнение надписи заложения откоса
                      ;
                  (command "_.text" "_j" "_mc" xy1
                                   (rtos (*  0.2 mb) 2 2) (cadr n) (strcat "1:" (car n))
                  )
                 ) 
                 ((and n (> (abs sp) 0.005) (< (abs sp) 0.085))
                   ;
                   ;Надпись уклонов
                   ;
                      ;
                      ;Вычисление точки вставки и угла наклона текста
                      ;          и координат отрисовки уклоноуказателя
                      ;
                  (setq xy1 (list (* 0.5 (+ x x0)) ;Координаты середины отрезка
                                  (* 0.5 (+ h h0)) ;подписываемого уклоном
                            )
                         x0 (atan (atof n)) ;угол наклона в радианах (n - величина уклона STR)
                          n (list n                               ;величина уклона STR
                                  (rtos (/ (* 180.0 x0) pi) 2 2) ;угол наклона в градусах
                            )
                  )
                  (if (< sp 0.0)
                        ;
                        ;Правая сторона поперечника
                        ;
                        ;C размещением текста справа от уклоноуказателя
                        ;
                      (setq x0 (- x0) 
                             n (list (car n)                        ;величина уклона STR
                                     (rtos (/ (* 180.0 x0) pi) 2 2) :угол наклона текста в градусах
                               )
                           xy1 (list     ;
                                         ;Координаты начала уклоноуказателя
                                         ;
                                     (list (+ (car xy1)             ;X середины отрезка
                                              (* -0.08 mb (cos x0)) ;приращение по Х (mb - масштабный коэффициент)
                                              (* 0.1 mb (cos (+ (* pi 0.5) x0)))
                                           )
                                           (+ (cadr xy1)
                                              (* -0.08 mb (sin x0))
                                              (* 0.1 mb (sin (+ (* pi 0.5) x0)))
                                           )
                                     )
                                         ;
                                         ;Координаты точки вставки текста - величины уклона
                                         ;
                                     (list (+ (car xy1)
                                              (* 0.28 mb (cos x0))
                                              (* 0.2 mb (cos (+ (* pi 0.5) x0)))
                                           )
                                           (+ (cadr xy1)
                                              (* 0.28 mb (sin x0))
                                              (* 0.2 mb (sin (+ (* pi 0.5) x0)))
                                           ) 
                                     )
                               )
                                         ;
                                         ;Координаты для отрисовки уклоноуказателя
                                         ;
                           xy1
                               (list         ;вершина уклоноуказателя
                                     (list (+ (caar xy1)
                                              (* -0.35 mb (cos x0))
                                           )
                                           (+ (cadar xy1)
                                              (* -0.35 mb (sin x0))
                                           )
                                     )
                                             ;начало уклоноуказателя
                                     (car xy1)
                                             ;конец уклоноуказателя
                                     (list (+ (caar xy1)
                                              (* 0.14 mb (cos (+ (* pi 0.5) x0)))
                                              (* -0.35 mb (cos x0))
                                           )
                                           (+ (cadar xy1)
                                              (* 0.14 mb (sin (+ (* pi 0.5) x0)))
                                              (* -0.35 mb (sin x0))
                                           )
                                     )
                                           ;точка вставки текста
                                     (cadr xy1)
                               )
                      )
                       ;
                       ;ИНАЧЕ SP более 0.0 - левая сторона поперечника
                       ;
                      (setq xy1 (list (list (+ (car xy1)
                                               (* -0.08 mb (cos x0))
                                               (* 0.1 mb (cos (+ (* pi 0.5) x0)))
                                            )
                                            (+ (cadr xy1)
                                               (* -0.08 mb (sin x0))
                                               (* 0.1 mb (sin (+ (* pi 0.5) x0)))
                                            )
                                      )
                                      (list (+ (car xy1)
                                               (* 0.28 mb (cos x0))
                                               (* 0.2 mb (cos (+ (* pi 0.5) x0)))
                                            )
                                            (+ (cadr xy1)
                                               (* 0.28 mb (sin x0))
                                               (* 0.2 mb (sin (+ (* pi 0.5) x0)))
                                            ) 
                                      )
                                )
                            xy1 (list     ;начало уклоноуказателя
                                      (car xy1)
                                            ;вершина уклоноуказателя
                                      (list (+ (caar xy1)
                                               (* -0.35 mb (cos x0))
                                            )
                                            (+ (cadar xy1)
                                               (* -0.35 mb (sin x0))
                                            )
                                      )
                                            ;конец уклоноуказателя
                                      (list (+ (caar xy1)
                                               (* 0.14 mb (cos (+ (* pi 0.5) x0)))
                                            )
                                            (+ (cadar xy1)
                                               (* 0.14 mb (sin (+ (* pi 0.5) x0)))
                                            )
                                      )
                                             ;точка вставки текста
                                      (cadr xy1)
                                )
                      )
                  );if (< sp 0.0)
                   ;
                   ;Выполнение надписи уклона и отрисовка уклоноуказателя
                   ;
                  (command "_.text" "_j" "_mc" (cadddr xy1)
                                   (rtos (*  0.2 mb) 2 2) (cadr n) (rtos (* (atof (car n)) 1000.0) 2 0)
                           "_.line" (car xy1) (cadr xy1) (caddr xy1) ""
                  )
                 )
           );cond
             ;
           (setq x0 x
                 h0 h
                spx (cdr spx)  ;удаление из списка SPX отработанного члена
                sph (cdr sph)  ;синхронизация списка SPH со списком SPX
           )
    );while
      ;
    (if (> (atof xx) 0.01)
        (alert (strcat "На поперечном профиле разность суммы округленных длин"
                       "\nс действительным расстоянием составляет "
                       (rtos ddx 2 2) " м."
                       "\n\nПроверте размещение вычисленных значений"
               )
        )
    );if (> (atof xx) 0.01)
       ;
       ;Восстановление прежних значений системных переменных
       ;
    (foreach k '("cecolor"
                 "autosnap"
                 "cmdecho"
                 "osmode"
                 "dimzin"
                 "textstyle"  ; текстовый стиль
                )
             (setvar k (car old))
             (setq old (cdr old))
    );foreach k '("cmdecho")
    );progn
);if n
;
(if y
    (progn
      ;
      ;Удаление (обнуление) задействованных переменных
      ;
      ;При снятии комметариев с defun не имеет смысла (масло масленное)
      ;
    (foreach k (list 'sp 'old 'nabor 'n 'm 'spx 'name 'mb 'tip 'xy1 'xy2 'x 'h
                     'y 'x0 'dx 'ddx 'xx 'sph 'h0
               )
               (set k 'nil)
    );foreach k
       ;
    (princ)
    );progn
       ;
       ;ИНАЧЕ
       ;
    (command "_.quit")
);if y

);defun

[Neznayka]

trushev, спасибо! в ie выудить рабочий вариант исходника - тот еще квест. Поэтому я его в файле прикладываю. Местами выдает ошибку в определение отметок.

[trushev]

Сообщение от Neznayka trushev, спасибо! в ie выудить рабочий вариант исходника - тот еще квест. Поэтому я его в файле прикладываю. Местами выдает ошибку в определение отметок.

Приложенный Вами файл работает в режиме команды, настроен на поперечники с исходным масштабом 1:100 и выпиской расстояний с точностью до 0.01 м.
Случаи с ошибкой в определении отметок за 17 лет эксплуатации не выявлены. Приложите *.dwg файл где встречается эта ошибка.

Обнаружена причина ошибки неправильной выписки проектных отметок. Ошибка связана с низким качеством исходного поперечника и проявляется в случае не совпадения очертания земли базисной точки со значением отметки.
При установке системы координат проектная система высот соответствует значению отметки базисной точки.