无聊ing，trans函数的小应用（点在ucs上的位置）
本帖最后由 x_s_s_1 于 2022-9-17 20:04 编辑无聊ing，trans函数的小应用（点在ucs上的位置），有时候有点用，抛砖引玉，看大家有什么更好的方法{:1_1:}
;;;=============================================
;;; 通用函数点在ucs上的位置
;;;参数： pt------测试点
;;; p0------ucs原点
;;; px------ucsx向点
;;; fuzz----容差
;;;返回值：点位特征值
(defun xty-G-PtAtUcs (pt p0 px fuzz / o v x x+ x- y y+ y- z z+ z-)
(setqv(mapcar '- px p0)
v(trans (mapcar '- pt p0) 0 v)
x(last v)
y(car v)
z(cadr v)
o0
x+ 1
x- 2
y+ 4
y- 8
z+ 16
z- 32
)
(cond((equal pt p0 fuzz) o) ;_位于原点
((and (equal y 0. fuzz) (equal z 0. fuzz) (> x fuzz)) x+) ;_位于正x轴
((and (equal y 0. fuzz) (equal z 0. fuzz) (< x (- fuzz)))
x-
) ;_位于负x轴
((and (equal x 0. fuzz) (equal z 0. fuzz) (> y fuzz)) y+) ;_位于正y轴
((and (equal x 0. fuzz) (equal z 0. fuzz) (< y (- fuzz)))
y-
) ;_位于负y轴
((and (equal x 0. fuzz) (equal y 0. fuzz) (> z fuzz)) z+) ;_位于正z轴
((and (equal x 0. fuzz) (equal y 0. fuzz) (< z (- fuzz)))
z-
) ;_位于负z轴
((and (equal z 0. fuzz) (> x fuzz) (> y fuzz)) (+ x+ y+)) ;_位于xy平面第一象限
((and (equal z 0. fuzz) (< x (- fuzz)) (> y fuzz))
(+ y+ x-)
) ;_位于xy平面第二象限
((and (equal z 0. fuzz) (< x (- fuzz)) (< y (- fuzz)))
(+ x- y-)
) ;_位于xy平面第三象限
((and (equal z 0. fuzz) (> x fuzz) (< y (- fuzz)))
(+ y- x+)
) ;_位于xy平面第四象限
((and (equal y 0. fuzz) (> x fuzz) (> z fuzz)) (+ x+ z+)) ;_位于xz平面第一象限
((and (equal y 0. fuzz) (< x (- fuzz)) (> z fuzz))
(+ z+ x-)
) ;_位于xz平面第二象限
((and (equal y 0. fuzz) (< x (- fuzz)) (< z (- fuzz)))
(+ x- z-)
) ;_位于xz平面第三象限
((and (equal y 0. fuzz) (> x fuzz) (< z (- fuzz)))
(+ z- x+)
) ;_位于xz平面第四象限
((and (equal x 0. fuzz) (> y fuzz) (> z fuzz)) (+ y+ z+)) ;_位于yz平面第一象限
((and (equal x 0. fuzz) (< y (- fuzz)) (> z fuzz))
(+ z+ y-)
) ;_位于yz平面第二象限
((and (equal x 0. fuzz) (< y (- fuzz)) (< z (- fuzz)))
(+ y- z-)
) ;_位于yz平面第三象限
((and (equal x 0. fuzz) (> y fuzz) (< z (- fuzz)))
(+ z- y+)
) ;_位于yz平面第四象限
((and (> x fuzz) (> y fuzz) (> z fuzz)) (+ x+ y+ z+)) ;_位于第Ⅰ象限
((and (< x (- fuzz)) (> y fuzz) (> z fuzz)) (+ x- y+ z+)) ;_位于第Ⅱ象限
((and (< x (- fuzz)) (< y (- fuzz)) (> z fuzz))
(+ x- y- z+)
) ;_位于第Ⅲ象限
((and (> x fuzz) (< y (- fuzz)) (> z fuzz)) (+ x+ y- z+)) ;_位于第Ⅳ象限
((and (> x fuzz) (> y fuzz) (< z (- fuzz))) (+ x+ y+ z-)) ;_位于第Ⅴ象限
((and (< x (- fuzz)) (> y fuzz)(< z (- fuzz))) (+ x- y+ z-)) ;_位于第Ⅵ象限
((and (< x (- fuzz)) (< y (- fuzz))(< z (- fuzz)))
(+ x- y- z-)
) ;_位于第Ⅶ象限
((and (> x fuzz) (< y (- fuzz)) (< z (- fuzz))) (+ x+ y- z-)) ;_位于第Ⅷ象限
)
)
(setq
lst (mapcar '(lambda (x) (xty-G-PtAtUcs x '(0 0 0) '(1 0 0) 1e-6))
(list '(0 0 0) '(1 0 0) '(-1 0 0) '(0 1 0)
'(0 -1 0) '(0 0 1) '(0 0 -1) '(1 1 0)
'(-1 1 0) '(-1 -1 0) '(1 -1 0) '(1 0 1)
'(-1 0 1) '(-1 0 -1) '(1 0 -1) '(0 1 1)
'(0 -1 1) '(0 -1 -1) '(0 1 -1) '(1 1 1)
'(-1 1 1) '(-1 -1 1) '(1 -1 1) '(1 1 -1)
'(-1 1 -1) '(-1 -1 -1)'(1 -1 -1)
)
)
)
=>(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)
测试代码
(defun c:tt (/ en ent gr loop obj pt pt1 pt2)
(setqen (car (entsel "\n拾取一条直线:"))
ent(entget en)
pt1(cdr (assoc 10 ent))
pt2(cdr (assoc 11 ent))
objnil
loop t
)
(while loop
(setq gr (grread t 15 0)
pt (cadr gr)
gr (car gr)
)
(cond ((= 5 gr)
(if obj
(vla-delete obj)
)
(command "sphere" pt 100)
(setq obj(vlax-ename->vla-object (entlast)))
(vla-put-color obj(xty-G-PtAtUcs pt pt1 pt2 1e-8))
)
((= 3 gr) (setq loop nil))
)
)
)
再举个栗子:D，判断象限有时候还是有用的
(defun c:tt ()
(setqpt0 (getpoint "\n拾取原点:")
pt1 (getpoint "\n拾取x方向点:")
)
(while (setq pt2 (getpoint "\n拾取点:"))
(setq mode (xty-G-PtAtUcs pt2 pt0 pt1 1e-8))
(setq en (entmakex (list '(0 . "text")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt2)
(cons 1 (itoa mode))
(cons 40 100)
(cons 41 0.8)
(cons 7 "standard")
(cons 72 0)
(cons 11 pt2)
(cons 50 0)
(cons 73 0)
(cons 62 mode)
)
)
)
)
)
支持下，希望多发代码给我们学习。 大佬威武！！！！ 向优秀者致敬和学习！
页:
[1]