【函数分享】“判断点是否在屏幕内”与 “给起点、终点、数量--定数等分线段得点表”
本帖最后由 wowan1314 于 2013-6-19 14:31 编辑最近做的两个函数。希望对你有用。
1、判断点是否在屏幕内
其中pt点为UCS下的点坐标。该函数适用正斜ucs及正斜wcs下的2D情况。3D的情况没测试。;;==================={ 判断点是否在屏幕内 }============
;;格式(YY-ptinview pt)--在T,不在nil---BY wowan1314
;;测试:(YY-ptinview (GETPOINT))
(defun YY-ptinview (pt / a b c d x)
(setq b (getvar "viewsize")
c (car (getvar "screensize"))
d (cadr (getvar "screensize"))
a (* b (/ c d))
x (trans (getvar "viewctr") 1 2)
c (list (- (car x)(* a 0.5)) (- (cadr x) (* b 0.5)) 0.0)
d (list (+ (car x) (* a 0.5)) (+ (cadr x) (* b 0.5)) 0.0)
a (MAPCAR '<= C (TRANS PT 1 2) D)
)
(AND(CAR A)(CADR A))
)2、给定起点、终点、数量--------定数等分线段，得点表
该函数算是向量的基本运用吧。;;给定起点、终点、数量--------定数等分线段，得点表
;;调用: (YY-np1p2 P1 P2 N)----- BY wowan1314
;;返回值:点表 按据第一个参数P1由近及远的有序点表。
;; 如：(P11 P12 P13 . . .) 不包括起点终点
;; P1 P2 (2D 3D坐标)N (大于1的正整数)N=2就是求两点中点函数。
(defun YY-np1p2(p1 p2 n / v m plst)
(setqm 0 v (mapcar '(lambda (x y) (/ (- x y) n)) P2 P1) n (1- n))
(while (< m n)
(setq m (1+ m)
plst (cons (mapcar '(lambda(x y)(- x (* m y))) p2 v) plst)
)
)
) 沙了个发~~~ 支持，分享源就要顶! 谢谢楼主分享源码 大师对程序的看法很有独到的眼光啊
谢谢楼主分享源码 本帖最后由 wowan1314 于 2013-7-25 18:57 编辑
;============{ 在指定位置删除或插入元素 }===============
;nil表示要删除。如果有值为要插入的元素---by wowan1314
;(t11 '(1 2 3 4 5 6) 2 0);;->(1 2 0 3 4 5 6)
;(t11 '(1 2 3 4 5 6) 2 nil);;->(1 2 4 5 6)
;2013年7月20日 星期六
(defun t11 (lst pos mod / qlst a hlst)
(setq a -1)
(setq hlst (vl-member-if-not
'(lambda(x)
(setq a (1+ a))
(if (= a pos) nil
(setq qlst (cons x qlst))
)
)
lst
)
)
(if mod
(apply 'append (list (reverse(cons mod qlst)) hlst))
(apply 'append (list (reverse qlst) (cdr hlst)))
)
)瞎玩下;按新的点对表修改组码表更新图元
(defun t1 (en xin / enb)
(setq enb (entget en))
(mapcar '(lambda(x)
(entmod(subst x (assoc (car x) enb)enb))
)
xin
)
)
;表中两个两个配对后的表
(defun t3 (lst / a)
(setq a 0)
(vl-remove-if '(lambda(x)(= (rem (setq a (1+ a))2)0))
(mapcar 'cons lst (cdr lst))
)
)
;得到表的奇偶项
;(T2 LST T)奇数项。(T2 LST NIL)为偶数
(defun t2 (lst b / a)
(setq a 0
c '(lambda(x)(= (rem (setq a (1+ a))2)0))
)
(if b
(vl-remove-if c lst)
(vl-remove-if-not c lst)
)
);选择集变图元名表
(defun t1 (ss)
(cdr(reverse(mapcar 'cadr (ssnamex (ssget))
)
)
)
)
;选择集变图元名表
(defun t2 (ss / a en lst)
(setq a -1)
(while (setq en (ssname ss (setq a (1+ a))
)
)
(setq lst (cons en lst))
)
lst
)
;图元名表变选择集
(defun t3 (lst / ss)
(setq ss (ssadd))
(mapcar '(lambda(x)(setq ss (cons x ss)))lst)
ss
)
;dxf_read 按值或值表读取组码表
(defun dxf_read (a en / enb)
(setq enb (entget en))
(if (= 'list (type a))
(mapcar '(lambda(x)(cdr(assoc x enb))) a)
(cdr(assoc a enb))
)
);删除相应组码
(defun t1 (lst1 lst)
(vl-remove-if '(lambda(x)(member x lst1)) lst)
)
;删除相应组码只删第一个
(defun t2 (lst1 lst / lst2)
(vl-remove-if '(lambda(x)
(if
(and(member x lst1)(not(member x lst2))
)
(setq lst2 (cons x lst2))
)
)
lst
)
)
;替换组码表，如果没有就加到最后
(defun t3 (lst1 lst / old)
(mapcar
'(lambda(x)
(if (setq old (assoc (car x) lst))
(setq lst (subst x old lst))
(setq lst (cons x (reverse lst))
)
)
)
lst1
)
lst
)
;从指定位置a截取指定长度b的表
(defun t4 (lst a b / i c xlst)
(setq i -1 c (1-(+ a b)))
(vl-member-if
'(lambda(x)
(setq i (1+ i))
(if (<= a i c)
(setq xlst (cons x xlst))
)
(if (> i c)
t
)
)
lst
)
xlst
)
;分解表内套的表
(defun t5 (lst )
(mapcar '(lambda(x)(if (listp x)(setq lst2 (t5 x))(setq lst2 (cons x lst2))))lst)
lst2
);单个图元包围盒
(defun enbox (ename / ll ur)
(vla-getboundingbox (vlax-ename->vla-object ename) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)
;选择集包围盒1
(defun t12 (ss / enma enmi a en ll ur)
(setq a -1)
(while
(setq en (ssname ss (setq a (1+ a))
)
)
(setq entb (enbox en)
enma (cons (car entb) enma)
enmi (cons (cadr entb) enmi)
)
)
(mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(max min) (list enma enmi))
)
;选择集包围盒2
(defun t11 (ss / a en enma enmi ll ur)
(setq a -1)
(while
(setq en (ssname ss (setq a (1+ a))
)
)
(vla-getboundingbox (vlax-ename->vla-object en) 'll 'ur)
(setq enma (cons (vlax-safearray->list ll) enma)
enmi (cons (vlax-safearray->list ur) enmi)
)
)
(mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(max min) (list enma enmi))
)
;图元名表包围盒
(defun t13 (sslst / enma enmi ll ur)
(mapcar
'(lambda(x)
(vla-getboundingbox (vlax-ename->vla-object x) 'll 'ur)
(setq enma (cons (vlax-safearray->list ll) enma)
enmi (cons (vlax-safearray->list ur) enmi)
)
)
sslst
)
(mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(max min) (list enma enmi))
)3/分隔字符串---高飞鸟的 ==该代码不适合处理字符串中带空格的字符。(defun split (string del / str)
(setq str (vl-string-translate del " " string))
(mapcar 'vl-princ-to-string (read (strcat "(" str ")")))
)1、三点确定ARC的圆心、半径;|
=============={三点求ARC:圆心+半径}============
三点求ARC的圆心、半径。返回值:(圆心坐标 半径) 、nil表示三点共线
(YY-3arc P1 P2 P3) BY wowan1314
2013年7月16日 星期二
============================================
|;
(defun YY-3arc (p1 p2 p3 / z1 z2 yxin)
(setq z1 (car (YY-np1p2 p1 p2 2))
z2 (car (YY-np1p2 p1 p3 2))
)
(if
(setq yxin (inters
z1 (polar z1 (+ (angle p1 p2)(* pi 0.5)) 0.1)
z2 (polar z2 (+ (angle p1 p3)(* pi 0.5)) 0.1)
nil
)
)
(list yxin (distance yxin p1))
)
)2、分隔字符串按分隔符分解字符串成表.
(defun t11 (str del / pos lst)
(while
(setq pos (vl-string-search del str))
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ 1 pos (strlen del))
)
)
)
(reverse(cons str lst))
) 本帖最后由 wowan1314 于 2013-7-27 13:04 编辑
瞎玩！;中点函数
(defun t1 (p1 p2)
(mapcar '(lambda(a b) (* 0.5 (+ a b))) p1 p2)
)
(defun t2 (p1 p2)
(mapcar '* (mapcar '+ p1 p2)'(0.5 0.5 0.5))
)
;;消除字符串中的空格
(defun t11 (str)
(apply
'strcat
(mapcar
'vl-princ-to-string
(read
(strcat "(" str ")")
)
)
)
)
;;消除字符串中的空格
(defun t12 (str)
(while
(> (strlen str)
(strlen
(setq str (vl-string-subst "" " " str))
)
)
)
str
);求字符串表 或 数表中 最大的数 或最长的字符串
(defun t11 (lst)
(if (= (type (car lst)) 'str)
(cdr
(assoc
(apply
'max
(mapcar
'(lambda(x)
(strlen x)
)
lst
)
)
(mapcar
'(lambda(x)
(list (strlen x) x)
)
lst
)
)
)
(apply 'max lst)
)
);图元之后所有图元组成的选择集
(defun t12 (en / ss)
(setq ss (ssadd))
(while
(setq en (entnext en))
(if (member
(cdr (assoc 0 (entget en))
)
'("attrib" "vertex" "seqend")
)
nil
(setq ss (ssadd en ss))
)
)
ss
)
;;图元之后所有图元的表
(defun t11 (en / lst)
(while
(setq en (entnext en))
(if (member
(cdr (assoc 0 (entget en))
)
'("attrib" "vertex" "seqend")
)
nil
(setq lst (cons en lst))
)
)
lst
); (t11 '("1" "2" "3" "4" "5" "6") ":")
;==> "1:2:3:4:5:6"
(defun t11 (lst del)
(vl-string-right-trim
del
(apply
'strcat
(mapcar
'(lambda
(
x
)
(strcat
x
del
)
)
lst
)
)
)
);将字符串表合并为按指定分隔符分隔的字符串
; (t11 '("1" "2" "3" "4" "5" "6") ":")
;==> "1:2:3:4:5:6"
(defun t11 (lst del / ss lst p1 p2 p3)
(vl-string-right-trim
del
(eval
(cons 'strcat
(mapcar
'(lambda(x)
(strcat x del)
)
lst
)
)
)
)
);计算点集中距离原点 （最大 最小）
(defun t11 (plst)
(setq lst (vl-sort lst '(lambda(a b) (> (distance a '(0 0 0)) (distance b '(0 0 0)) ))
)
)
(list (car lst)(last lst))
)
;计算点集围成的包围盒的 对角点
(defun t12 (plst)
(mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(min max) (list lst lst))
)
;计算实数表中 最大 最小值
(defun t13 (plst)
(mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(min max) (list lst lst))
);;等分表，没考虑表的顺序。
(defun t1 (n lst / a ll zll)
(setq a 1)
(mapcar
'(lambda(x)
(if (< a n)
(setq ll (cons x ll) a (1+ a))
(setq zll (cons (cons x a) zll)
ll nil
a 1
)
)
)
lst
)
(if ll (cons ll zll) zll)
);;用新项替换表中的旧项，只替换第一个。
(defun t2 (new old lst)
(read(apply 'vl-string-subst (mapcar 'vl-princ-to-string (list new old lst))))
);;点集按pl线的pl起点到点到曲线的最近点的距离排序
;;pl为vla实体. 返回排序后的点表
(defun t11 (pl pts)
(mapcar
'cadr
(vl-sort
(mapcar
'(lambda (x)
(list (vlax-curve-getdistatpoint
pl
(vlax-curve-getclosestpointto pl x)
)
x
)
)
pts
)
'(lambda (a b)
(< (car a) (car b))
)
)
)
);;得到表中重复次数 及 删除重复后的表
;; (t1 '(1 2 1 2 (1 1) (1 2) (1 2) 1 2))
(defun t1 (lst / lst1 lst2)
(mapcar
'(lambda(x)
(if (member x lst2)
(setq lst1 (cons x lst1))
(setq lst2 (cons x lst2))
)
)
lst
)
(list (length lst1) lst2)
);;=============={ 返回表m-n之间的所有元素 }===============
;;测试: (T66 3 5 '(2334 556 33 44 66 77 22))==> (33 44 66)
(DEFUN T66 (n m LST / A)
(setq A 0)
(vl-remove-if-not '(lambda(x)(setq A (1+ A)) (<= n A m) ) lst)
);;=============={ 返回表第N个元素之前的所有元素 }===================
;;测试: (T2 3 '(2334 556 33 44 66 77 22))==> (2334 556 33)
(DEFUN T2 (n lst / m NEW)
(setq m 0)
(WHILE (< M N)
(SETQ NEW (CONS (CAR LST) NEW) LST (CDR LST) m (1+ m))
)
(REverse NEW)
)
;;=============={ 返回表第N个元素之前的所有元素 }===================
;;测试: (T1 3 '(2334 556 33 44 66 77 22))==> (2334 556 33)
(DEFUN T1 (n lst / m)
(setq m 0)
(vl-remove-if '(lambda(x)(setq m (1+ m))(< n m) ) lst)
);;=============={ 用member的话，对于有重复元素的表是不行的 }===================
;;测试: (T3 3 '(2334 556 33 44 66 77 22))==> (44 66 77 22)
(DEFUN T3 (n lst)
(setq n (nth n lst))
(member n lst)
)
;;=============={ 返回表第N个元素之后的所有元素 }===================
;;测试: (T31 3'(2334 556 33 44 66 77 22))==> (44 66 77 22)
(DEFUN T31 (n LST / A)
(setq A 0)
(vl-member-if '(lambda(x)(setq A (1+ A)) (< n A) ) lst)
)
;;=============={ 返回表第N个元素之后的所有元素 }===================
;;测试: (T32 3'(2334 556 33 44 66 77 22))==> (44 66 77 22)
(DEFUN T32 (n LST / A)
(setq A 0)
(vl-remove-if '(lambda(x)(setq A (1+ A)) (<= A n) ) lst)
)
;;=============={ 返回表第N个元素之后的所有元素 }===================
;;测试: (T33 3'(2334 556 33 44 66 77 22))==> (44 66 77 22)
(DEFUN T33 (n LST / A)
(setq A 0)
(vl-catch-all-apply
'mapcar
(LIST '(lambda (x)
(SETQ A (1+ A))
(if (< N A)
(EXIT)
(setq lst (cdr lst))
)
)
lst
)
)
lst
)
;;=============={ 返回表第N个元素之后的所有元素(最优版) }=================
;;测试: (T6 3'(2334 556 33 44 66 77 22))==> (44 66 77 22)
(DEFUN T6 (n LST / A NLST L)
(setq A 0 L (LENGTH LST))
(IF (< N (* L 0.65))
(SETQ NLST (vl-member-if '(lambda(x)(setq A (1+ A)) (< n A) ) lst))
(vl-member-if '(lambda(x)(SETQ L (1- L) Nlst (CONS X NLST)) (<= L N) ) (reverse lst))
)
NLST
);vl-position返回第一个元素出现的索引位置
;这个函数返回元素出现的所有索引位置
(defun t11 (at lst / a nlst)
(setq a 0)
(mapcar '(lambda(x)(and(eq x at)(setq nlst(cons a nlst)))(setq a(1+ a))) lst)
(reverse nlst)
;TEXT的四个交点坐标
(defun t11 (ent / p0 p12 ang lst)
(setq ent (entget ent)
p0 (cdr (assoc 10 ent))
ang (cdr (assoc 50 ent))
p12 (textbox ent)
lst
(list
(car p12)
(list (caar p12)(cadadr p12))
(cadr p12)
(list (caadr p12)(cadar p12))
)
)
(mapcar '(lambda(x)(polar p0 (+ ang (angle '(0 0) x)) (distance '(0 0) x))) lst)
);;给定起点、终点、数量--------定数等分线段，得点表
;;调用: (YY-np1p2 P1 P2 N)----- BY wowan1314
;;返回值:点表 按据第一个参数P1由近及远的有序点表。
;; 如：(P1 P11 P12 P13 . . . P2) 包括起点终点
(defun YY-np1p2X(p1 p2 n / v m plst)
(setq v (mapcar '(lambda (x y) (/ (- x y) n)) P2 P1) plst (cons p2 plst) )
(repeat n
(setq plst (cons (mapcar '- (car plst) v) plst))
)
)用正则也许更简单！;得到文字内容
(defun gps->txt-getvalue1 (ename)
(cdr(assoc 1 (entget enmae))
)
)
;设置文字内容
(defun gps->txt-setvalue1 (ename val)
(entmod(subst (cons 1 val)(assoc 1 (entget enmae)) (entget enmae))
)
)
; 得到带数字后缀的字符串的 (文字前缀、数字后缀、小数点位数)
(defun t11 (txt1 / nums lop a1 txt len a2)
(setq nums '(49 50 51 52 53 54 55 56 57 48 43 45 46)
lop t
a1 0
txt (reverse(vl-string->list txt1))
)
(while lop
(if (member (car txt) nums)
(progn
(if (= (car txt) 46) (setq a2 a1))
(setq a1 (1+ a1) txt (cdr txt))
)
(setq lop nil)
)
)
(if (/= a1 0)
(progn
(setq len (- (strlen txt1) a1))
(list (substr txt1 1 len) (substr txt1 (1+ len)) a2)
)
)
) 太好了，这么多能用函数 非常感谢 很好，多谢楼主分享。
页:
[1]
2