明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1892|回复: 4

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

  [复制链接]
发表于 2016-10-13 16:11 | 显示全部楼层 |阅读模式
本帖最后由 ashleytgg 于 2016-10-13 16:11 编辑
  1. ;|
  2. (setq Z_continue 1)  (setq Z_continue 0)
  3.   (create_cass_data_out
  4.    group_Line_segments        group_widen   group_vertical_curve_2
  5.    group_superelevation        0          20  stake_mark_group        Z_continue  5 )  
  6. |;
  7. (defun create_cass_data_out (group_Line_segments
  8.                              group_widen     group_vertical_curve_2
  9.                              group_superelevation
  10.                              mold             Z_Δ
  11.                              stake_mark_group
  12.                              Z_continue             road_wide
  13.                              /                     number
  14.                              group_transition
  15.                              group             group_Z_out
  16.                              title             n
  17.                              ID                     ID1
  18.                              ID2             ID_total
  19.                              color             color_lst
  20.                              range             xlapp
  21.                              xl
  22.                             )
  23.   (vl-load-com)
  24.   (setq xlapp (vlxls-app-new T))
  25.   ;; 当电脑已经打开excel 程序时  
  26.   (vla-put-visible xlapp 1)

  27.   ;; 在excal 工作簿中 加入"绘制公路曲线" 工作页   
  28.   (setq        xl
  29.          (vlax-invoke-method
  30.            (vlax-get-property Xlapp "sheets")
  31.            "Add"
  32.          )
  33.   )
  34.   (vlax-put-property
  35.     xl
  36.     "name"
  37.     "绘制公路曲线"
  38.   )

  39.   (vlxls-app-Init)
  40.   (Defun vllist-explode1 (lst)
  41.     (cond ((not lst) nil)
  42.           ((atom lst) (list lst))
  43.           ((append (vllist-explode1 (car lst))
  44.                    (vllist-explode1 (cdr lst))
  45.            )
  46.           )
  47.     )
  48.   )
  49.   ;; 设置 线路 参数   
  50.   (setq group_transition (create_group_transition group_Line_segments))
  51.   (if (null Z_Δ)
  52.     (setq Z_Δ 20)
  53.   )
  54.   (if (null road_wide)
  55.     (setq road_wide 5)                        ;设置路面宽度
  56.   )

  57.   ;; (setq   Z_continue 0   )   (setq   Z_continue  1  Z_Δ 20   )
  58.   (if (= Z_continue 0)
  59.     (setq group_Z_out
  60.            (creat_group_z group_Line_segments stake_mark_group)
  61.     )
  62.   )
  63.   ;; 开始绘制表格  000 88888888888888      88888888888888     888888888888 8888888888888888888888     开始绘制表格        
  64.   (setq        ID1 (vlxls-rangeid
  65.               (list 1 1)
  66.             )
  67.         ID2 (vlxls-rangeid
  68.               (list 5 1)
  69.             )
  70.         ID  (strcat ID1 ":" ID2)
  71.   )
  72.   ;; 绘制标题行   
  73.   (vlxls-cell-merge xlapp ID)
  74.   (vlxls-cell-put-value
  75.     xlapp
  76.     (list 1 1)
  77.     (list "用cass格式输出公路曲线")
  78.   )
  79.   (setq        title (list "桩号:" "编码" "E(Y)" "N(x)" "高程 ")
  80.   )
  81.   (vlxls-cell-put-value
  82.     xlapp
  83.     (list 1 2)
  84.     (list title)
  85.   )
  86.   ;; 设置excel 表格的 列宽度
  87.   (setq        lst (list '(1 . 13) '(2 . 15) '(3 . 15) '(4 . 16) '(5 . 11))
  88.   )
  89.   (mapcar '(lambda (x)
  90.              (vlxls-ColumnWidth xlapp (car x) (cdr x))
  91.            )
  92.           lst
  93.   )
  94.   (setq number 3)
  95.   (mapcar '(lambda (Line_segments / group)
  96.              (create_cass_data_out_sub
  97.                Line_segments
  98.              )
  99.            )
  100.           group_Line_segments
  101.   )

  102. )
  103. ;; defun create_group_data_out 函数结束


  104. ;|  调试程序用参数   
  105. (setq group_turning_point_original (car ( create_turning_point_group_original ) ) )   
  106. (setq group_turning_point (car  ( create_turning_point_group   group_turning_point_original  Z_road_start )  ) )   
  107. (setq tang   ( create_group_Line_segments   group_turning_point  0 )   group_Line_segments (car tang )  tgg (cadr tang)  )  
  108.    (setq group_widen (write_into_group_widen))   
  109.    (setq stake_mark_group   (write_into_group_stake_mark))  (setq group_Z_out  ( creat_group_z  group_Line_segments    stake_mark_group )  )   

  110.    (setq group_vertical_curve  (create_group_vertical_curve ))(setq group_vertical_curve_2 ( create_group_vertical_curve_2  group_vertical_curve ) )   
  111.   (setq group_superelevation (create_group_superelevation ) )     
  112. |;



  113. ;; (setq Line_segments (nth 1 group_Line_segments))   
  114. (defun create_cass_data_out_sub        (Line_segments         /
  115.                                  lst                 Line_segments_type
  116.                                  str
  117.                                 )
  118.   ;; (setq Width 5  number 0  Z_continue 1 Z_Δ 1  )   
  119.   (mapcar                                ;  (setq subset (nth 0 (nth 4 group_Line_segments )) )      
  120.     '(lambda (subset        /          lst            group_Z   num
  121.               Z_start        Z_end          len            group_data_out
  122.               subset_2        i          array
  123.              )
  124.        (setq array    (car subset)
  125.              num      (cadr array)
  126.              ;; 去除 [( 转点号I j)   R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert )]中的第一个元素  
  127.              subset_2 (cdr subset)
  128.              reflex   (nth 3 subset_2)
  129.              Z_start  (nth 5 subset_2)
  130.        )
  131.        (cond
  132.          ((or (= num 0)
  133.               (= num 2)
  134.           )
  135.           (progn
  136.             (setq len        (car (caddr subset_2))
  137.                   Z_end        (+ Z_start len)
  138.             )
  139.             (if        (= Z_continue 1)
  140.               (setq group_Z (create_group_Z Z_start Z_end Z_Δ))
  141.               (setq group_Z (cadr (assoc Z_start group_Z_out))
  142.                             ;;group_Z (append group_z (list Z_start))
  143.               )
  144.             )
  145.             (setq group_data_out
  146.                    (solve_transition_curve group_Z subset_2)
  147.             )
  148.           )
  149.          )
  150.          ((= num 1)
  151.           (progn
  152.             (setq len        (caddr subset_2)
  153.                   Z_end        (+ Z_start len)
  154.             )
  155.             (if        (= Z_continue 1)
  156.               (setq group_Z (create_group_Z Z_start Z_end Z_Δ))
  157.               (setq group_Z (cadr (assoc Z_start group_Z_out))
  158.                             ;;group_Z (append group_z (list Z_start))
  159.               )
  160.             )
  161.             (setq group_data_out (solve_circular_arc group_Z subset_2))
  162.           )
  163.          )
  164.          ((= num 3)
  165.           (progn
  166.             (setq len        (caddr subset_2)
  167.                   Z_end        (+ Z_start len)
  168.             )
  169.             (if        (= Z_continue 1)
  170.               (setq group_Z (create_group_Z Z_start Z_end Z_Δ))
  171.               (setq group_Z (cadr (assoc Z_start group_Z_out))
  172.                             ;; group_Z (append group_z (list Z_start))
  173.               )
  174.             )
  175.             (setq group_data_out (solve_straightway group_Z subset_2))
  176.           )
  177.          )
  178.        )                                ; cond 函数结束
  179.        ;; 求group_Z 中每个桩号的加宽值
  180.        (if (not mold)
  181.          (setq mold 1)                        ; mold没有定义时,设置为直线加宽  
  182.        )
  183.        (if (and        (/= num 3)
  184.                 (assoc (car array) group_widen) ; 判断该转点是否加宽  
  185.            )
  186.          (setq group_width
  187.                 (mapcar
  188.                   '(lambda (z / Width)
  189.                      (setq Width
  190.                             (calculate_Transition-curve_widen
  191.                               Z
  192.                               group_widen
  193.                               subset
  194.                               mold
  195.                             )
  196.                      )
  197.                      (* Width reflex)        ; 对确定加宽值的左右方向   
  198.                    )
  199.                   group_Z
  200.                 )
  201.          )
  202.          ;; 直线线元加宽值设置为0
  203.          (setq group_width
  204.                 (mapcar
  205.                   '(lambda (z / Width)
  206.                      0
  207.                    )
  208.                   group_Z
  209.                 )
  210.          )
  211.        )
  212.        ;;  group_transition ( 转点号num j) (i j k) ,i 和 k 分别为该线元的 前后线元编号  i k 取值为0 ,1 ,2 ,3  
  213.        (setq lst (cadr (assoc array group_transition)))
  214.        (cond
  215.          ((= (cadr lst) 3)                ; 直线线元时
  216.           (setq
  217.             Line_segments_type
  218.              "  直线"
  219.           )
  220.          )
  221.          ((= (cadr lst) 1)                ;圆曲线线元时
  222.           (setq
  223.             Line_segments_type
  224.              "  圆曲线"
  225.           )                                ; 黄色  
  226.          )
  227.          ;; 当缓和曲线时接直线和圆时   
  228.          ((or (equal lst '(3 0 1))
  229.               (equal lst '(1 2 3))
  230.           )
  231.           (setq
  232.             Line_segments_type
  233.              "缓和曲线"
  234.           )                                ; 绿色  
  235.          )
  236.          ;; 当缓和曲线时接缓和曲线和圆时   
  237.          ((or (equal lst '(2 0 1))
  238.               (equal lst '(1 2 0))
  239.           )
  240.           (progn
  241.             (setq Line_segments_type
  242.                    "缓和曲线"
  243.             )                                ; 洋红色
  244.           )
  245.          )
  246.          ;; 当缓和曲线是接圆和圆时   
  247.          ((or (equal lst '(1 0 1))
  248.               (equal lst '(1 2 1))
  249.           )
  250.           (setq
  251.             Line_segments_type
  252.              "缓和曲线"
  253.           )                                ; 青色  
  254.          )
  255.          (t
  256.           (setq
  257.             Line_segments_type
  258.              "缺省状态"
  259.           )
  260.          )
  261.        )
  262.        ;; 判断线元的起点是什么型号,如ZH HY   
  263.        (setq
  264.          array_2 (list (car lst) (cadr lst))
  265.        )
  266.        (cond
  267.          ((equal array_2
  268.                  '(3 0)
  269.           )
  270.           (setq str "ZH")
  271.          )
  272.          ((equal array_2
  273.                  '(3 1)
  274.           )
  275.           (setq str "ZY")
  276.          )
  277.          ((equal array_2
  278.                  '(0 1)
  279.           )
  280.           (setq str "HY")
  281.          )
  282.          ((equal array_2
  283.                  '(1 0)
  284.           )
  285.           (setq str "YH")
  286.          )
  287.          ((equal array_2
  288.                  '(1 2)
  289.           )
  290.           (setq str "YH")
  291.          )
  292.          ((equal array_2
  293.                  '(1 3)
  294.           )
  295.           (setq str "YZ")
  296.          )
  297.          ((equal array_2
  298.                  '(2 3)
  299.           )
  300.           (setq str "HZ")
  301.          )
  302.          ((equal array_2
  303.                  '(2 0)
  304.           )
  305.           (setq str "HH")
  306.          )
  307.          ((equal array_2
  308.                  '(2 1)
  309.           )
  310.           (setq str "HY")
  311.          )
  312.          (t
  313.           (setq str "88")
  314.          )
  315.        )                                ; cond 函数结束
  316.        ;; 创建group_Z 的高程值
  317.        (setq group_h_slope
  318.               (mapcar '(lambda (z / h slope)
  319.                                         ; ( setq z (car group_Z ))  
  320.                          (setq h     (QH2_10N Z group_vertical_curve_2)
  321.                                slope (calculate_superelevation
  322.                                        z
  323.                                        group_superelevation
  324.                                        subset
  325.                                      )
  326.                          )
  327.                          (if h
  328.                            (list h slope)
  329.                            (list 100 slope)
  330.                          )
  331.                        )
  332.                       group_Z
  333.               )
  334.        )

  335.        ;; 把 group_data_out 、 group_width 和 group_h_slope 合并起来 组成新的数组 { z U ang width h  ( superelevation_L  superelevation_R )}
  336.        (setq i 0)
  337.        (setq group
  338.               (mapcar '(lambda (lst / width lst2 string)
  339.                          (if (= (car lst) Z_start)
  340.                            (setq string str)
  341.                            (setq string Line_segments_type)
  342.                          )
  343.                          (setq width (nth i group_width)
  344.                                lst2  (nth i group_h_slope)
  345.                                i     (+ i 1)
  346.                          )
  347.                          (append lst (list width) lst2 (list string))
  348.                        )
  349.                       group_data_out
  350.               )
  351.        )
  352.        ;; 把数组 group  { z U ang width h  ( superelevation_L  superelevation_R )} 写入表格table 中
  353.        ;; 把group 数组 变成一维数组  
  354.        (setq group (mapcar '(lambda (lst)
  355.                               (vllist-explode1 lst)
  356.                             )
  357.                            group
  358.                    )
  359.        )
  360.        ;; 对group数组转变成南方cass的格式 [ Z Bian_ma   E_x N_y H ]  
  361.        (setq group
  362.               (mapcar
  363.                 '(lambda
  364.                    (lst            /            Z            E_x            N_y            H
  365.                     Bian_ma ang            wide    slope_L slope_R W_L
  366.                     W_R            U_L            U_R            U            H_L            H_R
  367.                     Z_L            Z_R            Bian_ma_L            Bian_ma_R
  368.                    )
  369.                     (setq Z          (car lst)
  370.                                         ; (setq lst (nth 47 group))   
  371.                           Z          (f_zhuanghao Z)
  372.                           E_x          (cadr lst)
  373.                           E_x          (rtos E_x 2 3)
  374.                           N_y          (caddr lst)
  375.                           N_y          (rtos N_y 2 3)
  376.                           H          (nth 5 lst)
  377.                           H          (rtos H 2 2)
  378.                           Bian_ma (nth 8 lst)
  379.                     )
  380.                     (setq ang          (nth 3 lst)
  381.                           ang          (+ ang (* 0.5 pi))
  382.                                         ;把路线象限角变成横断面象限角   
  383.                           wide          (nth 4 lst)
  384.                           slope_L (* (nth 6 lst) 0.01)
  385.                           slope_R (* (nth 7 lst) 0.01)
  386.                     )
  387.                     ;; 设置左右边桩的宽度
  388.                     (if        (>= wide 0)
  389.                       (setq
  390.                         W_L (+ wide 5)
  391.                         W_R -5
  392.                       )
  393.                       (setq
  394.                         W_L 5
  395.                         W_R (+ wide -5)
  396.                       )
  397.                     )
  398.                     (setq U   (list (nth 1 lst)
  399.                                     (nth 2 lst)
  400.                               )
  401.                           U_L (polar U ang W_L)
  402.                           U_L (mapcar 'rtos U_L)
  403.                           U_R (polar U ang W_R)
  404.                           U_R (mapcar 'rtos U_R)
  405.                     )
  406.                     (setq H_L (- (nth 5 lst)
  407.                                  (* (abs W_L) slope_L)
  408.                               )
  409.                           H_L (rtos H_L 2 2)
  410.                           H_R (+ (nth 5 lst)
  411.                                  (* (abs W_R) slope_R)
  412.                               )
  413.                           H_R (rtos H_R 2 2)
  414.                     )
  415.                     (setq Z_L            (strcat "左" "_L")
  416.                           Z_R            (strcat  "右" "_R")
  417.                           Bian_ma_L (strcat "左边_"
  418.                                             (rtos (abs W_L) 2 2)
  419.                                     )
  420.                           Bian_ma_R (strcat "右边_"
  421.                                             (rtos (abs W_R) 2 2)
  422.                                     )
  423.                     )
  424.                     (list
  425.                       (list Z Bian_ma E_x N_y H)
  426.                       (list Z_L Bian_ma_L (car U_L) (cadr U_L) H_L)
  427.                       (list Z_R Bian_ma_R (car U_R) (cadr U_R) H_R)
  428.                     )
  429.                  )
  430.                 group
  431.               )
  432.        )
  433.        (setq group (apply 'append group))

  434.        ;; 把group数组写入 excel 表格   (setq number 3)   
  435.        (mapcar
  436.          '(lambda (lst)
  437.             (vlxls-cell-put-value
  438.               xlapp
  439.               (list 1 number)
  440.               (list lst)
  441.             )
  442.             (setq number (+ number 1))
  443.           )
  444.          group
  445.        )                                ;把group写入excel表格函数结束   

  446.      )
  447.     Line_segments
  448.   )

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

      


  1. ;; 创建  group_data_out 和 加宽值  
  2. (defun create_group_data_out_sub (Line_segments         mold
  3.                                   /                 lst
  4.                                   Line_segments_type
  5.                                   str
  6.                                  )
  7.   ;; (setq Width 5  number 0 )   
  8.   (mapcar                                ;  (setq subset (nth 0 (nth 11 group_Line_segments )) )      
  9.     '(lambda (subset        /          lst            group_Z   num
  10.               Z_start        Z_end          len            group_data_out
  11.               subset_2        i          array            color
  12.              )
  13.        (setq array    (car subset)
  14.              num      (cadr array)
  15.              ;; 去除 [( 转点号I j)   R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert )]中的第一个元素  
  16.              subset_2 (cdr subset)
  17.              reflex   (nth 3 subset_2)
  18.              Z_start  (nth 5 subset_2)
  19.        )
  20.        (cond
  21.          ((or (= num 0)
  22.               (= num 2)
  23.           )
  24.           (progn
  25.             (setq len        (car (caddr subset_2))
  26.                   Z_end        (+ Z_start len)
  27.             )
  28.             (if        (= Z_continue 1)
  29.               (setq group_Z (create_group_Z Z_start Z_end Z_Δ))
  30.               (setq group_Z (cadr (assoc Z_start group_Z_out)))
  31.             )
  32.             (setq group_data_out
  33.                    (solve_transition_curve group_Z subset_2)
  34.             )
  35.           )
  36.          )
  37.          ((= num 1)
  38.           (progn
  39.             (setq len        (caddr subset_2)
  40.                   Z_end        (+ Z_start len)
  41.             )
  42.             (if        (= Z_continue 1)
  43.               (setq group_Z (create_group_Z Z_start Z_end Z_Δ))
  44.               (setq group_Z (cadr (assoc Z_start group_Z_out)))
  45.             )
  46.             (setq group_data_out (solve_circular_arc group_Z subset_2))
  47.           )
  48.          )
  49.          ((= num 3)
  50.           (progn
  51.             (setq len        (caddr subset_2)
  52.                   Z_end        (+ Z_start len)
  53.             )
  54.             (if        (= Z_continue 1)
  55.               (setq group_Z (create_group_Z Z_start Z_end Z_Δ))
  56.               (setq group_Z (cadr (assoc Z_start group_Z_out)))
  57.             )
  58.             (setq group_data_out (solve_straightway group_Z subset_2))
  59.           )
  60.          )
  61.        )                                ; cond 函数结束
  62.        ;; 求group_Z 中每个桩号的加宽值
  63.        (if (not mold)
  64.          (setq mold 1)                        ; mold没有定义时,设置为直线加宽  
  65.        )
  66.        (if (and        (/= num 3)
  67.                 (assoc (car array) group_widen) ; 判断该转点是否加宽  
  68.            )
  69.          (setq group_width
  70.                 (mapcar
  71.                   '(lambda (z / Width)
  72.                      (setq Width
  73.                             (calculate_Transition-curve_widen
  74.                               Z
  75.                               group_widen
  76.                               subset
  77.                               mold
  78.                             )
  79.                      )
  80.                      (* Width reflex)        ; 对确定加宽值的左右方向   
  81.                    )
  82.                   group_Z
  83.                 )
  84.          )
  85.          ;; 直线线元加宽值设置为0
  86.          (setq group_width
  87.                 (mapcar
  88.                   '(lambda (z / Width)
  89.                      0
  90.                    )
  91.                   group_Z
  92.                 )
  93.          )
  94.        )
  95.        ;;  group_transition ( 转点号num j) (i j k) ,i 和 k 分别为该线元的 前后线元编号  i k 取值为0 ,1 ,2 ,3  
  96.        (setq lst (cadr (assoc array group_transition)))
  97.        (cond
  98.          ((= (cadr lst) 3)                ; 直线线元时
  99.           (setq        color 1
  100.                 Line_segments_type
  101.                  "  直线"
  102.           )
  103.          )
  104.          ((= (cadr lst) 1)                ;圆曲线线元时
  105.           (setq        color 2
  106.                 Line_segments_type
  107.                  "  圆曲线"
  108.           )                                ; 黄色  
  109.          )
  110.          ;; 当缓和曲线时接直线和圆时   
  111.          ((or (equal lst '(3 0 1))
  112.               (equal lst '(1 2 3))
  113.           )
  114.           (setq        color 3
  115.                 Line_segments_type
  116.                  "  缓和曲线"
  117.           )                                ; 绿色  
  118.          )
  119.          ;; 当缓和曲线时接缓和曲线和圆时   
  120.          ((or (equal lst '(2 0 1))
  121.               (equal lst '(1 2 0))
  122.           )
  123.           (progn
  124.             (if        (= (cadr lst) 0)
  125.               (setq color 6)                ; 洋红色 入口缓和曲线  
  126.               (setq color 5)                ;蓝色  出口缓和曲线  
  127.             )
  128.             (setq Line_segments_type
  129.                    "  缓和曲线"
  130.             )                                ; 洋红色
  131.           )
  132.          )
  133.          ;; 当缓和曲线是接圆和圆时   
  134.          ((or (equal lst '(1 0 1))
  135.               (equal lst '(1 2 1))
  136.           )
  137.           (setq        color 4
  138.                 Line_segments_type
  139.                  "  缓和曲线"
  140.           )                                ; 青色  
  141.          )
  142.          (t
  143.           (setq        color 0
  144.                 Line_segments_type
  145.                  "  缺省状态"
  146.           )
  147.          )
  148.        )
  149.        ;; 判断线元的起点是什么型号,如ZH HY   
  150.        (setq
  151.          array_2 (list (car lst) (cadr lst))
  152.        )
  153.        (cond
  154.          ((equal array_2
  155.                  '(3 0)
  156.           )
  157.           (setq str "ZH")
  158.          )
  159.          ((equal array_2
  160.                  '(3 1)
  161.           )
  162.           (setq str "ZY")
  163.          )
  164.          ((equal array_2
  165.                  '(0 1)
  166.           )
  167.           (setq str "HY")
  168.          )
  169.          ((equal array_2
  170.                  '(1 0)
  171.           )
  172.           (setq str "YH")
  173.          )
  174.          ((equal array_2
  175.                  '(1 2)
  176.           )
  177.           (setq str "YH")
  178.          )
  179.          ((equal array_2
  180.                  '(1 3)
  181.           )
  182.           (setq str "YZ")
  183.          )
  184.          ((equal array_2
  185.                  '(2 3)
  186.           )
  187.           (setq str "HZ")
  188.          )
  189.          ((equal array_2
  190.                  '(2 0)
  191.           )
  192.           (setq str "HH")
  193.          )
  194.          ((equal array_2
  195.                  '(2 1)
  196.           )
  197.           (setq str "HY")
  198.          )
  199.          (t
  200.           (setq str "88")
  201.          )
  202.        )                                ; cond 函数结束
  203.        ;; 创建group_Z 的高程值
  204.        (setq group_h_slope
  205.               (mapcar '(lambda (z / h slope)
  206.                                         ; ( setq z (car group_Z ))  
  207.                          (setq h     (QH2_10N Z group_vertical_curve_2)
  208.                                slope (calculate_superelevation
  209.                                        z
  210.                                        group_superelevation
  211.                                        subset
  212.                                      )
  213.                          )
  214.                          (if h
  215.                            (list h slope)
  216.                            (list 100 slope)
  217.                          )
  218.                        )
  219.                       group_Z
  220.               )
  221.        )

  222.        ;; 把 group_data_out 、 group_width 和 group_h_slope 合并起来 组成新的数组 { z U ang width h  ( superelevation_L  superelevation_R )}
  223.        (setq i 0)
  224.        (setq group
  225.               (mapcar '(lambda (lst / width lst2)
  226.                          (setq width (nth i group_width)
  227.                                lst2  (nth i group_h_slope)
  228.                                i     (+ i 1)
  229.                          )
  230.                          (append lst (list width) lst2)
  231.                        )
  232.                       group_data_out
  233.               )
  234.        )

  235.        (setq i 0)
  236.        (mapcar
  237.          '(lambda (lst              /                 string            j
  238.                    residue    U_page         U_move            ang
  239.                    group_U    superelevation_L            superelevation_R
  240.                    W_L              W_R         h_L            h_R
  241.                    lst2              lst3
  242.                   )
  243.             (setq residue (rem number n_grid)
  244.                                         ; n_grid 为Uniform_group_center 中的格子数
  245.                   j          (/ (- number residue) n_grid) ; 页数
  246.                   U_page  (polar U_insert 0 (* j (* frame_wide 1.2)))
  247.                   U          (nth residue Uniform_group_center)
  248.                                         ; 桩号Z 在Uniform_group_center 域中的插入点  
  249.                   U_move  (list        (+ (car U_page) (car U))
  250.                                 (+ (cadr U_page) (cadr U))
  251.                           )
  252.             )
  253.             ;; 把z U ang width 桩号、坐标、方位角、加宽值 写入 图中
  254.             (setq U        (cadr lst)        ;  (setq lst (car group))   
  255.                   width        (nth 3 lst)
  256.                   lst2        (cons width U)
  257.                   lst2        (mapcar 'rtos lst2)
  258.                   桩号        (f_zhuanghao (car lst))
  259.                   ang        (caddr lst)
  260.                   ang        (angtos (* (- ang (* 0.5 pi)) -1) 1 6)
  261.                                         ; 把象限角转换成方位角
  262.                   lst2        (append (list 桩号 ang) lst2)
  263.                   lst2        (mapcar        '(lambda (i)
  264.                                    (nth i lst2)
  265.                                  )
  266.                                 (list 0 4 3 1 2)
  267.                         )
  268.             )
  269.             (if        (and (= i 0) Z_continue)
  270.               (setq
  271.                 lst3 (list str "\n N(X):" "E(Y):" "\n 方位角:"
  272.                            "\n 加宽值:")
  273.               )
  274.               (setq
  275.                 lst3 (list Line_segments_type "\n N(X):"
  276.                            "E(Y):"              "\n 方位角:"
  277.                            "\n 加宽值:"
  278.                           )
  279.               )
  280.             )
  281.             (setq
  282.               lst2 (append lst2 lst3)
  283.             )
  284.             (setq lst2 (mapcar '(lambda        (i)
  285.                                   (nth i lst2)
  286.                                 )
  287.                                (list 0 5 6 1 7 2 8 3 9 4)
  288.                        )
  289.             )
  290.             (setq string (vl-princ-to-string lst2)
  291.                   string (vl-string-left-trim "\(" string)
  292.                   string (vl-string-right-trim "\)" string)
  293.             )
  294.             (entmake
  295.               (list
  296.                 '(0 . "MTEXT")
  297.                 '(100 . "AcDbEntity")
  298.                 '(100 . "AcDbMText")
  299.                 (cons 62 color)
  300.                 (cons 40 (* road_wide 0.1))
  301.                 (cons 71 5)
  302.                 (cons 72 5)
  303.                 (cons '1 string)
  304.                 (cons 10 (polar U_move (* pi 0.5) (* road_wide -0.25)))
  305.               )
  306.             )
  307.             ;; 用 group 数组和路面宽度road_wide 创建 桩号Z 的标准横断面控制点 U_cen U_L U_R U_L_2 U_R_2  
  308.             ;; U_L_2 U_R_2 路面宽度road_wide 加 土路肩宽度的值
  309.             (setq h (nth 4 lst)
  310.                   width        (nth 3 lst)
  311.                   superelevation_L
  312.                    (car (nth 5 lst))
  313.                   superelevation_R
  314.                    (cadr (nth 5 lst))
  315.             )
  316.             (if        (> width 0)                ; 在Ucs坐标系中以向右为正
  317.               (setq W_L        (+ road_wide width)
  318.                     W_R
  319.                         (* road_wide -1)
  320.               )
  321.               (setq W_L        road_wide
  322.                     W_R
  323.                         (+ (* road_wide -1) width)
  324.               )
  325.             )
  326.             ;; 在Ucs坐标系中以向右为正 , 所以对 W_L W_R 反向  
  327.             (setq W_L (* W_L -1)
  328.                   W_R (* W_R -1)
  329.             )
  330.             ;; 创建 U   U_L U_R U_L_2 U_R_2 各点的高程  
  331.             (setq
  332.               superelevation_L (* superelevation_L 0.01)
  333.               superelevation_R (* superelevation_R 0.01)
  334.               h_L
  335.                                (* superelevation_L W_L)
  336.               h_R
  337.                                (* superelevation_R W_R)
  338.             )
  339.             (setq lst2 (list (- h_L 0.015)
  340.                              h_L
  341.                              (* h_L 0.5)
  342.                              0
  343.                              (* h_R 0.5)
  344.                              h_R
  345.                              (- h_R 0.015)
  346.                              (* h_L 0.85)
  347.                                         ; 标识横坡superelevation_L 所用点
  348.                              (* h_L 0.15)
  349.                                         ; 标识横坡superelevation_L 所用点
  350.                              (* h_R 0.15)
  351.                                         ; 标识横坡superelevation_R 所用点
  352.                              (* h_R 0.85)
  353.                                         ; 标识横坡superelevation_R 所用点
  354.                        )
  355.                   lst3 (list (- W_L 0.5)
  356.                              W_L
  357.                              (* W_L 0.5)
  358.                              0
  359.                              (* W_R 0.5)
  360.                              W_R
  361.                              (+ W_R 0.5)
  362.                              (* W_L 0.85)
  363.                                         ; 标识横坡superelevation_L 所用点
  364.                              (* W_L 0.15)
  365.                                         ; 标识横坡superelevation_L 所用点
  366.                              (* W_R 0.15)
  367.                                         ; 标识横坡superelevation_R 所用点
  368.                              (* W_R 0.85)
  369.                                         ; 标识横坡superelevation_R 所用点
  370.                        )
  371.                   U    (list (car U_move) (+ (cadr U_move) (* road_wide 0.25)))
  372.             )
  373.             (setq j 0)                        ; (setq U_move (getpoint "输入插入点:"))  
  374.             (setq group_U (mapcar '(lambda (x / y)
  375.                                      (setq y (nth j lst2)
  376.                                            j (1+ j)
  377.                                      )
  378.                                      (list (+ (car U) x)
  379.                                            (+ (cadr U) y)
  380.                                      )
  381.                                    )
  382.                                   lst3
  383.                           )
  384.             )
  385.             (setq group_h (mapcar '(lambda (i / y)
  386.                                      (setq y (nth i lst2))
  387.                                      (+ h y)
  388.                                    )
  389.                                   (list 0 3 6)
  390.                           )
  391.             )
  392.             ;; 把 U_L U U_R 二维多段线写入图中
  393.             (setq pt (mapcar '(lambda (i / U)
  394.                                 (setq U (nth i group_U))
  395.                                 U
  396.                               )
  397.                              (list 0 1 3 5 6)
  398.                      )
  399.             )
  400.             (entmake
  401.               (append (list '(0 . "LWPOLYLINE")
  402.                             '(100 . "AcDbEntity")
  403.                             '(100 . "AcDbPolyline")
  404.                             (cons 62 color)
  405.                             (cons 90 (length pt))
  406.                             (cons 70 0)
  407.                       )
  408.                       (mapcar '(lambda (U) (cons 10 U)) pt)
  409.               )
  410.             )
  411.             ;; 对group_U 中U_L U U_R 顶点绘制 等边三角形  
  412.             (setq j    0
  413.                   lst2
  414.                        (mapcar '(lambda        (U / U_2 U_3)
  415.                                   (if (or (= j 1) (= j 3))
  416.                                     (setq U_2 (polar U (* (/ pi 3.0) 1) (/ road_wide 15.0))
  417.                                           U_3 (polar U (* (/ pi 3.0) 2) (/ road_wide 15.0))
  418.                                     )
  419.                                     (setq U_2 (polar U (* (/ pi 3.0) 1) (/ road_wide 9.0))
  420.                                           U_3 (polar U (* (/ pi 3.0) 2) (/ road_wide 9.0))
  421.                                     )
  422.                                   )
  423.                                   (setq j (1+ j))
  424.                                   (list U_2 U U_3)
  425.                                 )
  426.                                pt
  427.                        )
  428.             )
  429.             (mapcar '(lambda (pt)
  430.                        (entmake
  431.                          (append (list '(0 . "LWPOLYLINE")
  432.                                        '(100 . "AcDbEntity")
  433.                                        '(100 . "AcDbPolyline")
  434.                                        (cons 62 (+ color 1))
  435.                                        (cons 90 (length pt))
  436.                                        (cons 70 1)
  437.                                  )
  438.                                  (mapcar '(lambda (U) (cons 10 U)) pt)
  439.                          )
  440.                        )
  441.                      )
  442.                     lst2
  443.             )
  444.             ;; 绘制用以标识 superelevation_L 和 superelevation_R 的箭头  
  445.             (setq pt
  446.                    (mapcar '(lambda (i / U)
  447.                               (setq U (nth i group_U))
  448.                               (polar U (* pi 0.5) (/ road_wide 15.0))
  449.                             )
  450.                            (list 7 8 9 10)
  451.                    )
  452.             )
  453.             (setq
  454.               lst2
  455.                (apply
  456.                  '(lambda (x_0 x_1 x_3 x_4 / x_5 x_6 group_L group_R)
  457.                     (if        (>= superelevation_L 0)
  458.                       (setq
  459.                         x_5        (polar x_0 (/ pi 6) (/ road_wide 15.0))
  460.                         group_L        (list x_5 x_0 x_1)
  461.                       )
  462.                       (setq
  463.                         x_5        (polar x_1 (* 0.8333 pi) (/ road_wide 15.0))
  464.                         group_L        (list x_0 x_1 x_5)
  465.                       )
  466.                     )
  467.                     (if        (< superelevation_R 0)
  468.                       (setq
  469.                         x_6        (polar x_4 (* 0.8333 pi) (/ road_wide 15.0))
  470.                         group_R        (list x_3 x_4 x_6)
  471.                       )
  472.                       (setq
  473.                         x_6        (polar x_3 (/ pi 6) (/ road_wide 15.0))
  474.                         group_R        (list x_6 x_3 x_4)
  475.                       )
  476.                     )
  477.                     (list group_L group_R)
  478.                   )
  479.                  pt
  480.                )
  481.             )
  482.             (mapcar '(lambda (pt)
  483.                        (entmake
  484.                          (append (list '(0 . "LWPOLYLINE")
  485.                                        '(100 . "AcDbEntity")
  486.                                        '(100 . "AcDbPolyline")
  487.                                        (cons 62 (+ color 2))
  488.                                        (cons 90 (length pt))
  489.                                        (cons 70 0)
  490.                                  )
  491.                                  (mapcar '(lambda (U) (cons 10 U)) pt)
  492.                          )
  493.                        )
  494.                      )
  495.                     lst2
  496.             )
  497.             ;; 把group 中    h_L h  h_R ( superelevation_L  superelevation_R )  W_L W_R   写入图中
  498.             (setq
  499.               pt (mapcar '(lambda (i / U U_2)
  500.                             (setq U (nth i group_U))
  501.                             (if        (or (= i 2) (= i 4))
  502.                               (polar U (* pi 0.5) (* road_wide 0.3))
  503.                               (polar U (* pi 0.5) (* road_wide 0.15))
  504.                             )
  505.                           )
  506.                          (list 0 2 3 4 6)
  507.                  )
  508.             )
  509.             (setq
  510.               U          (car pt)
  511.               U          (list        (car U)
  512.                         (- (cadr U) (* road_wide 0.35))
  513.                   )
  514.               U_2 (last pt)
  515.               U_2 (list        (car U_2)
  516.                         (- (cadr U_2) (* road_wide 0.35))
  517.                   )
  518.               pt  (append pt (list U) (list U_2))
  519.             )
  520.             (setq
  521.               lst2 (append group_h
  522.                            (nth 5 lst)        ; ( superelevation_L  superelevation_R )  
  523.                            (list (abs W_L))
  524.                            (list W_R)
  525.                    )
  526.               lst2 (mapcar '(lambda (x) (rtos x 2 2)) lst2)
  527.               lst2 (apply '(lambda (h_L h h_R slope_L slope_R W_L W_R)
  528.                              (list h_L
  529.                                    (strcat slope_L " %")
  530.                                    h
  531.                                    (strcat slope_R " %")
  532.                                    h_R
  533.                                    (strcat "左宽:" W_L)
  534.                                    (strcat "右宽:" W_R)
  535.                              )
  536.                            )
  537.                           lst2
  538.                    )
  539.             )
  540.             (setq j 0)
  541.             (mapcar '(lambda (str / U_move)
  542.                        (setq U_move (nth j pt))
  543.                        (entmake
  544.                          (list '(0 . "TEXT")
  545.                                (cons 62 color)
  546.                                (append '(10) U_move)
  547.                                (cons 40 (* road_wide 0.1))
  548.                                (cons '1 str)
  549.                                (cons '71 0)
  550.                                (cons '72 1)
  551.                                (append '(11) U_move)
  552.                          )
  553.                        )
  554.                        (setq j (+ j 1))
  555.                      )
  556.                     lst2
  557.             )
  558.             (setq number (+ number 1)
  559.                   i         (+ i 1)
  560.             )
  561.           )
  562.          group
  563.        )
  564.      )
  565.     Line_segments
  566.   )
  567. )
  568. ;;  (setq tang   ( create_group_Line_segments   group_turning_point  6782.755 )   group_Line_segments (car tang )  tgg (cadr tang)  )  
  569. ;;    (setq group_widen (write_into_group_widen))   
  570. ;;  (setq stake_mark_group   (write_into_group_stake_mark))  (setq group_Z_out  ( creat_group_z  group_Line_segments    stake_mark_group )  )   






  571. ;; (setq group_turning_point_original (car ( create_turning_point_group_original ) ) )   
  572. ;; (setq group_turning_point (car  ( create_turning_point_group   group_turning_point_original  Z_road_start )  ) )   
  573. ;;  (setq group_vertical_curve  (create_group_vertical_curve ))(setq group_vertical_curve_2 ( create_group_vertical_curve_2  group_vertical_curve ) )   
  574. ;;  (setq group_superelevation (create_group_superelevation ) )     创建左右边坡数组
  575. (defun create_group_data_out (group_Line_segments
  576.                               group_widen        group_vertical_curve_2
  577.                               group_superelevation
  578.                               road_wide                frame_wide
  579.                               U_insert                mold
  580.                               Z_Δ                stake_mark_group
  581.                               Z_continue        /
  582.                               number                Uniform_group_center
  583.                               group_transition        group_move
  584.                               group                n_x
  585.                               n_y                scale
  586.                               group_Z_out
  587.                              )

  588.   (setq group_transition (create_group_transition group_Line_segments))
  589.   (if (not road_wide)                        ; 路面宽度
  590.     (setq road_wide 5.0)
  591.   )
  592.   (if (not frame_wide)                        ; 图框宽度
  593.     (setq frame_wide 297)
  594.   )
  595.   (if (not Z_Δ)                        ; 图框宽度
  596.     (setq Z_Δ 5)
  597.   )
  598.   (setq        n_x    (/ frame_wide (* road_wide 3.5))
  599.         n_x    (fix n_x)
  600.         n_y    (/ (* n_x 210) 297)
  601.         n_y    (fix n_y)
  602.         n_grid (* n_x n_y)
  603.   )
  604.   (setq        Uniform_group_center
  605.          (create_Uniform_distribution
  606.            n_x
  607.            n_y
  608.            frame_wide
  609.          )
  610.   )
  611.   (if (= Z_continue 0)
  612.     (setq group_Z_out
  613.            (creat_group_z group_Line_segments stake_mark_group)
  614.     )
  615.   )
  616.   ;; (setq U_insert (getpoint "输入插入点:"))   
  617.   (setq number 0)
  618.   (mapcar '(lambda (Line_segments / group)
  619.              (create_group_data_out_sub
  620.                Line_segments
  621.                mold
  622.              )
  623.            )
  624.           group_Line_segments
  625.   )
  626.   ;; 绘制每页的边框
  627.   (if (not (tblobjname "block" "图框"))
  628.     (make_drawing_frame 297 U_insert "图框")
  629.                                         ;创建一图框 ,图框宽度设置为297
  630.   )
  631.   (setq        residue        (rem number n_grid)
  632.         n        (/ (- number residue) n_grid) ; 页数
  633.   )
  634.   (if (> residue 0)
  635.     (setq n (+ n 1))
  636.   )
  637.   (setq        i     0
  638.         scale (/ frame_wide 297.0)
  639.   )
  640.   (repeat n
  641.     (setq b (* (/ frame_wide 297) 210)
  642.           U (list (+ (car U_insert) (* (* frame_wide 1.2) i))
  643.                   (cadr U_insert)
  644.             )
  645.     )
  646.     (entmake (list '(0 . "INSERT")
  647.                    (cons 2 "图框")
  648.                    (cons 10 U)
  649.                    (cons 41 scale)
  650.                    (cons 42 scale)
  651.                    (cons 43 scale)
  652.              )
  653.     )
  654.     (setq i (+ i 1))
  655.   )
  656. )
  657. ;; defun create_group_data_out 函数结束
  658. ;; ( create_group_data_out group_Line_segments group_widen  road_wide  frame_wide   U_insert  mold)  









  659. ;; 在一个给定的长方形页面中 建立一个点集合 ,该点集合均匀的分布在页面中,页面左下角点为原点(list 0 0 )   
  660. (defun create_Uniform_distribution
  661.                                    (n_x             n_y      Width    /
  662.                                     n_grid   i              j               n_1
  663.                                     n_grid   finite_field
  664.                                    )
  665.   ;;   (setq U_insert (getpoint "输入插入点:"))  
  666.   (if (not n_x)
  667.     (setq n_x 8)
  668.   )
  669.   (if (not n_y)
  670.     (setq n_y 4)
  671.   )

  672.   (setq        n_grid (* n_x n_y)
  673.         n_1    0
  674.         group  nil
  675.   )
  676.   (repeat n_grid
  677.     ;;确定行数 i  列数j  ,group 的方向是由:下->上,再从:左->右  
  678.     (setq j (rem n_1 n_y)
  679.           i (/ (- n_1 j) n_y)
  680.     )
  681.     (setq group (cons (list i j) group))
  682.     (setq n_1 (+ n_1 1))
  683.   )

  684.   (setq finite_field (reverse group))
  685.   ;; 对新建有限域finite_field 从原点:(0 0) 移位到 (0.75 0.75)  
  686.   (setq        group
  687.          (mapcar '(lambda (U)
  688.                     (apply '(lambda (x y)
  689.                               (list (+ x 0.75)
  690.                                     (+ y 0.75)
  691.                               )
  692.                             )
  693.                            U
  694.                     )
  695.                   )
  696.                  finite_field
  697.          )
  698.   )
  699.   ;; 对数组group (i j)    按原点0 进行放大 ,放大为 图框297*210 大 ,   
  700.   (setq        scale_x        (/ 297.0 (+ n_x 0.5))
  701.         scale_y        (/ 210.0 (+ n_y 0.5))
  702.                 ;; n_y  n_x 加0.5 是为了留下页面的左右、上下空间
  703.   )
  704.   (setq        k        (/ width 297.0)                ; 指定的图框大小
  705.         scale_x        (* scale_x k)
  706.         scale_y        (* scale_y k)
  707.   )
  708.   (mapcar '(lambda (U)
  709.              (apply '(lambda (x y)
  710.                        (list (* x scale_x)
  711.                              (* y scale_y)
  712.                        )
  713.                      )
  714.                     U
  715.              )
  716.            )
  717.           group
  718.   )
  719. )                                        ; (defun create_Uniform_distribution 函数结束   
  720. ;; (setq  Uniform_group_center  ( create_Uniform_distribution 5 4 600    )  )   


  721. ;;  (setq ss (ssget) )   (setq pt (getpoint "输入插入点:"))   
  722. ;;  (emkblk ss pt "tang")    (setq name "tang" )   
  723. (defun emkblk (ss pt name / i)
  724.   (entmake
  725.     (list '(0 . "block")
  726.           (cons 2 name)
  727.           '(70 . 0)
  728.           (cons 10 '(0 0))
  729.     )
  730.   )
  731.   (repeat (setq i (sslength ss))
  732.     (entmake (cdr (entget (ssname ss (setq i (1- i))))))
  733.   )
  734.   (entmake '((0 . "ENDBLK")))
  735.   (command "_.erase" ss "")
  736.   (entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
  737. )


  738. ;; 绘制图框  (setq U_insert  (getpoint "输入插入点:"))  
  739. (defun make_drawing_frame
  740.        (a U_insert name / b d U ss group i group_string)
  741.   (if (not a)
  742.     (setq a 600.0)
  743.   )
  744.   (setq b (* (/ a 297.0) 210))
  745.   (setq
  746.     group
  747.      (list '(0 0)
  748.            (list a 0)
  749.            (list a b)
  750.            (list 0 b)
  751.      )
  752.   )
  753.   (entmake
  754.     (append (list '(0 . "LWPOLYLINE")
  755.                   '(100 . "AcDbEntity")
  756.                   '(100 . "AcDbPolyline")
  757.                   (cons 90 (length group))
  758.                   (cons 70 1)                ; 二维曲线闭合
  759.             )
  760.             (mapcar '(lambda (U) (cons 10 U)) group)
  761.     )
  762.   )
  763.   (setq ss (ssget "L"))                        ;用刚刚生成的图形创造一个选择集合ss
  764.   (setq d (/ b 29.0))
  765.   (entmakex
  766.     (list '(0 . "line")
  767.           (cons 10 (list 0 d))
  768.           (cons 11 (list a d))
  769.     )
  770.   )
  771.   (ssadd (entlast) ss)
  772.   (setq        L     (/ a 5)
  773.         U     (list L 0)
  774.         i     1
  775.         group nil

  776.   )
  777.   (repeat 4
  778.     (entmakex
  779.       (list '(0 . "line")
  780.             (cons 10 (list (* L i) 0))
  781.             (cons 11 (list (* L i) d))
  782.       )
  783.     )
  784.     (ssadd (entlast) ss)
  785.     (setq U        (list (* L (- i 1)) (* 0.1 d))
  786.           group        (cons U group)
  787.     )
  788.     (setq i (+ i 1))
  789.   )
  790.   (setq        U     (list (* L (- i 1)) (* 0.1 d))
  791.         group (cons U group)
  792.         group (reverse group)
  793.   )
  794.   (setq        group_string
  795.          (list "项目名称:" "设计单位:" "监理单位:" "施工单位:"
  796.                "制图人:ashleytgg")
  797.   )
  798.   (setq i 0)
  799.   (repeat 5
  800.     (entmake
  801.       (list '(0 . "TEXT")
  802.             (append '(10) (nth i group)) ;第一对齐点(在 OCS 中)
  803.             (cons 40 (* d 0.65))        ; 文字高度  
  804.             (cons '1 (nth i group_string)) ; 内容
  805.       )
  806.     )
  807.     (ssadd (entlast) ss)
  808.     (setq i (+ i 1))
  809.   )
  810.   (if (not name)
  811.     (setq name "tang")
  812.   )
  813.   (emkblk ss U_insert name)
  814. )                                        ;  make_drawing_frame  函数结束
  815. ;;   (setq U_insert  (getpoint "输入插入点:"))   ( make_drawing_frame  600  U_insert  "tang"  )   






  816. ;; 绘图用函数函数结束 88888    绘图用函数函数结束88888     绘图用函数函数结束88888    绘图用函数函数结束88888    绘图用函数函数结束88888   绘图用函数函数结束   






  817. ;; dcl 使用函数  888888888888888888        dcl 使用函数  888888888888888888  dcl 使用函数  888888888888888888dcl   使用函数  888888888888888888    dcl 使用函数  888888888888888888


  818. (defun Dcl_write (lst / dcl_file str file)
  819.   (vl-load-com)
  820.   (setq dcl_file (vl-filename-mktemp nil nil ".dcl"))
  821.   (setq file (open dcl_file "w"))
  822.   (foreach str lst (write-line str file))
  823.   (close file)
  824.   (setq id (load_dialog dcl_file))
  825. )

  826. (defun C:use_dcl (/                      id
  827.                   sdt                      group_vertical_curve
  828.                   group_vertical_curve_2
  829.                   parameter              list_key
  830.                   list_key_2              list_key_3
  831.                   U                      group
  832.                   group_JD_list              group_JD_plane
  833.                   group_JD_Width      group_JD_slope
  834.                   group_vertical_segments
  835.                   mold                      group_turning_point
  836.                   group_Line_segments group_widen
  837.                   group_superelevation
  838.                   stake_mark_group    Z_Δ
  839.                   Z_continue              group_z_str
  840.                  )
  841.   (setq        string_dcl
  842.          '("JD_item:list_box{  key="JD_list"; label="交点参数表:"; value=0;"
  843.            "list=" ( 转点号  转点状态nil) 转点坐标  ( Lh1 R  Lh2  ) \\n ( 转点号  转点状态t) 转点坐标 (R_start R R_end  Lh1 Lh2 )";"
  844.            "fixed_width=true; width=100; allow_accept=true;}"
  845.            "table_wide :list_box{  key="table_wide";  value=0;"
  846.            "list=" 交点号  交点加宽值 ";"
  847.            "allow_accept=true;}"
  848.            "scfg:toggle{  label="曲线加宽方式,选中为直线加宽,不选一般加宽";  key="scfg";}"
  849.            "Z_road_start :edit_box {label="起点桩号:";  key= "Z_road_start";value="0";allow_accept=true;is_enabled=false;}"
  850.            "insert_table_J :button {label="请选择交点参数列表:";  key= "insert_table_J"; fixed_width=true;width=20; }"
  851.            "insert_table_W :button {label="请选择加宽参数列表:";  key= "insert_table_W"; fixed_width=true;width=20; }"
  852.            "JD_item_vertical:list_box{  key="JD_list_vertical"; label="竖曲线交点参数表:"; value=0;"
  853.            "list=" ( 转点号  转点桩号 转点高程  转点半径 )    ";"
  854.            "fixed_width=true;width=100;"
  855.            "allow_accept=true;}"
  856.            "insert_table_J_V :button {label="请选择竖曲线交点参数列表:";  key= "insert_table_J_V";  fixed_width=true;width=10;   }"
  857.            "display :button {label="显示竖曲线、平面曲线交点参数:";  key= "display";  fixed_width=true;width=10;   }"
  858.            "N_x :edit_box {label="N(X):";  key= "N_x";value="0";allow_accept=true;}"
  859.            "E_Y :edit_box {label="E(Y):";  key= "E_Y";value="0";allow_accept=true;}"
  860.            "insert_point : button {label="请选择插入点:";  key= "insert_point";  fixed_width=true;width=20;} "
  861.            "road_wide :edit_box {label="请选择路面宽度:(不包括土路肩):";  key= "road_wide";value="5.0";allow_accept=true;}"
  862.            "frame_wide :edit_box {label="请选择设计图框的宽度:";  key= "frame_wide";value="297";allow_accept=true;}"
  863.            "Z_Δ :edit_box {label="请选择桩号的间距:";  key= "Z_Δ";value="5";allow_accept=true;}"
  864.            "table_superelevation :list_box{  key="table_superelevation";  value=0;"
  865.            "list=" 交点号  交点超高值 ";"
  866.            "allow_accept=true;}"
  867.            "insert_table_slope :button {label="请选择超高参数列表:";  key= "insert_table_slope"; fixed_width=true;width=20; }"
  868.            "table_Z :list_box{  key="table_Z";  value=0;"
  869.            "list="设计桩号列表\\n 设计桩号列表2";"
  870.            "allow_accept=true;is_enabled=false;}"
  871.            "stake_Z :button {label="选择设计桩号列表";  key= "stake_Z";   fixed_width=true;width=8;is_enabled=false;}"
  872.            "draw_table :button {label="绘制CAD表格";  key= "draw_table";   fixed_width=true;width=8;is_enabled=true;}"
  873.            "draw_excel :button {label="绘制EXCEL表格";  key= "draw_excel";   fixed_width=true;width=8;is_enabled=true;}"
  874.            "draw_standard_section:"
  875.            "dialog{  label="绘制公路标准断面";  spacer;"
  876.            "fixed_width=true;width=120;"
  877.            ": boxed_row  {JD_item;"
  878.            ": column {"
  879.            "insert_table_J;"
  880.            ":text{label="请填入线路起点桩号:";}"
  881.            "Z_road_start ;"
  882.            "}"
  883.            "}"
  884.            ": boxed_row  {JD_item_vertical;"
  885.            ": column {  fixed_width=true;width=10;"
  886.            ": column { insert_table_J_V ;display ; }"
  887.            "}"
  888.            "}"
  889.            ": boxed_row  {"
  890.            ": boxed_column   { fixed_width=true;width=30;"
  891.            "label="交点加宽参数参数表:";"
  892.            "table_wide ;"
  893.            ": column { scfg ; insert_table_W ; }"
  894.            "}"
  895.            ": boxed_column   { fixed_width=true;width=40;"
  896.            "label="交点超高参数参数表:";"
  897.            "table_superelevation ;"
  898.            "insert_table_slope;"
  899.            "}"
  900.            ": boxed_column   { fixed_width=true;width=40;"
  901.            "label="设计桩号列表";"
  902.            "table_Z;"
  903.            "stake_Z;"
  904.            "}"
  905.            "}"
  906.            ": boxed_row   {"
  907.            ": boxed_column  { fixed_width=true;width=30;"
  908.            "N_x ;  E_Y;insert_point;"
  909.            "}"
  910.            ":  boxed_column    {fixed_width=true;width=30; road_wide ; frame_wide;Z_Δ; }"
  911.            ":  boxed_column    {fixed_width=true;width=20;"
  912.            ":text{label="选择桩号形式";key="Z_txt";}"
  913.            ":boxed_radio_column {:radio_button { key="z_con"; label="连续桩号";value=1;}"
  914.            ":radio_button  { key="z_desi"; label="设计桩号";}"
  915.            "}"
  916.            "}"
  917.            ":  boxed_column {"
  918.            "draw_excel;"
  919.            ": button {label="输出cass横断面";key="draw_cass";is_default=true;fixed_width=true;width=12;}"
  920.            "}"
  921.            ":  boxed_column {"
  922.            ": button {label="绘制横断面";key="ok";is_default=true;fixed_width=true;width=12;}"
  923.            "draw_table;"
  924.            ": button {label="退出";key="cancel";is_cancel=true;fixed_width=true;width=12;}"
  925.            "}"
  926.            "}"
  927.            "}"
  928.            "vertical_segments :list_box{  key="vertical_segments";  value=0;"
  929.            "list="( 转点号I j)Z_start Z_end  起点高程  线元起点象限角  R  转角Δ) ";"
  930.            "allow_accept=true;}"
  931.            "Line_segments :list_box{  key="Line_segments";value=0;"
  932.            "list="( 转点号I j) 起点半径 终点半径  曲线长度  偏转系数  线元起点方位角  起点桩号  起点坐标 ) ";"
  933.            "allow_accept=true;}"
  934.            "display_calculate_message:"
  935.            "dialog{  label="显示计算信息";  spacer;"
  936.            "fixed_width=true;width=140;"
  937.            ":boxed_column{  label="线元参数参数表:";  Line_segments ;}"
  938.            ":boxed_column{  label="竖曲线线元参数表:";  vertical_segments  ;}"
  939.            ": boxed_row    {"
  940.            ": button {label="退出";key="cancel";is_cancel=true;fixed_width=true;width=12;}"
  941.            ": button {label="返回原界面";key="accept";is_default=true;fixed_width=true;width=12;}"
  942.            "}"
  943.            "}"
  944.           )
  945.   )

  946.   (if nil
  947.     (setq ID
  948.            (load_dialog
  949.              "D:\\工作文件\\新建文件夹\\work\\公路曲线简易程序\\用变换群绘制公路曲线\\绘制标准断面\\绘制标准断面"
  950.            )
  951.     )
  952.     (progn
  953.       (Dcl_write string_dcl)
  954.       (setq string_dcl nil)
  955.     )
  956.   )
  957.   (setq        sdt           1
  958.         list_key   (list "JD_list"           "Z_road_start"
  959.                          "JD_list_vertical"
  960.                          "table_wide"           "scfg"
  961.                          "table_superelevation"
  962.                          "road_wide"           "frame_wide"
  963.                          "Z_Δ"                   "z_con"
  964.                          "z_desi"           "table_Z"
  965.                          "N_x"                   "E_Y"
  966.                         )
  967.         list_key_2 (list "table_Z" "stake_Z")
  968.         list_key_3 (list "Z_Δ")
  969.   )
  970.   (while (>= sdt 0)
  971.     (if        (< sdt 10)
  972.       (progn
  973.         (if (not (new_dialog "draw_standard_section" id))
  974.           (exit)
  975.         )
  976.         ;; 对对对话框中的参数进行重新设置  
  977.         (if (or (= sdt 3) (= sdt 6))
  978.           (progn
  979.             (if        (or group_JD_plane        group_JD_list
  980.                     group_JD_Width        group_JD_slope
  981.                     group_z_str
  982.                    )
  983.               (progn
  984.                 (start_list "JD_list" 3)
  985.                 (mapcar 'add_list group_JD_plane)
  986.                 (end_list)
  987.                 (start_list "JD_list_vertical" 3)
  988.                 (mapcar 'add_list group_JD_list)
  989.                 (end_list)
  990.                 (start_list "table_wide" 3)
  991.                 (mapcar 'add_list group_JD_Width)
  992.                 (end_list)
  993.                 (start_list "table_superelevation" 3)
  994.                 (mapcar 'add_list group_JD_slope)
  995.                 (end_list)
  996.                 (start_list "table_Z" 3) ; 把原先列表去掉,换成新的
  997.                 (mapcar 'add_list group_z_str)
  998.                 (end_list)
  999.               )
  1000.             )
  1001.             (set_inform_dialog parameter list_key)
  1002.             (if        (and (= (get_tile "z_con") "0")
  1003.                      (= (get_tile "z_desi") "1")
  1004.                 )
  1005.               (progn
  1006.                 (mode_value 0 list_key_2)
  1007.                 (mode_value 1 list_key_3)
  1008.               )
  1009.               (progn
  1010.                 (mode_value 1 list_key_2)
  1011.                 (mode_value 0 list_key_3)
  1012.               )
  1013.             )
  1014.           )
  1015.         )
  1016.         (action_tile
  1017.           "cancel"
  1018.           "(done_dialog -2 )"
  1019.         )
  1020.         (action_tile                        ; 竖曲线交点参数 插入表格的动作函数   
  1021.           "insert_table_J_V"
  1022.           "(action_insert_table_J_V)"
  1023.         )
  1024.         (action_tile                        ; 平面曲线交点参数 插入表格的动作函数  
  1025.           "insert_table_J"
  1026.           "(action_insert_table_J)
  1027.           (action_calculate \t group_turning_point)
  1028.            (setq parameter(get_inform_dialog \t list_key))
  1029.           "
  1030.         )
  1031.         (action_tile                        ; 平面曲线交点的加宽参数插入的动作函数  
  1032.           "insert_table_W"
  1033.           "(action_insert_table_W)"
  1034.         )
  1035.         (action_tile
  1036.           "insert_point"
  1037.           "(setq parameter(get_inform_dialog \t list_key))(done_dialog 3 )"
  1038.         )
  1039.         (action_tile                        ; 绘制标准断面  
  1040.           "ok"
  1041.           "(setq parameter(get_inform_dialog \t list_key))(done_dialog -8 )"
  1042.         )
  1043.         (action_tile
  1044.           "display"
  1045.           "(setq parameter(get_inform_dialog \t list_key)) (done_dialog 18 )"
  1046.         )

  1047.         (action_tile                        ;交点的超高参数插入的动作函数  
  1048.           "insert_table_slope"
  1049.           "(action_insert_table_slope)"
  1050.         )
  1051.         (action_tile
  1052.           "z_con"
  1053.           "(set_tile "Z_txt"  "连续桩号")
  1054.           ( mode_value  1  \t  list_key_2 )
  1055.           ( mode_value  0  \t  list_key_3 )
  1056.           "
  1057.         )
  1058.         (action_tile
  1059.           "z_desi"
  1060.           "(set_tile "Z_txt"  "设计桩号")
  1061.           ( mode_value  0  \t  list_key_2 )
  1062.           ( mode_value  1  \t  list_key_3 )"
  1063.         )
  1064.         (action_tile                        ;设计桩号参数的动作函数  
  1065.           "stake_Z"
  1066.           "(setq stake_mark_group (action_stake_Z ))"
  1067.         )
  1068.         (action_tile
  1069.           "draw_table"
  1070.           "(setq parameter(get_inform_dialog \t list_key))(done_dialog -9 )"
  1071.         )
  1072.         (action_tile
  1073.           "draw_excel"
  1074.           "(setq parameter(get_inform_dialog \t list_key))(done_dialog -12 )"
  1075.         )
  1076.         (action_tile
  1077.           "draw_cass"
  1078.           "(setq parameter(get_inform_dialog \t list_key))(done_dialog -13 )"
  1079.         )

  1080.         (setq sdt (start_dialog))
  1081.       )
  1082.     )                                        ; (if (< sdt 10) 函数结束
  1083.     (if        (>= sdt 10)
  1084.       (progn
  1085.         (if (not (new_dialog "display_calculate_message" id))
  1086.           (exit)
  1087.         )
  1088.         (action_display group_vertical_segments group_Line_segments)
  1089.         (action_tile
  1090.           "accept"
  1091.           "(done_dialog 6 )"
  1092.         )
  1093.         (action_tile
  1094.           "cancel"
  1095.           "(done_dialog -2 )"
  1096.         )
  1097.         (setq sdt (start_dialog))
  1098.       )
  1099.     )                                        ; (if (>= sdt 10) 函数结束
  1100.     (if        (= sdt 3)
  1101.       (setq u              (getpoint "请选择插入点:")
  1102.             U              (list (cadr U) (car U))
  1103.             U              (mapcar 'rtos U)
  1104.             parameter
  1105.                       (mapcar '(lambda (i)
  1106.                                  (nth i parameter)
  1107.                                )
  1108.                               (list 0 1 2 3 4 5 6 7 8 9 10 11)
  1109.                       )
  1110.             parameter (append parameter U)
  1111.             parameter
  1112.                       (mapcar '(lambda (i)
  1113.                                  (nth i parameter)
  1114.                                )
  1115.                               (list 0 1 2 3 4 5 6 7 8 9 10 11 12 13)
  1116.                       )
  1117.       )
  1118.     )                                        ; (if        (= sdt 3) 函数结束  
  1119.   )                                        ; (while (> sdt 0) 函数结束  


  1120.   (unload_dialog id)
  1121.   (if (= sdt -8)
  1122.     (progn
  1123.       ;; lst 结构为 mold   "N_x"  "E_Y"  "road_wide" "frame_wide" "Z_Δ"   "z_con"
  1124.       (setq lst               (mapcar '(lambda        (i)
  1125.                                   (nth i parameter)
  1126.                                 )
  1127.                                (list 12 13 6 7 8)
  1128.                        )
  1129.             lst               (mapcar 'atof lst)
  1130.             U_insert   (list (cadr lst) (car lst))
  1131.             road_wide  (caddr lst)
  1132.             frame_wide (nth 3 lst)
  1133.             Z_Δ       (nth 4 lst)        ;桩号增加值
  1134.             lst               (mapcar '(lambda        (i)
  1135.                                   (atoi (nth i parameter))
  1136.                                 )
  1137.                                (list 4 9)
  1138.                        )
  1139.             mold       (car lst)
  1140.             Z_continue (cadr lst)        ; 表示连续或设计桩号的状态值
  1141.       )
  1142.       (setq lst        (mapcar 'read parameter)
  1143.             lst        (mapcar        '(lambda (i)
  1144.                            (nth i lst)
  1145.                          )
  1146.                         (list 12 13 6 7 8 4 9)
  1147.                 )
  1148.             lst        (mapcar 'numberp lst)
  1149.       )
  1150.       (if (not (apply 'and lst))
  1151.         (progn
  1152.           (alert "您输入了内容格式不对!")
  1153.           (exit)
  1154.         )
  1155.       )
  1156.       (if group_Line_segments
  1157.         (progn
  1158.           (create_group_data_out
  1159.             group_Line_segments        group_widen
  1160.             group_vertical_curve_2                    group_superelevation
  1161.             road_wide                frame_wide            U_insert
  1162.             mold                Z_Δ                    stake_mark_group
  1163.             Z_continue
  1164.            )                                ; mold 为加宽方式
  1165.         )
  1166.         (alert "您还没有输入完整的线路参数!")
  1167.       )
  1168.     )
  1169.   )                                        ;  (if (= sdt 8) 函数结束
  1170.   (if (= sdt -9)
  1171.     (progn
  1172.       ;; lst 结构为 mold   "N_x"  "E_Y"     "Z_Δ"   
  1173.       (setq lst               (mapcar '(lambda        (i)
  1174.                                   (nth i parameter)
  1175.                                 )
  1176.                                (list 12 13 8)
  1177.                        )
  1178.             lst               (mapcar 'atof lst)
  1179.             U_insert   (list (cadr lst) (car lst))
  1180.             Z_Δ       (caddr lst)        ;桩号增加值
  1181.             ;;  lst 结构为   "scfg"  "z_con"   
  1182.             lst               (mapcar '(lambda        (i)
  1183.                                   (atoi (nth i parameter))
  1184.                                 )
  1185.                                (list 4 9)
  1186.                        )
  1187.             mold       (car lst)
  1188.             Z_continue (cadr lst)        ; 表示连续或设计桩号的状态值
  1189.       )
  1190.       (if group_Line_segments
  1191.         (progn
  1192.           (create_table_data_out
  1193.             group_Line_segments          group_widen
  1194.             group_vertical_curve_2
  1195.             group_superelevation  U_insert
  1196.             mold                  Z_Δ
  1197.             stake_mark_group          Z_continue
  1198.            )
  1199.         )
  1200.         (alert "您还没有输入完整的线路参数!")
  1201.       )
  1202.     )
  1203.   )                                        ;  (if (= sdt -9) 函数结束
  1204.   (if (= sdt -12)
  1205.     (progn
  1206.       ;; lst 结构为 mold   "N_x"  "E_Y"     "Z_Δ"   
  1207.       (setq lst               (mapcar '(lambda        (i)
  1208.                                   (nth i parameter)
  1209.                                 )
  1210.                                (list 12 13 8)
  1211.                        )
  1212.             lst               (mapcar 'atof lst)
  1213.             Z_Δ       (caddr lst)        ;桩号增加值
  1214.             ;;  lst 结构为   "scfg"  "z_con"   
  1215.             lst               (mapcar '(lambda        (i)
  1216.                                   (atoi (nth i parameter))
  1217.                                 )
  1218.                                (list 4 9)
  1219.                        )
  1220.             mold       (car lst)
  1221.             Z_continue (cadr lst)        ; 表示连续或设计桩号的状态值
  1222.       )
  1223.       (if group_Line_segments
  1224.         (progn
  1225.           (create_excel_data_out
  1226.             group_Line_segments          group_widen
  1227.             group_vertical_curve_2
  1228.             group_superelevation  mold
  1229.             Z_Δ                  stake_mark_group
  1230.             Z_continue
  1231.            )
  1232.         )
  1233.         (alert "您还没有输入完整的线路参数!")
  1234.       )
  1235.     )
  1236.   )                                        ;  (if (= sdt -12) 函数结束
  1237.   (if (= sdt -13)
  1238.     (progn
  1239.       (setq lst               (mapcar '(lambda        (i)
  1240.                                   (nth i parameter)
  1241.                                 )
  1242.                                (list 3 13 8)
  1243.                        )
  1244.             lst               (mapcar 'atof lst)
  1245.             Z_Δ       (caddr lst)        ;桩号增加值
  1246.             road_wide  (car lst)

  1247.             ;;  lst 结构为   "scfg"  "z_con"   
  1248.             lst               (mapcar '(lambda        (i)
  1249.                                   (atoi (nth i parameter))
  1250.                                 )
  1251.                                (list 4 9)
  1252.                        )
  1253.             mold       (car lst)
  1254.             Z_continue (cadr lst)        ; 表示连续或设计桩号的状态值
  1255.       )
  1256.       (if group_Line_segments
  1257.         (progn
  1258.           (create_cass_data_out
  1259.             group_Line_segments          group_widen
  1260.             group_vertical_curve_2
  1261.             group_superelevation  mold
  1262.             Z_Δ                  stake_mark_group
  1263.             Z_continue                  road_wide
  1264.            )
  1265.         )
  1266.         (alert "您还没有输入完整的线路参数!")
  1267.       )
  1268.     )
  1269.   )                                        ;  (if (= sdt -13) 函数结束   
  1270. )


  1271. ;; 定义"insert_table_J_V" 按钮的动作
  1272. (defun action_insert_table_J_V
  1273.                                (/ lst n group)
  1274.   (setq group_vertical_curve (create_group_vertical_curve))
  1275.   (setq        group_vertical_curve_2
  1276.          (create_group_vertical_curve_2
  1277.            group_vertical_curve
  1278.          )
  1279.   )
  1280.   (setq n (length group_vertical_curve))
  1281.   (setq        group_JD_list
  1282.          (mapcar '(lambda (lst)
  1283.                     (apply '(lambda (JD Z h R)
  1284.                               (strcat "JD: "
  1285.                                       (itoa JD)
  1286.                                       "   转点桩号:"
  1287.                                       (rtos Z 2 3)
  1288.                                       "   转点高程:"
  1289.                                       (rtos h 2 2)
  1290.                                       "   转点半径:"
  1291.                                       (rtos R 2 2)
  1292.                               )
  1293.                             )
  1294.                            lst
  1295.                     )
  1296.                   )
  1297.                  group_vertical_curve
  1298.          )
  1299.   )
  1300.   (setq        group_vertical_segments
  1301.          (mapcar '(lambda (lst                ; (setq lst ( nth 5 group_vertical_curve_2 ) )   
  1302.                            / lst2 lst3 element i j)
  1303.                     (setq lst2          (mapcar '(lambda (i)
  1304.                                              (rtos (nth i lst) 2 2)
  1305.                                            )
  1306.                                           (list 1 2 3 5)
  1307.                                   )
  1308.                           lst3          (mapcar '(lambda (i)
  1309.                                              (angtos (nth i lst) 1 6)
  1310.                                            )
  1311.                                           (list 4 6)
  1312.                                   )
  1313.                           element (car lst) ; 对第一个元素进行处理  
  1314.                           i          (itoa (car element))
  1315.                           j          (itoa (cadr element))
  1316.                           element (strcat i "-" j)
  1317.                           lst          (append (list element) lst2 lst3)
  1318.                                         ; lst 顺序为 (list 0 1 2 3 5 4 6 )  
  1319.                           ;; 对lst 进行逆置换, 对 (list 0  1 2 3 5 4 6 )  用 (list 0 1 2 3  5 4 6 ) 置换   
  1320.                           lst          (mapcar '(lambda (i)
  1321.                                              (nth i lst)
  1322.                                            )
  1323.                                           (list 0 1 2 3 5 4 6)
  1324.                                   )
  1325.                     )
  1326.                     ;; 对lst数组进行注释
  1327.                     (setq
  1328.                       lst2 (list "JD:"            "Z_start:" "Z_end:"
  1329.                                  "H:"            "α0:"     "R:"
  1330.                                  "α_Δ:"
  1331.                                 )
  1332.                       lst  (append lst lst2)
  1333.                       lst  (mapcar '(lambda (i)
  1334.                                       (nth i lst)
  1335.                                     )
  1336.                                    (list 7 0 8 1 9 2 10 3 11 4 12 5 13 6)
  1337.                            )
  1338.                     )
  1339.                     (setq lst (vl-princ-to-string lst)
  1340.                           lst (vl-string-left-trim "\(" lst)
  1341.                           lst (vl-string-right-trim "\)" lst)
  1342.                     )
  1343.                   )
  1344.                  group_vertical_curve_2
  1345.          )
  1346.   )
  1347.   (start_list "JD_list_vertical" 3)
  1348.   (mapcar 'add_list group_JD_list)
  1349.   (end_list)
  1350.   (set_tile "JD_list_vertical" (itoa n))
  1351. )



  1352. ;; 用参数parameter 对控件集合list_key 进行参数重置
  1353. (defun set_inform_dialog
  1354.                          (parameter list_key / i lst)
  1355.   (setq i 0)
  1356.   (mapcar '(lambda (x / str)
  1357.              (setq str (nth i parameter))
  1358.              (set_tile x str)
  1359.              (setq i (+ 1 i))
  1360.            )
  1361.           list_key
  1362.   )
  1363. )
  1364. ;;( set_inform_dialog  parameter  list_key )     

  1365. ;;获取控件集合list_key 的参数parameter   
  1366. (defun get_inform_dialog
  1367.                          (list_key / lst)
  1368.   (mapcar '(lambda (x) (get_tile x))
  1369.           list_key
  1370.   )
  1371. )

  1372. ;; 定义平面曲线插入交点文件按钮的函数     
  1373. (defun action_insert_table_J (/ lst group Z_road_start)
  1374.   (setq
  1375.     lst        (create_turning_point_group_original)
  1376.     group_turning_point_original
  1377.      (car lst)
  1378.     Z_road_start
  1379.      (rtos (cadr lst))
  1380.   )
  1381.   (setq        lst                    (create_turning_point_group
  1382.                               group_turning_point_original
  1383.                               Z_road_start
  1384.                             )                ; Z_road_start 在此程序中不变  
  1385.         group_turning_point (car lst)
  1386.   )
  1387.   ;; 用group_turning_point 数组分别对列表框 "JD_list"   
  1388.   (setq        group
  1389.          (mapcar
  1390.            '(lambda (lst / state subset_label)
  1391.               (apply '(lambda (x_0 x_1 x_2 x_3)
  1392.                         (setq x_1 (mapcar 'rtos x_1)
  1393.                               x_1 (list "N:" (cadr x_1) " E:" (car x_1))
  1394.                               x_1 (apply 'strcat x_1)
  1395.                         )
  1396.                         (if (cadr x_0)
  1397.                           (progn
  1398.                             (setq state "Yes")
  1399.                             (setq
  1400.                               x_2 (apply '(lambda (y_0 y_1 y_2 y_3 y_4)
  1401.                                             (setq subset_label (list "R_s"
  1402.                                                                      "R"
  1403.                                                                      "R_e"
  1404.                                                                      "Lh1"
  1405.                                                                      "Lh2")
  1406.                                                   subset       (list y_0 y_1 y_2 y_3 y_4)
  1407.                                                   subset       (append subset subset_label)
  1408.                                             )
  1409.                                             (mapcar '(lambda (i)
  1410.                                                        (nth i subset)
  1411.                                                      )
  1412.                                                     (list 5 0 6 1 7 2 8 3 9 4)
  1413.                                             )
  1414.                                           )
  1415.                                          x_2
  1416.                                   )
  1417.                             )
  1418.                           )
  1419.                           (progn
  1420.                             (setq state "No")
  1421.                             (setq x_2 (apply '(lambda (y_0 y_1 y_2)
  1422.                                                 (setq subset_label (list "Lh1" "R" "Lh2")
  1423.                                                       subset           (list y_0 y_1 y_2)
  1424.                                                       subset           (append subset subset_label)
  1425.                                                 )
  1426.                                                 (mapcar        '(lambda (i)
  1427.                                                            (nth i subset)
  1428.                                                          )
  1429.                                                         (list 3 0 4 1 5 2)
  1430.                                                 )
  1431.                                               )
  1432.                                              x_2
  1433.                                       )
  1434.                             )
  1435.                           )
  1436.                         )                ; (if (cadr x_0) 函数结束
  1437.                         (setq x_2 (vl-princ-to-string x_2)
  1438.                               x_2 (vl-string-left-trim "\(" x_2)
  1439.                               x_2 (vl-string-right-trim "\)" x_2)
  1440.                         )
  1441.                         (list "JD:" (car x_0) state x_1 x_2)
  1442.                       )
  1443.                      lst
  1444.               )
  1445.             )
  1446.            group_turning_point
  1447.          )
  1448.   )
  1449.   (setq        group_JD_plane
  1450.          (mapcar '(lambda (lst / string)
  1451.                     (setq string (vl-princ-to-string lst)
  1452.                           string (vl-string-left-trim "\(" string)
  1453.                           string (vl-string-right-trim "\)" string)
  1454.                     )
  1455.                   )
  1456.                  group
  1457.          )
  1458.   )

  1459.   (start_list "JD_list" 3)
  1460.   (mapcar 'add_list group_JD_plane)
  1461.   (end_list)
  1462.   ;;用Z_road_start 对编辑框"Z_road_start" 进行填充
  1463.   (set_tile "Z_road_start" Z_road_start)

  1464. )                                        ;   action_insert_table_J 函数结束





  1465. (defun action_insert_table_W (/ lst group)
  1466.   (setq group_widen (write_into_group_widen))
  1467.   ;; 用group_widen 数组分别对列表框 "table_wide" 进行填充  
  1468.   (setq        group_JD_Width
  1469.          (mapcar '(lambda (lst
  1470.                            /
  1471.                            JD
  1472.                            W
  1473.                           )
  1474.                     (setq JD (itoa (car lst))
  1475.                           W  (rtos (cadr lst) 2 3)
  1476.                     )
  1477.                     (strcat "JD: " JD "  加宽:" W)

  1478.                   )
  1479.                  group_widen
  1480.          )
  1481.   )
  1482.   (start_list "table_wide" 3)
  1483.   (mapcar 'add_list group_JD_Width)
  1484.   (end_list)
  1485. )                                        ;   action_insert_table_W 函数结束




  1486. (defun action_calculate
  1487.        (group_turning_point / lst group road_start group_sum n)
  1488.   (setq        road_start (get_tile "Z_road_start")
  1489.         road_start (read road_start)
  1490.   )
  1491.   (if (not (numberp road_start))
  1492.     (progn
  1493.       (alert "您输入的起止桩号不是实数!")
  1494.       (exit)
  1495.     )
  1496.   )
  1497.   (if group_turning_point
  1498.     (setq
  1499.       lst
  1500.                           (create_group_Line_segments group_turning_point road_start)
  1501.       group_Line_segments
  1502.                           (car lst)
  1503.     )
  1504.   )
  1505. )                                        ;   action_calculate 函数结束


  1506. ;; 显示按钮 display 的动作函数
  1507. (defun action_display
  1508.                       (group_vertical_segments
  1509.                        group_Line_segments /
  1510.                        n                   group
  1511.                        group_sum
  1512.                       )
  1513.   (if group_vertical_segments
  1514.     (progn
  1515.       (start_list "vertical_segments" 3)
  1516.       (mapcar 'add_list group_vertical_segments)
  1517.       (end_list)
  1518.       (setq n (length group_vertical_curve_2))
  1519.       (set_tile "vertical_segments" (itoa n))
  1520.     )
  1521.   )
  1522.   (if group_Line_segments
  1523.     (progn
  1524.       (setq group_sum (apply 'append group_Line_segments))
  1525.       ;; 用 group_Line_segments 填充列表框 "Line_segments"
  1526.       (setq group_sum
  1527.              (mapcar                        ; (setq lst (car group_sum))  (setq x_7 ( nth 7  lst))   
  1528.                '(lambda        (lst / lenth lst_label)
  1529.                   (apply '(lambda (x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7)
  1530.                             (setq x_0 (mapcar 'itoa x_0)
  1531.                                   x_0 (list (car x_0) "-" (cadr x_0))
  1532.                                   x_0 (apply 'strcat x_0)
  1533.                             )
  1534.                             (setq x_7 (mapcar 'rtos x_7)
  1535.                                   x_7 (list "N:" (cadr x_7) " E:" (car x_7))
  1536.                                   x_7 (apply 'strcat x_7)
  1537.                             )
  1538.                             (setq
  1539.                               x_6 (f_zhuanghao x_6)
  1540.                             )
  1541.                             (if        (atom x_3)
  1542.                               (setq lenth x_3)
  1543.                               (setq lenth (car x_3))
  1544.                             )
  1545.                             (setq lenth        (* lenth 1.0)
  1546.                                   x_3        (rtos lenth 2 2)
  1547.                                   x_5        (+ (* x_5 -1) (/ pi 2))
  1548.                                         ; 把象限角变成方位角
  1549.                                   x_5        (angtos x_5 1 6)
  1550.                             )
  1551.                             ;; 对(list x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7 ) 进行标注
  1552.                             (setq lst            (list x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7)
  1553.                                   lst_label (list "R_s:"
  1554.                                                   "R_e:"
  1555.                                                   "lenth:"
  1556.                                                   "reflex:"
  1557.                                                   "α_s:"
  1558.                                                  )
  1559.                                   lst            (append lst lst_label)
  1560.                             )
  1561.                             ;;  lst顺序为 (0 1 2 3 4 5 6 7 8 9 10 11 12 )
  1562.                             (mapcar '(lambda (i)
  1563.                                        (nth i lst)
  1564.                                      )
  1565.                                     (list 0 8 1 9 2 10 3 11 4 12 5 6 7)
  1566.                             )
  1567.                           )
  1568.                          lst
  1569.                   )
  1570.                 )
  1571.                group_sum
  1572.              )
  1573.       )
  1574.       (setq group                        ; (setq lst (car group_sum ))  
  1575.              (mapcar '(lambda (lst / string)
  1576.                         (setq string (vl-princ-to-string lst))
  1577.                         (setq string (vl-string-left-trim "\(" string)
  1578.                               string (vl-string-right-trim "\)" string)
  1579.                         )
  1580.                       )
  1581.                      group_sum
  1582.              )
  1583.       )
  1584.       (start_list "Line_segments" 3)
  1585.       (mapcar 'add_list group)
  1586.       (end_list)
  1587.     )
  1588.     ;; 当group_Line_segments  数组为空时
  1589.     (progn
  1590.       (start_list "Line_segments" 2)
  1591.       (mapcar 'add_list
  1592.               (list "group_Line_segments 交点数组为空!")
  1593.       )
  1594.       (end_list)
  1595.     )
  1596.   )
  1597.   (setq n (length group))
  1598.   (set_tile "Line_segments" (itoa n))
  1599. )
  1600. ;;  ( action_display  group_vertical_segments  group_Line_segments )  



  1601. ;; 定义插入 交点超高参数 的动作函数   
  1602. (defun action_insert_table_slope (/ n)
  1603.   (setq group_superelevation (create_group_superelevation))
  1604.   (setq        group_JD_slope
  1605.          (mapcar '(lambda (lst / JD slope lst2 slope_back slope_front)
  1606.                     (if        (= (length lst) 2)
  1607.                       (setq JD          (itoa (car lst))
  1608.                             slope (rtos (cadr lst))
  1609.                             lst2  (strcat "JD: " JD " 超高值: " slope " %")
  1610.                       )
  1611.                     )
  1612.                     (if        (= (length lst) 3)
  1613.                       (setq JD                (itoa (car lst))
  1614.                             slope_bakc        (rtos (car (cadr lst)))
  1615.                             slope        (rtos (cadr (cadr lst)))
  1616.                             slope_front        (rtos (car (caddr lst)))
  1617.                             lst2        (strcat        "JD: "
  1618.                                                 JD
  1619.                                                 " 超高开始值: "
  1620.                                                 slope_bakc
  1621.                                                 " %"
  1622.                                                 " 超高值: "
  1623.                                                 slope
  1624.                                                 " %"
  1625.                                                 " 超高结束值: "
  1626.                                                 slope_front
  1627.                                                 " %"
  1628.                                                )
  1629.                       )
  1630.                     )
  1631.                     lst2
  1632.                   )
  1633.                  group_superelevation
  1634.          )
  1635.   )
  1636.   (start_list "table_superelevation" 3)
  1637.   (mapcar 'add_list group_JD_slope)
  1638.   (end_list)
  1639.   (setq n (length group_JD_slope))
  1640.   (set_tile "table_superelevation" (itoa n))
  1641. )


  1642. ;;  对控件集合"table_Z" "stake_Z" "Z_txt" 进行参数设置  
  1643. (defun mode_value
  1644.                   (value list_key / i lst)
  1645.   (setq i 0)
  1646.   (mapcar '(lambda (x)
  1647.              (mode_tile x value)
  1648.              (setq i (+ 1 i))
  1649.            )
  1650.           list_key                        ; (setq list_key  (list "table_Z" "stake_Z" "Z_Δ")  )   
  1651.   )
  1652. )
  1653. ;; ( mode_value  0   list_key )     


  绘制cass文件格式的程序




  1. ;;;*************函数 vlxls-app-init.lsp  *************

  2. ;|Examples:

  3. Excel Application Session Progress Function

  4. Name
  5. x2c

  6. Usage
  7. Import Microsoft Excel Type Library, set prefix of "msxl-" for all of the :methods-prefix; :properties-prefix
  8. & :constants-prefix. This function can detect Excel’s installation path automatically from Windows registry so
  9. that it can run smoothly on any language platform of Windows and Office.

  10. Input
  11. NONE
  12. No Arguments

  13. RetVal
  14. True
  15. BOOLEAN
  16. msxlc-xl24HourClock

  17. Fail
  18. BOOLEAN
  19. NIL
  20. |;
  21. (Defun vlxls-app-Init
  22.        (/ OSVar GGG Olb8 Olb9 Olb10 TLB Out msg msg1 msg2)
  23.   (if *Chinese*
  24.     (setq msg  "\n 初始化微软Excel "
  25.           msg1 "\042初始化Excel错误\042"
  26.           msg2 (strcat
  27.                  "\042 警告"
  28.                  "\n ===="
  29.                  "\n 无法在您的计算机上检测到微软Excel软件"
  30.                  "\n 如果您确认已经安装Excel, 请发送电子邮"
  31.                  "\n 件到kozmosovia@hotmail.com获取更多的解决方案\042"
  32.                 )
  33.     )
  34.     (setq msg  "\n Initializing Microsoft Excel "
  35.           msg1 "\042Initialization Error\042"
  36.           msg2 (strcat
  37.                  "\042 WARNING"        "\n ======="
  38.                  "\n Can NOT detect Excel97/200X/XP in your computer"
  39.                  "\n If you already have Excel installed, please email"
  40.                  "\n us to get more solution via GuXiaolin@hxch.com.cn\042")
  41.     )
  42.   )
  43.   (if (null msxlc-xl24HourClock)
  44.     (progn
  45.       (if (and (setq GGG
  46.                       (vl-registry-read
  47.                         "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\Excel.EXE"
  48.                         "Path"
  49.                       )
  50.                )
  51.                (setq GGG (strcase (strcat GGG "Excel.EXE")))
  52.           )
  53.         (progn
  54.           ;; 当发现windows表中 有excel 注册程序时  
  55.           (foreach OSVar (list "SYSTEMROOT"         "WINDIR"
  56.                                "WINBOOTDIR"         "SYSTEMDRIVE"
  57.                                "USERNAME"         "COMPUTERNAME"
  58.                                "HOMEDRIVE"         "HOMEPATH"
  59.                                "PROGRAMFILES"
  60.                               )
  61.             ;; (setq OSVar "SYSTEMROOT" )  
  62.             (if        (vl-string-search (strcat "%" OSVar "%") GGG)
  63.               (setq GGG        (vl-string-subst
  64.                           (strcase (getenv OSVar))
  65.                           (strcat "%" OSVar "%")
  66.                           GGG
  67.                         )
  68.               )
  69.             )
  70.           )                                ;(foreach OSVar (list "SYSTEMROOT"      "WINDIR" 函数结束  
  71.           (setq        Olb8  (findfile
  72.                         (vl-string-subst "EXCEL8.OLB" "EXCEL.EXE" GGG)
  73.                       )
  74.                 Olb9  (findfile
  75.                         (vl-string-subst "EXCEL9.OLB" "EXCEL.EXE" GGG)
  76.                       )
  77.                 Olb10 (findfile        (vl-string-subst
  78.                                   "EXCEL10.OLB"
  79.                                   "EXCEL.EXE"
  80.                                   GGG
  81.                                 )
  82.                       )
  83.           )
  84.           (cond
  85.             ((=        (vl-filename-base (vl-filename-directory GGG))
  86.                 "OFFICE15"
  87.              )
  88.              (setq TLB GGG
  89.                    Out "2013"
  90.              )
  91.             )
  92.             ((=        (vl-filename-base (vl-filename-directory GGG))
  93.                 "OFFICE14"
  94.              )
  95.              (setq TLB GGG
  96.                    Out "2010"
  97.              )
  98.             )
  99.             ((=        (vl-filename-base (vl-filename-directory GGG))
  100.                 "OFFICE12"
  101.              )
  102.              (setq TLB GGG
  103.                    Out "2007"
  104.              )
  105.             )
  106.             ((=        (vl-filename-base (vl-filename-directory GGG))
  107.                 "OFFICE11"
  108.              )
  109.              (setq TLB GGG
  110.                    Out "2003"
  111.              )
  112.             )
  113.             ((=        (vl-filename-base (vl-filename-directory GGG))
  114.                 "OFFICE10"
  115.              )
  116.              (setq TLB GGG
  117.                    Out "XP"
  118.              )
  119.             )
  120.             (Olb9
  121.              (setq TLB Olb9
  122.                    Out "2000"
  123.              )
  124.             )
  125.             (Olb8
  126.              (setq TLB Olb8
  127.                    Out "97"
  128.              )
  129.             )
  130.             (t
  131.              (setq TLB GGG
  132.                    Out "Version Unknown"
  133.              )
  134.             )
  135.           )
  136.           (if TLB
  137.             (progn
  138.               ;; 当前我的电脑 out为"2010" ,TLB 为
  139.               ;; "C:\\PROGRAM FILES\\MICROSOFT OFFICE\\OFFICE14\\EXCEL.EXE"
  140.               (princ (strcat MSG Out "..."))
  141.               (vlax-import-type-library
  142.                 :tlb-filename           TLB
  143.                 :methods-prefix           "msxl-"
  144.                 :properties-prefix "msxlp-"
  145.                 :constants-prefix  "msxlc-"
  146.                )
  147.             )
  148.           )
  149.         )
  150.         ;; 当电脑中没有安装excel 程序时   
  151.         (progn
  152.          ;|(if vldcl-msgbox
  153.             (vldcl-msgbox "x" msg1 msg2)
  154.             (alert (read msg2))
  155.             )|;
  156.           (alert msg2)
  157.           (exit)
  158.         )
  159.         ;;(if (and (setq GGG  (vl-registry-read 函数结束
  160.       )
  161.       ;; (if (null msxlc-xl24HourClock)中的progn 函数结束
  162.     )
  163.   )                                        ; (if (null msxlc-xl24HourClock) 函数结束
  164.   msxlc-xl24HourClock
  165. )
  166. ;;;***************** 函数 vlxls-app-Init*****************
  167. ;;  (vlxls-app-Init )  
  168. (Defun vlxls-app-New (UnHide / Rtn)
  169. ;;; 該程序實現功能:新建一個excel格
  170. ;;; THIS PROGRAM CAN BUILD A NEW EXCELFILE
  171.   (if (vlxls-app-init)
  172.     (progn
  173.       (if *Chinese*
  174.         (princ "\n 新建微軟Excel工作表...")
  175.         (princ "\n Creating new Excel Spreadsheet file...")
  176.       )
  177.       (if (setq Rtn (vlax-get-or-create-object "Excel.Application"))
  178.         (progn
  179.           (vlax-invoke-method (vlax-get-property Rtn 'WorkBooks) 'Add)
  180.           (if UnHide
  181.             (vla-put-visible Rtn 1)
  182.             (vla-put-visible Rtn 0)
  183.           )
  184.         )
  185.       )                                        ;if (setq Rtn 函数结束  
  186.     )
  187.   )
  188.   Rtn
  189. )


  190. ;;;Examples:   
  191. ;; (setq  xlapp  (vlxls-app-new T))     
  192. ;; cell id 轉換
  193. (Defun vlxls-cellid (id / xx id1 id2 Rtn)
  194.   (if (= (type id) 'list)
  195.     (setq id (vlxls-rangeid id))
  196.   )
  197.   (setq id (strcase id))
  198.   (if (null (setq xx (vl-string-search ":" id)))
  199.     (setq Rtn (list id ""))
  200.     (setq id1 (substr id 1 xx)
  201.           id2 (substr id (+ xx 2))
  202.           id1 (vlxls-rangeid id1)
  203.           id2 (vlxls-rangeid id2)
  204.           Rtn (list (vlxls-rangeid
  205.                       (list (min (car id1) (car id2))
  206.                             (min (cadr id1) (cadr id2))
  207.                       )
  208.                     )
  209.                     (vlxls-rangeid
  210.                       (list (max (car id1) (car id2))
  211.                             (max (cadr id1) (cadr id2))
  212.                       )
  213.                     )
  214.               )
  215.     )
  216.   )
  217.   Rtn
  218. )


  219. ;;;Examples:
  220. ;|
  221.   (vlxls-cellid '(3 14)) ; return: ("C14" "")
  222.   (vlxls-cellid "D23")  ; return: ("D23" "")
  223.   (vlxls-cellid "C12:F3") ;return: ("C3" "F12")
  224.   (vlxls-cellid "F15:G22") ;return: ("F15" "G22")

  225. |;
  226. ;;;range id 轉換
  227. (Defun vlxls-rangeid (id / str->list list->str xid->str Rtn)
  228.   ;; (setq str "DD23")   
  229.   (Defun str->list1 (str / ii xk xv rr pos x y)
  230.     (setq rr (strlen str))
  231.     (foreach ii        '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  232. ;;;vl-string-search 在字符串中搜索指定子串, 返回值:整数,表示找到指定 pattern 的位置。若没有找到子串,则返回 nil。字符串第一个字符的位置为0  
  233.       (if (setq pos (vl-string-search ii str))
  234.         (setq rr (min pos rr))
  235.       )
  236.     )
  237.     (setq x (substr str 1 rr)                ; substr 第一元素为1 , 返回 "DD23" 中的文字部分 DD
  238.           y (substr str (1+ rr))
  239.             ;;  返回"DD23" 中的"23"部分
  240.     )
  241.     (if        (= (strlen x) 2)                ;当x的字符串长度等于2时   
  242.       (setq xk (- (ascii (substr x 1 1)) ; 返回 "DE23" 中的文字部分D
  243.                   64
  244.                )
  245.             xv (- (ascii (substr x 2))        ; 返回 "DE23" 中的文字部分E  
  246.                   64
  247.                )
  248.       )
  249.       (setq xk 0
  250.             xv (- (ascii x) 64)
  251.       )
  252.     )
  253.     (list (+ (* xk 26) xv) (read y))
  254.   )

  255.   ;;  (setq IntNum 14)   
  256.   (Defun xid->str (IntNum / PosNum Nm-One)
  257.     (setq Nm-One (1- IntNum)
  258.           PosNum (/ Nm-One 26)
  259.     )
  260.     ;; (chr 65) 返回值'A'   
  261.     (if        (= PosNum 0)
  262.       (chr (+ 65 (rem Nm-One 26)))        ; chr 把数字转换成ascill 字符串
  263.       ;;当PosNum 大于0时  
  264.       (strcat (chr (+ 64 PosNum))        ; 返回 "DE23" 中的文字部分D
  265.               (chr (+ 65
  266.                       (rem Nm-One 26)        ; 返回 "DE23" 中的文字部分E
  267.                    )
  268.               )
  269.       )
  270.     )
  271.   )
  272.   ;;注意idr中的 x必须是>=1     
  273.   (Defun list->str1 (idr / x y)
  274.     (setq x (car idr)
  275.           y (cadr idr)
  276.           x (xid->str x)
  277.           y (itoa y)
  278.     )
  279.     (strcat x y)
  280.   )
  281.   (cond        ((= (type id) 'str) (setq Rtn (str->list1 id)))
  282.         ((= (type id) 'list) (setq Rtn (list->str1 id)))
  283.   )
  284.   Rtn
  285. )

  286. (Defun vlxls-cell-put-value
  287.        (xl id Data / vllist-explode idx xx yy ary Rtn)
  288.   (Defun vllist-explode1 (lst)
  289.     (cond ((not lst) nil)
  290.           ((atom lst) (list lst))
  291.           ((append (vllist-explode1 (car lst))
  292.                    (vllist-explode1 (cdr lst))
  293.            )
  294.           )
  295.     )
  296.   )

  297.   (if (null id)
  298.     (setq id "A1")
  299.   )
  300.   (if (= (type id) 'list)
  301.     (setq id (vlxls-rangeid id))
  302.   )
  303.   (if (= (type (car Data)) 'LIST)
  304.     ;; 当Data为列表时(list ("tang" "hong")  ("tang100" "hong200") )   
  305.     (setq ARY (vlax-make-safearray
  306.                 vlax-vbstring
  307.                 ;; 第一维 0 至 (length Data) 减1 ,  表示excel列表"A1:F12"的1--12项   
  308.                 (cons 0 (1- (length Data))) ; 创建点对  (a . b)
  309.                 ;; 第二维 1 至 Data 列表的每个元素 的个数 ,表示excel列表"A1:F12"的A--F项   
  310.                 (cons 1 (length (car Data)))
  311.               )                                ; 创建二维 vlax-vbstring 数组 ARY  (vlax-safearray->list ary)   
  312.           XX  (1- (length (car Data)))
  313.           YY  (1- (length Data))
  314.     )
  315.     ;; 当Data为单个元素时,(list"tang" "hong" "song"  )  (vlax-make-safearray type '(l-bound . u-bound) ['(l-bound . u-bound)...)]   
  316.     (setq ARY (vlax-make-safearray
  317.                 vlax-vbstring
  318.                 (cons 0 1)
  319.                 (cons 1 (length Data))
  320.               )
  321.           XX  (1- (length Data))
  322.           YY  0
  323.     )
  324.   )
  325.   (if (= xx yy 0)
  326.     (msxlp-put-value2                        ; 当id 为excel表中的一个单元格时  
  327.       (setq Rtn (msxlp-get-range xl id))
  328.       (car (vllist-explode1 data))
  329.     )
  330.     (progn
  331.       ;; 把id从"C12" 变成 "C12:E13"形式  
  332.       (setq id (vlxls-cellid-calc id xx yy))
  333.       (msxlp-put-value2
  334.         (setq Rtn (msxlp-get-range xl id))
  335.         (vlax-safearray-fill ary data)
  336.       )
  337.     )
  338.   )                                        ;  (if (= xx yy 0)  函数结束
  339.   Rtn
  340. )


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
"觉得好,就打赏"
还没有人打赏,支持一下
 楼主| 发表于 2016-10-13 16:14 | 显示全部楼层
把还有一些代码补上

  1. ;;对一个二维点集合group_point 绕 点center 旋转 ang 弧度
  2. (defun rotate_group_point (group_point ang center / lst)
  3.   (setq        group_point
  4.          (mapcar '(lambda (point)
  5.                     (list (- (car point) (car center))
  6.                           (- (cadr point) (cadr center))
  7.                     )
  8.                   )
  9.                  group_point
  10.          )
  11.   )
  12.   (setq        lst (list (list (cos ang) (* (sin ang) -1))
  13.                   (list (sin ang) (cos ang))
  14.             )
  15.   )
  16.   (setq        group_point
  17.          (mapcar '(lambda (point)
  18.                     (apply '(lambda (element_1 element_2)
  19.                               (list (+ (* (car element_1) (car point))
  20.                                        (* (cadr element_1) (cadr point))
  21.                                     )
  22.                                     (+ (* (car element_2) (car point))
  23.                                        (* (cadr element_2) (cadr point))
  24.                                     )
  25.                               )
  26.                             )
  27.                            lst
  28.                     )
  29.                   )
  30.                  group_point
  31.          )
  32.   )
  33.   (setq
  34.     group_point
  35.      (mapcar '(lambda (x)
  36.                 (list (+ (car x) (car center))
  37.                       (+ (cadr x) (cadr center))
  38.                 )
  39.               )
  40.              group_point
  41.      )
  42.   )
  43. )
  44. ;; 8888888888888888  88888888888888888888888  88888888888888888   

  45. ;;定义一个队group_data_out 数组进行群变换的函数 ,group_data_out 结构为:(Z_桩号 U ang_象限角 )  
  46. ;; 对点集合 group_point 首先进行镜像变换,然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度
  47. (defun transformation_group_data_out
  48.                                      (group_data_out
  49.                                       reflex           data_origin
  50.                                       data_insert  /
  51.                                       group_point  quadrant_ang
  52.                                       ang_Δ           ang
  53.                                       U_origin           U_insert
  54.                                       group           i
  55.                                      )

  56.   (setq group (append (list data_origin) group_data_out))
  57.   (if (= reflex -1)
  58.     (setq group
  59.            (mapcar '(lambda (lst / Z U ang)
  60.                       (setq Z        (car lst)
  61.                             U        (cadr lst)
  62.                             ang        (caddr lst)
  63.                       )
  64.                       (list Z
  65.                             (list (car U)
  66.                                   (* (cadr U) -1)
  67.                             )
  68.                             (* ang -1)
  69.                       )
  70.                     )
  71.                    group
  72.            )
  73.     )
  74.   )                                        ; (if (= reflex -1) 函数结束
  75.   (setq        data_origin    (car group)
  76.         group_data_out (cdr group)

  77.   )
  78.   ;; 对group_data_out 数组进行平移,使得原坐标系中的U_origin点,和实际线元的起点U_insert向符合
  79.   (setq        U_origin (cadr data_origin)
  80.         U_insert (cadr data_insert)
  81.   )
  82.   (setq        group_data_out
  83.          (mapcar '(lambda (lst / Z U x y ang)
  84.                     (setq Z   (car lst)
  85.                           U   (cadr lst)
  86.                           x   (+ (- (car U) (car U_origin))
  87.                                  (car U_insert)
  88.                               )
  89.                           y   (+ (- (cadr U) (cadr U_origin))
  90.                                  (cadr U_insert)
  91.                               )
  92.                           ang (caddr lst)
  93.                     )
  94.                     (list Z (list x Y) ang)
  95.                   )
  96.                  group_data_out
  97.          )
  98.   )
  99.   ;; 对 group_data_out 数组,以线元的起点U_insert进行旋转 quadrant_ang- ang 角度操作
  100.   (setq        ang             (caddr data_origin)
  101.         quadrant_ang (caddr data_insert)
  102.   )

  103.   (setq        group_point
  104.          (mapcar 'cadr group_data_out)
  105.   )
  106.   (setq        ang_Δ            (- quadrant_ang ang)
  107.         group_point (rotate_group_point group_point ang_Δ U_insert)
  108.   )
  109.   (setq        i 0
  110.         group_data_out
  111.          (mapcar '(lambda (lst / U ang)
  112.                     (setq U   (nth i group_point)
  113.                           ang (caddr lst)
  114.                           i   (+ i 1)
  115.                     )
  116.                     (list (car lst) U (+ ang ang_Δ))

  117.                   )
  118.                  group_data_out
  119.          )
  120.   )
  121. )                                        ; (defun transformation_group_data_out 函数结束
  122. ;; (transformation_group_data_out group_data_out reflex         data_origin  data_insert)   





  123. ;;888888888888888888888888888888888888888888888888888888888888888888888888888888  
  124. ;;  人口变量, 缓和曲线参数A,  缓和曲线长L  
  125. (defun solve_transition_curve_sub (A               L           /
  126.                                    group       U           deflection
  127.                                    functon_parameter
  128.                                   )
  129.   ;; (setq L 40.0 A 200 )   
  130.   (if (> L 0.000001)
  131.     (progn
  132.       (setq L (* L 1.0)
  133.             A (* A 1.0)
  134.       )
  135.       (setq functon_parameter
  136.              '(((1 0 1.0 1)
  137.                 (5 4 40.0 -1)
  138.                 (9 8 3456.0 1)
  139.                 (13 12 599040.0 -1)
  140.                 (17 16 1.75473e+007 1)
  141.                )
  142.                ((3 2 6.0 1)
  143.                 (7 6 336.0 -1)
  144.                 (11 10 42240.0 1)
  145.                 (15 14 9.6768e+006 -1)
  146.                 (19 18 3.5301e+009 1)
  147.                )
  148.               )
  149.       )
  150.       ;; 把 L A 带入函数 进行求值  
  151.       (setq group
  152.              (mapcar '(lambda (subset)
  153.                         (mapcar        '(lambda (lst)
  154.                                    (apply '(lambda (a_1 a_2 a_3 a_4)
  155.                                              (*        (/ (expt L a_1)
  156.                                                    (* (expt A a_2) a_3)
  157.                                                 )
  158.                                                 a_4
  159.                                              )
  160.                                            )
  161.                                           lst
  162.                                    )
  163.                                  )
  164.                                 subset
  165.                         )
  166.                       )
  167.                      functon_parameter
  168.              )
  169.       )

  170.       (setq U
  171.              (mapcar '(lambda (subset)
  172.                         (apply '+ subset)
  173.                       )
  174.                      group
  175.              )
  176.       )

  177.       (setq deflection
  178.              (/ (expt L 2.0) (* (expt A 2.0) 2.0))
  179.       )                                        ;  J为弧度
  180.       (list U deflection)
  181.     )                                        ; progn函数结束
  182.     ;; 当缓和曲线长L很小时
  183.     (list '(0 0) 0)
  184.   )                                        ;  if 函数结束
  185. )
  186. ;;  输出参数为切线支距坐标复数U,偏角deflection  
  187. ;;888888888888888888888888888888888888888888888888888888888888888888888888888888888



  188. ;; 当线元是缓和曲线时, subset 数据结构为
  189. ;;  ( R_start R_end  transition_parameter    reflex         quadrant_ang    Z_start  U_insert )   
  190. (defun solve_transition_curve (group_Z           subset      /
  191.                                A           Lh               lst
  192.                                Lh_start           Lh_end      U_Z_start
  193.                                β_start           Z_end       group_data_out
  194.                                data_origin data_insert
  195.                               )
  196.   (apply
  197.     '(lambda (R_start              R_end              transition_parameter
  198.               reflex              quadrant_ang    Z_start
  199.               U_insert
  200.              )

  201.        (setq Lh             (car transition_parameter) ; 缓和曲线长度  
  202.              A             (cadr transition_parameter) ; 缓和曲线参数
  203.              R_start (* R_start 1.0)
  204.              R_end   (* R_end 1.0)
  205.        )
  206.        (if (= R_start 0)
  207.          (setq R_start (expt 10.0 30))
  208.        )
  209.        (if (= R_end 0)
  210.          (setq R_end (expt 10.0 30))
  211.        )
  212.        (if (> R_start R_end)
  213.          ;; 正向缓和曲线时  
  214.          (progn
  215.            (setq Lh_start  (/ (expt A 2) R_start) ; 起点缓和曲线长度
  216.                  lst           (solve_transition_curve_sub A Lh_start)
  217.                  U_Z_start (car lst)        ; 缓和曲线的起点切线支距坐标
  218.                  β_start  (cadr lst)        ;缓和曲线起点象限角
  219.            )
  220.            ;; 对桩号集合group_Z 进行操作
  221.            (setq group_data_out
  222.                   (mapcar '(lambda (z / L lst U_Z β_Z)
  223.                              (setq L (+ (- Z Z_start) Lh_start))
  224.                              (setq lst        (solve_transition_curve_sub A L)
  225.                                    U_Z        (car lst)
  226.                                    β_Z        (cadr lst)
  227.                              )
  228.                              (list Z U_Z β_Z)
  229.                            )
  230.                           group_Z
  231.                   )
  232.            )
  233.          )
  234.          ;; 反向缓和曲线时  
  235.          (progn
  236.            (setq Lh_start  (/ (expt A 2) R_start)
  237.                  lst           (solve_transition_curve_sub A Lh_start)
  238.                  U_Z_start (car lst)
  239.                  β_start  (cadr lst)
  240.            )
  241.            (setq Lh_end        (/ (expt A 2) R_end) ; 终点缓和曲线长度
  242.                  Z_end        (+ Z_start Lh)
  243.            )
  244.            (setq group_data_out
  245.                   (mapcar '(lambda (z / L lst U_Z β_Z)
  246.                              (setq L (+ (- Z_end Z) Lh_end))
  247.                                         ; 加桩点的缓和曲线长度,从完整缓和曲线的起点算起
  248.                              (setq lst        (solve_transition_curve_sub A L)
  249.                                    U_Z        (car lst)
  250.                                    β_Z        (cadr lst)
  251.                              )
  252.                              (list Z U_Z β_Z)
  253.                            )
  254.                           group_Z
  255.                   )
  256.            )
  257.            ;;此时生成的group_data_out与标准的正向缓和曲线线(原点0,启始方位角0,右手螺旋坐标系) 沿着X轴对称 ,
  258.            ;;所以要对group_data_ou 进行沿x轴镜像  
  259.            (setq group_data_out
  260.                                 (mapcar        '(lambda (lst / Z U ang)
  261.                                            (setq Z   (car lst)
  262.                                                  U   (cadr lst)
  263.                                                  ang (caddr lst)
  264.                                            )
  265.                                            (list Z
  266.                                                  (list (* (car U) -1)
  267.                                                        (cadr U)
  268.                                                  )
  269.                                                  (* ang -1)
  270.                                            )
  271.                                          )
  272.                                         group_data_out
  273.                                 )

  274.                  U_Z_start
  275.                                 (list (* (car U_Z_start) -1)
  276.                                       (cadr U_Z_start)
  277.                                 )

  278.                  β_start
  279.                                 (* β_start -1)
  280.            )
  281.          )

  282.        )                                ; (if (> R_start R_end)  函数结束  
  283.        ;; 创建transformation_group_data_out 函数用参数   data_origin  data_insert  
  284.        (setq data_origin (list 0 U_Z_start β_start)
  285.              data_insert (list 0 U_insert quadrant_ang)
  286.        )
  287.        ;; 对点集合 group_point 首先进行镜像变换,然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度
  288.        (transformation_group_data_out
  289.          group_data_out
  290.          reflex
  291.          data_origin
  292.          data_insert
  293.        )
  294.      )
  295.     subset
  296.   )
  297. )
  298. ;;88888888888888888888888888888888888888888888888888888888888888888   (expt 10.0 30)   










  299. ;; 当线元是圆曲线时 subset 数据结构为
  300. ;;  ( R_start R_end  lenth    reflex         quadrant_ang    Z_start  U_insert   )   
  301. (defun solve_circular_arc (group_Z         subset               /
  302.                            i                 group_data_out
  303.                            U_center         data_origin   data_insert
  304.                           )


  305.   ;; (tang_test   group_data_out )   
  306.   (apply
  307.     '(lambda (R_start R_end lenth reflex quadrant_ang Z_start U_insert)

  308.        ;; 设定圆曲线圆心为原点(0 R_start),方向为 右手坐标系,圆曲线线起点坐标(0   0 ),切线为X轴

  309.        (setq R_start  (* R_start 1.0)
  310.              U_center (list 0 R_start)
  311.        )
  312.        (setq group_data_out
  313.               (mapcar '(lambda (Z / L β U_Z ang)
  314.                          (setq L   (- Z Z_start)
  315.                                β  (/ L R_start)
  316.                                ang (- β (/ pi 2))
  317.                                U_Z (polar U_center ang R_start)
  318.                          )
  319.                          (list Z U_Z β)
  320.                        )
  321.                       group_Z
  322.               )
  323.        )
  324.        ;; 创建transformation_group_data_out 函数用参数   data_origin  data_insert  
  325.        (setq data_origin (list 0 (list 0 0) 0)
  326.              data_insert (list 0 U_insert quadrant_ang)
  327.        )
  328.        ;; 对点集合 group_point 首先进行镜像变换,然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度
  329.        (transformation_group_data_out
  330.          group_data_out
  331.          reflex
  332.          data_origin
  333.          data_insert
  334.        )
  335.      )
  336.     subset
  337.   )
  338. )
  339. ;;88888888888888888888888888888888888888888888888888888888888888888  





  340. ;; 当线元是直线时 subset 数据结构为
  341. ;;  ( R_start R_end  lenth    reflex         quadrant_ang    Z_start  U_insert   )   
  342. (defun solve_straightway
  343.                          (group_Z subset / group_data_out)

  344.   ;; (tang_test   group_data_out )   
  345.   (apply
  346.     '(lambda (R_start R_end lenth reflex quadrant_ang Z_start U_insert)
  347.        (setq group_data_out
  348.               (mapcar '(lambda (Z / L U_Z)
  349.                          (setq L   (- Z Z_start)
  350.                                U_Z (polar U_insert quadrant_ang L)
  351.                          )
  352.                          (list Z U_Z quadrant_ang)
  353.                        )
  354.                       group_Z
  355.               )
  356.        )
  357.      )
  358.     subset
  359.   )
  360. )
  361. ;;88888888888888888888888888888888888888888888888888888888888888888  







  362. ;;888888888888888888888888888888888888888888888888888888888888888888888888888888  
  363. ;;  人口变量缓和曲线长Lh, 缓和曲线半径R,  出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A   
  364. (defun evaluation_transition_curve
  365.                                    (Lh              R                /
  366.                                     A              p                q
  367.                                     β              group
  368.                                     functon_parameter
  369.                                    )
  370.   ;; (setq lh 50 r 480 )  
  371.   (setq        R  (* 1.0 R)
  372.         Lh (* 1.0 Lh)
  373.   )
  374.   (setq        functon_parameter
  375.          '(((2 1 24.0)
  376.             (4 3 -2688.0)
  377.             (6 5 506880.0)
  378.             (8 7 -1.54829e+008)
  379.            )
  380.            ((1 0 2.0)
  381.             (3 2 -240.0)
  382.             (5 4 34560.0)
  383.             (7 6 -8.38656e+006)
  384.             (9 8 3.15851e+009)
  385.            )
  386.           )
  387.   )
  388.   ;;把参数parameter_easement_curve  带入求值,
  389.   (setq        group
  390.          (mapcar '(lambda (subset)
  391.                     (mapcar '(lambda (lst)
  392.                                (apply '(lambda (a_1 a_2 a_3)
  393.                                          (/ (expt Lh a_1)
  394.                                             (* (expt R a_2) a_3)
  395.                                          )
  396.                                        )
  397.                                       lst
  398.                                )
  399.                              )
  400.                             subset
  401.                     )
  402.                   )
  403.                  functon_parameter
  404.          )
  405.   )
  406.   (setq        group
  407.          (mapcar '(lambda (subset)
  408.                     (apply '+ subset)
  409.                   )
  410.                  group
  411.          )
  412.   )
  413.   (setq        p  (car group)
  414.         q  (cadr group)
  415.         β (/ Lh (* R 2.0))
  416.         A  (sqrt (* R Lh))
  417.   )
  418.   ;; 出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A   
  419.   (list p q β A)
  420. )                                        ;   evaluation_easement_curve 函数结束                                 
  421. ;;  (evaluation_transition_curve  50  480  )  (evaluation_transition_curve   50  480  )                          
  422. ;;888888888888888888888888888888888888888888888888888888888888888888888888888888888



  423. ;;888888888888888888888888888888888888888888888888888888888888888888888888888888
  424. ;; (setq group_turning_point ( create_turning_point_group )  )   
  425. ;; 求基本对称路线平曲线的 曲线要素 入口变量: [ ( 转点号I nil)   U_转点  ( Lh R  Lh  )(α1  α2   Δ Dist_1   Dist_2 )]  
  426. ;; 出口变量:该转点各线元的数据[( 转点号I j)   R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert )  ]   
  427. (defun evaluation_symmetrical_curve (subset / Z_I U group_data_out)
  428.   ;; (setq subset (nth 15   group_turning_point ))
  429.   (setq        Z_I    (car (car subset))        ; 转点编号
  430.         subset (cdr subset)
  431.   )
  432.   ;; (setq U_ZD_real (car subset) lst1  (cadr subset) lst2  (caddr subset) )   
  433.   (apply '(lambda (U_ZD_real             lst1     lst2     /
  434.                    ;; 计算交点用参数
  435.                    quadrant_ang             Δ
  436.                    ;; 计算切线长度 T1 T2 所用参数
  437.                    T1            T2             a_1      a_2      tangent
  438.                    cscΔ    cotΔ
  439.                    ;; 计算缓和曲线的内蕴参数
  440.                    parameter             Lh1      Lh2      R
  441.                    A1            A2             p1              p2       q1
  442.                    q2            β1             β2      βy      E
  443.                    Ly            L             adjusted_value    reflex
  444.                    ;; 建立线元坐标系所用参数
  445.                    U_center U_JD     U_ZH     U_HY     U_QZ
  446.                    U_YH            U_HZ
  447.                    ;; 桩号用参数
  448.                    Z_JD            Z_ZH     Z_HY     Z_QZ     Z_YH
  449.                    Z_HZ
  450.                    ;; 切线角用参数  
  451.                    ang_JD   ang_ZH   ang_HY   ang_QZ   ang_YH
  452.                    ang_HZ
  453.                    ;; 对数组 group_data_out 进行移位,镜像,旋转 用参数
  454.                    quadrant_ang             data_origin       data_insert
  455.                    ;;创建线元列表所用参数  
  456.                    lst            lst2     lst3     lst4     Line_segments
  457.                   )
  458.             (setq Lh1               (car lst1)
  459.                   R               (cadr lst1)
  460.                   Lh2               (caddr lst1)
  461.                   quadrant_ang
  462.                                (car lst2) ; 设计交点的入口方位角  
  463.                   Δ               (caddr lst2) ; 设计交点偏转系数

  464.             )
  465.             (if        (>= Δ 0)
  466.               (setq reflex 1)
  467.               (setq reflex -1
  468.                     Δ           (* -1 Δ)
  469.               )
  470.             )
  471.             (setq
  472.               parameter
  473.                         (evaluation_transition_curve Lh1 R)
  474.               ;; 出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A   
  475.               p1        (car parameter)
  476.               q1        (cadr parameter)
  477.               β1        (caddr parameter)
  478.               A1        (nth 3 parameter)
  479.             )
  480.             (cond
  481.               ((= Lh1 Lh2)
  482.                (setq
  483.                  β2 β1
  484.                  A2  A1
  485.                )
  486.                (setq tangent (/ (sin (/ Δ 2)) (cos (/ Δ 2)))
  487.                      T1             (+ (* (+ R p1) tangent) q1)
  488.                      T2             T1
  489.                                         ; 切线长度
  490.                )
  491.               )
  492.               ;; 当出口、进口缓和曲线长度不相等时
  493.               ((/= Lh1 Lh2)
  494.                (setq
  495.                  parameter
  496.                            (evaluation_transition_curve Lh2 R)
  497.                  ;; 出口变量缓和曲线出口段内移值p,切线增量q ,偏角β,缓和曲线参数A   
  498.                  p2           (car parameter)
  499.                  q2           (cadr parameter)
  500.                  β2           (caddr parameter)
  501.                  A2           (nth 3 parameter)
  502.                )
  503.                (setq cscΔ (/ 1.0 (sin Δ))
  504.                      cotΔ (/ (cos Δ) (sin Δ))
  505.                      a_1   (* (+ R p2) cscΔ)
  506.                      a_2   (* (+ R p1) cotΔ)
  507.                      T1           (+ (- a_1 a_2)
  508.                               q1
  509.                            )
  510.                      a_1   (* (+ R p1) cscΔ)
  511.                      a_2   (* (+ R p2) cotΔ)
  512.                      T2           (+ (- a_1 a_2)
  513.                               q2
  514.                            )
  515.                )
  516.               )
  517.             )                                ; (cond  函数 结束
  518.             (setq a_1                 (expt (+ R p1) 2)
  519.                   a_2                 (expt (- T1 q1) 2)
  520.                   E                 (- (sqrt (+ a_1 a_2)) R) ; 外距
  521.                   βy                 (- Δ (+ β1 β2))
  522.                   Ly                 (* βy R)
  523.                                         ; 圆曲线长度
  524.                   L                 (+ Ly (+ Lh1 Lh2))
  525.                   adjusted_value (- (+ T1 T2) L) ; 切曲差  
  526.             )
  527.             ;; 以ZH点为坐标原点,该点的切线方向为X轴,建立右手螺旋坐标系 ,转角 Δ取正数   
  528.             ;;转点的桩号 Z_JD = z_QZ + adjusted_value
  529.             (setq ang_JD (/ Δ 2)
  530.                   ;; 设置为U_JD ->U_center的垂直方向
  531.                   ang_ZH 0
  532.                   ang_HY β1
  533.                   ang_QZ (+ β1 (/ βy 2))
  534.                   ang_YH (- Δ β2)
  535.                   ang_HZ Δ
  536.             )
  537.             ;;   (angtos   (+(/ (- pi Δ) 2)Δ)   1 6  )   
  538.             (setq
  539.               U_JD     (list T1 0)
  540.               U_center (list q1 (+ R p1))
  541.               U_ZH     (list 0 0)        ;向量U_center ->U_JD 的方位角 (+ (/ Δ 2)pi)   
  542.               U_HY     (polar U_center (- ang_HY (* pi 0.5)) R)
  543.               U_QZ     (polar U_center (- ang_QZ (* pi 0.5)) R)
  544.               U_YH     (polar U_center (- ang_YH (* pi 0.5)) R)
  545.               U_HZ     (polar U_JD Δ T2)
  546.             )
  547.             (setq Z_JD T1
  548.                   Z_ZH 0
  549.                   Z_HY Lh1
  550.                   Z_QZ (+ Lh1 (/ Ly 2))
  551.                   Z_YH (+ Lh1 Ly)
  552.                   Z_HZ L
  553.             )
  554.             (setq group_data_out
  555.                    (list
  556.                      (list Z_JD U_JD ang_JD)
  557.                      (list Z_ZH U_ZH ang_ZH)
  558.                      (list Z_HY U_HY ang_HY)
  559.                      (list Z_QZ U_QZ ang_QZ)
  560.                      (list Z_YH U_YH ang_YH)
  561.                      (list Z_HZ U_HZ ang_HZ)
  562.                    )
  563.             )
  564.             ;; 创建transformation_group_data_out 函数用参数   data_origin  data_insert  
  565.             (setq
  566.               data_origin (list 0 U_JD 0)
  567.               data_insert (list 0 U_ZD_real quadrant_ang)
  568.             )
  569.             ;; 对点集合 group_point 首先进行镜像变换,然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度quadrant_ang
  570.             (setq group_data_out
  571.                    (transformation_group_data_out
  572.                      group_data_out
  573.                      reflex
  574.                      data_origin
  575.                      data_insert
  576.                    )
  577.             )
  578.             ;;利用group_data_out数组 设置线元参数: (( 转点号I j)  R_start R_end  transition_parameter  reflex quadrant_ang  Z_start  U_insert )
  579.             (cond
  580.               ((and (/= Lh1 0)
  581.                     (/= Lh2 0)
  582.                )
  583.                (setq lst  (list 1 2 4)
  584.                      lst3 (list 0 1 2)
  585.                )
  586.               )
  587.               ((and (= Lh1 0)
  588.                     (/= Lh2 0)

  589.                )
  590.                (setq lst  (list 2 4)
  591.                      lst3 (list 1 2)
  592.                )
  593.               )
  594.               ((and (/= Lh1 0)
  595.                     (= Lh2 0)
  596.                )
  597.                (setq lst  (list 1 2)
  598.                      lst3 (list 0 1)
  599.                )
  600.               )
  601.               ((and (= Lh1 0)
  602.                     (= Lh2 0)
  603.                )
  604.                (setq lst  (list 2)
  605.                      lst3 (list 1)
  606.                )
  607.               )
  608.             )                                ; cond  函数结束  
  609.             (setq
  610.               group
  611.                             (mapcar '(lambda (i / lst2)
  612.                                        (setq lst2 (nth i group_data_out))
  613.                                        (list (caddr lst2) (car lst2) (cadr lst2))
  614.                                      )
  615.                                     (list 1 2 4)
  616.                             )
  617.               lst_4            (list (list (list Z_I 0) 0 R (list Lh1 A1) reflex)
  618.                                   (list (list Z_I 1) R R Ly reflex)
  619.                                   (list (list Z_I 2) R 0 (list Lh2 A2) reflex)
  620.                             )
  621.               Line_segments (mapcar '(lambda (i)
  622.                                        (append (nth i lst_4) (nth i group))
  623.                                      )
  624.                                     lst3
  625.                             )
  626.             )
  627.             (list Line_segments (list T1 T2 adjusted_value))
  628.           )
  629.          subset
  630.   )

  631. )                                        ;   evaluation_easement_curve 函数结束
  632. ;;888888888888888888888888888888888888888888888888888888888888888888888888888888888   





  633. ;;888888888888888888888888888888888888888888888888888888888888888888888888888888 (setq tgg  ( evaluation_no_symmetrical_curve subset ) )   
  634. ;; (setq group_turning_point_original (car ( create_turning_point_group_original ) ) )   
  635. ;; (setq group_turning_point (car( create_turning_point_group   group_turning_point_original  Z_road_start )))     
  636. ;; 求包含非完整缓和曲线的线元要素 入口变量: [ ( 转点号I T)   U_转点  ( R_start R R_end   Lh1  Lh2  )(α1  α2   Δ Dist_1   Dist_2 )]
  637. ;; 出口变量:该转点各线元的数据[( 转点号I j)   R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert )  ]   
  638. (defun evaluation_no_symmetrical_curve (subset / Z_I U group_data_out)
  639.   ;; (setq subset (nth 11   group_turning_point ))
  640.   (setq        Z_I         (car (car subset))        ; 转点编号
  641.         subset_2 (cdr subset)
  642.   )
  643.   ;; (setq U_ZD_real (car subset_2) lst1  (cadr subset_2) lst2  (caddr subset_2) )   
  644.   (apply '(lambda (U_ZD_real lst1      lst2         /
  645.                    ;; 计算交点用参数
  646.                    quadrant_ang               Δ
  647.                    ;; 计算切线长度 T1 T2 所用参数
  648.                    T1             T2               group_Z         Lh1_start Lh2_start
  649.                    ;; 计算缓和曲线的内蕴参数
  650.                    parameter Lh1       Lh2         R           A1
  651.                    A2             p1               p2         q1           q2
  652.                    β1             β2       βy         E           Ly
  653.                    L             adjusted_value         reflex
  654.                    ;; 建立线元坐标系所用参数
  655.                    U_center  U_ZD      U_ZH         U_HY           U_QZ
  656.                    U_YH             U_HZ
  657.                    ;; 桩号用参数
  658.                    Z_JD             Z_ZH      Z_HY         Z_QZ           Z_YH
  659.                    Z_HZ
  660.                    ;; 切线角用参数  
  661.                    ang_JD    ang_ZH    ang_HY         ang_QZ           ang_YH
  662.                    ang_HZ
  663.                    ;; 对数组 group_data_out 进行移位,镜像,旋转 用参数
  664.                    quadrant_ang               data_origin           data_insert
  665.                    ;;创建线元列表所用参数  
  666.                    lst             lst2      lst3         lst4           Line_segments
  667.                   )
  668.             (setq R_start (car lst1)
  669.                   R (cadr lst1)
  670.                   R_end        (caddr lst1)
  671.                   Lh1 (nth 3 lst1)
  672.                   Lh2 (nth 4 lst1)
  673.                   quadrant_ang
  674.                    (car lst2)                ; 设计交点的入口方位角  
  675.                   Δ (caddr lst2)        ; 设计交点偏转系数
  676.             )
  677.             (if        (= R_start 0)
  678.               (setq R_start (expt 10.0 30))
  679.             )
  680.             (if        (= R_end 0)
  681.               (setq R_end (expt 10.0 30))
  682.             )
  683.             (if        (>= Δ 0)
  684.               (setq reflex 1)
  685.               (setq reflex -1
  686.                     Δ           (* -1 Δ)
  687.               )                                ; (setq Δ (/ pi 3))   
  688.             )
  689.             ;; 当出口 缓和曲线长度不相等时
  690.             (if        (/= Lh1 0)
  691.               (progn
  692.                 ;; 创建lst结构 ( ( 转点号I j)  R_start R_end  transition_parameter    reflex         quadrant_ang    Z_start  U_insert )  
  693.                 (setq
  694.                   A1
  695.                      (abs (- (/ 1.0 R)
  696.                              (/ 1.0 R_start)
  697.                           )
  698.                      )
  699.                   A1
  700.                      (sqrt (/ Lh1 A1))
  701.                 )
  702.                 ;; 求入口非完整缓和曲线的HY点 ( z_桩号 U_z ang  )  
  703.                 (setq lst     (list R_start
  704.                                     R
  705.                                     (list Lh1 A1)
  706.                                     1
  707.                                     0        ; 线元的起点方位角
  708.                                     0
  709.                                     (list 0 0)
  710.                               )
  711.                       group_Z (list Lh1)
  712.                 )
  713.                 (setq group (solve_transition_curve group_Z lst)
  714.                       U_HY  (cadr (car group))
  715.                       β1   (caddr (car group))
  716.                 )
  717.                 ;; (setq group_data_out (solve_transition_curve  ( create_group_Z  0  Lh1   1)  lst ))  (tang_test   group_data_out )
  718.               )
  719.               (setq β1 0)                ; 当Lh1长度为0 时 , β1 偏角为0  
  720.             )
  721.             ;; 求出口口非完整缓和曲线的HY点 ( z_桩号 U_z ang  ) (以YH点为0点,右手螺旋坐标系,过YH点的切线为0度 )
  722.             (if        (/= Lh2 0)
  723.               (progn
  724.                 ;; 创建lst结构 ( R_start R_end  transition_parameter    reflex         quadrant_ang    Z_start  U_insert )  
  725.                 (setq
  726.                   A2
  727.                      (abs (- (/ 1.0 R)
  728.                              (/ 1.0 R_end)
  729.                           )
  730.                      )
  731.                   A2
  732.                      (sqrt (/ Lh2 A2))
  733.                 )
  734.                 (setq lst     (list R
  735.                                     R_end
  736.                                     (list Lh2 A2)
  737.                                     1
  738.                                     0        ; 线元的起点方位角
  739.                                     0
  740.                                     (list 0 0)
  741.                               )
  742.                       group_Z (list Lh2)
  743.                 )
  744.                 (setq group (solve_transition_curve group_Z lst)
  745.                       β2   (caddr (car group))
  746.                 )
  747.               )
  748.               (setq β2 0)                ; 当Lh2长度为0 时 , β2 偏角为0  
  749.             )                                ; (if        (/= Lh2 0) 函数结束

  750.             ;; 计算圆曲线的偏角
  751.             (setq βy (- Δ (+ β2 β1))
  752.                   Ly  (* R βy)                ; 圆曲线长度  
  753.             )

  754.             ;; 创建lst结构 ( R_start R_end  lenth    reflex         quadrant_ang    Z_start  U_insert )  
  755.             (setq lst          (list R R Ly 1 β1 0 U_HY)
  756.                   group_Z (list Ly)        ; YH 点的桩号
  757.             )
  758.             (setq group        (solve_circular_arc group_Z lst)
  759.                                         ; 求圆曲线的终点坐标
  760.                   U_YH        (cadr (car group))
  761.             )
  762.             ;; (setq group_data_out (solve_circular_arc  ( create_group_Z  0  Ly  1)  lst ))  (tang_test   group_data_out )  
  763.             (if        (/= Lh2 0)
  764.               (progn
  765.                 ;;求HZ点的 group_data_out 的数组( z_桩号 U_z ang  )  
  766.                 (setq lst     (list R
  767.                                     R_end
  768.                                     (list Lh2 A2)
  769.                                     1
  770.                                     (+ βy β1) ; 线元的起点方位角
  771.                                     0        ; 线元的起始桩号   
  772.                                     U_YH
  773.                               )
  774.                       group_Z (list Lh2) ; HZ点桩号
  775.                 )
  776.                 (setq group (solve_transition_curve group_Z lst)
  777.                       U_HZ  (cadr (car group))
  778.                                         ; 求第二缓和曲线在 以HZ点为坐标原点,起点缓和曲线切线为X轴方向
  779.                 )
  780.                 ;; (setq group_data_out (solve_transition_curve  ( create_group_Z  0  Lh2   1)  lst ))  (tang_test   group_data_out )  
  781.               )
  782.               (setq U_HZ U_YH)
  783.             )                                ; (if        (/= Lh2 0) 函数结束

  784.             ;; 求次坐标系中的转点坐标 U_ZD
  785.             (setq U_HZ_2 (polar U_HZ Δ 100.0)
  786.                   U_ZD         (inters U_HZ
  787.                                  U_HZ_2
  788.                                  (list 0 0)
  789.                                  (list 10000 0)
  790.                                  nil
  791.                          )
  792.             )
  793.             ;;  (setq tang99 (list  (list 0 0) U_HY  U_YH   U_HZ  U_ZD  ))( create_LWPOLYLINE  tang99 nil  "0"  )      

  794.             (setq T1                 (car U_ZD)
  795.                   T2                 (distance U_ZD U_HZ)
  796.                   L                 (+ Ly (+ Lh1 Lh2))
  797.                   adjusted_value (- (+ T1 T2) L) ; 切曲差  
  798.             )

  799.             ;; 以ZH点为坐标原点,该点的切线方向为X轴,建立右手螺旋坐标系 ,转角 Δ取正数   
  800.             ;;转点的桩号 Z_JD = z_QZ + adjusted_value
  801.             (setq ang_JD (/ Δ 2)
  802.                   ;; 设置为U_JD ->U_center的垂直方向
  803.                   ang_ZH 0
  804.                   ang_HY β1
  805.                   ang_QZ (+ β1 (/ βy 2))
  806.                   ang_YH (- Δ β2)
  807.                   ang_HZ Δ
  808.             )
  809.             ;;   (angtos   (+(/ (- pi Δ) 2)Δ)   1 6  )   
  810.             (setq
  811.               U_center (polar U_HY (+ ang_HY (* pi 0.5)) R)
  812.               U_ZH     (list 0 0)        ;向量U_center ->U_JD 的方位角 (+ (/ Δ 2)pi)   
  813.               U_QZ     (polar U_center (- ang_QZ (* pi 0.5)) R)
  814.             )
  815.             (setq Z_JD T1
  816.                   Z_ZH 0
  817.                   Z_HY Lh1
  818.                   Z_QZ (+ Lh1 (/ Ly 2))
  819.                   Z_YH (+ Lh1 Ly)
  820.                   Z_HZ L
  821.             )
  822.             (setq group_data_out
  823.                    (list
  824.                      (list Z_JD U_ZD ang_JD)
  825.                      (list Z_ZH U_ZH ang_ZH)
  826.                      (list Z_HY U_HY ang_HY)
  827.                      (list Z_QZ U_QZ ang_QZ)
  828.                      (list Z_YH U_YH ang_YH)
  829.                      (list Z_HZ U_HZ ang_HZ)
  830.                    )
  831.             )
  832.             ;; 创建transformation_group_data_out 函数用参数   data_origin  data_insert  
  833.             (setq
  834.               data_origin (list 0 U_ZD 0)
  835.               data_insert (list 0 U_ZD_real quadrant_ang)
  836.             )
  837.             ;; 对点集合 group_point 首先进行镜像变换,然后把变换后的点集合从U_origin 以为到U_insert ,然后围绕U_insert点旋转制定的角度quadrant_ang
  838.             (setq group_data_out
  839.                    (transformation_group_data_out
  840.                      group_data_out
  841.                      reflex
  842.                      data_origin
  843.                      data_insert
  844.                    )
  845.             )
  846.             ;;利用group_data_out数组 设置线元参数: ( R_start R_end  transition_parameter  reflex quadrant_ang  Z_start  U_insert )
  847.             (cond
  848.               ((and (/= Lh1 0)
  849.                     (/= Lh2 0)
  850.                )
  851.                (setq lst  (list 1 2 4)
  852.                      lst3 (list 0 1 2)
  853.                )
  854.               )
  855.               ((and (= Lh1 0)
  856.                     (/= Lh2 0)

  857.                )
  858.                (setq lst  (list 2 4)
  859.                      lst3 (list 1 2)
  860.                )
  861.               )
  862.               ((and (/= Lh1 0)
  863.                     (= Lh2 0)
  864.                )
  865.                (setq lst  (list 1 2)
  866.                      lst3 (list 0 1)
  867.                )
  868.               )
  869.               ((and (= Lh1 0)
  870.                     (= Lh2 0)
  871.                )
  872.                (setq lst  (list 2)
  873.                      lst3 (list 1)

  874.                )
  875.               )
  876.             )                                ; cond  函数结束  
  877.             (setq
  878.               group
  879.                             (mapcar '(lambda (i / lst2)
  880.                                        (setq lst2 (nth i group_data_out))
  881.                                        (list (caddr lst2) (car lst2) (cadr lst2))
  882.                                      )
  883.                                     (list 1 2 4)
  884.                             )
  885.               lst_4            (list (list (list Z_I 0) R_start R (list Lh1 A1) reflex)
  886.                                   (list (list Z_I 1) R R Ly reflex)
  887.                                   (list (list Z_I 2) R R_end (list Lh2 A2) reflex)
  888.                             )
  889.               Line_segments (mapcar '(lambda (i)
  890.                                        (append (nth i lst_4) (nth i group))
  891.                                      )
  892.                                     lst3
  893.                             )
  894.             )
  895.             (list Line_segments (list T1 T2 adjusted_value))
  896.           )
  897.          subset_2
  898.   )


  899. )                                        ;   evaluation_easement_curve 函数结束
  900. ;;888888888888888888888888888888888888888888888888888888888888888888888888888888888   




  901. ;;  (setq group_turning_point ( create_turning_point_group )  )
  902. ;; 求线路的线元参数group_Line_segments [( 转点号I j) R_start R_end  transition_parameter   reflex  quadrant_ang   Z_start  U_insert ]  
  903. ;; 以及转点参数  group_data_JD  ( Z_JD U ang JD  reflex )  
  904. (defun create_group_Line_segments
  905.                                   (group_turning_point
  906.                                    Z_road_start           /
  907.                                    group_turning_point_2
  908.                                    lst                   state
  909.                                    i                   dist
  910.                                    quadrant_ang           num
  911.                                    T_front           Δ
  912.                                    U_insert           U
  913.                                    Z                   group_parameter
  914.                                    group_Line_segments
  915.                                    group_data_JD
  916.                                   )
  917.   ;; 去掉group_turning_point 中的第一和最后一个转点,不进行处理
  918.   (setq        group_turning_point_2
  919.          (cdr group_turning_point)
  920.         group_turning_point_2
  921.          (reverse group_turning_point_2)
  922.         group_turning_point_2
  923.          (cdr group_turning_point_2)
  924.         group_turning_point_2
  925.          (reverse group_turning_point_2)
  926.   )
  927.   ;; 创建线元集合group_Line_segments [( 转点号I j) R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert ]   
  928.   ;; 和 转点用的参数集合 group_parameter (list T1 T2 adjusted_value)
  929.   (setq
  930.     group_Line_segments
  931.      nil
  932.     group_parameter
  933.      nil
  934.   )
  935.   (mapcar '(lambda                        ; (setq subset (nth 9 group_turning_point ) )   
  936.              (subset / Line_segments state lst lst2)
  937.               (setq state (cadr (car subset)))
  938.                                         ; 判断该转点是否包含非完整缓和曲线   
  939.               (if state
  940.                 (setq lst
  941.                        (evaluation_no_symmetrical_curve subset)
  942.                       Line_segments
  943.                        (car lst)
  944.                       lst2 (cadr lst)

  945.                 )
  946.                 (setq lst
  947.                        (evaluation_symmetrical_curve subset)
  948.                       Line_segments
  949.                        (car lst)
  950.                       lst2 (cadr lst)

  951.                 )
  952.               )
  953.               (setq group_Line_segments
  954.                      (cons Line_segments group_Line_segments)
  955.                     group_parameter
  956.                      (cons lst2 group_parameter)
  957.               )
  958.            )
  959.           group_turning_point_2
  960.   )
  961.   (setq        group_Line_segments
  962.          (reverse group_Line_segments)
  963.         group_parameter
  964.          (reverse group_parameter)
  965.   )
  966.   ;;利用参数group_parameter (list T1 T2 adjusted_value)   和group_turning_point  把直线线元加进group_Line_segments 中
  967.   (setq        i 0
  968.         n (length group_Line_segments)
  969.   )
  970.   ;; 把第二个转点至最后一个转点的直线线元加进数组group_Line_segments 中
  971.   (setq        group_Line_segments
  972.          (mapcar
  973.            '(lambda
  974.               (lst         /           dist             lst2      T_back
  975.                T_now         T_front   Δ             U_JD      quadrant_ang
  976.                U_insert         element   num             Z_start
  977.               )
  978.                (cond
  979.                  ((/= i (- n 1))        ; 当转点num 不是最后一个转点时  
  980.                   (setq        T_now               (cadr (nth i group_parameter))
  981.                         T_back               (car (nth i group_parameter))
  982.                         adjusted_value (caddr (nth i group_parameter))
  983.                         T_front               (car (nth (+ i 1) group_parameter))
  984.                         lst2               (nth (+ i 1) group_turning_point)
  985.                                         ; 线元所对应的转点号  
  986.                         dist               (nth 4 (nth 3 lst2))
  987.                         quadrant_ang   (cadr (nth 3 lst2))
  988.                         Δ               (- dist (+ T_now T_front))
  989.                                         ;直线线元的长度
  990.                         num               (car (car lst2)) ; 转点号
  991.                         Z_start               (- (+ T_now T_back) adjusted_value)
  992.                                         ;线元的起点桩号  
  993.                   )
  994.                  )
  995.                  ;;   当转点num  是最后一个转点时   
  996.                  ((= i (- n 1))
  997.                   (setq        T_now               (cadr (nth i group_parameter))
  998.                         T_back               (car (nth i group_parameter))
  999.                         adjusted_value (caddr (nth i group_parameter))
  1000.                         T_front               0;  最后一个转点的切线长度设置为0   
  1001.                         lst2               (nth (+ i 1) group_turning_point)
  1002.                                         ; 线元所对应的转点号  
  1003.                         dist               (nth 4 (nth 3 lst2))
  1004.                         quadrant_ang   (cadr (nth 3 lst2))
  1005.                         Δ               (- dist (+ T_now T_front))
  1006.                         num               (car (car lst2)) ; 转点号
  1007.                         Z_start               (- (+ T_now T_back) adjusted_value)
  1008.                                         ;线元的起点桩号  
  1009.                   )
  1010.                  )
  1011.                )
  1012.                (setq i (+ i 1))
  1013.                ;; 当 Δ 长度大于0.1米 时, 在该转点处加进直线线元
  1014.                (if (> Δ 0.1)
  1015.                  (progn
  1016.                    (setq U_JD          (cadr lst2)
  1017.                          U_insert (polar U_JD quadrant_ang T_now)
  1018.                          num          (car (car lst2))
  1019.                    )
  1020.                    ;; 创建直线线元[( 转点号I 3)  0  0   Δ    reflex  quadrant_ang    Z_start  U_insert ]  
  1021.                    (setq element (list (list num 3)
  1022.                                        0
  1023.                                        0
  1024.                                        Δ
  1025.                                        1
  1026.                                        quadrant_ang
  1027.                                        Z_start
  1028.                                        U_insert
  1029.                                  )
  1030.                          lst         (append lst (list element))
  1031.                    )
  1032.                  )
  1033.                )                        ; (if (> Δ 0.1) 函数结束
  1034.                lst
  1035.             )
  1036.            group_Line_segments
  1037.          )
  1038.   )
  1039.   ;; 把第一直线线元加进数组 group_Line_segments  
  1040.   (setq        lst             (car group_turning_point)
  1041.         dist             (nth 4 (nth 3 lst))
  1042.         quadrant_ang (cadr (nth 3 lst))
  1043.         U_insert     (cadr lst)                ; 第一个转点的 坐标
  1044.         num             (car (car lst))        ; 第一个线元的转点号   
  1045.         lst             (car group_parameter)
  1046.         T_front             (car lst)                ; 第二个转点 的入口方向切线长度
  1047.         Δ             (- dist T_front)
  1048.   )
  1049.   ;; 判断第一个线元的转点是否存在
  1050.   (if (> Δ 0.1)
  1051.     (progn
  1052.       (setq element (list (list num 3)
  1053.                           0
  1054.                           0
  1055.                           Δ
  1056.                           1
  1057.                           quadrant_ang
  1058.                           0
  1059.                           U_insert
  1060.                     )

  1061.       )
  1062.       (setq group_Line_segments
  1063.              (append (list (list element)) group_Line_segments)
  1064.       )
  1065.     )
  1066.   )
  1067.   ;; 对线元数组 group_Line_segments 中的起始桩号进行处理,  
  1068.   (if (not Z_road_start)
  1069.     (setq Z_road_start 0)                ; 当线路起始桩号没有定义时,设置为0  
  1070.   )
  1071.   (setq Z Z_road_start)                        ; 初始化桩号Z 为路线的起始桩号
  1072.   (setq        group_Line_segments
  1073.          (mapcar
  1074.            '(lambda (lst / element lenth)
  1075.               (setq lst
  1076.                      (mapcar
  1077.                        '(lambda        (subset)
  1078.                           (apply '(lambda (x_0 x_1 x_2 x_3 x_4 x_5 x_6 x_7)
  1079.                                     (list x_0 x_1 x_2 x_3 x_4 x_5 (+ Z x_6) x_7)
  1080.                                   )
  1081.                                  subset
  1082.                           )
  1083.                         )
  1084.                        lst
  1085.                      )
  1086.               )                                ;  (mapcar '(lambda        (subset) 函数结束
  1087.               ;; 当一个转点 的全部线元处理完毕后, 对该转点的最后一个线元的结束桩号,赋值给Z
  1088.               (setq element (last lst))        ; 该转点的最后一个线元
  1089.               (if (= (cadr (car element)) 2)
  1090.                 (setq lenth (car (nth 3 element)))
  1091.                                         ; 当最后一个线元是缓和曲线时  
  1092.                 (setq lenth (nth 3 element))
  1093.               )
  1094.               (setq Z (+ (nth 6 element) lenth))
  1095.               lst                        ; 保证输出结果为想要的group_Line_segments 数组  
  1096.             )
  1097.            group_Line_segments
  1098.          )
  1099.   )
  1100.   ;; 对group_turning_point 中的交点 ,求其交点桩号,病并求其象限角,以转角的一半为切线方向   

  1101.   (setq group_data_JD nil)                ; 利用数组group_Line_segments和group_parameter (list T1 T2 adjusted_value) 求解
  1102.   (setq i 1)
  1103.   (setq        group_data_JD
  1104.          (mapcar '(lambda (lst / T1 Z Z_JD lst2 U ang JD Δ reflex)
  1105.                     (setq T1         (car lst)
  1106.                           lst2         (nth i group_Line_segments)
  1107.                           Z         (nth 6 (car lst2))
  1108.                                         ; 该交点中的第一个线元的起点桩号
  1109.                           Z_JD         (+ Z T1)
  1110.                           reflex (nth 4 (car lst2))
  1111.                     )
  1112.                     (setq lst2 (nth i group_turning_point)
  1113.                           U    (cadr lst2)
  1114.                           JD   (car (car lst2))
  1115.                           Δ   (caddr (nth 3 lst2))
  1116.                           ang  (car (nth 3 lst2))
  1117.                           ang  (+ (* 0.5 Δ) ang)
  1118.                     )
  1119.                     (setq i (+ i 1))
  1120.                     (list Z_JD U ang JD reflex)
  1121.                   )
  1122.                  group_parameter
  1123.          )
  1124.   )


  1125.   (list group_Line_segments group_data_JD)
  1126. )
  1127. ;; 88888888888           88888888888888            88888888888888888          88888888888888888888   






  1128. ;; 输入参数 线元 Line_segments [( 转点号I j) R_start R_end  transition_parameter   reflex  quadrant_ang    Z_start  U_insert ]   
  1129. ;; mold加宽类型 ,mold为0时, 绘制普通加宽,mold=1 时,按直线加宽
  1130. (defun calculate_Transition-curve_widen
  1131.                                         (Z          group_widen
  1132.                                          Line_segments           mold
  1133.                                          /          L           widen
  1134.                                          k          k_2           k_3
  1135.                                          l_x          T_1           T_2
  1136.                                          T_3          widen_x  lenth
  1137.                                          lst          Z_end
  1138.                                         )
  1139.   (apply
  1140.     '(lambda (x_0 x_1 x_2 transition_parameter reflex x_5 Z_start x_7)
  1141.        (setq I         (car x_0)                ; 转点的编号
  1142.              num (cadr x_0)                ; 线元在转点中的编号
  1143.        )
  1144.        (setq lst   (assoc I group_widen)
  1145.                                         ; 寻找转点I 所对应的加宽值   
  1146.              widen (cadr lst)
  1147.        )
  1148.        (if (not widen)
  1149.          (setq widen 0)
  1150.        )
  1151.        (if (or (= num 0)
  1152.                (= num 2)
  1153.            )
  1154.          ;; 当线元为缓和曲线时  
  1155.          (progn
  1156.            (setq lenth (car transition_parameter)
  1157.                  lenth (* lenth 1.0)
  1158.                  Z_end (+ Z_start lenth)
  1159.            )
  1160.            (if (and
  1161.                  (>= Z z_start)
  1162.                  (<= Z z_end)
  1163.                )
  1164.              (progn
  1165.                (cond
  1166.                  ;; 当线元为进口缓和曲线时  
  1167.                  ((= num 0)
  1168.                   (setq L (- Z z_start))
  1169.                  )
  1170.                  ;; 当线元为出口缓和曲线时  
  1171.                  ((= num 2)
  1172.                   (setq L (- z_end z))
  1173.                  )
  1174.                )                        ; cond 函数结束   
  1175.                (setq k (/ L lenth))
  1176.                ;; 当 mold为0时, 绘制普通加宽,mold=1 时,按直线加宽
  1177.                (cond
  1178.                  ((= mold 0)
  1179.                   (setq        k_2        (* (expt k 3) 4)
  1180.                         k_3        (* (expt k 4) 3)
  1181.                         widen_x        (* (- k_2 k_3) widen)
  1182.                   )
  1183.                  )
  1184.                  ((= mold 1)
  1185.                   (setq widen_x (* k widen))
  1186.                  )
  1187.                )                        ; 判断 缓和曲线是否为普通或直线加宽的函数 结束   
  1188.              )
  1189.            )                                ; (if (and  (>= Z z_start) (< Z z_end) ) 函数结束
  1190.          )
  1191.        )                                ; 处理缓和曲线线元加宽值的 函数结束
  1192.        (if (= num 1)
  1193.          ;; 当线元为圆曲线时   
  1194.          (progn
  1195.            (setq lenth (* transition_parameter 1.0)
  1196.                  Z_end (+ Z_start lenth)
  1197.            )
  1198.            (if (and
  1199.                  (>= Z z_start)
  1200.                  (<= Z z_end)
  1201.                )
  1202.              (setq widen_x widen)
  1203.            )                                ; (if (and  (>= Z z_start) (< Z z_end) ) 函数结束
  1204.          )
  1205.        )                                ; 处理圆曲线线元加宽值的 函数结束
  1206.        (if (not widen_x)
  1207.          (setq widen_x 0)
  1208.          widen_x
  1209.        )
  1210.      )
  1211.     Line_segments
  1212.   )
  1213. )                                        ; calculate_Transition-curve_widen函数结束
  1214. ;; (calculate_Transition-curve_widen 7530  group_widen Line_segments  0 )   
  1215. ;;  (setq  group_widen (write_into_group_widen))  
  1216. ;; (setq Line_segments  (cadr(nth 2 tang99 )))  (setq   mold 0  z 7570  I 25  )




  1217. ;; 对线元参数group_Line_segments [( 转点号num j) R_start R_end  transition_parameter   reflex  quadrant_ang   Z_start  U_insert ]  
  1218. ;; 求出一个新的数组 group_transition ( 转点号num j) (i j k) ,i 和 k 分别为该线元的 前后线元编号  i k 取值为0 ,1 ,2 ,3  
  1219. (defun create_group_transition
  1220.                                (group_Line_segments
  1221.                                 /              group_transition
  1222.                                 group              n_1
  1223.                                 n              group_i
  1224.                                 lst              num
  1225.                                )
  1226.   (setq group (apply 'append group_Line_segments))
  1227.   ;; 为了计算方便,在数组group的头和尾巴各加入一个数组  
  1228.   (setq        lst   (car (car group))
  1229.         num   (car lst)
  1230.         lst   (list (list num 3))
  1231.         group (append (list lst) group)
  1232.         lst   (car (last group))
  1233.         num   (car lst)
  1234.         lst   (list (list num 3))
  1235.         group (append group (list lst))
  1236.   )
  1237.   (setq        n        (length group)
  1238.         n_1        1
  1239.         group_i        nil
  1240.   )
  1241.   (repeat (- n 2)
  1242.     (setq group_i (cons n_1 group_i))
  1243.     (setq n_1 (+ n_1 1))
  1244.   )
  1245.   (setq group_i (reverse group_i))
  1246.   (setq group_transition nil)
  1247.   (mapcar '(lambda (n_1 / lst lst_back lst_front i j k)
  1248.              (setq lst (nth n_1 group)
  1249.                    j   (cadr (car lst))
  1250.              )
  1251.              (setq lst_back  (nth (- n_1 1) group)
  1252.                    lst_front
  1253.                              (nth (+ n_1 1) group)
  1254.              )
  1255.              (setq i (cadr (car lst_back))
  1256.                    k (cadr (car lst_front))
  1257.              )
  1258.              (setq group_transition
  1259.                     (cons (list (car lst) (list i j k))
  1260.                           group_transition
  1261.                     )
  1262.              )
  1263.            )
  1264.           group_i
  1265.   )
  1266.   (reverse group_transition)
  1267. )                                        ; (defun create_group_transition   函数结束  
  1268. ;; (setq group_transition ( create_group_transition group_Line_segments ) )   


  1. ;; 把竖曲线划分为直线线元 和 圆曲线线元
  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  )  
  3. (defun create_group_vertical_curve_2 (group_vertical_curve
  4.                                       /                     group
  5.                                       i                     lst
  6.                                       lst2             n
  7.                                       group_vertical_curve_2
  8.                                       Z                     ang_2
  9.                                       Z_ZY_next
  10.                                      )

  11.   (setq n (length group_vertical_curve))
  12.   (setq        i 1
  13.         group nil
  14.   )
  15.   (repeat (- n 2)
  16.     (setq group        (cons i group)
  17.           i        (+ i 1)
  18.     )
  19.   )
  20.   (setq group (reverse group))
  21.   ;;创建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  )  
  22.   (setq        group_vertical_curve_2
  23.          (mapcar
  24.            '(lambda (i              /               lst_front         lst
  25.                      lst_back U_now    U_back        U_front         ang_1
  26.                      ang_2    ang_Δ   Δ        tangent         R_now
  27.                      I_JD     Z_JD     Z_ZY        H_ZY         Z_YZ
  28.                      H_YZ     Z_ZY_next
  29.                     )
  30.               (setq lst_back  (nth (- i 1) group_vertical_curve)
  31.                     lst              (nth i group_vertical_curve)
  32.                     lst_front (nth (+ i 1) group_vertical_curve)
  33.               )
  34.               (apply '(lambda (I Z_JD H R)
  35.                         (setq Z_JD   (* Z_JD 1.0)
  36.                               H             (* H 1.0)
  37.                               U_back (list Z_JD H)
  38.                         )
  39.                       )
  40.                      lst_back
  41.               )
  42.               (apply '(lambda (I Z_JD H R)
  43.                         (setq Z_JD  (* Z_JD 1.0)
  44.                               H            (* H 1.0)
  45.                               U_now (list Z_JD H)
  46.                               R_now (* R 1.0)
  47.                               I_JD  I
  48.                         )
  49.                       )
  50.                      lst
  51.               )
  52.               (apply '(lambda (I Z_JD H R)
  53.                         (setq Z_JD    (* Z_JD 1.0)
  54.                               H              (* H 1.0)
  55.                               U_front (list Z_JD H)
  56.                         )
  57.                       )
  58.                      lst_front
  59.               )
  60.               (setq
  61.                 ang_1  (angle U_back U_now)
  62.                 ang_2  (angle U_now U_front)
  63.                 ang_Δ (- ang_2 ang_1)        ; 该竖曲线的转点 角度   
  64.                 Z_JD   (car U_now)
  65.                 H_JD   (cadr U_now)
  66.               )
  67.               ;; 对转角ang_Δ 使其控制在(-pi pi) 之间
  68.               (cond
  69.                 ((and (>= ang_Δ (* -1 pi))
  70.                       (< ang_Δ pi)
  71.                  )
  72.                  (setq ang_Δ ang_Δ)
  73.                 )
  74.                 ((< ang_Δ (* -1 pi))
  75.                  (setq ang_Δ (+ ang_Δ (* 2 pi)))
  76.                 )
  77.                 ((> ang_Δ pi)
  78.                  (setq ang_Δ (- ang_Δ (* 2 pi)))
  79.                 )
  80.               )
  81.               (setq Δ            (/ (abs ang_Δ) 2.0)
  82.                     tangent (* (/ (sin Δ) (cos Δ)) R_now)
  83.                     tangent (abs tangent)
  84.                                         ; 竖曲线切线长度
  85.               )
  86.               (setq U_ZY (polar U_now (+ ang_1 pi) tangent)
  87.                     U_YZ (polar U_now ang_2 tangent)
  88.                     Z_ZY (car U_ZY)
  89.                     H_ZY (cadr U_ZY)
  90.                     Z_YZ (car U_YZ)
  91.                     H_YZ (cadr U_YZ)
  92.               )
  93.               ;;创建元素其结构为(( 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  )  
  94.               (list (list (list I_JD 0) Z_ZY Z_YZ H_ZY ang_1 R_now ang_Δ)
  95.                     (list (list I_JD 1) Z_YZ nil H_YZ ang_2 0 0)
  96.                                         ;  Z_ZY_next 暂时设置为空 nil ,因为是直线半径R设置为0     
  97.               )
  98.             )
  99.            group
  100.          )
  101.   )
  102.   ;; 对        group_vertical_curve_2 中 的直线线元( (I_JD 1) Z_YZ  Z_ZY_next  H_YZ  quadrant_ang 0 0  ) 中Z_ZY_next 进行处理
  103.   (setq        group (mapcar '(lambda (lst)
  104.                          (cadr (car lst))
  105.                        )
  106.                       (cdr group_vertical_curve_2)
  107.               )
  108.   )
  109.   ;; 把最后一个交点的桩号也加入 group 中
  110.   (setq        Z     (cadr (last group_vertical_curve))
  111.         group (append group (list z))
  112.   )
  113.   ;; 用group 对group_vertical_curve_2 进行填充
  114.   (setq i 0)
  115.   (setq        group_vertical_curve_2
  116.          (mapcar '(lambda (Z / lst subset)
  117.                     (setq lst         (nth i group_vertical_curve_2)
  118.                           subset (cadr lst)
  119.                           subset (subst Z nil subset)
  120.                           i         (+ i 1)
  121.                     )
  122.                     (list (car lst) subset)
  123.                   )
  124.                  group
  125.          )
  126.   )
  127.   ;; 把 第一第二转点之间直线线元 加进数组group_vertical_curve_2 中   
  128.   (setq        lst          (car (car group_vertical_curve_2))
  129.         Z_ZY_next (cadr lst)                ; 第一第二转点之间直线线元的终点桩号
  130.         ang_2          (nth 4 lst)                ;象限角   
  131.         lst          (car group_vertical_curve)
  132.         lst2          (apply
  133.                     '(lambda (I Z_JD H R)
  134.                        (list (list I 1)
  135.                              Z_JD
  136.                              Z_ZY_next
  137.                              H
  138.                              ang_2
  139.                              0
  140.                              0
  141.                        )
  142.                      )
  143.                     lst
  144.                   )

  145.   )
  146.   (setq        group_vertical_curve_2
  147.          (append (list (list lst2)) group_vertical_curve_2)
  148.   )
  149.   (setq group_vertical_curve_2 (apply 'append group_vertical_curve_2))
  150. )
  151. ;;  (setq group_vertical_curve_2 ( create_group_vertical_curve_2  group_vertical_curve ) )   





  152. ;;  QH2_10N 对每个输入桩号Z 求其高程  solve_elevation  , QH2_10N 摘录自 书1-fx5800P公路与铁路施工测量程序
  153. ;; 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  )  
  154. (defun QH2_10N (Z          group_vertical_curve_2        /
  155.                 n          lst_1            lst_2     lst_3        lst
  156.                 n_1          Z_start   Z_end     t1        t2
  157.                 ;;   
  158.                 reflex          A            B              C                G
  159.                 result_1  result_2  H              tan        Δ
  160.                 ang          α            elevation L                α0
  161.                )

  162.   (setq        n          (length group_vertical_curve_2)
  163.         lst_1          (car group_vertical_curve_2)
  164.         lst_2          (last group_vertical_curve_2)
  165.         elevation nil
  166.   )
  167.   (setq        Z_start        (cadr lst_1)
  168.         Z_end        (caddr lst_2)
  169.   )
  170.   (if (and (>= Z Z_start) (<= Z Z_end))        ; (setq Z  13950)  
  171.     (setq t1 t)
  172.     (setq t1 nil)
  173.   )
  174.   ;; 开始循环函数 888888888888888888888888888888888888888888888888888888888888   
  175.   (setq        i  0
  176.         t2 t
  177.   )
  178.   (while (and (< i n) t1 t2)                ;  (setq i 44  )   
  179.     (setq lst (nth i group_vertical_curve_2))
  180.     (apply
  181.       '(lambda (array Z_S Z_e H quadrant_ang R ang_Δ)
  182.          (if (and (>= Z Z_s) (<= Z Z_e))
  183.            (progn
  184.              (setq L (* (- Z Z_S) 1.0))
  185.              (cond
  186.                ;; 当Z在直线线元时  
  187.                ((= (cadr array) 1)
  188.                 (setq
  189.                   tan            (/ (sin quadrant_ang) (cos quadrant_ang))
  190.                   elevation (+ (* tan L) H)
  191.                   t2            nil
  192.                 )
  193.                )
  194.                ;; 当Z在竖曲线,线元时
  195.                ((= (cadr array) 0)
  196.                 (progn
  197.                   (if (minusp ang_Δ)
  198.                     (setq reflex -1)        ;当转角为负数时,凸曲线 ,  
  199.                     (setq reflex 1)        ; 转角为正数时,凹曲线时  
  200.                   )
  201.                   (setq        α0 (abs quadrant_ang)
  202.                         Δ  (/ (abs ang_Δ) 2.0)
  203.                   )
  204.                   (setq
  205.                     A
  206.                       (- (* (sin α0)
  207.                             (* (* R 2.0) reflex)
  208.                          )
  209.                          L
  210.                       )
  211.                     B
  212.                       (* (cos α0)
  213.                          (* R 2.0)
  214.                       )
  215.                     C
  216.                       (* -1.0 L)
  217.                     G
  218.                       (sqrt (- (expt B 2) (* (* A C) 4.0)))
  219.                   )
  220.                   ;; 一元二次方程的两个解
  221.                   (setq
  222.                     result_1
  223.                              (atan (/ (+ (* -1 B) G) (* 2.0 A)))
  224.                     result_2
  225.                              (atan (/ (- (* -1 B) G) (* 2.0 A)))
  226.                   )
  227.                   (if
  228.                     (and (> result_2 0) (<= result_2 Δ))
  229.                      (setq ang result_2)
  230.                      (setq ang result_1)
  231.                   )
  232.                   (setq α (+ quadrant_ang (* ang reflex)))
  233.                   (setq
  234.                     elevation (+ (* (/ (sin α) (cos α)) L) H)
  235.                   )
  236.                   (setq t2 nil)
  237.                 )
  238.                )
  239.              )                                ;  (cond  函数结束   
  240.            )
  241.          )                                ; (if (and (>= Z Z_s) (< Z Z_e)) 函数结束  
  242.        )
  243.       lst
  244.     )                                        ; apply 函数结束   
  245.     (setq i (+ i 1))
  246.   )
  247.   ;;(while (< i  (- n 1)) 函数结束88888888888888888888888

  248.   elevation                                ;  (setq elevation 0)  
  249. )
  250. ;;QH2_10N 函数结束
  251. ;; (QH2_10N   13950    group_vertical_curve_2   )  




  1. ;;  (setq group_turning_point ( create_turning_point_group )  )  
  2. ;;  (setq  group_Line_segments (car ( create_group_Line_segments   group_turning_point  6782.755 ))  )     
  3. ;; 输入参数 线元 Line_segments [( 转点号I j) R_start R_end  transition_parameter   reflex  quadrant_ang   Z_start  U_insert ]   
  4. (defun calculate_superelevation
  5.                                 (Z                   group_superelevation
  6.                                  Line_segments           /
  7.                                  lenth                   lst
  8.                                  lst_seek           Z_end
  9.                                  I                   num
  10.                                  superelevation           superelevation_R
  11.                                  superelevation_L  superelevation_back
  12.                                  slope_comparison  superelevation_front
  13.                                  cross_slope           K
  14.                                  Z_state           temp
  15.                                 )

  16.   ;;  (setq x_0 (car Line_segments ))   
  17.   (apply
  18.     '(lambda (x_0 x_1 x_2 transition_parameter reflex x_5 Z_start x_7)

  19.        (setq I         (car x_0)                ; 转点的编号
  20.              num (cadr x_0)                ; 线元在转点中的编号
  21.        )
  22.        (setq lst_seek (assoc I group_superelevation)
  23.                                         ; 寻找转点I 所对应的超高值
  24.        )
  25.        (if (= (length lst_seek) 2)
  26.          ;; 当转点超高方式是标准超高时, 既从直线-2% 边坡到superelevation% 再边坡到 2%  
  27.          (setq superelevation (cadr lst_seek))
  28.          ;; 当转点超高方式是非标准超高时,  既从superelevation_back% 边坡到slope% 再边坡到superelevation_front%  
  29.          (setq superelevation                ; 当前线元 最大坡度值
  30.                 (cadr (cadr lst_seek))
  31.                superelevation_back        ; 当前线元的起始坡度值
  32.                 (car (cadr lst_seek))
  33.                superelevation_front
  34.                 (cadr (caddr lst_seek))        ; 当前线元的结束坡度值  
  35.          )
  36.        )

  37.        (if (and        superelevation
  38.                 (/= num 3)                ; 线元 Line_segments 不为直线时
  39.            )
  40.          (progn
  41.            (cond
  42.              ((or (= num 0)
  43.                   (= num 2)
  44.               )
  45.               (setq lenth (car transition_parameter))
  46.                                         ; 当线元为缓和曲线时
  47.              )
  48.              ((= num 1)
  49.               (setq lenth transition_parameter)
  50.                                         ; 圆曲线时
  51.              )
  52.            )
  53.            (setq lenth         (* lenth 1.0)
  54.                  Z_end         (+ Z_start lenth)
  55.                  L         (- Z z_start)
  56.                  Z_state (and
  57.                            (>= Z z_start)
  58.                            (<= Z z_end)
  59.                          )
  60.            )
  61.            (cond
  62.              ;;  该转点为 标准超高值 既 横坡从-2% 超高到 superelevation% 变化到 -2%  
  63.              ((and
  64.                 (or (= num 0)
  65.                     (= num 2)
  66.                 )
  67.                 Z_state
  68.                 (= (length lst_seek) 2)
  69.               )
  70.               (progn
  71.                 (setq K (/ (+ 2 superelevation) lenth))
  72.                 (if (= num 0)
  73.                   (setq cross_slope (+ (* K L) -2.0)) ; 入口缓和曲线  
  74.                   (setq cross_slope (- superelevation (* K L)))
  75.                                         ; 出口缓和曲线
  76.                 )
  77.                 (setq
  78.                   superelevation_R
  79.                    cross_slope
  80.                 )
  81.                 (if (<= cross_slope 2)
  82.                   (setq superelevation_L 2)
  83.                   (setq superelevation_L cross_slope)
  84.                 )
  85.               )
  86.              )
  87.              ;; 当转点为非 标准超高时,  既横坡从superelevation_back% 超高到 superelevation% 变化到superelevation_front%  
  88.              ((and
  89.                 (or (= num 0)
  90.                     (= num 2)
  91.                 )
  92.                 Z_state
  93.                 (= (length lst_seek) 3)
  94.               )
  95.               (progn
  96.                 (if (= num 0)
  97.                   (setq        K            (/ (- superelevation superelevation_back) lenth)
  98.                         cross_slope (+ (* K L) superelevation_back)
  99.                   )                        ; 入口缓和曲线  
  100.                   (setq        K            (/ (- superelevation superelevation_front) lenth)
  101.                         cross_slope (- superelevation (* K L))
  102.                   )                        ; 出口缓和曲线
  103.                 )
  104.                 (setq superelevation_R cross_slope)
  105.                 (if (or        (and (= (abs superelevation_back)  2) (= num 0))
  106.                                         ; 入口缓和曲线时,其起始横坡是从2%   
  107.                         (and (= (abs superelevation_front)  2) (= num 2))
  108.                                         ; 出口缓和曲线时 ,其结束横坡是从2%  
  109.                     )
  110.                   ;; 当该缓和曲线线元的横坡是从 superelevation% 变到-2%,或者从-2%变到 superelevation%  
  111.                   (progn
  112.                     (if        (<= cross_slope 2)
  113.                       (setq superelevation_L 2)
  114.                       (setq superelevation_L cross_slope)
  115.                     )
  116.                   )
  117.                   ;; 横坡不变到负数  
  118.                   (setq superelevation_L cross_slope)
  119.                 )
  120.               )
  121.              )
  122.              ;; 当线元 Line_segments 是圆曲线时   
  123.              ((and (= num 1)
  124.                    Z_state
  125.               )
  126.               (setq superelevation_R superelevation
  127.                     superelevation_L superelevation
  128.               )
  129.              )                                ; 处理圆曲线线元的横坡值函数结束  
  130.            )                                ; cond 函数结束
  131.            ;; 对求出来的superelevation_L superelevation_R 通过偏转系数reflex 进行镜像  
  132.            (if (and (= reflex -1) Z_state)
  133.              (setq temp                    superelevation_L
  134.                    superelevation_L (* superelevation_R -1)
  135.                    superelevation_R (* temp -1)
  136.              )
  137.            )                                ;  (if (= reflex -1)  函数结束
  138.          )                                ;(if superelevation 中的progn 函数结束  
  139.        )                                ; (if superelevation 函数结束
  140.      )
  141.     Line_segments
  142.   )
  143.   ;; 当superelevation 没有定义时
  144.   (if (or (not superelevation)
  145.           (= num 3)
  146.       )
  147.     (setq superelevation_L 2.0
  148.           superelevation_R -2.0
  149.     )
  150.   )
  151.   (list superelevation_L superelevation_R)
  152. )                                        ;calculate_superelevation 函数结束
  153. ;; (setq i 20  j 2 Z 12445   )  (setq i 12  j 2 Z 10530   )        
  154. ;; (setq   Line_segments (nth j   (nth i group_Line_segments ) ) )   
  155. ;; (setq tang  ( calculate_superelevation   z  group_superelevation    Line_segments ) )  

 楼主| 发表于 2016-10-13 16:20 | 显示全部楼层
再补一点
  1. (defun change_group_turning_point_original
  2.                                            (group_turning_point_original
  3.                                             Z_road_start
  4.                                             /
  5.                                             group
  6.                                             group_2
  7.                                             group_string
  8.                                             lst_str
  9.                                             lst1
  10.                                             lst2
  11.                                             string
  12.                                            )

  13.   ;; 把group_turning_point_original 数组转换成 自己需要的形式  
  14.   (setq        lst_str        (list "JD="         "state="   "E(Y)="    "N(X)="
  15.                       "Lh1="         "R_start=" "R="       "R_end="
  16.                       "Lh2="
  17.                      )
  18.   )
  19.   (setq        group_string
  20.          (mapcar '(lambda (lst)
  21.                     (apply 'append lst)
  22.                   )
  23.                  group_turning_point_original
  24.          )
  25.   )
  26.   (setq        group_2                                ; (setq lst (cadr group_string))  
  27.          (mapcar '(lambda (lst / state subset)
  28.                     (setq state (cadr lst))
  29.                     (setq subset
  30.                            (append lst lst_str)
  31.                     )
  32.                     (if        (not state)
  33.                       (progn
  34.                         (setq subset
  35.                                (mapcar '(lambda        (i)
  36.                                           (nth i subset)
  37.                                         )
  38.                                        (list 7 0 8 1 9 2 10 3 11 4 13 5 15 6)
  39.                                )
  40.                         )
  41.                         (setq subset
  42.                                (mapcar '(lambda        (i / j lst1 lst2)
  43.                                           (setq j (* i 2))
  44.                                           (setq        lst1 (nth j subset)
  45.                                                 lst2 (nth (+ j 1) subset)
  46.                                           )
  47.                                           (cond
  48.                                             ((= (type lst2) 'real)
  49.                                              (setq lst2 (rtos lst2))
  50.                                             )
  51.                                             ((= (type lst2) 'int)
  52.                                              (setq lst2 (itoa lst2))
  53.                                             )
  54.                                             (t
  55.                                              (setq lst2
  56.                                                     (vl-princ-to-string
  57.                                                       lst2
  58.                                                     )
  59.                                              )
  60.                                             )
  61.                                           ) ;cond 函数结束  
  62.                                           (list lst1 lst2)
  63.                                         )
  64.                                        (list 0 1 2 3 4 5 6)
  65.                                )
  66.                         )
  67.                       )
  68.                       (progn
  69.                         (setq subset
  70.                                (mapcar '(lambda        (i)
  71.                                           (nth i subset)
  72.                                         )
  73.                                        (list 9 0 10 1 11 2 12 3 13 7 14 4 15 5 16 6 17 8)
  74.                                )
  75.                         )
  76.                         (setq subset
  77.                                (mapcar '(lambda        (i / j lst1 lst2)
  78.                                           (setq j (* i 2))
  79.                                           (setq        lst1 (nth j subset)
  80.                                                 lst2 (nth (+ j 1) subset)
  81.                                           )
  82.                                           (cond
  83.                                             ((= (type lst2) 'real)
  84.                                              (setq lst2 (rtos lst2))
  85.                                             )
  86.                                             ((= (type lst2) 'int)
  87.                                              (setq lst2 (itoa lst2))
  88.                                             )
  89.                                             (t
  90.                                              (setq lst2
  91.                                                     (vl-princ-to-string
  92.                                                       lst2
  93.                                                     )
  94.                                              )
  95.                                             )
  96.                                           ) ;cond 函数结束  
  97.                                           (list lst1 lst2)
  98.                                         )
  99.                                        (list 0 1 2 3 4 5 6 7 8)
  100.                                )
  101.                         )
  102.                       )
  103.                     )                        ; (if        (not state) 函数结束  
  104.                     (mapcar '(lambda (lst)
  105.                                (apply 'strcat lst)
  106.                              )
  107.                             subset
  108.                     )
  109.                   )
  110.                  group_string
  111.          )
  112.   )
  113.   ;; 把Z_road_start 加入数组 group_2 中的第一行 最后一个元素  
  114.   (if (not Z_road_start)
  115.     (setq Z_road_start 0)
  116.   )
  117.   (setq        string (rtos Z_road_start)
  118.         string (strcat "Z_start=" string)
  119.   )
  120.   (setq        lst1        (car group_2)
  121.         lst2        (append lst1 (list string))
  122.         group_2        (append (list lst2) (cdr group_2))
  123.   )
  124.   (mapcar
  125.     '(lambda (lst / str)                ; (setq str (car group_2))  
  126.        (setq str (vl-princ-to-string lst)
  127.              str (vl-string-left-trim "(" str)
  128.              str (vl-string-right-trim ")" str)
  129.        )
  130.      )
  131.     group_2
  132.   )
  133. )
  134. ;; (setq tgg (change_group_turning_point_original group_turning_point_original Z_road_start ) )   



  1. ;; 交点参数的文件格式, 当交点为完整缓和曲线时 :  [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )  ] ,
  2. ;; 当交点为非完整缓和曲线交点时 :   [ ( 转点号I t)  U_转点   ( R_start  R  R_end  Ls1   Ls2) ]  
  3. ;; 输出变量group_turning_point_original : [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )]   
  4. (defun create_turning_point_group_original
  5.                                            (/
  6.                                             n
  7.                                             i
  8.                                             lst
  9.                                             group
  10.                                             group_turning_point_original
  11.                                             Z_road_start
  12.                                            )
  13.   ;; group_turning_point_original 格式 [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )  ]  , 完整缓和曲线时  
  14.   ;;  or [ ( 转点号I nil)  U_转点   ( R_start R  R_end  Ls1   Ls2) ]  , 非完整缓和曲线交点时   
  15.   (if nil
  16.     (setq group_turning_point_original (insert_交点_value))
  17.     (setq lst (insert_交点_str)
  18.           group_turning_point_original
  19.            (car lst)
  20.           Z_road_start
  21.            (cadr lst)
  22.     )
  23.   )
  24.   (list group_turning_point_original Z_road_start)

  25.                                         ; 排序函数结束
  26. )                                        ;  create_turning_point_group_2 函数结束  
  27. ;; (setq group_turning_point_original (car ( create_turning_point_group_original ) ) )   



  28. ;; 交点参数的文件格式, 当交点为完整缓和曲线时 :  [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )  ] ,
  29. ;; 当交点为非完整缓和曲线交点时 :   [ ( 转点号I t)  U_转点   ( R_start  R  R_end  Ls1   Ls2) ]  
  30. ;; 输出变量turning_point_group : [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )(α1  α2   Δ Dist_1   Dist_2 )]     
  31. (defun create_turning_point_group
  32.                                   (group_turning_point_original
  33.                                    Z_road_start        /
  34.                                    n                i
  35.                                    lst                group
  36.                                    ;; 求交点距离角度时用到的参数  
  37.                                    α1                α2
  38.                                    Δ                Dist_1
  39.                                    Dist_2        lst_1
  40.                                    lst_2        lst_3
  41.                                    U_1                U_2
  42.                                    U_3
  43.                                   )
  44.   ;; turning_point_group 格式 [ ( 转点号I nil)   U_转点  ( Ls1 R Ls2 )  ]  , 完整缓和曲线时  
  45.   ;;  or [ ( 转点号I nil)  U_转点   ( R_start R  R_end  Ls1   Ls2) ]  , 非完整缓和曲线交点时   

  46.   ;; 对数组group_turning_point  [ ( 转点号I nil)  U_转点 ( Ls1 R Ls2 )  ] , 加入第三项 (α1  α2   Δ Dist_1   Dist_2 )  
  47.   (setq        i     0
  48.         group nil
  49.         n     (length group_turning_point_original)
  50.   )
  51.   (repeat n
  52.     (cond
  53.       ;;当转点为[第二个->倒数第二个] 转点时  
  54.       ((and (/= i 0) (/= i (- n 1)))
  55.        (progn
  56.          (setq lst_1 (nth (- i 1) group_turning_point_original))
  57.          (setq lst_2 (nth i group_turning_point_original))
  58.          (setq lst_3 (nth (+ i 1) group_turning_point_original))
  59.          (setq U_1 (cadr lst_1)
  60.                U_2 (cadr lst_2)
  61.                U_3 (cadr lst_3)
  62.          )
  63.          (setq Dist_1 (distance U_1 U_2)
  64.                Dist_2 (distance U_2 U_3)
  65.          )
  66.          (setq α1 (angle U_1 U_2)
  67.                α2 (angle U_2 U_3)
  68.                Δ  (- α2 α1)
  69.          )
  70.          ;; 对转角Δ 使其控制在(-pi pi) 之间
  71.          (cond
  72.            ((and (>= Δ (* -1 pi))
  73.                  (< Δ pi)
  74.             )
  75.             (setq Δ Δ)
  76.            )
  77.            ((< Δ (* -1 pi))
  78.             (setq Δ (+ Δ (* 2 pi)))
  79.            )
  80.            ((> Δ pi)
  81.             (setq Δ (- Δ (* 2 pi)))
  82.            )
  83.          )
  84.          (setq lst   (list α1 α2 Δ Dist_1 Dist_2)
  85.                lst   (append lst_2 (list lst))
  86.                group (cons lst group)
  87.          )
  88.        )
  89.       )
  90.       ;;当为第一个转点时的情形 起始转点->下一转点
  91.       ((= i 0)
  92.        (progn
  93.          (setq lst_2 (nth i group_turning_point_original))
  94.          (setq lst_3 (nth (+ i 1) group_turning_point_original))
  95.          (setq
  96.            U_2 (cadr lst_2)
  97.            U_3 (cadr lst_3)
  98.          )
  99.          (setq Dist_1 0
  100.                Dist_2 (distance U_2 U_3)
  101.                α2    (angle U_2 U_3)
  102.                lst    (list 0 α2 0 0 Dist_2)
  103.          )
  104.          (setq lst   (append lst_2 (list lst))
  105.                group (cons lst group)
  106.          )
  107.        )
  108.       )
  109.       ;; 当转点为最后一个转点时的情形 上一转点->终点转点   
  110.       ((= i (- n 1))
  111.        (progn
  112.          (setq lst_1 (nth (- i 1) group_turning_point_original))
  113.          (setq lst_2 (nth i group_turning_point_original))
  114.          (setq U_1 (cadr lst_1)
  115.                U_2 (cadr lst_2)
  116.          )
  117.          (setq Dist_1 (distance U_1 U_2)
  118.                α1    (angle U_1 U_2)

  119.                lst    (list α1 0 0 Dist_1 0)
  120.          )
  121.          (setq lst   (append lst_2 (list lst))
  122.                group (cons lst group)
  123.          )
  124.        )
  125.       )
  126.     )                                        ; cond  函数结束  
  127.     (setq i (+ i 1))
  128.   )                                        ; (repeat n  函数结束
  129.   (setq group_turning_point (reverse group))
  130.   (list group_turning_point Z_road_start)

  131.                                         ; 排序函数结束
  132. )                                        ;  create_turning_point_group_2 函数结束  
  133. ;; (setq group_turning_point(car  ( create_turning_point_group   group_turning_point_original  Z_road_start )  ) )   





  134. ;; (setq tang (insert_交点_str ))   
  135. (defun insert_交点_str (/      fname  f1     group  lst           str
  136.                         X      Y      Lh1    Lh2    JD           state
  137.                         stake_Z              str_seek
  138.                        )
  139.   (setq
  140.     fname (getfiled "\n输入存放交点参数的文件" "" "txt" 1)
  141.   )
  142.   (if fname
  143.     (progn
  144.       (setq f1 (open fname
  145.                      "r"
  146.                )
  147.       )
  148.       (setq group
  149.              nil
  150.             lst        nil
  151.             group_2 nil
  152.       )
  153.       (while (setq lst (read-line f1))
  154.         (setq group
  155.                (cons lst group)
  156.         )
  157.       )
  158.       (setq group (reverse group))
  159.       (close f1)
  160.       (setq lst (car group))
  161.       (if (vl-string-search "Z_start=" lst)
  162.         (progn
  163.           ;; 线路起始点的转点号
  164.           (setq JD (string_search lst "JD=" " "))
  165.           ;;线路起始点的转点状态  
  166.           (setq state (string_search lst "state=" " "))
  167.           ;; 线路起始点的X坐标  
  168.           (setq X (string_search lst "E(Y)=" " "))
  169.           ;; 线路起始点的Y坐标   
  170.           (setq Y (string_search lst "N(X)=" " "))
  171.           ;; 线路起始点的桩号  
  172.           (setq stake_Z (string_search lst "Z_start=" nil))
  173.           (setq        group_2        (cons (list
  174.                                 (list JD state)
  175.                                 (list X Y)
  176.                                 (list 0 0 0)
  177.                               )
  178.                               group_2
  179.                         )
  180.           )
  181.         )
  182.       )                                        ;(if (setq i_start (vl-string-search "COORD" lst)) 函数结束
  183.       ;; 对各交点进行计算  88888888888        888888888888          8888888888888                        
  184.       (setq group (cdr group))
  185.       (mapcar
  186.         '(lambda (lst / R_start R_end R)
  187.                                         ;   (setq i 10) (setq lst (nth i group))   
  188.            (if (vl-string-search "JD" lst)
  189.              (progn
  190.                ;; 第N个交点的转点号  
  191.                (setq JD (string_search lst "JD=" " "))
  192.                ;;第N个交点的转点状态  
  193.                (setq state (string_search lst "state=" " "))
  194.                ;; 第N个交点的X坐标
  195.                (setq X (string_search lst "E(Y)=" " "))
  196.                ;; 第N个交点的Y坐标
  197.                (setq Y (string_search lst "N(X)=" " "))
  198.                ;; 第N个交点的第一缓和曲线长度  
  199.                (setq Lh1 (string_search lst "Lh1=" " "))
  200.                ;; 第N个交点的半径  
  201.                (setq R (string_search lst "R=" " "))
  202.                ;; 第N个交点的出口缓和曲线长度
  203.                (setq Lh2 (string_search lst "Lh2=" nil))
  204.                ;; 当交点中含有的缓和曲线为正规缓和曲线时  
  205.                (if (not state)
  206.                  (setq group_2 (cons (list (list JD state)
  207.                                            (list X Y)
  208.                                            (list Lh1 R Lh2)
  209.                                      )
  210.                                      group_2
  211.                                )
  212.                  )

  213.                )                        ; if (not state) 函数结束
  214.                ;; 当交点中含有非正规缓和曲线时   
  215.                (if state
  216.                  (progn
  217.                    ;; 第N个交点的缓和曲线起始半径
  218.                    (setq R_start (string_search lst "R_start=" " "))
  219.                    ;; 第N个交点的缓和曲线终点半径   
  220.                    (setq R_end (string_search lst "R_end=" " "))
  221.                    (setq group_2
  222.                           (cons        (list (list JD state)
  223.                                       (list X Y)
  224.                                       (list R_start R R_end Lh1 Lh2)
  225.                                 )
  226.                                 group_2
  227.                           )
  228.                    )
  229.                  )
  230.                )                        ; if state 函数结束
  231.              )                                ; prong 函数结束  
  232.            )                                ;(if          (vl-string-search "JD" lst)  
  233.          )
  234.         group
  235.       )                                        ;mapcar  函数结束
  236.       (setq group_2 (reverse group_2))

  237.     )                                        ;progn
  238.   )                                        ;(if fname 函数结束
  239.   (setq        group_2
  240.          (vl-sort group_2
  241.                   '(lambda (lst1 lst2)
  242.                      (<        (car (car lst1))
  243.                         (car (car lst2))
  244.                      )
  245.                    )
  246.          )
  247.   )
  248.   (list group_2 stake_Z)
  249. )
  250. ;; (setq tang (insert_交点_str ))



  251. ;;用复制的方法创建vertical_curve_group 数组
  252. ;;group_vertical_curve  数组形式 (转点号  竖曲线变坡点桩号 变坡点高程  变坡点半径 )
  253. ;; 起始点 结束点 半径为0
  254. (defun create_group_vertical_curve
  255.        (/ f1 lst_1 fname group_vertical_curve)
  256.   (if t
  257.     ;; 当用标准字符参数输入时   
  258.     (progn
  259.       (setq
  260.         fname (getfiled "\n输入存放竖曲线参数的文件" "" "txt" 1)
  261.       )
  262.       (if fname
  263.         (progn
  264.           (setq        f1 (open fname
  265.                          "r"
  266.                    )
  267.           )
  268.           (setq        group
  269.                  nil
  270.                 lst nil
  271.                 group_2        nil
  272.           )
  273.           (while (setq lst (read-line f1))
  274.             (setq group
  275.                    (cons lst group)
  276.             )
  277.           )
  278.           (setq group (reverse group))
  279.           (mapcar
  280.             '(lambda (lst / JD Z_stake H R) ; (setq lst (car group))   
  281.                (setq JD (string_search lst "JD=" " "))
  282.                (setq Z_stake (string_search lst "桩号=" " "))
  283.                (setq H (string_search lst "高程=" " "))
  284.                (setq R (string_search lst "R=" nil))
  285.                (setq group_2 (cons (list JD Z_stake H R) group_2))
  286.              )
  287.             group
  288.           )                                ;mapcar  函数结束
  289.           (setq group_2 (reverse group_2))

  290.         )                                ;progn
  291.       )                                        ;(if fname 函数结束
  292.     )

  293.     ;; 当用原先参数输入时 8888888888888888888888888888888888888888888888  888888888888888888888888888888888
  294.     (progn
  295.       (setq fname (getfiled "输入存放竖曲线交点参数的文件" "" "txt" 1))
  296.       (if fname
  297.         (progn
  298.           (setq        f1 (open fname
  299.                          "r"
  300.                    )
  301.           )
  302.           (setq        group_vertical_curve
  303.                  nil
  304.                 lst nil
  305.           )
  306.           (while (setq lst (read-line f1))
  307.             (setq group_vertical_curve
  308.                    (cons (read lst) group_vertical_curve)
  309.             )
  310.           )
  311.           ;; while (/= list_1 nil)循环函数结束
  312.         )
  313.       )
  314.       (close f1)
  315.       (setq group_vertical_curve
  316.              (vl-sort group_vertical_curve
  317.                       '(lambda (lst1 lst2)
  318.                          (< (car lst1) (car lst2))
  319.                        )
  320.              )
  321.       )
  322.       ;; 排序函数结
  323.     )
  324.   )
  325. )
  326. ;; (setq group_vertical_curve  (create_group_vertical_curve ))     




  327. ;;输出  数组superelevation_group 其格式为 (转点号   超高值 )   
  328. ;; 或者 (转点号 (ZH点超高  HY点超高)(YH点超高  HZ点超高)  )   
  329. (defun create_group_superelevation (/                  group_superelevation
  330.                                     n                  lst
  331.                                     f1
  332.                                    )
  333.   (if nil
  334.     ;; 当输入文件为原先超高文件时   
  335.     (progn
  336.       (setq
  337.         fname
  338.          (getfiled "\n输入存放线路交点超高方式的数据表" "" "txt" 1)
  339.       )
  340.       (if fname
  341.         (progn
  342.           (setq        f1 (open fname
  343.                          "r"
  344.                    )
  345.           )
  346.           (setq        group_superelevation
  347.                  nil
  348.                 lst nil
  349.           )
  350.           (while (setq lst (read-line f1))
  351.             (setq group_superelevation
  352.                    (cons (read lst) group_superelevation)
  353.             )
  354.           )
  355.           ;; while (/= list_1 nil)循环函数结束
  356.           (close f1)

  357.         )
  358.       )                                        ;(if fname 函数结束
  359.     )
  360.     ;; 当输入文件为标准超高文件时
  361.     (progn
  362.       (setq
  363.         fname
  364.          (getfiled "\n输入存放线路交点超高方式的数据表" "" "txt" 1)
  365.       )
  366.       (if fname
  367.         (progn
  368.           (setq        f1 (open fname
  369.                          "r"
  370.                    )
  371.           )
  372.           (setq        group
  373.                  nil
  374.                 lst nil
  375.           )
  376.           (while (setq lst (read-line f1))
  377.             (setq group
  378.                    (cons lst group)
  379.             )
  380.           )
  381.           (close f1)
  382.         )
  383.       )                                        ;(if fname 函数结束
  384.       (setq group (reverse group))
  385.       (mapcar
  386.         '(lambda (lst                       /
  387.                   JD                       superelevation
  388.                   superelevation_start superelevation_end
  389.                   superelevation_circle
  390.                  )                        ; (setq lst (car group))   
  391.            (setq JD (string_search lst "JD=" " "))
  392.            (if (vl-string-search "圆曲线超高值=" lst)
  393.              ;; 当加点超高为不规则超高时  
  394.              (progn
  395.                (setq superelevation_circle
  396.                       (string_search
  397.                         lst
  398.                         "圆曲线超高值="
  399.                         " "
  400.                       )
  401.                      superelevation_start
  402.                       (string_search lst "起点超高值=" " ")
  403.                      superelevation_end
  404.                       (string_search lst "终点超高值=" nil)
  405.                )
  406.                (setq group_superelevation
  407.                       (cons
  408.                         (list JD
  409.                               (list superelevation_start
  410.                                     superelevation_circle
  411.                               )
  412.                               (list superelevation_circle
  413.                                     superelevation_end
  414.                               )
  415.                         )
  416.                         group_superelevation
  417.                       )
  418.                )
  419.              )
  420.              (progn
  421.                (setq superelevation (string_search lst "超高值=" nil))
  422.                (setq group_superelevation
  423.                       (cons (list JD superelevation)
  424.                             group_superelevation
  425.                       )

  426.                )
  427.              )
  428.            )                                ;(if (string_search lst "圆曲线超高值=" " ") 函数结束   
  429.          )
  430.         group
  431.       )                                        ;mapcar  函数结束
  432.       (setq group_superelevation (reverse group_superelevation))
  433.     )
  434.   )                                        ; (if nil 函数结束   
  435.   (setq        group_superelevation
  436.          (vl-sort group_superelevation
  437.                   '(lambda (lst1 lst2)
  438.                      (<        (car lst1)
  439.                         (car lst2)
  440.                      )
  441.                    )
  442.          )
  443.   )
  444. )
  445. ;; (setq group_superelevation (create_group_superelevation ) )   




  446. ;; 计算线路加宽值8888888888            8888888888888888888              88888888888888888888           88888888888888888888   
  447. ;;从文件中写入加宽数组 ,  输出 数组group_widen 其格式为 ( 转点号   widen 线路加宽值)  
  448. (defun write_into_group_widen (/ lst fname f1 group group_widen)

  449.   (if nil
  450.     (progn
  451.       (setq
  452.         fname (getfiled "\n输入存放线路交点加宽参数的文件" "" "txt" 1)
  453.       )
  454.       (if (/= fname nil)
  455.         (progn
  456.           (setq        f1 (open fname
  457.                          "r"
  458.                    )
  459.           )
  460.           (while (setq list_1 (read-line f1))
  461.             (setq group (cons list_1 group))
  462.           )
  463.           (setq group (reverse group))
  464.           (setq
  465.             group_widen
  466.              nil
  467.           )
  468.           (setq        group_widen
  469.                  (mapcar '(lambda (x)
  470.                             (read x)
  471.                           )
  472.                          group
  473.                  )
  474.           )
  475.           (close f1)                        ;关闭文件fname
  476.         )                                ;  progn 函数结束
  477.       )                                        ;if (/= fname nil) 函数结束
  478.     )
  479.     ;; 用标准参数文件创建 group_widen 数组   
  480.     (progn
  481.       (setq
  482.         fname (getfiled "\n输入存放线路交点加宽参数的文件" "" "txt" 1)
  483.       )
  484.       (if fname
  485.         (progn
  486.           (setq        f1 (open fname
  487.                          "r"
  488.                    )
  489.           )
  490.           (setq        group
  491.                  nil
  492.                 lst nil
  493.                 group_2        nil
  494.           )
  495.           (while (setq lst (read-line f1))
  496.             (setq group
  497.                    (cons lst group)
  498.             )
  499.           )
  500.           (setq group (reverse group))
  501.           (mapcar
  502.             '(lambda (lst / JD Wide)
  503.                (setq JD (string_search lst "JD=" " "))
  504.                (setq Wide (string_search lst "加宽值=" nil))
  505.                (setq group_2 (cons (list JD Wide) group_2))
  506.              )
  507.             group
  508.           )                                ;mapcar  函数结束
  509.           (setq group_widen (reverse group_2))

  510.         )                                ;progn
  511.       )
  512.       (close f1)
  513.     )
  514.   )                                        ;(if nil 函数结束
  515.   (setq        group_widen
  516.          (vl-sort group_widen
  517.                   '(lambda (lst1 lst2)
  518.                      (< (car lst1) (car lst2))
  519.                    )
  520.          )
  521.   )
  522.   ;; 排序函数结
  523. )                                        ; write_into_group_widen 函数结束
  524. ;; 88888888888888888888888888888888888       (write_into_group_widen )      
  525. ;;  (setq  group_widen (write_into_group_widen))  





  526. ;; 计算线路加宽值8888888888            8888888888888888888              88888888888888888888           88888888888888888888   
  527. ;;从文件中写入设计桩号数组 ,  
  528. (defun write_into_group_stake_mark (/ lst fname f1 group group_widen)

  529.   (if nil
  530.     (progn
  531.       (setq
  532.         fname (getfiled "\n输入存放线路设计桩号参数的文件" "" "txt" 1)
  533.       )
  534.       (if (/= fname nil)
  535.         (progn
  536.           (setq        f1 (open fname
  537.                          "r"
  538.                    )
  539.           )
  540.           (while (setq list_1 (read-line f1))
  541.             (setq group (read (cons list_1 group)))
  542.           )
  543.           (setq group (reverse group))
  544.           (setq group_stake_mark (apply 'append group))
  545.           (close f1)                        ;关闭文件fname
  546.         )                                ;  progn 函数结束
  547.       )                                        ;if (/= fname nil) 函数结束
  548.     )
  549.     ;; 用标准参数文件创建group_stake_mark 数组   
  550.     (progn
  551.       (setq
  552.         fname (getfiled "\n输入存放线路设计桩号参数的文件" "" "txt" 1)
  553.       )
  554.       (if fname
  555.         (progn
  556.           (setq        f1 (open fname
  557.                          "r"
  558.                    )
  559.           )
  560.           (setq group nil)
  561.           (while (setq lst (read-line f1))
  562.             (setq group (cons lst group))
  563.           )
  564.           (setq group (reverse group))
  565.           (setq        lst nil
  566.                 group_2        nil
  567.           )
  568.           (mapcar
  569.             '(lambda (lst / stake_mark)        ; (setq lst ( car group))  
  570.                (setq stake_mark (string_search lst "设计桩号:" nil))
  571.                (setq group_2 (cons stake_mark group_2))
  572.              )
  573.             group
  574.           )                                ;mapcar  函数结束
  575.           (setq        group_2                 (reverse group_2)
  576.                 group_stake_mark (apply 'append group_2)
  577.           )


  578.         )                                ;progn
  579.       )
  580.       (close f1)
  581.     )
  582.   )                                        ;(if nil 函数结束
  583.   group_stake_mark
  584. )                                        ; write_into_group_widen 函数结束
  585. ;; 88888888888888888888888888888888888       (write_into_group_widen )      
  586. ;;  (setq tgg (write_into_group_stake_mark))   





  587. ;; 创建一个寻找字符串str 中str_sub 的函数
  588. ;; 返回参数为 字符中str 中str_search str_stop 之间的 字符串  
  589. (defun string_search (str str_search str_stop / n i_1 i_2 string_out)
  590.   (setq n (strlen str_search))
  591.   (setq
  592.     i_1        (vl-string-search str_search str)
  593.   )
  594.   (if i_1
  595.     (progn
  596.       (if str_stop
  597.         (progn
  598.           (setq
  599.             i_2        (vl-string-search
  600.                   str_stop
  601.                   str
  602.                   (+ (+ i_1 n) 1)
  603.                 )
  604.           )
  605.           (if i_2
  606.             (setq
  607.               string (substr str
  608.                              (+ (+ i_1 n) 1)
  609.                              (- i_2 (+ i_1 n))
  610.                      )
  611.             )
  612.             (progn
  613.               (alert (strcat "\n您输入的表格:"
  614.                              str
  615.                              "中"
  616.                              (substr str (+ i_1 1))
  617.                              "的后面无法找到:"
  618.                              str_stop
  619.                              "!"
  620.                      )
  621.               )
  622.               (quit)
  623.             )
  624.           )
  625.         )                                ;progn 函数结束
  626.         ;; 当str_stop 没有定义时  
  627.         (progn
  628.           (setq
  629.             string (substr str
  630.                            (+ (+ i_1 n) 1)
  631.                    )
  632.           )
  633.           ;; 当字符串string是 " 123.4 345.9 tyu " 的形式时  
  634.           (if (vl-string-search " "  string )
  635.             (setq string (strcat "(" string ")"))
  636.           )
  637.         )
  638.       )                                        ; (if str_stop 函数结束
  639.       (setq string_out (read string))
  640.     )
  641.     (progn
  642.       (alert
  643.         (strcat        "\n您输入的表格:"  str
  644.                 " 中无法寻找到:  " str_search
  645.                 "  !!!"
  646.                )
  647.       )
  648.       (quit)
  649.     )
  650.   )                                        ; (if i_1 函数结束
  651. )
  652. ;; (setq str "  tang i_love ,you "  str_search "tang"  str_stop "," )  
  653. ;; (setq tgg (string_search  str  str_search  str_stop ) )   
  654. ;; (setq tgg (string_search "tang i_love ,you "  "hong"  "," ) )   
  655. ;; (setq tgg (string_search "tang i_love ,you "  "i"  "hate" ) )   
  656. ;; (setq tgg (string_search "唐国庚,you "  "唐国"  "庚" ) )   


  657. (defun insert_交点_value (/ fname f1 group group_turning_point n i)
  658.   (setq fname (getfiled "输入存放交点参数的文件" "" "txt" 1))
  659.   (setq f1 (open fname "r"))
  660.   (setq group nil)
  661.   (while (setq lst (read-line f1))
  662.     (setq group (cons lst group))
  663.   )                                        ; while (/= list  nil)循环函数结束
  664.   (close f1)
  665.   (setq        i 0
  666.         group_turning_point
  667.          nil
  668.         n (length group)
  669.   )
  670.   (repeat n
  671.     (setq lst                      (read (nth i group))
  672.           group_turning_point
  673.                               (cons lst group_turning_point)
  674.     )
  675.     (setq i (+ i 1))
  676.   )
  677.   (setq        group_turning_point
  678.          (vl-sort group_turning_point
  679.                   '(lambda (lst1 lst2)
  680.                      (<        (car (car lst1))
  681.                         (car (car lst2))
  682.                      )
  683.                    )
  684.          )
  685.   )
  686. )
  687. ;; (setq tang (insert_交点_value ))   


  1. (defun write_group_vertical_curve
  2.                                   (group_vertical_curve
  3.                                    /                 fname
  4.                                    f1                 group
  5.                                    group_2         group_string
  6.                                    lst_str         string
  7.                                   )
  8.   (if t
  9.     (progn
  10.       (setq
  11.         fname (getfiled "\n输入要选择竖曲线交点参数的文件" "" "txt" 1)
  12.       )

  13.       (setq f1 (open fname
  14.                      "r"
  15.                )
  16.       )
  17.       (setq group
  18.              nil
  19.             lst        nil
  20.             group_2 nil
  21.       )
  22.       (while (setq lst (read-line f1))
  23.         (setq group
  24.                (cons lst group)
  25.         )
  26.       )
  27.       (close f1)
  28.       (setq group (reverse group))
  29.       (setq group_vertical_curve (mapcar 'read group))
  30.     )
  31.   )
  32.   ;; 把group 数组转换成 自己需要的形式
  33.   (setq        group_string
  34.          (mapcar '(lambda (lst)
  35.                     (mapcar '(lambda (x)
  36.                                (cond
  37.                                  ((= (type x) 'real)
  38.                                   (rtos x)
  39.                                  )
  40.                                  ((= (type x) 'int)
  41.                                   (itoa x)
  42.                                  )
  43.                                  (t
  44.                                   (vl-princ-to-string
  45.                                     x
  46.                                   )
  47.                                  )
  48.                                )        ;cond 函数结束
  49.                              )
  50.                             lst
  51.                     )
  52.                   )
  53.                  group_vertical_curve
  54.          )
  55.   )
  56.   (setq lst_str (list "JD=" "桩号=" "高程=" "R="))
  57.   (setq        group_2
  58.          (mapcar '(lambda (lst / subset)
  59.                     (setq subset
  60.                            (append lst lst_str)
  61.                     )
  62.                     (setq subset
  63.                            (mapcar '(lambda (i)
  64.                                       (nth i subset)
  65.                                     )
  66.                                    (list 4 0 5 1 6 2 7 3)
  67.                            )
  68.                     )
  69.                     (setq subset
  70.                            (mapcar '(lambda (i / j)
  71.                                       (setq j (* i 2))
  72.                                       (list (nth j subset)
  73.                                             (nth (+ j 1) subset)
  74.                                       )
  75.                                     )
  76.                                    (list 0 1 2 3)
  77.                            )
  78.                     )
  79.                     (mapcar '(lambda (lst)
  80.                                (apply 'strcat lst)
  81.                              )
  82.                             subset
  83.                     )
  84.                   )
  85.                  group_string
  86.          )
  87.   )
  88.   (setq
  89.     fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1)
  90.   )

  91.   (setq        f1 (open fname
  92.                  "w"
  93.            )
  94.   )
  95.   (mapcar
  96.     '(lambda (lst / str)                ; (setq str (car group_2))  
  97.        (setq str (vl-princ-to-string lst)
  98.              str (vl-string-left-trim "(" str)
  99.              str (vl-string-right-trim ")" str)
  100.        )
  101.        (write-line str f1)
  102.      )
  103.     group_2
  104.   )
  105.   (close f1)
  106. )
  107. ;;  (write_group_vertical_curve  group_vertical_curve  )   


  108. ;; (setq lst (insert_交点_str )    Z_road_start (cadr lst)  group_turning_point (car lst))   
  109. (defun write_group_turning_point_original
  110.                                           (Z_road_start
  111.                                            group_turning_point_original
  112.                                            /
  113.                                            fname
  114.                                            f1
  115.                                            group
  116.                                            group_2
  117.                                            group_string
  118.                                            lst_str
  119.                                            lst1
  120.                                            lst2
  121.                                            string
  122.                                           )
  123.   (if nil
  124.     (progn
  125.       (setq
  126.         fname (getfiled "\n输入要选择的交点参数文件" "" "txt" 1)
  127.       )

  128.       (setq f1 (open fname
  129.                      "r"
  130.                )
  131.       )
  132.       (setq group
  133.              nil
  134.             lst        nil
  135.             group_2 nil
  136.       )
  137.       (while (setq lst (read-line f1))
  138.         (setq group
  139.                (cons lst group)
  140.         )
  141.       )
  142.       (close f1)
  143.       (setq group (reverse group))
  144.       (setq group_turning_point_original (mapcar 'read group))
  145.     )
  146.   )
  147.   (if (not Z_road_start)
  148.     (setq Z_road_start 0)
  149.   )
  150.   (setq        group_2        (change_group_turning_point_original
  151.                   group_turning_point_original
  152.                   Z_road_start
  153.                 )
  154.   )
  155.   (setq
  156.     fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1)
  157.   )

  158.   (setq        f1 (open fname
  159.                  "w"
  160.            )
  161.   )
  162.   (mapcar
  163.     '(lambda (str)                        ; (setq str (car group_2))  
  164.        (write-line str f1)
  165.      )
  166.     group_2
  167.   )
  168.   (close f1)
  169. )
  170. ;;  (write_group_turning_point_original   Z_road_start  group_turning_point_original )  
  171. ;;  (write_group_turning_point_original   60100  group_turning_point_original )  



  172. ;; 把超高数组group_superelevation 写入指定文件中
  173. (defun write_group_superelevation
  174.                                   (group_superelevation
  175.                                    /                 fname
  176.                                    f1                 group
  177.                                    group_2         group_string
  178.                                    lst_str         string
  179.                                   )
  180.   (if t
  181.     (progn
  182.       (setq
  183.         fname
  184.          (getfiled "\n输入存放线路交点超高方式的数据表" "" "txt" 1)
  185.       )
  186.       (setq f1 (open fname
  187.                      "r"
  188.                )
  189.       )
  190.       (setq group
  191.              nil
  192.             lst        nil
  193.             group_2 nil
  194.       )
  195.       (while (setq lst (read-line f1))
  196.         (setq group
  197.                (cons lst group)
  198.         )
  199.       )
  200.       (close f1)
  201.       (setq group (reverse group))
  202.       (setq group_superelevation (mapcar 'read group))
  203.     )
  204.   )
  205.   (setq        group_string
  206.          (mapcar '(lambda (lst)
  207.                     (if        (= (length lst) 3)
  208.                       (list (car lst)
  209.                             (car (cadr lst))
  210.                             (cadr (cadr lst))
  211.                             (cadr (caddr lst))
  212.                       )
  213.                       lst
  214.                     )
  215.                   )
  216.                  group_superelevation
  217.          )
  218.   )
  219.   (setq        group_string
  220.          (mapcar '(lambda (lst)
  221.                     (mapcar '(lambda (x)
  222.                                (cond
  223.                                  ((= (type x) 'real)
  224.                                   (rtos x)
  225.                                  )
  226.                                  ((= (type x) 'int)
  227.                                   (itoa x)
  228.                                  )
  229.                                  (t
  230.                                   (vl-princ-to-string
  231.                                     x
  232.                                   )
  233.                                  )
  234.                                )        ;cond 函数结束
  235.                              )
  236.                             lst
  237.                     )
  238.                   )
  239.                  group_string
  240.          )
  241.   )
  242.   (setq        lst_str_1 (list "JD=" "超高值=")
  243.         lst_str_2 (list        "JD="
  244.                         "起点超高值="
  245.                         "圆曲线超高值="
  246.                         "终点超高值="
  247.                   )
  248.   )
  249.   (setq        group_2
  250.          (mapcar '(lambda (lst / subset)

  251.                     (if        (= (length lst) 2)
  252.                       (progn
  253.                         (setq subset
  254.                                (append lst lst_str_1)
  255.                         )
  256.                         (setq subset
  257.                                (mapcar '(lambda        (i)
  258.                                           (nth i subset)
  259.                                         )
  260.                                        (list 2 0 3 1)
  261.                                )
  262.                         )
  263.                         (setq subset
  264.                                (mapcar '(lambda        (i / j)
  265.                                           (setq j (* i 2))
  266.                                           (list        (nth j subset)
  267.                                                 (nth (+ j 1) subset)
  268.                                           )
  269.                                         )
  270.                                        (list 0 1)
  271.                                )
  272.                         )
  273.                       )
  274.                     )
  275.                     (if        (= (length lst) 4)
  276.                                         ; (setq lst (nth 9 group_string))   
  277.                       (progn
  278.                         (setq subset
  279.                                (append lst lst_str_2)
  280.                         )
  281.                         (setq subset
  282.                                (mapcar '(lambda        (i)
  283.                                           (nth i subset)
  284.                                         )
  285.                                        (list 4 0 5 1 6 2 7 3)
  286.                                )
  287.                         )
  288.                         (setq subset
  289.                                (mapcar '(lambda        (i / j)
  290.                                           (setq j (* i 2))
  291.                                           (list        (nth j subset)
  292.                                                 (nth (+ j 1) subset)
  293.                                           )
  294.                                         )
  295.                                        (list 0 1 2 3)
  296.                                )
  297.                         )
  298.                       )
  299.                     )
  300.                     (mapcar '(lambda (lst)
  301.                                (apply 'strcat lst)
  302.                              )
  303.                             subset
  304.                     )
  305.                   )
  306.                  group_string
  307.          )
  308.   )
  309.   (setq
  310.     fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1)
  311.   )
  312.   (setq        f1 (open fname
  313.                  "w"
  314.            )
  315.   )
  316.   (mapcar
  317.     '(lambda (lst / str)                ; (setq str (car group_2))  
  318.        (setq str (vl-princ-to-string lst)
  319.              str (vl-string-left-trim "(" str)
  320.              str (vl-string-right-trim ")" str)
  321.        )
  322.        (write-line str f1)
  323.      )
  324.     group_2
  325.   )
  326.   (close f1)
  327. )
  328. ;;  (write_group_superelevation  group_superelevation )  



  329. (defun write_group_widen
  330.                          (group_widen                /           fname
  331.                           f1             group        group_2           group_string
  332.                           lst_str    string
  333.                          )
  334.   (if t
  335.     (progn
  336.       (setq
  337.         fname (getfiled "\n输入要选择的转点加宽文件" "" "txt" 1)
  338.       )
  339.       (setq f1 (open fname
  340.                      "r"
  341.                )
  342.       )
  343.       (setq group
  344.              nil
  345.             lst        nil
  346.             group_2 nil
  347.       )
  348.       (while (setq lst (read-line f1))
  349.         (setq group
  350.                (cons lst group)
  351.         )
  352.       )
  353.       (close f1)
  354.       (setq group (reverse group))
  355.       (setq group_widen (mapcar 'read group))
  356.     )
  357.   )
  358.   ;; 把group 数组转换成 自己需要的形式
  359.   (setq        group_string
  360.          (mapcar '(lambda (lst)
  361.                     (mapcar '(lambda (x)
  362.                                (cond
  363.                                  ((= (type x) 'real)
  364.                                   (rtos x)
  365.                                  )
  366.                                  ((= (type x) 'int)
  367.                                   (itoa x)
  368.                                  )
  369.                                  (t
  370.                                   (vl-princ-to-string
  371.                                     x
  372.                                   )
  373.                                  )
  374.                                )        ;cond 函数结束
  375.                              )
  376.                             lst
  377.                     )
  378.                   )
  379.                  group_widen
  380.          )
  381.   )
  382.   (setq lst_str (list "JD=" "加宽值="))
  383.   (setq        group_2
  384.          (mapcar '(lambda (lst / subset)
  385.                     (setq subset
  386.                            (append lst lst_str)
  387.                     )
  388.                     (setq subset
  389.                            (mapcar '(lambda (i)
  390.                                       (nth i subset)
  391.                                     )
  392.                                    (list 2 0 3 1)
  393.                            )
  394.                     )
  395.                     (setq subset
  396.                            (mapcar '(lambda (i / j)
  397.                                       (setq j (* i 2))
  398.                                       (list (nth j subset)
  399.                                             (nth (+ j 1) subset)
  400.                                       )
  401.                                     )
  402.                                    (list 0 1)
  403.                            )
  404.                     )
  405.                     (mapcar '(lambda (lst)
  406.                                (apply 'strcat lst)
  407.                              )
  408.                             subset
  409.                     )
  410.                   )
  411.                  group_string
  412.          )
  413.   )
  414.   (setq
  415.     fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1)
  416.   )

  417.   (setq        f1 (open fname
  418.                  "w"
  419.            )
  420.   )
  421.   (mapcar
  422.     '(lambda (lst / str)                ; (setq str (car group_2))  
  423.        (setq str (vl-princ-to-string lst)
  424.              str (vl-string-left-trim "(" str)
  425.              str (vl-string-right-trim ")" str)
  426.        )
  427.        (write-line str f1)
  428.      )
  429.     group_2
  430.   )
  431.   (close f1)
  432. )
  433. ;;  (write_group_widen   group_widen )   




  434. (defun write_group_stake_mark
  435.                               (group_stake_mark
  436.                                /               fname
  437.                                f1               group
  438.                                group_2               group_string
  439.                                lst_str               string
  440.                                group_stake_mark_divide
  441.                               )
  442.   (if nil
  443.     (progn
  444.       (setq fname (getfiled "输入存放桩号的数据表" "" "txt" 1))
  445.       (if fname
  446.         (progn
  447.           (setq        f1 (open fname
  448.                          "r"
  449.                    )
  450.           )
  451.           (setq        group_stake_mark
  452.                  nil
  453.                 lst nil
  454.           )
  455.           (while (setq lst (read-line f1))
  456.             (setq group_stake_mark
  457.                    (cons (read lst) group_stake_mark)
  458.             )
  459.           )
  460.           (close f1)
  461.           (setq group_stake_mark (reverse group_stake_mark))
  462.           ;; 把桩号数组group_stake_mark  变为一元列表  
  463.           (setq group_stake_mark (apply 'append group_stake_mark))
  464.         )
  465.       )                                        ; if fname 函数结束
  466.     )
  467.   )
  468.   ;;在对group_stake_mark数组,按每10个桩号进行分组  
  469.   (setq        n_1 0
  470.         group nil
  471.         lst nil
  472.   )
  473.   (mapcar '(lambda (x)
  474.              (setq n_1 (+ n_1 1))
  475.              (if (= (rem n_1 10) 0)
  476.                (setq
  477.                  lst   (cons x lst)
  478.                  lst   (reverse lst)
  479.                  group (cons lst group)
  480.                  lst   nil
  481.                )
  482.                (setq lst (cons x lst))
  483.              )
  484.            )
  485.           group_stake_mark
  486.   )
  487.   (if lst
  488.     (setq group (cons lst group))
  489.   )
  490.   (setq group_stake_mark_divide (reverse group))
  491.   ;; 把group_stake_mark_divide  数组转换成 自己需要的形式
  492.   (setq        group
  493.          (mapcar '(lambda (lst)
  494.                     (mapcar 'rtos lst)
  495.                   )
  496.                  group_stake_mark_divide
  497.          )
  498.   )
  499.   (setq lst_str (list "设计桩号:"))
  500.   (setq        group_2
  501.          (mapcar '(lambda (lst / subset)   ;  (setq lst (last group))  
  502.                     (setq subset
  503.                            (append lst_str lst)
  504.                     )
  505.                   )
  506.                  group
  507.          )
  508.   )
  509.   (setq
  510.     fname (getfiled "\n输入要选择要写入的文件" "" "txt" 1)
  511.   )
  512.   (setq        f1 (open fname
  513.                  "w"
  514.            )
  515.   )
  516.   (mapcar
  517.     '(lambda (lst / str)                ; (setq str (car group_2))  
  518.        (setq str (vl-princ-to-string lst)
  519.              str (vl-string-left-trim "(" str)
  520.              str (vl-string-right-trim ")" str)
  521.        )
  522.        (write-line str f1)
  523.      )
  524.     group_2
  525.   )
  526.   (close f1)
  527. )
  528. ;;  (write_group_stake_mark   group_stake_mark )   


  1. (defun f_zhuanghao (Z / 桩号1 桩号2 Z_1 z_2 z_3 桩号3 桩号)
  2.   (setq        Z_1 (fix Z)
  3.         Z_2 (rem Z_1 1000)                ;整数桩号
  4.         Z_3 (/ (- Z_1 Z_2) 1000)        ;公里桩号
  5.         Z_4 (- Z Z_1)                        ;小数桩号
  6.   )
  7.   (setq        桩号1 (itoa Z_3)                ;获得整公里桩号
  8.         桩号2 (itoa Z_2)                ;获得桩号的小里程数
  9.         桩号3 (substr (rtos Z_4 2 3) 2 4) ;获得桩号的小数  
  10.   )
  11.   (cond
  12.     ((and (= Z_2 0) (= Z_4 0))
  13.      (setq 桩号 (strcat "K" 桩号1 "+000"))
  14.                                         ; 获得桩号的字符表达式如"K3+000" 的形式
  15.     )
  16.     ((and (= (rem Z_2 10) 0) (= Z_4 0))
  17.      (setq 桩号 (strcat "K" 桩号1 "+" 桩号2))
  18.                                         ; 获得桩号的字符表达式如"+860" 的形式
  19.     )
  20.     (t (setq 桩号 (strcat "K" 桩号1 "+" 桩号2 桩号3)))
  21.   )
  22. )                                        ;zhuanghao函数结束
  23. ;;8888888888888888888888888888888888888888888888




  24. (defun action_stake_Z
  25.                       (/          fname             f1                lst
  26.                        group_stake_mark             group        group_2
  27.                        n_1          n
  28.                       )

  29.   (setq group_stake_mark (write_into_group_stake_mark))

  30.   (setq        group
  31.          (mapcar '(lambda (x)
  32.                     (f_zhuanghao x)
  33.                   )
  34.                  group_stake_mark
  35.          )
  36.   )
  37.   ;;在对group数组,按每10个桩号进行分组  
  38.   (setq        n_1 0
  39.         group_2        nil
  40.         lst ""
  41.   )
  42.   (mapcar '(lambda (x)                        ; (setq x (car group) )   
  43.              (setq n_1 (+ n_1 1))
  44.              (if (= (rem n_1 2) 0)
  45.                (setq lst
  46.                              (strcat lst " " (itoa n_1) " : " x)
  47.                      group_2 (cons lst group_2)
  48.                      lst     ""
  49.                )
  50.                (setq lst
  51.                       (strcat lst (itoa n_1) " : " x)
  52.                )
  53.              )
  54.            )
  55.           group
  56.   )
  57.   (if (/= lst "")
  58.     (setq group_2 (cons lst group_2))
  59.   )
  60.   (setq group_z_str (reverse group_2))
  61.   (start_list "table_Z" 3)                ; 把原先列表去掉,换成新的
  62.   (mapcar 'add_list group_z_str)
  63.   (end_list)
  64.   (setq        n (length group_stake_mark)
  65.         n (itoa n)
  66.   )
  67.   (set_tile "table_Z" n)
  68.   group_stake_mark
  69. )
  70. ;; (action_stake_Z )






  71. ;; 创建一个 桩号的函数  
  72. (defun create_group_Z (Z_start Z_end Z_Δ / lst group_Z z residue)

  73.   (setq        group_z        (list Z_start)
  74.         Z        (+ (fix Z_start) 1)
  75.   )
  76.   ;; 对Z取摸5,使得group_z 为Z_Δ的倍数
  77.   (setq        residue        (rem Z Z_Δ)
  78.         Z        (- Z residue)
  79.   )
  80.   (if (>= Z Z_start)
  81.     (setq Z Z)
  82.     (setq Z (+ Z Z_Δ))
  83.   )

  84.   (while (< Z Z_end)
  85.     (setq group_Z (cons z group_Z))
  86.     (setq z (+ z Z_Δ))
  87.   )
  88.   (setq        group_z
  89.          (reverse group_z)
  90.   )
  91. )
  92. ;; (setq  group_Z ( create_group_Z 10784.9 10834  20 )  )   




  93. ;;  (setq group_turning_point ( create_turning_point_group ))  
  94. ;; (setq  group_Line_segments (car ( create_group_Line_segments   group_turning_point  6782.755 )) )  
  95. ;; 把设计桩号 分割成每个线元里面的 桩号数组  
  96. (defun creat_group_z (group_Line_segments              stake_mark_group
  97.                       /                      n                      group
  98.                       group_divide    group_divide_2  z_max
  99.                       lst
  100.                      )
  101.   (setq        group             (apply 'append group_Line_segments)
  102.         group_divide (mapcar '(lambda (x) (nth 6 x)) group)
  103.   )
  104.   (setq        group               (cdr group_divide)
  105.         n               (length group)
  106.         group_divide_2 nil
  107.         i               0
  108.   )
  109.   (repeat n
  110.     (setq lst                 (list (nth i group_divide)
  111.                                (nth i group)
  112.                          )
  113.           group_divide_2 (cons lst group_divide_2)
  114.     )
  115.     (setq i (+ i 1))
  116.   )
  117.   (setq z_max (last group_divide))        ;最后一个线元的起始桩号
  118.   ;; 把stake_mark_group位于最后一个线元桩号z_max 的桩号找出来
  119.   (setq        lst nil
  120.         stake_mark_group_sum
  121.          nil
  122.   )
  123.   (mapcar '(lambda (Z)
  124.              (if (>= z z_max)
  125.                (setq lst (cons z lst))
  126.              )
  127.            )
  128.           stake_mark_group
  129.   )
  130.   (if lst
  131.     (setq lst (reverse lst)
  132.           stake_mark_group_sum
  133.            (cons (list z_max lst) stake_mark_group_sum)
  134.     )
  135.   )
  136.   (mapcar '(lambda (u / z_start z_end)
  137.              (setq z_start (car U)
  138.                    z_end   (cadr U)
  139.              )
  140.              (setq lst nil)
  141.              (mapcar '(lambda (Z)
  142.                         (if (and (>= z z_start)
  143.                                  (< z z_end)
  144.                             )
  145.                           (setq lst (cons z lst))
  146.                         )
  147.                       )
  148.                      stake_mark_group
  149.              )
  150.              (if lst
  151.                (setq lst (reverse lst)
  152.                      stake_mark_group_sum
  153.                       (cons (list z_start lst) stake_mark_group_sum)
  154.                )
  155.              )
  156.            )
  157.           group_divide_2
  158.   )

  159.   stake_mark_group_sum
  160. )
  161. ;;  (setq stake_mark_group   (write_into_group_stake_mark))   
  162. ;; (setq group_Z_out  ( creat_group_z  group_Line_segments    stake_mark_group )  )   
发表于 2018-9-1 15:03 | 显示全部楼层
十分感谢,很好
发表于 2018-9-3 07:03 | 显示全部楼层
楼主威武,洋洋洒洒数百行代码,彰显着楼主在cad编程上出神入化的造诣,在下佩服至极。准备有空的时候下载了研究
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 03:34 , Processed in 0.386475 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表