[原创]比较两多义线图元是否相同

torcky 发表于 2005-2-10 15:37:00

(defun c:w2(/ a1 a2 a1ent a2ent aa1 aa2 a1list a2list templist a1dist a2dist a1distpo-list a1distpo-list-sort maxlist1 a2distpo-list a2distpo-list-sort maxlist2 equalflag copya1 transmat copya1list copya1bulge a2list-1 complist xatom n sum e2 e1 i pos xcom ycom bcom a2bulge copya1list copya1bulge complist) (setvar "cmdecho" 0) (setq a1 (car(entsel))) (setq a2 (car(entsel))) (setq a1ent (entget a1)) (setq a2ent (entget a2)) (command "area" "o" a1) (setq aa1 (getvar "area")) (command "area" "o" a2) (setq aa2 (getvar "area")) (setq equalflag nil) (if (equal aa1 aa2 0.00001);比较面积 (if (= (cdr (assoc 0 a1ent)) (cdr (assoc 0 a2ent)));比较图元类别 (if (= (cdr (assoc 90 a1ent)) (cdr (assoc 90 a2ent)));比较节点数 (if (= (cdr (assoc 70 a1ent)) (cdr (assoc 70 a2ent)));比较封闭性 (progn (setq a1list (vex a1ent)) (setq a1bulge (getbulge a1ent)) (setq templist (append (cdr a1list) (list(car a1list)))) (setq a1dist (mapcar 'distance a1list templist)) (setq a1distpo-list (mapcar 'list a1dist a1list templist)) (setq a1distpo-list-sort (vl-sort a1distpo-list (function (lambda (e1 e2) (> (car e1)(car e2)))))) (setq maxlist1(getmax a1distpo-list-sort)) (setq a2list (vex a2ent)) (setq a2bulge (getbulge a2ent)) (setq templist (append (cdr a2list) (list(car a2list)))) (setq a2dist (mapcar 'distance a2list templist)) (setq a2distpo-list (mapcar 'list a2dist a2list templist)) (setq a2distpo-list-sort (vl-sort a2distpo-list (function (lambda (e1 e2) (> (car e1)(car e2)))))) (setq maxlist2(getmax a2distpo-list-sort)) (setq i 0) (while (and (not equalflag) ( (setq copya1(vla-copy (vlax-ename->vla-object a1))) (setq transmat(fox_align (cdr(car maxlist1)) (cdr(nth i maxlist2)))) ;;; (setq transmat(fox_align (cdr(nth i maxlist1)) (cdr(nth i maxlist2)))) (vla-transformby copya1 transmat) (setq copya1list (vex (entget(vlax-vla-object->ename copya1)))) (setq copya1bulge (getbulge (entget(vlax-vla-object->ename copya1)))) (setq a2list-1(list (fix(* 10000(car(car a2list)))) (fix(* 10000(cadr(car a2list)))))) (setq complist (mapcar '(lambda (xatom) (list (fix(* 10000(car xatom))) (fix(* 10000(cadr xatom))))) copya1list)) (if (setq pos(vl-position a2list-1 complist)) (repeat pos (setq copya1list (append (cdr copya1list) (list(car copya1list)))) (setq copya1bulge (append (cdr copya1bulge) (list(car copya1bulge)))) ) ) (setq sum 0) (setq xcom(foreach n (mapcar '- (mapcar 'car copya1list)(mapcar 'car a2list)) (setq sum(+ sum (abs n))))) (setq sum 0) (setq ycom(foreach n (mapcar '- (mapcar 'cadr copya1list)(mapcar 'cadr a2list)) (setq sum(+ sum (abs n))))) (setq sum 0) (setq bcom(foreach n (mapcar '- a2bulge copya1bulge) (setq sum(+ sum (abs n))))) (if (and (equal 0 xcom 0.0000001)(equal 0 ycom 0.0000001)(equal 0 bcom 0.0000001)) (setq equalflag 't)) (vla-delete copya1) (setq i (1+ i)) ) ) ) ) ) ) (princ equalflag) (princ ) ) (defun getbulge(ent / i entlist ent);得到凸度列表 (setq i 0 entlist '()) (while ( (if (= 42 (car (nth i ent))) (setq entlist (cons (cdr(nth i ent))entlist)) ) (setq i (1+ i)) ) (reverse entlist) )

(defun vex(ent / i entlist ent);得到节点列表 (setq i 0 entlist '()) (while ( (if (= 10 (car (nth i ent))) (setq entlist (cons (cdr(nth i ent))entlist)) ) (setq i (1+ i)) ) (reverse entlist) )

(defun getmax (list-sort / maxlista kl maxlist);得到最大边列表 (setq maxlista (car list-sort) maxlist '()) (setq kl 't) (while (and kl list-sort) (setq list-sort (cdr list-sort)) (if (equal (car maxlista) (car(car list-sort)) 0.0001) (progn (setq maxlist (cons maxlista maxlist)) (setq maxlista (car list-sort)) ) (progn (setq maxlist (cons maxlista maxlist)) (setq kl nil) ) ) ) maxlist )

(defun fox_align(a1-p2 a2-p2 / delta-ang mx my sum transmat);得到两图元的转换矩阵 (setq sum 0) (setq a1-po1 (car a1-p2)) (setq a1-po2 (cadr a1-p2)) (setq a2-po1 (car a2-p2)) (setq a2-po2 (cadr a2-p2)) (setq delta-ang(- (angle a2-po1 a2-po2) (angle a1-po1 a1-po2))) (setq mx (-(car a2-po2)(foreach n (mapcar '* (list (cos delta-ang) (- 0 (sin delta-ang)) 0) a1-po2) (setq sum(+ sum n))))) (setq sum 0) (setq my (-(cadr a2-po2)(foreach n (mapcar '* (list (sin delta-ang) (cos delta-ang) 0) a1-po2) (setq sum(+ sum n))))) (setq transmat (vlax-make-safearray vlax-vbdouble '(0 . 3) '(0 . 3))) (vlax-safearray-fill transmat (list(list (cos delta-ang) (- 0 (sin delta-ang)) 0 mx) (list (sin delta-ang) (cos delta-ang) 0 my) '(0 0 1 0) '(0 0 0 1)) ) transmat )

torcky 发表于 2005-2-18 20:32:00

两多义线图元若相同函数返回T，否则返回Nil

HuaiYu 发表于 2005-7-10 20:52:00

太好了，很好的东东，

我要好好看看

你是不是传说中的TJZ啊?

HuaiYu 发表于 2005-7-17 22:07:00

(defun c:ww (/ en_a en_b aa a1 bb b1 a_clock b_clock)   (setq en_a (car (entsel "\n Please select a lwpolyline object a:  "))  en_b (car (entsel "\n Please select a lwpolyline object b:  "))   ) ;_ Endsetq   (princ "*********")   (setq a (get_data en_a))   (setq b (get_data en_b))   (setq aa (get_list (car a))  a1 (cadr a)   ;a1=the list of bulge a  a1 (mapcar '(lambda (x) (rtos x 2 4)) a1)  a1 (mapcar '(lambda (x) (atof x)) a1)   ) ;_ Endsetq   (setq bb (get_list (car b))  b1 (cadr b)   ; b1= the list of bulge b  b1 (mapcar '(lambda (x) (rtos x 2 4)) b1)  b1 (mapcar '(lambda (x) (atof x)) b1)   ) ;_ Endsetq   (setq a_clock (get_clock aa))  ; 0-clock 1-counterclock ; 0 抖皐  1 は皐   (setq b_clock (get_clock bb))   (if (equal a_clock b_clock)  ; if the same clock     (progn ;;judge the dist-----angle     (if (not (equal aa bb))       (setq bb (compare aa bb))     ) ;_ Endif     ;;judge the bulge     (if (not (equal a1 b1))       (setq b1 (compare a1 b1))     ) ;_ Endif     ) ;_ Endprogn     ;; if not the same clock     (progn ;;judge the dist----angle     (setq bb (get_list (reverse (car b))))     (if (not (equal aa bb))       (setq bb (compare aa bb))     ) ;_ Endif     ;;judge the bulge     (setq b1 (reverse (mapcar '(lambda (x) (- 0 x)) b1)))     (if (not (equal a1 b1))       (setq b1 (compare a1 b1))     ) ;_ Endif     ) ;_ Endprogn   ) ;_ Endif   ;; if dist--angle same and list-bulge then alert ok else alert no   (if (and (equal aa bb) (equal a1 b1))     (alert "OK")     (alert "NO")   ) ;_ Endif   (prin1) ) ;_ Enddefun ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compare (aa bb / flag i bb1)   (setq flag 1  i 0   ) ;_ Endsetq   (while (= flag 1)     (setq bb1 (append (cdr bb) (list (car bb))))     (setq i (1+ i))     (if (equal aa bb1)       (setq flag 0)       (setq bb bb1)     ) ;_ Endif     (if (= i (length aa))       (setq flag 0)     ) ;_ Endif   ) ;_ Endwhile   bb1 ) ;_ Enddefun ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun get_list (pt1 / list_d list_b i p_i p_i1 p_i2 dist ang21 ang10 ang)   (setq list_d '()  list_b '()  i      0  pt1    (append pt1 (list (car pt1)) (list (cadr pt1)))   ) ;_ Endsetq   (repeat (- (length pt1) 2)     (setq p_i  (nth i pt1)    p_i1  (nth (+ i 1) pt1)    p_i2  (nth (+ i 2) pt1)    dist  (distance p_i1 p_i)    ang21  (angle p_i1 p_i2)    ang10  (angle p_i1 p_i)    ang  (- ang10 ang21)    ang  (angtos ang 0 4)    ang  (atof ang)    dist  (rtos dist 2 4)    dist  (atof dist)    list_d (append list_d (list (list dist ang)))    i  (1+ i)     ) ;_ Endsetq   ) ;_ Endrepeat   list_d ) ;_ Enddefun ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun get_data (en / list_pt list_b en_data i en_i)   (setq list_pt '()  list_b '()  en_data (entget en)  i 0   ) ;_ Endsetq   (repeat (length en_data)     (setq en_i (nth i en_data))     (if (= (car en_i) 10)       (progn ;;; (getint "\n PLease press any key to continue: ") ;;; (command "circle" (cdr en_i) 3)       (setq list_pt (append list_pt (list (cdr en_i)))      list_b  (append list_b (list (cdr (nth (+ i 3) en_data))))       ) ;_ Endsetq       ) ;_ Endprogn     ) ;_ Endif     (setq i (1+ i))   ) ;_ Endrepeat   (list list_pt list_b) ) ;_ Enddefun ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun get_clock (cc / k)   (setq k 0)   (foreach n cc     (if (> (cadr n) 180)       (setq k (1+ k))     ) ;_ Endif   ) ;_ Endforeach   (if (> k (/ (length cc) 2))  ; 0 抖皐  1 は皐     0     1   ) ;_ Endif ) ;_ Enddefun

HuaiYu 发表于 2005-7-17 22:08:00

唐，看看我的

torcky 发表于 2005-7-19 17:14:00

今天下午研究了一下<A name=45694>HuaiYu</A>君的大作，厉害！！
 比拙作简洁缜密，佩服！！！

洋葱老爹 发表于 2005-8-1 13:40:00

L看不太懂,有vba的就好啦......期待中!!!

舟自横 发表于 2005-9-25 09:07:00

本帖最后由作者于 2005-9-25 9:28:22 编辑 其实用不了这么麻烦..
单就复线而言只要判断顶点的增量坐标(相对坐标列表,即后一点相对于前一点的坐标增量)是否一致.并且凸度列表一致就可以了..
判断很多也是没有意义的看一下这段
(defun hy_samepoly(en1 en2);;t nil相同返回T不同返回NIL    (if (and (equal (mapcar '(lambda(x y) (list (- (car y) (car x)) (- (cadr y) (cadr x))))         (massoc 10 (entget en1)) (append (cdr (massoc 10 (entget en1)))       (list (car (massoc 10 (entget en1))))))      (mapcar '(lambda(x y) (list (- (car y) (car x)) (- (cadr y) (cadr x))))         (massoc 10 (entget en2)) (append (cdr (massoc 10 (entget en2)))       (list (car (massoc 10 (entget en2)))))) 0.000001)      (equal (massoc 42 (entget en1)) (massoc 42 (entget en2)) 0.000001)      )      t nil)
)
(defun massoc (key alist / x nlist)   (foreach x alist     (if (eq key (car x))       (setq nlist (cons (cdr x) nlist))       )     )    )

无痕发表于 2005-10-8 00:32:00

怎么随便拿两个不同形状的多义线也返回T？？
知道了：(defun massoc (key alist / x nlist)
(foreach x alist
(if (eq key (car x))
(setq nlist (cons (cdr x) nlist))
)
)nlist
)

无痕发表于 2005-10-8 01:19:00

(defun c:tt2 (/ l1 l2 vs1 vs2 bg1 bg2 v b)
(setq e1 (car(entsel))
e2 (car(entsel))
l1 (entget e1)
l2 (entget e2)
)
(setq vs1 (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= 10 (car x))) l1))
vs2 (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= 10 (car x))) l2))
bg1 (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= 42 (car x))) l1))
bg2 (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= 42 (car x))) l2))
v (mapcar '(lambda(x y)(mapcar '- x y)) vs1 vs2)
b (mapcar '- bg1 bg2))
(and (apply '= (mapcar 'car v))
(apply '= (mapcar 'cadr v))
(apply '= (cons 0 b)))
)

页: [1] 2

明经CAD社区's Archiver

[原创]比较两多义线图元是否相同