公路曲线输出CASS文件

ashleytgg · 发表于 2016-10-13 16:11:34

本帖最后由 ashleytgg 于 2016-10-13 16:11 编辑

;|
(setq Z_continue 1) (setq Z_continue 0)
(create_cass_data_out
group_Line_segments group_widen group_vertical_curve_2
group_superelevation 0 20 stake_mark_group Z_continue 5 )
|;
(defun create_cass_data_out (group_Line_segments
group_widen group_vertical_curve_2
group_superelevation
mold Z_Δ
stake_mark_group
Z_continue road_wide
/ number
group_transition
group group_Z_out
title n
ID ID1
ID2 ID_total
color color_lst
range xlapp
xl
)
(vl-load-com)
(setq xlapp (vlxls-app-new T))
;; 当电脑已经打开excel 程序时
(vla-put-visible xlapp 1)
;; 在excal 工作簿中加入"绘制公路曲线" 工作页
(setq xl
(vlax-invoke-method
(vlax-get-property Xlapp "sheets")
"Add"
)
)
(vlax-put-property
xl
"name"
"绘制公路曲线"
)
(vlxls-app-Init)
(Defun vllist-explode1 (lst)
(cond ((not lst) nil)
((atom lst) (list lst))
((append (vllist-explode1 (car lst))
(vllist-explode1 (cdr lst))
)
)
)
)
;; 设置线路参数
(setq group_transition (create_group_transition group_Line_segments))
(if (null Z_Δ)
(setq Z_Δ 20)
)
(if (null road_wide)
(setq road_wide 5) ;设置路面宽度
)
;; (setq Z_continue 0 ) (setq Z_continue 1 Z_Δ 20 )
(if (= Z_continue 0)
(setq group_Z_out
(creat_group_z group_Line_segments stake_mark_group)
)
)
;; 开始绘制表格 000 88888888888888 88888888888888 888888888888 8888888888888888888888 开始绘制表格
(setq ID1 (vlxls-rangeid
(list 1 1)
)
ID2 (vlxls-rangeid
(list 5 1)
)
ID (strcat ID1 ":" ID2)
)
;; 绘制标题行
(vlxls-cell-merge xlapp ID)
(vlxls-cell-put-value
xlapp
(list 1 1)
(list "用cass格式输出公路曲线")
)
(setq title (list "桩号:" "编码" "E(Y)" "N(x)" "高程 ")
)
(vlxls-cell-put-value
xlapp
(list 1 2)
(list title)
)
;; 设置excel 表格的列宽度
(setq lst (list '(1 . 13) '(2 . 15) '(3 . 15) '(4 . 16) '(5 . 11))
)
(mapcar '(lambda (x)
(vlxls-ColumnWidth xlapp (car x) (cdr x))
)
lst
)
(setq number 3)
(mapcar '(lambda (Line_segments / group)
(create_cass_data_out_sub
Line_segments
)
)
group_Line_segments
)
)
;; defun create_group_data_out 函数结束
;| 调试程序用参数
(setq group_turning_point_original (car ( create_turning_point_group_original ) ) )
(setq group_turning_point (car ( create_turning_point_group group_turning_point_original Z_road_start ) ) )
(setq tang ( create_group_Line_segments group_turning_point 0 ) group_Line_segments (car tang ) tgg (cadr tang) )
(setq group_widen (write_into_group_widen))
(setq stake_mark_group (write_into_group_stake_mark)) (setq group_Z_out ( creat_group_z group_Line_segments stake_mark_group ) )
(setq group_vertical_curve (create_group_vertical_curve ))(setq group_vertical_curve_2 ( create_group_vertical_curve_2 group_vertical_curve ) )
(setq group_superelevation (create_group_superelevation ) )
|;
;; (setq Line_segments (nth 1 group_Line_segments))
(defun create_cass_data_out_sub (Line_segments /
lst Line_segments_type
str
)
;; (setq Width 5 number 0 Z_continue 1 Z_Δ 1 )
(mapcar ; (setq subset (nth 0 (nth 4 group_Line_segments )) )
'(lambda (subset / lst group_Z num
Z_start Z_end len group_data_out
subset_2 i array
)
(setq array (car subset)
num (cadr array)
;; 去除 [( 转点号I j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert )]中的第一个元素
subset_2 (cdr subset)
reflex (nth 3 subset_2)
Z_start (nth 5 subset_2)
)
(cond
((or (= num 0)
(= num 2)
)
(progn
(setq len (car (caddr subset_2))
Z_end (+ Z_start len)
)
(if (= Z_continue 1)
(setq group_Z (create_group_Z Z_start Z_end Z_Δ))
(setq group_Z (cadr (assoc Z_start group_Z_out))
;;group_Z (append group_z (list Z_start))
)
)
(setq group_data_out
(solve_transition_curve group_Z subset_2)
)
)
)
((= num 1)
(progn
(setq len (caddr subset_2)
Z_end (+ Z_start len)
)
(if (= Z_continue 1)
(setq group_Z (create_group_Z Z_start Z_end Z_Δ))
(setq group_Z (cadr (assoc Z_start group_Z_out))
;;group_Z (append group_z (list Z_start))
)
)
(setq group_data_out (solve_circular_arc group_Z subset_2))
)
)
((= num 3)
(progn
(setq len (caddr subset_2)
Z_end (+ Z_start len)
)
(if (= Z_continue 1)
(setq group_Z (create_group_Z Z_start Z_end Z_Δ))
(setq group_Z (cadr (assoc Z_start group_Z_out))
;; group_Z (append group_z (list Z_start))
)
)
(setq group_data_out (solve_straightway group_Z subset_2))
)
)
) ; cond 函数结束
;; 求group_Z 中每个桩号的加宽值
(if (not mold)
(setq mold 1) ; mold没有定义时，设置为直线加宽
)
(if (and (/= num 3)
(assoc (car array) group_widen) ; 判断该转点是否加宽
)
(setq group_width
(mapcar
'(lambda (z / Width)
(setq Width
(calculate_Transition-curve_widen
Z
group_widen
subset
mold
)
)
(* Width reflex) ; 对确定加宽值的左右方向
)
group_Z
)
)
;; 直线线元加宽值设置为0
(setq group_width
(mapcar
'(lambda (z / Width)
0
)
group_Z
)
)
)
;; group_transition ( 转点号num j) (i j k) ，i 和 k 分别为该线元的前后线元编号 i k 取值为0 ，1 ，2 ,3
(setq lst (cadr (assoc array group_transition)))
(cond
((= (cadr lst) 3) ; 直线线元时
(setq
Line_segments_type
" 直线"
)
)
((= (cadr lst) 1) ;圆曲线线元时
(setq
Line_segments_type
" 圆曲线"
) ; 黄色
)
;; 当缓和曲线时接直线和圆时
((or (equal lst '(3 0 1))
(equal lst '(1 2 3))
)
(setq
Line_segments_type
"缓和曲线"
) ; 绿色
)
;; 当缓和曲线时接缓和曲线和圆时
((or (equal lst '(2 0 1))
(equal lst '(1 2 0))
)
(progn
(setq Line_segments_type
"缓和曲线"
) ; 洋红色
)
)
;; 当缓和曲线是接圆和圆时
((or (equal lst '(1 0 1))
(equal lst '(1 2 1))
)
(setq
Line_segments_type
"缓和曲线"
) ; 青色
)
(t
(setq
Line_segments_type
"缺省状态"
)
)
)
;; 判断线元的起点是什么型号，如ZH HY
(setq
array_2 (list (car lst) (cadr lst))
)
(cond
((equal array_2
'(3 0)
)
(setq str "ZH")
)
((equal array_2
'(3 1)
)
(setq str "ZY")
)
((equal array_2
'(0 1)
)
(setq str "HY")
)
((equal array_2
'(1 0)
)
(setq str "YH")
)
((equal array_2
'(1 2)
)
(setq str "YH")
)
((equal array_2
'(1 3)
)
(setq str "YZ")
)
((equal array_2
'(2 3)
)
(setq str "HZ")
)
((equal array_2
'(2 0)
)
(setq str "HH")
)
((equal array_2
'(2 1)
)
(setq str "HY")
)
(t
(setq str "88")
)
) ; cond 函数结束
;; 创建group_Z 的高程值
(setq group_h_slope
(mapcar '(lambda (z / h slope)
; ( setq z (car group_Z ))
(setq h (QH2_10N Z group_vertical_curve_2)
slope (calculate_superelevation
z
group_superelevation
subset
)
)
(if h
(list h slope)
(list 100 slope)
)
)
group_Z
)
)
;; 把 group_data_out 、 group_width 和 group_h_slope 合并起来组成新的数组 { z U ang width h ( superelevation_L superelevation_R )}
(setq i 0)
(setq group
(mapcar '(lambda (lst / width lst2 string)
(if (= (car lst) Z_start)
(setq string str)
(setq string Line_segments_type)
)
(setq width (nth i group_width)
lst2 (nth i group_h_slope)
i (+ i 1)
)
(append lst (list width) lst2 (list string))
)
group_data_out
)
)
;; 把数组 group { z U ang width h ( superelevation_L superelevation_R )} 写入表格table 中
;; 把group 数组变成一维数组
(setq group (mapcar '(lambda (lst)
(vllist-explode1 lst)
)
group
)
)
;; 对group数组转变成南方cass的格式 [ Z Bian_ma E_x N_y H ]
(setq group
(mapcar
'(lambda
(lst / Z E_x N_y H
Bian_ma ang wide slope_L slope_R W_L
W_R U_L U_R U H_L H_R
Z_L Z_R Bian_ma_L Bian_ma_R
)
(setq Z (car lst)
; (setq lst (nth 47 group))
Z (f_zhuanghao Z)
E_x (cadr lst)
E_x (rtos E_x 2 3)
N_y (caddr lst)
N_y (rtos N_y 2 3)
H (nth 5 lst)
H (rtos H 2 2)
Bian_ma (nth 8 lst)
)
(setq ang (nth 3 lst)
ang (+ ang (* 0.5 pi))
;把路线象限角变成横断面象限角
wide (nth 4 lst)
slope_L (* (nth 6 lst) 0.01)
slope_R (* (nth 7 lst) 0.01)
)
;; 设置左右边桩的宽度
(if (>= wide 0)
(setq
W_L (+ wide 5)
W_R -5
)
(setq
W_L 5
W_R (+ wide -5)
)
)
(setq U (list (nth 1 lst)
(nth 2 lst)
)
U_L (polar U ang W_L)
U_L (mapcar 'rtos U_L)
U_R (polar U ang W_R)
U_R (mapcar 'rtos U_R)
)
(setq H_L (- (nth 5 lst)
(* (abs W_L) slope_L)
)
H_L (rtos H_L 2 2)
H_R (+ (nth 5 lst)
(* (abs W_R) slope_R)
)
H_R (rtos H_R 2 2)
)
(setq Z_L (strcat "左" "_L")
Z_R (strcat "右" "_R")
Bian_ma_L (strcat "左边_"
(rtos (abs W_L) 2 2)
)
Bian_ma_R (strcat "右边_"
(rtos (abs W_R) 2 2)
)
)
(list
(list Z Bian_ma E_x N_y H)
(list Z_L Bian_ma_L (car U_L) (cadr U_L) H_L)
(list Z_R Bian_ma_R (car U_R) (cadr U_R) H_R)
)
)
group
)
)
(setq group (apply 'append group))
;; 把group数组写入 excel 表格 (setq number 3)
(mapcar
'(lambda (lst)
(vlxls-cell-put-value
xlapp
(list 1 number)
(list lst)
)
(setq number (+ number 1))
)
group
) ;把group写入excel表格函数结束
)
Line_segments
)
)
;;8888888888888888888 8888888888888888 888888888888

;| 
(setq Z_continue 1)  (setq Z_continue 0) 
  (create_cass_data_out 
   group_Line_segments        group_widen   group_vertical_curve_2 
   group_superelevation        0          20  stake_mark_group        Z_continue  5 )   
|; 
(defun create_cass_data_out (group_Line_segments 
                             group_widen     group_vertical_curve_2 
                             group_superelevation 
                             mold             Z_Δ 
                             stake_mark_group 
                             Z_continue             road_wide 
                             /                     number 
                             group_transition 
                             group             group_Z_out 
                             title             n 
                             ID                     ID1 
                             ID2             ID_total 
                             color             color_lst 
                             range             xlapp 
                             xl 
                            ) 
  (vl-load-com) 
  (setq xlapp (vlxls-app-new T)) 
  ;; 当电脑已经打开excel 程序时   
  (vla-put-visible xlapp 1) 
 
  ;; 在excal 工作簿中 加入"绘制公路曲线" 工作页    
  (setq        xl 
         (vlax-invoke-method 
           (vlax-get-property Xlapp "sheets") 
           "Add" 
         ) 
  ) 
  (vlax-put-property 
    xl 
    "name" 
    "绘制公路曲线" 
  ) 
 
  (vlxls-app-Init) 
  (Defun vllist-explode1 (lst) 
    (cond ((not lst) nil) 
          ((atom lst) (list lst)) 
          ((append (vllist-explode1 (car lst)) 
                   (vllist-explode1 (cdr lst)) 
           ) 
          ) 
    ) 
  ) 
  ;; 设置 线路 参数    
  (setq group_transition (create_group_transition group_Line_segments)) 
  (if (null Z_Δ) 
    (setq Z_Δ 20) 
  ) 
  (if (null road_wide) 
    (setq road_wide 5)                        ;设置路面宽度 
  ) 
 
  ;; (setq   Z_continue 0   )   (setq   Z_continue  1  Z_Δ 20   ) 
  (if (= Z_continue 0) 
    (setq group_Z_out 
           (creat_group_z group_Line_segments stake_mark_group) 
    ) 
  ) 
  ;; 开始绘制表格  000 88888888888888      88888888888888     888888888888 8888888888888888888888     开始绘制表格         
  (setq        ID1 (vlxls-rangeid 
              (list 1 1) 
            ) 
        ID2 (vlxls-rangeid 
              (list 5 1) 
            ) 
        ID  (strcat ID1 ":" ID2) 
  ) 
  ;; 绘制标题行    
  (vlxls-cell-merge xlapp ID) 
  (vlxls-cell-put-value 
    xlapp 
    (list 1 1) 
    (list "用cass格式输出公路曲线") 
  ) 
  (setq        title (list "桩号:" "编码" "E(Y)" "N(x)" "高程 ") 
  ) 
  (vlxls-cell-put-value 
    xlapp 
    (list 1 2) 
    (list title) 
  ) 
  ;; 设置excel 表格的 列宽度 
  (setq        lst (list '(1 . 13) '(2 . 15) '(3 . 15) '(4 . 16) '(5 . 11)) 
  ) 
  (mapcar '(lambda (x) 
             (vlxls-ColumnWidth xlapp (car x) (cdr x)) 
           ) 
          lst 
  ) 
  (setq number 3) 
  (mapcar '(lambda (Line_segments / group) 
             (create_cass_data_out_sub 
               Line_segments 
             ) 
           ) 
          group_Line_segments 
  ) 
 
) 
;; defun create_group_data_out 函数结束 
 
 
;|  调试程序用参数    
(setq group_turning_point_original (car ( create_turning_point_group_original ) ) )    
(setq group_turning_point (car  ( create_turning_point_group   group_turning_point_original  Z_road_start )  ) )    
(setq tang   ( create_group_Line_segments   group_turning_point  0 )   group_Line_segments (car tang )  tgg (cadr tang)  )   
   (setq group_widen (write_into_group_widen))    
   (setq stake_mark_group   (write_into_group_stake_mark))  (setq group_Z_out  ( creat_group_z  group_Line_segments    stake_mark_group )  )    
 
   (setq group_vertical_curve  (create_group_vertical_curve ))(setq group_vertical_curve_2 ( create_group_vertical_curve_2  group_vertical_curve ) )    
  (setq group_superelevation (create_group_superelevation ) )      
|; 
 
 
 
;; (setq Line_segments (nth 1 group_Line_segments))    
(defun create_cass_data_out_sub        (Line_segments         / 
                                 lst                 Line_segments_type 
                                 str 
                                ) 
  ;; (setq Width 5  number 0  Z_continue 1 Z_Δ 1  )    
  (mapcar                                ;  (setq subset (nth 0 (nth 4 group_Line_segments )) )       
    '(lambda (subset        /          lst            group_Z   num 
              Z_start        Z_end          len            group_data_out 
              subset_2        i          array 
             ) 
       (setq array    (car subset) 
             num      (cadr array) 
             ;; 去除 [( 转点号I j)   R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert )]中的第一个元素   
             subset_2 (cdr subset) 
             reflex   (nth 3 subset_2) 
             Z_start  (nth 5 subset_2) 
       ) 
       (cond 
         ((or (= num 0) 
              (= num 2) 
          ) 
          (progn 
            (setq len        (car (caddr subset_2)) 
                  Z_end        (+ Z_start len) 
            ) 
            (if        (= Z_continue 1) 
              (setq group_Z (create_group_Z Z_start Z_end Z_Δ)) 
              (setq group_Z (cadr (assoc Z_start group_Z_out)) 
                            ;;group_Z (append group_z (list Z_start)) 
              ) 
            ) 
            (setq group_data_out 
                   (solve_transition_curve group_Z subset_2) 
            ) 
          ) 
         ) 
         ((= num 1) 
          (progn 
            (setq len        (caddr subset_2) 
                  Z_end        (+ Z_start len) 
            ) 
            (if        (= Z_continue 1) 
              (setq group_Z (create_group_Z Z_start Z_end Z_Δ)) 
              (setq group_Z (cadr (assoc Z_start group_Z_out)) 
                            ;;group_Z (append group_z (list Z_start)) 
              ) 
            ) 
            (setq group_data_out (solve_circular_arc group_Z subset_2)) 
          ) 
         ) 
         ((= num 3) 
          (progn 
            (setq len        (caddr subset_2) 
                  Z_end        (+ Z_start len) 
            ) 
            (if        (= Z_continue 1) 
              (setq group_Z (create_group_Z Z_start Z_end Z_Δ)) 
              (setq group_Z (cadr (assoc Z_start group_Z_out)) 
                            ;; group_Z (append group_z (list Z_start)) 
              ) 
            ) 
            (setq group_data_out (solve_straightway group_Z subset_2)) 
          ) 
         ) 
       )                                ; cond 函数结束 
       ;; 求group_Z 中每个桩号的加宽值 
       (if (not mold) 
         (setq mold 1)                        ; mold没有定义时，设置为直线加宽   
       ) 
       (if (and        (/= num 3) 
                (assoc (car array) group_widen) ; 判断该转点是否加宽   
           ) 
         (setq group_width 
                (mapcar 
                  '(lambda (z / Width) 
                     (setq Width 
                            (calculate_Transition-curve_widen 
                              Z 
                              group_widen 
                              subset 
                              mold 
                            ) 
                     ) 
                     (* Width reflex)        ; 对确定加宽值的左右方向    
                   ) 
                  group_Z 
                ) 
         ) 
         ;; 直线线元加宽值设置为0 
         (setq group_width 
                (mapcar 
                  '(lambda (z / Width) 
                     0 
                   ) 
                  group_Z 
                ) 
         ) 
       ) 
       ;;  group_transition ( 转点号num j) (i j k) ，i 和 k 分别为该线元的 前后线元编号  i k 取值为0 ，1 ，2 ,3   
       (setq lst (cadr (assoc array group_transition))) 
       (cond 
         ((= (cadr lst) 3)                ; 直线线元时 
          (setq 
            Line_segments_type 
             "  直线" 
          ) 
         ) 
         ((= (cadr lst) 1)                ;圆曲线线元时 
          (setq 
            Line_segments_type 
             "  圆曲线" 
          )                                ; 黄色   
         ) 
         ;; 当缓和曲线时接直线和圆时    
         ((or (equal lst '(3 0 1)) 
              (equal lst '(1 2 3)) 
          ) 
          (setq 
            Line_segments_type 
             "缓和曲线" 
          )                                ; 绿色   
         ) 
         ;; 当缓和曲线时接缓和曲线和圆时    
         ((or (equal lst '(2 0 1)) 
              (equal lst '(1 2 0)) 
          ) 
          (progn 
            (setq Line_segments_type 
                   "缓和曲线" 
            )                                ; 洋红色 
          ) 
         ) 
         ;; 当缓和曲线是接圆和圆时    
         ((or (equal lst '(1 0 1)) 
              (equal lst '(1 2 1)) 
          ) 
          (setq 
            Line_segments_type 
             "缓和曲线" 
          )                                ; 青色   
         ) 
         (t 
          (setq 
            Line_segments_type 
             "缺省状态" 
          ) 
         ) 
       ) 
       ;; 判断线元的起点是什么型号，如ZH HY    
       (setq 
         array_2 (list (car lst) (cadr lst)) 
       ) 
       (cond 
         ((equal array_2 
                 '(3 0) 
          ) 
          (setq str "ZH") 
         ) 
         ((equal array_2 
                 '(3 1) 
          ) 
          (setq str "ZY") 
         ) 
         ((equal array_2 
                 '(0 1) 
          ) 
          (setq str "HY") 
         ) 
         ((equal array_2 
                 '(1 0) 
          ) 
          (setq str "YH") 
         ) 
         ((equal array_2 
                 '(1 2) 
          ) 
          (setq str "YH") 
         ) 
         ((equal array_2 
                 '(1 3) 
          ) 
          (setq str "YZ") 
         ) 
         ((equal array_2 
                 '(2 3) 
          ) 
          (setq str "HZ") 
         ) 
         ((equal array_2 
                 '(2 0) 
          ) 
          (setq str "HH") 
         ) 
         ((equal array_2 
                 '(2 1) 
          ) 
          (setq str "HY") 
         ) 
         (t 
          (setq str "88") 
         ) 
       )                                ; cond 函数结束 
       ;; 创建group_Z 的高程值 
       (setq group_h_slope 
              (mapcar '(lambda (z / h slope) 
                                        ; ( setq z (car group_Z ))   
                         (setq h     (QH2_10N Z group_vertical_curve_2) 
                               slope (calculate_superelevation 
                                       z 
                                       group_superelevation 
                                       subset 
                                     ) 
                         ) 
                         (if h 
                           (list h slope) 
                           (list 100 slope) 
                         ) 
                       ) 
                      group_Z 
              ) 
       ) 
 
       ;; 把 group_data_out 、 group_width 和 group_h_slope 合并起来 组成新的数组 { z U ang width h  ( superelevation_L  superelevation_R )} 
       (setq i 0) 
       (setq group 
              (mapcar '(lambda (lst / width lst2 string) 
                         (if (= (car lst) Z_start) 
                           (setq string str) 
                           (setq string Line_segments_type) 
                         ) 
                         (setq width (nth i group_width) 
                               lst2  (nth i group_h_slope) 
                               i     (+ i 1) 
                         ) 
                         (append lst (list width) lst2 (list string)) 
                       ) 
                      group_data_out 
              ) 
       ) 
       ;; 把数组 group  { z U ang width h  ( superelevation_L  superelevation_R )} 写入表格table 中 
       ;; 把group 数组 变成一维数组   
       (setq group (mapcar '(lambda (lst) 
                              (vllist-explode1 lst) 
                            ) 
                           group 
                   ) 
       ) 
       ;; 对group数组转变成南方cass的格式 [ Z Bian_ma   E_x N_y H ]   
       (setq group 
              (mapcar 
                '(lambda 
                   (lst            /            Z            E_x            N_y            H 
                    Bian_ma ang            wide    slope_L slope_R W_L 
                    W_R            U_L            U_R            U            H_L            H_R 
                    Z_L            Z_R            Bian_ma_L            Bian_ma_R 
                   ) 
                    (setq Z          (car lst) 
                                        ; (setq lst (nth 47 group))    
                          Z          (f_zhuanghao Z) 
                          E_x          (cadr lst) 
                          E_x          (rtos E_x 2 3) 
                          N_y          (caddr lst) 
                          N_y          (rtos N_y 2 3) 
                          H          (nth 5 lst) 
                          H          (rtos H 2 2) 
                          Bian_ma (nth 8 lst) 
                    ) 
                    (setq ang          (nth 3 lst) 
                          ang          (+ ang (* 0.5 pi)) 
                                        ;把路线象限角变成横断面象限角    
                          wide          (nth 4 lst) 
                          slope_L (* (nth 6 lst) 0.01) 
                          slope_R (* (nth 7 lst) 0.01) 
                    ) 
                    ;; 设置左右边桩的宽度 
                    (if        (>= wide 0) 
                      (setq 
                        W_L (+ wide 5) 
                        W_R -5 
                      ) 
                      (setq 
                        W_L 5 
                        W_R (+ wide -5) 
                      ) 
                    ) 
                    (setq U   (list (nth 1 lst) 
                                    (nth 2 lst) 
                              ) 
                          U_L (polar U ang W_L) 
                          U_L (mapcar 'rtos U_L) 
                          U_R (polar U ang W_R) 
                          U_R (mapcar 'rtos U_R) 
                    ) 
                    (setq H_L (- (nth 5 lst) 
                                 (* (abs W_L) slope_L) 
                              ) 
                          H_L (rtos H_L 2 2) 
                          H_R (+ (nth 5 lst) 
                                 (* (abs W_R) slope_R) 
                              ) 
                          H_R (rtos H_R 2 2) 
                    ) 
                    (setq Z_L            (strcat "左" "_L") 
                          Z_R            (strcat  "右" "_R") 
                          Bian_ma_L (strcat "左边_" 
                                            (rtos (abs W_L) 2 2) 
                                    ) 
                          Bian_ma_R (strcat "右边_" 
                                            (rtos (abs W_R) 2 2) 
                                    ) 
                    ) 
                    (list 
                      (list Z Bian_ma E_x N_y H) 
                      (list Z_L Bian_ma_L (car U_L) (cadr U_L) H_L) 
                      (list Z_R Bian_ma_R (car U_R) (cadr U_R) H_R) 
                    ) 
                 ) 
                group 
              ) 
       ) 
       (setq group (apply 'append group)) 
 
       ;; 把group数组写入 excel 表格   (setq number 3)    
       (mapcar 
         '(lambda (lst) 
            (vlxls-cell-put-value 
              xlapp 
              (list 1 number) 
              (list lst) 
            ) 
            (setq number (+ number 1)) 
          ) 
         group 
       )                                ;把group写入excel表格函数结束    
 
     ) 
    Line_segments 
  ) 
 
) 
;;8888888888888888888                8888888888888888           888888888888

本程序的目的是利用线路要素输出，南方CASS软件格式的DAT文件，然后把DAT文件引入RTK手柄中，便可方便测量。
下面附注主要源码，由于空间限制，源码其余部分将在回帖1中展示。

;; 创建 group_data_out 和加宽值
(defun create_group_data_out_sub (Line_segments mold
/ lst
Line_segments_type
str
)
;; (setq Width 5 number 0 )
(mapcar ; (setq subset (nth 0 (nth 11 group_Line_segments )) )
'(lambda (subset / lst group_Z num
Z_start Z_end len group_data_out
subset_2 i array color
)
(setq array (car subset)
num (cadr array)
;; 去除 [( 转点号I j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert )]中的第一个元素
subset_2 (cdr subset)
reflex (nth 3 subset_2)
Z_start (nth 5 subset_2)
)
(cond
((or (= num 0)
(= num 2)
)
(progn
(setq len (car (caddr subset_2))
Z_end (+ Z_start len)
)
(if (= Z_continue 1)
(setq group_Z (create_group_Z Z_start Z_end Z_Δ))
(setq group_Z (cadr (assoc Z_start group_Z_out)))
)
(setq group_data_out
(solve_transition_curve group_Z subset_2)
)
)
)
((= num 1)
(progn
(setq len (caddr subset_2)
Z_end (+ Z_start len)
)
(if (= Z_continue 1)
(setq group_Z (create_group_Z Z_start Z_end Z_Δ))
(setq group_Z (cadr (assoc Z_start group_Z_out)))
)
(setq group_data_out (solve_circular_arc group_Z subset_2))
)
)
((= num 3)
(progn
(setq len (caddr subset_2)
Z_end (+ Z_start len)
)
(if (= Z_continue 1)
(setq group_Z (create_group_Z Z_start Z_end Z_Δ))
(setq group_Z (cadr (assoc Z_start group_Z_out)))
)
(setq group_data_out (solve_straightway group_Z subset_2))
)
)
) ; cond 函数结束
;; 求group_Z 中每个桩号的加宽值
(if (not mold)
(setq mold 1) ; mold没有定义时，设置为直线加宽
)
(if (and (/= num 3)
(assoc (car array) group_widen) ; 判断该转点是否加宽
)
(setq group_width
(mapcar
'(lambda (z / Width)
(setq Width
(calculate_Transition-curve_widen
Z
group_widen
subset
mold
)
)
(* Width reflex) ; 对确定加宽值的左右方向
)
group_Z
)
)
;; 直线线元加宽值设置为0
(setq group_width
(mapcar
'(lambda (z / Width)
0
)
group_Z
)
)
)
;; group_transition ( 转点号num j) (i j k) ，i 和 k 分别为该线元的前后线元编号 i k 取值为0 ，1 ，2 ,3
(setq lst (cadr (assoc array group_transition)))
(cond
((= (cadr lst) 3) ; 直线线元时
(setq color 1
Line_segments_type
" 直线"
)
)
((= (cadr lst) 1) ;圆曲线线元时
(setq color 2
Line_segments_type
" 圆曲线"
) ; 黄色
)
;; 当缓和曲线时接直线和圆时
((or (equal lst '(3 0 1))
(equal lst '(1 2 3))
)
(setq color 3
Line_segments_type
" 缓和曲线"
) ; 绿色
)
;; 当缓和曲线时接缓和曲线和圆时
((or (equal lst '(2 0 1))
(equal lst '(1 2 0))
)
(progn
(if (= (cadr lst) 0)
(setq color 6) ; 洋红色入口缓和曲线
(setq color 5) ;蓝色出口缓和曲线
)
(setq Line_segments_type
" 缓和曲线"
) ; 洋红色
)
)
;; 当缓和曲线是接圆和圆时
((or (equal lst '(1 0 1))
(equal lst '(1 2 1))
)
(setq color 4
Line_segments_type
" 缓和曲线"
) ; 青色
)
(t
(setq color 0
Line_segments_type
" 缺省状态"
)
)
)
;; 判断线元的起点是什么型号，如ZH HY
(setq
array_2 (list (car lst) (cadr lst))
)
(cond
((equal array_2
'(3 0)
)
(setq str "ZH")
)
((equal array_2
'(3 1)
)
(setq str "ZY")
)
((equal array_2
'(0 1)
)
(setq str "HY")
)
((equal array_2
'(1 0)
)
(setq str "YH")
)
((equal array_2
'(1 2)
)
(setq str "YH")
)
((equal array_2
'(1 3)
)
(setq str "YZ")
)
((equal array_2
'(2 3)
)
(setq str "HZ")
)
((equal array_2
'(2 0)
)
(setq str "HH")
)
((equal array_2
'(2 1)
)
(setq str "HY")
)
(t
(setq str "88")
)
) ; cond 函数结束
;; 创建group_Z 的高程值
(setq group_h_slope
(mapcar '(lambda (z / h slope)
; ( setq z (car group_Z ))
(setq h (QH2_10N Z group_vertical_curve_2)
slope (calculate_superelevation
z
group_superelevation
subset
)
)
(if h
(list h slope)
(list 100 slope)
)
)
group_Z
)
)
;; 把 group_data_out 、 group_width 和 group_h_slope 合并起来组成新的数组 { z U ang width h ( superelevation_L superelevation_R )}
(setq i 0)
(setq group
(mapcar '(lambda (lst / width lst2)
(setq width (nth i group_width)
lst2 (nth i group_h_slope)
i (+ i 1)
)
(append lst (list width) lst2)
)
group_data_out
)
)
(setq i 0)
(mapcar
'(lambda (lst / string j
residue U_page U_move ang
group_U superelevation_L superelevation_R
W_L W_R h_L h_R
lst2 lst3
)
(setq residue (rem number n_grid)
; n_grid 为Uniform_group_center 中的格子数
j (/ (- number residue) n_grid) ; 页数
U_page (polar U_insert 0 (* j (* frame_wide 1.2)))
U (nth residue Uniform_group_center)
; 桩号Z 在Uniform_group_center 域中的插入点
U_move (list (+ (car U_page) (car U))
(+ (cadr U_page) (cadr U))
)
)
;; 把z U ang width 桩号、坐标、方位角、加宽值写入图中
(setq U (cadr lst) ; (setq lst (car group))
width (nth 3 lst)
lst2 (cons width U)
lst2 (mapcar 'rtos lst2)
桩号 (f_zhuanghao (car lst))
ang (caddr lst)
ang (angtos (* (- ang (* 0.5 pi)) -1) 1 6)
; 把象限角转换成方位角
lst2 (append (list 桩号 ang) lst2)
lst2 (mapcar '(lambda (i)
(nth i lst2)
)
(list 0 4 3 1 2)
)
)
(if (and (= i 0) Z_continue)
(setq
lst3 (list str "\n N(X):" "E(Y):" "\n 方位角:"
"\n 加宽值:")
)
(setq
lst3 (list Line_segments_type "\n N(X):"
"E(Y):" "\n 方位角:"
"\n 加宽值:"
)
)
)
(setq
lst2 (append lst2 lst3)
)
(setq lst2 (mapcar '(lambda (i)
(nth i lst2)
)
(list 0 5 6 1 7 2 8 3 9 4)
)
)
(setq string (vl-princ-to-string lst2)
string (vl-string-left-trim "\(" string)
string (vl-string-right-trim "\)" string)
)
(entmake
(list
'(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
(cons 62 color)
(cons 40 (* road_wide 0.1))
(cons 71 5)
(cons 72 5)
(cons '1 string)
(cons 10 (polar U_move (* pi 0.5) (* road_wide -0.25)))
)
)
;; 用 group 数组和路面宽度road_wide 创建桩号Z 的标准横断面控制点 U_cen U_L U_R U_L_2 U_R_2
;; U_L_2 U_R_2 路面宽度road_wide 加土路肩宽度的值
(setq h (nth 4 lst)
width (nth 3 lst)
superelevation_L
(car (nth 5 lst))
superelevation_R
(cadr (nth 5 lst))
)
(if (> width 0) ; 在Ucs坐标系中以向右为正
(setq W_L (+ road_wide width)
W_R
(* road_wide -1)
)
(setq W_L road_wide
W_R
(+ (* road_wide -1) width)
)
)
;; 在Ucs坐标系中以向右为正 , 所以对 W_L W_R 反向
(setq W_L (* W_L -1)
W_R (* W_R -1)
)
;; 创建 U U_L U_R U_L_2 U_R_2 各点的高程
(setq
superelevation_L (* superelevation_L 0.01)
superelevation_R (* superelevation_R 0.01)
h_L
(* superelevation_L W_L)
h_R
(* superelevation_R W_R)
)
(setq lst2 (list (- h_L 0.015)
h_L
(* h_L 0.5)
0
(* h_R 0.5)
h_R
(- h_R 0.015)
(* h_L 0.85)
; 标识横坡superelevation_L 所用点
(* h_L 0.15)
; 标识横坡superelevation_L 所用点
(* h_R 0.15)
; 标识横坡superelevation_R 所用点
(* h_R 0.85)
; 标识横坡superelevation_R 所用点
)
lst3 (list (- W_L 0.5)
W_L
(* W_L 0.5)
0
(* W_R 0.5)
W_R
(+ W_R 0.5)
(* W_L 0.85)
; 标识横坡superelevation_L 所用点
(* W_L 0.15)
; 标识横坡superelevation_L 所用点
(* W_R 0.15)
; 标识横坡superelevation_R 所用点
(* W_R 0.85)
; 标识横坡superelevation_R 所用点
)
U (list (car U_move) (+ (cadr U_move) (* road_wide 0.25)))
)
(setq j 0) ; (setq U_move (getpoint "输入插入点:"))
(setq group_U (mapcar '(lambda (x / y)
(setq y (nth j lst2)
j (1+ j)
)
(list (+ (car U) x)
(+ (cadr U) y)
)
)
lst3
)
)
(setq group_h (mapcar '(lambda (i / y)
(setq y (nth i lst2))
(+ h y)
)
(list 0 3 6)
)
)
;; 把 U_L U U_R 二维多段线写入图中
(setq pt (mapcar '(lambda (i / U)
(setq U (nth i group_U))
U
)
(list 0 1 3 5 6)
)
)
(entmake
(append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 62 color)
(cons 90 (length pt))
(cons 70 0)
)
(mapcar '(lambda (U) (cons 10 U)) pt)
)
)
;; 对group_U 中U_L U U_R 顶点绘制等边三角形
(setq j 0
lst2
(mapcar '(lambda (U / U_2 U_3)
(if (or (= j 1) (= j 3))
(setq U_2 (polar U (* (/ pi 3.0) 1) (/ road_wide 15.0))
U_3 (polar U (* (/ pi 3.0) 2) (/ road_wide 15.0))
)
(setq U_2 (polar U (* (/ pi 3.0) 1) (/ road_wide 9.0))
U_3 (polar U (* (/ pi 3.0) 2) (/ road_wide 9.0))
)
)
(setq j (1+ j))
(list U_2 U U_3)
)
pt
)
)
(mapcar '(lambda (pt)
(entmake
(append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 62 (+ color 1))
(cons 90 (length pt))
(cons 70 1)
)
(mapcar '(lambda (U) (cons 10 U)) pt)
)
)
)
lst2
)
;; 绘制用以标识 superelevation_L 和 superelevation_R 的箭头
(setq pt
(mapcar '(lambda (i / U)
(setq U (nth i group_U))
(polar U (* pi 0.5) (/ road_wide 15.0))
)
(list 7 8 9 10)
)
)
(setq
lst2
(apply
'(lambda (x_0 x_1 x_3 x_4 / x_5 x_6 group_L group_R)
(if (>= superelevation_L 0)
(setq
x_5 (polar x_0 (/ pi 6) (/ road_wide 15.0))
group_L (list x_5 x_0 x_1)
)
(setq
x_5 (polar x_1 (* 0.8333 pi) (/ road_wide 15.0))
group_L (list x_0 x_1 x_5)
)
)
(if (< superelevation_R 0)
(setq
x_6 (polar x_4 (* 0.8333 pi) (/ road_wide 15.0))
group_R (list x_3 x_4 x_6)
)
(setq
x_6 (polar x_3 (/ pi 6) (/ road_wide 15.0))
group_R (list x_6 x_3 x_4)
)
)
(list group_L group_R)
)
pt
)
)
(mapcar '(lambda (pt)
(entmake
(append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 62 (+ color 2))
(cons 90 (length pt))
(cons 70 0)
)
(mapcar '(lambda (U) (cons 10 U)) pt)
)
)
)
lst2
)
;; 把group 中 h_L h h_R ( superelevation_L superelevation_R ) W_L W_R 写入图中
(setq
pt (mapcar '(lambda (i / U U_2)
(setq U (nth i group_U))
(if (or (= i 2) (= i 4))
(polar U (* pi 0.5) (* road_wide 0.3))
(polar U (* pi 0.5) (* road_wide 0.15))
)
)
(list 0 2 3 4 6)
)
)
(setq
U (car pt)
U (list (car U)
(- (cadr U) (* road_wide 0.35))
)
U_2 (last pt)
U_2 (list (car U_2)
(- (cadr U_2) (* road_wide 0.35))
)
pt (append pt (list U) (list U_2))
)
(setq
lst2 (append group_h
(nth 5 lst) ; ( superelevation_L superelevation_R )
(list (abs W_L))
(list W_R)
)
lst2 (mapcar '(lambda (x) (rtos x 2 2)) lst2)
lst2 (apply '(lambda (h_L h h_R slope_L slope_R W_L W_R)
(list h_L
(strcat slope_L " %")
h
(strcat slope_R " %")
h_R
(strcat "左宽:" W_L)
(strcat "右宽:" W_R)
)
)
lst2
)
)
(setq j 0)
(mapcar '(lambda (str / U_move)
(setq U_move (nth j pt))
(entmake
(list '(0 . "TEXT")
(cons 62 color)
(append '(10) U_move)
(cons 40 (* road_wide 0.1))
(cons '1 str)
(cons '71 0)
(cons '72 1)
(append '(11) U_move)
)
)
(setq j (+ j 1))
)
lst2
)
(setq number (+ number 1)
i (+ i 1)
)
)
group
)
)
Line_segments
)
)
;; (setq tang ( create_group_Line_segments group_turning_point 6782.755 ) group_Line_segments (car tang ) tgg (cadr tang) )
;; (setq group_widen (write_into_group_widen))
;; (setq stake_mark_group (write_into_group_stake_mark)) (setq group_Z_out ( creat_group_z group_Line_segments stake_mark_group ) )
;; (setq group_turning_point_original (car ( create_turning_point_group_original ) ) )
;; (setq group_turning_point (car ( create_turning_point_group group_turning_point_original Z_road_start ) ) )
;; (setq group_vertical_curve (create_group_vertical_curve ))(setq group_vertical_curve_2 ( create_group_vertical_curve_2 group_vertical_curve ) )
;; (setq group_superelevation (create_group_superelevation ) ) 创建左右边坡数组
(defun create_group_data_out (group_Line_segments
group_widen group_vertical_curve_2
group_superelevation
road_wide frame_wide
U_insert mold
Z_Δ stake_mark_group
Z_continue /
number Uniform_group_center
group_transition group_move
group n_x
n_y scale
group_Z_out
)
(setq group_transition (create_group_transition group_Line_segments))
(if (not road_wide) ; 路面宽度
(setq road_wide 5.0)
)
(if (not frame_wide) ; 图框宽度
(setq frame_wide 297)
)
(if (not Z_Δ) ; 图框宽度
(setq Z_Δ 5)
)
(setq n_x (/ frame_wide (* road_wide 3.5))
n_x (fix n_x)
n_y (/ (* n_x 210) 297)
n_y (fix n_y)
n_grid (* n_x n_y)
)
(setq Uniform_group_center
(create_Uniform_distribution
n_x
n_y
frame_wide
)
)
(if (= Z_continue 0)
(setq group_Z_out
(creat_group_z group_Line_segments stake_mark_group)
)
)
;; (setq U_insert (getpoint "输入插入点:"))
(setq number 0)
(mapcar '(lambda (Line_segments / group)
(create_group_data_out_sub
Line_segments
mold
)
)
group_Line_segments
)
;; 绘制每页的边框
(if (not (tblobjname "block" "图框"))
(make_drawing_frame 297 U_insert "图框")
;创建一图框 ,图框宽度设置为297
)
(setq residue (rem number n_grid)
n (/ (- number residue) n_grid) ; 页数
)
(if (> residue 0)
(setq n (+ n 1))
)
(setq i 0
scale (/ frame_wide 297.0)
)
(repeat n
(setq b (* (/ frame_wide 297) 210)
U (list (+ (car U_insert) (* (* frame_wide 1.2) i))
(cadr U_insert)
)
)
(entmake (list '(0 . "INSERT")
(cons 2 "图框")
(cons 10 U)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
)
)
(setq i (+ i 1))
)
)
;; defun create_group_data_out 函数结束
;; ( create_group_data_out group_Line_segments group_widen road_wide frame_wide U_insert mold)
;; 在一个给定的长方形页面中建立一个点集合，该点集合均匀的分布在页面中,页面左下角点为原点(list 0 0 )
(defun create_Uniform_distribution
(n_x n_y Width /
n_grid i j n_1
n_grid finite_field
)
;; (setq U_insert (getpoint "输入插入点:"))
(if (not n_x)
(setq n_x 8)
)
(if (not n_y)
(setq n_y 4)
)
(setq n_grid (* n_x n_y)
n_1 0
group nil
)
(repeat n_grid
;;确定行数 i 列数j ，group 的方向是由：下->上，再从：左->右
(setq j (rem n_1 n_y)
i (/ (- n_1 j) n_y)
)
(setq group (cons (list i j) group))
(setq n_1 (+ n_1 1))
)
(setq finite_field (reverse group))
;; 对新建有限域finite_field 从原点：(0 0) 移位到 (0.75 0.75)
(setq group
(mapcar '(lambda (U)
(apply '(lambda (x y)
(list (+ x 0.75)
(+ y 0.75)
)
)
U
)
)
finite_field
)
)
;; 对数组group (i j) 按原点0 进行放大，放大为图框297*210 大 ,
(setq scale_x (/ 297.0 (+ n_x 0.5))
scale_y (/ 210.0 (+ n_y 0.5))
;; n_y n_x 加0.5 是为了留下页面的左右、上下空间
)
(setq k (/ width 297.0) ; 指定的图框大小
scale_x (* scale_x k)
scale_y (* scale_y k)
)
(mapcar '(lambda (U)
(apply '(lambda (x y)
(list (* x scale_x)
(* y scale_y)
)
)
U
)
)
group
)
) ; (defun create_Uniform_distribution 函数结束
;; (setq Uniform_group_center ( create_Uniform_distribution 5 4 600 ) )
;; (setq ss (ssget) ) (setq pt (getpoint "输入插入点:"))
;; (emkblk ss pt "tang") (setq name "tang" )
(defun emkblk (ss pt name / i)
(entmake
(list '(0 . "block")
(cons 2 name)
'(70 . 0)
(cons 10 '(0 0))
)
)
(repeat (setq i (sslength ss))
(entmake (cdr (entget (ssname ss (setq i (1- i))))))
)
(entmake '((0 . "ENDBLK")))
(command "_.erase" ss "")
(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
)
;; 绘制图框 (setq U_insert (getpoint "输入插入点:"))
(defun make_drawing_frame
(a U_insert name / b d U ss group i group_string)
(if (not a)
(setq a 600.0)
)
(setq b (* (/ a 297.0) 210))
(setq
group
(list '(0 0)
(list a 0)
(list a b)
(list 0 b)
)
)
(entmake
(append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length group))
(cons 70 1) ; 二维曲线闭合
)
(mapcar '(lambda (U) (cons 10 U)) group)
)
)
(setq ss (ssget "L")) ;用刚刚生成的图形创造一个选择集合ss
(setq d (/ b 29.0))
(entmakex
(list '(0 . "line")
(cons 10 (list 0 d))
(cons 11 (list a d))
)
)
(ssadd (entlast) ss)
(setq L (/ a 5)
U (list L 0)
i 1
group nil
)
(repeat 4
(entmakex
(list '(0 . "line")
(cons 10 (list (* L i) 0))
(cons 11 (list (* L i) d))
)
)
(ssadd (entlast) ss)
(setq U (list (* L (- i 1)) (* 0.1 d))
group (cons U group)
)
(setq i (+ i 1))
)
(setq U (list (* L (- i 1)) (* 0.1 d))
group (cons U group)
group (reverse group)
)
(setq group_string
(list "项目名称:" "设计单位:" "监理单位:" "施工单位:"
"制图人:ashleytgg")
)
(setq i 0)
(repeat 5
(entmake
(list '(0 . "TEXT")
(append '(10) (nth i group)) ;第一对齐点（在 OCS 中）
(cons 40 (* d 0.65)) ; 文字高度
(cons '1 (nth i group_string)) ; 内容
)
)
(ssadd (entlast) ss)
(setq i (+ i 1))
)
(if (not name)
(setq name "tang")
)
(emkblk ss U_insert name)
) ; make_drawing_frame 函数结束
;; (setq U_insert (getpoint "输入插入点:")) ( make_drawing_frame 600 U_insert "tang" )
;; 绘图用函数函数结束 88888 绘图用函数函数结束88888 绘图用函数函数结束88888 绘图用函数函数结束88888 绘图用函数函数结束88888 绘图用函数函数结束
;; dcl 使用函数 888888888888888888 dcl 使用函数 888888888888888888 dcl 使用函数 888888888888888888dcl 使用函数 888888888888888888 dcl 使用函数 888888888888888888
(defun Dcl_write (lst / dcl_file str file)
(vl-load-com)
(setq dcl_file (vl-filename-mktemp nil nil ".dcl"))
(setq file (open dcl_file "w"))
(foreach str lst (write-line str file))
(close file)
(setq id (load_dialog dcl_file))
)
(defun C:use_dcl (/ id
sdt group_vertical_curve
group_vertical_curve_2
parameter list_key
list_key_2 list_key_3
U group
group_JD_list group_JD_plane
group_JD_Width group_JD_slope
group_vertical_segments
mold group_turning_point
group_Line_segments group_widen
group_superelevation
stake_mark_group Z_Δ
Z_continue group_z_str
)
(setq string_dcl
'("JD_item:list_box{ key="JD_list"; label="交点参数表："; value=0;"
"list=" ( 转点号转点状态nil) 转点坐标 ( Lh1 R Lh2 ) \\n ( 转点号转点状态t) 转点坐标 (R_start R R_end Lh1 Lh2 )";"
"fixed_width=true; width=100; allow_accept=true;}"
"table_wide :list_box{ key="table_wide"; value=0;"
"list=" 交点号交点加宽值 ";"
"allow_accept=true;}"
"scfg:toggle{ label="曲线加宽方式,选中为直线加宽,不选一般加宽"; key="scfg";}"
"Z_road_start :edit_box {label="起点桩号:"; key= "Z_road_start";value="0";allow_accept=true;is_enabled=false;}"
"insert_table_J :button {label="请选择交点参数列表:"; key= "insert_table_J"; fixed_width=true;width=20; }"
"insert_table_W :button {label="请选择加宽参数列表:"; key= "insert_table_W"; fixed_width=true;width=20; }"
"JD_item_vertical:list_box{ key="JD_list_vertical"; label="竖曲线交点参数表："; value=0;"
"list=" ( 转点号转点桩号转点高程转点半径 ) ";"
"fixed_width=true;width=100;"
"allow_accept=true;}"
"insert_table_J_V :button {label="请选择竖曲线交点参数列表:"; key= "insert_table_J_V"; fixed_width=true;width=10; }"
"display :button {label="显示竖曲线、平面曲线交点参数:"; key= "display"; fixed_width=true;width=10; }"
"N_x :edit_box {label="N(X):"; key= "N_x";value="0";allow_accept=true;}"
"E_Y :edit_box {label="E(Y):"; key= "E_Y";value="0";allow_accept=true;}"
"insert_point : button {label="请选择插入点:"; key= "insert_point"; fixed_width=true;width=20;} "
"road_wide :edit_box {label="请选择路面宽度:(不包括土路肩):"; key= "road_wide";value="5.0";allow_accept=true;}"
"frame_wide :edit_box {label="请选择设计图框的宽度:"; key= "frame_wide";value="297";allow_accept=true;}"
"Z_Δ :edit_box {label="请选择桩号的间距:"; key= "Z_Δ";value="5";allow_accept=true;}"
"table_superelevation :list_box{ key="table_superelevation"; value=0;"
"list=" 交点号交点超高值 ";"
"allow_accept=true;}"
"insert_table_slope :button {label="请选择超高参数列表:"; key= "insert_table_slope"; fixed_width=true;width=20; }"
"table_Z :list_box{ key="table_Z"; value=0;"
"list="设计桩号列表\\n 设计桩号列表2";"
"allow_accept=true;is_enabled=false;}"
"stake_Z :button {label="选择设计桩号列表"; key= "stake_Z"; fixed_width=true;width=8;is_enabled=false;}"
"draw_table :button {label="绘制CAD表格"; key= "draw_table"; fixed_width=true;width=8;is_enabled=true;}"
"draw_excel :button {label="绘制EXCEL表格"; key= "draw_excel"; fixed_width=true;width=8;is_enabled=true;}"
"draw_standard_section:"
"dialog{ label="绘制公路标准断面"; spacer;"
"fixed_width=true;width=120;"
": boxed_row {JD_item;"
": column {"
"insert_table_J;"
":text{label="请填入线路起点桩号:";}"
"Z_road_start ;"
"}"
"}"
": boxed_row {JD_item_vertical;"
": column { fixed_width=true;width=10;"
": column { insert_table_J_V ;display ; }"
"}"
"}"
": boxed_row {"
": boxed_column { fixed_width=true;width=30;"
"label="交点加宽参数参数表:";"
"table_wide ;"
": column { scfg ; insert_table_W ; }"
"}"
": boxed_column { fixed_width=true;width=40;"
"label="交点超高参数参数表:";"
"table_superelevation ;"
"insert_table_slope;"
"}"
": boxed_column { fixed_width=true;width=40;"
"label="设计桩号列表";"
"table_Z;"
"stake_Z;"
"}"
"}"
": boxed_row {"
": boxed_column { fixed_width=true;width=30;"
"N_x ; E_Y;insert_point;"
"}"
": boxed_column {fixed_width=true;width=30; road_wide ; frame_wide;Z_Δ; }"
": boxed_column {fixed_width=true;width=20;"
":text{label="选择桩号形式";key="Z_txt";}"
":boxed_radio_column {:radio_button { key="z_con"; label="连续桩号";value=1;}"
":radio_button { key="z_desi"; label="设计桩号";}"
"}"
"}"
": boxed_column {"
"draw_excel;"
": button {label="输出cass横断面";key="draw_cass";is_default=true;fixed_width=true;width=12;}"
"}"
": boxed_column {"
": button {label="绘制横断面";key="ok";is_default=true;fixed_width=true;width=12;}"
"draw_table;"
": button {label="退出";key="cancel";is_cancel=true;fixed_width=true;width=12;}"
"}"
"}"
"}"
"vertical_segments :list_box{ key="vertical_segments"; value=0;"
"list="( 转点号I j)Z_start Z_end 起点高程线元起点象限角 R 转角Δ) ";"
"allow_accept=true;}"
"Line_segments :list_box{ key="Line_segments";value=0;"
"list="( 转点号I j) 起点半径终点半径曲线长度偏转系数线元起点方位角起点桩号起点坐标 ) ";"
"allow_accept=true;}"
"display_calculate_message:"
"dialog{ label="显示计算信息"; spacer;"
"fixed_width=true;width=140;"
":boxed_column{ label="线元参数参数表："; Line_segments ;}"
":boxed_column{ label="竖曲线线元参数表："; vertical_segments ;}"
": boxed_row {"
": button {label="退出";key="cancel";is_cancel=true;fixed_width=true;width=12;}"
": button {label="返回原界面";key="accept";is_default=true;fixed_width=true;width=12;}"
"}"
"}"
)
)
(if nil
(setq ID
(load_dialog
"D:\\工作文件\\新建文件夹\\work\\公路曲线简易程序\\用变换群绘制公路曲线\\绘制标准断面\\绘制标准断面"
)
)
(progn
(Dcl_write string_dcl)
(setq string_dcl nil)
)
)
(setq sdt 1
list_key (list "JD_list" "Z_road_start"
"JD_list_vertical"
"table_wide" "scfg"
"table_superelevation"
"road_wide" "frame_wide"
"Z_Δ" "z_con"
"z_desi" "table_Z"
"N_x" "E_Y"
)
list_key_2 (list "table_Z" "stake_Z")
list_key_3 (list "Z_Δ")
)
(while (>= sdt 0)
(if (< sdt 10)
(progn
(if (not (new_dialog "draw_standard_section" id))
(exit)
)
;; 对对对话框中的参数进行重新设置
(if (or (= sdt 3) (= sdt 6))
(progn
(if (or group_JD_plane group_JD_list
group_JD_Width group_JD_slope
group_z_str
)
(progn
(start_list "JD_list" 3)
(mapcar 'add_list group_JD_plane)
(end_list)
(start_list "JD_list_vertical" 3)
(mapcar 'add_list group_JD_list)
(end_list)
(start_list "table_wide" 3)
(mapcar 'add_list group_JD_Width)
(end_list)
(start_list "table_superelevation" 3)
(mapcar 'add_list group_JD_slope)
(end_list)
(start_list "table_Z" 3) ; 把原先列表去掉，换成新的
(mapcar 'add_list group_z_str)
(end_list)
)
)
(set_inform_dialog parameter list_key)
(if (and (= (get_tile "z_con") "0")
(= (get_tile "z_desi") "1")
)
(progn
(mode_value 0 list_key_2)
(mode_value 1 list_key_3)
)
(progn
(mode_value 1 list_key_2)
(mode_value 0 list_key_3)
)
)
)
)
(action_tile
"cancel"
"(done_dialog -2 )"
)
(action_tile ; 竖曲线交点参数插入表格的动作函数
"insert_table_J_V"
"(action_insert_table_J_V)"
)
(action_tile ; 平面曲线交点参数插入表格的动作函数
"insert_table_J"
"(action_insert_table_J)
(action_calculate \t group_turning_point)
(setq parameter(get_inform_dialog \t list_key))
"
)
(action_tile ; 平面曲线交点的加宽参数插入的动作函数
"insert_table_W"
"(action_insert_table_W)"
)
(action_tile
"insert_point"
"(setq parameter(get_inform_dialog \t list_key))(done_dialog 3 )"
)
(action_tile ; 绘制标准断面
"ok"
"(setq parameter(get_inform_dialog \t list_key))(done_dialog -8 )"
)
(action_tile
"display"
"(setq parameter(get_inform_dialog \t list_key)) (done_dialog 18 )"
)
(action_tile ;交点的超高参数插入的动作函数
"insert_table_slope"
"(action_insert_table_slope)"
)
(action_tile
"z_con"
"(set_tile "Z_txt" "连续桩号")
( mode_value 1 \t list_key_2 )
( mode_value 0 \t list_key_3 )
"
)
(action_tile
"z_desi"
"(set_tile "Z_txt" "设计桩号")
( mode_value 0 \t list_key_2 )
( mode_value 1 \t list_key_3 )"
)
(action_tile ;设计桩号参数的动作函数
"stake_Z"
"(setq stake_mark_group (action_stake_Z ))"
)
(action_tile
"draw_table"
"(setq parameter(get_inform_dialog \t list_key))(done_dialog -9 )"
)
(action_tile
"draw_excel"
"(setq parameter(get_inform_dialog \t list_key))(done_dialog -12 )"
)
(action_tile
"draw_cass"
"(setq parameter(get_inform_dialog \t list_key))(done_dialog -13 )"
)
(setq sdt (start_dialog))
)
) ; (if (< sdt 10) 函数结束
(if (>= sdt 10)
(progn
(if (not (new_dialog "display_calculate_message" id))
(exit)
)
(action_display group_vertical_segments group_Line_segments)
(action_tile
"accept"
"(done_dialog 6 )"
)
(action_tile
"cancel"
"(done_dialog -2 )"
)
(setq sdt (start_dialog))
)
) ; (if (>= sdt 10) 函数结束
(if (= sdt 3)
(setq u (getpoint "请选择插入点:")
U (list (cadr U) (car U))
U (mapcar 'rtos U)
parameter
(mapcar '(lambda (i)
(nth i parameter)
)
(list 0 1 2 3 4 5 6 7 8 9 10 11)
)
parameter (append parameter U)
parameter
(mapcar '(lambda (i)
(nth i parameter)
)
(list 0 1 2 3 4 5 6 7 8 9 10 11 12 13)
)
)
) ; (if (= sdt 3) 函数结束
) ; (while (> sdt 0) 函数结束
(unload_dialog id)
(if (= sdt -8)
(progn
;; lst 结构为 mold "N_x" "E_Y" "road_wide" "frame_wide" "Z_Δ" "z_con"
(setq lst (mapcar '(lambda (i)
(nth i parameter)
)
(list 12 13 6 7 8)
)
lst (mapcar 'atof lst)
U_insert (list (cadr lst) (car lst))
road_wide (caddr lst)
frame_wide (nth 3 lst)
Z_Δ (nth 4 lst) ;桩号增加值
lst (mapcar '(lambda (i)
(atoi (nth i parameter))
)
(list 4 9)
)
mold (car lst)
Z_continue (cadr lst) ; 表示连续或设计桩号的状态值
)
(setq lst (mapcar 'read parameter)
lst (mapcar '(lambda (i)
(nth i lst)
)
(list 12 13 6 7 8 4 9)
)
lst (mapcar 'numberp lst)
)
(if (not (apply 'and lst))
(progn
(alert "您输入了内容格式不对！")
(exit)
)
)
(if group_Line_segments
(progn
(create_group_data_out
group_Line_segments group_widen
group_vertical_curve_2 group_superelevation
road_wide frame_wide U_insert
mold Z_Δ stake_mark_group
Z_continue
) ; mold 为加宽方式
)
(alert "您还没有输入完整的线路参数!")
)
)
) ; (if (= sdt 8) 函数结束
(if (= sdt -9)
(progn
;; lst 结构为 mold "N_x" "E_Y" "Z_Δ"
(setq lst (mapcar '(lambda (i)
(nth i parameter)
)
(list 12 13 8)
)
lst (mapcar 'atof lst)
U_insert (list (cadr lst) (car lst))
Z_Δ (caddr lst) ;桩号增加值
;; lst 结构为 "scfg" "z_con"
lst (mapcar '(lambda (i)
(atoi (nth i parameter))
)
(list 4 9)
)
mold (car lst)
Z_continue (cadr lst) ; 表示连续或设计桩号的状态值
)
(if group_Line_segments
(progn
(create_table_data_out
group_Line_segments group_widen
group_vertical_curve_2
group_superelevation U_insert
mold Z_Δ
stake_mark_group Z_continue
)
)
(alert "您还没有输入完整的线路参数!")
)
)
) ; (if (= sdt -9) 函数结束
(if (= sdt -12)
(progn
;; lst 结构为 mold "N_x" "E_Y" "Z_Δ"
(setq lst (mapcar '(lambda (i)
(nth i parameter)
)
(list 12 13 8)
)
lst (mapcar 'atof lst)
Z_Δ (caddr lst) ;桩号增加值
;; lst 结构为 "scfg" "z_con"
lst (mapcar '(lambda (i)
(atoi (nth i parameter))
)
(list 4 9)
)
mold (car lst)
Z_continue (cadr lst) ; 表示连续或设计桩号的状态值
)
(if group_Line_segments
(progn
(create_excel_data_out
group_Line_segments group_widen
group_vertical_curve_2
group_superelevation mold
Z_Δ stake_mark_group
Z_continue
)
)
(alert "您还没有输入完整的线路参数!")
)
)
) ; (if (= sdt -12) 函数结束
(if (= sdt -13)
(progn
(setq lst (mapcar '(lambda (i)
(nth i parameter)
)
(list 3 13 8)
)
lst (mapcar 'atof lst)
Z_Δ (caddr lst) ;桩号增加值
road_wide (car lst)
;; lst 结构为 "scfg" "z_con"
lst (mapcar '(lambda (i)
(atoi (nth i parameter))
)
(list 4 9)
)
mold (car lst)
Z_continue (cadr lst) ; 表示连续或设计桩号的状态值
)
(if group_Line_segments
(progn
(create_cass_data_out
group_Line_segments group_widen
group_vertical_curve_2
group_superelevation mold
Z_Δ stake_mark_group
Z_continue road_wide
)
)
(alert "您还没有输入完整的线路参数!")
)
)
) ; (if (= sdt -13) 函数结束
)
;; 定义"insert_table_J_V" 按钮的动作
(defun action_insert_table_J_V
(/ lst n group)
(setq group_vertical_curve (create_group_vertical_curve))
(setq group_vertical_curve_2
(create_group_vertical_curve_2
group_vertical_curve
)
)
(setq n (length group_vertical_curve))
(setq group_JD_list
(mapcar '(lambda (lst)
(apply '(lambda (JD Z h R)
(strcat "JD: "
(itoa JD)
" 转点桩号:"
(rtos Z 2 3)
" 转点高程:"
(rtos h 2 2)
" 转点半径:"
(rtos R 2 2)
)
)
lst
)
)
group_vertical_curve
)
)
(setq group_vertical_segments
(mapcar '(lambda (lst ; (setq lst ( nth 5 group_vertical_curve_2 ) )
/ lst2 lst3 element i j)
(setq lst2 (mapcar '(lambda (i)
(rtos (nth i lst) 2 2)
)
(list 1 2 3 5)
)
lst3 (mapcar '(lambda (i)
(angtos (nth i lst) 1 6)
)
(list 4 6)
)
element (car lst) ; 对第一个元素进行处理
i (itoa (car element))
j (itoa (cadr element))
element (strcat i "-" j)
lst (append (list element) lst2 lst3)
; lst 顺序为 (list 0 1 2 3 5 4 6 )
;; 对lst 进行逆置换, 对 (list 0 1 2 3 5 4 6 ) 用 (list 0 1 2 3 5 4 6 ) 置换
lst (mapcar '(lambda (i)
(nth i lst)
)
(list 0 1 2 3 5 4 6)
)
)
;; 对lst数组进行注释
(setq
lst2 (list "JD:" "Z_start:" "Z_end:"
"H:" "α0:" "R:"
"α_Δ:"
)
lst (append lst lst2)
lst (mapcar '(lambda (i)
(nth i lst)
)
(list 7 0 8 1 9 2 10 3 11 4 12 5 13 6)
)
)
(setq lst (vl-princ-to-string lst)
lst (vl-string-left-trim "\(" lst)
lst (vl-string-right-trim "\)" lst)
)
)
group_vertical_curve_2
)
)
(start_list "JD_list_vertical" 3)
(mapcar 'add_list group_JD_list)
(end_list)
(set_tile "JD_list_vertical" (itoa n))
)
;; 用参数parameter 对控件集合list_key 进行参数重置
(defun set_inform_dialog
(parameter list_key / i lst)
(setq i 0)
(mapcar '(lambda (x / str)
(setq str (nth i parameter))
(set_tile x str)
(setq i (+ 1 i))
)
list_key
)
)
;;( set_inform_dialog parameter list_key )
;;获取控件集合list_key 的参数parameter
(defun get_inform_dialog
(list_key / lst)
(mapcar '(lambda (x) (get_tile x))
list_key
)
)
;; 定义平面曲线插入交点文件按钮的函数
(defun action_insert_table_J (/ lst group Z_road_start)
(setq
lst (create_turning_point_group_original)
group_turning_point_original
(car lst)
Z_road_start
(rtos (cadr lst))
)
(setq lst (create_turning_point_group
group_turning_point_original
Z_road_start
) ; Z_road_start 在此程序中不变
group_turning_point (car lst)
)
;; 用group_turning_point 数组分别对列表框 "JD_list"
(setq group
(mapcar
'(lambda (lst / state subset_label)
(apply '(lambda (x_0 x_1 x_2 x_3)
(setq x_1 (mapcar 'rtos x_1)
x_1 (list "N:" (cadr x_1) " E:" (car x_1))
x_1 (apply 'strcat x_1)
)
(if (cadr x_0)
(progn
(setq state "Yes")
(setq
x_2 (apply '(lambda (y_0 y_1 y_2 y_3 y_4)
(setq subset_label (list "R_s"
"R"
"R_e"
"Lh1"
"Lh2")
subset (list y_0 y_1 y_2 y_3 y_4)
subset (append subset subset_label)
)
(mapcar '(lambda (i)
(nth i subset)
)
(list 5 0 6 1 7 2 8 3 9 4)
)
)
x_2
)
)
)
(progn
(setq state "No")
(setq x_2 (apply '(lambda (y_0 y_1 y_2)
(setq subset_label (list "Lh1" "R" "Lh2")
subset (list y_0 y_1 y_2)
subset (append subset subset_label)
)
(mapcar '(lambda (i)
(nth i subset)
)
(list 3 0 4 1 5 2)
)
)
x_2
)
)
)
) ; (if (cadr x_0) 函数结束
(setq x_2 (vl-princ-to-string x_2)
x_2 (vl-string-left-trim "\(" x_2)
x_2 (vl-string-right-trim "\)" x_2)
)
(list "JD:" (car x_0) state x_1 x_2)
)
lst
)
)
group_turning_point
)
)
(setq group_JD_plane
(mapcar '(lambda (lst / string)
(setq string (vl-princ-to-string lst)
string (vl-string-left-trim "\(" string)
string (vl-string-right-trim "\)" string)
)
)
group
)
)
(start_list "JD_list" 3)
(mapcar 'add_list group_JD_plane)
(end_list)
;;用Z_road_start 对编辑框"Z_road_start" 进行填充
(set_tile "Z_road_start" Z_road_start)
) ; action_insert_table_J 函数结束
(defun action_insert_table_W (/ lst group)
(setq group_widen (write_into_group_widen))
;; 用group_widen 数组分别对列表框 "table_wide" 进行填充
(setq group_JD_Width
(mapcar '(lambda (lst
/
JD
W
)
(setq JD (itoa (car lst))
W (rtos (cadr lst) 2 3)
)
(strcat "JD: " JD " 加宽:" W)
)
group_widen
)
)
(start_list "table_wide" 3)
(mapcar 'add_list group_JD_Width)
(end_list)
) ; action_insert_table_W 函数结束
(defun action_calculate
(group_turning_point / lst group road_start group_sum n)
(setq road_start (get_tile "Z_road_start")
road_start (read road_start)
)
(if (not (numberp road_start))
(progn
(alert "您输入的起止桩号不是实数！")
(exit)
)
)
(if group_turning_point
(setq
lst
(create_group_Line_segments group_turning_point road_start)
group_Line_segments
(car lst)
)
)
) ; action_calculate 函数结束
;; 显示按钮 display 的动作函数
(defun action_display
(group_vertical_segments
group_Line_segments /
n group
group_sum
)
(if group_vertical_segments
(progn
(start_list "vertical_segments" 3)
(mapcar 'add_list group_vertical_segments)
(end_list)
(setq n (length group_vertical_curve_2))
(set_tile "vertical_segments" (itoa n))
)
)
(if group_Line_segments
(progn
(setq group_sum (apply 'append group_Line_segments))
;; 用 group_Line_segments 填充列表框 "Line_segments"
(setq group_sum
(mapcar ; (setq lst (car group_sum)) (setq x_7 ( nth 7 lst))
'(lambda (lst / lenth lst_label)
(apply '(lambda (x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7)
(setq x_0 (mapcar 'itoa x_0)
x_0 (list (car x_0) "-" (cadr x_0))
x_0 (apply 'strcat x_0)
)
(setq x_7 (mapcar 'rtos x_7)
x_7 (list "N:" (cadr x_7) " E:" (car x_7))
x_7 (apply 'strcat x_7)
)
(setq
x_6 (f_zhuanghao x_6)
)
(if (atom x_3)
(setq lenth x_3)
(setq lenth (car x_3))
)
(setq lenth (* lenth 1.0)
x_3 (rtos lenth 2 2)
x_5 (+ (* x_5 -1) (/ pi 2))
; 把象限角变成方位角
x_5 (angtos x_5 1 6)
)
;; 对(list x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7 ) 进行标注
(setq lst (list x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7)
lst_label (list "R_s:"
"R_e:"
"lenth:"
"reflex:"
"α_s:"
)
lst (append lst lst_label)
)
;; lst顺序为 (0 1 2 3 4 5 6 7 8 9 10 11 12 )
(mapcar '(lambda (i)
(nth i lst)
)
(list 0 8 1 9 2 10 3 11 4 12 5 6 7)
)
)
lst
)
)
group_sum
)
)
(setq group ; (setq lst (car group_sum ))
(mapcar '(lambda (lst / string)
(setq string (vl-princ-to-string lst))
(setq string (vl-string-left-trim "\(" string)
string (vl-string-right-trim "\)" string)
)
)
group_sum
)
)
(start_list "Line_segments" 3)
(mapcar 'add_list group)
(end_list)
)
;; 当group_Line_segments 数组为空时
(progn
(start_list "Line_segments" 2)
(mapcar 'add_list
(list "group_Line_segments 交点数组为空!")
)
(end_list)
)
)
(setq n (length group))
(set_tile "Line_segments" (itoa n))
)
;; ( action_display group_vertical_segments group_Line_segments )
;; 定义插入交点超高参数的动作函数
(defun action_insert_table_slope (/ n)
(setq group_superelevation (create_group_superelevation))
(setq group_JD_slope
(mapcar '(lambda (lst / JD slope lst2 slope_back slope_front)
(if (= (length lst) 2)
(setq JD (itoa (car lst))
slope (rtos (cadr lst))
lst2 (strcat "JD: " JD " 超高值: " slope " %")
)
)
(if (= (length lst) 3)
(setq JD (itoa (car lst))
slope_bakc (rtos (car (cadr lst)))
slope (rtos (cadr (cadr lst)))
slope_front (rtos (car (caddr lst)))
lst2 (strcat "JD: "
JD
" 超高开始值: "
slope_bakc
" %"
" 超高值: "
slope
" %"
" 超高结束值: "
slope_front
" %"
)
)
)
lst2
)
group_superelevation
)
)
(start_list "table_superelevation" 3)
(mapcar 'add_list group_JD_slope)
(end_list)
(setq n (length group_JD_slope))
(set_tile "table_superelevation" (itoa n))
)
;; 对控件集合"table_Z" "stake_Z" "Z_txt" 进行参数设置
(defun mode_value
(value list_key / i lst)
(setq i 0)
(mapcar '(lambda (x)
(mode_tile x value)
(setq i (+ 1 i))
)
list_key ; (setq list_key (list "table_Z" "stake_Z" "Z_Δ") )
)
)
;; ( mode_value 0 list_key )

;; 创建  group_data_out 和 加宽值   
(defun create_group_data_out_sub (Line_segments         mold 
                                  /                 lst 
                                  Line_segments_type 
                                  str 
                                 ) 
  ;; (setq Width 5  number 0 )    
  (mapcar                                ;  (setq subset (nth 0 (nth 11 group_Line_segments )) )       
    '(lambda (subset        /          lst            group_Z   num 
              Z_start        Z_end          len            group_data_out 
              subset_2        i          array            color 
             ) 
       (setq array    (car subset) 
             num      (cadr array) 
             ;; 去除 [( 转点号I j)   R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert )]中的第一个元素   
             subset_2 (cdr subset) 
             reflex   (nth 3 subset_2) 
             Z_start  (nth 5 subset_2) 
       ) 
       (cond 
         ((or (= num 0) 
              (= num 2) 
          ) 
          (progn 
            (setq len        (car (caddr subset_2)) 
                  Z_end        (+ Z_start len) 
            ) 
            (if        (= Z_continue 1) 
              (setq group_Z (create_group_Z Z_start Z_end Z_Δ)) 
              (setq group_Z (cadr (assoc Z_start group_Z_out))) 
            ) 
            (setq group_data_out 
                   (solve_transition_curve group_Z subset_2) 
            ) 
          ) 
         ) 
         ((= num 1) 
          (progn 
            (setq len        (caddr subset_2) 
                  Z_end        (+ Z_start len) 
            ) 
            (if        (= Z_continue 1) 
              (setq group_Z (create_group_Z Z_start Z_end Z_Δ)) 
              (setq group_Z (cadr (assoc Z_start group_Z_out))) 
            ) 
            (setq group_data_out (solve_circular_arc group_Z subset_2)) 
          ) 
         ) 
         ((= num 3) 
          (progn 
            (setq len        (caddr subset_2) 
                  Z_end        (+ Z_start len) 
            ) 
            (if        (= Z_continue 1) 
              (setq group_Z (create_group_Z Z_start Z_end Z_Δ)) 
              (setq group_Z (cadr (assoc Z_start group_Z_out))) 
            ) 
            (setq group_data_out (solve_straightway group_Z subset_2)) 
          ) 
         ) 
       )                                ; cond 函数结束 
       ;; 求group_Z 中每个桩号的加宽值 
       (if (not mold) 
         (setq mold 1)                        ; mold没有定义时，设置为直线加宽   
       ) 
       (if (and        (/= num 3) 
                (assoc (car array) group_widen) ; 判断该转点是否加宽   
           ) 
         (setq group_width 
                (mapcar 
                  '(lambda (z / Width) 
                     (setq Width 
                            (calculate_Transition-curve_widen 
                              Z 
                              group_widen 
                              subset 
                              mold 
                            ) 
                     ) 
                     (* Width reflex)        ; 对确定加宽值的左右方向    
                   ) 
                  group_Z 
                ) 
         ) 
         ;; 直线线元加宽值设置为0 
         (setq group_width 
                (mapcar 
                  '(lambda (z / Width) 
                     0 
                   ) 
                  group_Z 
                ) 
         ) 
       ) 
       ;;  group_transition ( 转点号num j) (i j k) ，i 和 k 分别为该线元的 前后线元编号  i k 取值为0 ，1 ，2 ,3   
       (setq lst (cadr (assoc array group_transition))) 
       (cond 
         ((= (cadr lst) 3)                ; 直线线元时 
          (setq        color 1 
                Line_segments_type 
                 "  直线" 
          ) 
         ) 
         ((= (cadr lst) 1)                ;圆曲线线元时 
          (setq        color 2 
                Line_segments_type 
                 "  圆曲线" 
          )                                ; 黄色   
         ) 
         ;; 当缓和曲线时接直线和圆时    
         ((or (equal lst '(3 0 1)) 
              (equal lst '(1 2 3)) 
          ) 
          (setq        color 3 
                Line_segments_type 
                 "  缓和曲线" 
          )                                ; 绿色   
         ) 
         ;; 当缓和曲线时接缓和曲线和圆时    
         ((or (equal lst '(2 0 1)) 
              (equal lst '(1 2 0)) 
          ) 
          (progn 
            (if        (= (cadr lst) 0) 
              (setq color 6)                ; 洋红色 入口缓和曲线   
              (setq color 5)                ;蓝色  出口缓和曲线   
            ) 
            (setq Line_segments_type 
                   "  缓和曲线" 
            )                                ; 洋红色 
          ) 
         ) 
         ;; 当缓和曲线是接圆和圆时    
         ((or (equal lst '(1 0 1)) 
              (equal lst '(1 2 1)) 
          ) 
          (setq        color 4 
                Line_segments_type 
                 "  缓和曲线" 
          )                                ; 青色   
         ) 
         (t 
          (setq        color 0 
                Line_segments_type 
                 "  缺省状态" 
          ) 
         ) 
       ) 
       ;; 判断线元的起点是什么型号，如ZH HY    
       (setq 
         array_2 (list (car lst) (cadr lst)) 
       ) 
       (cond 
         ((equal array_2 
                 '(3 0) 
          ) 
          (setq str "ZH") 
         ) 
         ((equal array_2 
                 '(3 1) 
          ) 
          (setq str "ZY") 
         ) 
         ((equal array_2 
                 '(0 1) 
          ) 
          (setq str "HY") 
         ) 
         ((equal array_2 
                 '(1 0) 
          ) 
          (setq str "YH") 
         ) 
         ((equal array_2 
                 '(1 2) 
          ) 
          (setq str "YH") 
         ) 
         ((equal array_2 
                 '(1 3) 
          ) 
          (setq str "YZ") 
         ) 
         ((equal array_2 
                 '(2 3) 
          ) 
          (setq str "HZ") 
         ) 
         ((equal array_2 
                 '(2 0) 
          ) 
          (setq str "HH") 
         ) 
         ((equal array_2 
                 '(2 1) 
          ) 
          (setq str "HY") 
         ) 
         (t 
          (setq str "88") 
         ) 
       )                                ; cond 函数结束 
       ;; 创建group_Z 的高程值 
       (setq group_h_slope 
              (mapcar '(lambda (z / h slope) 
                                        ; ( setq z (car group_Z ))   
                         (setq h     (QH2_10N Z group_vertical_curve_2) 
                               slope (calculate_superelevation 
                                       z 
                                       group_superelevation 
                                       subset 
                                     ) 
                         ) 
                         (if h 
                           (list h slope) 
                           (list 100 slope) 
                         ) 
                       ) 
                      group_Z 
              ) 
       ) 
 
       ;; 把 group_data_out 、 group_width 和 group_h_slope 合并起来 组成新的数组 { z U ang width h  ( superelevation_L  superelevation_R )} 
       (setq i 0) 
       (setq group 
              (mapcar '(lambda (lst / width lst2) 
                         (setq width (nth i group_width) 
                               lst2  (nth i group_h_slope) 
                               i     (+ i 1) 
                         ) 
                         (append lst (list width) lst2) 
                       ) 
                      group_data_out 
              ) 
       ) 
 
       (setq i 0) 
       (mapcar 
         '(lambda (lst              /                 string            j 
                   residue    U_page         U_move            ang 
                   group_U    superelevation_L            superelevation_R 
                   W_L              W_R         h_L            h_R 
                   lst2              lst3 
                  ) 
            (setq residue (rem number n_grid) 
                                        ; n_grid 为Uniform_group_center 中的格子数 
                  j          (/ (- number residue) n_grid) ; 页数 
                  U_page  (polar U_insert 0 (* j (* frame_wide 1.2))) 
                  U          (nth residue Uniform_group_center) 
                                        ; 桩号Z 在Uniform_group_center 域中的插入点   
                  U_move  (list        (+ (car U_page) (car U)) 
                                (+ (cadr U_page) (cadr U)) 
                          ) 
            ) 
            ;; 把z U ang width 桩号、坐标、方位角、加宽值 写入 图中 
            (setq U        (cadr lst)        ;  (setq lst (car group))    
                  width        (nth 3 lst) 
                  lst2        (cons width U) 
                  lst2        (mapcar 'rtos lst2) 
                  桩号        (f_zhuanghao (car lst)) 
                  ang        (caddr lst) 
                  ang        (angtos (* (- ang (* 0.5 pi)) -1) 1 6) 
                                        ; 把象限角转换成方位角 
                  lst2        (append (list 桩号 ang) lst2) 
                  lst2        (mapcar        '(lambda (i) 
                                   (nth i lst2) 
                                 ) 
                                (list 0 4 3 1 2) 
                        ) 
            ) 
            (if        (and (= i 0) Z_continue) 
              (setq 
                lst3 (list str "\n N(X):" "E(Y):" "\n 方位角:" 
                           "\n 加宽值:") 
              ) 
              (setq 
                lst3 (list Line_segments_type "\n N(X):" 
                           "E(Y):"              "\n 方位角:" 
                           "\n 加宽值:" 
                          ) 
              ) 
            ) 
            (setq 
              lst2 (append lst2 lst3) 
            ) 
            (setq lst2 (mapcar '(lambda        (i) 
                                  (nth i lst2) 
                                ) 
                               (list 0 5 6 1 7 2 8 3 9 4) 
                       ) 
            ) 
            (setq string (vl-princ-to-string lst2) 
                  string (vl-string-left-trim "\(" string) 
                  string (vl-string-right-trim "\)" string) 
            ) 
            (entmake 
              (list 
                '(0 . "MTEXT") 
                '(100 . "AcDbEntity") 
                '(100 . "AcDbMText") 
                (cons 62 color) 
                (cons 40 (* road_wide 0.1)) 
                (cons 71 5) 
                (cons 72 5) 
                (cons '1 string) 
                (cons 10 (polar U_move (* pi 0.5) (* road_wide -0.25))) 
              ) 
            ) 
            ;; 用 group 数组和路面宽度road_wide 创建 桩号Z 的标准横断面控制点 U_cen U_L U_R U_L_2 U_R_2   
            ;; U_L_2 U_R_2 路面宽度road_wide 加 土路肩宽度的值 
            (setq h (nth 4 lst) 
                  width        (nth 3 lst) 
                  superelevation_L 
                   (car (nth 5 lst)) 
                  superelevation_R 
                   (cadr (nth 5 lst)) 
            ) 
            (if        (> width 0)                ; 在Ucs坐标系中以向右为正 
              (setq W_L        (+ road_wide width) 
                    W_R 
                        (* road_wide -1) 
              ) 
              (setq W_L        road_wide 
                    W_R 
                        (+ (* road_wide -1) width) 
              ) 
            ) 
            ;; 在Ucs坐标系中以向右为正 , 所以对 W_L W_R 反向   
            (setq W_L (* W_L -1) 
                  W_R (* W_R -1) 
            ) 
            ;; 创建 U   U_L U_R U_L_2 U_R_2 各点的高程   
            (setq 
              superelevation_L (* superelevation_L 0.01) 
              superelevation_R (* superelevation_R 0.01) 
              h_L 
                               (* superelevation_L W_L) 
              h_R 
                               (* superelevation_R W_R) 
            ) 
            (setq lst2 (list (- h_L 0.015) 
                             h_L 
                             (* h_L 0.5) 
                             0 
                             (* h_R 0.5) 
                             h_R 
                             (- h_R 0.015) 
                             (* h_L 0.85) 
                                        ; 标识横坡superelevation_L 所用点 
                             (* h_L 0.15) 
                                        ; 标识横坡superelevation_L 所用点 
                             (* h_R 0.15) 
                                        ; 标识横坡superelevation_R 所用点 
                             (* h_R 0.85) 
                                        ; 标识横坡superelevation_R 所用点 
                       ) 
                  lst3 (list (- W_L 0.5) 
                             W_L 
                             (* W_L 0.5) 
                             0 
                             (* W_R 0.5) 
                             W_R 
                             (+ W_R 0.5) 
                             (* W_L 0.85) 
                                        ; 标识横坡superelevation_L 所用点 
                             (* W_L 0.15) 
                                        ; 标识横坡superelevation_L 所用点 
                             (* W_R 0.15) 
                                        ; 标识横坡superelevation_R 所用点 
                             (* W_R 0.85) 
                                        ; 标识横坡superelevation_R 所用点 
                       ) 
                  U    (list (car U_move) (+ (cadr U_move) (* road_wide 0.25))) 
            ) 
            (setq j 0)                        ; (setq U_move (getpoint "输入插入点:"))   
            (setq group_U (mapcar '(lambda (x / y) 
                                     (setq y (nth j lst2) 
                                           j (1+ j) 
                                     ) 
                                     (list (+ (car U) x) 
                                           (+ (cadr U) y) 
                                     ) 
                                   ) 
                                  lst3 
                          ) 
            ) 
            (setq group_h (mapcar '(lambda (i / y) 
                                     (setq y (nth i lst2)) 
                                     (+ h y) 
                                   ) 
                                  (list 0 3 6) 
                          ) 
            ) 
            ;; 把 U_L U U_R 二维多段线写入图中 
            (setq pt (mapcar '(lambda (i / U) 
                                (setq U (nth i group_U)) 
                                U 
                              ) 
                             (list 0 1 3 5 6) 
                     ) 
            ) 
            (entmake 
              (append (list '(0 . "LWPOLYLINE") 
                            '(100 . "AcDbEntity") 
                            '(100 . "AcDbPolyline") 
                            (cons 62 color) 
                            (cons 90 (length pt)) 
                            (cons 70 0) 
                      ) 
                      (mapcar '(lambda (U) (cons 10 U)) pt) 
              ) 
            ) 
            ;; 对group_U 中U_L U U_R 顶点绘制 等边三角形   
            (setq j    0 
                  lst2 
                       (mapcar '(lambda        (U / U_2 U_3) 
                                  (if (or (= j 1) (= j 3)) 
                                    (setq U_2 (polar U (* (/ pi 3.0) 1) (/ road_wide 15.0)) 
                                          U_3 (polar U (* (/ pi 3.0) 2) (/ road_wide 15.0)) 
                                    ) 
                                    (setq U_2 (polar U (* (/ pi 3.0) 1) (/ road_wide 9.0)) 
                                          U_3 (polar U (* (/ pi 3.0) 2) (/ road_wide 9.0)) 
                                    ) 
                                  ) 
                                  (setq j (1+ j)) 
                                  (list U_2 U U_3) 
                                ) 
                               pt 
                       ) 
            ) 
            (mapcar '(lambda (pt) 
                       (entmake 
                         (append (list '(0 . "LWPOLYLINE") 
                                       '(100 . "AcDbEntity") 
                                       '(100 . "AcDbPolyline") 
                                       (cons 62 (+ color 1)) 
                                       (cons 90 (length pt)) 
                                       (cons 70 1) 
                                 ) 
                                 (mapcar '(lambda (U) (cons 10 U)) pt) 
                         ) 
                       ) 
                     ) 
                    lst2 
            ) 
            ;; 绘制用以标识 superelevation_L 和 superelevation_R 的箭头   
            (setq pt 
                   (mapcar '(lambda (i / U) 
                              (setq U (nth i group_U)) 
                              (polar U (* pi 0.5) (/ road_wide 15.0)) 
                            ) 
                           (list 7 8 9 10) 
                   ) 
            ) 
            (setq 
              lst2 
               (apply 
                 '(lambda (x_0 x_1 x_3 x_4 / x_5 x_6 group_L group_R) 
                    (if        (>= superelevation_L 0) 
                      (setq 
                        x_5        (polar x_0 (/ pi 6) (/ road_wide 15.0)) 
                        group_L        (list x_5 x_0 x_1) 
                      ) 
                      (setq 
                        x_5        (polar x_1 (* 0.8333 pi) (/ road_wide 15.0)) 
                        group_L        (list x_0 x_1 x_5) 
                      ) 
                    ) 
                    (if        (< superelevation_R 0) 
                      (setq 
                        x_6        (polar x_4 (* 0.8333 pi) (/ road_wide 15.0)) 
                        group_R        (list x_3 x_4 x_6) 
                      ) 
                      (setq 
                        x_6        (polar x_3 (/ pi 6) (/ road_wide 15.0)) 
                        group_R        (list x_6 x_3 x_4) 
                      ) 
                    ) 
                    (list group_L group_R) 
                  ) 
                 pt 
               ) 
            ) 
            (mapcar '(lambda (pt) 
                       (entmake 
                         (append (list '(0 . "LWPOLYLINE") 
                                       '(100 . "AcDbEntity") 
                                       '(100 . "AcDbPolyline") 
                                       (cons 62 (+ color 2)) 
                                       (cons 90 (length pt)) 
                                       (cons 70 0) 
                                 ) 
                                 (mapcar '(lambda (U) (cons 10 U)) pt) 
                         ) 
                       ) 
                     ) 
                    lst2 
            ) 
            ;; 把group 中    h_L h  h_R ( superelevation_L  superelevation_R )  W_L W_R   写入图中 
            (setq 
              pt (mapcar '(lambda (i / U U_2) 
                            (setq U (nth i group_U)) 
                            (if        (or (= i 2) (= i 4)) 
                              (polar U (* pi 0.5) (* road_wide 0.3)) 
                              (polar U (* pi 0.5) (* road_wide 0.15)) 
                            ) 
                          ) 
                         (list 0 2 3 4 6) 
                 ) 
            ) 
            (setq 
              U          (car pt) 
              U          (list        (car U) 
                        (- (cadr U) (* road_wide 0.35)) 
                  ) 
              U_2 (last pt) 
              U_2 (list        (car U_2) 
                        (- (cadr U_2) (* road_wide 0.35)) 
                  ) 
              pt  (append pt (list U) (list U_2)) 
            ) 
            (setq 
              lst2 (append group_h 
                           (nth 5 lst)        ; ( superelevation_L  superelevation_R )   
                           (list (abs W_L)) 
                           (list W_R) 
                   ) 
              lst2 (mapcar '(lambda (x) (rtos x 2 2)) lst2) 
              lst2 (apply '(lambda (h_L h h_R slope_L slope_R W_L W_R) 
                             (list h_L 
                                   (strcat slope_L " %") 
                                   h 
                                   (strcat slope_R " %") 
                                   h_R 
                                   (strcat "左宽:" W_L) 
                                   (strcat "右宽:" W_R) 
                             ) 
                           ) 
                          lst2 
                   ) 
            ) 
            (setq j 0) 
            (mapcar '(lambda (str / U_move) 
                       (setq U_move (nth j pt)) 
                       (entmake 
                         (list '(0 . "TEXT") 
                               (cons 62 color) 
                               (append '(10) U_move) 
                               (cons 40 (* road_wide 0.1)) 
                               (cons '1 str) 
                               (cons '71 0) 
                               (cons '72 1) 
                               (append '(11) U_move) 
                         ) 
                       ) 
                       (setq j (+ j 1)) 
                     ) 
                    lst2 
            ) 
            (setq number (+ number 1) 
                  i         (+ i 1) 
            ) 
          ) 
         group 
       ) 
     ) 
    Line_segments 
  ) 
) 
;;  (setq tang   ( create_group_Line_segments   group_turning_point  6782.755 )   group_Line_segments (car tang )  tgg (cadr tang)  )   
;;    (setq group_widen (write_into_group_widen))    
;;  (setq stake_mark_group   (write_into_group_stake_mark))  (setq group_Z_out  ( creat_group_z  group_Line_segments    stake_mark_group )  )    
 
 
 
 
 
 
;; (setq group_turning_point_original (car ( create_turning_point_group_original ) ) )    
;; (setq group_turning_point (car  ( create_turning_point_group   group_turning_point_original  Z_road_start )  ) )    
;;  (setq group_vertical_curve  (create_group_vertical_curve ))(setq group_vertical_curve_2 ( create_group_vertical_curve_2  group_vertical_curve ) )    
;;  (setq group_superelevation (create_group_superelevation ) )     创建左右边坡数组 
(defun create_group_data_out (group_Line_segments 
                              group_widen        group_vertical_curve_2 
                              group_superelevation 
                              road_wide                frame_wide 
                              U_insert                mold 
                              Z_Δ                stake_mark_group 
                              Z_continue        / 
                              number                Uniform_group_center 
                              group_transition        group_move 
                              group                n_x 
                              n_y                scale 
                              group_Z_out 
                             ) 
 
  (setq group_transition (create_group_transition group_Line_segments)) 
  (if (not road_wide)                        ; 路面宽度 
    (setq road_wide 5.0) 
  ) 
  (if (not frame_wide)                        ; 图框宽度 
    (setq frame_wide 297) 
  ) 
  (if (not Z_Δ)                        ; 图框宽度 
    (setq Z_Δ 5) 
  ) 
  (setq        n_x    (/ frame_wide (* road_wide 3.5)) 
        n_x    (fix n_x) 
        n_y    (/ (* n_x 210) 297) 
        n_y    (fix n_y) 
        n_grid (* n_x n_y) 
  ) 
  (setq        Uniform_group_center 
         (create_Uniform_distribution 
           n_x 
           n_y 
           frame_wide 
         ) 
  ) 
  (if (= Z_continue 0) 
    (setq group_Z_out 
           (creat_group_z group_Line_segments stake_mark_group) 
    ) 
  ) 
  ;; (setq U_insert (getpoint "输入插入点:"))    
  (setq number 0) 
  (mapcar '(lambda (Line_segments / group) 
             (create_group_data_out_sub 
               Line_segments 
               mold 
             ) 
           ) 
          group_Line_segments 
  ) 
  ;; 绘制每页的边框 
  (if (not (tblobjname "block" "图框")) 
    (make_drawing_frame 297 U_insert "图框") 
                                        ;创建一图框 ,图框宽度设置为297 
  ) 
  (setq        residue        (rem number n_grid) 
        n        (/ (- number residue) n_grid) ; 页数 
  ) 
  (if (> residue 0) 
    (setq n (+ n 1)) 
  ) 
  (setq        i     0 
        scale (/ frame_wide 297.0) 
  ) 
  (repeat n 
    (setq b (* (/ frame_wide 297) 210) 
          U (list (+ (car U_insert) (* (* frame_wide 1.2) i)) 
                  (cadr U_insert) 
            ) 
    ) 
    (entmake (list '(0 . "INSERT") 
                   (cons 2 "图框") 
                   (cons 10 U) 
                   (cons 41 scale) 
                   (cons 42 scale) 
                   (cons 43 scale) 
             ) 
    ) 
    (setq i (+ i 1)) 
  ) 
) 
;; defun create_group_data_out 函数结束 
;; ( create_group_data_out group_Line_segments group_widen  road_wide  frame_wide   U_insert  mold)   
 
 
 
 
 
 
 
 
 
;; 在一个给定的长方形页面中 建立一个点集合 ，该点集合均匀的分布在页面中,页面左下角点为原点(list 0 0 )    
(defun create_Uniform_distribution 
                                   (n_x             n_y      Width    / 
                                    n_grid   i              j               n_1 
                                    n_grid   finite_field 
                                   ) 
  ;;   (setq U_insert (getpoint "输入插入点:"))   
  (if (not n_x) 
    (setq n_x 8) 
  ) 
  (if (not n_y) 
    (setq n_y 4) 
  ) 
 
  (setq        n_grid (* n_x n_y) 
        n_1    0 
        group  nil 
  ) 
  (repeat n_grid 
    ;;确定行数 i  列数j  ，group 的方向是由：下->上，再从：左->右   
    (setq j (rem n_1 n_y) 
          i (/ (- n_1 j) n_y) 
    ) 
    (setq group (cons (list i j) group)) 
    (setq n_1 (+ n_1 1)) 
  ) 
 
  (setq finite_field (reverse group)) 
  ;; 对新建有限域finite_field 从原点：(0 0) 移位到 (0.75 0.75)   
  (setq        group 
         (mapcar '(lambda (U) 
                    (apply '(lambda (x y) 
                              (list (+ x 0.75) 
                                    (+ y 0.75) 
                              ) 
                            ) 
                           U 
                    ) 
                  ) 
                 finite_field 
         ) 
  ) 
  ;; 对数组group (i j)    按原点0 进行放大 ，放大为 图框297*210 大 ,    
  (setq        scale_x        (/ 297.0 (+ n_x 0.5)) 
        scale_y        (/ 210.0 (+ n_y 0.5)) 
                ;; n_y  n_x 加0.5 是为了留下页面的左右、上下空间 
  ) 
  (setq        k        (/ width 297.0)                ; 指定的图框大小 
        scale_x        (* scale_x k) 
        scale_y        (* scale_y k) 
  ) 
  (mapcar '(lambda (U) 
             (apply '(lambda (x y) 
                       (list (* x scale_x) 
                             (* y scale_y) 
                       ) 
                     ) 
                    U 
             ) 
           ) 
          group 
  ) 
)                                        ; (defun create_Uniform_distribution 函数结束    
;; (setq  Uniform_group_center  ( create_Uniform_distribution 5 4 600    )  )    
 
 
;;  (setq ss (ssget) )   (setq pt (getpoint "输入插入点:"))    
;;  (emkblk ss pt "tang")    (setq name "tang" )    
(defun emkblk (ss pt name / i) 
  (entmake 
    (list '(0 . "block") 
          (cons 2 name) 
          '(70 . 0) 
          (cons 10 '(0 0)) 
    ) 
  ) 
  (repeat (setq i (sslength ss)) 
    (entmake (cdr (entget (ssname ss (setq i (1- i)))))) 
  ) 
  (entmake '((0 . "ENDBLK"))) 
  (command "_.erase" ss "") 
  (entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt))) 
) 
 
 
;; 绘制图框  (setq U_insert  (getpoint "输入插入点:"))   
(defun make_drawing_frame 
       (a U_insert name / b d U ss group i group_string) 
  (if (not a) 
    (setq a 600.0) 
  ) 
  (setq b (* (/ a 297.0) 210)) 
  (setq 
    group 
     (list '(0 0) 
           (list a 0) 
           (list a b) 
           (list 0 b) 
     ) 
  ) 
  (entmake 
    (append (list '(0 . "LWPOLYLINE") 
                  '(100 . "AcDbEntity") 
                  '(100 . "AcDbPolyline") 
                  (cons 90 (length group)) 
                  (cons 70 1)                ; 二维曲线闭合 
            ) 
            (mapcar '(lambda (U) (cons 10 U)) group) 
    ) 
  ) 
  (setq ss (ssget "L"))                        ;用刚刚生成的图形创造一个选择集合ss 
  (setq d (/ b 29.0)) 
  (entmakex 
    (list '(0 . "line") 
          (cons 10 (list 0 d)) 
          (cons 11 (list a d)) 
    ) 
  ) 
  (ssadd (entlast) ss) 
  (setq        L     (/ a 5) 
        U     (list L 0) 
        i     1 
        group nil 
 
  ) 
  (repeat 4 
    (entmakex 
      (list '(0 . "line") 
            (cons 10 (list (* L i) 0)) 
            (cons 11 (list (* L i) d)) 
      ) 
    ) 
    (ssadd (entlast) ss) 
    (setq U        (list (* L (- i 1)) (* 0.1 d)) 
          group        (cons U group) 
    ) 
    (setq i (+ i 1)) 
  ) 
  (setq        U     (list (* L (- i 1)) (* 0.1 d)) 
        group (cons U group) 
        group (reverse group) 
  ) 
  (setq        group_string 
         (list "项目名称:" "设计单位:" "监理单位:" "施工单位:" 
               "制图人:ashleytgg") 
  ) 
  (setq i 0) 
  (repeat 5 
    (entmake 
      (list '(0 . "TEXT") 
            (append '(10) (nth i group)) ;第一对齐点（在 OCS 中） 
            (cons 40 (* d 0.65))        ; 文字高度   
            (cons '1 (nth i group_string)) ; 内容 
      ) 
    ) 
    (ssadd (entlast) ss) 
    (setq i (+ i 1)) 
  ) 
  (if (not name) 
    (setq name "tang") 
  ) 
  (emkblk ss U_insert name) 
)                                        ;  make_drawing_frame  函数结束 
;;   (setq U_insert  (getpoint "输入插入点:"))   ( make_drawing_frame  600  U_insert  "tang"  )    
 
 
 
 
 
 
;; 绘图用函数函数结束 88888    绘图用函数函数结束88888     绘图用函数函数结束88888    绘图用函数函数结束88888    绘图用函数函数结束88888   绘图用函数函数结束    
 
 
 
 
 
 
;; dcl 使用函数  888888888888888888        dcl 使用函数  888888888888888888  dcl 使用函数  888888888888888888dcl   使用函数  888888888888888888    dcl 使用函数  888888888888888888 
 
 
(defun Dcl_write (lst / dcl_file str file) 
  (vl-load-com) 
  (setq dcl_file (vl-filename-mktemp nil nil ".dcl")) 
  (setq file (open dcl_file "w")) 
  (foreach str lst (write-line str file)) 
  (close file) 
  (setq id (load_dialog dcl_file)) 
) 
 
(defun C:use_dcl (/                      id 
                  sdt                      group_vertical_curve 
                  group_vertical_curve_2 
                  parameter              list_key 
                  list_key_2              list_key_3 
                  U                      group 
                  group_JD_list              group_JD_plane 
                  group_JD_Width      group_JD_slope 
                  group_vertical_segments 
                  mold                      group_turning_point 
                  group_Line_segments group_widen 
                  group_superelevation 
                  stake_mark_group    Z_Δ 
                  Z_continue              group_z_str 
                 ) 
  (setq        string_dcl 
         '("JD_item:list_box{  key="JD_list"; label="交点参数表："; value=0;" 
           "list=" ( 转点号  转点状态nil) 转点坐标  ( Lh1 R  Lh2  ) \\n ( 转点号  转点状态t) 转点坐标 (R_start R R_end  Lh1 Lh2 )";" 
           "fixed_width=true; width=100; allow_accept=true;}" 
           "table_wide :list_box{  key="table_wide";  value=0;" 
           "list=" 交点号  交点加宽值 ";" 
           "allow_accept=true;}" 
           "scfg:toggle{  label="曲线加宽方式,选中为直线加宽,不选一般加宽";  key="scfg";}" 
           "Z_road_start :edit_box {label="起点桩号:";  key= "Z_road_start";value="0";allow_accept=true;is_enabled=false;}" 
           "insert_table_J :button {label="请选择交点参数列表:";  key= "insert_table_J"; fixed_width=true;width=20; }" 
           "insert_table_W :button {label="请选择加宽参数列表:";  key= "insert_table_W"; fixed_width=true;width=20; }" 
           "JD_item_vertical:list_box{  key="JD_list_vertical"; label="竖曲线交点参数表："; value=0;" 
           "list=" ( 转点号  转点桩号 转点高程  转点半径 )    ";" 
           "fixed_width=true;width=100;" 
           "allow_accept=true;}" 
           "insert_table_J_V :button {label="请选择竖曲线交点参数列表:";  key= "insert_table_J_V";  fixed_width=true;width=10;   }" 
           "display :button {label="显示竖曲线、平面曲线交点参数:";  key= "display";  fixed_width=true;width=10;   }" 
           "N_x :edit_box {label="N(X):";  key= "N_x";value="0";allow_accept=true;}" 
           "E_Y :edit_box {label="E(Y):";  key= "E_Y";value="0";allow_accept=true;}" 
           "insert_point : button {label="请选择插入点:";  key= "insert_point";  fixed_width=true;width=20;} " 
           "road_wide :edit_box {label="请选择路面宽度:(不包括土路肩):";  key= "road_wide";value="5.0";allow_accept=true;}" 
           "frame_wide :edit_box {label="请选择设计图框的宽度:";  key= "frame_wide";value="297";allow_accept=true;}" 
           "Z_Δ :edit_box {label="请选择桩号的间距:";  key= "Z_Δ";value="5";allow_accept=true;}" 
           "table_superelevation :list_box{  key="table_superelevation";  value=0;" 
           "list=" 交点号  交点超高值 ";" 
           "allow_accept=true;}" 
           "insert_table_slope :button {label="请选择超高参数列表:";  key= "insert_table_slope"; fixed_width=true;width=20; }" 
           "table_Z :list_box{  key="table_Z";  value=0;" 
           "list="设计桩号列表\\n 设计桩号列表2";" 
           "allow_accept=true;is_enabled=false;}" 
           "stake_Z :button {label="选择设计桩号列表";  key= "stake_Z";   fixed_width=true;width=8;is_enabled=false;}" 
           "draw_table :button {label="绘制CAD表格";  key= "draw_table";   fixed_width=true;width=8;is_enabled=true;}" 
           "draw_excel :button {label="绘制EXCEL表格";  key= "draw_excel";   fixed_width=true;width=8;is_enabled=true;}" 
           "draw_standard_section:" 
           "dialog{  label="绘制公路标准断面";  spacer;" 
           "fixed_width=true;width=120;" 
           ": boxed_row  {JD_item;" 
           ": column {" 
           "insert_table_J;" 
           ":text{label="请填入线路起点桩号:";}" 
           "Z_road_start ;" 
           "}" 
           "}" 
           ": boxed_row  {JD_item_vertical;" 
           ": column {  fixed_width=true;width=10;" 
           ": column { insert_table_J_V ;display ; }" 
           "}" 
           "}" 
           ": boxed_row  {" 
           ": boxed_column   { fixed_width=true;width=30;" 
           "label="交点加宽参数参数表:";" 
           "table_wide ;" 
           ": column { scfg ; insert_table_W ; }" 
           "}" 
           ": boxed_column   { fixed_width=true;width=40;" 
           "label="交点超高参数参数表:";" 
           "table_superelevation ;" 
           "insert_table_slope;" 
           "}" 
           ": boxed_column   { fixed_width=true;width=40;" 
           "label="设计桩号列表";" 
           "table_Z;" 
           "stake_Z;" 
           "}" 
           "}" 
           ": boxed_row   {" 
           ": boxed_column  { fixed_width=true;width=30;" 
           "N_x ;  E_Y;insert_point;" 
           "}" 
           ":  boxed_column    {fixed_width=true;width=30; road_wide ; frame_wide;Z_Δ; }" 
           ":  boxed_column    {fixed_width=true;width=20;" 
           ":text{label="选择桩号形式";key="Z_txt";}" 
           ":boxed_radio_column {:radio_button { key="z_con"; label="连续桩号";value=1;}" 
           ":radio_button  { key="z_desi"; label="设计桩号";}" 
           "}" 
           "}" 
           ":  boxed_column {" 
           "draw_excel;" 
           ": button {label="输出cass横断面";key="draw_cass";is_default=true;fixed_width=true;width=12;}" 
           "}" 
           ":  boxed_column {" 
           ": button {label="绘制横断面";key="ok";is_default=true;fixed_width=true;width=12;}" 
           "draw_table;" 
           ": button {label="退出";key="cancel";is_cancel=true;fixed_width=true;width=12;}" 
           "}" 
           "}" 
           "}" 
           "vertical_segments :list_box{  key="vertical_segments";  value=0;" 
           "list="( 转点号I j)Z_start Z_end  起点高程  线元起点象限角  R  转角Δ) ";" 
           "allow_accept=true;}" 
           "Line_segments :list_box{  key="Line_segments";value=0;" 
           "list="( 转点号I j) 起点半径 终点半径  曲线长度  偏转系数  线元起点方位角  起点桩号  起点坐标 ) ";" 
           "allow_accept=true;}" 
           "display_calculate_message:" 
           "dialog{  label="显示计算信息";  spacer;" 
           "fixed_width=true;width=140;" 
           ":boxed_column{  label="线元参数参数表：";  Line_segments ;}" 
           ":boxed_column{  label="竖曲线线元参数表：";  vertical_segments  ;}" 
           ": boxed_row    {" 
           ": button {label="退出";key="cancel";is_cancel=true;fixed_width=true;width=12;}" 
           ": button {label="返回原界面";key="accept";is_default=true;fixed_width=true;width=12;}" 
           "}" 
           "}" 
          ) 
  ) 
 
  (if nil 
    (setq ID 
           (load_dialog 
             "D:\\工作文件\\新建文件夹\\work\\公路曲线简易程序\\用变换群绘制公路曲线\\绘制标准断面\\绘制标准断面" 
           ) 
    ) 
    (progn 
      (Dcl_write string_dcl) 
      (setq string_dcl nil) 
    ) 
  ) 
  (setq        sdt           1 
        list_key   (list "JD_list"           "Z_road_start" 
                         "JD_list_vertical" 
                         "table_wide"           "scfg" 
                         "table_superelevation" 
                         "road_wide"           "frame_wide" 
                         "Z_Δ"                   "z_con" 
                         "z_desi"           "table_Z" 
                         "N_x"                   "E_Y" 
                        ) 
        list_key_2 (list "table_Z" "stake_Z") 
        list_key_3 (list "Z_Δ") 
  ) 
  (while (>= sdt 0) 
    (if        (< sdt 10) 
      (progn 
        (if (not (new_dialog "draw_standard_section" id)) 
          (exit) 
        ) 
        ;; 对对对话框中的参数进行重新设置   
        (if (or (= sdt 3) (= sdt 6)) 
          (progn 
            (if        (or group_JD_plane        group_JD_list 
                    group_JD_Width        group_JD_slope 
                    group_z_str 
                   ) 
              (progn 
                (start_list "JD_list" 3) 
                (mapcar 'add_list group_JD_plane) 
                (end_list) 
                (start_list "JD_list_vertical" 3) 
                (mapcar 'add_list group_JD_list) 
                (end_list) 
                (start_list "table_wide" 3) 
                (mapcar 'add_list group_JD_Width) 
                (end_list) 
                (start_list "table_superelevation" 3) 
                (mapcar 'add_list group_JD_slope) 
                (end_list) 
                (start_list "table_Z" 3) ; 把原先列表去掉，换成新的 
                (mapcar 'add_list group_z_str) 
                (end_list) 
              ) 
            ) 
            (set_inform_dialog parameter list_key) 
            (if        (and (= (get_tile "z_con") "0") 
                     (= (get_tile "z_desi") "1") 
                ) 
              (progn 
                (mode_value 0 list_key_2) 
                (mode_value 1 list_key_3) 
              ) 
              (progn 
                (mode_value 1 list_key_2) 
                (mode_value 0 list_key_3) 
              ) 
            ) 
          ) 
        ) 
        (action_tile 
          "cancel" 
          "(done_dialog -2 )" 
        ) 
        (action_tile                        ; 竖曲线交点参数 插入表格的动作函数    
          "insert_table_J_V" 
          "(action_insert_table_J_V)" 
        ) 
        (action_tile                        ; 平面曲线交点参数 插入表格的动作函数   
          "insert_table_J" 
          "(action_insert_table_J) 
          (action_calculate \t group_turning_point) 
           (setq parameter(get_inform_dialog \t list_key)) 
          " 
        ) 
        (action_tile                        ; 平面曲线交点的加宽参数插入的动作函数   
          "insert_table_W" 
          "(action_insert_table_W)" 
        ) 
        (action_tile 
          "insert_point" 
          "(setq parameter(get_inform_dialog \t list_key))(done_dialog 3 )" 
        ) 
        (action_tile                        ; 绘制标准断面   
          "ok" 
          "(setq parameter(get_inform_dialog \t list_key))(done_dialog -8 )" 
        ) 
        (action_tile 
          "display" 
          "(setq parameter(get_inform_dialog \t list_key)) (done_dialog 18 )" 
        ) 
 
        (action_tile                        ;交点的超高参数插入的动作函数   
          "insert_table_slope" 
          "(action_insert_table_slope)" 
        ) 
        (action_tile 
          "z_con" 
          "(set_tile "Z_txt"  "连续桩号") 
          ( mode_value  1  \t  list_key_2 ) 
          ( mode_value  0  \t  list_key_3 ) 
          " 
        ) 
        (action_tile 
          "z_desi" 
          "(set_tile "Z_txt"  "设计桩号") 
          ( mode_value  0  \t  list_key_2 ) 
          ( mode_value  1  \t  list_key_3 )" 
        ) 
        (action_tile                        ;设计桩号参数的动作函数   
          "stake_Z" 
          "(setq stake_mark_group (action_stake_Z ))" 
        ) 
        (action_tile 
          "draw_table" 
          "(setq parameter(get_inform_dialog \t list_key))(done_dialog -9 )" 
        ) 
        (action_tile 
          "draw_excel" 
          "(setq parameter(get_inform_dialog \t list_key))(done_dialog -12 )" 
        ) 
        (action_tile 
          "draw_cass" 
          "(setq parameter(get_inform_dialog \t list_key))(done_dialog -13 )" 
        ) 
 
        (setq sdt (start_dialog)) 
      ) 
    )                                        ; (if (< sdt 10) 函数结束 
    (if        (>= sdt 10) 
      (progn 
        (if (not (new_dialog "display_calculate_message" id)) 
          (exit) 
        ) 
        (action_display group_vertical_segments group_Line_segments) 
        (action_tile 
          "accept" 
          "(done_dialog 6 )" 
        ) 
        (action_tile 
          "cancel" 
          "(done_dialog -2 )" 
        ) 
        (setq sdt (start_dialog)) 
      ) 
    )                                        ; (if (>= sdt 10) 函数结束 
    (if        (= sdt 3) 
      (setq u              (getpoint "请选择插入点:") 
            U              (list (cadr U) (car U)) 
            U              (mapcar 'rtos U) 
            parameter 
                      (mapcar '(lambda (i) 
                                 (nth i parameter) 
                               ) 
                              (list 0 1 2 3 4 5 6 7 8 9 10 11) 
                      ) 
            parameter (append parameter U) 
            parameter 
                      (mapcar '(lambda (i) 
                                 (nth i parameter) 
                               ) 
                              (list 0 1 2 3 4 5 6 7 8 9 10 11 12 13) 
                      ) 
      ) 
    )                                        ; (if        (= sdt 3) 函数结束   
  )                                        ; (while (> sdt 0) 函数结束   
 
 
  (unload_dialog id) 
  (if (= sdt -8) 
    (progn 
      ;; lst 结构为 mold   "N_x"  "E_Y"  "road_wide" "frame_wide" "Z_Δ"   "z_con" 
      (setq lst               (mapcar '(lambda        (i) 
                                  (nth i parameter) 
                                ) 
                               (list 12 13 6 7 8) 
                       ) 
            lst               (mapcar 'atof lst) 
            U_insert   (list (cadr lst) (car lst)) 
            road_wide  (caddr lst) 
            frame_wide (nth 3 lst) 
            Z_Δ       (nth 4 lst)        ;桩号增加值 
            lst               (mapcar '(lambda        (i) 
                                  (atoi (nth i parameter)) 
                                ) 
                               (list 4 9) 
                       ) 
            mold       (car lst) 
            Z_continue (cadr lst)        ; 表示连续或设计桩号的状态值 
      ) 
      (setq lst        (mapcar 'read parameter) 
            lst        (mapcar        '(lambda (i) 
                           (nth i lst) 
                         ) 
                        (list 12 13 6 7 8 4 9) 
                ) 
            lst        (mapcar 'numberp lst) 
      ) 
      (if (not (apply 'and lst)) 
        (progn 
          (alert "您输入了内容格式不对！") 
          (exit) 
        ) 
      ) 
      (if group_Line_segments 
        (progn 
          (create_group_data_out 
            group_Line_segments        group_widen 
            group_vertical_curve_2                    group_superelevation 
            road_wide                frame_wide            U_insert 
            mold                Z_Δ                    stake_mark_group 
            Z_continue 
           )                                ; mold 为加宽方式 
        ) 
        (alert "您还没有输入完整的线路参数!") 
      ) 
    ) 
  )                                        ;  (if (= sdt 8) 函数结束 
  (if (= sdt -9) 
    (progn 
      ;; lst 结构为 mold   "N_x"  "E_Y"     "Z_Δ"    
      (setq lst               (mapcar '(lambda        (i) 
                                  (nth i parameter) 
                                ) 
                               (list 12 13 8) 
                       ) 
            lst               (mapcar 'atof lst) 
            U_insert   (list (cadr lst) (car lst)) 
            Z_Δ       (caddr lst)        ;桩号增加值 
            ;;  lst 结构为   "scfg"  "z_con"    
            lst               (mapcar '(lambda        (i) 
                                  (atoi (nth i parameter)) 
                                ) 
                               (list 4 9) 
                       ) 
            mold       (car lst) 
            Z_continue (cadr lst)        ; 表示连续或设计桩号的状态值 
      ) 
      (if group_Line_segments 
        (progn 
          (create_table_data_out 
            group_Line_segments          group_widen 
            group_vertical_curve_2 
            group_superelevation  U_insert 
            mold                  Z_Δ 
            stake_mark_group          Z_continue 
           ) 
        ) 
        (alert "您还没有输入完整的线路参数!") 
      ) 
    ) 
  )                                        ;  (if (= sdt -9) 函数结束 
  (if (= sdt -12) 
    (progn 
      ;; lst 结构为 mold   "N_x"  "E_Y"     "Z_Δ"    
      (setq lst               (mapcar '(lambda        (i) 
                                  (nth i parameter) 
                                ) 
                               (list 12 13 8) 
                       ) 
            lst               (mapcar 'atof lst) 
            Z_Δ       (caddr lst)        ;桩号增加值 
            ;;  lst 结构为   "scfg"  "z_con"    
            lst               (mapcar '(lambda        (i) 
                                  (atoi (nth i parameter)) 
                                ) 
                               (list 4 9) 
                       ) 
            mold       (car lst) 
            Z_continue (cadr lst)        ; 表示连续或设计桩号的状态值 
      ) 
      (if group_Line_segments 
        (progn 
          (create_excel_data_out 
            group_Line_segments          group_widen 
            group_vertical_curve_2 
            group_superelevation  mold 
            Z_Δ                  stake_mark_group 
            Z_continue 
           ) 
        ) 
        (alert "您还没有输入完整的线路参数!") 
      ) 
    ) 
  )                                        ;  (if (= sdt -12) 函数结束 
  (if (= sdt -13) 
    (progn 
      (setq lst               (mapcar '(lambda        (i) 
                                  (nth i parameter) 
                                ) 
                               (list 3 13 8) 
                       ) 
            lst               (mapcar 'atof lst) 
            Z_Δ       (caddr lst)        ;桩号增加值 
            road_wide  (car lst) 
 
            ;;  lst 结构为   "scfg"  "z_con"    
            lst               (mapcar '(lambda        (i) 
                                  (atoi (nth i parameter)) 
                                ) 
                               (list 4 9) 
                       ) 
            mold       (car lst) 
            Z_continue (cadr lst)        ; 表示连续或设计桩号的状态值 
      ) 
      (if group_Line_segments 
        (progn 
          (create_cass_data_out 
            group_Line_segments          group_widen 
            group_vertical_curve_2 
            group_superelevation  mold 
            Z_Δ                  stake_mark_group 
            Z_continue                  road_wide 
           ) 
        ) 
        (alert "您还没有输入完整的线路参数!") 
      ) 
    ) 
  )                                        ;  (if (= sdt -13) 函数结束    
) 
 
 
;; 定义"insert_table_J_V" 按钮的动作 
(defun action_insert_table_J_V 
                               (/ lst n group) 
  (setq group_vertical_curve (create_group_vertical_curve)) 
  (setq        group_vertical_curve_2 
         (create_group_vertical_curve_2 
           group_vertical_curve 
         ) 
  ) 
  (setq n (length group_vertical_curve)) 
  (setq        group_JD_list 
         (mapcar '(lambda (lst) 
                    (apply '(lambda (JD Z h R) 
                              (strcat "JD: " 
                                      (itoa JD) 
                                      "   转点桩号:" 
                                      (rtos Z 2 3) 
                                      "   转点高程:" 
                                      (rtos h 2 2) 
                                      "   转点半径:" 
                                      (rtos R 2 2) 
                              ) 
                            ) 
                           lst 
                    ) 
                  ) 
                 group_vertical_curve 
         ) 
  ) 
  (setq        group_vertical_segments 
         (mapcar '(lambda (lst                ; (setq lst ( nth 5 group_vertical_curve_2 ) )    
                           / lst2 lst3 element i j) 
                    (setq lst2          (mapcar '(lambda (i) 
                                             (rtos (nth i lst) 2 2) 
                                           ) 
                                          (list 1 2 3 5) 
                                  ) 
                          lst3          (mapcar '(lambda (i) 
                                             (angtos (nth i lst) 1 6) 
                                           ) 
                                          (list 4 6) 
                                  ) 
                          element (car lst) ; 对第一个元素进行处理   
                          i          (itoa (car element)) 
                          j          (itoa (cadr element)) 
                          element (strcat i "-" j) 
                          lst          (append (list element) lst2 lst3) 
                                        ; lst 顺序为 (list 0 1 2 3 5 4 6 )   
                          ;; 对lst 进行逆置换, 对 (list 0  1 2 3 5 4 6 )  用 (list 0 1 2 3  5 4 6 ) 置换    
                          lst          (mapcar '(lambda (i) 
                                             (nth i lst) 
                                           ) 
                                          (list 0 1 2 3 5 4 6) 
                                  ) 
                    ) 
                    ;; 对lst数组进行注释 
                    (setq 
                      lst2 (list "JD:"            "Z_start:" "Z_end:" 
                                 "H:"            "α0:"     "R:" 
                                 "α_Δ:" 
                                ) 
                      lst  (append lst lst2) 
                      lst  (mapcar '(lambda (i) 
                                      (nth i lst) 
                                    ) 
                                   (list 7 0 8 1 9 2 10 3 11 4 12 5 13 6) 
                           ) 
                    ) 
                    (setq lst (vl-princ-to-string lst) 
                          lst (vl-string-left-trim "\(" lst) 
                          lst (vl-string-right-trim "\)" lst) 
                    ) 
                  ) 
                 group_vertical_curve_2 
         ) 
  ) 
  (start_list "JD_list_vertical" 3) 
  (mapcar 'add_list group_JD_list) 
  (end_list) 
  (set_tile "JD_list_vertical" (itoa n)) 
) 
 
 
 
;; 用参数parameter 对控件集合list_key 进行参数重置 
(defun set_inform_dialog 
                         (parameter list_key / i lst) 
  (setq i 0) 
  (mapcar '(lambda (x / str) 
             (setq str (nth i parameter)) 
             (set_tile x str) 
             (setq i (+ 1 i)) 
           ) 
          list_key 
  ) 
) 
;;( set_inform_dialog  parameter  list_key )      
 
;;获取控件集合list_key 的参数parameter    
(defun get_inform_dialog 
                         (list_key / lst) 
  (mapcar '(lambda (x) (get_tile x)) 
          list_key 
  ) 
) 
 
;; 定义平面曲线插入交点文件按钮的函数      
(defun action_insert_table_J (/ lst group Z_road_start) 
  (setq 
    lst        (create_turning_point_group_original) 
    group_turning_point_original 
     (car lst) 
    Z_road_start 
     (rtos (cadr lst)) 
  ) 
  (setq        lst                    (create_turning_point_group 
                              group_turning_point_original 
                              Z_road_start 
                            )                ; Z_road_start 在此程序中不变   
        group_turning_point (car lst) 
  ) 
  ;; 用group_turning_point 数组分别对列表框 "JD_list"    
  (setq        group 
         (mapcar 
           '(lambda (lst / state subset_label) 
              (apply '(lambda (x_0 x_1 x_2 x_3) 
                        (setq x_1 (mapcar 'rtos x_1) 
                              x_1 (list "N:" (cadr x_1) " E:" (car x_1)) 
                              x_1 (apply 'strcat x_1) 
                        ) 
                        (if (cadr x_0) 
                          (progn 
                            (setq state "Yes") 
                            (setq 
                              x_2 (apply '(lambda (y_0 y_1 y_2 y_3 y_4) 
                                            (setq subset_label (list "R_s" 
                                                                     "R" 
                                                                     "R_e" 
                                                                     "Lh1" 
                                                                     "Lh2") 
                                                  subset       (list y_0 y_1 y_2 y_3 y_4) 
                                                  subset       (append subset subset_label) 
                                            ) 
                                            (mapcar '(lambda (i) 
                                                       (nth i subset) 
                                                     ) 
                                                    (list 5 0 6 1 7 2 8 3 9 4) 
                                            ) 
                                          ) 
                                         x_2 
                                  ) 
                            ) 
                          ) 
                          (progn 
                            (setq state "No") 
                            (setq x_2 (apply '(lambda (y_0 y_1 y_2) 
                                                (setq subset_label (list "Lh1" "R" "Lh2") 
                                                      subset           (list y_0 y_1 y_2) 
                                                      subset           (append subset subset_label) 
                                                ) 
                                                (mapcar        '(lambda (i) 
                                                           (nth i subset) 
                                                         ) 
                                                        (list 3 0 4 1 5 2) 
                                                ) 
                                              ) 
                                             x_2 
                                      ) 
                            ) 
                          ) 
                        )                ; (if (cadr x_0) 函数结束 
                        (setq x_2 (vl-princ-to-string x_2) 
                              x_2 (vl-string-left-trim "\(" x_2) 
                              x_2 (vl-string-right-trim "\)" x_2) 
                        ) 
                        (list "JD:" (car x_0) state x_1 x_2) 
                      ) 
                     lst 
              ) 
            ) 
           group_turning_point 
         ) 
  ) 
  (setq        group_JD_plane 
         (mapcar '(lambda (lst / string) 
                    (setq string (vl-princ-to-string lst) 
                          string (vl-string-left-trim "\(" string) 
                          string (vl-string-right-trim "\)" string) 
                    ) 
                  ) 
                 group 
         ) 
  ) 
 
  (start_list "JD_list" 3) 
  (mapcar 'add_list group_JD_plane) 
  (end_list) 
  ;;用Z_road_start 对编辑框"Z_road_start" 进行填充 
  (set_tile "Z_road_start" Z_road_start) 
 
)                                        ;   action_insert_table_J 函数结束 
 
 
 
 
 
(defun action_insert_table_W (/ lst group) 
  (setq group_widen (write_into_group_widen)) 
  ;; 用group_widen 数组分别对列表框 "table_wide" 进行填充   
  (setq        group_JD_Width 
         (mapcar '(lambda (lst 
                           / 
                           JD 
                           W 
                          ) 
                    (setq JD (itoa (car lst)) 
                          W  (rtos (cadr lst) 2 3) 
                    ) 
                    (strcat "JD: " JD "  加宽:" W) 
 
                  ) 
                 group_widen 
         ) 
  ) 
  (start_list "table_wide" 3) 
  (mapcar 'add_list group_JD_Width) 
  (end_list) 
)                                        ;   action_insert_table_W 函数结束 
 
 
 
 
(defun action_calculate 
       (group_turning_point / lst group road_start group_sum n) 
  (setq        road_start (get_tile "Z_road_start") 
        road_start (read road_start) 
  ) 
  (if (not (numberp road_start)) 
    (progn 
      (alert "您输入的起止桩号不是实数！") 
      (exit) 
    ) 
  ) 
  (if group_turning_point 
    (setq 
      lst 
                          (create_group_Line_segments group_turning_point road_start) 
      group_Line_segments 
                          (car lst) 
    ) 
  ) 
)                                        ;   action_calculate 函数结束 
 
 
;; 显示按钮 display 的动作函数 
(defun action_display 
                      (group_vertical_segments 
                       group_Line_segments / 
                       n                   group 
                       group_sum 
                      ) 
  (if group_vertical_segments 
    (progn 
      (start_list "vertical_segments" 3) 
      (mapcar 'add_list group_vertical_segments) 
      (end_list) 
      (setq n (length group_vertical_curve_2)) 
      (set_tile "vertical_segments" (itoa n)) 
    ) 
  ) 
  (if group_Line_segments 
    (progn 
      (setq group_sum (apply 'append group_Line_segments)) 
      ;; 用 group_Line_segments 填充列表框 "Line_segments" 
      (setq group_sum 
             (mapcar                        ; (setq lst (car group_sum))  (setq x_7 ( nth 7  lst))    
               '(lambda        (lst / lenth lst_label) 
                  (apply '(lambda (x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7) 
                            (setq x_0 (mapcar 'itoa x_0) 
                                  x_0 (list (car x_0) "-" (cadr x_0)) 
                                  x_0 (apply 'strcat x_0) 
                            ) 
                            (setq x_7 (mapcar 'rtos x_7) 
                                  x_7 (list "N:" (cadr x_7) " E:" (car x_7)) 
                                  x_7 (apply 'strcat x_7) 
                            ) 
                            (setq 
                              x_6 (f_zhuanghao x_6) 
                            ) 
                            (if        (atom x_3) 
                              (setq lenth x_3) 
                              (setq lenth (car x_3)) 
                            ) 
                            (setq lenth        (* lenth 1.0) 
                                  x_3        (rtos lenth 2 2) 
                                  x_5        (+ (* x_5 -1) (/ pi 2)) 
                                        ; 把象限角变成方位角 
                                  x_5        (angtos x_5 1 6) 
                            ) 
                            ;; 对(list x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7 ) 进行标注 
                            (setq lst            (list x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7) 
                                  lst_label (list "R_s:" 
                                                  "R_e:" 
                                                  "lenth:" 
                                                  "reflex:" 
                                                  "α_s:" 
                                                 ) 
                                  lst            (append lst lst_label) 
                            ) 
                            ;;  lst顺序为 (0 1 2 3 4 5 6 7 8 9 10 11 12 ) 
                            (mapcar '(lambda (i) 
                                       (nth i lst) 
                                     ) 
                                    (list 0 8 1 9 2 10 3 11 4 12 5 6 7) 
                            ) 
                          ) 
                         lst 
                  ) 
                ) 
               group_sum 
             ) 
      ) 
      (setq group                        ; (setq lst (car group_sum ))   
             (mapcar '(lambda (lst / string) 
                        (setq string (vl-princ-to-string lst)) 
                        (setq string (vl-string-left-trim "\(" string) 
                              string (vl-string-right-trim "\)" string) 
                        ) 
                      ) 
                     group_sum 
             ) 
      ) 
      (start_list "Line_segments" 3) 
      (mapcar 'add_list group) 
      (end_list) 
    ) 
    ;; 当group_Line_segments  数组为空时 
    (progn 
      (start_list "Line_segments" 2) 
      (mapcar 'add_list 
              (list "group_Line_segments 交点数组为空!") 
      ) 
      (end_list) 
    ) 
  ) 
  (setq n (length group)) 
  (set_tile "Line_segments" (itoa n)) 
) 
;;  ( action_display  group_vertical_segments  group_Line_segments )   
 
 
 
;; 定义插入 交点超高参数 的动作函数    
(defun action_insert_table_slope (/ n) 
  (setq group_superelevation (create_group_superelevation)) 
  (setq        group_JD_slope 
         (mapcar '(lambda (lst / JD slope lst2 slope_back slope_front) 
                    (if        (= (length lst) 2) 
                      (setq JD          (itoa (car lst)) 
                            slope (rtos (cadr lst)) 
                            lst2  (strcat "JD: " JD " 超高值: " slope " %") 
                      ) 
                    ) 
                    (if        (= (length lst) 3) 
                      (setq JD                (itoa (car lst)) 
                            slope_bakc        (rtos (car (cadr lst))) 
                            slope        (rtos (cadr (cadr lst))) 
                            slope_front        (rtos (car (caddr lst))) 
                            lst2        (strcat        "JD: " 
                                                JD 
                                                " 超高开始值: " 
                                                slope_bakc 
                                                " %" 
                                                " 超高值: " 
                                                slope 
                                                " %" 
                                                " 超高结束值: " 
                                                slope_front 
                                                " %" 
                                               ) 
                      ) 
                    ) 
                    lst2 
                  ) 
                 group_superelevation 
         ) 
  ) 
  (start_list "table_superelevation" 3) 
  (mapcar 'add_list group_JD_slope) 
  (end_list) 
  (setq n (length group_JD_slope)) 
  (set_tile "table_superelevation" (itoa n)) 
) 
 
 
;;  对控件集合"table_Z" "stake_Z" "Z_txt" 进行参数设置   
(defun mode_value 
                  (value list_key / i lst) 
  (setq i 0) 
  (mapcar '(lambda (x) 
             (mode_tile x value) 
             (setq i (+ 1 i)) 
           ) 
          list_key                        ; (setq list_key  (list "table_Z" "stake_Z" "Z_Δ")  )    
  ) 
) 
;; ( mode_value  0   list_key )

绘制cass文件格式的程序

;;;*************函数 vlxls-app-init.lsp *************
;|Examples:
Excel Application Session Progress Function
Name
x2c
Usage
Import Microsoft Excel Type Library, set prefix of "msxl-" for all of the :methods-prefix; :properties-prefix
& :constants-prefix. This function can detect Excel’s installation path automatically from Windows registry so
that it can run smoothly on any language platform of Windows and Office.
Input
NONE
No Arguments
RetVal
True
BOOLEAN
msxlc-xl24HourClock
Fail
BOOLEAN
NIL
|;
(Defun vlxls-app-Init
(/ OSVar GGG Olb8 Olb9 Olb10 TLB Out msg msg1 msg2)
(if *Chinese*
(setq msg "\n 初始化微软Excel "
msg1 "\042初始化Excel错误\042"
msg2 (strcat
"\042 警告"
"\n ===="
"\n 无法在您的计算机上检测到微软Excel软件"
"\n 如果您确认已经安装Excel, 请发送电子邮"
"\n 件到kozmosovia@hotmail.com获取更多的解决方案\042"
)
)
(setq msg "\n Initializing Microsoft Excel "
msg1 "\042Initialization Error\042"
msg2 (strcat
"\042 WARNING" "\n ======="
"\n Can NOT detect Excel97/200X/XP in your computer"
"\n If you already have Excel installed, please email"
"\n us to get more solution via GuXiaolin@hxch.com.cn\042")
)
)
(if (null msxlc-xl24HourClock)
(progn
(if (and (setq GGG
(vl-registry-read
"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\Excel.EXE"
"Path"
)
)
(setq GGG (strcase (strcat GGG "Excel.EXE")))
)
(progn
;; 当发现windows表中有excel 注册程序时
(foreach OSVar (list "SYSTEMROOT" "WINDIR"
"WINBOOTDIR" "SYSTEMDRIVE"
"USERNAME" "COMPUTERNAME"
"HOMEDRIVE" "HOMEPATH"
"PROGRAMFILES"
)
;; (setq OSVar "SYSTEMROOT" )
(if (vl-string-search (strcat "%" OSVar "%") GGG)
(setq GGG (vl-string-subst
(strcase (getenv OSVar))
(strcat "%" OSVar "%")
GGG
)
)
)
) ;(foreach OSVar (list "SYSTEMROOT" "WINDIR" 函数结束
(setq Olb8 (findfile
(vl-string-subst "EXCEL8.OLB" "EXCEL.EXE" GGG)
)
Olb9 (findfile
(vl-string-subst "EXCEL9.OLB" "EXCEL.EXE" GGG)
)
Olb10 (findfile (vl-string-subst
"EXCEL10.OLB"
"EXCEL.EXE"
GGG
)
)
)
(cond
((= (vl-filename-base (vl-filename-directory GGG))
"OFFICE15"
)
(setq TLB GGG
Out "2013"
)
)
((= (vl-filename-base (vl-filename-directory GGG))
"OFFICE14"
)
(setq TLB GGG
Out "2010"
)
)
((= (vl-filename-base (vl-filename-directory GGG))
"OFFICE12"
)
(setq TLB GGG
Out "2007"
)
)
((= (vl-filename-base (vl-filename-directory GGG))
"OFFICE11"
)
(setq TLB GGG
Out "2003"
)
)
((= (vl-filename-base (vl-filename-directory GGG))
"OFFICE10"
)
(setq TLB GGG
Out "XP"
)
)
(Olb9
(setq TLB Olb9
Out "2000"
)
)
(Olb8
(setq TLB Olb8
Out "97"
)
)
(t
(setq TLB GGG
Out "Version Unknown"
)
)
)
(if TLB
(progn
;; 当前我的电脑 out为"2010" ，TLB 为
;; "C:\\PROGRAM FILES\\MICROSOFT OFFICE\\OFFICE14\\EXCEL.EXE"
(princ (strcat MSG Out "..."))
(vlax-import-type-library
:tlb-filename TLB
:methods-prefix "msxl-"
:properties-prefix "msxlp-"
:constants-prefix "msxlc-"
)
)
)
)
;; 当电脑中没有安装excel 程序时
(progn
;|(if vldcl-msgbox
(vldcl-msgbox "x" msg1 msg2)
(alert (read msg2))
)|;
(alert msg2)
(exit)
)
;;(if (and (setq GGG (vl-registry-read 函数结束
)
;; (if (null msxlc-xl24HourClock)中的progn 函数结束
)
) ; (if (null msxlc-xl24HourClock) 函数结束
msxlc-xl24HourClock
)
;;;***************** 函数 vlxls-app-Init*****************
;; (vlxls-app-Init )
(Defun vlxls-app-New (UnHide / Rtn)
;;; 該程序實現功能:新建一個excel格
;;; THIS PROGRAM CAN BUILD A NEW EXCELFILE
(if (vlxls-app-init)
(progn
(if *Chinese*
(princ "\n 新建微軟Excel工作表...")
(princ "\n Creating new Excel Spreadsheet file...")
)
(if (setq Rtn (vlax-get-or-create-object "Excel.Application"))
(progn
(vlax-invoke-method (vlax-get-property Rtn 'WorkBooks) 'Add)
(if UnHide
(vla-put-visible Rtn 1)
(vla-put-visible Rtn 0)
)
)
) ;if (setq Rtn 函数结束
)
)
Rtn
)
;;;Examples:
;; (setq xlapp (vlxls-app-new T))
;; cell id 轉換
(Defun vlxls-cellid (id / xx id1 id2 Rtn)
(if (= (type id) 'list)
(setq id (vlxls-rangeid id))
)
(setq id (strcase id))
(if (null (setq xx (vl-string-search ":" id)))
(setq Rtn (list id ""))
(setq id1 (substr id 1 xx)
id2 (substr id (+ xx 2))
id1 (vlxls-rangeid id1)
id2 (vlxls-rangeid id2)
Rtn (list (vlxls-rangeid
(list (min (car id1) (car id2))
(min (cadr id1) (cadr id2))
)
)
(vlxls-rangeid
(list (max (car id1) (car id2))
(max (cadr id1) (cadr id2))
)
)
)
)
)
Rtn
)
;;;Examples:
;|
(vlxls-cellid '(3 14)) ; return: ("C14" "")
(vlxls-cellid "D23") ; return: ("D23" "")
(vlxls-cellid "C12:F3") ;return: ("C3" "F12")
(vlxls-cellid "F15:G22") ;return: ("F15" "G22")
|;
;;;range id 轉換
(Defun vlxls-rangeid (id / str->list list->str xid->str Rtn)
;; (setq str "DD23")
(Defun str->list1 (str / ii xk xv rr pos x y)
(setq rr (strlen str))
(foreach ii '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
;;;vl-string-search 在字符串中搜索指定子串, 返回值：整数，表示找到指定 pattern 的位置。若没有找到子串，则返回 nil。字符串第一个字符的位置为0
(if (setq pos (vl-string-search ii str))
(setq rr (min pos rr))
)
)
(setq x (substr str 1 rr) ; substr 第一元素为1 , 返回 "DD23" 中的文字部分 DD
y (substr str (1+ rr))
;; 返回"DD23" 中的"23"部分
)
(if (= (strlen x) 2) ;当x的字符串长度等于2时
(setq xk (- (ascii (substr x 1 1)) ; 返回 "DE23" 中的文字部分D
64
)
xv (- (ascii (substr x 2)) ; 返回 "DE23" 中的文字部分E
64
)
)
(setq xk 0
xv (- (ascii x) 64)
)
)
(list (+ (* xk 26) xv) (read y))
)
;; (setq IntNum 14)
(Defun xid->str (IntNum / PosNum Nm-One)
(setq Nm-One (1- IntNum)
PosNum (/ Nm-One 26)
)
;; (chr 65) 返回值'A'
(if (= PosNum 0)
(chr (+ 65 (rem Nm-One 26))) ; chr 把数字转换成ascill 字符串
;;当PosNum 大于0时
(strcat (chr (+ 64 PosNum)) ; 返回 "DE23" 中的文字部分D
(chr (+ 65
(rem Nm-One 26) ; 返回 "DE23" 中的文字部分E
)
)
)
)
)
;;注意idr中的 x必须是>=1
(Defun list->str1 (idr / x y)
(setq x (car idr)
y (cadr idr)
x (xid->str x)
y (itoa y)
)
(strcat x y)
)
(cond ((= (type id) 'str) (setq Rtn (str->list1 id)))
((= (type id) 'list) (setq Rtn (list->str1 id)))
)
Rtn
)
(Defun vlxls-cell-put-value
(xl id Data / vllist-explode idx xx yy ary Rtn)
(Defun vllist-explode1 (lst)
(cond ((not lst) nil)
((atom lst) (list lst))
((append (vllist-explode1 (car lst))
(vllist-explode1 (cdr lst))
)
)
)
)
(if (null id)
(setq id "A1")
)
(if (= (type id) 'list)
(setq id (vlxls-rangeid id))
)
(if (= (type (car Data)) 'LIST)
;; 当Data为列表时(list ("tang" "hong") ("tang100" "hong200") )
(setq ARY (vlax-make-safearray
vlax-vbstring
;; 第一维 0 至 (length Data) 减1 , 表示excel列表"A1:F12"的1--12项
(cons 0 (1- (length Data))) ; 创建点对 (a . b)
;; 第二维 1 至 Data 列表的每个元素的个数，表示excel列表"A1:F12"的A--F项
(cons 1 (length (car Data)))
) ; 创建二维 vlax-vbstring 数组 ARY (vlax-safearray->list ary)
XX (1- (length (car Data)))
YY (1- (length Data))
)
;; 当Data为单个元素时，(list"tang" "hong" "song" ) (vlax-make-safearray type '(l-bound . u-bound) ['(l-bound . u-bound)...)]
(setq ARY (vlax-make-safearray
vlax-vbstring
(cons 0 1)
(cons 1 (length Data))
)
XX (1- (length Data))
YY 0
)
)
(if (= xx yy 0)
(msxlp-put-value2 ; 当id 为excel表中的一个单元格时
(setq Rtn (msxlp-get-range xl id))
(car (vllist-explode1 data))
)
(progn
;; 把id从"C12" 变成 "C12:E13"形式
(setq id (vlxls-cellid-calc id xx yy))
(msxlp-put-value2
(setq Rtn (msxlp-get-range xl id))
(vlax-safearray-fill ary data)
)
)
) ; (if (= xx yy 0) 函数结束
Rtn
)

;;;*************函数 vlxls-app-init.lsp  ************* 
 
;|Examples: 
 
Excel Application Session Progress Function 
 
Name 
x2c 
 
Usage 
Import Microsoft Excel Type Library, set prefix of "msxl-" for all of the :methods-prefix; :properties-prefix 
& :constants-prefix. This function can detect Excel’s installation path automatically from Windows registry so 
that it can run smoothly on any language platform of Windows and Office. 
 
Input 
NONE 
No Arguments 
 
RetVal 
True 
BOOLEAN 
msxlc-xl24HourClock 
 
Fail 
BOOLEAN 
NIL 
|; 
(Defun vlxls-app-Init 
       (/ OSVar GGG Olb8 Olb9 Olb10 TLB Out msg msg1 msg2) 
  (if *Chinese* 
    (setq msg  "\n 初始化微软Excel " 
          msg1 "\042初始化Excel错误\042" 
          msg2 (strcat 
                 "\042 警告" 
                 "\n ====" 
                 "\n 无法在您的计算机上检测到微软Excel软件" 
                 "\n 如果您确认已经安装Excel, 请发送电子邮" 
                 "\n 件到kozmosovia@hotmail.com获取更多的解决方案\042" 
                ) 
    ) 
    (setq msg  "\n Initializing Microsoft Excel " 
          msg1 "\042Initialization Error\042" 
          msg2 (strcat 
                 "\042 WARNING"        "\n =======" 
                 "\n Can NOT detect Excel97/200X/XP in your computer" 
                 "\n If you already have Excel installed, please email" 
                 "\n us to get more solution via GuXiaolin@hxch.com.cn\042") 
    ) 
  ) 
  (if (null msxlc-xl24HourClock) 
    (progn 
      (if (and (setq GGG 
                      (vl-registry-read 
                        "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\Excel.EXE" 
                        "Path" 
                      ) 
               ) 
               (setq GGG (strcase (strcat GGG "Excel.EXE"))) 
          ) 
        (progn 
          ;; 当发现windows表中 有excel 注册程序时   
          (foreach OSVar (list "SYSTEMROOT"         "WINDIR" 
                               "WINBOOTDIR"         "SYSTEMDRIVE" 
                               "USERNAME"         "COMPUTERNAME" 
                               "HOMEDRIVE"         "HOMEPATH" 
                               "PROGRAMFILES" 
                              ) 
            ;; (setq OSVar "SYSTEMROOT" )   
            (if        (vl-string-search (strcat "%" OSVar "%") GGG) 
              (setq GGG        (vl-string-subst 
                          (strcase (getenv OSVar)) 
                          (strcat "%" OSVar "%") 
                          GGG 
                        ) 
              ) 
            ) 
          )                                ;(foreach OSVar (list "SYSTEMROOT"      "WINDIR" 函数结束   
          (setq        Olb8  (findfile 
                        (vl-string-subst "EXCEL8.OLB" "EXCEL.EXE" GGG) 
                      ) 
                Olb9  (findfile 
                        (vl-string-subst "EXCEL9.OLB" "EXCEL.EXE" GGG) 
                      ) 
                Olb10 (findfile        (vl-string-subst 
                                  "EXCEL10.OLB" 
                                  "EXCEL.EXE" 
                                  GGG 
                                ) 
                      ) 
          ) 
          (cond 
            ((=        (vl-filename-base (vl-filename-directory GGG)) 
                "OFFICE15" 
             ) 
             (setq TLB GGG 
                   Out "2013" 
             ) 
            ) 
            ((=        (vl-filename-base (vl-filename-directory GGG)) 
                "OFFICE14" 
             ) 
             (setq TLB GGG 
                   Out "2010" 
             ) 
            ) 
            ((=        (vl-filename-base (vl-filename-directory GGG)) 
                "OFFICE12" 
             ) 
             (setq TLB GGG 
                   Out "2007" 
             ) 
            ) 
            ((=        (vl-filename-base (vl-filename-directory GGG)) 
                "OFFICE11" 
             ) 
             (setq TLB GGG 
                   Out "2003" 
             ) 
            ) 
            ((=        (vl-filename-base (vl-filename-directory GGG)) 
                "OFFICE10" 
             ) 
             (setq TLB GGG 
                   Out "XP" 
             ) 
            ) 
            (Olb9 
             (setq TLB Olb9 
                   Out "2000" 
             ) 
            ) 
            (Olb8 
             (setq TLB Olb8 
                   Out "97" 
             ) 
            ) 
            (t 
             (setq TLB GGG 
                   Out "Version Unknown" 
             ) 
            ) 
          ) 
          (if TLB 
            (progn 
              ;; 当前我的电脑 out为"2010" ，TLB 为 
              ;; "C:\\PROGRAM FILES\\MICROSOFT OFFICE\\OFFICE14\\EXCEL.EXE" 
              (princ (strcat MSG Out "...")) 
              (vlax-import-type-library 
                :tlb-filename           TLB 
                :methods-prefix           "msxl-" 
                :properties-prefix "msxlp-" 
                :constants-prefix  "msxlc-" 
               ) 
            ) 
          ) 
        ) 
        ;; 当电脑中没有安装excel 程序时    
        (progn 
         ;|(if vldcl-msgbox 
            (vldcl-msgbox "x" msg1 msg2) 
            (alert (read msg2)) 
            )|; 
          (alert msg2) 
          (exit) 
        ) 
        ;;(if (and (setq GGG  (vl-registry-read 函数结束 
      ) 
      ;; (if (null msxlc-xl24HourClock)中的progn 函数结束 
    ) 
  )                                        ; (if (null msxlc-xl24HourClock) 函数结束 
  msxlc-xl24HourClock 
) 
;;;***************** 函数 vlxls-app-Init***************** 
;;  (vlxls-app-Init )   
(Defun vlxls-app-New (UnHide / Rtn) 
;;; 該程序實現功能:新建一個excel格 
;;; THIS PROGRAM CAN BUILD A NEW EXCELFILE 
  (if (vlxls-app-init) 
    (progn 
      (if *Chinese* 
        (princ "\n 新建微軟Excel工作表...") 
        (princ "\n Creating new Excel Spreadsheet file...") 
      ) 
      (if (setq Rtn (vlax-get-or-create-object "Excel.Application")) 
        (progn 
          (vlax-invoke-method (vlax-get-property Rtn 'WorkBooks) 'Add) 
          (if UnHide 
            (vla-put-visible Rtn 1) 
            (vla-put-visible Rtn 0) 
          ) 
        ) 
      )                                        ;if (setq Rtn 函数结束   
    ) 
  ) 
  Rtn 
) 
 
 
;;;Examples:    
;; (setq  xlapp  (vlxls-app-new T))      
;; cell id 轉換 
(Defun vlxls-cellid (id / xx id1 id2 Rtn) 
  (if (= (type id) 'list) 
    (setq id (vlxls-rangeid id)) 
  ) 
  (setq id (strcase id)) 
  (if (null (setq xx (vl-string-search ":" id))) 
    (setq Rtn (list id "")) 
    (setq id1 (substr id 1 xx) 
          id2 (substr id (+ xx 2)) 
          id1 (vlxls-rangeid id1) 
          id2 (vlxls-rangeid id2) 
          Rtn (list (vlxls-rangeid 
                      (list (min (car id1) (car id2)) 
                            (min (cadr id1) (cadr id2)) 
                      ) 
                    ) 
                    (vlxls-rangeid 
                      (list (max (car id1) (car id2)) 
                            (max (cadr id1) (cadr id2)) 
                      ) 
                    ) 
              ) 
    ) 
  ) 
  Rtn 
) 
 
 
;;;Examples: 
;| 
  (vlxls-cellid '(3 14)) ; return: ("C14" "") 
  (vlxls-cellid "D23")  ; return: ("D23" "") 
  (vlxls-cellid "C12:F3") ;return: ("C3" "F12") 
  (vlxls-cellid "F15:G22") ;return: ("F15" "G22") 
 
|; 
;;;range id 轉換 
(Defun vlxls-rangeid (id / str->list list->str xid->str Rtn) 
  ;; (setq str "DD23")    
  (Defun str->list1 (str / ii xk xv rr pos x y) 
    (setq rr (strlen str)) 
    (foreach ii        '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9") 
;;;vl-string-search 在字符串中搜索指定子串, 返回值：整数，表示找到指定 pattern 的位置。若没有找到子串，则返回 nil。字符串第一个字符的位置为0   
      (if (setq pos (vl-string-search ii str)) 
        (setq rr (min pos rr)) 
      ) 
    ) 
    (setq x (substr str 1 rr)                ; substr 第一元素为1 , 返回 "DD23" 中的文字部分 DD 
          y (substr str (1+ rr)) 
            ;;  返回"DD23" 中的"23"部分 
    ) 
    (if        (= (strlen x) 2)                ;当x的字符串长度等于2时    
      (setq xk (- (ascii (substr x 1 1)) ; 返回 "DE23" 中的文字部分D 
                  64 
               ) 
            xv (- (ascii (substr x 2))        ; 返回 "DE23" 中的文字部分E   
                  64 
               ) 
      ) 
      (setq xk 0 
            xv (- (ascii x) 64) 
      ) 
    ) 
    (list (+ (* xk 26) xv) (read y)) 
  ) 
 
  ;;  (setq IntNum 14)    
  (Defun xid->str (IntNum / PosNum Nm-One) 
    (setq Nm-One (1- IntNum) 
          PosNum (/ Nm-One 26) 
    ) 
    ;; (chr 65) 返回值'A'    
    (if        (= PosNum 0) 
      (chr (+ 65 (rem Nm-One 26)))        ; chr 把数字转换成ascill 字符串 
      ;;当PosNum 大于0时   
      (strcat (chr (+ 64 PosNum))        ; 返回 "DE23" 中的文字部分D 
              (chr (+ 65 
                      (rem Nm-One 26)        ; 返回 "DE23" 中的文字部分E 
                   ) 
              ) 
      ) 
    ) 
  ) 
  ;;注意idr中的 x必须是>=1      
  (Defun list->str1 (idr / x y) 
    (setq x (car idr) 
          y (cadr idr) 
          x (xid->str x) 
          y (itoa y) 
    ) 
    (strcat x y) 
  ) 
  (cond        ((= (type id) 'str) (setq Rtn (str->list1 id))) 
        ((= (type id) 'list) (setq Rtn (list->str1 id))) 
  ) 
  Rtn 
) 
 
(Defun vlxls-cell-put-value 
       (xl id Data / vllist-explode idx xx yy ary Rtn) 
  (Defun vllist-explode1 (lst) 
    (cond ((not lst) nil) 
          ((atom lst) (list lst)) 
          ((append (vllist-explode1 (car lst)) 
                   (vllist-explode1 (cdr lst)) 
           ) 
          ) 
    ) 
  ) 
 
  (if (null id) 
    (setq id "A1") 
  ) 
  (if (= (type id) 'list) 
    (setq id (vlxls-rangeid id)) 
  ) 
  (if (= (type (car Data)) 'LIST) 
    ;; 当Data为列表时(list ("tang" "hong")  ("tang100" "hong200") )    
    (setq ARY (vlax-make-safearray 
                vlax-vbstring 
                ;; 第一维 0 至 (length Data) 减1 ,  表示excel列表"A1:F12"的1--12项    
                (cons 0 (1- (length Data))) ; 创建点对  (a . b) 
                ;; 第二维 1 至 Data 列表的每个元素 的个数 ，表示excel列表"A1:F12"的A--F项    
                (cons 1 (length (car Data))) 
              )                                ; 创建二维 vlax-vbstring 数组 ARY  (vlax-safearray->list ary)    
          XX  (1- (length (car Data))) 
          YY  (1- (length Data)) 
    ) 
    ;; 当Data为单个元素时，(list"tang" "hong" "song"  )  (vlax-make-safearray type '(l-bound . u-bound) ['(l-bound . u-bound)...)]    
    (setq ARY (vlax-make-safearray 
                vlax-vbstring 
                (cons 0 1) 
                (cons 1 (length Data)) 
              ) 
          XX  (1- (length Data)) 
          YY  0 
    ) 
  ) 
  (if (= xx yy 0) 
    (msxlp-put-value2                        ; 当id 为excel表中的一个单元格时   
      (setq Rtn (msxlp-get-range xl id)) 
      (car (vllist-explode1 data)) 
    ) 
    (progn 
      ;; 把id从"C12" 变成 "C12:E13"形式   
      (setq id (vlxls-cellid-calc id xx yy)) 
      (msxlp-put-value2 
        (setq Rtn (msxlp-get-range xl id)) 
        (vlax-safearray-fill ary data) 
      ) 
    ) 
  )                                        ;  (if (= xx yy 0)  函数结束 
  Rtn 
)

ashleytgg · 发表于 2016-10-13 16:14:50

把还有一些代码补上

;;对一个二维点集合group_point 绕点center 旋转 ang 弧度
(defun rotate_group_point (group_point ang center / lst)
(setq group_point
(mapcar '(lambda (point)
(list (- (car point) (car center))
(- (cadr point) (cadr center))
)
)
group_point
)
)
(setq lst (list (list (cos ang) (* (sin ang) -1))
(list (sin ang) (cos ang))
)
)
(setq group_point
(mapcar '(lambda (point)
(apply '(lambda (element_1 element_2)
(list (+ (* (car element_1) (car point))
(* (cadr element_1) (cadr point))
)
(+ (* (car element_2) (car point))
(* (cadr element_2) (cadr point))
)
)
)
lst
)
)
group_point
)
)
(setq
group_point
(mapcar '(lambda (x)
(list (+ (car x) (car center))
(+ (cadr x) (cadr center))
)
)
group_point
)
)
)
;; 8888888888888888 88888888888888888888888 88888888888888888
;;定义一个队group_data_out 数组进行群变换的函数，group_data_out 结构为：(Z_桩号 U ang_象限角 )
;; 对点集合 group_point 首先进行镜像变换，然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度
(defun transformation_group_data_out
(group_data_out
reflex data_origin
data_insert /
group_point quadrant_ang
ang_Δ ang
U_origin U_insert
group i
)
(setq group (append (list data_origin) group_data_out))
(if (= reflex -1)
(setq group
(mapcar '(lambda (lst / Z U ang)
(setq Z (car lst)
U (cadr lst)
ang (caddr lst)
)
(list Z
(list (car U)
(* (cadr U) -1)
)
(* ang -1)
)
)
group
)
)
) ; (if (= reflex -1) 函数结束
(setq data_origin (car group)
group_data_out (cdr group)
)
;; 对group_data_out 数组进行平移,使得原坐标系中的U_origin点，和实际线元的起点U_insert向符合
(setq U_origin (cadr data_origin)
U_insert (cadr data_insert)
)
(setq group_data_out
(mapcar '(lambda (lst / Z U x y ang)
(setq Z (car lst)
U (cadr lst)
x (+ (- (car U) (car U_origin))
(car U_insert)
)
y (+ (- (cadr U) (cadr U_origin))
(cadr U_insert)
)
ang (caddr lst)
)
(list Z (list x Y) ang)
)
group_data_out
)
)
;; 对 group_data_out 数组,以线元的起点U_insert进行旋转 quadrant_ang- ang 角度操作
(setq ang (caddr data_origin)
quadrant_ang (caddr data_insert)
)
(setq group_point
(mapcar 'cadr group_data_out)
)
(setq ang_Δ (- quadrant_ang ang)
group_point (rotate_group_point group_point ang_Δ U_insert)
)
(setq i 0
group_data_out
(mapcar '(lambda (lst / U ang)
(setq U (nth i group_point)
ang (caddr lst)
i (+ i 1)
)
(list (car lst) U (+ ang ang_Δ))
)
group_data_out
)
)
) ; (defun transformation_group_data_out 函数结束
;; (transformation_group_data_out group_data_out reflex data_origin data_insert)
;;888888888888888888888888888888888888888888888888888888888888888888888888888888
;; 人口变量, 缓和曲线参数A, 缓和曲线长L
(defun solve_transition_curve_sub (A L /
group U deflection
functon_parameter
)
;; (setq L 40.0 A 200 )
(if (> L 0.000001)
(progn
(setq L (* L 1.0)
A (* A 1.0)
)
(setq functon_parameter
'(((1 0 1.0 1)
(5 4 40.0 -1)
(9 8 3456.0 1)
(13 12 599040.0 -1)
(17 16 1.75473e+007 1)
)
((3 2 6.0 1)
(7 6 336.0 -1)
(11 10 42240.0 1)
(15 14 9.6768e+006 -1)
(19 18 3.5301e+009 1)
)
)
)
;; 把 L A 带入函数进行求值
(setq group
(mapcar '(lambda (subset)
(mapcar '(lambda (lst)
(apply '(lambda (a_1 a_2 a_3 a_4)
(* (/ (expt L a_1)
(* (expt A a_2) a_3)
)
a_4
)
)
lst
)
)
subset
)
)
functon_parameter
)
)
(setq U
(mapcar '(lambda (subset)
(apply '+ subset)
)
group
)
)
(setq deflection
(/ (expt L 2.0) (* (expt A 2.0) 2.0))
) ; J为弧度
(list U deflection)
) ; progn函数结束
;; 当缓和曲线长L很小时
(list '(0 0) 0)
) ; if 函数结束
)
;; 输出参数为切线支距坐标复数U,偏角deflection
;;888888888888888888888888888888888888888888888888888888888888888888888888888888888
;; 当线元是缓和曲线时， subset 数据结构为
;; ( R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert )
(defun solve_transition_curve (group_Z subset /
A Lh lst
Lh_start Lh_end U_Z_start
β_start Z_end group_data_out
data_origin data_insert
)
(apply
'(lambda (R_start R_end transition_parameter
reflex quadrant_ang Z_start
U_insert
)
(setq Lh (car transition_parameter) ; 缓和曲线长度
A (cadr transition_parameter) ; 缓和曲线参数
R_start (* R_start 1.0)
R_end (* R_end 1.0)
)
(if (= R_start 0)
(setq R_start (expt 10.0 30))
)
(if (= R_end 0)
(setq R_end (expt 10.0 30))
)
(if (> R_start R_end)
;; 正向缓和曲线时
(progn
(setq Lh_start (/ (expt A 2) R_start) ; 起点缓和曲线长度
lst (solve_transition_curve_sub A Lh_start)
U_Z_start (car lst) ; 缓和曲线的起点切线支距坐标
β_start (cadr lst) ;缓和曲线起点象限角
)
;; 对桩号集合group_Z 进行操作
(setq group_data_out
(mapcar '(lambda (z / L lst U_Z β_Z)
(setq L (+ (- Z Z_start) Lh_start))
(setq lst (solve_transition_curve_sub A L)
U_Z (car lst)
β_Z (cadr lst)
)
(list Z U_Z β_Z)
)
group_Z
)
)
)
;; 反向缓和曲线时
(progn
(setq Lh_start (/ (expt A 2) R_start)
lst (solve_transition_curve_sub A Lh_start)
U_Z_start (car lst)
β_start (cadr lst)
)
(setq Lh_end (/ (expt A 2) R_end) ; 终点缓和曲线长度
Z_end (+ Z_start Lh)
)
(setq group_data_out
(mapcar '(lambda (z / L lst U_Z β_Z)
(setq L (+ (- Z_end Z) Lh_end))
; 加桩点的缓和曲线长度，从完整缓和曲线的起点算起
(setq lst (solve_transition_curve_sub A L)
U_Z (car lst)
β_Z (cadr lst)
)
(list Z U_Z β_Z)
)
group_Z
)
)
;;此时生成的group_data_out与标准的正向缓和曲线线(原点0，启始方位角0，右手螺旋坐标系) 沿着X轴对称，
;;所以要对group_data_ou 进行沿x轴镜像
(setq group_data_out
(mapcar '(lambda (lst / Z U ang)
(setq Z (car lst)
U (cadr lst)
ang (caddr lst)
)
(list Z
(list (* (car U) -1)
(cadr U)
)
(* ang -1)
)
)
group_data_out
)
U_Z_start
(list (* (car U_Z_start) -1)
(cadr U_Z_start)
)
β_start
(* β_start -1)
)
)
) ; (if (> R_start R_end) 函数结束
;; 创建transformation_group_data_out 函数用参数 data_origin data_insert
(setq data_origin (list 0 U_Z_start β_start)
data_insert (list 0 U_insert quadrant_ang)
)
;; 对点集合 group_point 首先进行镜像变换，然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度
(transformation_group_data_out
group_data_out
reflex
data_origin
data_insert
)
)
subset
)
)
;;88888888888888888888888888888888888888888888888888888888888888888 (expt 10.0 30)
;; 当线元是圆曲线时 subset 数据结构为
;; ( R_start R_end lenth reflex quadrant_ang Z_start U_insert )
(defun solve_circular_arc (group_Z subset /
i group_data_out
U_center data_origin data_insert
)
;; (tang_test group_data_out )
(apply
'(lambda (R_start R_end lenth reflex quadrant_ang Z_start U_insert)
;; 设定圆曲线圆心为原点(0 R_start)，方向为右手坐标系，圆曲线线起点坐标(0 0 ),切线为X轴
(setq R_start (* R_start 1.0)
U_center (list 0 R_start)
)
(setq group_data_out
(mapcar '(lambda (Z / L β U_Z ang)
(setq L (- Z Z_start)
β (/ L R_start)
ang (- β (/ pi 2))
U_Z (polar U_center ang R_start)
)
(list Z U_Z β)
)
group_Z
)
)
;; 创建transformation_group_data_out 函数用参数 data_origin data_insert
(setq data_origin (list 0 (list 0 0) 0)
data_insert (list 0 U_insert quadrant_ang)
)
;; 对点集合 group_point 首先进行镜像变换，然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度
(transformation_group_data_out
group_data_out
reflex
data_origin
data_insert
)
)
subset
)
)
;;88888888888888888888888888888888888888888888888888888888888888888
;; 当线元是直线时 subset 数据结构为
;; ( R_start R_end lenth reflex quadrant_ang Z_start U_insert )
(defun solve_straightway
(group_Z subset / group_data_out)
;; (tang_test group_data_out )
(apply
'(lambda (R_start R_end lenth reflex quadrant_ang Z_start U_insert)
(setq group_data_out
(mapcar '(lambda (Z / L U_Z)
(setq L (- Z Z_start)
U_Z (polar U_insert quadrant_ang L)
)
(list Z U_Z quadrant_ang)
)
group_Z
)
)
)
subset
)
)
;;88888888888888888888888888888888888888888888888888888888888888888
;;888888888888888888888888888888888888888888888888888888888888888888888888888888
;; 人口变量缓和曲线长Lh, 缓和曲线半径R，出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A
(defun evaluation_transition_curve
(Lh R /
A p q
β group
functon_parameter
)
;; (setq lh 50 r 480 )
(setq R (* 1.0 R)
Lh (* 1.0 Lh)
)
(setq functon_parameter
'(((2 1 24.0)
(4 3 -2688.0)
(6 5 506880.0)
(8 7 -1.54829e+008)
)
((1 0 2.0)
(3 2 -240.0)
(5 4 34560.0)
(7 6 -8.38656e+006)
(9 8 3.15851e+009)
)
)
)
;;把参数parameter_easement_curve 带入求值，
(setq group
(mapcar '(lambda (subset)
(mapcar '(lambda (lst)
(apply '(lambda (a_1 a_2 a_3)
(/ (expt Lh a_1)
(* (expt R a_2) a_3)
)
)
lst
)
)
subset
)
)
functon_parameter
)
)
(setq group
(mapcar '(lambda (subset)
(apply '+ subset)
)
group
)
)
(setq p (car group)
q (cadr group)
β (/ Lh (* R 2.0))
A (sqrt (* R Lh))
)
;; 出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A
(list p q β A)
) ; evaluation_easement_curve 函数结束
;; (evaluation_transition_curve 50 480 ) (evaluation_transition_curve 50 480 )
;;888888888888888888888888888888888888888888888888888888888888888888888888888888888
;;888888888888888888888888888888888888888888888888888888888888888888888888888888
;; (setq group_turning_point ( create_turning_point_group ) )
;; 求基本对称路线平曲线的曲线要素入口变量: [ ( 转点号I nil) U_转点 ( Lh R Lh )(α1 α2 Δ Dist_1 Dist_2 )]
;; 出口变量:该转点各线元的数据[( 转点号I j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert ) ]
(defun evaluation_symmetrical_curve (subset / Z_I U group_data_out)
;; (setq subset (nth 15 group_turning_point ))
(setq Z_I (car (car subset)) ; 转点编号
subset (cdr subset)
)
;; (setq U_ZD_real (car subset) lst1 (cadr subset) lst2 (caddr subset) )
(apply '(lambda (U_ZD_real lst1 lst2 /
;; 计算交点用参数
quadrant_ang Δ
;; 计算切线长度 T1 T2 所用参数
T1 T2 a_1 a_2 tangent
cscΔ cotΔ
;; 计算缓和曲线的内蕴参数
parameter Lh1 Lh2 R
A1 A2 p1 p2 q1
q2 β1 β2 βy E
Ly L adjusted_value reflex
;; 建立线元坐标系所用参数
U_center U_JD U_ZH U_HY U_QZ
U_YH U_HZ
;; 桩号用参数
Z_JD Z_ZH Z_HY Z_QZ Z_YH
Z_HZ
;; 切线角用参数
ang_JD ang_ZH ang_HY ang_QZ ang_YH
ang_HZ
;; 对数组 group_data_out 进行移位，镜像，旋转用参数
quadrant_ang data_origin data_insert
;;创建线元列表所用参数
lst lst2 lst3 lst4 Line_segments
)
(setq Lh1 (car lst1)
R (cadr lst1)
Lh2 (caddr lst1)
quadrant_ang
(car lst2) ; 设计交点的入口方位角
Δ (caddr lst2) ; 设计交点偏转系数
)
(if (>= Δ 0)
(setq reflex 1)
(setq reflex -1
Δ (* -1 Δ)
)
)
(setq
parameter
(evaluation_transition_curve Lh1 R)
;; 出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A
p1 (car parameter)
q1 (cadr parameter)
β1 (caddr parameter)
A1 (nth 3 parameter)
)
(cond
((= Lh1 Lh2)
(setq
β2 β1
A2 A1
)
(setq tangent (/ (sin (/ Δ 2)) (cos (/ Δ 2)))
T1 (+ (* (+ R p1) tangent) q1)
T2 T1
; 切线长度
)
)
;; 当出口、进口缓和曲线长度不相等时
((/= Lh1 Lh2)
(setq
parameter
(evaluation_transition_curve Lh2 R)
;; 出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A
p2 (car parameter)
q2 (cadr parameter)
β2 (caddr parameter)
A2 (nth 3 parameter)
)
(setq cscΔ (/ 1.0 (sin Δ))
cotΔ (/ (cos Δ) (sin Δ))
a_1 (* (+ R p2) cscΔ)
a_2 (* (+ R p1) cotΔ)
T1 (+ (- a_1 a_2)
q1
)
a_1 (* (+ R p1) cscΔ)
a_2 (* (+ R p2) cotΔ)
T2 (+ (- a_1 a_2)
q2
)
)
)
) ; (cond 函数结束
(setq a_1 (expt (+ R p1) 2)
a_2 (expt (- T1 q1) 2)
E (- (sqrt (+ a_1 a_2)) R) ; 外距
βy (- Δ (+ β1 β2))
Ly (* βy R)
; 圆曲线长度
L (+ Ly (+ Lh1 Lh2))
adjusted_value (- (+ T1 T2) L) ; 切曲差
)
;; 以ZH点为坐标原点，该点的切线方向为X轴，建立右手螺旋坐标系 ,转角 Δ取正数
;;转点的桩号 Z_JD = z_QZ + adjusted_value
(setq ang_JD (/ Δ 2)
;; 设置为U_JD ->U_center的垂直方向
ang_ZH 0
ang_HY β1
ang_QZ (+ β1 (/ βy 2))
ang_YH (- Δ β2)
ang_HZ Δ
)
;; (angtos (+(/ (- pi Δ) 2)Δ) 1 6 )
(setq
U_JD (list T1 0)
U_center (list q1 (+ R p1))
U_ZH (list 0 0) ;向量U_center ->U_JD 的方位角 (+ (/ Δ 2)pi)
U_HY (polar U_center (- ang_HY (* pi 0.5)) R)
U_QZ (polar U_center (- ang_QZ (* pi 0.5)) R)
U_YH (polar U_center (- ang_YH (* pi 0.5)) R)
U_HZ (polar U_JD Δ T2)
)
(setq Z_JD T1
Z_ZH 0
Z_HY Lh1
Z_QZ (+ Lh1 (/ Ly 2))
Z_YH (+ Lh1 Ly)
Z_HZ L
)
(setq group_data_out
(list
(list Z_JD U_JD ang_JD)
(list Z_ZH U_ZH ang_ZH)
(list Z_HY U_HY ang_HY)
(list Z_QZ U_QZ ang_QZ)
(list Z_YH U_YH ang_YH)
(list Z_HZ U_HZ ang_HZ)
)
)
;; 创建transformation_group_data_out 函数用参数 data_origin data_insert
(setq
data_origin (list 0 U_JD 0)
data_insert (list 0 U_ZD_real quadrant_ang)
)
;; 对点集合 group_point 首先进行镜像变换，然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度quadrant_ang
(setq group_data_out
(transformation_group_data_out
group_data_out
reflex
data_origin
data_insert
)
)
;;利用group_data_out数组设置线元参数: (( 转点号I j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert )
(cond
((and (/= Lh1 0)
(/= Lh2 0)
)
(setq lst (list 1 2 4)
lst3 (list 0 1 2)
)
)
((and (= Lh1 0)
(/= Lh2 0)
)
(setq lst (list 2 4)
lst3 (list 1 2)
)
)
((and (/= Lh1 0)
(= Lh2 0)
)
(setq lst (list 1 2)
lst3 (list 0 1)
)
)
((and (= Lh1 0)
(= Lh2 0)
)
(setq lst (list 2)
lst3 (list 1)
)
)
) ; cond 函数结束
(setq
group
(mapcar '(lambda (i / lst2)
(setq lst2 (nth i group_data_out))
(list (caddr lst2) (car lst2) (cadr lst2))
)
(list 1 2 4)
)
lst_4 (list (list (list Z_I 0) 0 R (list Lh1 A1) reflex)
(list (list Z_I 1) R R Ly reflex)
(list (list Z_I 2) R 0 (list Lh2 A2) reflex)
)
Line_segments (mapcar '(lambda (i)
(append (nth i lst_4) (nth i group))
)
lst3
)
)
(list Line_segments (list T1 T2 adjusted_value))
)
subset
)
) ; evaluation_easement_curve 函数结束
;;888888888888888888888888888888888888888888888888888888888888888888888888888888888
;;888888888888888888888888888888888888888888888888888888888888888888888888888888 (setq tgg ( evaluation_no_symmetrical_curve subset ) )
;; (setq group_turning_point_original (car ( create_turning_point_group_original ) ) )
;; (setq group_turning_point (car( create_turning_point_group group_turning_point_original Z_road_start )))
;; 求包含非完整缓和曲线的线元要素入口变量: [ ( 转点号I T) U_转点 ( R_start R R_end Lh1 Lh2 )(α1 α2 Δ Dist_1 Dist_2 )]
;; 出口变量:该转点各线元的数据[( 转点号I j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert ) ]
(defun evaluation_no_symmetrical_curve (subset / Z_I U group_data_out)
;; (setq subset (nth 11 group_turning_point ))
(setq Z_I (car (car subset)) ; 转点编号
subset_2 (cdr subset)
)
;; (setq U_ZD_real (car subset_2) lst1 (cadr subset_2) lst2 (caddr subset_2) )
(apply '(lambda (U_ZD_real lst1 lst2 /
;; 计算交点用参数
quadrant_ang Δ
;; 计算切线长度 T1 T2 所用参数
T1 T2 group_Z Lh1_start Lh2_start
;; 计算缓和曲线的内蕴参数
parameter Lh1 Lh2 R A1
A2 p1 p2 q1 q2
β1 β2 βy E Ly
L adjusted_value reflex
;; 建立线元坐标系所用参数
U_center U_ZD U_ZH U_HY U_QZ
U_YH U_HZ
;; 桩号用参数
Z_JD Z_ZH Z_HY Z_QZ Z_YH
Z_HZ
;; 切线角用参数
ang_JD ang_ZH ang_HY ang_QZ ang_YH
ang_HZ
;; 对数组 group_data_out 进行移位，镜像，旋转用参数
quadrant_ang data_origin data_insert
;;创建线元列表所用参数
lst lst2 lst3 lst4 Line_segments
)
(setq R_start (car lst1)
R (cadr lst1)
R_end (caddr lst1)
Lh1 (nth 3 lst1)
Lh2 (nth 4 lst1)
quadrant_ang
(car lst2) ; 设计交点的入口方位角
Δ (caddr lst2) ; 设计交点偏转系数
)
(if (= R_start 0)
(setq R_start (expt 10.0 30))
)
(if (= R_end 0)
(setq R_end (expt 10.0 30))
)
(if (>= Δ 0)
(setq reflex 1)
(setq reflex -1
Δ (* -1 Δ)
) ; (setq Δ (/ pi 3))
)
;; 当出口缓和曲线长度不相等时
(if (/= Lh1 0)
(progn
;; 创建lst结构 ( ( 转点号I j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert )
(setq
A1
(abs (- (/ 1.0 R)
(/ 1.0 R_start)
)
)
A1
(sqrt (/ Lh1 A1))
)
;; 求入口非完整缓和曲线的HY点 ( z_桩号 U_z ang )
(setq lst (list R_start
R
(list Lh1 A1)
1
0 ; 线元的起点方位角
0
(list 0 0)
)
group_Z (list Lh1)
)
(setq group (solve_transition_curve group_Z lst)
U_HY (cadr (car group))
β1 (caddr (car group))
)
;; (setq group_data_out (solve_transition_curve ( create_group_Z 0 Lh1 1) lst )) (tang_test group_data_out )
)
(setq β1 0) ; 当Lh1长度为0 时， β1 偏角为0
)
;; 求出口口非完整缓和曲线的HY点 ( z_桩号 U_z ang ) (以YH点为0点，右手螺旋坐标系，过YH点的切线为0度 )
(if (/= Lh2 0)
(progn
;; 创建lst结构 ( R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert )
(setq
A2
(abs (- (/ 1.0 R)
(/ 1.0 R_end)
)
)
A2
(sqrt (/ Lh2 A2))
)
(setq lst (list R
R_end
(list Lh2 A2)
1
0 ; 线元的起点方位角
0
(list 0 0)
)
group_Z (list Lh2)
)
(setq group (solve_transition_curve group_Z lst)
β2 (caddr (car group))
)
)
(setq β2 0) ; 当Lh2长度为0 时， β2 偏角为0
) ; (if (/= Lh2 0) 函数结束
;; 计算圆曲线的偏角
(setq βy (- Δ (+ β2 β1))
Ly (* R βy) ; 圆曲线长度
)
;; 创建lst结构 ( R_start R_end lenth reflex quadrant_ang Z_start U_insert )
(setq lst (list R R Ly 1 β1 0 U_HY)
group_Z (list Ly) ; YH 点的桩号
)
(setq group (solve_circular_arc group_Z lst)
; 求圆曲线的终点坐标
U_YH (cadr (car group))
)
;; (setq group_data_out (solve_circular_arc ( create_group_Z 0 Ly 1) lst )) (tang_test group_data_out )
(if (/= Lh2 0)
(progn
;;求HZ点的 group_data_out 的数组( z_桩号 U_z ang )
(setq lst (list R
R_end
(list Lh2 A2)
1
(+ βy β1) ; 线元的起点方位角
0 ; 线元的起始桩号
U_YH
)
group_Z (list Lh2) ; HZ点桩号
)
(setq group (solve_transition_curve group_Z lst)
U_HZ (cadr (car group))
; 求第二缓和曲线在以HZ点为坐标原点，起点缓和曲线切线为X轴方向
)
;; (setq group_data_out (solve_transition_curve ( create_group_Z 0 Lh2 1) lst )) (tang_test group_data_out )
)
(setq U_HZ U_YH)
) ; (if (/= Lh2 0) 函数结束
;; 求次坐标系中的转点坐标 U_ZD
(setq U_HZ_2 (polar U_HZ Δ 100.0)
U_ZD (inters U_HZ
U_HZ_2
(list 0 0)
(list 10000 0)
nil
)
)
;; (setq tang99 (list (list 0 0) U_HY U_YH U_HZ U_ZD ))( create_LWPOLYLINE tang99 nil "0" )
(setq T1 (car U_ZD)
T2 (distance U_ZD U_HZ)
L (+ Ly (+ Lh1 Lh2))
adjusted_value (- (+ T1 T2) L) ; 切曲差
)
;; 以ZH点为坐标原点，该点的切线方向为X轴，建立右手螺旋坐标系 ,转角 Δ取正数
;;转点的桩号 Z_JD = z_QZ + adjusted_value
(setq ang_JD (/ Δ 2)
;; 设置为U_JD ->U_center的垂直方向
ang_ZH 0
ang_HY β1
ang_QZ (+ β1 (/ βy 2))
ang_YH (- Δ β2)
ang_HZ Δ
)
;; (angtos (+(/ (- pi Δ) 2)Δ) 1 6 )
(setq
U_center (polar U_HY (+ ang_HY (* pi 0.5)) R)
U_ZH (list 0 0) ;向量U_center ->U_JD 的方位角 (+ (/ Δ 2)pi)
U_QZ (polar U_center (- ang_QZ (* pi 0.5)) R)
)
(setq Z_JD T1
Z_ZH 0
Z_HY Lh1
Z_QZ (+ Lh1 (/ Ly 2))
Z_YH (+ Lh1 Ly)
Z_HZ L
)
(setq group_data_out
(list
(list Z_JD U_ZD ang_JD)
(list Z_ZH U_ZH ang_ZH)
(list Z_HY U_HY ang_HY)
(list Z_QZ U_QZ ang_QZ)
(list Z_YH U_YH ang_YH)
(list Z_HZ U_HZ ang_HZ)
)
)
;; 创建transformation_group_data_out 函数用参数 data_origin data_insert
(setq
data_origin (list 0 U_ZD 0)
data_insert (list 0 U_ZD_real quadrant_ang)
)
;; 对点集合 group_point 首先进行镜像变换，然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度quadrant_ang
(setq group_data_out
(transformation_group_data_out
group_data_out
reflex
data_origin
data_insert
)
)
;;利用group_data_out数组设置线元参数: ( R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert )
(cond
((and (/= Lh1 0)
(/= Lh2 0)
)
(setq lst (list 1 2 4)
lst3 (list 0 1 2)
)
)
((and (= Lh1 0)
(/= Lh2 0)
)
(setq lst (list 2 4)
lst3 (list 1 2)
)
)
((and (/= Lh1 0)
(= Lh2 0)
)
(setq lst (list 1 2)
lst3 (list 0 1)
)
)
((and (= Lh1 0)
(= Lh2 0)
)
(setq lst (list 2)
lst3 (list 1)
)
)
) ; cond 函数结束
(setq
group
(mapcar '(lambda (i / lst2)
(setq lst2 (nth i group_data_out))
(list (caddr lst2) (car lst2) (cadr lst2))
)
(list 1 2 4)
)
lst_4 (list (list (list Z_I 0) R_start R (list Lh1 A1) reflex)
(list (list Z_I 1) R R Ly reflex)
(list (list Z_I 2) R R_end (list Lh2 A2) reflex)
)
Line_segments (mapcar '(lambda (i)
(append (nth i lst_4) (nth i group))
)
lst3
)
)
(list Line_segments (list T1 T2 adjusted_value))
)
subset_2
)
) ; evaluation_easement_curve 函数结束
;;888888888888888888888888888888888888888888888888888888888888888888888888888888888
;; (setq group_turning_point ( create_turning_point_group ) )
;; 求线路的线元参数group_Line_segments [( 转点号I j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert ]
;; 以及转点参数 group_data_JD ( Z_JD U ang JD reflex )
(defun create_group_Line_segments
(group_turning_point
Z_road_start /
group_turning_point_2
lst state
i dist
quadrant_ang num
T_front Δ
U_insert U
Z group_parameter
group_Line_segments
group_data_JD
)
;; 去掉group_turning_point 中的第一和最后一个转点，不进行处理
(setq group_turning_point_2
(cdr group_turning_point)
group_turning_point_2
(reverse group_turning_point_2)
group_turning_point_2
(cdr group_turning_point_2)
group_turning_point_2
(reverse group_turning_point_2)
)
;; 创建线元集合group_Line_segments [( 转点号I j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert ]
;; 和转点用的参数集合 group_parameter (list T1 T2 adjusted_value)
(setq
group_Line_segments
nil
group_parameter
nil
)
(mapcar '(lambda ; (setq subset (nth 9 group_turning_point ) )
(subset / Line_segments state lst lst2)
(setq state (cadr (car subset)))
; 判断该转点是否包含非完整缓和曲线
(if state
(setq lst
(evaluation_no_symmetrical_curve subset)
Line_segments
(car lst)
lst2 (cadr lst)
)
(setq lst
(evaluation_symmetrical_curve subset)
Line_segments
(car lst)
lst2 (cadr lst)
)
)
(setq group_Line_segments
(cons Line_segments group_Line_segments)
group_parameter
(cons lst2 group_parameter)
)
)
group_turning_point_2
)
(setq group_Line_segments
(reverse group_Line_segments)
group_parameter
(reverse group_parameter)
)
;;利用参数group_parameter (list T1 T2 adjusted_value) 和group_turning_point 把直线线元加进group_Line_segments 中
(setq i 0
n (length group_Line_segments)
)
;; 把第二个转点至最后一个转点的直线线元加进数组group_Line_segments 中
(setq group_Line_segments
(mapcar
'(lambda
(lst / dist lst2 T_back
T_now T_front Δ U_JD quadrant_ang
U_insert element num Z_start
)
(cond
((/= i (- n 1)) ; 当转点num 不是最后一个转点时
(setq T_now (cadr (nth i group_parameter))
T_back (car (nth i group_parameter))
adjusted_value (caddr (nth i group_parameter))
T_front (car (nth (+ i 1) group_parameter))
lst2 (nth (+ i 1) group_turning_point)
; 线元所对应的转点号
dist (nth 4 (nth 3 lst2))
quadrant_ang (cadr (nth 3 lst2))
Δ (- dist (+ T_now T_front))
;直线线元的长度
num (car (car lst2)) ; 转点号
Z_start (- (+ T_now T_back) adjusted_value)
;线元的起点桩号
)
)
;; 当转点num 是最后一个转点时
((= i (- n 1))
(setq T_now (cadr (nth i group_parameter))
T_back (car (nth i group_parameter))
adjusted_value (caddr (nth i group_parameter))
T_front 0; 最后一个转点的切线长度设置为0
lst2 (nth (+ i 1) group_turning_point)
; 线元所对应的转点号
dist (nth 4 (nth 3 lst2))
quadrant_ang (cadr (nth 3 lst2))
Δ (- dist (+ T_now T_front))
num (car (car lst2)) ; 转点号
Z_start (- (+ T_now T_back) adjusted_value)
;线元的起点桩号
)
)
)
(setq i (+ i 1))
;; 当 Δ 长度大于0.1米时，在该转点处加进直线线元
(if (> Δ 0.1)
(progn
(setq U_JD (cadr lst2)
U_insert (polar U_JD quadrant_ang T_now)
num (car (car lst2))
)
;; 创建直线线元[( 转点号I 3) 0 0 Δ reflex quadrant_ang Z_start U_insert ]
(setq element (list (list num 3)
0
0
Δ
1
quadrant_ang
Z_start
U_insert
)
lst (append lst (list element))
)
)
) ; (if (> Δ 0.1) 函数结束
lst
)
group_Line_segments
)
)
;; 把第一直线线元加进数组 group_Line_segments
(setq lst (car group_turning_point)
dist (nth 4 (nth 3 lst))
quadrant_ang (cadr (nth 3 lst))
U_insert (cadr lst) ; 第一个转点的坐标
num (car (car lst)) ; 第一个线元的转点号
lst (car group_parameter)
T_front (car lst) ; 第二个转点的入口方向切线长度
Δ (- dist T_front)
)
;; 判断第一个线元的转点是否存在
(if (> Δ 0.1)
(progn
(setq element (list (list num 3)
0
0
Δ
1
quadrant_ang
0
U_insert
)
)
(setq group_Line_segments
(append (list (list element)) group_Line_segments)
)
)
)
;; 对线元数组 group_Line_segments 中的起始桩号进行处理，
(if (not Z_road_start)
(setq Z_road_start 0) ; 当线路起始桩号没有定义时，设置为0
)
(setq Z Z_road_start) ; 初始化桩号Z 为路线的起始桩号
(setq group_Line_segments
(mapcar
'(lambda (lst / element lenth)
(setq lst
(mapcar
'(lambda (subset)
(apply '(lambda (x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7)
(list x_0 x_1 x_2 x_3 x_4 x_5 (+ Z x_6) x_7)
)
subset
)
)
lst
)
) ; (mapcar '(lambda (subset) 函数结束
;; 当一个转点的全部线元处理完毕后，对该转点的最后一个线元的结束桩号，赋值给Z
(setq element (last lst)) ; 该转点的最后一个线元
(if (= (cadr (car element)) 2)
(setq lenth (car (nth 3 element)))
; 当最后一个线元是缓和曲线时
(setq lenth (nth 3 element))
)
(setq Z (+ (nth 6 element) lenth))
lst ; 保证输出结果为想要的group_Line_segments 数组
)
group_Line_segments
)
)
;; 对group_turning_point 中的交点，求其交点桩号，病并求其象限角，以转角的一半为切线方向
(setq group_data_JD nil) ; 利用数组group_Line_segments和group_parameter (list T1 T2 adjusted_value) 求解
(setq i 1)
(setq group_data_JD
(mapcar '(lambda (lst / T1 Z Z_JD lst2 U ang JD Δ reflex)
(setq T1 (car lst)
lst2 (nth i group_Line_segments)
Z (nth 6 (car lst2))
; 该交点中的第一个线元的起点桩号
Z_JD (+ Z T1)
reflex (nth 4 (car lst2))
)
(setq lst2 (nth i group_turning_point)
U (cadr lst2)
JD (car (car lst2))
Δ (caddr (nth 3 lst2))
ang (car (nth 3 lst2))
ang (+ (* 0.5 Δ) ang)
)
(setq i (+ i 1))
(list Z_JD U ang JD reflex)
)
group_parameter
)
)
(list group_Line_segments group_data_JD)
)
;; 88888888888 88888888888888 88888888888888888 88888888888888888888
;; 输入参数线元 Line_segments [( 转点号I j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert ]
;; mold加宽类型，mold为0时, 绘制普通加宽，mold=1 时，按直线加宽
(defun calculate_Transition-curve_widen
(Z group_widen
Line_segments mold
/ L widen
k k_2 k_3
l_x T_1 T_2
T_3 widen_x lenth
lst Z_end
)
(apply
'(lambda (x_0 x_1 x_2 transition_parameter reflex x_5 Z_start x_7)
(setq I (car x_0) ; 转点的编号
num (cadr x_0) ; 线元在转点中的编号
)
(setq lst (assoc I group_widen)
; 寻找转点I 所对应的加宽值
widen (cadr lst)
)
(if (not widen)
(setq widen 0)
)
(if (or (= num 0)
(= num 2)
)
;; 当线元为缓和曲线时
(progn
(setq lenth (car transition_parameter)
lenth (* lenth 1.0)
Z_end (+ Z_start lenth)
)
(if (and
(>= Z z_start)
(<= Z z_end)
)
(progn
(cond
;; 当线元为进口缓和曲线时
((= num 0)
(setq L (- Z z_start))
)
;; 当线元为出口缓和曲线时
((= num 2)
(setq L (- z_end z))
)
) ; cond 函数结束
(setq k (/ L lenth))
;; 当 mold为0时, 绘制普通加宽，mold=1 时，按直线加宽
(cond
((= mold 0)
(setq k_2 (* (expt k 3) 4)
k_3 (* (expt k 4) 3)
widen_x (* (- k_2 k_3) widen)
)
)
((= mold 1)
(setq widen_x (* k widen))
)
) ; 判断缓和曲线是否为普通或直线加宽的函数结束
)
) ; (if (and (>= Z z_start) (< Z z_end) ) 函数结束
)
) ; 处理缓和曲线线元加宽值的函数结束
(if (= num 1)
;; 当线元为圆曲线时
(progn
(setq lenth (* transition_parameter 1.0)
Z_end (+ Z_start lenth)
)
(if (and
(>= Z z_start)
(<= Z z_end)
)
(setq widen_x widen)
) ; (if (and (>= Z z_start) (< Z z_end) ) 函数结束
)
) ; 处理圆曲线线元加宽值的函数结束
(if (not widen_x)
(setq widen_x 0)
widen_x
)
)
Line_segments
)
) ; calculate_Transition-curve_widen函数结束
;; (calculate_Transition-curve_widen 7530 group_widen Line_segments 0 )
;; (setq group_widen (write_into_group_widen))
;; (setq Line_segments (cadr(nth 2 tang99 ))) (setq mold 0 z 7570 I 25 )
;; 对线元参数group_Line_segments [( 转点号num j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert ]
;; 求出一个新的数组 group_transition ( 转点号num j) (i j k) ，i 和 k 分别为该线元的前后线元编号 i k 取值为0 ，1 ，2 ,3
(defun create_group_transition
(group_Line_segments
/ group_transition
group n_1
n group_i
lst num
)
(setq group (apply 'append group_Line_segments))
;; 为了计算方便，在数组group的头和尾巴各加入一个数组
(setq lst (car (car group))
num (car lst)
lst (list (list num 3))
group (append (list lst) group)
lst (car (last group))
num (car lst)
lst (list (list num 3))
group (append group (list lst))
)
(setq n (length group)
n_1 1
group_i nil
)
(repeat (- n 2)
(setq group_i (cons n_1 group_i))
(setq n_1 (+ n_1 1))
)
(setq group_i (reverse group_i))
(setq group_transition nil)
(mapcar '(lambda (n_1 / lst lst_back lst_front i j k)
(setq lst (nth n_1 group)
j (cadr (car lst))
)
(setq lst_back (nth (- n_1 1) group)
lst_front
(nth (+ n_1 1) group)
)
(setq i (cadr (car lst_back))
k (cadr (car lst_front))
)
(setq group_transition
(cons (list (car lst) (list i j k))
group_transition
)
)
)
group_i
)
(reverse group_transition)
) ; (defun create_group_transition 函数结束
;; (setq group_transition ( create_group_transition group_Line_segments ) )

;;对一个二维点集合group_point 绕 点center 旋转 ang 弧度 
(defun rotate_group_point (group_point ang center / lst) 
  (setq        group_point 
         (mapcar '(lambda (point) 
                    (list (- (car point) (car center)) 
                          (- (cadr point) (cadr center)) 
                    ) 
                  ) 
                 group_point 
         ) 
  ) 
  (setq        lst (list (list (cos ang) (* (sin ang) -1)) 
                  (list (sin ang) (cos ang)) 
            ) 
  ) 
  (setq        group_point 
         (mapcar '(lambda (point) 
                    (apply '(lambda (element_1 element_2) 
                              (list (+ (* (car element_1) (car point)) 
                                       (* (cadr element_1) (cadr point)) 
                                    ) 
                                    (+ (* (car element_2) (car point)) 
                                       (* (cadr element_2) (cadr point)) 
                                    ) 
                              ) 
                            ) 
                           lst 
                    ) 
                  ) 
                 group_point 
         ) 
  ) 
  (setq 
    group_point 
     (mapcar '(lambda (x) 
                (list (+ (car x) (car center)) 
                      (+ (cadr x) (cadr center)) 
                ) 
              ) 
             group_point 
     ) 
  ) 
) 
;; 8888888888888888  88888888888888888888888  88888888888888888    
 
;;定义一个队group_data_out 数组进行群变换的函数 ，group_data_out 结构为：(Z_桩号 U ang_象限角 )   
;; 对点集合 group_point 首先进行镜像变换，然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度 
(defun transformation_group_data_out 
                                     (group_data_out 
                                      reflex           data_origin 
                                      data_insert  / 
                                      group_point  quadrant_ang 
                                      ang_Δ           ang 
                                      U_origin           U_insert 
                                      group           i 
                                     ) 
 
  (setq group (append (list data_origin) group_data_out)) 
  (if (= reflex -1) 
    (setq group 
           (mapcar '(lambda (lst / Z U ang) 
                      (setq Z        (car lst) 
                            U        (cadr lst) 
                            ang        (caddr lst) 
                      ) 
                      (list Z 
                            (list (car U) 
                                  (* (cadr U) -1) 
                            ) 
                            (* ang -1) 
                      ) 
                    ) 
                   group 
           ) 
    ) 
  )                                        ; (if (= reflex -1) 函数结束 
  (setq        data_origin    (car group) 
        group_data_out (cdr group) 
 
  ) 
  ;; 对group_data_out 数组进行平移,使得原坐标系中的U_origin点，和实际线元的起点U_insert向符合 
  (setq        U_origin (cadr data_origin) 
        U_insert (cadr data_insert) 
  ) 
  (setq        group_data_out 
         (mapcar '(lambda (lst / Z U x y ang) 
                    (setq Z   (car lst) 
                          U   (cadr lst) 
                          x   (+ (- (car U) (car U_origin)) 
                                 (car U_insert) 
                              ) 
                          y   (+ (- (cadr U) (cadr U_origin)) 
                                 (cadr U_insert) 
                              ) 
                          ang (caddr lst) 
                    ) 
                    (list Z (list x Y) ang) 
                  ) 
                 group_data_out 
         ) 
  ) 
  ;; 对 group_data_out 数组,以线元的起点U_insert进行旋转 quadrant_ang- ang 角度操作 
  (setq        ang             (caddr data_origin) 
        quadrant_ang (caddr data_insert) 
  ) 
 
  (setq        group_point 
         (mapcar 'cadr group_data_out) 
  ) 
  (setq        ang_Δ            (- quadrant_ang ang) 
        group_point (rotate_group_point group_point ang_Δ U_insert) 
  ) 
  (setq        i 0 
        group_data_out 
         (mapcar '(lambda (lst / U ang) 
                    (setq U   (nth i group_point) 
                          ang (caddr lst) 
                          i   (+ i 1) 
                    ) 
                    (list (car lst) U (+ ang ang_Δ)) 
 
                  ) 
                 group_data_out 
         ) 
  ) 
)                                        ; (defun transformation_group_data_out 函数结束 
;; (transformation_group_data_out group_data_out reflex         data_origin  data_insert)    
 
 
 
 
 
;;888888888888888888888888888888888888888888888888888888888888888888888888888888   
;;  人口变量, 缓和曲线参数A,  缓和曲线长L   
(defun solve_transition_curve_sub (A               L           / 
                                   group       U           deflection 
                                   functon_parameter 
                                  ) 
  ;; (setq L 40.0 A 200 )    
  (if (> L 0.000001) 
    (progn 
      (setq L (* L 1.0) 
            A (* A 1.0) 
      ) 
      (setq functon_parameter 
             '(((1 0 1.0 1) 
                (5 4 40.0 -1) 
                (9 8 3456.0 1) 
                (13 12 599040.0 -1) 
                (17 16 1.75473e+007 1) 
               ) 
               ((3 2 6.0 1) 
                (7 6 336.0 -1) 
                (11 10 42240.0 1) 
                (15 14 9.6768e+006 -1) 
                (19 18 3.5301e+009 1) 
               ) 
              ) 
      ) 
      ;; 把 L A 带入函数 进行求值   
      (setq group 
             (mapcar '(lambda (subset) 
                        (mapcar        '(lambda (lst) 
                                   (apply '(lambda (a_1 a_2 a_3 a_4) 
                                             (*        (/ (expt L a_1) 
                                                   (* (expt A a_2) a_3) 
                                                ) 
                                                a_4 
                                             ) 
                                           ) 
                                          lst 
                                   ) 
                                 ) 
                                subset 
                        ) 
                      ) 
                     functon_parameter 
             ) 
      ) 
 
      (setq U 
             (mapcar '(lambda (subset) 
                        (apply '+ subset) 
                      ) 
                     group 
             ) 
      ) 
 
      (setq deflection 
             (/ (expt L 2.0) (* (expt A 2.0) 2.0)) 
      )                                        ;  J为弧度 
      (list U deflection) 
    )                                        ; progn函数结束 
    ;; 当缓和曲线长L很小时 
    (list '(0 0) 0) 
  )                                        ;  if 函数结束 
) 
;;  输出参数为切线支距坐标复数U,偏角deflection   
;;888888888888888888888888888888888888888888888888888888888888888888888888888888888 
 
 
 
;; 当线元是缓和曲线时， subset 数据结构为 
;;  ( R_start R_end  transition_parameter    reflex         quadrant_ang    Z_start  U_insert )    
(defun solve_transition_curve (group_Z           subset      / 
                               A           Lh               lst 
                               Lh_start           Lh_end      U_Z_start 
                               β_start           Z_end       group_data_out 
                               data_origin data_insert 
                              ) 
  (apply 
    '(lambda (R_start              R_end              transition_parameter 
              reflex              quadrant_ang    Z_start 
              U_insert 
             ) 
 
       (setq Lh             (car transition_parameter) ; 缓和曲线长度   
             A             (cadr transition_parameter) ; 缓和曲线参数 
             R_start (* R_start 1.0) 
             R_end   (* R_end 1.0) 
       ) 
       (if (= R_start 0) 
         (setq R_start (expt 10.0 30)) 
       ) 
       (if (= R_end 0) 
         (setq R_end (expt 10.0 30)) 
       ) 
       (if (> R_start R_end) 
         ;; 正向缓和曲线时   
         (progn 
           (setq Lh_start  (/ (expt A 2) R_start) ; 起点缓和曲线长度 
                 lst           (solve_transition_curve_sub A Lh_start) 
                 U_Z_start (car lst)        ; 缓和曲线的起点切线支距坐标 
                 β_start  (cadr lst)        ;缓和曲线起点象限角 
           ) 
           ;; 对桩号集合group_Z 进行操作 
           (setq group_data_out 
                  (mapcar '(lambda (z / L lst U_Z β_Z) 
                             (setq L (+ (- Z Z_start) Lh_start)) 
                             (setq lst        (solve_transition_curve_sub A L) 
                                   U_Z        (car lst) 
                                   β_Z        (cadr lst) 
                             ) 
                             (list Z U_Z β_Z) 
                           ) 
                          group_Z 
                  ) 
           ) 
         ) 
         ;; 反向缓和曲线时   
         (progn 
           (setq Lh_start  (/ (expt A 2) R_start) 
                 lst           (solve_transition_curve_sub A Lh_start) 
                 U_Z_start (car lst) 
                 β_start  (cadr lst) 
           ) 
           (setq Lh_end        (/ (expt A 2) R_end) ; 终点缓和曲线长度 
                 Z_end        (+ Z_start Lh) 
           ) 
           (setq group_data_out 
                  (mapcar '(lambda (z / L lst U_Z β_Z) 
                             (setq L (+ (- Z_end Z) Lh_end)) 
                                        ; 加桩点的缓和曲线长度，从完整缓和曲线的起点算起 
                             (setq lst        (solve_transition_curve_sub A L) 
                                   U_Z        (car lst) 
                                   β_Z        (cadr lst) 
                             ) 
                             (list Z U_Z β_Z) 
                           ) 
                          group_Z 
                  ) 
           ) 
           ;;此时生成的group_data_out与标准的正向缓和曲线线(原点0，启始方位角0，右手螺旋坐标系) 沿着X轴对称 ， 
           ;;所以要对group_data_ou 进行沿x轴镜像   
           (setq group_data_out 
                                (mapcar        '(lambda (lst / Z U ang) 
                                           (setq Z   (car lst) 
                                                 U   (cadr lst) 
                                                 ang (caddr lst) 
                                           ) 
                                           (list Z 
                                                 (list (* (car U) -1) 
                                                       (cadr U) 
                                                 ) 
                                                 (* ang -1) 
                                           ) 
                                         ) 
                                        group_data_out 
                                ) 
 
                 U_Z_start 
                                (list (* (car U_Z_start) -1) 
                                      (cadr U_Z_start) 
                                ) 
 
                 β_start 
                                (* β_start -1) 
           ) 
         ) 
 
       )                                ; (if (> R_start R_end)  函数结束   
       ;; 创建transformation_group_data_out 函数用参数   data_origin  data_insert   
       (setq data_origin (list 0 U_Z_start β_start) 
             data_insert (list 0 U_insert quadrant_ang) 
       ) 
       ;; 对点集合 group_point 首先进行镜像变换，然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度 
       (transformation_group_data_out 
         group_data_out 
         reflex 
         data_origin 
         data_insert 
       ) 
     ) 
    subset 
  ) 
) 
;;88888888888888888888888888888888888888888888888888888888888888888   (expt 10.0 30)    
 
 
 
 
 
 
 
 
 
 
;; 当线元是圆曲线时 subset 数据结构为 
;;  ( R_start R_end  lenth    reflex         quadrant_ang    Z_start  U_insert   )    
(defun solve_circular_arc (group_Z         subset               / 
                           i                 group_data_out 
                           U_center         data_origin   data_insert 
                          ) 
 
 
  ;; (tang_test   group_data_out )    
  (apply 
    '(lambda (R_start R_end lenth reflex quadrant_ang Z_start U_insert) 
 
       ;; 设定圆曲线圆心为原点(0 R_start)，方向为 右手坐标系，圆曲线线起点坐标(0   0 ),切线为X轴 
 
       (setq R_start  (* R_start 1.0) 
             U_center (list 0 R_start) 
       ) 
       (setq group_data_out 
              (mapcar '(lambda (Z / L β U_Z ang) 
                         (setq L   (- Z Z_start) 
                               β  (/ L R_start) 
                               ang (- β (/ pi 2)) 
                               U_Z (polar U_center ang R_start) 
                         ) 
                         (list Z U_Z β) 
                       ) 
                      group_Z 
              ) 
       ) 
       ;; 创建transformation_group_data_out 函数用参数   data_origin  data_insert   
       (setq data_origin (list 0 (list 0 0) 0) 
             data_insert (list 0 U_insert quadrant_ang) 
       ) 
       ;; 对点集合 group_point 首先进行镜像变换，然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度 
       (transformation_group_data_out 
         group_data_out 
         reflex 
         data_origin 
         data_insert 
       ) 
     ) 
    subset 
  ) 
) 
;;88888888888888888888888888888888888888888888888888888888888888888   
 
 
 
 
 
;; 当线元是直线时 subset 数据结构为 
;;  ( R_start R_end  lenth    reflex         quadrant_ang    Z_start  U_insert   )    
(defun solve_straightway 
                         (group_Z subset / group_data_out) 
 
  ;; (tang_test   group_data_out )    
  (apply 
    '(lambda (R_start R_end lenth reflex quadrant_ang Z_start U_insert) 
       (setq group_data_out 
              (mapcar '(lambda (Z / L U_Z) 
                         (setq L   (- Z Z_start) 
                               U_Z (polar U_insert quadrant_ang L) 
                         ) 
                         (list Z U_Z quadrant_ang) 
                       ) 
                      group_Z 
              ) 
       ) 
     ) 
    subset 
  ) 
) 
;;88888888888888888888888888888888888888888888888888888888888888888   
 
 
 
 
 
 
 
;;888888888888888888888888888888888888888888888888888888888888888888888888888888   
;;  人口变量缓和曲线长Lh, 缓和曲线半径R，  出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A    
(defun evaluation_transition_curve 
                                   (Lh              R                / 
                                    A              p                q 
                                    β              group 
                                    functon_parameter 
                                   ) 
  ;; (setq lh 50 r 480 )   
  (setq        R  (* 1.0 R) 
        Lh (* 1.0 Lh) 
  ) 
  (setq        functon_parameter 
         '(((2 1 24.0) 
            (4 3 -2688.0) 
            (6 5 506880.0) 
            (8 7 -1.54829e+008) 
           ) 
           ((1 0 2.0) 
            (3 2 -240.0) 
            (5 4 34560.0) 
            (7 6 -8.38656e+006) 
            (9 8 3.15851e+009) 
           ) 
          ) 
  ) 
  ;;把参数parameter_easement_curve  带入求值， 
  (setq        group 
         (mapcar '(lambda (subset) 
                    (mapcar '(lambda (lst) 
                               (apply '(lambda (a_1 a_2 a_3) 
                                         (/ (expt Lh a_1) 
                                            (* (expt R a_2) a_3) 
                                         ) 
                                       ) 
                                      lst 
                               ) 
                             ) 
                            subset 
                    ) 
                  ) 
                 functon_parameter 
         ) 
  ) 
  (setq        group 
         (mapcar '(lambda (subset) 
                    (apply '+ subset) 
                  ) 
                 group 
         ) 
  ) 
  (setq        p  (car group) 
        q  (cadr group) 
        β (/ Lh (* R 2.0)) 
        A  (sqrt (* R Lh)) 
  ) 
  ;; 出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A    
  (list p q β A) 
)                                        ;   evaluation_easement_curve 函数结束                                  
;;  (evaluation_transition_curve  50  480  )  (evaluation_transition_curve   50  480  )                           
;;888888888888888888888888888888888888888888888888888888888888888888888888888888888 
 
 
 
;;888888888888888888888888888888888888888888888888888888888888888888888888888888 
;; (setq group_turning_point ( create_turning_point_group )  )    
;; 求基本对称路线平曲线的 曲线要素 入口变量: [ ( 转点号I nil)   U_转点  ( Lh R  Lh  )(α1  α2   Δ Dist_1   Dist_2 )]   
;; 出口变量:该转点各线元的数据[( 转点号I j)   R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert )  ]    
(defun evaluation_symmetrical_curve (subset / Z_I U group_data_out) 
  ;; (setq subset (nth 15   group_turning_point )) 
  (setq        Z_I    (car (car subset))        ; 转点编号 
        subset (cdr subset) 
  ) 
  ;; (setq U_ZD_real (car subset) lst1  (cadr subset) lst2  (caddr subset) )    
  (apply '(lambda (U_ZD_real             lst1     lst2     / 
                   ;; 计算交点用参数 
                   quadrant_ang             Δ 
                   ;; 计算切线长度 T1 T2 所用参数 
                   T1            T2             a_1      a_2      tangent 
                   cscΔ    cotΔ 
                   ;; 计算缓和曲线的内蕴参数 
                   parameter             Lh1      Lh2      R 
                   A1            A2             p1              p2       q1 
                   q2            β1             β2      βy      E 
                   Ly            L             adjusted_value    reflex 
                   ;; 建立线元坐标系所用参数 
                   U_center U_JD     U_ZH     U_HY     U_QZ 
                   U_YH            U_HZ 
                   ;; 桩号用参数 
                   Z_JD            Z_ZH     Z_HY     Z_QZ     Z_YH 
                   Z_HZ 
                   ;; 切线角用参数   
                   ang_JD   ang_ZH   ang_HY   ang_QZ   ang_YH 
                   ang_HZ 
                   ;; 对数组 group_data_out 进行移位，镜像，旋转 用参数 
                   quadrant_ang             data_origin       data_insert 
                   ;;创建线元列表所用参数   
                   lst            lst2     lst3     lst4     Line_segments 
                  ) 
            (setq Lh1               (car lst1) 
                  R               (cadr lst1) 
                  Lh2               (caddr lst1) 
                  quadrant_ang 
                               (car lst2) ; 设计交点的入口方位角   
                  Δ               (caddr lst2) ; 设计交点偏转系数 
 
            ) 
            (if        (>= Δ 0) 
              (setq reflex 1) 
              (setq reflex -1 
                    Δ           (* -1 Δ) 
              ) 
            ) 
            (setq 
              parameter 
                        (evaluation_transition_curve Lh1 R) 
              ;; 出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A    
              p1        (car parameter) 
              q1        (cadr parameter) 
              β1        (caddr parameter) 
              A1        (nth 3 parameter) 
            ) 
            (cond 
              ((= Lh1 Lh2) 
               (setq 
                 β2 β1 
                 A2  A1 
               ) 
               (setq tangent (/ (sin (/ Δ 2)) (cos (/ Δ 2))) 
                     T1             (+ (* (+ R p1) tangent) q1) 
                     T2             T1 
                                        ; 切线长度 
               ) 
              ) 
              ;; 当出口、进口缓和曲线长度不相等时 
              ((/= Lh1 Lh2) 
               (setq 
                 parameter 
                           (evaluation_transition_curve Lh2 R) 
                 ;; 出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A    
                 p2           (car parameter) 
                 q2           (cadr parameter) 
                 β2           (caddr parameter) 
                 A2           (nth 3 parameter) 
               ) 
               (setq cscΔ (/ 1.0 (sin Δ)) 
                     cotΔ (/ (cos Δ) (sin Δ)) 
                     a_1   (* (+ R p2) cscΔ) 
                     a_2   (* (+ R p1) cotΔ) 
                     T1           (+ (- a_1 a_2) 
                              q1 
                           ) 
                     a_1   (* (+ R p1) cscΔ) 
                     a_2   (* (+ R p2) cotΔ) 
                     T2           (+ (- a_1 a_2) 
                              q2 
                           ) 
               ) 
              ) 
            )                                ; (cond  函数 结束 
            (setq a_1                 (expt (+ R p1) 2) 
                  a_2                 (expt (- T1 q1) 2) 
                  E                 (- (sqrt (+ a_1 a_2)) R) ; 外距 
                  βy                 (- Δ (+ β1 β2)) 
                  Ly                 (* βy R) 
                                        ; 圆曲线长度 
                  L                 (+ Ly (+ Lh1 Lh2)) 
                  adjusted_value (- (+ T1 T2) L) ; 切曲差   
            ) 
            ;; 以ZH点为坐标原点，该点的切线方向为X轴，建立右手螺旋坐标系 ,转角 Δ取正数    
            ;;转点的桩号 Z_JD = z_QZ + adjusted_value 
            (setq ang_JD (/ Δ 2) 
                  ;; 设置为U_JD ->U_center的垂直方向 
                  ang_ZH 0 
                  ang_HY β1 
                  ang_QZ (+ β1 (/ βy 2)) 
                  ang_YH (- Δ β2) 
                  ang_HZ Δ 
            ) 
            ;;   (angtos   (+(/ (- pi Δ) 2)Δ)   1 6  )    
            (setq 
              U_JD     (list T1 0) 
              U_center (list q1 (+ R p1)) 
              U_ZH     (list 0 0)        ;向量U_center ->U_JD 的方位角 (+ (/ Δ 2)pi)    
              U_HY     (polar U_center (- ang_HY (* pi 0.5)) R) 
              U_QZ     (polar U_center (- ang_QZ (* pi 0.5)) R) 
              U_YH     (polar U_center (- ang_YH (* pi 0.5)) R) 
              U_HZ     (polar U_JD Δ T2) 
            ) 
            (setq Z_JD T1 
                  Z_ZH 0 
                  Z_HY Lh1 
                  Z_QZ (+ Lh1 (/ Ly 2)) 
                  Z_YH (+ Lh1 Ly) 
                  Z_HZ L 
            ) 
            (setq group_data_out 
                   (list 
                     (list Z_JD U_JD ang_JD) 
                     (list Z_ZH U_ZH ang_ZH) 
                     (list Z_HY U_HY ang_HY) 
                     (list Z_QZ U_QZ ang_QZ) 
                     (list Z_YH U_YH ang_YH) 
                     (list Z_HZ U_HZ ang_HZ) 
                   ) 
            ) 
            ;; 创建transformation_group_data_out 函数用参数   data_origin  data_insert   
            (setq 
              data_origin (list 0 U_JD 0) 
              data_insert (list 0 U_ZD_real quadrant_ang) 
            ) 
            ;; 对点集合 group_point 首先进行镜像变换，然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度quadrant_ang 
            (setq group_data_out 
                   (transformation_group_data_out 
                     group_data_out 
                     reflex 
                     data_origin 
                     data_insert 
                   ) 
            ) 
            ;;利用group_data_out数组 设置线元参数: (( 转点号I j)  R_start R_end  transition_parameter  reflex quadrant_ang  Z_start  U_insert ) 
            (cond 
              ((and (/= Lh1 0) 
                    (/= Lh2 0) 
               ) 
               (setq lst  (list 1 2 4) 
                     lst3 (list 0 1 2) 
               ) 
              ) 
              ((and (= Lh1 0) 
                    (/= Lh2 0) 
 
               ) 
               (setq lst  (list 2 4) 
                     lst3 (list 1 2) 
               ) 
              ) 
              ((and (/= Lh1 0) 
                    (= Lh2 0) 
               ) 
               (setq lst  (list 1 2) 
                     lst3 (list 0 1) 
               ) 
              ) 
              ((and (= Lh1 0) 
                    (= Lh2 0) 
               ) 
               (setq lst  (list 2) 
                     lst3 (list 1) 
               ) 
              ) 
            )                                ; cond  函数结束   
            (setq 
              group 
                            (mapcar '(lambda (i / lst2) 
                                       (setq lst2 (nth i group_data_out)) 
                                       (list (caddr lst2) (car lst2) (cadr lst2)) 
                                     ) 
                                    (list 1 2 4) 
                            ) 
              lst_4            (list (list (list Z_I 0) 0 R (list Lh1 A1) reflex) 
                                  (list (list Z_I 1) R R Ly reflex) 
                                  (list (list Z_I 2) R 0 (list Lh2 A2) reflex) 
                            ) 
              Line_segments (mapcar '(lambda (i) 
                                       (append (nth i lst_4) (nth i group)) 
                                     ) 
                                    lst3 
                            ) 
            ) 
            (list Line_segments (list T1 T2 adjusted_value)) 
          ) 
         subset 
  ) 
 
)                                        ;   evaluation_easement_curve 函数结束 
;;888888888888888888888888888888888888888888888888888888888888888888888888888888888    
 
 
 
 
 
;;888888888888888888888888888888888888888888888888888888888888888888888888888888 (setq tgg  ( evaluation_no_symmetrical_curve subset ) )    
;; (setq group_turning_point_original (car ( create_turning_point_group_original ) ) )    
;; (setq group_turning_point (car( create_turning_point_group   group_turning_point_original  Z_road_start )))      
;; 求包含非完整缓和曲线的线元要素 入口变量: [ ( 转点号I T)   U_转点  ( R_start R R_end   Lh1  Lh2  )(α1  α2   Δ Dist_1   Dist_2 )] 
;; 出口变量:该转点各线元的数据[( 转点号I j)   R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert )  ]    
(defun evaluation_no_symmetrical_curve (subset / Z_I U group_data_out) 
  ;; (setq subset (nth 11   group_turning_point )) 
  (setq        Z_I         (car (car subset))        ; 转点编号 
        subset_2 (cdr subset) 
  ) 
  ;; (setq U_ZD_real (car subset_2) lst1  (cadr subset_2) lst2  (caddr subset_2) )    
  (apply '(lambda (U_ZD_real lst1      lst2         / 
                   ;; 计算交点用参数 
                   quadrant_ang               Δ 
                   ;; 计算切线长度 T1 T2 所用参数 
                   T1             T2               group_Z         Lh1_start Lh2_start 
                   ;; 计算缓和曲线的内蕴参数 
                   parameter Lh1       Lh2         R           A1 
                   A2             p1               p2         q1           q2 
                   β1             β2       βy         E           Ly 
                   L             adjusted_value         reflex 
                   ;; 建立线元坐标系所用参数 
                   U_center  U_ZD      U_ZH         U_HY           U_QZ 
                   U_YH             U_HZ 
                   ;; 桩号用参数 
                   Z_JD             Z_ZH      Z_HY         Z_QZ           Z_YH 
                   Z_HZ 
                   ;; 切线角用参数   
                   ang_JD    ang_ZH    ang_HY         ang_QZ           ang_YH 
                   ang_HZ 
                   ;; 对数组 group_data_out 进行移位，镜像，旋转 用参数 
                   quadrant_ang               data_origin           data_insert 
                   ;;创建线元列表所用参数   
                   lst             lst2      lst3         lst4           Line_segments 
                  ) 
            (setq R_start (car lst1) 
                  R (cadr lst1) 
                  R_end        (caddr lst1) 
                  Lh1 (nth 3 lst1) 
                  Lh2 (nth 4 lst1) 
                  quadrant_ang 
                   (car lst2)                ; 设计交点的入口方位角   
                  Δ (caddr lst2)        ; 设计交点偏转系数 
            ) 
            (if        (= R_start 0) 
              (setq R_start (expt 10.0 30)) 
            ) 
            (if        (= R_end 0) 
              (setq R_end (expt 10.0 30)) 
            ) 
            (if        (>= Δ 0) 
              (setq reflex 1) 
              (setq reflex -1 
                    Δ           (* -1 Δ) 
              )                                ; (setq Δ (/ pi 3))    
            ) 
            ;; 当出口 缓和曲线长度不相等时 
            (if        (/= Lh1 0) 
              (progn 
                ;; 创建lst结构 ( ( 转点号I j)  R_start R_end  transition_parameter    reflex         quadrant_ang    Z_start  U_insert )   
                (setq 
                  A1 
                     (abs (- (/ 1.0 R) 
                             (/ 1.0 R_start) 
                          ) 
                     ) 
                  A1 
                     (sqrt (/ Lh1 A1)) 
                ) 
                ;; 求入口非完整缓和曲线的HY点 ( z_桩号 U_z ang  )   
                (setq lst     (list R_start 
                                    R 
                                    (list Lh1 A1) 
                                    1 
                                    0        ; 线元的起点方位角 
                                    0 
                                    (list 0 0) 
                              ) 
                      group_Z (list Lh1) 
                ) 
                (setq group (solve_transition_curve group_Z lst) 
                      U_HY  (cadr (car group)) 
                      β1   (caddr (car group)) 
                ) 
                ;; (setq group_data_out (solve_transition_curve  ( create_group_Z  0  Lh1   1)  lst ))  (tang_test   group_data_out ) 
              ) 
              (setq β1 0)                ; 当Lh1长度为0 时 ， β1 偏角为0   
            ) 
            ;; 求出口口非完整缓和曲线的HY点 ( z_桩号 U_z ang  ) (以YH点为0点，右手螺旋坐标系，过YH点的切线为0度 ) 
            (if        (/= Lh2 0) 
              (progn 
                ;; 创建lst结构 ( R_start R_end  transition_parameter    reflex         quadrant_ang    Z_start  U_insert )   
                (setq 
                  A2 
                     (abs (- (/ 1.0 R) 
                             (/ 1.0 R_end) 
                          ) 
                     ) 
                  A2 
                     (sqrt (/ Lh2 A2)) 
                ) 
                (setq lst     (list R 
                                    R_end 
                                    (list Lh2 A2) 
                                    1 
                                    0        ; 线元的起点方位角 
                                    0 
                                    (list 0 0) 
                              ) 
                      group_Z (list Lh2) 
                ) 
                (setq group (solve_transition_curve group_Z lst) 
                      β2   (caddr (car group)) 
                ) 
              ) 
              (setq β2 0)                ; 当Lh2长度为0 时 ， β2 偏角为0   
            )                                ; (if        (/= Lh2 0) 函数结束 
 
            ;; 计算圆曲线的偏角 
            (setq βy (- Δ (+ β2 β1)) 
                  Ly  (* R βy)                ; 圆曲线长度   
            ) 
 
            ;; 创建lst结构 ( R_start R_end  lenth    reflex         quadrant_ang    Z_start  U_insert )   
            (setq lst          (list R R Ly 1 β1 0 U_HY) 
                  group_Z (list Ly)        ; YH 点的桩号 
            ) 
            (setq group        (solve_circular_arc group_Z lst) 
                                        ; 求圆曲线的终点坐标 
                  U_YH        (cadr (car group)) 
            ) 
            ;; (setq group_data_out (solve_circular_arc  ( create_group_Z  0  Ly  1)  lst ))  (tang_test   group_data_out )   
            (if        (/= Lh2 0) 
              (progn 
                ;;求HZ点的 group_data_out 的数组( z_桩号 U_z ang  )   
                (setq lst     (list R 
                                    R_end 
                                    (list Lh2 A2) 
                                    1 
                                    (+ βy β1) ; 线元的起点方位角 
                                    0        ; 线元的起始桩号    
                                    U_YH 
                              ) 
                      group_Z (list Lh2) ; HZ点桩号 
                ) 
                (setq group (solve_transition_curve group_Z lst) 
                      U_HZ  (cadr (car group)) 
                                        ; 求第二缓和曲线在 以HZ点为坐标原点，起点缓和曲线切线为X轴方向 
                ) 
                ;; (setq group_data_out (solve_transition_curve  ( create_group_Z  0  Lh2   1)  lst ))  (tang_test   group_data_out )   
              ) 
              (setq U_HZ U_YH) 
            )                                ; (if        (/= Lh2 0) 函数结束 
 
            ;; 求次坐标系中的转点坐标 U_ZD 
            (setq U_HZ_2 (polar U_HZ Δ 100.0) 
                  U_ZD         (inters U_HZ 
                                 U_HZ_2 
                                 (list 0 0) 
                                 (list 10000 0) 
                                 nil 
                         ) 
            ) 
            ;;  (setq tang99 (list  (list 0 0) U_HY  U_YH   U_HZ  U_ZD  ))( create_LWPOLYLINE  tang99 nil  "0"  )       
 
            (setq T1                 (car U_ZD) 
                  T2                 (distance U_ZD U_HZ) 
                  L                 (+ Ly (+ Lh1 Lh2)) 
                  adjusted_value (- (+ T1 T2) L) ; 切曲差   
            ) 
 
            ;; 以ZH点为坐标原点，该点的切线方向为X轴，建立右手螺旋坐标系 ,转角 Δ取正数    
            ;;转点的桩号 Z_JD = z_QZ + adjusted_value 
            (setq ang_JD (/ Δ 2) 
                  ;; 设置为U_JD ->U_center的垂直方向 
                  ang_ZH 0 
                  ang_HY β1 
                  ang_QZ (+ β1 (/ βy 2)) 
                  ang_YH (- Δ β2) 
                  ang_HZ Δ 
            ) 
            ;;   (angtos   (+(/ (- pi Δ) 2)Δ)   1 6  )    
            (setq 
              U_center (polar U_HY (+ ang_HY (* pi 0.5)) R) 
              U_ZH     (list 0 0)        ;向量U_center ->U_JD 的方位角 (+ (/ Δ 2)pi)    
              U_QZ     (polar U_center (- ang_QZ (* pi 0.5)) R) 
            ) 
            (setq Z_JD T1 
                  Z_ZH 0 
                  Z_HY Lh1 
                  Z_QZ (+ Lh1 (/ Ly 2)) 
                  Z_YH (+ Lh1 Ly) 
                  Z_HZ L 
            ) 
            (setq group_data_out 
                   (list 
                     (list Z_JD U_ZD ang_JD) 
                     (list Z_ZH U_ZH ang_ZH) 
                     (list Z_HY U_HY ang_HY) 
                     (list Z_QZ U_QZ ang_QZ) 
                     (list Z_YH U_YH ang_YH) 
                     (list Z_HZ U_HZ ang_HZ) 
                   ) 
            ) 
            ;; 创建transformation_group_data_out 函数用参数   data_origin  data_insert   
            (setq 
              data_origin (list 0 U_ZD 0) 
              data_insert (list 0 U_ZD_real quadrant_ang) 
            ) 
            ;; 对点集合 group_point 首先进行镜像变换，然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度quadrant_ang 
            (setq group_data_out 
                   (transformation_group_data_out 
                     group_data_out 
                     reflex 
                     data_origin 
                     data_insert 
                   ) 
            ) 
            ;;利用group_data_out数组 设置线元参数: ( R_start R_end  transition_parameter  reflex quadrant_ang  Z_start  U_insert ) 
            (cond 
              ((and (/= Lh1 0) 
                    (/= Lh2 0) 
               ) 
               (setq lst  (list 1 2 4) 
                     lst3 (list 0 1 2) 
               ) 
              ) 
              ((and (= Lh1 0) 
                    (/= Lh2 0) 
 
               ) 
               (setq lst  (list 2 4) 
                     lst3 (list 1 2) 
               ) 
              ) 
              ((and (/= Lh1 0) 
                    (= Lh2 0) 
               ) 
               (setq lst  (list 1 2) 
                     lst3 (list 0 1) 
               ) 
              ) 
              ((and (= Lh1 0) 
                    (= Lh2 0) 
               ) 
               (setq lst  (list 2) 
                     lst3 (list 1) 
 
               ) 
              ) 
            )                                ; cond  函数结束   
            (setq 
              group 
                            (mapcar '(lambda (i / lst2) 
                                       (setq lst2 (nth i group_data_out)) 
                                       (list (caddr lst2) (car lst2) (cadr lst2)) 
                                     ) 
                                    (list 1 2 4) 
                            ) 
              lst_4            (list (list (list Z_I 0) R_start R (list Lh1 A1) reflex) 
                                  (list (list Z_I 1) R R Ly reflex) 
                                  (list (list Z_I 2) R R_end (list Lh2 A2) reflex) 
                            ) 
              Line_segments (mapcar '(lambda (i) 
                                       (append (nth i lst_4) (nth i group)) 
                                     ) 
                                    lst3 
                            ) 
            ) 
            (list Line_segments (list T1 T2 adjusted_value)) 
          ) 
         subset_2 
  ) 
 
 
)                                        ;   evaluation_easement_curve 函数结束 
;;888888888888888888888888888888888888888888888888888888888888888888888888888888888    
 
 
 
 
;;  (setq group_turning_point ( create_turning_point_group )  ) 
;; 求线路的线元参数group_Line_segments [( 转点号I j) R_start R_end  transition_parameter   reflex  quadrant_ang   Z_start  U_insert ]   
;; 以及转点参数  group_data_JD  ( Z_JD U ang JD  reflex )   
(defun create_group_Line_segments 
                                  (group_turning_point 
                                   Z_road_start           / 
                                   group_turning_point_2 
                                   lst                   state 
                                   i                   dist 
                                   quadrant_ang           num 
                                   T_front           Δ 
                                   U_insert           U 
                                   Z                   group_parameter 
                                   group_Line_segments 
                                   group_data_JD 
                                  ) 
  ;; 去掉group_turning_point 中的第一和最后一个转点，不进行处理 
  (setq        group_turning_point_2 
         (cdr group_turning_point) 
        group_turning_point_2 
         (reverse group_turning_point_2) 
        group_turning_point_2 
         (cdr group_turning_point_2) 
        group_turning_point_2 
         (reverse group_turning_point_2) 
  ) 
  ;; 创建线元集合group_Line_segments [( 转点号I j) R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert ]    
  ;; 和 转点用的参数集合 group_parameter (list T1 T2 adjusted_value) 
  (setq 
    group_Line_segments 
     nil 
    group_parameter 
     nil 
  ) 
  (mapcar '(lambda                        ; (setq subset (nth 9 group_turning_point ) )    
             (subset / Line_segments state lst lst2) 
              (setq state (cadr (car subset))) 
                                        ; 判断该转点是否包含非完整缓和曲线    
              (if state 
                (setq lst 
                       (evaluation_no_symmetrical_curve subset) 
                      Line_segments 
                       (car lst) 
                      lst2 (cadr lst) 
 
                ) 
                (setq lst 
                       (evaluation_symmetrical_curve subset) 
                      Line_segments 
                       (car lst) 
                      lst2 (cadr lst) 
 
                ) 
              ) 
              (setq group_Line_segments 
                     (cons Line_segments group_Line_segments) 
                    group_parameter 
                     (cons lst2 group_parameter) 
              ) 
           ) 
          group_turning_point_2 
  ) 
  (setq        group_Line_segments 
         (reverse group_Line_segments) 
        group_parameter 
         (reverse group_parameter) 
  ) 
  ;;利用参数group_parameter (list T1 T2 adjusted_value)   和group_turning_point  把直线线元加进group_Line_segments 中 
  (setq        i 0 
        n (length group_Line_segments) 
  ) 
  ;; 把第二个转点至最后一个转点的直线线元加进数组group_Line_segments 中 
  (setq        group_Line_segments 
         (mapcar 
           '(lambda 
              (lst         /           dist             lst2      T_back 
               T_now         T_front   Δ             U_JD      quadrant_ang 
               U_insert         element   num             Z_start 
              ) 
               (cond 
                 ((/= i (- n 1))        ; 当转点num 不是最后一个转点时   
                  (setq        T_now               (cadr (nth i group_parameter)) 
                        T_back               (car (nth i group_parameter)) 
                        adjusted_value (caddr (nth i group_parameter)) 
                        T_front               (car (nth (+ i 1) group_parameter)) 
                        lst2               (nth (+ i 1) group_turning_point) 
                                        ; 线元所对应的转点号   
                        dist               (nth 4 (nth 3 lst2)) 
                        quadrant_ang   (cadr (nth 3 lst2)) 
                        Δ               (- dist (+ T_now T_front)) 
                                        ;直线线元的长度 
                        num               (car (car lst2)) ; 转点号 
                        Z_start               (- (+ T_now T_back) adjusted_value) 
                                        ;线元的起点桩号   
                  ) 
                 ) 
                 ;;   当转点num  是最后一个转点时    
                 ((= i (- n 1)) 
                  (setq        T_now               (cadr (nth i group_parameter)) 
                        T_back               (car (nth i group_parameter)) 
                        adjusted_value (caddr (nth i group_parameter)) 
                        T_front               0;  最后一个转点的切线长度设置为0    
                        lst2               (nth (+ i 1) group_turning_point) 
                                        ; 线元所对应的转点号   
                        dist               (nth 4 (nth 3 lst2)) 
                        quadrant_ang   (cadr (nth 3 lst2)) 
                        Δ               (- dist (+ T_now T_front)) 
                        num               (car (car lst2)) ; 转点号 
                        Z_start               (- (+ T_now T_back) adjusted_value) 
                                        ;线元的起点桩号   
                  ) 
                 ) 
               ) 
               (setq i (+ i 1)) 
               ;; 当 Δ 长度大于0.1米 时， 在该转点处加进直线线元 
               (if (> Δ 0.1) 
                 (progn 
                   (setq U_JD          (cadr lst2) 
                         U_insert (polar U_JD quadrant_ang T_now) 
                         num          (car (car lst2)) 
                   ) 
                   ;; 创建直线线元[( 转点号I 3)  0  0   Δ    reflex  quadrant_ang    Z_start  U_insert ]   
                   (setq element (list (list num 3) 
                                       0 
                                       0 
                                       Δ 
                                       1 
                                       quadrant_ang 
                                       Z_start 
                                       U_insert 
                                 ) 
                         lst         (append lst (list element)) 
                   ) 
                 ) 
               )                        ; (if (> Δ 0.1) 函数结束 
               lst 
            ) 
           group_Line_segments 
         ) 
  ) 
  ;; 把第一直线线元加进数组 group_Line_segments   
  (setq        lst             (car group_turning_point) 
        dist             (nth 4 (nth 3 lst)) 
        quadrant_ang (cadr (nth 3 lst)) 
        U_insert     (cadr lst)                ; 第一个转点的 坐标 
        num             (car (car lst))        ; 第一个线元的转点号    
        lst             (car group_parameter) 
        T_front             (car lst)                ; 第二个转点 的入口方向切线长度 
        Δ             (- dist T_front) 
  ) 
  ;; 判断第一个线元的转点是否存在 
  (if (> Δ 0.1) 
    (progn 
      (setq element (list (list num 3) 
                          0 
                          0 
                          Δ 
                          1 
                          quadrant_ang 
                          0 
                          U_insert 
                    ) 
 
      ) 
      (setq group_Line_segments 
             (append (list (list element)) group_Line_segments) 
      ) 
    ) 
  ) 
  ;; 对线元数组 group_Line_segments 中的起始桩号进行处理，   
  (if (not Z_road_start) 
    (setq Z_road_start 0)                ; 当线路起始桩号没有定义时，设置为0   
  ) 
  (setq Z Z_road_start)                        ; 初始化桩号Z 为路线的起始桩号 
  (setq        group_Line_segments 
         (mapcar 
           '(lambda (lst / element lenth) 
              (setq lst 
                     (mapcar 
                       '(lambda        (subset) 
                          (apply '(lambda (x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7) 
                                    (list x_0 x_1 x_2 x_3 x_4 x_5 (+ Z x_6) x_7) 
                                  ) 
                                 subset 
                          ) 
                        ) 
                       lst 
                     ) 
              )                                ;  (mapcar '(lambda        (subset) 函数结束 
              ;; 当一个转点 的全部线元处理完毕后， 对该转点的最后一个线元的结束桩号，赋值给Z 
              (setq element (last lst))        ; 该转点的最后一个线元 
              (if (= (cadr (car element)) 2) 
                (setq lenth (car (nth 3 element))) 
                                        ; 当最后一个线元是缓和曲线时   
                (setq lenth (nth 3 element)) 
              ) 
              (setq Z (+ (nth 6 element) lenth)) 
              lst                        ; 保证输出结果为想要的group_Line_segments 数组   
            ) 
           group_Line_segments 
         ) 
  ) 
  ;; 对group_turning_point 中的交点 ，求其交点桩号，病并求其象限角，以转角的一半为切线方向    
 
  (setq group_data_JD nil)                ; 利用数组group_Line_segments和group_parameter (list T1 T2 adjusted_value) 求解 
  (setq i 1) 
  (setq        group_data_JD 
         (mapcar '(lambda (lst / T1 Z Z_JD lst2 U ang JD Δ reflex) 
                    (setq T1         (car lst) 
                          lst2         (nth i group_Line_segments) 
                          Z         (nth 6 (car lst2)) 
                                        ; 该交点中的第一个线元的起点桩号 
                          Z_JD         (+ Z T1) 
                          reflex (nth 4 (car lst2)) 
                    ) 
                    (setq lst2 (nth i group_turning_point) 
                          U    (cadr lst2) 
                          JD   (car (car lst2)) 
                          Δ   (caddr (nth 3 lst2)) 
                          ang  (car (nth 3 lst2)) 
                          ang  (+ (* 0.5 Δ) ang) 
                    ) 
                    (setq i (+ i 1)) 
                    (list Z_JD U ang JD reflex) 
                  ) 
                 group_parameter 
         ) 
  ) 
 
 
  (list group_Line_segments group_data_JD) 
) 
;; 88888888888           88888888888888            88888888888888888          88888888888888888888    
 
 
 
 
 
 
;; 输入参数 线元 Line_segments [( 转点号I j) R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert ]    
;; mold加宽类型 ，mold为0时, 绘制普通加宽，mold=1 时，按直线加宽 
(defun calculate_Transition-curve_widen 
                                        (Z          group_widen 
                                         Line_segments           mold 
                                         /          L           widen 
                                         k          k_2           k_3 
                                         l_x          T_1           T_2 
                                         T_3          widen_x  lenth 
                                         lst          Z_end 
                                        ) 
  (apply 
    '(lambda (x_0 x_1 x_2 transition_parameter reflex x_5 Z_start x_7) 
       (setq I         (car x_0)                ; 转点的编号 
             num (cadr x_0)                ; 线元在转点中的编号 
       ) 
       (setq lst   (assoc I group_widen) 
                                        ; 寻找转点I 所对应的加宽值    
             widen (cadr lst) 
       ) 
       (if (not widen) 
         (setq widen 0) 
       ) 
       (if (or (= num 0) 
               (= num 2) 
           ) 
         ;; 当线元为缓和曲线时   
         (progn 
           (setq lenth (car transition_parameter) 
                 lenth (* lenth 1.0) 
                 Z_end (+ Z_start lenth) 
           ) 
           (if (and 
                 (>= Z z_start) 
                 (<= Z z_end) 
               ) 
             (progn 
               (cond 
                 ;; 当线元为进口缓和曲线时   
                 ((= num 0) 
                  (setq L (- Z z_start)) 
                 ) 
                 ;; 当线元为出口缓和曲线时   
                 ((= num 2) 
                  (setq L (- z_end z)) 
                 ) 
               )                        ; cond 函数结束    
               (setq k (/ L lenth)) 
               ;; 当 mold为0时, 绘制普通加宽，mold=1 时，按直线加宽 
               (cond 
                 ((= mold 0) 
                  (setq        k_2        (* (expt k 3) 4) 
                        k_3        (* (expt k 4) 3) 
                        widen_x        (* (- k_2 k_3) widen) 
                  ) 
                 ) 
                 ((= mold 1) 
                  (setq widen_x (* k widen)) 
                 ) 
               )                        ; 判断 缓和曲线是否为普通或直线加宽的函数 结束    
             ) 
           )                                ; (if (and  (>= Z z_start) (< Z z_end) ) 函数结束 
         ) 
       )                                ; 处理缓和曲线线元加宽值的 函数结束 
       (if (= num 1) 
         ;; 当线元为圆曲线时    
         (progn 
           (setq lenth (* transition_parameter 1.0) 
                 Z_end (+ Z_start lenth) 
           ) 
           (if (and 
                 (>= Z z_start) 
                 (<= Z z_end) 
               ) 
             (setq widen_x widen) 
           )                                ; (if (and  (>= Z z_start) (< Z z_end) ) 函数结束 
         ) 
       )                                ; 处理圆曲线线元加宽值的 函数结束 
       (if (not widen_x) 
         (setq widen_x 0) 
         widen_x 
       ) 
     ) 
    Line_segments 
  ) 
)                                        ; calculate_Transition-curve_widen函数结束 
;; (calculate_Transition-curve_widen 7530  group_widen Line_segments  0 )    
;;  (setq  group_widen (write_into_group_widen))   
;; (setq Line_segments  (cadr(nth 2 tang99 )))  (setq   mold 0  z 7570  I 25  ) 
 
 
 
 
;; 对线元参数group_Line_segments [( 转点号num j) R_start R_end  transition_parameter   reflex  quadrant_ang   Z_start  U_insert ]   
;; 求出一个新的数组 group_transition ( 转点号num j) (i j k) ，i 和 k 分别为该线元的 前后线元编号  i k 取值为0 ，1 ，2 ,3   
(defun create_group_transition 
                               (group_Line_segments 
                                /              group_transition 
                                group              n_1 
                                n              group_i 
                                lst              num 
                               ) 
  (setq group (apply 'append group_Line_segments)) 
  ;; 为了计算方便，在数组group的头和尾巴各加入一个数组   
  (setq        lst   (car (car group)) 
        num   (car lst) 
        lst   (list (list num 3)) 
        group (append (list lst) group) 
        lst   (car (last group)) 
        num   (car lst) 
        lst   (list (list num 3)) 
        group (append group (list lst)) 
  ) 
  (setq        n        (length group) 
        n_1        1 
        group_i        nil 
  ) 
  (repeat (- n 2) 
    (setq group_i (cons n_1 group_i)) 
    (setq n_1 (+ n_1 1)) 
  ) 
  (setq group_i (reverse group_i)) 
  (setq group_transition nil) 
  (mapcar '(lambda (n_1 / lst lst_back lst_front i j k) 
             (setq lst (nth n_1 group) 
                   j   (cadr (car lst)) 
             ) 
             (setq lst_back  (nth (- n_1 1) group) 
                   lst_front 
                             (nth (+ n_1 1) group) 
             ) 
             (setq i (cadr (car lst_back)) 
                   k (cadr (car lst_front)) 
             ) 
             (setq group_transition 
                    (cons (list (car lst) (list i j k)) 
                          group_transition 
                    ) 
             ) 
           ) 
          group_i 
  ) 
  (reverse group_transition) 
)                                        ; (defun create_group_transition   函数结束   
;; (setq group_transition ( create_group_transition group_Line_segments ) )

;; 把竖曲线划分为直线线元和圆曲线线元
;;group_vertical_curve_2 结构为(( I_JD 0) Z_ZY Z_YZ H_ZY quadrant_ang R ang_Δ) ( (I_JD 1) Z_YZ Z_ZY_next H_YZ quadrant_ang 0 0 )
(defun create_group_vertical_curve_2 (group_vertical_curve
/ group
i lst
lst2 n
group_vertical_curve_2
Z ang_2
Z_ZY_next
)
(setq n (length group_vertical_curve))
(setq i 1
group nil
)
(repeat (- n 2)
(setq group (cons i group)
i (+ i 1)
)
)
(setq group (reverse group))
;;创建group_vertical_curve_2 ，(( I_JD 0) Z_ZY Z_YZ H_ZY quadrant_ang R ang_Δ) ( (I_JD 1) Z_YZ Z_ZY_next H_YZ quadrant_ang 0 0 )
(setq group_vertical_curve_2
(mapcar
'(lambda (i / lst_front lst
lst_back U_now U_back U_front ang_1
ang_2 ang_Δ Δ tangent R_now
I_JD Z_JD Z_ZY H_ZY Z_YZ
H_YZ Z_ZY_next
)
(setq lst_back (nth (- i 1) group_vertical_curve)
lst (nth i group_vertical_curve)
lst_front (nth (+ i 1) group_vertical_curve)
)
(apply '(lambda (I Z_JD H R)
(setq Z_JD (* Z_JD 1.0)
H (* H 1.0)
U_back (list Z_JD H)
)
)
lst_back
)
(apply '(lambda (I Z_JD H R)
(setq Z_JD (* Z_JD 1.0)
H (* H 1.0)
U_now (list Z_JD H)
R_now (* R 1.0)
I_JD I
)
)
lst
)
(apply '(lambda (I Z_JD H R)
(setq Z_JD (* Z_JD 1.0)
H (* H 1.0)
U_front (list Z_JD H)
)
)
lst_front
)
(setq
ang_1 (angle U_back U_now)
ang_2 (angle U_now U_front)
ang_Δ (- ang_2 ang_1) ; 该竖曲线的转点角度
Z_JD (car U_now)
H_JD (cadr U_now)
)
;; 对转角ang_Δ 使其控制在(-pi pi) 之间
(cond
((and (>= ang_Δ (* -1 pi))
(< ang_Δ pi)
)
(setq ang_Δ ang_Δ)
)
((< ang_Δ (* -1 pi))
(setq ang_Δ (+ ang_Δ (* 2 pi)))
)
((> ang_Δ pi)
(setq ang_Δ (- ang_Δ (* 2 pi)))
)
)
(setq Δ (/ (abs ang_Δ) 2.0)
tangent (* (/ (sin Δ) (cos Δ)) R_now)
tangent (abs tangent)
; 竖曲线切线长度
)
(setq U_ZY (polar U_now (+ ang_1 pi) tangent)
U_YZ (polar U_now ang_2 tangent)
Z_ZY (car U_ZY)
H_ZY (cadr U_ZY)
Z_YZ (car U_YZ)
H_YZ (cadr U_YZ)
)
;;创建元素其结构为(( I_JD 0) Z_ZY Z_YZ H_ZY quadrant_ang R ang_Δ) ( (I_JD 1) Z_YZ Z_ZY_next H_YZ quadrant_ang 0 0 )
(list (list (list I_JD 0) Z_ZY Z_YZ H_ZY ang_1 R_now ang_Δ)
(list (list I_JD 1) Z_YZ nil H_YZ ang_2 0 0)
; Z_ZY_next 暂时设置为空 nil ,因为是直线半径R设置为0
)
)
group
)
)
;; 对 group_vertical_curve_2 中的直线线元( (I_JD 1) Z_YZ Z_ZY_next H_YZ quadrant_ang 0 0 ) 中Z_ZY_next 进行处理
(setq group (mapcar '(lambda (lst)
(cadr (car lst))
)
(cdr group_vertical_curve_2)
)
)
;; 把最后一个交点的桩号也加入 group 中
(setq Z (cadr (last group_vertical_curve))
group (append group (list z))
)
;; 用group 对group_vertical_curve_2 进行填充
(setq i 0)
(setq group_vertical_curve_2
(mapcar '(lambda (Z / lst subset)
(setq lst (nth i group_vertical_curve_2)
subset (cadr lst)
subset (subst Z nil subset)
i (+ i 1)
)
(list (car lst) subset)
)
group
)
)
;; 把第一第二转点之间直线线元加进数组group_vertical_curve_2 中
(setq lst (car (car group_vertical_curve_2))
Z_ZY_next (cadr lst) ; 第一第二转点之间直线线元的终点桩号
ang_2 (nth 4 lst) ;象限角
lst (car group_vertical_curve)
lst2 (apply
'(lambda (I Z_JD H R)
(list (list I 1)
Z_JD
Z_ZY_next
H
ang_2
0
0
)
)
lst
)
)
(setq group_vertical_curve_2
(append (list (list lst2)) group_vertical_curve_2)
)
(setq group_vertical_curve_2 (apply 'append group_vertical_curve_2))
)
;; (setq group_vertical_curve_2 ( create_group_vertical_curve_2 group_vertical_curve ) )
;; QH2_10N 对每个输入桩号Z 求其高程 solve_elevation , QH2_10N 摘录自书1-fx5800P公路与铁路施工测量程序
;; group_vertical_curve_2 ，其数组结构为(( I_JD 0) Z_ZY Z_YZ H_ZY quadrant_ang R ang_Δ) ( (I_JD 1) Z_YZ Z_ZY_next H_YZ quadrant_ang 0 0 )
(defun QH2_10N (Z group_vertical_curve_2 /
n lst_1 lst_2 lst_3 lst
n_1 Z_start Z_end t1 t2
;;
reflex A B C G
result_1 result_2 H tan Δ
ang α elevation L α0
)
(setq n (length group_vertical_curve_2)
lst_1 (car group_vertical_curve_2)
lst_2 (last group_vertical_curve_2)
elevation nil
)
(setq Z_start (cadr lst_1)
Z_end (caddr lst_2)
)
(if (and (>= Z Z_start) (<= Z Z_end)) ; (setq Z 13950)
(setq t1 t)
(setq t1 nil)
)
;; 开始循环函数 888888888888888888888888888888888888888888888888888888888888
(setq i 0
t2 t
)
(while (and (< i n) t1 t2) ; (setq i 44 )
(setq lst (nth i group_vertical_curve_2))
(apply
'(lambda (array Z_S Z_e H quadrant_ang R ang_Δ)
(if (and (>= Z Z_s) (<= Z Z_e))
(progn
(setq L (* (- Z Z_S) 1.0))
(cond
;; 当Z在直线线元时
((= (cadr array) 1)
(setq
tan (/ (sin quadrant_ang) (cos quadrant_ang))
elevation (+ (* tan L) H)
t2 nil
)
)
;; 当Z在竖曲线，线元时
((= (cadr array) 0)
(progn
(if (minusp ang_Δ)
(setq reflex -1) ;当转角为负数时，凸曲线 ,
(setq reflex 1) ; 转角为正数时，凹曲线时
)
(setq α0 (abs quadrant_ang)
Δ (/ (abs ang_Δ) 2.0)
)
(setq
A
(- (* (sin α0)
(* (* R 2.0) reflex)
)
L
)
B
(* (cos α0)
(* R 2.0)
)
C
(* -1.0 L)
G
(sqrt (- (expt B 2) (* (* A C) 4.0)))
)
;; 一元二次方程的两个解
(setq
result_1
(atan (/ (+ (* -1 B) G) (* 2.0 A)))
result_2
(atan (/ (- (* -1 B) G) (* 2.0 A)))
)
(if
(and (> result_2 0) (<= result_2 Δ))
(setq ang result_2)
(setq ang result_1)
)
(setq α (+ quadrant_ang (* ang reflex)))
(setq
elevation (+ (* (/ (sin α) (cos α)) L) H)
)
(setq t2 nil)
)
)
) ; (cond 函数结束
)
) ; (if (and (>= Z Z_s) (< Z Z_e)) 函数结束
)
lst
) ; apply 函数结束
(setq i (+ i 1))
)
;;(while (< i (- n 1)) 函数结束88888888888888888888888
elevation ; (setq elevation 0)
)
;;QH2_10N 函数结束
;; (QH2_10N 13950 group_vertical_curve_2 )

;; 把竖曲线划分为直线线元 和 圆曲线线元 
;;group_vertical_curve_2 结构为(( I_JD 0)  Z_ZY  Z_YZ  H_ZY  quadrant_ang  R  ang_Δ)  ( (I_JD 1) Z_YZ  Z_ZY_next  H_YZ  quadrant_ang 0 0  )   
(defun create_group_vertical_curve_2 (group_vertical_curve 
                                      /                     group 
                                      i                     lst 
                                      lst2             n 
                                      group_vertical_curve_2 
                                      Z                     ang_2 
                                      Z_ZY_next 
                                     ) 
 
  (setq n (length group_vertical_curve)) 
  (setq        i 1 
        group nil 
  ) 
  (repeat (- n 2) 
    (setq group        (cons i group) 
          i        (+ i 1) 
    ) 
  ) 
  (setq group (reverse group)) 
  ;;创建group_vertical_curve_2 ，(( I_JD 0)  Z_ZY  Z_YZ  H_ZY  quadrant_ang  R  ang_Δ)  ( (I_JD 1) Z_YZ  Z_ZY_next  H_YZ  quadrant_ang 0 0  )   
  (setq        group_vertical_curve_2 
         (mapcar 
           '(lambda (i              /               lst_front         lst 
                     lst_back U_now    U_back        U_front         ang_1 
                     ang_2    ang_Δ   Δ        tangent         R_now 
                     I_JD     Z_JD     Z_ZY        H_ZY         Z_YZ 
                     H_YZ     Z_ZY_next 
                    ) 
              (setq lst_back  (nth (- i 1) group_vertical_curve) 
                    lst              (nth i group_vertical_curve) 
                    lst_front (nth (+ i 1) group_vertical_curve) 
              ) 
              (apply '(lambda (I Z_JD H R) 
                        (setq Z_JD   (* Z_JD 1.0) 
                              H             (* H 1.0) 
                              U_back (list Z_JD H) 
                        ) 
                      ) 
                     lst_back 
              ) 
              (apply '(lambda (I Z_JD H R) 
                        (setq Z_JD  (* Z_JD 1.0) 
                              H            (* H 1.0) 
                              U_now (list Z_JD H) 
                              R_now (* R 1.0) 
                              I_JD  I 
                        ) 
                      ) 
                     lst 
              ) 
              (apply '(lambda (I Z_JD H R) 
                        (setq Z_JD    (* Z_JD 1.0) 
                              H              (* H 1.0) 
                              U_front (list Z_JD H) 
                        ) 
                      ) 
                     lst_front 
              ) 
              (setq 
                ang_1  (angle U_back U_now) 
                ang_2  (angle U_now U_front) 
                ang_Δ (- ang_2 ang_1)        ; 该竖曲线的转点 角度    
                Z_JD   (car U_now) 
                H_JD   (cadr U_now) 
              ) 
              ;; 对转角ang_Δ 使其控制在(-pi pi) 之间 
              (cond 
                ((and (>= ang_Δ (* -1 pi)) 
                      (< ang_Δ pi) 
                 ) 
                 (setq ang_Δ ang_Δ) 
                ) 
                ((< ang_Δ (* -1 pi)) 
                 (setq ang_Δ (+ ang_Δ (* 2 pi))) 
                ) 
                ((> ang_Δ pi) 
                 (setq ang_Δ (- ang_Δ (* 2 pi))) 
                ) 
              ) 
              (setq Δ            (/ (abs ang_Δ) 2.0) 
                    tangent (* (/ (sin Δ) (cos Δ)) R_now) 
                    tangent (abs tangent) 
                                        ; 竖曲线切线长度 
              ) 
              (setq U_ZY (polar U_now (+ ang_1 pi) tangent) 
                    U_YZ (polar U_now ang_2 tangent) 
                    Z_ZY (car U_ZY) 
                    H_ZY (cadr U_ZY) 
                    Z_YZ (car U_YZ) 
                    H_YZ (cadr U_YZ) 
              ) 
              ;;创建元素其结构为(( I_JD 0)  Z_ZY  Z_YZ  H_ZY  quadrant_ang  R  ang_Δ)  ( (I_JD 1) Z_YZ  Z_ZY_next  H_YZ  quadrant_ang 0 0  )   
              (list (list (list I_JD 0) Z_ZY Z_YZ H_ZY ang_1 R_now ang_Δ) 
                    (list (list I_JD 1) Z_YZ nil H_YZ ang_2 0 0) 
                                        ;  Z_ZY_next 暂时设置为空 nil ,因为是直线半径R设置为0      
              ) 
            ) 
           group 
         ) 
  ) 
  ;; 对        group_vertical_curve_2 中 的直线线元( (I_JD 1) Z_YZ  Z_ZY_next  H_YZ  quadrant_ang 0 0  ) 中Z_ZY_next 进行处理 
  (setq        group (mapcar '(lambda (lst) 
                         (cadr (car lst)) 
                       ) 
                      (cdr group_vertical_curve_2) 
              ) 
  ) 
  ;; 把最后一个交点的桩号也加入 group 中 
  (setq        Z     (cadr (last group_vertical_curve)) 
        group (append group (list z)) 
  ) 
  ;; 用group 对group_vertical_curve_2 进行填充 
  (setq i 0) 
  (setq        group_vertical_curve_2 
         (mapcar '(lambda (Z / lst subset) 
                    (setq lst         (nth i group_vertical_curve_2) 
                          subset (cadr lst) 
                          subset (subst Z nil subset) 
                          i         (+ i 1) 
                    ) 
                    (list (car lst) subset) 
                  ) 
                 group 
         ) 
  ) 
  ;; 把 第一第二转点之间直线线元 加进数组group_vertical_curve_2 中    
  (setq        lst          (car (car group_vertical_curve_2)) 
        Z_ZY_next (cadr lst)                ; 第一第二转点之间直线线元的终点桩号 
        ang_2          (nth 4 lst)                ;象限角    
        lst          (car group_vertical_curve) 
        lst2          (apply 
                    '(lambda (I Z_JD H R) 
                       (list (list I 1) 
                             Z_JD 
                             Z_ZY_next 
                             H 
                             ang_2 
                             0 
                             0 
                       ) 
                     ) 
                    lst 
                  ) 
 
  ) 
  (setq        group_vertical_curve_2 
         (append (list (list lst2)) group_vertical_curve_2) 
  ) 
  (setq group_vertical_curve_2 (apply 'append group_vertical_curve_2)) 
) 
;;  (setq group_vertical_curve_2 ( create_group_vertical_curve_2  group_vertical_curve ) )    
 
 
 
 
 
;;  QH2_10N 对每个输入桩号Z 求其高程  solve_elevation  , QH2_10N 摘录自 书1-fx5800P公路与铁路施工测量程序 
;; group_vertical_curve_2 ，其数组结构为(( I_JD 0)  Z_ZY  Z_YZ  H_ZY  quadrant_ang  R  ang_Δ)  ( (I_JD 1) Z_YZ  Z_ZY_next  H_YZ  quadrant_ang 0 0  )   
(defun QH2_10N (Z          group_vertical_curve_2        / 
                n          lst_1            lst_2     lst_3        lst 
                n_1          Z_start   Z_end     t1        t2 
                ;;    
                reflex          A            B              C                G 
                result_1  result_2  H              tan        Δ 
                ang          α            elevation L                α0 
               ) 
 
  (setq        n          (length group_vertical_curve_2) 
        lst_1          (car group_vertical_curve_2) 
        lst_2          (last group_vertical_curve_2) 
        elevation nil 
  ) 
  (setq        Z_start        (cadr lst_1) 
        Z_end        (caddr lst_2) 
  ) 
  (if (and (>= Z Z_start) (<= Z Z_end))        ; (setq Z  13950)   
    (setq t1 t) 
    (setq t1 nil) 
  ) 
  ;; 开始循环函数 888888888888888888888888888888888888888888888888888888888888    
  (setq        i  0 
        t2 t 
  ) 
  (while (and (
    (setq lst (nth i group_vertical_curve_2)) 
    (apply 
      '(lambda (array Z_S Z_e H quadrant_ang R ang_Δ) 
         (if (and (>= Z Z_s) (<= Z Z_e)) 
           (progn 
             (setq L (* (- Z Z_S) 1.0)) 
             (cond 
               ;; 当Z在直线线元时   
               ((= (cadr array) 1) 
                (setq 
                  tan            (/ (sin quadrant_ang) (cos quadrant_ang)) 
                  elevation (+ (* tan L) H) 
                  t2            nil 
                ) 
               ) 
               ;; 当Z在竖曲线，线元时 
               ((= (cadr array) 0) 
                (progn 
                  (if (minusp ang_Δ) 
                    (setq reflex -1)        ;当转角为负数时，凸曲线 ,   
                    (setq reflex 1)        ; 转角为正数时，凹曲线时   
                  ) 
                  (setq        α0 (abs quadrant_ang) 
                        Δ  (/ (abs ang_Δ) 2.0) 
                  ) 
                  (setq 
                    A 
                      (- (* (sin α0) 
                            (* (* R 2.0) reflex) 
                         ) 
                         L 
                      ) 
                    B 
                      (* (cos α0) 
                         (* R 2.0) 
                      ) 
                    C 
                      (* -1.0 L) 
                    G 
                      (sqrt (- (expt B 2) (* (* A C) 4.0))) 
                  ) 
                  ;; 一元二次方程的两个解 
                  (setq 
                    result_1 
                             (atan (/ (+ (* -1 B) G) (* 2.0 A))) 
                    result_2 
                             (atan (/ (- (* -1 B) G) (* 2.0 A))) 
                  ) 
                  (if 
                    (and (> result_2 0) (<= result_2 Δ)) 
                     (setq ang result_2) 
                     (setq ang result_1) 
                  ) 
                  (setq α (+ quadrant_ang (* ang reflex))) 
                  (setq 
                    elevation (+ (* (/ (sin α) (cos α)) L) H) 
                  ) 
                  (setq t2 nil) 
                ) 
               ) 
             )                                ;  (cond  函数结束    
           ) 
         )                                ; (if (and (>= Z Z_s) (< Z Z_e)) 函数结束   
       ) 
      lst 
    )                                        ; apply 函数结束    
    (setq i (+ i 1)) 
  ) 
  ;;(while (< i  (- n 1)) 函数结束88888888888888888888888 
 
  elevation                                ;  (setq elevation 0)   
) 
;;QH2_10N 函数结束 
;; (QH2_10N   13950    group_vertical_curve_2   )

;; (setq group_turning_point ( create_turning_point_group ) )
;; (setq group_Line_segments (car ( create_group_Line_segments group_turning_point 6782.755 )) )
;; 输入参数线元 Line_segments [( 转点号I j) R_start R_end transition_parameter reflex quadrant_ang Z_start U_insert ]
(defun calculate_superelevation
(Z group_superelevation
Line_segments /
lenth lst
lst_seek Z_end
I num
superelevation superelevation_R
superelevation_L superelevation_back
slope_comparison superelevation_front
cross_slope K
Z_state temp
)
;; (setq x_0 (car Line_segments ))
(apply
'(lambda (x_0 x_1 x_2 transition_parameter reflex x_5 Z_start x_7)
(setq I (car x_0) ; 转点的编号
num (cadr x_0) ; 线元在转点中的编号
)
(setq lst_seek (assoc I group_superelevation)
; 寻找转点I 所对应的超高值
)
(if (= (length lst_seek) 2)
;; 当转点超高方式是标准超高时，既从直线-2% 边坡到superelevation% 再边坡到 2%
(setq superelevation (cadr lst_seek))
;; 当转点超高方式是非标准超高时, 既从superelevation_back% 边坡到slope% 再边坡到superelevation_front%
(setq superelevation ; 当前线元最大坡度值
(cadr (cadr lst_seek))
superelevation_back ; 当前线元的起始坡度值
(car (cadr lst_seek))
superelevation_front
(cadr (caddr lst_seek)) ; 当前线元的结束坡度值
)
)
(if (and superelevation
(/= num 3) ; 线元 Line_segments 不为直线时
)
(progn
(cond
((or (= num 0)
(= num 2)
)
(setq lenth (car transition_parameter))
; 当线元为缓和曲线时
)
((= num 1)
(setq lenth transition_parameter)
; 圆曲线时
)
)
(setq lenth (* lenth 1.0)
Z_end (+ Z_start lenth)
L (- Z z_start)
Z_state (and
(>= Z z_start)
(<= Z z_end)
)
)
(cond
;; 该转点为标准超高值既横坡从-2% 超高到 superelevation% 变化到 -2%
((and
(or (= num 0)
(= num 2)
)
Z_state
(= (length lst_seek) 2)
)
(progn
(setq K (/ (+ 2 superelevation) lenth))
(if (= num 0)
(setq cross_slope (+ (* K L) -2.0)) ; 入口缓和曲线
(setq cross_slope (- superelevation (* K L)))
; 出口缓和曲线
)
(setq
superelevation_R
cross_slope
)
(if (<= cross_slope 2)
(setq superelevation_L 2)
(setq superelevation_L cross_slope)
)
)
)
;; 当转点为非标准超高时，既横坡从superelevation_back% 超高到 superelevation% 变化到superelevation_front%
((and
(or (= num 0)
(= num 2)
)
Z_state
(= (length lst_seek) 3)
)
(progn
(if (= num 0)
(setq K (/ (- superelevation superelevation_back) lenth)
cross_slope (+ (* K L) superelevation_back)
) ; 入口缓和曲线
(setq K (/ (- superelevation superelevation_front) lenth)
cross_slope (- superelevation (* K L))
) ; 出口缓和曲线
)
(setq superelevation_R cross_slope)
(if (or (and (= (abs superelevation_back) 2) (= num 0))
; 入口缓和曲线时,其起始横坡是从2%
(and (= (abs superelevation_front) 2) (= num 2))
; 出口缓和曲线时，其结束横坡是从2%
)
;; 当该缓和曲线线元的横坡是从 superelevation% 变到-2%，或者从-2%变到 superelevation%
(progn
(if (<= cross_slope 2)
(setq superelevation_L 2)
(setq superelevation_L cross_slope)
)
)
;; 横坡不变到负数
(setq superelevation_L cross_slope)
)
)
)
;; 当线元 Line_segments 是圆曲线时
((and (= num 1)
Z_state
)
(setq superelevation_R superelevation
superelevation_L superelevation
)
) ; 处理圆曲线线元的横坡值函数结束
) ; cond 函数结束
;; 对求出来的superelevation_L superelevation_R 通过偏转系数reflex 进行镜像
(if (and (= reflex -1) Z_state)
(setq temp superelevation_L
superelevation_L (* superelevation_R -1)
superelevation_R (* temp -1)
)
) ; (if (= reflex -1) 函数结束
) ;(if superelevation 中的progn 函数结束
) ; (if superelevation 函数结束
)
Line_segments
)
;; 当superelevation 没有定义时
(if (or (not superelevation)
(= num 3)
)
(setq superelevation_L 2.0
superelevation_R -2.0
)
)
(list superelevation_L superelevation_R)
) ;calculate_superelevation 函数结束
;; (setq i 20 j 2 Z 12445 ) (setq i 12 j 2 Z 10530 )
;; (setq Line_segments (nth j (nth i group_Line_segments ) ) )
;; (setq tang ( calculate_superelevation z group_superelevation Line_segments ) )

;;  (setq group_turning_point ( create_turning_point_group )  )   
;;  (setq  group_Line_segments (car ( create_group_Line_segments   group_turning_point  6782.755 ))  )      
;; 输入参数 线元 Line_segments [( 转点号I j) R_start R_end  transition_parameter   reflex  quadrant_ang   Z_start  U_insert ]    
(defun calculate_superelevation 
                                (Z                   group_superelevation 
                                 Line_segments           / 
                                 lenth                   lst 
                                 lst_seek           Z_end 
                                 I                   num 
                                 superelevation           superelevation_R 
                                 superelevation_L  superelevation_back 
                                 slope_comparison  superelevation_front 
                                 cross_slope           K 
                                 Z_state           temp 
                                ) 
 
  ;;  (setq x_0 (car Line_segments ))    
  (apply 
    '(lambda (x_0 x_1 x_2 transition_parameter reflex x_5 Z_start x_7) 
 
       (setq I         (car x_0)                ; 转点的编号 
             num (cadr x_0)                ; 线元在转点中的编号 
       ) 
       (setq lst_seek (assoc I group_superelevation) 
                                        ; 寻找转点I 所对应的超高值 
       ) 
       (if (= (length lst_seek) 2) 
         ;; 当转点超高方式是标准超高时， 既从直线-2% 边坡到superelevation% 再边坡到 2%   
         (setq superelevation (cadr lst_seek)) 
         ;; 当转点超高方式是非标准超高时,  既从superelevation_back% 边坡到slope% 再边坡到superelevation_front%   
         (setq superelevation                ; 当前线元 最大坡度值 
                (cadr (cadr lst_seek)) 
               superelevation_back        ; 当前线元的起始坡度值 
                (car (cadr lst_seek)) 
               superelevation_front 
                (cadr (caddr lst_seek))        ; 当前线元的结束坡度值   
         ) 
       ) 
 
       (if (and        superelevation 
                (/= num 3)                ; 线元 Line_segments 不为直线时 
           ) 
         (progn 
           (cond 
             ((or (= num 0) 
                  (= num 2) 
              ) 
              (setq lenth (car transition_parameter)) 
                                        ; 当线元为缓和曲线时 
             ) 
             ((= num 1) 
              (setq lenth transition_parameter) 
                                        ; 圆曲线时 
             ) 
           ) 
           (setq lenth         (* lenth 1.0) 
                 Z_end         (+ Z_start lenth) 
                 L         (- Z z_start) 
                 Z_state (and 
                           (>= Z z_start) 
                           (<= Z z_end) 
                         ) 
           ) 
           (cond 
             ;;  该转点为 标准超高值 既 横坡从-2% 超高到 superelevation% 变化到 -2%   
             ((and 
                (or (= num 0) 
                    (= num 2) 
                ) 
                Z_state 
                (= (length lst_seek) 2) 
              ) 
              (progn 
                (setq K (/ (+ 2 superelevation) lenth)) 
                (if (= num 0) 
                  (setq cross_slope (+ (* K L) -2.0)) ; 入口缓和曲线   
                  (setq cross_slope (- superelevation (* K L))) 
                                        ; 出口缓和曲线 
                ) 
                (setq 
                  superelevation_R 
                   cross_slope 
                ) 
                (if (<= cross_slope 2) 
                  (setq superelevation_L 2) 
                  (setq superelevation_L cross_slope) 
                ) 
              ) 
             ) 
             ;; 当转点为非 标准超高时，  既横坡从superelevation_back% 超高到 superelevation% 变化到superelevation_front%   
             ((and 
                (or (= num 0) 
                    (= num 2) 
                ) 
                Z_state 
                (= (length lst_seek) 3) 
              ) 
              (progn 
                (if (= num 0) 
                  (setq        K            (/ (- superelevation superelevation_back) lenth) 
                        cross_slope (+ (* K L) superelevation_back) 
                  )                        ; 入口缓和曲线   
                  (setq        K            (/ (- superelevation superelevation_front) lenth) 
                        cross_slope (- superelevation (* K L)) 
                  )                        ; 出口缓和曲线 
                ) 
                (setq superelevation_R cross_slope) 
                (if (or        (and (= (abs superelevation_back)  2) (= num 0)) 
                                        ; 入口缓和曲线时,其起始横坡是从2%    
                        (and (= (abs superelevation_front)  2) (= num 2)) 
                                        ; 出口缓和曲线时 ，其结束横坡是从2%   
                    ) 
                  ;; 当该缓和曲线线元的横坡是从 superelevation% 变到-2%，或者从-2%变到 superelevation%   
                  (progn 
                    (if        (<= cross_slope 2) 
                      (setq superelevation_L 2) 
                      (setq superelevation_L cross_slope) 
                    ) 
                  ) 
                  ;; 横坡不变到负数   
                  (setq superelevation_L cross_slope) 
                ) 
              ) 
             ) 
             ;; 当线元 Line_segments 是圆曲线时    
             ((and (= num 1) 
                   Z_state 
              ) 
              (setq superelevation_R superelevation 
                    superelevation_L superelevation 
              ) 
             )                                ; 处理圆曲线线元的横坡值函数结束   
           )                                ; cond 函数结束 
           ;; 对求出来的superelevation_L superelevation_R 通过偏转系数reflex 进行镜像   
           (if (and (= reflex -1) Z_state) 
             (setq temp                    superelevation_L 
                   superelevation_L (* superelevation_R -1) 
                   superelevation_R (* temp -1) 
             ) 
           )                                ;  (if (= reflex -1)  函数结束 
         )                                ;(if superelevation 中的progn 函数结束   
       )                                ; (if superelevation 函数结束 
     ) 
    Line_segments 
  ) 
  ;; 当superelevation 没有定义时 
  (if (or (not superelevation) 
          (= num 3) 
      ) 
    (setq superelevation_L 2.0 
          superelevation_R -2.0 
    ) 
  ) 
  (list superelevation_L superelevation_R) 
)                                        ;calculate_superelevation 函数结束 
;; (setq i 20  j 2 Z 12445   )  (setq i 12  j 2 Z 10530   )         
;; (setq   Line_segments (nth j   (nth i group_Line_segments ) ) )    
;; (setq tang  ( calculate_superelevation   z  group_superelevation    Line_segments ) )

ashleytgg · 发表于 2016-10-13 16:20:37

再补一点

(defun change_group_turning_point_original
(group_turning_point_original
Z_road_start
/
group
group_2
group_string
lst_str
lst1
lst2
string
)
;; 把group_turning_point_original 数组转换成自己需要的形式
(setq lst_str (list "JD=" "state=" "E(Y)=" "N(X)="
"Lh1=" "R_start=" "R=" "R_end="
"Lh2="
)
)
(setq group_string
(mapcar '(lambda (lst)
(apply 'append lst)
)
group_turning_point_original
)
)
(setq group_2 ; (setq lst (cadr group_string))
(mapcar '(lambda (lst / state subset)
(setq state (cadr lst))
(setq subset
(append lst lst_str)
)
(if (not state)
(progn
(setq subset
(mapcar '(lambda (i)
(nth i subset)
)
(list 7 0 8 1 9 2 10 3 11 4 13 5 15 6)
)
)
(setq subset
(mapcar '(lambda (i / j lst1 lst2)
(setq j (* i 2))
(setq lst1 (nth j subset)
lst2 (nth (+ j 1) subset)
)
(cond
((= (type lst2) 'real)
(setq lst2 (rtos lst2))
)
((= (type lst2) 'int)
(setq lst2 (itoa lst2))
)
(t
(setq lst2
(vl-princ-to-string
lst2
)
)
)
) ;cond 函数结束
(list lst1 lst2)
)
(list 0 1 2 3 4 5 6)
)
)
)
(progn
(setq subset
(mapcar '(lambda (i)
(nth i subset)
)
(list 9 0 10 1 11 2 12 3 13 7 14 4 15 5 16 6 17 8)
)
)
(setq subset
(mapcar '(lambda (i / j lst1 lst2)
(setq j (* i 2))
(setq lst1 (nth j subset)
lst2 (nth (+ j 1) subset)
)
(cond
((= (type lst2) 'real)
(setq lst2 (rtos lst2))
)
((= (type lst2) 'int)
(setq lst2 (itoa lst2))
)
(t
(setq lst2
(vl-princ-to-string
lst2
)
)
)
) ;cond 函数结束
(list lst1 lst2)
)
(list 0 1 2 3 4 5 6 7 8)
)
)
)
) ; (if (not state) 函数结束
(mapcar '(lambda (lst)
(apply 'strcat lst)
)
subset
)
)
group_string
)
)
;; 把Z_road_start 加入数组 group_2 中的第一行最后一个元素
(if (not Z_road_start)
(setq Z_road_start 0)
)
(setq string (rtos Z_road_start)
string (strcat "Z_start=" string)
)
(setq lst1 (car group_2)
lst2 (append lst1 (list string))
group_2 (append (list lst2) (cdr group_2))
)
(mapcar
'(lambda (lst / str) ; (setq str (car group_2))
(setq str (vl-princ-to-string lst)
str (vl-string-left-trim "(" str)
str (vl-string-right-trim ")" str)
)
)
group_2
)
)
;; (setq tgg (change_group_turning_point_original group_turning_point_original Z_road_start ) )

(defun change_group_turning_point_original 
                                           (group_turning_point_original 
                                            Z_road_start 
                                            / 
                                            group 
                                            group_2 
                                            group_string 
                                            lst_str 
                                            lst1 
                                            lst2 
                                            string 
                                           ) 
 
  ;; 把group_turning_point_original 数组转换成 自己需要的形式   
  (setq        lst_str        (list "JD="         "state="   "E(Y)="    "N(X)=" 
                      "Lh1="         "R_start=" "R="       "R_end=" 
                      "Lh2=" 
                     ) 
  ) 
  (setq        group_string 
         (mapcar '(lambda (lst) 
                    (apply 'append lst) 
                  ) 
                 group_turning_point_original 
         ) 
  ) 
  (setq        group_2                                ; (setq lst (cadr group_string))   
         (mapcar '(lambda (lst / state subset) 
                    (setq state (cadr lst)) 
                    (setq subset 
                           (append lst lst_str) 
                    ) 
                    (if        (not state) 
                      (progn 
                        (setq subset 
                               (mapcar '(lambda        (i) 
                                          (nth i subset) 
                                        ) 
                                       (list 7 0 8 1 9 2 10 3 11 4 13 5 15 6) 
                               ) 
                        ) 
                        (setq subset 
                               (mapcar '(lambda        (i / j lst1 lst2) 
                                          (setq j (* i 2)) 
                                          (setq        lst1 (nth j subset) 
                                                lst2 (nth (+ j 1) subset) 
                                          ) 
                                          (cond 
                                            ((= (type lst2) 'real) 
                                             (setq lst2 (rtos lst2)) 
                                            ) 
                                            ((= (type lst2) 'int) 
                                             (setq lst2 (itoa lst2)) 
                                            ) 
                                            (t 
                                             (setq lst2 
                                                    (vl-princ-to-string 
                                                      lst2 
                                                    ) 
                                             ) 
                                            ) 
                                          ) ;cond 函数结束   
                                          (list lst1 lst2) 
                                        ) 
                                       (list 0 1 2 3 4 5 6) 
                               ) 
                        ) 
                      ) 
                      (progn 
                        (setq subset 
                               (mapcar '(lambda        (i) 
                                          (nth i subset) 
                                        ) 
                                       (list 9 0 10 1 11 2 12 3 13 7 14 4 15 5 16 6 17 8) 
                               ) 
                        ) 
                        (setq subset 
                               (mapcar '(lambda        (i / j lst1 lst2) 
                                          (setq j (* i 2)) 
                                          (setq        lst1 (nth j subset) 
                                                lst2 (nth (+ j 1) subset) 
                                          ) 
                                          (cond 
                                            ((= (type lst2) 'real) 
                                             (setq lst2 (rtos lst2)) 
                                            ) 
                                            ((= (type lst2) 'int) 
                                             (setq lst2 (itoa lst2)) 
                                            ) 
                                            (t 
                                             (setq lst2 
                                                    (vl-princ-to-string 
                                                      lst2 
                                                    ) 
                                             ) 
                                            ) 
                                          ) ;cond 函数结束   
                                          (list lst1 lst2) 
                                        ) 
                                       (list 0 1 2 3 4 5 6 7 8) 
                               ) 
                        ) 
                      ) 
                    )                        ; (if        (not state) 函数结束   
                    (mapcar '(lambda (lst) 
                               (apply 'strcat lst) 
                             ) 
                            subset 
                    ) 
                  ) 
                 group_string 
         ) 
  ) 
  ;; 把Z_road_start 加入数组 group_2 中的第一行 最后一个元素   
  (if (not Z_road_start) 
    (setq Z_road_start 0) 
  ) 
  (setq        string (rtos Z_road_start) 
        string (strcat "Z_start=" string) 
  ) 
  (setq        lst1        (car group_2) 
        lst2        (append lst1 (list string)) 
        group_2        (append (list lst2) (cdr group_2)) 
  ) 
  (mapcar 
    '(lambda (lst / str)                ; (setq str (car group_2))   
       (setq str (vl-princ-to-string lst) 
             str (vl-string-left-trim "(" str) 
             str (vl-string-right-trim ")" str) 
       ) 
     ) 
    group_2 
  ) 
) 
;; (setq tgg (change_group_turning_point_original group_turning_point_original Z_road_start ) )

;; 交点参数的文件格式, 当交点为完整缓和曲线时 : [ ( 转点号I nil) U_转点 ( Ls1 R Ls2 ) ] ，
;; 当交点为非完整缓和曲线交点时 : [ ( 转点号I t) U_转点 ( R_start R R_end Ls1 Ls2) ]
;; 输出变量group_turning_point_original : [ ( 转点号I nil) U_转点 ( Ls1 R Ls2 )]
(defun create_turning_point_group_original
(/
n
i
lst
group
group_turning_point_original
Z_road_start
)
;; group_turning_point_original 格式 [ ( 转点号I nil) U_转点 ( Ls1 R Ls2 ) ] , 完整缓和曲线时
;; or [ ( 转点号I nil) U_转点 ( R_start R R_end Ls1 Ls2) ] , 非完整缓和曲线交点时
(if nil
(setq group_turning_point_original (insert_交点_value))
(setq lst (insert_交点_str)
group_turning_point_original
(car lst)
Z_road_start
(cadr lst)
)
)
(list group_turning_point_original Z_road_start)
; 排序函数结束
) ; create_turning_point_group_2 函数结束
;; (setq group_turning_point_original (car ( create_turning_point_group_original ) ) )
;; 交点参数的文件格式, 当交点为完整缓和曲线时 : [ ( 转点号I nil) U_转点 ( Ls1 R Ls2 ) ] ，
;; 当交点为非完整缓和曲线交点时 : [ ( 转点号I t) U_转点 ( R_start R R_end Ls1 Ls2) ]
;; 输出变量turning_point_group : [ ( 转点号I nil) U_转点 ( Ls1 R Ls2 )(α1 α2 Δ Dist_1 Dist_2 )]
(defun create_turning_point_group
(group_turning_point_original
Z_road_start /
n i
lst group
;; 求交点距离角度时用到的参数
α1 α2
Δ Dist_1
Dist_2 lst_1
lst_2 lst_3
U_1 U_2
U_3
)
;; turning_point_group 格式 [ ( 转点号I nil) U_转点 ( Ls1 R Ls2 ) ] , 完整缓和曲线时
;; or [ ( 转点号I nil) U_转点 ( R_start R R_end Ls1 Ls2) ] , 非完整缓和曲线交点时
;; 对数组group_turning_point [ ( 转点号I nil) U_转点 ( Ls1 R Ls2 ) ] ，加入第三项 (α1 α2 Δ Dist_1 Dist_2 )
(setq i 0
group nil
n (length group_turning_point_original)
)
(repeat n
(cond
;;当转点为[第二个->倒数第二个] 转点时
((and (/= i 0) (/= i (- n 1)))
(progn
(setq lst_1 (nth (- i 1) group_turning_point_original))
(setq lst_2 (nth i group_turning_point_original))
(setq lst_3 (nth (+ i 1) group_turning_point_original))
(setq U_1 (cadr lst_1)
U_2 (cadr lst_2)
U_3 (cadr lst_3)
)
(setq Dist_1 (distance U_1 U_2)
Dist_2 (distance U_2 U_3)
)
(setq α1 (angle U_1 U_2)
α2 (angle U_2 U_3)
Δ (- α2 α1)
)
;; 对转角Δ 使其控制在(-pi pi) 之间
(cond
((and (>= Δ (* -1 pi))
(< Δ pi)
)
(setq Δ Δ)
)
((< Δ (* -1 pi))
(setq Δ (+ Δ (* 2 pi)))
)
((> Δ pi)
(setq Δ (- Δ (* 2 pi)))
)
)
(setq lst (list α1 α2 Δ Dist_1 Dist_2)
lst (append lst_2 (list lst))
group (cons lst group)
)
)
)
;;当为第一个转点时的情形起始转点->下一转点
((= i 0)
(progn
(setq lst_2 (nth i group_turning_point_original))
(setq lst_3 (nth (+ i 1) group_turning_point_original))
(setq
U_2 (cadr lst_2)
U_3 (cadr lst_3)
)
(setq Dist_1 0
Dist_2 (distance U_2 U_3)
α2 (angle U_2 U_3)
lst (list 0 α2 0 0 Dist_2)
)
(setq lst (append lst_2 (list lst))
group (cons lst group)
)
)
)
;; 当转点为最后一个转点时的情形上一转点->终点转点
((= i (- n 1))
(progn
(setq lst_1 (nth (- i 1) group_turning_point_original))
(setq lst_2 (nth i group_turning_point_original))
(setq U_1 (cadr lst_1)
U_2 (cadr lst_2)
)
(setq Dist_1 (distance U_1 U_2)
α1 (angle U_1 U_2)
lst (list α1 0 0 Dist_1 0)
)
(setq lst (append lst_2 (list lst))
group (cons lst group)
)
)
)
) ; cond 函数结束
(setq i (+ i 1))
) ; (repeat n 函数结束
(setq group_turning_point (reverse group))
(list group_turning_point Z_road_start)
; 排序函数结束
) ; create_turning_point_group_2 函数结束
;; (setq group_turning_point(car ( create_turning_point_group group_turning_point_original Z_road_start ) ) )
;; (setq tang (insert_交点_str ))
(defun insert_交点_str (/ fname f1 group lst str
X Y Lh1 Lh2 JD state
stake_Z str_seek
)
(setq
fname (getfiled "\n输入存放交点参数的文件" "" "txt" 1)
)
(if fname
(progn
(setq f1 (open fname
"r"
)
)
(setq group
nil
lst nil
group_2 nil
)
(while (setq lst (read-line f1))
(setq group
(cons lst group)
)
)
(setq group (reverse group))
(close f1)
(setq lst (car group))
(if (vl-string-search "Z_start=" lst)
(progn
;; 线路起始点的转点号
(setq JD (string_search lst "JD=" " "))
;;线路起始点的转点状态
(setq state (string_search lst "state=" " "))
;; 线路起始点的X坐标
(setq X (string_search lst "E(Y)=" " "))
;; 线路起始点的Y坐标
(setq Y (string_search lst "N(X)=" " "))
;; 线路起始点的桩号
(setq stake_Z (string_search lst "Z_start=" nil))
(setq group_2 (cons (list
(list JD state)
(list X Y)
(list 0 0 0)
)
group_2
)
)
)
) ;(if (setq i_start (vl-string-search "COORD" lst)) 函数结束
;; 对各交点进行计算 88888888888 888888888888 8888888888888
(setq group (cdr group))
(mapcar
'(lambda (lst / R_start R_end R)
; (setq i 10) (setq lst (nth i group))
(if (vl-string-search "JD" lst)
(progn
;; 第N个交点的转点号
(setq JD (string_search lst "JD=" " "))
;;第N个交点的转点状态
(setq state (string_search lst "state=" " "))
;; 第N个交点的X坐标
(setq X (string_search lst "E(Y)=" " "))
;; 第N个交点的Y坐标
(setq Y (string_search lst "N(X)=" " "))
;; 第N个交点的第一缓和曲线长度
(setq Lh1 (string_search lst "Lh1=" " "))
;; 第N个交点的半径
(setq R (string_search lst "R=" " "))
;; 第N个交点的出口缓和曲线长度
(setq Lh2 (string_search lst "Lh2=" nil))
;; 当交点中含有的缓和曲线为正规缓和曲线时
(if (not state)
(setq group_2 (cons (list (list JD state)
(list X Y)
(list Lh1 R Lh2)
)
group_2
)
)
) ; if (not state) 函数结束
;; 当交点中含有非正规缓和曲线时
(if state
(progn
;; 第N个交点的缓和曲线起始半径
(setq R_start (string_search lst "R_start=" " "))
;; 第N个交点的缓和曲线终点半径
(setq R_end (string_search lst "R_end=" " "))
(setq group_2
(cons (list (list JD state)
(list X Y)
(list R_start R R_end Lh1 Lh2)
)
group_2
)
)
)
) ; if state 函数结束
) ; prong 函数结束
) ;(if (vl-string-search "JD" lst)
)
group
) ;mapcar 函数结束
(setq group_2 (reverse group_2))
) ;progn
) ;(if fname 函数结束
(setq group_2
(vl-sort group_2
'(lambda (lst1 lst2)
(< (car (car lst1))
(car (car lst2))
)
)
)
)
(list group_2 stake_Z)
)
;; (setq tang (insert_交点_str ))
;;用复制的方法创建vertical_curve_group 数组
;;group_vertical_curve 数组形式 (转点号竖曲线变坡点桩号变坡点高程变坡点半径 )
;; 起始点结束点半径为0
(defun create_group_vertical_curve
(/ f1 lst_1 fname group_vertical_curve)
(if t
;; 当用标准字符参数输入时
(progn
(setq
fname (getfiled "\n输入存放竖曲线参数的文件" "" "txt" 1)
)
(if fname
(progn
(setq f1 (open fname
"r"
)
)
(setq group
nil
lst nil
group_2 nil
)
(while (setq lst (read-line f1))
(setq group
(cons lst group)
)
)
(setq group (reverse group))
(mapcar
'(lambda (lst / JD Z_stake H R) ; (setq lst (car group))
(setq JD (string_search lst "JD=" " "))
(setq Z_stake (string_search lst "桩号=" " "))
(setq H (string_search lst "高程=" " "))
(setq R (string_search lst "R=" nil))
(setq group_2 (cons (list JD Z_stake H R) group_2))
)
group
) ;mapcar 函数结束
(setq group_2 (reverse group_2))
) ;progn
) ;(if fname 函数结束
)
;; 当用原先参数输入时 8888888888888888888888888888888888888888888888 888888888888888888888888888888888
(progn
(setq fname (getfiled "输入存放竖曲线交点参数的文件" "" "txt" 1))
(if fname
(progn
(setq f1 (open fname
"r"
)
)
(setq group_vertical_curve
nil
lst nil
)
(while (setq lst (read-line f1))
(setq group_vertical_curve
(cons (read lst) group_vertical_curve)
)
)
;; while (/= list_1 nil)循环函数结束
)
)
(close f1)
(setq group_vertical_curve
(vl-sort group_vertical_curve
'(lambda (lst1 lst2)
(< (car lst1) (car lst2))
)
)
)
;; 排序函数结
)
)
)
;; (setq group_vertical_curve (create_group_vertical_curve ))
;;输出数组superelevation_group 其格式为 (转点号超高值 )
;; 或者 (转点号 (ZH点超高 HY点超高)(YH点超高 HZ点超高) )
(defun create_group_superelevation (/ group_superelevation
n lst
f1
)
(if nil
;; 当输入文件为原先超高文件时
(progn
(setq
fname
(getfiled "\n输入存放线路交点超高方式的数据表" "" "txt" 1)
)
(if fname
(progn
(setq f1 (open fname
"r"
)
)
(setq group_superelevation
nil
lst nil
)
(while (setq lst (read-line f1))
(setq group_superelevation
(cons (read lst) group_superelevation)
)
)
;; while (/= list_1 nil)循环函数结束
(close f1)
)
) ;(if fname 函数结束
)
;; 当输入文件为标准超高文件时
(progn
(setq
fname
(getfiled "\n输入存放线路交点超高方式的数据表" "" "txt" 1)
)
(if fname
(progn
(setq f1 (open fname
"r"
)
)
(setq group
nil
lst nil
)
(while (setq lst (read-line f1))
(setq group
(cons lst group)
)
)
(close f1)
)
) ;(if fname 函数结束
(setq group (reverse group))
(mapcar
'(lambda (lst /
JD superelevation
superelevation_start superelevation_end
superelevation_circle
) ; (setq lst (car group))
(setq JD (string_search lst "JD=" " "))
(if (vl-string-search "圆曲线超高值=" lst)
;; 当加点超高为不规则超高时
(progn
(setq superelevation_circle
(string_search
lst
"圆曲线超高值="
" "
)
superelevation_start
(string_search lst "起点超高值=" " ")
superelevation_end
(string_search lst "终点超高值=" nil)
)
(setq group_superelevation
(cons
(list JD
(list superelevation_start
superelevation_circle
)
(list superelevation_circle
superelevation_end
)
)
group_superelevation
)
)
)
(progn
(setq superelevation (string_search lst "超高值=" nil))
(setq group_superelevation
(cons (list JD superelevation)
group_superelevation
)
)
)
) ;(if (string_search lst "圆曲线超高值=" " ") 函数结束
)
group
) ;mapcar 函数结束
(setq group_superelevation (reverse group_superelevation))
)
) ; (if nil 函数结束
(setq group_superelevation
(vl-sort group_superelevation
'(lambda (lst1 lst2)
(< (car lst1)
(car lst2)
)
)
)
)
)
;; (setq group_superelevation (create_group_superelevation ) )
;; 计算线路加宽值8888888888 8888888888888888888 88888888888888888888 88888888888888888888
;;从文件中写入加宽数组，输出数组group_widen 其格式为 ( 转点号 widen 线路加宽值)
(defun write_into_group_widen (/ lst fname f1 group group_widen)
(if nil
(progn
(setq
fname (getfiled "\n输入存放线路交点加宽参数的文件" "" "txt" 1)
)
(if (/= fname nil)
(progn
(setq f1 (open fname
"r"
)
)
(while (setq list_1 (read-line f1))
(setq group (cons list_1 group))
)
(setq group (reverse group))
(setq
group_widen
nil
)
(setq group_widen
(mapcar '(lambda (x)
(read x)
)
group
)
)
(close f1) ;关闭文件fname
) ; progn 函数结束
) ;if (/= fname nil) 函数结束
)
;; 用标准参数文件创建 group_widen 数组
(progn
(setq
fname (getfiled "\n输入存放线路交点加宽参数的文件" "" "txt" 1)
)
(if fname
(progn
(setq f1 (open fname
"r"
)
)
(setq group
nil
lst nil
group_2 nil
)
(while (setq lst (read-line f1))
(setq group
(cons lst group)
)
)
(setq group (reverse group))
(mapcar
'(lambda (lst / JD Wide)
(setq JD (string_search lst "JD=" " "))
(setq Wide (string_search lst "加宽值=" nil))
(setq group_2 (cons (list JD Wide) group_2))
)
group
) ;mapcar 函数结束
(setq group_widen (reverse group_2))
) ;progn
)
(close f1)
)
) ;(if nil 函数结束
(setq group_widen
(vl-sort group_widen
'(lambda (lst1 lst2)
(< (car lst1) (car lst2))
)
)
)
;; 排序函数结
) ; write_into_group_widen 函数结束
;; 88888888888888888888888888888888888 (write_into_group_widen )
;; (setq group_widen (write_into_group_widen))
;; 计算线路加宽值8888888888 8888888888888888888 88888888888888888888 88888888888888888888
;;从文件中写入设计桩号数组，
(defun write_into_group_stake_mark (/ lst fname f1 group group_widen)
(if nil
(progn
(setq
fname (getfiled "\n输入存放线路设计桩号参数的文件" "" "txt" 1)
)
(if (/= fname nil)
(progn
(setq f1 (open fname
"r"
)
)
(while (setq list_1 (read-line f1))
(setq group (read (cons list_1 group)))
)
(setq group (reverse group))
(setq group_stake_mark (apply 'append group))
(close f1) ;关闭文件fname
) ; progn 函数结束
) ;if (/= fname nil) 函数结束
)
;; 用标准参数文件创建group_stake_mark 数组
(progn
(setq
fname (getfiled "\n输入存放线路设计桩号参数的文件" "" "txt" 1)
)
(if fname
(progn
(setq f1 (open fname
"r"
)
)
(setq group nil)
(while (setq lst (read-line f1))
(setq group (cons lst group))
)
(setq group (reverse group))
(setq lst nil
group_2 nil
)
(mapcar
'(lambda (lst / stake_mark) ; (setq lst ( car group))
(setq stake_mark (string_search lst "设计桩号:" nil))
(setq group_2 (cons stake_mark group_2))
)
group
) ;mapcar 函数结束
(setq group_2 (reverse group_2)
group_stake_mark (apply 'append group_2)
)
) ;progn
)
(close f1)
)
) ;(if nil 函数结束
group_stake_mark
) ; write_into_group_widen 函数结束
;; 88888888888888888888888888888888888 (write_into_group_widen )
;; (setq tgg (write_into_group_stake_mark))
;; 创建一个寻找字符串str 中str_sub 的函数
;; 返回参数为字符中str 中str_search str_stop 之间的字符串
(defun string_search (str str_search str_stop / n i_1 i_2 string_out)
(setq n (strlen str_search))
(setq
i_1 (vl-string-search str_search str)
)
(if i_1
(progn
(if str_stop
(progn
(setq
i_2 (vl-string-search
str_stop
str
(+ (+ i_1 n) 1)
)
)
(if i_2
(setq
string (substr str
(+ (+ i_1 n) 1)
(- i_2 (+ i_1 n))
)
)
(progn
(alert (strcat "\n您输入的表格:"
str
"中"
(substr str (+ i_1 1))
"的后面无法找到:"
str_stop
"!"
)
)
(quit)
)
)
) ;progn 函数结束
;; 当str_stop 没有定义时
(progn
(setq
string (substr str
(+ (+ i_1 n) 1)
)
)
;; 当字符串string是 " 123.4 345.9 tyu " 的形式时
(if (vl-string-search " " string )
(setq string (strcat "(" string ")"))
)
)
) ; (if str_stop 函数结束
(setq string_out (read string))
)
(progn
(alert
(strcat "\n您输入的表格:" str
" 中无法寻找到: " str_search
" !!!"
)
)
(quit)
)
) ; (if i_1 函数结束
)
;; (setq str " tang i_love ,you " str_search "tang" str_stop "," )
;; (setq tgg (string_search str str_search str_stop ) )
;; (setq tgg (string_search "tang i_love ,you " "hong" "," ) )
;; (setq tgg (string_search "tang i_love ,you " "i" "hate" ) )
;; (setq tgg (string_search "唐国庚,you " "唐国" "庚" ) )
(defun insert_交点_value (/ fname f1 group group_turning_point n i)
(setq fname (getfiled "输入存放交点参数的文件" "" "txt" 1))
(setq f1 (open fname "r"))
(setq group nil)
(while (setq lst (read-line f1))
(setq group (cons lst group))
) ; while (/= list nil)循环函数结束
(close f1)
(setq i 0
group_turning_point
nil
n (length group)
)
(repeat n
(setq lst (read (nth i group))
group_turning_point
(cons lst group_turning_point)
)
(setq i (+ i 1))
)
(setq group_turning_point
(vl-sort group_turning_point
'(lambda (lst1 lst2)
(< (car (car lst1))
(car (car lst2))
)
)
)
)
)
;; (setq tang (insert_交点_value ))

;; 交点参数的文件格式, 当交点为完整缓和曲线时 :  [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )  ] ， 
;; 当交点为非完整缓和曲线交点时 :   [ ( 转点号I t)  U_转点   ( R_start  R  R_end  Ls1   Ls2) ]   
;; 输出变量group_turning_point_original : [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )]    
(defun create_turning_point_group_original 
                                           (/ 
                                            n 
                                            i 
                                            lst 
                                            group 
                                            group_turning_point_original 
                                            Z_road_start 
                                           ) 
  ;; group_turning_point_original 格式 [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )  ]  , 完整缓和曲线时   
  ;;  or [ ( 转点号I nil)  U_转点   ( R_start R  R_end  Ls1   Ls2) ]  , 非完整缓和曲线交点时    
  (if nil 
    (setq group_turning_point_original (insert_交点_value)) 
    (setq lst (insert_交点_str) 
          group_turning_point_original 
           (car lst) 
          Z_road_start 
           (cadr lst) 
    ) 
  ) 
  (list group_turning_point_original Z_road_start) 
 
                                        ; 排序函数结束 
)                                        ;  create_turning_point_group_2 函数结束   
;; (setq group_turning_point_original (car ( create_turning_point_group_original ) ) )    
 
 
 
;; 交点参数的文件格式, 当交点为完整缓和曲线时 :  [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )  ] ， 
;; 当交点为非完整缓和曲线交点时 :   [ ( 转点号I t)  U_转点   ( R_start  R  R_end  Ls1   Ls2) ]   
;; 输出变量turning_point_group : [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )(α1  α2   Δ Dist_1   Dist_2 )]      
(defun create_turning_point_group 
                                  (group_turning_point_original 
                                   Z_road_start        / 
                                   n                i 
                                   lst                group 
                                   ;; 求交点距离角度时用到的参数   
                                   α1                α2 
                                   Δ                Dist_1 
                                   Dist_2        lst_1 
                                   lst_2        lst_3 
                                   U_1                U_2 
                                   U_3 
                                  ) 
  ;; turning_point_group 格式 [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )  ]  , 完整缓和曲线时   
  ;;  or [ ( 转点号I nil)  U_转点   ( R_start R  R_end  Ls1   Ls2) ]  , 非完整缓和曲线交点时    
 
  ;; 对数组group_turning_point  [ ( 转点号I nil)  U_转点 ( Ls1 R Ls2 )  ] ， 加入第三项 (α1  α2   Δ Dist_1   Dist_2 )   
  (setq        i     0 
        group nil 
        n     (length group_turning_point_original) 
  ) 
  (repeat n 
    (cond 
      ;;当转点为[第二个->倒数第二个] 转点时   
      ((and (/= i 0) (/= i (- n 1))) 
       (progn 
         (setq lst_1 (nth (- i 1) group_turning_point_original)) 
         (setq lst_2 (nth i group_turning_point_original)) 
         (setq lst_3 (nth (+ i 1) group_turning_point_original)) 
         (setq U_1 (cadr lst_1) 
               U_2 (cadr lst_2) 
               U_3 (cadr lst_3) 
         ) 
         (setq Dist_1 (distance U_1 U_2) 
               Dist_2 (distance U_2 U_3) 
         ) 
         (setq α1 (angle U_1 U_2) 
               α2 (angle U_2 U_3) 
               Δ  (- α2 α1) 
         ) 
         ;; 对转角Δ 使其控制在(-pi pi) 之间 
         (cond 
           ((and (>= Δ (* -1 pi)) 
                 (< Δ pi) 
            ) 
            (setq Δ Δ) 
           ) 
           ((< Δ (* -1 pi)) 
            (setq Δ (+ Δ (* 2 pi))) 
           ) 
           ((> Δ pi) 
            (setq Δ (- Δ (* 2 pi))) 
           ) 
         ) 
         (setq lst   (list α1 α2 Δ Dist_1 Dist_2) 
               lst   (append lst_2 (list lst)) 
               group (cons lst group) 
         ) 
       ) 
      ) 
      ;;当为第一个转点时的情形 起始转点->下一转点 
      ((= i 0) 
       (progn 
         (setq lst_2 (nth i group_turning_point_original)) 
         (setq lst_3 (nth (+ i 1) group_turning_point_original)) 
         (setq 
           U_2 (cadr lst_2) 
           U_3 (cadr lst_3) 
         ) 
         (setq Dist_1 0 
               Dist_2 (distance U_2 U_3) 
               α2    (angle U_2 U_3) 
               lst    (list 0 α2 0 0 Dist_2) 
         ) 
         (setq lst   (append lst_2 (list lst)) 
               group (cons lst group) 
         ) 
       ) 
      ) 
      ;; 当转点为最后一个转点时的情形 上一转点->终点转点    
      ((= i (- n 1)) 
       (progn 
         (setq lst_1 (nth (- i 1) group_turning_point_original)) 
         (setq lst_2 (nth i group_turning_point_original)) 
         (setq U_1 (cadr lst_1) 
               U_2 (cadr lst_2) 
         ) 
         (setq Dist_1 (distance U_1 U_2) 
               α1    (angle U_1 U_2) 
 
               lst    (list α1 0 0 Dist_1 0) 
         ) 
         (setq lst   (append lst_2 (list lst)) 
               group (cons lst group) 
         ) 
       ) 
      ) 
    )                                        ; cond  函数结束   
    (setq i (+ i 1)) 
  )                                        ; (repeat n  函数结束 
  (setq group_turning_point (reverse group)) 
  (list group_turning_point Z_road_start) 
 
                                        ; 排序函数结束 
)                                        ;  create_turning_point_group_2 函数结束   
;; (setq group_turning_point(car  ( create_turning_point_group   group_turning_point_original  Z_road_start )  ) )    
 
 
 
 
 
;; (setq tang (insert_交点_str ))    
(defun insert_交点_str (/      fname  f1     group  lst           str 
                        X      Y      Lh1    Lh2    JD           state 
                        stake_Z              str_seek 
                       ) 
  (setq 
    fname (getfiled "\n输入存放交点参数的文件" "" "txt" 1) 
  ) 
  (if fname 
    (progn 
      (setq f1 (open fname 
                     "r" 
               ) 
      ) 
      (setq group 
             nil 
            lst        nil 
            group_2 nil 
      ) 
      (while (setq lst (read-line f1)) 
        (setq group 
               (cons lst group) 
        ) 
      ) 
      (setq group (reverse group)) 
      (close f1) 
      (setq lst (car group)) 
      (if (vl-string-search "Z_start=" lst) 
        (progn 
          ;; 线路起始点的转点号 
          (setq JD (string_search lst "JD=" " ")) 
          ;;线路起始点的转点状态   
          (setq state (string_search lst "state=" " ")) 
          ;; 线路起始点的X坐标   
          (setq X (string_search lst "E(Y)=" " ")) 
          ;; 线路起始点的Y坐标    
          (setq Y (string_search lst "N(X)=" " ")) 
          ;; 线路起始点的桩号   
          (setq stake_Z (string_search lst "Z_start=" nil)) 
          (setq        group_2        (cons (list 
                                (list JD state) 
                                (list X Y) 
                                (list 0 0 0) 
                              ) 
                              group_2 
                        ) 
          ) 
        ) 
      )                                        ;(if (setq i_start (vl-string-search "COORD" lst)) 函数结束 
      ;; 对各交点进行计算  88888888888        888888888888          8888888888888                         
      (setq group (cdr group)) 
      (mapcar 
        '(lambda (lst / R_start R_end R) 
                                        ;   (setq i 10) (setq lst (nth i group))    
           (if (vl-string-search "JD" lst) 
             (progn 
               ;; 第N个交点的转点号   
               (setq JD (string_search lst "JD=" " ")) 
               ;;第N个交点的转点状态   
               (setq state (string_search lst "state=" " ")) 
               ;; 第N个交点的X坐标 
               (setq X (string_search lst "E(Y)=" " ")) 
               ;; 第N个交点的Y坐标 
               (setq Y (string_search lst "N(X)=" " ")) 
               ;; 第N个交点的第一缓和曲线长度   
               (setq Lh1 (string_search lst "Lh1=" " ")) 
               ;; 第N个交点的半径   
               (setq R (string_search lst "R=" " ")) 
               ;; 第N个交点的出口缓和曲线长度 
               (setq Lh2 (string_search lst "Lh2=" nil)) 
               ;; 当交点中含有的缓和曲线为正规缓和曲线时   
               (if (not state) 
                 (setq group_2 (cons (list (list JD state) 
                                           (list X Y) 
                                           (list Lh1 R Lh2) 
                                     ) 
                                     group_2 
                               ) 
                 ) 
 
               )                        ; if (not state) 函数结束 
               ;; 当交点中含有非正规缓和曲线时    
               (if state 
                 (progn 
                   ;; 第N个交点的缓和曲线起始半径 
                   (setq R_start (string_search lst "R_start=" " ")) 
                   ;; 第N个交点的缓和曲线终点半径    
                   (setq R_end (string_search lst "R_end=" " ")) 
                   (setq group_2 
                          (cons        (list (list JD state) 
                                      (list X Y) 
                                      (list R_start R R_end Lh1 Lh2) 
                                ) 
                                group_2 
                          ) 
                   ) 
                 ) 
               )                        ; if state 函数结束 
             )                                ; prong 函数结束   
           )                                ;(if          (vl-string-search "JD" lst)   
         ) 
        group 
      )                                        ;mapcar  函数结束 
      (setq group_2 (reverse group_2)) 
 
    )                                        ;progn 
  )                                        ;(if fname 函数结束 
  (setq        group_2 
         (vl-sort group_2 
                  '(lambda (lst1 lst2) 
                     (<        (car (car lst1)) 
                        (car (car lst2)) 
                     ) 
                   ) 
         ) 
  ) 
  (list group_2 stake_Z) 
) 
;; (setq tang (insert_交点_str )) 
 
 
 
;;用复制的方法创建vertical_curve_group 数组 
;;group_vertical_curve  数组形式 (转点号  竖曲线变坡点桩号 变坡点高程  变坡点半径 ) 
;; 起始点 结束点 半径为0 
(defun create_group_vertical_curve 
       (/ f1 lst_1 fname group_vertical_curve) 
  (if t 
    ;; 当用标准字符参数输入时    
    (progn 
      (setq 
        fname (getfiled "\n输入存放竖曲线参数的文件" "" "txt" 1) 
      ) 
      (if fname 
        (progn 
          (setq        f1 (open fname 
                         "r" 
                   ) 
          ) 
          (setq        group 
                 nil 
                lst nil 
                group_2        nil 
          ) 
          (while (setq lst (read-line f1)) 
            (setq group 
                   (cons lst group) 
            ) 
          ) 
          (setq group (reverse group)) 
          (mapcar 
            '(lambda (lst / JD Z_stake H R) ; (setq lst (car group))    
               (setq JD (string_search lst "JD=" " ")) 
               (setq Z_stake (string_search lst "桩号=" " ")) 
               (setq H (string_search lst "高程=" " ")) 
               (setq R (string_search lst "R=" nil)) 
               (setq group_2 (cons (list JD Z_stake H R) group_2)) 
             ) 
            group 
          )                                ;mapcar  函数结束 
          (setq group_2 (reverse group_2)) 
 
        )                                ;progn 
      )                                        ;(if fname 函数结束 
    ) 
 
    ;; 当用原先参数输入时 8888888888888888888888888888888888888888888888  888888888888888888888888888888888 
    (progn 
      (setq fname (getfiled "输入存放竖曲线交点参数的文件" "" "txt" 1)) 
      (if fname 
        (progn 
          (setq        f1 (open fname 
                         "r" 
                   ) 
          ) 
          (setq        group_vertical_curve 
                 nil 
                lst nil 
          ) 
          (while (setq lst (read-line f1)) 
            (setq group_vertical_curve 
                   (cons (read lst) group_vertical_curve) 
            ) 
          ) 
          ;; while (/= list_1 nil)循环函数结束 
        ) 
      ) 
      (close f1) 
      (setq group_vertical_curve 
             (vl-sort group_vertical_curve 
                      '(lambda (lst1 lst2) 
                         (< (car lst1) (car lst2)) 
                       ) 
             ) 
      ) 
      ;; 排序函数结 
    ) 
  ) 
) 
;; (setq group_vertical_curve  (create_group_vertical_curve ))      
 
 
 
 
;;输出  数组superelevation_group 其格式为 (转点号   超高值 )    
;; 或者 (转点号 (ZH点超高  HY点超高)(YH点超高  HZ点超高)  )    
(defun create_group_superelevation (/                  group_superelevation 
                                    n                  lst 
                                    f1 
                                   ) 
  (if nil 
    ;; 当输入文件为原先超高文件时    
    (progn 
      (setq 
        fname 
         (getfiled "\n输入存放线路交点超高方式的数据表" "" "txt" 1) 
      ) 
      (if fname 
        (progn 
          (setq        f1 (open fname 
                         "r" 
                   ) 
          ) 
          (setq        group_superelevation 
                 nil 
                lst nil 
          ) 
          (while (setq lst (read-line f1)) 
            (setq group_superelevation 
                   (cons (read lst) group_superelevation) 
            ) 
          ) 
          ;; while (/= list_1 nil)循环函数结束 
          (close f1) 
 
        ) 
      )                                        ;(if fname 函数结束 
    ) 
    ;; 当输入文件为标准超高文件时 
    (progn 
      (setq 
        fname 
         (getfiled "\n输入存放线路交点超高方式的数据表" "" "txt" 1) 
      ) 
      (if fname 
        (progn 
          (setq        f1 (open fname 
                         "r" 
                   ) 
          ) 
          (setq        group 
                 nil 
                lst nil 
          ) 
          (while (setq lst (read-line f1)) 
            (setq group 
                   (cons lst group) 
            ) 
          ) 
          (close f1) 
        ) 
      )                                        ;(if fname 函数结束 
      (setq group (reverse group)) 
      (mapcar 
        '(lambda (lst                       / 
                  JD                       superelevation 
                  superelevation_start superelevation_end 
                  superelevation_circle 
                 )                        ; (setq lst (car group))    
           (setq JD (string_search lst "JD=" " ")) 
           (if (vl-string-search "圆曲线超高值=" lst) 
             ;; 当加点超高为不规则超高时   
             (progn 
               (setq superelevation_circle 
                      (string_search 
                        lst 
                        "圆曲线超高值=" 
                        " " 
                      ) 
                     superelevation_start 
                      (string_search lst "起点超高值=" " ") 
                     superelevation_end 
                      (string_search lst "终点超高值=" nil) 
               ) 
               (setq group_superelevation 
                      (cons 
                        (list JD 
                              (list superelevation_start 
                                    superelevation_circle 
                              ) 
                              (list superelevation_circle 
                                    superelevation_end 
                              ) 
                        ) 
                        group_superelevation 
                      ) 
               ) 
             ) 
             (progn 
               (setq superelevation (string_search lst "超高值=" nil)) 
               (setq group_superelevation 
                      (cons (list JD superelevation) 
                            group_superelevation 
                      ) 
 
               ) 
             ) 
           )                                ;(if (string_search lst "圆曲线超高值=" " ") 函数结束    
         ) 
        group 
      )                                        ;mapcar  函数结束 
      (setq group_superelevation (reverse group_superelevation)) 
    ) 
  )                                        ; (if nil 函数结束    
  (setq        group_superelevation 
         (vl-sort group_superelevation 
                  '(lambda (lst1 lst2) 
                     (<        (car lst1) 
                        (car lst2) 
                     ) 
                   ) 
         ) 
  ) 
) 
;; (setq group_superelevation (create_group_superelevation ) )    
 
 
 
 
;; 计算线路加宽值8888888888            8888888888888888888              88888888888888888888           88888888888888888888    
;;从文件中写入加宽数组 ，  输出 数组group_widen 其格式为 ( 转点号   widen 线路加宽值)   
(defun write_into_group_widen (/ lst fname f1 group group_widen) 
 
  (if nil 
    (progn 
      (setq 
        fname (getfiled "\n输入存放线路交点加宽参数的文件" "" "txt" 1) 
      ) 
      (if (/= fname nil) 
        (progn 
          (setq        f1 (open fname 
                         "r" 
                   ) 
          ) 
          (while (setq list_1 (read-line f1)) 
            (setq group (cons list_1 group)) 
          ) 
          (setq group (reverse group)) 
          (setq 
            group_widen 
             nil 
          ) 
          (setq        group_widen 
                 (mapcar '(lambda (x) 
                            (read x) 
                          ) 
                         group 
                 ) 
          ) 
          (close f1)                        ;关闭文件fname 
        )                                ;  progn 函数结束 
      )                                        ;if (/= fname nil) 函数结束 
    ) 
    ;; 用标准参数文件创建 group_widen 数组    
    (progn 
      (setq 
        fname (getfiled "\n输入存放线路交点加宽参数的文件" "" "txt" 1) 
      ) 
      (if fname 
        (progn 
          (setq        f1 (open fname 
                         "r" 
                   ) 
          ) 
          (setq        group 
                 nil 
                lst nil 
                group_2        nil 
          ) 
          (while (setq lst (read-line f1)) 
            (setq group 
                   (cons lst group) 
            ) 
          ) 
          (setq group (reverse group)) 
          (mapcar 
            '(lambda (lst / JD Wide) 
               (setq JD (string_search lst "JD=" " ")) 
               (setq Wide (string_search lst "加宽值=" nil)) 
               (setq group_2 (cons (list JD Wide) group_2)) 
             ) 
            group 
          )                                ;mapcar  函数结束 
          (setq group_widen (reverse group_2)) 
 
        )                                ;progn 
      ) 
      (close f1) 
    ) 
  )                                        ;(if nil 函数结束 
  (setq        group_widen 
         (vl-sort group_widen 
                  '(lambda (lst1 lst2) 
                     (< (car lst1) (car lst2)) 
                   ) 
         ) 
  ) 
  ;; 排序函数结 
)                                        ; write_into_group_widen 函数结束 
;; 88888888888888888888888888888888888       (write_into_group_widen )       
;;  (setq  group_widen (write_into_group_widen))   
 
 
 
 
 
;; 计算线路加宽值8888888888            8888888888888888888              88888888888888888888           88888888888888888888    
;;从文件中写入设计桩号数组 ，   
(defun write_into_group_stake_mark (/ lst fname f1 group group_widen) 
 
  (if nil 
    (progn 
      (setq 
        fname (getfiled "\n输入存放线路设计桩号参数的文件" "" "txt" 1) 
      ) 
      (if (/= fname nil) 
        (progn 
          (setq        f1 (open fname 
                         "r" 
                   ) 
          ) 
          (while (setq list_1 (read-line f1)) 
            (setq group (read (cons list_1 group))) 
          ) 
          (setq group (reverse group)) 
          (setq group_stake_mark (apply 'append group)) 
          (close f1)                        ;关闭文件fname 
        )                                ;  progn 函数结束 
      )                                        ;if (/= fname nil) 函数结束 
    ) 
    ;; 用标准参数文件创建group_stake_mark 数组    
    (progn 
      (setq 
        fname (getfiled "\n输入存放线路设计桩号参数的文件" "" "txt" 1) 
      ) 
      (if fname 
        (progn 
          (setq        f1 (open fname 
                         "r" 
                   ) 
          ) 
          (setq group nil) 
          (while (setq lst (read-line f1)) 
            (setq group (cons lst group)) 
          ) 
          (setq group (reverse group)) 
          (setq        lst nil 
                group_2        nil 
          ) 
          (mapcar 
            '(lambda (lst / stake_mark)        ; (setq lst ( car group))   
               (setq stake_mark (string_search lst "设计桩号:" nil)) 
               (setq group_2 (cons stake_mark group_2)) 
             ) 
            group 
          )                                ;mapcar  函数结束 
          (setq        group_2                 (reverse group_2) 
                group_stake_mark (apply 'append group_2) 
          ) 
 
 
        )                                ;progn 
      ) 
      (close f1) 
    ) 
  )                                        ;(if nil 函数结束 
  group_stake_mark 
)                                        ; write_into_group_widen 函数结束 
;; 88888888888888888888888888888888888       (write_into_group_widen )       
;;  (setq tgg (write_into_group_stake_mark))    
 
 
 
 
 
;; 创建一个寻找字符串str 中str_sub 的函数 
;; 返回参数为 字符中str 中str_search str_stop 之间的 字符串   
(defun string_search (str str_search str_stop / n i_1 i_2 string_out) 
  (setq n (strlen str_search)) 
  (setq 
    i_1        (vl-string-search str_search str) 
  ) 
  (if i_1 
    (progn 
      (if str_stop 
        (progn 
          (setq 
            i_2        (vl-string-search 
                  str_stop 
                  str 
                  (+ (+ i_1 n) 1) 
                ) 
          ) 
          (if i_2 
            (setq 
              string (substr str 
                             (+ (+ i_1 n) 1) 
                             (- i_2 (+ i_1 n)) 
                     ) 
            ) 
            (progn 
              (alert (strcat "\n您输入的表格:" 
                             str 
                             "中" 
                             (substr str (+ i_1 1)) 
                             "的后面无法找到:" 
                             str_stop 
                             "!" 
                     ) 
              ) 
              (quit) 
            ) 
          ) 
        )                                ;progn 函数结束 
        ;; 当str_stop 没有定义时   
        (progn 
          (setq 
            string (substr str 
                           (+ (+ i_1 n) 1) 
                   ) 
          ) 
          ;; 当字符串string是 " 123.4 345.9 tyu " 的形式时   
          (if (vl-string-search " "  string ) 
            (setq string (strcat "(" string ")")) 
          ) 
        ) 
      )                                        ; (if str_stop 函数结束 
      (setq string_out (read string)) 
    ) 
    (progn 
      (alert 
        (strcat        "\n您输入的表格:"  str 
                " 中无法寻找到:  " str_search 
                "  !!!" 
               ) 
      ) 
      (quit) 
    ) 
  )                                        ; (if i_1 函数结束 
) 
;; (setq str "  tang i_love ,you "  str_search "tang"  str_stop "," )   
;; (setq tgg (string_search  str  str_search  str_stop ) )    
;; (setq tgg (string_search "tang i_love ,you "  "hong"  "," ) )    
;; (setq tgg (string_search "tang i_love ,you "  "i"  "hate" ) )    
;; (setq tgg (string_search "唐国庚,you "  "唐国"  "庚" ) )    
 
 
(defun insert_交点_value (/ fname f1 group group_turning_point n i) 
  (setq fname (getfiled "输入存放交点参数的文件" "" "txt" 1)) 
  (setq f1 (open fname "r")) 
  (setq group nil) 
  (while (setq lst (read-line f1)) 
    (setq group (cons lst group)) 
  )                                        ; while (/= list  nil)循环函数结束 
  (close f1) 
  (setq        i 0 
        group_turning_point 
         nil 
        n (length group) 
  ) 
  (repeat n 
    (setq lst                      (read (nth i group)) 
          group_turning_point 
                              (cons lst group_turning_point) 
    ) 
    (setq i (+ i 1)) 
  ) 
  (setq        group_turning_point 
         (vl-sort group_turning_point 
                  '(lambda (lst1 lst2) 
                     (<        (car (car lst1)) 
                        (car (car lst2)) 
                     ) 
                   ) 
         ) 
  ) 
) 
;; (setq tang (insert_交点_value ))

(defun write_group_vertical_curve
(group_vertical_curve
/ fname
f1 group
group_2 group_string
lst_str string
)
(if t
(progn
(setq
fname (getfiled "\n输入要选择竖曲线交点参数的文件" "" "txt" 1)
)
(setq f1 (open fname
"r"
)
)
(setq group
nil
lst nil
group_2 nil
)
(while (setq lst (read-line f1))
(setq group
(cons lst group)
)
)
(close f1)
(setq group (reverse group))
(setq group_vertical_curve (mapcar 'read group))
)
)
;; 把group 数组转换成自己需要的形式
(setq group_string
(mapcar '(lambda (lst)
(mapcar '(lambda (x)
(cond
((= (type x) 'real)
(rtos x)
)
((= (type x) 'int)
(itoa x)
)
(t
(vl-princ-to-string
x
)
)
) ;cond 函数结束
)
lst
)
)
group_vertical_curve
)
)
(setq lst_str (list "JD=" "桩号=" "高程=" "R="))
(setq group_2
(mapcar '(lambda (lst / subset)
(setq subset
(append lst lst_str)
)
(setq subset
(mapcar '(lambda (i)
(nth i subset)
)
(list 4 0 5 1 6 2 7 3)
)
)
(setq subset
(mapcar '(lambda (i / j)
(setq j (* i 2))
(list (nth j subset)
(nth (+ j 1) subset)
)
)
(list 0 1 2 3)
)
)
(mapcar '(lambda (lst)
(apply 'strcat lst)
)
subset
)
)
group_string
)
)
(setq
fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1)
)
(setq f1 (open fname
"w"
)
)
(mapcar
'(lambda (lst / str) ; (setq str (car group_2))
(setq str (vl-princ-to-string lst)
str (vl-string-left-trim "(" str)
str (vl-string-right-trim ")" str)
)
(write-line str f1)
)
group_2
)
(close f1)
)
;; (write_group_vertical_curve group_vertical_curve )
;; (setq lst (insert_交点_str ) Z_road_start (cadr lst) group_turning_point (car lst))
(defun write_group_turning_point_original
(Z_road_start
group_turning_point_original
/
fname
f1
group
group_2
group_string
lst_str
lst1
lst2
string
)
(if nil
(progn
(setq
fname (getfiled "\n输入要选择的交点参数文件" "" "txt" 1)
)
(setq f1 (open fname
"r"
)
)
(setq group
nil
lst nil
group_2 nil
)
(while (setq lst (read-line f1))
(setq group
(cons lst group)
)
)
(close f1)
(setq group (reverse group))
(setq group_turning_point_original (mapcar 'read group))
)
)
(if (not Z_road_start)
(setq Z_road_start 0)
)
(setq group_2 (change_group_turning_point_original
group_turning_point_original
Z_road_start
)
)
(setq
fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1)
)
(setq f1 (open fname
"w"
)
)
(mapcar
'(lambda (str) ; (setq str (car group_2))
(write-line str f1)
)
group_2
)
(close f1)
)
;; (write_group_turning_point_original Z_road_start group_turning_point_original )
;; (write_group_turning_point_original 60100 group_turning_point_original )
;; 把超高数组group_superelevation 写入指定文件中
(defun write_group_superelevation
(group_superelevation
/ fname
f1 group
group_2 group_string
lst_str string
)
(if t
(progn
(setq
fname
(getfiled "\n输入存放线路交点超高方式的数据表" "" "txt" 1)
)
(setq f1 (open fname
"r"
)
)
(setq group
nil
lst nil
group_2 nil
)
(while (setq lst (read-line f1))
(setq group
(cons lst group)
)
)
(close f1)
(setq group (reverse group))
(setq group_superelevation (mapcar 'read group))
)
)
(setq group_string
(mapcar '(lambda (lst)
(if (= (length lst) 3)
(list (car lst)
(car (cadr lst))
(cadr (cadr lst))
(cadr (caddr lst))
)
lst
)
)
group_superelevation
)
)
(setq group_string
(mapcar '(lambda (lst)
(mapcar '(lambda (x)
(cond
((= (type x) 'real)
(rtos x)
)
((= (type x) 'int)
(itoa x)
)
(t
(vl-princ-to-string
x
)
)
) ;cond 函数结束
)
lst
)
)
group_string
)
)
(setq lst_str_1 (list "JD=" "超高值=")
lst_str_2 (list "JD="
"起点超高值="
"圆曲线超高值="
"终点超高值="
)
)
(setq group_2
(mapcar '(lambda (lst / subset)
(if (= (length lst) 2)
(progn
(setq subset
(append lst lst_str_1)
)
(setq subset
(mapcar '(lambda (i)
(nth i subset)
)
(list 2 0 3 1)
)
)
(setq subset
(mapcar '(lambda (i / j)
(setq j (* i 2))
(list (nth j subset)
(nth (+ j 1) subset)
)
)
(list 0 1)
)
)
)
)
(if (= (length lst) 4)
; (setq lst (nth 9 group_string))
(progn
(setq subset
(append lst lst_str_2)
)
(setq subset
(mapcar '(lambda (i)
(nth i subset)
)
(list 4 0 5 1 6 2 7 3)
)
)
(setq subset
(mapcar '(lambda (i / j)
(setq j (* i 2))
(list (nth j subset)
(nth (+ j 1) subset)
)
)
(list 0 1 2 3)
)
)
)
)
(mapcar '(lambda (lst)
(apply 'strcat lst)
)
subset
)
)
group_string
)
)
(setq
fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1)
)
(setq f1 (open fname
"w"
)
)
(mapcar
'(lambda (lst / str) ; (setq str (car group_2))
(setq str (vl-princ-to-string lst)
str (vl-string-left-trim "(" str)
str (vl-string-right-trim ")" str)
)
(write-line str f1)
)
group_2
)
(close f1)
)
;; (write_group_superelevation group_superelevation )
(defun write_group_widen
(group_widen / fname
f1 group group_2 group_string
lst_str string
)
(if t
(progn
(setq
fname (getfiled "\n输入要选择的转点加宽文件" "" "txt" 1)
)
(setq f1 (open fname
"r"
)
)
(setq group
nil
lst nil
group_2 nil
)
(while (setq lst (read-line f1))
(setq group
(cons lst group)
)
)
(close f1)
(setq group (reverse group))
(setq group_widen (mapcar 'read group))
)
)
;; 把group 数组转换成自己需要的形式
(setq group_string
(mapcar '(lambda (lst)
(mapcar '(lambda (x)
(cond
((= (type x) 'real)
(rtos x)
)
((= (type x) 'int)
(itoa x)
)
(t
(vl-princ-to-string
x
)
)
) ;cond 函数结束
)
lst
)
)
group_widen
)
)
(setq lst_str (list "JD=" "加宽值="))
(setq group_2
(mapcar '(lambda (lst / subset)
(setq subset
(append lst lst_str)
)
(setq subset
(mapcar '(lambda (i)
(nth i subset)
)
(list 2 0 3 1)
)
)
(setq subset
(mapcar '(lambda (i / j)
(setq j (* i 2))
(list (nth j subset)
(nth (+ j 1) subset)
)
)
(list 0 1)
)
)
(mapcar '(lambda (lst)
(apply 'strcat lst)
)
subset
)
)
group_string
)
)
(setq
fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1)
)
(setq f1 (open fname
"w"
)
)
(mapcar
'(lambda (lst / str) ; (setq str (car group_2))
(setq str (vl-princ-to-string lst)
str (vl-string-left-trim "(" str)
str (vl-string-right-trim ")" str)
)
(write-line str f1)
)
group_2
)
(close f1)
)
;; (write_group_widen group_widen )
(defun write_group_stake_mark
(group_stake_mark
/ fname
f1 group
group_2 group_string
lst_str string
group_stake_mark_divide
)
(if nil
(progn
(setq fname (getfiled "输入存放桩号的数据表" "" "txt" 1))
(if fname
(progn
(setq f1 (open fname
"r"
)
)
(setq group_stake_mark
nil
lst nil
)
(while (setq lst (read-line f1))
(setq group_stake_mark
(cons (read lst) group_stake_mark)
)
)
(close f1)
(setq group_stake_mark (reverse group_stake_mark))
;; 把桩号数组group_stake_mark 变为一元列表
(setq group_stake_mark (apply 'append group_stake_mark))
)
) ; if fname 函数结束
)
)
;;在对group_stake_mark数组，按每10个桩号进行分组
(setq n_1 0
group nil
lst nil
)
(mapcar '(lambda (x)
(setq n_1 (+ n_1 1))
(if (= (rem n_1 10) 0)
(setq
lst (cons x lst)
lst (reverse lst)
group (cons lst group)
lst nil
)
(setq lst (cons x lst))
)
)
group_stake_mark
)
(if lst
(setq group (cons lst group))
)
(setq group_stake_mark_divide (reverse group))
;; 把group_stake_mark_divide 数组转换成自己需要的形式
(setq group
(mapcar '(lambda (lst)
(mapcar 'rtos lst)
)
group_stake_mark_divide
)
)
(setq lst_str (list "设计桩号:"))
(setq group_2
(mapcar '(lambda (lst / subset) ; (setq lst (last group))
(setq subset
(append lst_str lst)
)
)
group
)
)
(setq
fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1)
)
(setq f1 (open fname
"w"
)
)
(mapcar
'(lambda (lst / str) ; (setq str (car group_2))
(setq str (vl-princ-to-string lst)
str (vl-string-left-trim "(" str)
str (vl-string-right-trim ")" str)
)
(write-line str f1)
)
group_2
)
(close f1)
)
;; (write_group_stake_mark group_stake_mark )

(defun write_group_vertical_curve 
                                  (group_vertical_curve 
                                   /                 fname 
                                   f1                 group 
                                   group_2         group_string 
                                   lst_str         string 
                                  ) 
  (if t 
    (progn 
      (setq 
        fname (getfiled "\n输入要选择竖曲线交点参数的文件" "" "txt" 1) 
      ) 
 
      (setq f1 (open fname 
                     "r" 
               ) 
      ) 
      (setq group 
             nil 
            lst        nil 
            group_2 nil 
      ) 
      (while (setq lst (read-line f1)) 
        (setq group 
               (cons lst group) 
        ) 
      ) 
      (close f1) 
      (setq group (reverse group)) 
      (setq group_vertical_curve (mapcar 'read group)) 
    ) 
  ) 
  ;; 把group 数组转换成 自己需要的形式 
  (setq        group_string 
         (mapcar '(lambda (lst) 
                    (mapcar '(lambda (x) 
                               (cond 
                                 ((= (type x) 'real) 
                                  (rtos x) 
                                 ) 
                                 ((= (type x) 'int) 
                                  (itoa x) 
                                 ) 
                                 (t 
                                  (vl-princ-to-string 
                                    x 
                                  ) 
                                 ) 
                               )        ;cond 函数结束 
                             ) 
                            lst 
                    ) 
                  ) 
                 group_vertical_curve 
         ) 
  ) 
  (setq lst_str (list "JD=" "桩号=" "高程=" "R=")) 
  (setq        group_2 
         (mapcar '(lambda (lst / subset) 
                    (setq subset 
                           (append lst lst_str) 
                    ) 
                    (setq subset 
                           (mapcar '(lambda (i) 
                                      (nth i subset) 
                                    ) 
                                   (list 4 0 5 1 6 2 7 3) 
                           ) 
                    ) 
                    (setq subset 
                           (mapcar '(lambda (i / j) 
                                      (setq j (* i 2)) 
                                      (list (nth j subset) 
                                            (nth (+ j 1) subset) 
                                      ) 
                                    ) 
                                   (list 0 1 2 3) 
                           ) 
                    ) 
                    (mapcar '(lambda (lst) 
                               (apply 'strcat lst) 
                             ) 
                            subset 
                    ) 
                  ) 
                 group_string 
         ) 
  ) 
  (setq 
    fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1) 
  ) 
 
  (setq        f1 (open fname 
                 "w" 
           ) 
  ) 
  (mapcar 
    '(lambda (lst / str)                ; (setq str (car group_2))   
       (setq str (vl-princ-to-string lst) 
             str (vl-string-left-trim "(" str) 
             str (vl-string-right-trim ")" str) 
       ) 
       (write-line str f1) 
     ) 
    group_2 
  ) 
  (close f1) 
) 
;;  (write_group_vertical_curve  group_vertical_curve  )    
 
 
;; (setq lst (insert_交点_str )    Z_road_start (cadr lst)  group_turning_point (car lst))    
(defun write_group_turning_point_original 
                                          (Z_road_start 
                                           group_turning_point_original 
                                           / 
                                           fname 
                                           f1 
                                           group 
                                           group_2 
                                           group_string 
                                           lst_str 
                                           lst1 
                                           lst2 
                                           string 
                                          ) 
  (if nil 
    (progn 
      (setq 
        fname (getfiled "\n输入要选择的交点参数文件" "" "txt" 1) 
      ) 
 
      (setq f1 (open fname 
                     "r" 
               ) 
      ) 
      (setq group 
             nil 
            lst        nil 
            group_2 nil 
      ) 
      (while (setq lst (read-line f1)) 
        (setq group 
               (cons lst group) 
        ) 
      ) 
      (close f1) 
      (setq group (reverse group)) 
      (setq group_turning_point_original (mapcar 'read group)) 
    ) 
  ) 
  (if (not Z_road_start) 
    (setq Z_road_start 0) 
  ) 
  (setq        group_2        (change_group_turning_point_original 
                  group_turning_point_original 
                  Z_road_start 
                ) 
  ) 
  (setq 
    fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1) 
  ) 
 
  (setq        f1 (open fname 
                 "w" 
           ) 
  ) 
  (mapcar 
    '(lambda (str)                        ; (setq str (car group_2))   
       (write-line str f1) 
     ) 
    group_2 
  ) 
  (close f1) 
) 
;;  (write_group_turning_point_original   Z_road_start  group_turning_point_original )   
;;  (write_group_turning_point_original   60100  group_turning_point_original )   
 
 
 
;; 把超高数组group_superelevation 写入指定文件中 
(defun write_group_superelevation 
                                  (group_superelevation 
                                   /                 fname 
                                   f1                 group 
                                   group_2         group_string 
                                   lst_str         string 
                                  ) 
  (if t 
    (progn 
      (setq 
        fname 
         (getfiled "\n输入存放线路交点超高方式的数据表" "" "txt" 1) 
      ) 
      (setq f1 (open fname 
                     "r" 
               ) 
      ) 
      (setq group 
             nil 
            lst        nil 
            group_2 nil 
      ) 
      (while (setq lst (read-line f1)) 
        (setq group 
               (cons lst group) 
        ) 
      ) 
      (close f1) 
      (setq group (reverse group)) 
      (setq group_superelevation (mapcar 'read group)) 
    ) 
  ) 
  (setq        group_string 
         (mapcar '(lambda (lst) 
                    (if        (= (length lst) 3) 
                      (list (car lst) 
                            (car (cadr lst)) 
                            (cadr (cadr lst)) 
                            (cadr (caddr lst)) 
                      ) 
                      lst 
                    ) 
                  ) 
                 group_superelevation 
         ) 
  ) 
  (setq        group_string 
         (mapcar '(lambda (lst) 
                    (mapcar '(lambda (x) 
                               (cond 
                                 ((= (type x) 'real) 
                                  (rtos x) 
                                 ) 
                                 ((= (type x) 'int) 
                                  (itoa x) 
                                 ) 
                                 (t 
                                  (vl-princ-to-string 
                                    x 
                                  ) 
                                 ) 
                               )        ;cond 函数结束 
                             ) 
                            lst 
                    ) 
                  ) 
                 group_string 
         ) 
  ) 
  (setq        lst_str_1 (list "JD=" "超高值=") 
        lst_str_2 (list        "JD=" 
                        "起点超高值=" 
                        "圆曲线超高值=" 
                        "终点超高值=" 
                  ) 
  ) 
  (setq        group_2 
         (mapcar '(lambda (lst / subset) 
 
                    (if        (= (length lst) 2) 
                      (progn 
                        (setq subset 
                               (append lst lst_str_1) 
                        ) 
                        (setq subset 
                               (mapcar '(lambda        (i) 
                                          (nth i subset) 
                                        ) 
                                       (list 2 0 3 1) 
                               ) 
                        ) 
                        (setq subset 
                               (mapcar '(lambda        (i / j) 
                                          (setq j (* i 2)) 
                                          (list        (nth j subset) 
                                                (nth (+ j 1) subset) 
                                          ) 
                                        ) 
                                       (list 0 1) 
                               ) 
                        ) 
                      ) 
                    ) 
                    (if        (= (length lst) 4) 
                                        ; (setq lst (nth 9 group_string))    
                      (progn 
                        (setq subset 
                               (append lst lst_str_2) 
                        ) 
                        (setq subset 
                               (mapcar '(lambda        (i) 
                                          (nth i subset) 
                                        ) 
                                       (list 4 0 5 1 6 2 7 3) 
                               ) 
                        ) 
                        (setq subset 
                               (mapcar '(lambda        (i / j) 
                                          (setq j (* i 2)) 
                                          (list        (nth j subset) 
                                                (nth (+ j 1) subset) 
                                          ) 
                                        ) 
                                       (list 0 1 2 3) 
                               ) 
                        ) 
                      ) 
                    ) 
                    (mapcar '(lambda (lst) 
                               (apply 'strcat lst) 
                             ) 
                            subset 
                    ) 
                  ) 
                 group_string 
         ) 
  ) 
  (setq 
    fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1) 
  ) 
  (setq        f1 (open fname 
                 "w" 
           ) 
  ) 
  (mapcar 
    '(lambda (lst / str)                ; (setq str (car group_2))   
       (setq str (vl-princ-to-string lst) 
             str (vl-string-left-trim "(" str) 
             str (vl-string-right-trim ")" str) 
       ) 
       (write-line str f1) 
     ) 
    group_2 
  ) 
  (close f1) 
) 
;;  (write_group_superelevation  group_superelevation )   
 
 
 
(defun write_group_widen 
                         (group_widen                /           fname 
                          f1             group        group_2           group_string 
                          lst_str    string 
                         ) 
  (if t 
    (progn 
      (setq 
        fname (getfiled "\n输入要选择的转点加宽文件" "" "txt" 1) 
      ) 
      (setq f1 (open fname 
                     "r" 
               ) 
      ) 
      (setq group 
             nil 
            lst        nil 
            group_2 nil 
      ) 
      (while (setq lst (read-line f1)) 
        (setq group 
               (cons lst group) 
        ) 
      ) 
      (close f1) 
      (setq group (reverse group)) 
      (setq group_widen (mapcar 'read group)) 
    ) 
  ) 
  ;; 把group 数组转换成 自己需要的形式 
  (setq        group_string 
         (mapcar '(lambda (lst) 
                    (mapcar '(lambda (x) 
                               (cond 
                                 ((= (type x) 'real) 
                                  (rtos x) 
                                 ) 
                                 ((= (type x) 'int) 
                                  (itoa x) 
                                 ) 
                                 (t 
                                  (vl-princ-to-string 
                                    x 
                                  ) 
                                 ) 
                               )        ;cond 函数结束 
                             ) 
                            lst 
                    ) 
                  ) 
                 group_widen 
         ) 
  ) 
  (setq lst_str (list "JD=" "加宽值=")) 
  (setq        group_2 
         (mapcar '(lambda (lst / subset) 
                    (setq subset 
                           (append lst lst_str) 
                    ) 
                    (setq subset 
                           (mapcar '(lambda (i) 
                                      (nth i subset) 
                                    ) 
                                   (list 2 0 3 1) 
                           ) 
                    ) 
                    (setq subset 
                           (mapcar '(lambda (i / j) 
                                      (setq j (* i 2)) 
                                      (list (nth j subset) 
                                            (nth (+ j 1) subset) 
                                      ) 
                                    ) 
                                   (list 0 1) 
                           ) 
                    ) 
                    (mapcar '(lambda (lst) 
                               (apply 'strcat lst) 
                             ) 
                            subset 
                    ) 
                  ) 
                 group_string 
         ) 
  ) 
  (setq 
    fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1) 
  ) 
 
  (setq        f1 (open fname 
                 "w" 
           ) 
  ) 
  (mapcar 
    '(lambda (lst / str)                ; (setq str (car group_2))   
       (setq str (vl-princ-to-string lst) 
             str (vl-string-left-trim "(" str) 
             str (vl-string-right-trim ")" str) 
       ) 
       (write-line str f1) 
     ) 
    group_2 
  ) 
  (close f1) 
) 
;;  (write_group_widen   group_widen )    
 
 
 
 
(defun write_group_stake_mark 
                              (group_stake_mark 
                               /               fname 
                               f1               group 
                               group_2               group_string 
                               lst_str               string 
                               group_stake_mark_divide 
                              ) 
  (if nil 
    (progn 
      (setq fname (getfiled "输入存放桩号的数据表" "" "txt" 1)) 
      (if fname 
        (progn 
          (setq        f1 (open fname 
                         "r" 
                   ) 
          ) 
          (setq        group_stake_mark 
                 nil 
                lst nil 
          ) 
          (while (setq lst (read-line f1)) 
            (setq group_stake_mark 
                   (cons (read lst) group_stake_mark) 
            ) 
          ) 
          (close f1) 
          (setq group_stake_mark (reverse group_stake_mark)) 
          ;; 把桩号数组group_stake_mark  变为一元列表   
          (setq group_stake_mark (apply 'append group_stake_mark)) 
        ) 
      )                                        ; if fname 函数结束 
    ) 
  ) 
  ;;在对group_stake_mark数组，按每10个桩号进行分组   
  (setq        n_1 0 
        group nil 
        lst nil 
  ) 
  (mapcar '(lambda (x) 
             (setq n_1 (+ n_1 1)) 
             (if (= (rem n_1 10) 0) 
               (setq 
                 lst   (cons x lst) 
                 lst   (reverse lst) 
                 group (cons lst group) 
                 lst   nil 
               ) 
               (setq lst (cons x lst)) 
             ) 
           ) 
          group_stake_mark 
  ) 
  (if lst 
    (setq group (cons lst group)) 
  ) 
  (setq group_stake_mark_divide (reverse group)) 
  ;; 把group_stake_mark_divide  数组转换成 自己需要的形式 
  (setq        group 
         (mapcar '(lambda (lst) 
                    (mapcar 'rtos lst) 
                  ) 
                 group_stake_mark_divide 
         ) 
  ) 
  (setq lst_str (list "设计桩号:")) 
  (setq        group_2 
         (mapcar '(lambda (lst / subset)   ;  (setq lst (last group))   
                    (setq subset 
                           (append lst_str lst) 
                    ) 
                  ) 
                 group 
         ) 
  ) 
  (setq 
    fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1) 
  ) 
  (setq        f1 (open fname 
                 "w" 
           ) 
  ) 
  (mapcar 
    '(lambda (lst / str)                ; (setq str (car group_2))   
       (setq str (vl-princ-to-string lst) 
             str (vl-string-left-trim "(" str) 
             str (vl-string-right-trim ")" str) 
       ) 
       (write-line str f1) 
     ) 
    group_2 
  ) 
  (close f1) 
) 
;;  (write_group_stake_mark   group_stake_mark )

(defun f_zhuanghao (Z / 桩号1 桩号2 Z_1 z_2 z_3 桩号3 桩号)
(setq Z_1 (fix Z)
Z_2 (rem Z_1 1000) ;整数桩号
Z_3 (/ (- Z_1 Z_2) 1000) ;公里桩号
Z_4 (- Z Z_1) ;小数桩号
)
(setq 桩号1 (itoa Z_3) ;获得整公里桩号
桩号2 (itoa Z_2) ;获得桩号的小里程数
桩号3 (substr (rtos Z_4 2 3) 2 4) ;获得桩号的小数
)
(cond
((and (= Z_2 0) (= Z_4 0))
(setq 桩号 (strcat "K" 桩号1 "+000"))
; 获得桩号的字符表达式如"K3+000" 的形式
)
((and (= (rem Z_2 10) 0) (= Z_4 0))
(setq 桩号 (strcat "K" 桩号1 "+" 桩号2))
; 获得桩号的字符表达式如"+860" 的形式
)
(t (setq 桩号 (strcat "K" 桩号1 "+" 桩号2 桩号3)))
)
) ;zhuanghao函数结束
;;8888888888888888888888888888888888888888888888
(defun action_stake_Z
(/ fname f1 lst
group_stake_mark group group_2
n_1 n
)
(setq group_stake_mark (write_into_group_stake_mark))
(setq group
(mapcar '(lambda (x)
(f_zhuanghao x)
)
group_stake_mark
)
)
;;在对group数组，按每10个桩号进行分组
(setq n_1 0
group_2 nil
lst ""
)
(mapcar '(lambda (x) ; (setq x (car group) )
(setq n_1 (+ n_1 1))
(if (= (rem n_1 2) 0)
(setq lst
(strcat lst " " (itoa n_1) " : " x)
group_2 (cons lst group_2)
lst ""
)
(setq lst
(strcat lst (itoa n_1) " : " x)
)
)
)
group
)
(if (/= lst "")
(setq group_2 (cons lst group_2))
)
(setq group_z_str (reverse group_2))
(start_list "table_Z" 3) ; 把原先列表去掉，换成新的
(mapcar 'add_list group_z_str)
(end_list)
(setq n (length group_stake_mark)
n (itoa n)
)
(set_tile "table_Z" n)
group_stake_mark
)
;; (action_stake_Z )
;; 创建一个桩号的函数
(defun create_group_Z (Z_start Z_end Z_Δ / lst group_Z z residue)
(setq group_z (list Z_start)
Z (+ (fix Z_start) 1)
)
;; 对Z取摸5，使得group_z 为Z_Δ的倍数
(setq residue (rem Z Z_Δ)
Z (- Z residue)
)
(if (>= Z Z_start)
(setq Z Z)
(setq Z (+ Z Z_Δ))
)
(while (< Z Z_end)
(setq group_Z (cons z group_Z))
(setq z (+ z Z_Δ))
)
(setq group_z
(reverse group_z)
)
)
;; (setq group_Z ( create_group_Z 10784.9 10834 20 ) )
;; (setq group_turning_point ( create_turning_point_group ))
;; (setq group_Line_segments (car ( create_group_Line_segments group_turning_point 6782.755 )) )
;; 把设计桩号分割成每个线元里面的桩号数组
(defun creat_group_z (group_Line_segments stake_mark_group
/ n group
group_divide group_divide_2 z_max
lst
)
(setq group (apply 'append group_Line_segments)
group_divide (mapcar '(lambda (x) (nth 6 x)) group)
)
(setq group (cdr group_divide)
n (length group)
group_divide_2 nil
i 0
)
(repeat n
(setq lst (list (nth i group_divide)
(nth i group)
)
group_divide_2 (cons lst group_divide_2)
)
(setq i (+ i 1))
)
(setq z_max (last group_divide)) ;最后一个线元的起始桩号
;; 把stake_mark_group位于最后一个线元桩号z_max 的桩号找出来
(setq lst nil
stake_mark_group_sum
nil
)
(mapcar '(lambda (Z)
(if (>= z z_max)
(setq lst (cons z lst))
)
)
stake_mark_group
)
(if lst
(setq lst (reverse lst)
stake_mark_group_sum
(cons (list z_max lst) stake_mark_group_sum)
)
)
(mapcar '(lambda (u / z_start z_end)
(setq z_start (car U)
z_end (cadr U)
)
(setq lst nil)
(mapcar '(lambda (Z)
(if (and (>= z z_start)
(< z z_end)
)
(setq lst (cons z lst))
)
)
stake_mark_group
)
(if lst
(setq lst (reverse lst)
stake_mark_group_sum
(cons (list z_start lst) stake_mark_group_sum)
)
)
)
group_divide_2
)
stake_mark_group_sum
)
;; (setq stake_mark_group (write_into_group_stake_mark))
;; (setq group_Z_out ( creat_group_z group_Line_segments stake_mark_group ) )

(defun f_zhuanghao (Z / 桩号1 桩号2 Z_1 z_2 z_3 桩号3 桩号) 
  (setq        Z_1 (fix Z) 
        Z_2 (rem Z_1 1000)                ;整数桩号 
        Z_3 (/ (- Z_1 Z_2) 1000)        ;公里桩号 
        Z_4 (- Z Z_1)                        ;小数桩号 
  ) 
  (setq        桩号1 (itoa Z_3)                ;获得整公里桩号 
        桩号2 (itoa Z_2)                ;获得桩号的小里程数 
        桩号3 (substr (rtos Z_4 2 3) 2 4) ;获得桩号的小数   
  ) 
  (cond 
    ((and (= Z_2 0) (= Z_4 0)) 
     (setq 桩号 (strcat "K" 桩号1 "+000")) 
                                        ; 获得桩号的字符表达式如"K3+000" 的形式 
    ) 
    ((and (= (rem Z_2 10) 0) (= Z_4 0)) 
     (setq 桩号 (strcat "K" 桩号1 "+" 桩号2)) 
                                        ; 获得桩号的字符表达式如"+860" 的形式 
    ) 
    (t (setq 桩号 (strcat "K" 桩号1 "+" 桩号2 桩号3))) 
  ) 
)                                        ;zhuanghao函数结束 
;;8888888888888888888888888888888888888888888888 
 
 
 
 
(defun action_stake_Z 
                      (/          fname             f1                lst 
                       group_stake_mark             group        group_2 
                       n_1          n 
                      ) 
 
  (setq group_stake_mark (write_into_group_stake_mark)) 
 
  (setq        group 
         (mapcar '(lambda (x) 
                    (f_zhuanghao x) 
                  ) 
                 group_stake_mark 
         ) 
  ) 
  ;;在对group数组，按每10个桩号进行分组   
  (setq        n_1 0 
        group_2        nil 
        lst "" 
  ) 
  (mapcar '(lambda (x)                        ; (setq x (car group) )    
             (setq n_1 (+ n_1 1)) 
             (if (= (rem n_1 2) 0) 
               (setq lst 
                             (strcat lst " " (itoa n_1) " : " x) 
                     group_2 (cons lst group_2) 
                     lst     "" 
               ) 
               (setq lst 
                      (strcat lst (itoa n_1) " : " x) 
               ) 
             ) 
           ) 
          group 
  ) 
  (if (/= lst "") 
    (setq group_2 (cons lst group_2)) 
  ) 
  (setq group_z_str (reverse group_2)) 
  (start_list "table_Z" 3)                ; 把原先列表去掉，换成新的 
  (mapcar 'add_list group_z_str) 
  (end_list) 
  (setq        n (length group_stake_mark) 
        n (itoa n) 
  ) 
  (set_tile "table_Z" n) 
  group_stake_mark 
) 
;; (action_stake_Z ) 
 
 
 
 
 
 
;; 创建一个 桩号的函数   
(defun create_group_Z (Z_start Z_end Z_Δ / lst group_Z z residue) 
 
  (setq        group_z        (list Z_start) 
        Z        (+ (fix Z_start) 1) 
  ) 
  ;; 对Z取摸5，使得group_z 为Z_Δ的倍数 
  (setq        residue        (rem Z Z_Δ) 
        Z        (- Z residue) 
  ) 
  (if (>= Z Z_start) 
    (setq Z Z) 
    (setq Z (+ Z Z_Δ)) 
  ) 
 
  (while (< Z Z_end) 
    (setq group_Z (cons z group_Z)) 
    (setq z (+ z Z_Δ)) 
  ) 
  (setq        group_z 
         (reverse group_z) 
  ) 
) 
;; (setq  group_Z ( create_group_Z 10784.9 10834  20 )  )    
 
 
 
 
;;  (setq group_turning_point ( create_turning_point_group ))   
;; (setq  group_Line_segments (car ( create_group_Line_segments   group_turning_point  6782.755 )) )   
;; 把设计桩号 分割成每个线元里面的 桩号数组   
(defun creat_group_z (group_Line_segments              stake_mark_group 
                      /                      n                      group 
                      group_divide    group_divide_2  z_max 
                      lst 
                     ) 
  (setq        group             (apply 'append group_Line_segments) 
        group_divide (mapcar '(lambda (x) (nth 6 x)) group) 
  ) 
  (setq        group               (cdr group_divide) 
        n               (length group) 
        group_divide_2 nil 
        i               0 
  ) 
  (repeat n 
    (setq lst                 (list (nth i group_divide) 
                               (nth i group) 
                         ) 
          group_divide_2 (cons lst group_divide_2) 
    ) 
    (setq i (+ i 1)) 
  ) 
  (setq z_max (last group_divide))        ;最后一个线元的起始桩号 
  ;; 把stake_mark_group位于最后一个线元桩号z_max 的桩号找出来 
  (setq        lst nil 
        stake_mark_group_sum 
         nil 
  ) 
  (mapcar '(lambda (Z) 
             (if (>= z z_max) 
               (setq lst (cons z lst)) 
             ) 
           ) 
          stake_mark_group 
  ) 
  (if lst 
    (setq lst (reverse lst) 
          stake_mark_group_sum 
           (cons (list z_max lst) stake_mark_group_sum) 
    ) 
  ) 
  (mapcar '(lambda (u / z_start z_end) 
             (setq z_start (car U) 
                   z_end   (cadr U) 
             ) 
             (setq lst nil) 
             (mapcar '(lambda (Z) 
                        (if (and (>= z z_start) 
                                 (< z z_end) 
                            ) 
                          (setq lst (cons z lst)) 
                        ) 
                      ) 
                     stake_mark_group 
             ) 
             (if lst 
               (setq lst (reverse lst) 
                     stake_mark_group_sum 
                      (cons (list z_start lst) stake_mark_group_sum) 
               ) 
             ) 
           ) 
          group_divide_2 
  ) 
 
  stake_mark_group_sum 
) 
;;  (setq stake_mark_group   (write_into_group_stake_mark))    
;; (setq group_Z_out  ( creat_group_z  group_Line_segments    stake_mark_group )  )

时见申 · 发表于 2018-9-1 15:03:43

十分感谢，很好

snight523 · 发表于 2018-9-3 07:03:03

楼主威武，洋洋洒洒数百行代码，彰显着楼主在cad编程上出神入化的造诣，在下佩服至极。准备有空的时候下载了研究

账号		自动登录	找回密码
密码			注册

[测绘] 公路曲线输出CASS文件

本帖子中包含更多资源

浏览过的版块