无聊ing，trans函数的小应用（点在ucs上的位置）

x_s_s_1

无聊ing，trans函数的小应用（点在ucs上的位置），有时候有点用，抛砖引玉，看大家有什么更好的方法

1. ;;;=============================================
   
2. ;;;      通用函数  点在ucs上的位置
   
3. ;;;参数： pt------测试点
   
4. ;;;       p0------ucs原点
   
5. ;;;       px------ucsx向点
   
6. ;;;       fuzz----容差
   
7. ;;;返回值：点位特征值
   
8. (defun xty-G-PtAtUcs (pt p0 px fuzz / o v x x+ x- y y+ y- z z+ z-)
   
9.   (setq  v  (mapcar '- px p0)
   
10.   v  (trans (mapcar '- pt p0) 0 v)
    
11.   x  (last v)
    
12.   y  (car v)
    
13.   z  (cadr v)
    
14.   o  0
    
15.   x+ 1
    
16.   x- 2
    
17.   y+ 4
    
18.   y- 8
    
19.   z+ 16
    
20.   z- 32
    
21.   )
    
22.   (cond  ((equal pt p0 fuzz) o) ;_位于原点
    
23.   ((and (equal y 0. fuzz) (equal z 0. fuzz) (> x fuzz)) x+) ;_位于正x轴
    
24.   ((and (equal y 0. fuzz) (equal z 0. fuzz) (< x (- fuzz)))
    
25.    x-
    
26.   ) ;_位于负x轴
    
27.   ((and (equal x 0. fuzz) (equal z 0. fuzz) (> y fuzz)) y+) ;_位于正y轴
    
28.   ((and (equal x 0. fuzz) (equal z 0. fuzz) (< y (- fuzz)))
    
29.    y-
    
30.   ) ;_位于负y轴
    
31.   ((and (equal x 0. fuzz) (equal y 0. fuzz) (> z fuzz)) z+) ;_位于正z轴
    
32.   ((and (equal x 0. fuzz) (equal y 0. fuzz) (< z (- fuzz)))
    
33.    z-
    
34.   ) ;_位于负z轴
    
35.   ((and (equal z 0. fuzz) (> x fuzz) (> y fuzz)) (+ x+ y+)) ;_位于xy平面第一象限
    
36.   ((and (equal z 0. fuzz) (< x (- fuzz)) (> y fuzz))
    
37.    (+ y+ x-)
    
38.   ) ;_位于xy平面第二象限
    
39.   ((and (equal z 0. fuzz) (< x (- fuzz)) (< y (- fuzz)))
    
40.    (+ x- y-)
    
41.   ) ;_位于xy平面第三象限
    
42.   ((and (equal z 0. fuzz) (> x fuzz) (< y (- fuzz)))
    
43.    (+ y- x+)
    
44.   ) ;_位于xy平面第四象限
    
45.   ((and (equal y 0. fuzz) (> x fuzz) (> z fuzz)) (+ x+ z+)) ;_位于xz平面第一象限
    
46.   ((and (equal y 0. fuzz) (< x (- fuzz)) (> z fuzz))
    
47.    (+ z+ x-)
    
48.   ) ;_位于xz平面第二象限
    
49.   ((and (equal y 0. fuzz) (< x (- fuzz)) (< z (- fuzz)))
    
50.    (+ x- z-)
    
51.   ) ;_位于xz平面第三象限
    
52.   ((and (equal y 0. fuzz) (> x fuzz) (< z (- fuzz)))
    
53.    (+ z- x+)
    
54.   ) ;_位于xz平面第四象限
    
55.   ((and (equal x 0. fuzz) (> y fuzz) (> z fuzz)) (+ y+ z+)) ;_位于yz平面第一象限
    
56.   ((and (equal x 0. fuzz) (< y (- fuzz)) (> z fuzz))
    
57.    (+ z+ y-)
    
58.   ) ;_位于yz平面第二象限
    
59.   ((and (equal x 0. fuzz) (< y (- fuzz)) (< z (- fuzz)))
    
60.    (+ y- z-)
    
61.   ) ;_位于yz平面第三象限
    
62.   ((and (equal x 0. fuzz) (> y fuzz) (< z (- fuzz)))
    
63.    (+ z- y+)
    
64.   ) ;_位于yz平面第四象限
    
65.   ((and (> x fuzz) (> y fuzz) (> z fuzz)) (+ x+ y+ z+)) ;_位于第Ⅰ象限
    
66.   ((and (< x (- fuzz)) (> y fuzz) (> z fuzz)) (+ x- y+ z+)) ;_位于第Ⅱ象限
    
67.   ((and (< x (- fuzz)) (< y (- fuzz)) (> z fuzz))
    
68.    (+ x- y- z+)
    
69.   ) ;_位于第Ⅲ象限
    
70.   ((and (> x fuzz) (< y (- fuzz)) (> z fuzz)) (+ x+ y- z+)) ;_位于第Ⅳ象限
    
71.   ((and (> x fuzz) (> y fuzz) (< z (- fuzz))) (+ x+ y+ z-)) ;_位于第Ⅴ象限
    
72.   ((and (< x (- fuzz)) (> y fuzz)(< z (- fuzz))) (+ x- y+ z-)) ;_位于第Ⅵ象限
    
73.   ((and (< x (- fuzz)) (< y (- fuzz))(< z (- fuzz)))
    
74.    (+ x- y- z-)
    
75.   ) ;_位于第Ⅶ象限
    
76.   ((and (> x fuzz) (< y (- fuzz)) (< z (- fuzz))) (+ x+ y- z-)) ;_位于第Ⅷ象限
    
77.   )
    
78. )

;;;=============================================<br /> ;;;      通用函数  点在ucs上的位置<br /> ;;;参数： pt------测试点<br /> ;;;       p0------ucs原点<br /> ;;;       px------ucsx向点<br /> ;;;       fuzz----容差<br /> ;;;返回值：点位特征值<br /> (defun xty-G-PtAtUcs (pt p0 px fuzz / o v x x+ x- y y+ y- z z+ z-)<br />   (setq  v  (mapcar '- px p0)<br />   v  (trans (mapcar '- pt p0) 0 v)<br />   x  (last v)<br />   y  (car v)<br />   z  (cadr v)<br />   o  0<br />   x+ 1<br />   x- 2<br />   y+ 4<br />   y- 8<br />   z+ 16<br />   z- 32<br />   )<br />   (cond  ((equal pt p0 fuzz) o) ;_位于原点<br />   ((and (equal y 0. fuzz) (equal z 0. fuzz) (> x fuzz)) x+) ;_位于正x轴<br />   ((and (equal y 0. fuzz) (equal z 0. fuzz) (< x (- fuzz)))<br />    x-<br />   ) ;_位于负x轴<br />   ((and (equal x 0. fuzz) (equal z 0. fuzz) (> y fuzz)) y+) ;_位于正y轴<br />   ((and (equal x 0. fuzz) (equal z 0. fuzz) (< y (- fuzz)))<br />    y-<br />   ) ;_位于负y轴<br />   ((and (equal x 0. fuzz) (equal y 0. fuzz) (> z fuzz)) z+) ;_位于正z轴<br />   ((and (equal x 0. fuzz) (equal y 0. fuzz) (< z (- fuzz)))<br />    z-<br />   ) ;_位于负z轴<br />   ((and (equal z 0. fuzz) (> x fuzz) (> y fuzz)) (+ x+ y+)) ;_位于xy平面第一象限<br />   ((and (equal z 0. fuzz) (< x (- fuzz)) (> y fuzz))<br />    (+ y+ x-)<br />   ) ;_位于xy平面第二象限<br />   ((and (equal z 0. fuzz) (< x (- fuzz)) (< y (- fuzz)))<br />    (+ x- y-)<br />   ) ;_位于xy平面第三象限<br />   ((and (equal z 0. fuzz) (> x fuzz) (< y (- fuzz)))<br />    (+ y- x+)<br />   ) ;_位于xy平面第四象限<br />   ((and (equal y 0. fuzz) (> x fuzz) (> z fuzz)) (+ x+ z+)) ;_位于xz平面第一象限<br />   ((and (equal y 0. fuzz) (< x (- fuzz)) (> z fuzz))<br />    (+ z+ x-)<br />   ) ;_位于xz平面第二象限<br />   ((and (equal y 0. fuzz) (< x (- fuzz)) (< z (- fuzz)))<br />    (+ x- z-)<br />   ) ;_位于xz平面第三象限<br />   ((and (equal y 0. fuzz) (> x fuzz) (< z (- fuzz)))<br />    (+ z- x+)<br />   ) ;_位于xz平面第四象限<br />   ((and (equal x 0. fuzz) (> y fuzz) (> z fuzz)) (+ y+ z+)) ;_位于yz平面第一象限<br />   ((and (equal x 0. fuzz) (< y (- fuzz)) (> z fuzz))<br />    (+ z+ y-)<br />   ) ;_位于yz平面第二象限<br />   ((and (equal x 0. fuzz) (< y (- fuzz)) (< z (- fuzz)))<br />    (+ y- z-)<br />   ) ;_位于yz平面第三象限<br />   ((and (equal x 0. fuzz) (> y fuzz) (< z (- fuzz)))<br />    (+ z- y+)<br />   ) ;_位于yz平面第四象限<br />   ((and (> x fuzz) (> y fuzz) (> z fuzz)) (+ x+ y+ z+)) ;_位于第Ⅰ象限<br />   ((and (< x (- fuzz)) (> y fuzz) (> z fuzz)) (+ x- y+ z+)) ;_位于第Ⅱ象限<br />   ((and (< x (- fuzz)) (< y (- fuzz)) (> z fuzz))<br />    (+ x- y- z+)<br />   ) ;_位于第Ⅲ象限<br />   ((and (> x fuzz) (< y (- fuzz)) (> z fuzz)) (+ x+ y- z+)) ;_位于第Ⅳ象限<br />   ((and (> x fuzz) (> y fuzz) (< z (- fuzz))) (+ x+ y+ z-)) ;_位于第Ⅴ象限<br />   ((and (< x (- fuzz)) (> y fuzz)(< z (- fuzz))) (+ x- y+ z-)) ;_位于第Ⅵ象限<br />   ((and (< x (- fuzz)) (< y (- fuzz))(< z (- fuzz)))<br />    (+ x- y- z-)<br />   ) ;_位于第Ⅶ象限<br />   ((and (> x fuzz) (< y (- fuzz)) (< z (- fuzz))) (+ x+ y- z-)) ;_位于第Ⅷ象限<br />   )<br /> )

1. (setq
   
2.   lst (mapcar '(lambda (x) (xty-G-PtAtUcs x '(0 0 0) '(1 0 0) 1e-6))
   
3.         (list '(0 0 0)   '(1 0 0)     '(-1 0 0)     '(0 1 0)
   
4.         '(0 -1 0)   '(0 0 1)     '(0 0 -1)     '(1 1 0)
   
5.         '(-1 1 0)   '(-1 -1 0)   '(1 -1 0)     '(1 0 1)
   
6.         '(-1 0 1)   '(-1 0 -1)   '(1 0 -1)     '(0 1 1)
   
7.         '(0 -1 1)   '(0 -1 -1)   '(0 1 -1)     '(1 1 1)
   
8.         '(-1 1 1)   '(-1 -1 1)   '(1 -1 1)     '(1 1 -1)
   
9.         '(-1 1 -1)   '(-1 -1 -1)  '(1 -1 -1)
   
10.        )
    
11.       )
    
12. )
    
13. =>(0 1 2 4 8 16 32 5 6 10 9 17 18 34 33 20 24 40 36 21 22 26 25 37 38 42 41)

(setq<br />   lst (mapcar '(lambda (x) (xty-G-PtAtUcs x '(0 0 0) '(1 0 0) 1e-6))<br />         (list '(0 0 0)   '(1 0 0)     '(-1 0 0)     '(0 1 0)<br />         '(0 -1 0)   '(0 0 1)     '(0 0 -1)     '(1 1 0)<br />         '(-1 1 0)   '(-1 -1 0)   '(1 -1 0)     '(1 0 1)<br />         '(-1 0 1)   '(-1 0 -1)   '(1 0 -1)     '(0 1 1)<br />         '(0 -1 1)   '(0 -1 -1)   '(0 1 -1)     '(1 1 1)<br />         '(-1 1 1)   '(-1 -1 1)   '(1 -1 1)     '(1 1 -1)<br />         '(-1 1 -1)   '(-1 -1 -1)  '(1 -1 -1)<br />        )<br />       )<br /> )<br /> =>(0 1 2 4 8 16 32 5 6 10 9 17 18 34 33 20 24 40 36 21 22 26 25 37 38 42 41)

测试代码

1. (defun c:tt (/ en ent gr loop obj pt pt1 pt2)
   
2.   (setq  en   (car (entsel "\n拾取一条直线:"))
   
3.   ent  (entget en)
   
4.   pt1  (cdr (assoc 10 ent))
   
5.   pt2  (cdr (assoc 11 ent))
   
6.   obj  nil
   
7.   loop t
   
8.   )
   
9.   (while loop
   
10.     (setq gr (grread t 15 0)
    
11.     pt (cadr gr)
    
12.     gr (car gr)
    
13.     )
    
14.     (cond ((= 5 gr)
    
15.      (if obj
    
16.        (vla-delete obj)
    
17.      )
    
18.      (command "sphere" pt 100)
    
19.      (setq obj(vlax-ename->vla-object (entlast)))
    
20.      (vla-put-color obj(xty-G-PtAtUcs pt pt1 pt2 1e-8))
    
21.     )
    
22.     ((= 3 gr) (setq loop nil))
    
23.     )
    
24.   )
    
25. )

(defun c:tt (/ en ent gr loop obj pt pt1 pt2)<br />   (setq  en   (car (entsel "\n拾取一条直线:"))<br />   ent  (entget en)<br />   pt1  (cdr (assoc 10 ent))<br />   pt2  (cdr (assoc 11 ent))<br />   obj  nil<br />   loop t<br />   )<br />   (while loop<br />     (setq gr (grread t 15 0)<br />     pt (cadr gr)<br />     gr (car gr)<br />     )<br />     (cond ((= 5 gr)<br />      (if obj<br />        (vla-delete obj)<br />      )<br />      (command "sphere" pt 100)<br />      (setq obj(vlax-ename->vla-object (entlast)))<br />      (vla-put-color obj(xty-G-PtAtUcs pt pt1 pt2 1e-8))<br />     )<br />     ((= 3 gr) (setq loop nil))<br />     )<br />   )<br /> )

x_s_s_1

再举个栗子:D，判断象限有时候还是有用的

1. (defun c:tt ()
   
2.   (setq  pt0 (getpoint "\n拾取原点:")
   
3.   pt1 (getpoint "\n拾取x方向点:")
   
4.   )
   
5.   (while (setq pt2 (getpoint "\n拾取点:"))
   
6.     (setq mode (xty-G-PtAtUcs pt2 pt0 pt1 1e-8))
   
7.     (setq en (entmakex (list '(0 . "text")
   
8.            '(100 . "AcDbEntity")
   
9.            '(100 . "AcDbText")
   
10.            (cons 10 pt2)
    
11.            (cons 1 (itoa mode))
    
12.            (cons 40 100)
    
13.            (cons 41 0.8)
    
14.            (cons 7 "standard")
    
15.            (cons 72 0)
    
16.            (cons 11 pt2)
    
17.            (cons 50 0)
    
18.            (cons 73 0)
    
19.            (cons 62 mode)
    
20.            )
    
21.        )
    
22.     )
    
23.   )
    
24. )
    

(defun c:tt ()<br />   (setq  pt0 (getpoint "\n拾取原点:")<br />   pt1 (getpoint "\n拾取x方向点:")<br />   )<br />   (while (setq pt2 (getpoint "\n拾取点:"))<br />     (setq mode (xty-G-PtAtUcs pt2 pt0 pt1 1e-8))<br />     (setq en (entmakex (list '(0 . "text")<br />            '(100 . "AcDbEntity")<br />            '(100 . "AcDbText")<br />            (cons 10 pt2)<br />            (cons 1 (itoa mode))<br />            (cons 40 100)<br />            (cons 41 0.8)<br />            (cons 7 "standard")<br />            (cons 72 0)<br />            (cons 11 pt2)<br />            (cons 50 0)<br />            (cons 73 0)<br />            (cons 62 mode)<br />            )<br />        )<br />     )<br />   )<br /> )<br />

tigcat

支持下，希望多发代码给我们学习。

xj6019

大佬威武！！！！

mokson

向优秀者致敬和学习！