1000人民币求一个切剖面程序，具体要求看附件

fdg30001 · 发表于 2013-11-10 20:07:02

这都不是事，看这幅图

fdg30001 · 发表于 2013-11-10 20:27:20

我只要剖面线与我画的地形线（多段线）交点标高，其他地方不考虑，剖面纵横比例都是1:1000

st788796 · 发表于 2013-11-10 21:04:17

fdg30001 发表于 2013-11-10 20:27
我只要剖面线与我画的地形线（多段线）交点标高，其他地方不考虑，剖面纵横比例都是1:1000

先下载api和lisp-lib库，给你用api写一个

fdg30001 · 发表于 2013-11-10 21:17:52

st788796 发表于 2013-11-10 21:04
先下载api和lisp-lib库，给你用api写一个

你是决定帮我写着程序了？
我下载了个XDRX_API.R16.X32，但是LISP-lib库没有，我找找看，要不等你做出来了一起打包给我。
加我QQ吧，详细谈谈，支付什么的一些问题，782244632

fdg30001 · 发表于 2013-11-10 21:19:08

st788796 发表于 2013-11-10 21:04
先下载api和lisp-lib库，给你用api写一个

你是决定帮我写着程序了？
我下载了个XDRX_API.R16.X32，但是LISP-lib库没有，我找找看，要不等你做出来了一起打包给我。
加我QQ吧，详细谈谈，支付什么的一些问题，782244632

st788796 · 发表于 2013-11-11 01:47:48

dnbcgrass 发表于 2013-11-10 22:49
加载qpmt.vlx后，在命令行键入qpmt命令，选择图中的剖面线，并指定第一条剖面线的起点，即可切取剖面，切完 ...

先写几句求交点的，有个函数没有关闭调试信息

(defun c:tt (/ ss Lss Pss Lcurve Lcurves pts Ppts)
(if (setq ss (ssget '((0 . "*polyline"))))
(progn
(setq Lss (ssget "P" '((0 . "lwpolyline")))
Pss (xdrx_pickset_subtract ss Lss)
Lcurve (xdrx_curve_getProjectCurve Pss '((0. 0. 0.) (0. 0. 1.)))
Lcurves (xdrx_pickset->ents lcurve)
pts (xdrx_curve_getinters Lss Lcurve)
Rays (mapcar '(lambda (x) (xdrx_ray_make x (mapcar '+ x '(0. 0. 1.)))) pts)
Ppts (xdrx_curve_getinters (XD::Entity->Pickset Rays) Pss)
)
(mapcar 'xdrx_entity_delete rays)
(mapcar 'xdrx_entity_delete Lcurves)
)
)
Ppts
)

st788796 · 发表于 2013-11-11 09:12:02

fdg30001 发表于 2013-11-10 21:19
你是决定帮我写着程序了？
我下载了个XDRX_API.R16.X32，但是LISP-lib库没有，我找找看，要不等你做出来 ...

楼主这个应用中的剖线编号最好有个配套程序在线上记录编号信息，直接由程序判定不好办，比如出现"U"时

fdg30001 · 发表于 2013-11-11 18:26:10

dnbcgrass，就交给i做了，加我QQ详谈，有些问题

st788796 · 发表于 2013-11-12 21:30:52

fdg30001 发表于 2013-11-11 18:26
dnbcgrass，就交给i做了，加我QQ详谈，有些问题

解决了就不往下写了

(defun c:tt (/ ss BaseH Lss Pss Lcurve Lcurves pts Ppts Pents PtsOnPl)
(defun cutz (p)
(list (car p) (cadr p))
)
(if (and (setq ss (ssget '((0 . "*polyline"))))
(setq BaseH (getreal "\n基准高程: "))
(setq p (getpoint "\n绘制基点: "))
)
(progn
(setq Lss (ssget "P" '((0 . "lwpolyline")))
Pss (xdrx_pickset_subtract ss Lss)
Pents (xdrx_pickset->ents lss)
Lcurve (xdrx_curve_getProjectCurve
Pss
'((0. 0. 0.) (0. 0. 1.))
)
Lcurves (xdrx_pickset->ents lcurve)
pts (xdrx_curve_getinters Lss Lcurve)
Rays (mapcar
'(lambda (x)
(xdrx_ray_make x (mapcar '+ x '(0. 0. 1.)))
)
pts
)
Ppts (xdrx_curve_getinters (XD::Entity->Pickset Rays) Pss)
)
(mapcar 'xdrx_entity_delete rays)
(mapcar 'xdrx_entity_delete Lcurves)
(setq Ppts (mapcar
'(lambda (x)
(list (car x) (cadr x) (- (caddr x) BaseH))
)
Ppts
)
PtsOnPl (mapcar '(lambda (x / l)
(setq l (vl-remove-if-not
'(lambda (p)
(xdrx_point_ison
(cutz p)
x
)
)
Ppts
)
Ppts (vl-remove-if
'(lambda (p)
(xdrx_point_ison
(cutz p)
x
)
)
Ppts
)
)
(cons x l)
)
Pents
)
PtsOnPl (mapcar '(lambda (x / e pts)
(setq e (car x)
pts (vl-sort
(cdr x)
'(lambda (p1 p2)
(< (xdrx_curve_getparamatpoint
e
(cutz p1)
)
(xdrx_curve_getparamatpoint
e
(cutz p2)
)
)
)
)
)
(cons e pts)
)
PtsOnPl
)
PtsOnpl (mapcar
'(lambda (x / pts e bp disL)
(setq e (car x)
pts (cdr x)
bp (cutz (car pts))
disL (mapcar '(lambda (a)
(cons (distance
(cutz a)
bp
)
(caddr a)
)
)
(cdr pts)
)
)
(cons e (cons (cons '0. (last (cadr x))) disL))
)
PtsOnpl
)
)
)
)
(princ PtsOnPl)
(princ)
)

(defun c:tt (/ ss BaseH Lss Pss Lcurve Lcurves pts Ppts Pents PtsOnPl) 
  (defun cutz (p) 
    (list (car p) (cadr p)) 
  ) 
  (if (and (setq ss (ssget '((0 . "*polyline")))) 
           (setq BaseH (getreal "\n基准高程: ")) 
           (setq p (getpoint "\n绘制基点: ")) 
      ) 
    (progn 
      (setq Lss            (ssget "P" '((0 . "lwpolyline"))) 
            Pss            (xdrx_pickset_subtract ss Lss) 
            Pents   (xdrx_pickset->ents lss) 
            Lcurve  (xdrx_curve_getProjectCurve 
                      Pss 
                      '((0. 0. 0.) (0. 0. 1.)) 
                    ) 
            Lcurves (xdrx_pickset->ents lcurve) 
            pts            (xdrx_curve_getinters Lss Lcurve) 
            Rays    (mapcar 
                      '(lambda (x) 
                         (xdrx_ray_make x (mapcar '+ x '(0. 0. 1.))) 
                       ) 
                      pts 
                    ) 
            Ppts    (xdrx_curve_getinters (XD::Entity->Pickset Rays) Pss) 
      ) 
      (mapcar 'xdrx_entity_delete rays) 
      (mapcar 'xdrx_entity_delete Lcurves) 
      (setq Ppts    (mapcar 
                      '(lambda (x) 
                         (list (car x) (cadr x) (- (caddr x) BaseH)) 
                       ) 
                      Ppts 
                    ) 
            PtsOnPl (mapcar '(lambda (x / l) 
                               (setq l          (vl-remove-if-not 
                                            '(lambda (p) 
                                               (xdrx_point_ison 
                                                 (cutz p) 
                                                 x 
                                               ) 
                                             ) 
                                            Ppts 
                                          ) 
                                     Ppts (vl-remove-if 
                                            '(lambda (p) 
                                               (xdrx_point_ison 
                                                 (cutz p) 
                                                 x 
                                               ) 
                                             ) 
                                            Ppts 
                                          ) 
                               ) 
                               (cons x l) 
                             ) 
                            Pents 
                    ) 
            PtsOnPl (mapcar '(lambda (x / e pts) 
                               (setq e         (car x) 
                                     pts (vl-sort 
                                           (cdr x) 
                                           '(lambda (p1 p2) 
                                              (< (xdrx_curve_getparamatpoint 
                                                   e 
                                                   (cutz p1) 
                                                 ) 
                                                 (xdrx_curve_getparamatpoint 
                                                   e 
                                                   (cutz p2) 
                                                 ) 
                                              ) 
                                            ) 
                                         ) 
                               ) 
                               (cons e pts) 
                             ) 
                            PtsOnPl 
                    ) 
            PtsOnpl (mapcar 
                      '(lambda (x / pts e bp disL) 
                         (setq e    (car x) 
                               pts  (cdr x) 
                               bp   (cutz (car pts)) 
                               disL (mapcar '(lambda (a) 
                                               (cons (distance 
                                                       (cutz a) 
                                                       bp 
                                                     ) 
                                                     (caddr a) 
                                               ) 
                                             ) 
                                            (cdr pts) 
                                    ) 
                         ) 
                         (cons e (cons (cons '0. (last (cadr x))) disL)) 
                       ) 
                      PtsOnpl 
                    ) 
      ) 
    ) 
  ) 
  (princ PtsOnPl) 
  (princ) 
)

st788796 · 发表于 2013-11-13 07:57:19

正好测试几个make函数，完整程序如下，没有写*error*处理，运行中如果中断可能会产生垃圾！

(defun c:tt (/ cutz ss BaseH Lss Pss Lcurve Lcurves
pts Ppts Pents Rays PtsOnPl bh an
p
)
(defun cutz (p)
(list (car p) (cadr p))
)
(if (and (setq ss (ssget '((0 . "*polyline"))))
(setq BaseH (getreal "\n基准高程: "))
(setq p (getpoint "\n绘制基点: "))
)
(progn
;;(XD::Begin)
(setq Lss (ssget "P" '((0 . "lwpolyline")))
Pss (xdrx_pickset_subtract ss Lss)
Pents (xdrx_pickset->ents lss)
Lcurve (xdrx_curve_getProjectCurve
Pss
'((0. 0. 0.) (0. 0. 1.))
)
Lcurves (xdrx_pickset->ents lcurve)
pts (xdrx_curve_getinters Lss Lcurve)
Rays (mapcar
'(lambda (x)
(xdrx_ray_make x (mapcar '+ x '(0. 0. 1.)))
)
pts
)
Ppts (xdrx_curve_getinters (XD::Entity->Pickset Rays) Pss)
)
(mapcar 'xdrx_entity_delete rays)
(mapcar 'xdrx_entity_delete Lcurves)
(setq Ppts (mapcar
'(lambda (x)
(list (car x) (cadr x) (- (caddr x) BaseH))
)
Ppts
)
PtsOnPl (mapcar '(lambda (x / l)
(setq l (vl-remove-if-not
'(lambda (p)
(xdrx_point_ison
(cutz p)
x
)
)
Ppts
)
Ppts (vl-remove-if
'(lambda (p)
(xdrx_point_ison
(cutz p)
x
)
)
Ppts
)
)
(cons x l)
)
Pents
)
PtsOnPl (mapcar '(lambda (x / e pts)
(setq e (car x)
pts (vl-sort
(cdr x)
'(lambda (p1 p2)
(< (xdrx_curve_getparamatpoint
e
(cutz p1)
)
(xdrx_curve_getparamatpoint
e
(cutz p2)
)
)
)
)
)
(cons e pts)
)
PtsOnPl
)
PtsOnpl (mapcar
'(lambda (x / pts e bp disL)
(setq e (car x)
pts (cdr x)
bp (cutz (car pts))
disL (mapcar '(lambda (a)
(list (distance
(cutz a)
bp
)
(caddr a)
)
)
(cdr pts)
)
)
(cons e (cons (list '0. (last (cadr x))) disL))
)
PtsOnpl
)
)
(setq an (- (/ pi 3.))
bh (rtos BaseH 2 0)
)
;;Draw
(mapcar '(lambda (x / pp pp1 p1 txt)
(setq pp (mapcar '(lambda (a) (mapcar '+ p a)) x)
pp1 (mapcar '(lambda (b)
(mapcar '+ p (list (car b) 0.))
)
x
)
p (mapcar '+ p '(100. 0. 0.))
)
(apply 'xdrx_polyline_make pp)
(mapcar '(lambda (a)
(xdrx_Donut_make
(list (car a) (cadr a) 0.) ;_需要 3D 点
0.
0.5
)
)
pp1
)
(mapcar '(lambda (c d) (xdrx_line_make c d)) pp pp1)
(xdrx_line_make
(polar (car pp1) pi 20.)
(setq p1 (polar (last pp1) 0. 20.))
)
(setq txt (xdrx_text_make
(list (car p1) (cadr p1) 0.) ;_需要 3D 点
bh
2.5
0.
)
)
(xdrx_text_setvermode txt 2)
(mapcar '(lambda (e f / txt)
(setq txt (xdrx_text_make
(list (car e) (cadr e) 0.) ;_需要 3D 点
(rtos (cadr f) 2 3)
2.0
an
)
)
(xdrx_text_setvermode txt 3)
)
pp1
x
)
)
(mapcar 'cdr PtsOnpl)
)
;; (XD::End)
)
)
;;(princ PtsOnPl)
(princ)
)

(defun c:tt (/            cutz   ss          BaseH         Lss        Pss    Lcurve Lcurves 
             pts    Ppts   Pents  Rays         PtsOnPl       bh     an 
             p 
            ) 
  (defun cutz (p) 
    (list (car p) (cadr p)) 
  ) 
  (if (and (setq ss (ssget '((0 . "*polyline")))) 
           (setq BaseH (getreal "\n基准高程: ")) 
           (setq p (getpoint "\n绘制基点: ")) 
      ) 
    (progn 
      ;;(XD::Begin) 
      (setq Lss            (ssget "P" '((0 . "lwpolyline"))) 
            Pss            (xdrx_pickset_subtract ss Lss) 
            Pents   (xdrx_pickset->ents lss) 
            Lcurve  (xdrx_curve_getProjectCurve 
                      Pss 
                      '((0. 0. 0.) (0. 0. 1.)) 
                    ) 
            Lcurves (xdrx_pickset->ents lcurve) 
            pts            (xdrx_curve_getinters Lss Lcurve) 
            Rays    (mapcar 
                      '(lambda (x) 
                         (xdrx_ray_make x (mapcar '+ x '(0. 0. 1.))) 
                       ) 
                      pts 
                    ) 
            Ppts    (xdrx_curve_getinters (XD::Entity->Pickset Rays) Pss) 
      ) 
      (mapcar 'xdrx_entity_delete rays) 
      (mapcar 'xdrx_entity_delete Lcurves) 
      (setq Ppts    (mapcar 
                      '(lambda (x) 
                         (list (car x) (cadr x) (- (caddr x) BaseH)) 
                       ) 
                      Ppts 
                    ) 
            PtsOnPl (mapcar '(lambda (x / l) 
                               (setq l          (vl-remove-if-not 
                                            '(lambda (p) 
                                               (xdrx_point_ison 
                                                 (cutz p) 
                                                 x 
                                               ) 
                                             ) 
                                            Ppts 
                                          ) 
                                     Ppts (vl-remove-if 
                                            '(lambda (p) 
                                               (xdrx_point_ison 
                                                 (cutz p) 
                                                 x 
                                               ) 
                                             ) 
                                            Ppts 
                                          ) 
                               ) 
                               (cons x l) 
                             ) 
                            Pents 
                    ) 
            PtsOnPl (mapcar '(lambda (x / e pts) 
                               (setq e         (car x) 
                                     pts (vl-sort 
                                           (cdr x) 
                                           '(lambda (p1 p2) 
                                              (< (xdrx_curve_getparamatpoint 
                                                   e 
                                                   (cutz p1) 
                                                 ) 
                                                 (xdrx_curve_getparamatpoint 
                                                   e 
                                                   (cutz p2) 
                                                 ) 
                                              ) 
                                            ) 
                                         ) 
                               ) 
                               (cons e pts) 
                             ) 
                            PtsOnPl 
                    ) 
            PtsOnpl (mapcar 
                      '(lambda (x / pts e bp disL) 
                         (setq e    (car x) 
                               pts  (cdr x) 
                               bp   (cutz (car pts)) 
                               disL (mapcar '(lambda (a) 
                                               (list (distance 
                                                       (cutz a) 
                                                       bp 
                                                     ) 
                                                     (caddr a) 
                                               ) 
                                             ) 
                                            (cdr pts) 
                                    ) 
                         ) 
                         (cons e (cons (list '0. (last (cadr x))) disL)) 
                       ) 
                      PtsOnpl 
                    ) 
      ) 
      (setq an (- (/ pi 3.)) 
            bh (rtos BaseH 2 0) 
      ) 
      ;;Draw 
      (mapcar '(lambda (x / pp pp1 p1 txt) 
                 (setq pp  (mapcar '(lambda (a) (mapcar '+ p a)) x) 
                       pp1 (mapcar '(lambda (b) 
                                      (mapcar '+ p (list (car b) 0.)) 
                                    ) 
                                   x 
                           ) 
                       p   (mapcar '+ p '(100. 0. 0.)) 
                 ) 
                 (apply 'xdrx_polyline_make pp) 
                 (mapcar '(lambda (a) 
                            (xdrx_Donut_make 
                              (list (car a) (cadr a) 0.) ;_需要 3D 点 
                              0. 
                              0.5 
                            ) 
                          ) 
                         pp1 
                 ) 
                 (mapcar '(lambda (c d) (xdrx_line_make c d)) pp pp1) 
                 (xdrx_line_make 
                   (polar (car pp1) pi 20.) 
                   (setq p1 (polar (last pp1) 0. 20.)) 
                 ) 
                 (setq txt (xdrx_text_make 
                             (list (car p1) (cadr p1) 0.) ;_需要 3D 点 
                             bh 
                             2.5 
                             0. 
                           ) 
                 ) 
                 (xdrx_text_setvermode txt 2) 
                 (mapcar '(lambda (e f / txt) 
                            (setq txt (xdrx_text_make 
                                        (list (car e) (cadr e) 0.) ;_需要 3D 点 
                                        (rtos (cadr f) 2 3) 
                                        2.0 
                                        an 
                                      ) 
                            ) 
                            (xdrx_text_setvermode txt 3) 
                          ) 
                         pp1 
                         x 
                 ) 
               ) 
              (mapcar 'cdr PtsOnpl) 
      ) 
     ;; (XD::End) 
    ) 
  )   
  ;;(princ PtsOnPl) 
  (princ) 
)

fdg30001 · 发表于 2013-11-13 18:24:34

本帖最后由 fdg30001 于 2013-11-13 18:31 编辑

st788796 发表于 2013-11-13 07:57
正好测试几个make函数，完整程序如下，没有写*error*处理，运行中如果中断可能会产生垃圾！

不好意思st788796，谢谢你的热情帮忙，dnbcgrass帮我写了，很完美的一个程序，超过我的预期，也谢谢dnbcgrass。

另外我测试了你写的代码，没用，辛苦了。

st788796 · 发表于 2013-11-13 19:17:56

fdg30001 发表于 2013-11-13 18:24
不好意思st788796，谢谢你的热情帮忙，dnbcgrass帮我写了，很完美的一个程序，超过我的预期，也谢谢dnbcg ...

有用的就好欢迎常来！

fdg30001 · 发表于 2013-11-13 20:31:55

XDCAD论坛很好，让我学习了很多知识，只要有时间就上来看看。

看了你的程序效果也很好，谢谢

fdg30001 · 发表于 2013-11-13 20:34:22

st788796 发表于 2013-11-13 19:17
有用的就好欢迎常来！

XDCAD论坛很好，让我学习了很多知识，只要有时间就上来看看。
看了你的程序效果也很好，谢谢

XDSoft · 发表于 2013-11-13 20:47:28

fdg30001 发表于 2013-11-13 20:34
XDCAD论坛很好，让我学习了很多知识，只要有时间就上来看看。
看了你的程序效果也很好，谢谢

那你可以把那个朋友给你做的效果，运行下，做个动画贴上来，让大家看看吧。

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

[已解决] 1000人民币求一个切剖面程序，具体要求看附件

点评

点评

点评

点评

点评

点评

点评

点评

点评