使用点监视器，动态绘制内存实体，拖动生成鱼骨线

newer

1. (defun c:tt ()
   
2.   (defun _callback (dynpt)
   
3.     (redraw)
   
4.     (xdrx-setpropertyvalue
   
5.       spl
   
6.       "setfitpoints"
   
7.       (reverse (cons dynpt lst))
   
8.       ;;设置拟合点
   
9.     )
   
10.     (setq pts (xdrx-getpropertyvalue spl "getpointsatdist" 500.0))
    
11.     (mapcar '(lambda (x)
    
12.                (setq v          (xdrx-getpropertyvalue spl "firstderiv" x)
    
13.                      v1          (xdrx-vector-perpvector v)
    
14.                      p1          (mapcar '+ x (xdrx-vector-product v1 500.0))
    
15.                      p2          (mapcar '- x (xdrx-vector-product v1 500.0))
    
16.                      pts1 (cons (list p1 p2) pts1)
    
17.                )
    
18.                (xdrx-grdraw 7 -1 p1 p2)
    
19.              )
    
20.             (cdr pts)
    
21.     )
    
22.     (setq tf t)
    
23.     (xdrx-grdraw 1 -1 spl)
    
24.     ;;显示内存实体
    
25.   )
    
26.   (if (and (setq p1 (getpoint "\n起点<退出>:"))
    
27.            (setq p2 (getpoint p1 "\n下一点<退出>:"))
    
28.       )
    
29.     (progn (xdrx-pointmonitor "_callback")
    
30.            (setq lst (list p2 p1))
    
31.            (setq spl (xdrx-spline-make))
    
32.            ;;创建内存DB实体
    
33.            (while (setq p3 (getpoint (car lst) "\n下一点<退出>:"))
    
34.              (setq lst (cons p3 lst))
    
35.              (setq nums (xdrx-getpropertyvalue spl "numfitpoints"))
    
36.              (setq tf nil)
    
37.            )
    
38.            (xdrx-pointmonitor)
    
39.            (if (> (xdrx-getpropertyvalue spl "numfitpoints") nums)
    
40.              (xdrx-setpropertyvalue spl "removefitpointat" (length lst))
    
41.            )
    
42.            ;;移除最后鼠标确认前最后一个拟合点
    
43.            (setq pts (xdrx-getpropertyvalue spl "getpointsatdist" 500.0))
    
44.            (mapcar '(lambda (x)
    
45.                       (setq v         (xdrx-getpropertyvalue spl "firstderiv" x)
    
46.                             v1         (xdrx-vector-perpvector v)
    
47.                             p1         (mapcar '+ x (xdrx-vector-product v1 500.0))
    
48.                             p2         (mapcar '- x (xdrx-vector-product v1 500.0))
    
49.                             pts1 (cons (list p1 p2) pts1)
    
50.                       )
    
51.                       (xdrx-line-make p1 p2)
    
52.                     )
    
53.                    (cdr pts)
    
54.            )
    
55.            (redraw)
    
56.            (xdrx-entity-make spl)
    
57. 
    
58.            ;;从内存实体创建到数据库
    
59.     )
    
60.   )
    
61.   (princ)
    
62. )
    
63. 
    

(defun c:tt ()<br />   (defun _callback (dynpt)<br />     (redraw)<br />     (xdrx-setpropertyvalue<br />       spl<br />       "setfitpoints"<br />       (reverse (cons dynpt lst))<br />       ;;设置拟合点<br />     )<br />     (setq pts (xdrx-getpropertyvalue spl "getpointsatdist" 500.0))<br />     (mapcar '(lambda (x)<br />                (setq v          (xdrx-getpropertyvalue spl "firstderiv" x)<br />                      v1          (xdrx-vector-perpvector v)<br />                      p1          (mapcar '+ x (xdrx-vector-product v1 500.0))<br />                      p2          (mapcar '- x (xdrx-vector-product v1 500.0))<br />                      pts1 (cons (list p1 p2) pts1)<br />                )<br />                (xdrx-grdraw 7 -1 p1 p2)<br />              )<br />             (cdr pts)<br />     )<br />     (setq tf t)<br />     (xdrx-grdraw 1 -1 spl)<br />     ;;显示内存实体<br />   )<br />   (if (and (setq p1 (getpoint "\n起点<退出>:"))<br />            (setq p2 (getpoint p1 "\n下一点<退出>:"))<br />       )<br />     (progn (xdrx-pointmonitor "_callback")<br />            (setq lst (list p2 p1))<br />            (setq spl (xdrx-spline-make))<br />            ;;创建内存DB实体<br />            (while (setq p3 (getpoint (car lst) "\n下一点<退出>:"))<br />              (setq lst (cons p3 lst))<br />              (setq nums (xdrx-getpropertyvalue spl "numfitpoints"))<br />              (setq tf nil)<br />            )<br />            (xdrx-pointmonitor)<br />            (if (> (xdrx-getpropertyvalue spl "numfitpoints") nums)<br />              (xdrx-setpropertyvalue spl "removefitpointat" (length lst))<br />            )<br />            ;;移除最后鼠标确认前最后一个拟合点<br />            (setq pts (xdrx-getpropertyvalue spl "getpointsatdist" 500.0))<br />            (mapcar '(lambda (x)<br />                       (setq v         (xdrx-getpropertyvalue spl "firstderiv" x)<br />                             v1         (xdrx-vector-perpvector v)<br />                             p1         (mapcar '+ x (xdrx-vector-product v1 500.0))<br />                             p2         (mapcar '- x (xdrx-vector-product v1 500.0))<br />                             pts1 (cons (list p1 p2) pts1)<br />                       )<br />                       (xdrx-line-make p1 p2)<br />                     )<br />                    (cdr pts)<br />            )<br />            (redraw)<br />            (xdrx-entity-make spl)<br /> <br />            ;;从内存实体创建到数据库<br />     )<br />   )<br />   (princ)<br /> )<br /> <br />

1917732332

谢谢分享

tzfcn

感觉这个代码用于放置铁轨枕木很有用处

xk15c

真好用，放点用真不错

既然青春留不住