精确快速求spline线的最小点及最大点

风树

不知道lisp里有没有求极值点的函数

lgx9612

自贡黄明儒 发表于 2014-7-16 20:41
你用了whi|e，是不是逼近法。G版写的那个更简洁

     while是计算的密度,也算是是逼近法.昨天在网上逛逛,得知兄弟是个大师,失敬!在此之前我一直都找关于spline曲线的最小包容盒子的计算但没有找到,不知G版写的那个更简洁的程序在哪,想学习学习(可否贴上代码?).我知道标准计算(vla-getboundingbox)对spline曲线和图块并不好.所以绞尽脑汁,出此下策,写出如此代码,多多指教.

xyp1964

Gu_xl

1. ;;(gxl-GetCurveBox curve) 精确取得曲线实体外矩形框对角点
   
2. ;;2014.07.18 修正1阶SPLINE的错误
   
3. (defun gxl-GetCurveBox (curve / obj p1 p2 p3 p4 lst pts)
   
4.   (if (= 'ename (type curve))
   
5.     (setq obj (vlax-ename->vla-object curve))
   
6.     (setq obj curve)
   
7.   )
   
8.   (if (and (= "AcDbSpline" (vla-get-objectname obj))
   
9.            (< (vla-get-Degree obj) 2)
   
10.       )
    
11.     (progn
    
12.       (setq pl (vlax-safearray->list
    
13.                  (vlax-variant-value (vla-get-ControlPoints obj))
    
14.                )
    
15.       )
    
16.       (while pl
    
17.         (setq pts (cons (list (car pl) (cadr pl) (caddr pl)) pts)
    
18.               pl  (cdddr pl)
    
19.         )
    
20.       )
    
21.       (setq p1 (apply 'mapcar (cons 'min pts))
    
22.             p3 (apply 'mapcar (cons 'max pts))
    
23.             p2 (list (car p1) (cadr p3) (caddr p1))
    
24.             p4 (list (car p3) (cadr p1) (caddr p1))
    
25.       )
    
26.     )
    
27.     (progn
    
28.       (vla-GetBoundingBox obj 'p1 'p3)
    
29.       (setq p1 (vlax-safearray->list p1)
    
30.             p3 (vlax-safearray->list p3)
    
31.             p2 (list (car p1) (cadr p3) (caddr p1))
    
32.             p4 (list (car p3) (cadr p1) (caddr p1))
    
33.       )
    
34.     )
    
35.   )
    
36.   (SETQ        lst
    
37.          (mapcar '(lambda (a b)
    
38.                     (vlax-curve-getClosestPointToProjection curve a b t)
    
39.                   )
    
40.                  (list p1 p2 p3 p4)
    
41.                  '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
    
42.          )
    
43.   )
    
44.   (list
    
45.     (apply 'mapcar (cons 'min lst))
    
46.     (apply 'mapcar (cons 'max lst))
    
47.   )
    
48. )
    

;;(gxl-GetCurveBox curve) 精确取得曲线实体外矩形框对角点<br /> ;;2014.07.18 修正1阶SPLINE的错误<br /> (defun gxl-GetCurveBox (curve / obj p1 p2 p3 p4 lst pts)<br />   (if (= 'ename (type curve))<br />     (setq obj (vlax-ename->vla-object curve))<br />     (setq obj curve)<br />   )<br />   (if (and (= "AcDbSpline" (vla-get-objectname obj))<br />            (< (vla-get-Degree obj) 2)<br />       )<br />     (progn<br />       (setq pl (vlax-safearray->list<br />                  (vlax-variant-value (vla-get-ControlPoints obj))<br />                )<br />       )<br />       (while pl<br />         (setq pts (cons (list (car pl) (cadr pl) (caddr pl)) pts)<br />               pl  (cdddr pl)<br />         )<br />       )<br />       (setq p1 (apply 'mapcar (cons 'min pts))<br />             p3 (apply 'mapcar (cons 'max pts))<br />             p2 (list (car p1) (cadr p3) (caddr p1))<br />             p4 (list (car p3) (cadr p1) (caddr p1))<br />       )<br />     )<br />     (progn<br />       (vla-GetBoundingBox obj 'p1 'p3)<br />       (setq p1 (vlax-safearray->list p1)<br />             p3 (vlax-safearray->list p3)<br />             p2 (list (car p1) (cadr p3) (caddr p1))<br />             p4 (list (car p3) (cadr p1) (caddr p1))<br />       )<br />     )<br />   )<br />   (SETQ        lst<br />          (mapcar '(lambda (a b)<br />                     (vlax-curve-getClosestPointToProjection curve a b t)<br />                   )<br />                  (list p1 p2 p3 p4)<br />                  '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))<br />          )<br />   )<br />   (list<br />     (apply 'mapcar (cons 'min lst))<br />     (apply 'mapcar (cons 'max lst))<br />   )<br /> )<br />

lgx9612

Gu_xl 发表于 2014-7-17 14:18

   Gu_xl兄弟,非常感谢你的代码,很多高级的函数我都不会,你的程序确实很值得我学习,但spline的情况很多,只要vla-getboundingbox得出的最小及最大没有包住曲线就不能得出最正确的结果.之前我做按区域自动生成块的程序时就这个困扰我很久,spline放大或缩小都会有不同的结果,可能是我的cad版本问题,附上我试验代码gif和cad图档.
      本着学习的态度向你请教,试验代码并不是次次正确,我是不是哪里错了?

Gu_xl

lgx9612 发表于 2014-7-17 19:51
Gu_xl兄弟,非常感谢你的代码,很多高级的函数我都不会,你的程序确实很值得我学习,但spline ...

你是要考我眼力吗？太花，看不明白你的意思！

lgx9612

Gu_xl 发表于 2014-7-17 20:10
你是要考我眼力吗？太花，看不明白你的意思！

在这个图中不能得出正确包容盒子我只是在你的代码中加了一句
  (command "rectang" (apply 'mapcar (cons 'min lst)) (apply 'mapcar (cons 'max lst)))


(gxl-GetCurveBox (car (entsel)))执行

2. (defun gxl-GetCurveBox (curve / obj p1 p2 p3 p4 lst)
   
3.   (if (= 'ename (type curve))
   
4.     (setq obj (vlax-ename->vla-object curve))
   
5.     (setq obj curve)
   
6.   )
   
7.   (vla-GetBoundingBox obj 'p1 'p3)
   
8.   (setq        p1 (vlax-safearray->list p1)
   
9.         p3 (vlax-safearray->list p3)
   
10.         p2 (list (car p1) (cadr p3) (caddr p1))
    
11.         p4 (list (car p3) (cadr p1) (caddr p1))
    
12.   )
    
13.   (SETQ        lst
    
14.          (mapcar '(lambda (a b)
    
15.                     (vlax-curve-getClosestPointToProjection curve a b t))
    
16.                  (list p1 p2 p3 p4)
    
17.                  '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
    
18.                  )
    
19.         )
    
20.   (list
    
21.     (apply 'mapcar (cons 'min lst))
    
22.     (apply 'mapcar (cons 'max lst))
    
23.   )
    
24.   (command "rectang" (apply 'mapcar (cons 'min lst)) (apply 'mapcar (cons 'max lst)))
    
25. )

(defun gxl-GetCurveBox (curve / obj p1 p2 p3 p4 lst)<br />   (if (= 'ename (type curve))<br />     (setq obj (vlax-ename->vla-object curve))<br />     (setq obj curve)<br />   )<br />   (vla-GetBoundingBox obj 'p1 'p3)<br />   (setq        p1 (vlax-safearray->list p1)<br />         p3 (vlax-safearray->list p3)<br />         p2 (list (car p1) (cadr p3) (caddr p1))<br />         p4 (list (car p3) (cadr p1) (caddr p1))<br />   )<br />   (SETQ        lst<br />          (mapcar '(lambda (a b)<br />                     (vlax-curve-getClosestPointToProjection curve a b t))<br />                  (list p1 p2 p3 p4)<br />                  '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))<br />                  )<br />         )<br />   (list<br />     (apply 'mapcar (cons 'min lst))<br />     (apply 'mapcar (cons 'max lst))<br />   )<br />   (command "rectang" (apply 'mapcar (cons 'min lst)) (apply 'mapcar (cons 'max lst)))<br /> )

风树

cad那个函数有一定的误差，如果向外偏移个百分之五左右不知道能不能在这种情况下补救一下

lgx9612

风树 发表于 2014-7-17 21:29
cad那个函数有一定的误差，如果向外偏移个百分之五左右不知道能不能在这种情况下补救一下

这个函数对spline线和图块毫无能力

菡萏

lgx9612 发表于 2014-7-17 20:32
在这个图中不能得出正确包容盒子我只是在你的代码中加了一句
  (command "rectang" (apply 'mapcar (con ...

G版挺高级的一个函数，运行正确无误，被你加了一句command代码给糟蹋了！