求高手们帮忙修改一下,增加一个容差
本帖最后由 ysq101 于 2017-12-11 19:20 编辑首先注明:此程序作者BY：LL_sheng
;2017-10-28更新BY：LL_sheng
(defun getcolor(e / c)
(if(setq e(entget e)c(assoc 62 e))
(cdr c)
(cdr(assoc 62(tblsearch"layer"(cdr(assoc 8 e)))))
))
(defun plinexy(e)
(mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
)
(defun Pldir(pt)
(<(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt))0))
(defun c:wt(/ s f i e p pt txt c)
(if(and(setq s(ssget'((0 . "lwpolyline")(-4 . "&")(70 . 1))))
(setq s(vl-remove-if'(lambda(x)(/=(type x)'ename))(mapcar'cadr(ssnamex s)))
f(getfiled "" "" "txt" 1))
(setq txt""f(open f"w")))
(progn
(foreach e s
(foreach i(if(pldir(setq p(plinexy e)))(setq p(reverse p))p)
(if(not(member i pt))(setq pt(append pt(list i))))
(setq txt(strcat(itoa(vl-position i pt))"\n"txt)))
(setq c(getcolor e)
c(cadr(assoc c(append'((1" 0 0 0 0 0 0 276")
(2" 0 0 0 0 0 0 260")
(3" 0 0 0 0 0 0 400")
(4" 0 0 0 1 0 0 384")
(5" 0 0 0 3 0 0 384")
(6" 0 0 25 0 25 0 260")
(7" 0 0 0 2 0 0 384")
(8" 0 0 0 0 0 0 384"))
(list(list c(strcat" 0 0 0 0 0 0 "(itoa c)))))))
txt(strcat"\n"(itoa(length p))c"\n"txt)))
(setq txt(strcat"\n"(itoa(length s))"\n"txt)
i(length pt));;;;
(foreach p(reverse pt)
(entmakex(mapcar'cons'(0 1 10 40 62)(list"text"(itoa i)p 2 1)));;;;
(setq i(1- i)txt(strcat(rtos(car p)2 4)" "(rtos(* -1.5557 (cadr p))2 4)"\n"txt)))
(write-line(strcat(itoa(length pt))"\n\n"txt)f)
(close f))
))
帮忙修改一下,判断各闭合多线段顶点时,
增加容差 差别0.01MM内全按相同点排除
跪谢
(defun getcolor (e / c)
(if (setq e (entget e)
c (assoc 62 e)
)
(cdr c)
(cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 e)))))
)
)
(defun PtFuzz (pt)
(list (atof (rtos (car pt) 2 3))
(atof (rtos (cadr pt) 2 3))
)
)
(defun plinexy (e / ptn)
(setq ptn (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget e)))
(mapcar 'PtFuzz (mapcar 'cdr ptn))
)
(defun Pldir (pt)
(< (apply '+
(mapcar '(lambda (x y) (- (* (car x) (cadr y)) (* (car y) (cadr x))))
(cons (last pt) pt)
pt
)
)
0
)
)
(defun c:tt (/ s f i e p pt txt c)
(princ "\n选择实体: ")
(if (setq s (ssget '((0 . "*polyline") (70 . 1))))
(progn
(setq s (vl-remove-if
'(lambda (x) (/= (type x) 'ename))
(mapcar 'cadr (ssnamex s))
)
f (getfiled "" "" "txt" 1)
txt ""
f (open f "w")
)
(foreach e s
(foreach i (if (pldir (setq p (plinexy e)))
(setq p (reverse p))
p
)
(if (not (member i pt))
(setq pt (append pt (list i)))
)
(setq txt (strcat (itoa (vl-position i pt)) "\n" txt))
)
(setq c (getcolor e)
c (cadr
(assoc c
(append '((1 " 0 0 0 0 0 0 276")
(2 " 0 0 0 0 0 0 260")
(3 " 0 0 0 0 0 0 400")
(4 " 0 0 0 1 0 0 384")
(5 " 0 0 0 3 0 0 384")
(6 " 0 0 25 0 25 0 260")
(7 " 0 0 0 2 0 0 384")
(8 " 0 0 0 0 0 0 384")
)
(list (list c (strcat " 0 0 0 0 0 0 " (itoa c))))
)
)
)
txt (strcat "\n" (itoa (length p)) c "\n" txt)
)
)
(setq txt (strcat "\n" (itoa (length s)) "\n" txt)
i (length pt)
)
(foreach p (reverse pt)
(entmakex
(mapcar 'cons '(0 1 10 40 62) (list "text" (itoa i) p 2 1))
)
(setq i (1- i)
txt (strcat (rtos (car p) 2 4)
" "
(rtos (* -1.5557 (cadr p)) 2 4)
"\n"
txt
)
)
)
(write-line (strcat (itoa (length pt)) "\n\n" txt) f)
(close f)
)
)
(princ)
) 符上图片和在测试文件
问题在
(if (not (member i pt)) 和
(setq txt (strcat (itoa (vl-position i pt)) "\n" txt))
两句上，member 和vl-position两个函数不支持容差，要解决这个问题恐怕要改写整个数据结构，感觉非常复杂
或者能否对点数据进行一定规则的圆整，使得一定范围内的点合并成一个点，但貌似没有很可靠的算法。 vectra 发表于 2017-12-11 21:54
问题在
(if (not (member i pt)) 和
(setq txt (strcat (itoa (vl-position i pt)) "\n" txt))
数据可以取整的...没多大影响
求帮修改一下 xyp1964 发表于 2017-12-12 00:25
院长出手果然牛B。。。。
问题完美解决。。
谢谢大师~~~~ xyp1964 发表于 2017-12-12 00:25
院长出手果然牛B。。。。
问题完美解决。。
谢谢大师~~~~ xyp1964 发表于 2017-12-11 19:18
今天实测了一下，还是会间歇性出现同样的BUG
按说我改了这个精度参数，X轴座标输出的应该是1位点数才对。
但还是输出了4位小数，
Y轴因为*1.5557的原因。输出4位小数是正常的
(atof (rtos (car pt) 2 1))
可能后面的函数不取用你取整后的 座标点？ xyp1964 发表于 2017-12-11 19:18
问题已经解决了。。。竟然是我打包一起的子程序重名了。。。
页:
[1]